From 270b4cfab473175ae556ffeeadfec87cd0b31096 Mon Sep 17 00:00:00 2001 From: RobertPincus Date: Tue, 21 May 2024 02:50:43 +0000 Subject: [PATCH] =?UTF-8?q?Deploying=20to=20gh-pages=20from=20@=20earth-sy?= =?UTF-8?q?stem-radiation/rte-rrtmgp@d287ae5b10fa4de5e0e3a92a268b5415b5882?= =?UTF-8?q?908=20=F0=9F=9A=80?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- assets/main.css.map | 8 +- explanations/index.html | 2 +- feed.xml | 2 +- how-tos/build-and-test.html | 2 +- how-tos/index.html | 2 +- index.html | 2 +- reference/index.html | 2 +- .../rrtmgp-fortran-interface/lists/files.html | 20 +- .../lists/modules.html | 300 +- .../rrtmgp-fortran-interface/lists/types.html | 52 +- .../mo_aerosol_optics_rrtmgp_merra.html | 56 +- .../module/mo_cloud_optics_rrtmgp.html | 58 +- .../module/mo_gas_optics_rrtmgp.html | 164 +- .../mo_cloud_optics_rrtmgp.f90.html | 2 +- .../sourcefile/mo_gas_optics_rrtmgp.f90.html | 3587 +++++++++-------- .../src/mo_gas_optics_rrtmgp.F90 | 77 +- .../tipuesearch/tipuesearch_content.js | 2 +- .../type/ty_aerosol_optics_rrtmgp_merra.html | 14 +- .../type/ty_cloud_optics_rrtmgp.html | 14 +- .../type/ty_gas_optics_rrtmgp.html | 14 +- reference/rrtmgp-kernels/index.html | 10 +- .../interface/compute_planck_source.html | 358 ++ .../interface/compute_tau_absorption.html | 436 ++ .../interface/compute_tau_rayleigh.html | 304 ++ .../interface/interpolation.html | 334 ++ reference/rrtmgp-kernels/lists/files.html | 199 + reference/rrtmgp-kernels/lists/modules.html | 47 +- .../rrtmgp-kernels/lists/procedures.html | 98 +- .../module/mo_gas_optics_rrtmgp_kernels.html | 28 +- .../mo_gas_optics_rrtmgp_kernels~2.html | 1089 +++++ .../proc/compute_planck_source.html | 30 +- .../proc/compute_tau_absorption.html | 6 +- .../proc/compute_tau_rayleigh.html | 6 +- .../rrtmgp-kernels/proc/interpolation.html | 6 +- reference/rrtmgp-kernels/search.html | 4 +- .../mo_gas_optics_rrtmgp_kernels.f90.html | 384 +- .../mo_gas_optics_rrtmgp_kernels.f90~2.html | 452 +++ .../src/mo_gas_optics_rrtmgp_kernels.F90 | 976 +---- .../tipuesearch/tipuesearch_content.js | 2 +- .../rte-fortran-interface/lists/files.html | 244 +- .../rte-fortran-interface/lists/modules.html | 370 +- .../lists/procedures.html | 124 +- .../rte-fortran-interface/lists/types.html | 132 +- .../module/mo_fluxes.html | 176 +- .../module/mo_optical_props.html | 116 +- .../module/mo_rte_config.html | 159 +- .../module/mo_rte_kind.html | 292 +- .../module/mo_rte_lw.html | 330 +- .../module/mo_rte_sw.html | 202 +- .../module/mo_source_functions.html | 65 +- .../rte-fortran-interface/proc/rte_lw.html | 56 +- .../sourcefile/mo_fluxes.f90.html | 6 +- .../sourcefile/mo_optical_props.f90.html | 104 +- .../sourcefile/mo_rte_config.f90.html | 157 +- .../sourcefile/mo_rte_kind.f90.html | 220 +- .../sourcefile/mo_rte_lw.f90.html | 843 ++-- .../sourcefile/mo_rte_sw.f90.html | 138 +- .../mo_rte_util_array_validation.f90.html | 157 +- .../sourcefile/mo_source_functions.f90.html | 502 ++- .../rte-fortran-interface/src/mo_rte_lw.F90 | 37 +- .../rte-fortran-interface/src/mo_rte_sw.F90 | 2 +- .../src/mo_source_functions.F90 | 20 +- .../tipuesearch/tipuesearch_content.js | 2 +- .../rte-fortran-interface/type/ty_fluxes.html | 2 +- .../type/ty_optical_props.html | 6 +- .../type/ty_optical_props_2str.html | 2 +- .../type/ty_optical_props_arry.html | 6 +- .../type/ty_optical_props_nstr.html | 2 +- .../type/ty_source_func_lw.html | 17 +- reference/rte-kernels/index.html | 12 +- .../interface/delta_scale_2str_kernel.html | 2 +- .../interface/delta_scale_2str_kernel~2.html | 310 ++ .../rte-kernels/interface/extract_subset.html | 6 +- .../interface/extract_subset~2.html | 387 ++ .../inc_1scalar_by_1scalar_bybnd.html | 228 ++ .../inc_1scalar_by_2stream_bybnd.html | 234 ++ .../inc_1scalar_by_nstream_bybnd.html | 234 ++ .../inc_2stream_by_1scalar_bybnd.html | 234 ++ .../inc_2stream_by_2stream_bybnd.html | 252 ++ .../inc_2stream_by_nstream_bybnd.html | 258 ++ .../inc_nstream_by_1scalar_bybnd.html | 234 ++ .../inc_nstream_by_2stream_bybnd.html | 258 ++ .../inc_nstream_by_nstream_bybnd.html | 264 ++ .../increment_1scalar_by_1scalar.html | 216 + .../increment_1scalar_by_2stream.html | 222 + .../increment_1scalar_by_nstream.html | 222 + .../increment_2stream_by_1scalar.html | 222 + .../increment_2stream_by_2stream.html | 240 ++ .../increment_2stream_by_nstream.html | 246 ++ .../increment_nstream_by_1scalar.html | 222 + .../increment_nstream_by_2stream.html | 246 ++ .../increment_nstream_by_nstream.html | 252 ++ .../interface/lw_solver_2stream.html | 274 ++ .../interface/lw_solver_noscat.html | 332 ++ .../rte-kernels/interface/net_broadband.html | 2 +- .../interface/net_broadband~2.html | 297 ++ .../rte-kernels/interface/sum_broadband.html | 216 + .../interface/sw_solver_2stream.html | 309 ++ .../interface/sw_solver_noscat.html | 232 ++ .../rte-kernels/interface/zero_array.html | 28 +- .../rte-kernels/interface/zero_array~2.html | 344 ++ reference/rte-kernels/lists/files.html | 88 +- reference/rte-kernels/lists/modules.html | 212 +- reference/rte-kernels/lists/procedures.html | 769 ++-- .../module/mo_fluxes_broadband_kernels.html | 42 +- .../module/mo_fluxes_broadband_kernels~2.html | 475 +++ .../module/mo_optical_props_kernels.html | 42 +- .../module/mo_optical_props_kernels~2.html | 1936 +++++++++ .../module/mo_rte_solver_kernels.html | 102 +- .../module/mo_rte_solver_kernels~2.html | 817 ++++ .../rte-kernels/module/mo_rte_util_array.html | 288 +- .../module/mo_rte_util_array~2.html | 710 ++++ .../proc/delta_scale_2str_f_k.html | 14 +- .../rte-kernels/proc/delta_scale_2str_k.html | 14 +- .../proc/extract_subset_absorption_tau.html | 8 +- .../proc/extract_subset_dim1_3d.html | 8 +- .../proc/extract_subset_dim2_4d.html | 8 +- .../proc/inc_1scalar_by_1scalar_bybnd.html | 8 +- .../proc/inc_1scalar_by_2stream_bybnd.html | 8 +- .../proc/inc_1scalar_by_nstream_bybnd.html | 8 +- .../proc/inc_2stream_by_1scalar_bybnd.html | 8 +- .../proc/inc_2stream_by_2stream_bybnd.html | 8 +- .../proc/inc_2stream_by_nstream_bybnd.html | 8 +- .../proc/inc_nstream_by_1scalar_bybnd.html | 8 +- .../proc/inc_nstream_by_2stream_bybnd.html | 8 +- .../proc/inc_nstream_by_nstream_bybnd.html | 8 +- .../proc/increment_1scalar_by_1scalar.html | 8 +- .../proc/increment_1scalar_by_2stream.html | 8 +- .../proc/increment_1scalar_by_nstream.html | 8 +- .../proc/increment_2stream_by_1scalar.html | 8 +- .../proc/increment_2stream_by_2stream.html | 8 +- .../proc/increment_2stream_by_nstream.html | 8 +- .../proc/increment_nstream_by_1scalar.html | 8 +- .../proc/increment_nstream_by_2stream.html | 8 +- .../proc/increment_nstream_by_nstream.html | 8 +- .../rte-kernels/proc/lw_solver_2stream.html | 28 +- .../rte-kernels/proc/lw_solver_noscat.html | 28 +- reference/rte-kernels/proc/sum_broadband.html | 6 +- .../rte-kernels/proc/sw_solver_2stream.html | 38 +- .../rte-kernels/proc/sw_solver_noscat.html | 10 +- reference/rte-kernels/proc/zero_array_1d.html | 4 +- reference/rte-kernels/proc/zero_array_2d.html | 4 +- reference/rte-kernels/proc/zero_array_3d.html | 4 +- reference/rte-kernels/proc/zero_array_4d.html | 4 +- .../mo_fluxes_broadband_kernels.f90.html | 2 +- .../mo_fluxes_broadband_kernels.f90~2.html | 281 ++ .../mo_optical_props_kernels.f90.html | 2 +- .../mo_optical_props_kernels.f90~2.html | 584 +++ .../sourcefile/mo_rte_solver_kernels.f90.html | 2392 ++++++----- .../mo_rte_solver_kernels.f90~2.html | 409 ++ .../sourcefile/mo_rte_util_array.f90.html | 6 +- .../sourcefile/mo_rte_util_array.f90~2.html | 254 ++ .../src/mo_fluxes_broadband_kernels.F90 | 142 +- .../src/mo_optical_props_kernels.F90 | 888 ++-- .../rte-kernels/src/mo_rte_solver_kernels.F90 | 1350 +------ .../rte-kernels/src/mo_rte_util_array.F90 | 96 +- .../tipuesearch/tipuesearch_content.js | 2 +- release-notes/2022/06/02/Release-notes.html | 2 +- .../2023/11/27/v1.7-Release-notes.html | 2 +- tutorials/index.html | 2 +- 160 files changed, 23318 insertions(+), 9572 deletions(-) create mode 100644 reference/rrtmgp-kernels/interface/compute_planck_source.html create mode 100644 reference/rrtmgp-kernels/interface/compute_tau_absorption.html create mode 100644 reference/rrtmgp-kernels/interface/compute_tau_rayleigh.html create mode 100644 reference/rrtmgp-kernels/interface/interpolation.html create mode 100644 reference/rrtmgp-kernels/lists/files.html create mode 100644 reference/rrtmgp-kernels/module/mo_gas_optics_rrtmgp_kernels~2.html create mode 100644 reference/rrtmgp-kernels/sourcefile/mo_gas_optics_rrtmgp_kernels.f90~2.html create mode 100644 reference/rte-kernels/interface/delta_scale_2str_kernel~2.html create mode 100644 reference/rte-kernels/interface/extract_subset~2.html create mode 100644 reference/rte-kernels/interface/inc_1scalar_by_1scalar_bybnd.html create mode 100644 reference/rte-kernels/interface/inc_1scalar_by_2stream_bybnd.html create mode 100644 reference/rte-kernels/interface/inc_1scalar_by_nstream_bybnd.html create mode 100644 reference/rte-kernels/interface/inc_2stream_by_1scalar_bybnd.html create mode 100644 reference/rte-kernels/interface/inc_2stream_by_2stream_bybnd.html create mode 100644 reference/rte-kernels/interface/inc_2stream_by_nstream_bybnd.html create mode 100644 reference/rte-kernels/interface/inc_nstream_by_1scalar_bybnd.html create mode 100644 reference/rte-kernels/interface/inc_nstream_by_2stream_bybnd.html create mode 100644 reference/rte-kernels/interface/inc_nstream_by_nstream_bybnd.html create mode 100644 reference/rte-kernels/interface/increment_1scalar_by_1scalar.html create mode 100644 reference/rte-kernels/interface/increment_1scalar_by_2stream.html create mode 100644 reference/rte-kernels/interface/increment_1scalar_by_nstream.html create mode 100644 reference/rte-kernels/interface/increment_2stream_by_1scalar.html create mode 100644 reference/rte-kernels/interface/increment_2stream_by_2stream.html create mode 100644 reference/rte-kernels/interface/increment_2stream_by_nstream.html create mode 100644 reference/rte-kernels/interface/increment_nstream_by_1scalar.html create mode 100644 reference/rte-kernels/interface/increment_nstream_by_2stream.html create mode 100644 reference/rte-kernels/interface/increment_nstream_by_nstream.html create mode 100644 reference/rte-kernels/interface/lw_solver_2stream.html create mode 100644 reference/rte-kernels/interface/lw_solver_noscat.html create mode 100644 reference/rte-kernels/interface/net_broadband~2.html create mode 100644 reference/rte-kernels/interface/sum_broadband.html create mode 100644 reference/rte-kernels/interface/sw_solver_2stream.html create mode 100644 reference/rte-kernels/interface/sw_solver_noscat.html create mode 100644 reference/rte-kernels/interface/zero_array~2.html create mode 100644 reference/rte-kernels/module/mo_fluxes_broadband_kernels~2.html create mode 100644 reference/rte-kernels/module/mo_optical_props_kernels~2.html create mode 100644 reference/rte-kernels/module/mo_rte_solver_kernels~2.html create mode 100644 reference/rte-kernels/module/mo_rte_util_array~2.html create mode 100644 reference/rte-kernels/sourcefile/mo_fluxes_broadband_kernels.f90~2.html create mode 100644 reference/rte-kernels/sourcefile/mo_optical_props_kernels.f90~2.html create mode 100644 reference/rte-kernels/sourcefile/mo_rte_solver_kernels.f90~2.html create mode 100644 reference/rte-kernels/sourcefile/mo_rte_util_array.f90~2.html diff --git a/assets/main.css.map b/assets/main.css.map index 82f92639a..b9308372a 100644 --- a/assets/main.css.map +++ b/assets/main.css.map @@ -3,10 +3,10 @@ "file": "main.css", "sources": [ "main.scss", - "../../../../../../../opt/hostedtoolcache/Ruby/3.1.4/x64/lib/ruby/gems/3.1.0/gems/minima-2.5.1/_sass/minima.scss", - "../../../../../../../opt/hostedtoolcache/Ruby/3.1.4/x64/lib/ruby/gems/3.1.0/gems/minima-2.5.1/_sass/minima/_base.scss", - "../../../../../../../opt/hostedtoolcache/Ruby/3.1.4/x64/lib/ruby/gems/3.1.0/gems/minima-2.5.1/_sass/minima/_layout.scss", - "../../../../../../../opt/hostedtoolcache/Ruby/3.1.4/x64/lib/ruby/gems/3.1.0/gems/minima-2.5.1/_sass/minima/_syntax-highlighting.scss" + "../../../../../../../opt/hostedtoolcache/Ruby/3.1.5/x64/lib/ruby/gems/3.1.0/gems/minima-2.5.1/_sass/minima.scss", + "../../../../../../../opt/hostedtoolcache/Ruby/3.1.5/x64/lib/ruby/gems/3.1.0/gems/minima-2.5.1/_sass/minima/_base.scss", + "../../../../../../../opt/hostedtoolcache/Ruby/3.1.5/x64/lib/ruby/gems/3.1.0/gems/minima-2.5.1/_sass/minima/_layout.scss", + "../../../../../../../opt/hostedtoolcache/Ruby/3.1.5/x64/lib/ruby/gems/3.1.0/gems/minima-2.5.1/_sass/minima/_syntax-highlighting.scss" ], "sourcesContent": [ "@import \"minima\";\n", diff --git a/explanations/index.html b/explanations/index.html index 04c9c33de..24bd86dd4 100644 --- a/explanations/index.html +++ b/explanations/index.html @@ -31,7 +31,7 @@ -
How to build and run testsRTE+RRTMGP documentationExplanationsTutorialsHow-to guidesReference (technical documentation)
+
How to build and run testsRTE+RRTMGP documentationTutorialsReference (technical documentation)ExplanationsHow-to guides
diff --git a/feed.xml b/feed.xml index 0c1f6e2ff..d38f1478a 100644 --- a/feed.xml +++ b/feed.xml @@ -1,4 +1,4 @@ -Jekyll2024-02-03T05:14:46+00:00https://earth-system-radiation.github.io//rte-rrtmgp/feed.xmlRTE-RRTMGPRTE+RRTMGP is a set of codes for computing radiative fluxes in planetary atmospheres. RRTMGP uses a k-distribution to provide an optical description (absorption and possibly Rayleigh optical depth) of the gaseous atmosphere, along with the relevant source functions, on a pre-determined spectral grid given temperatures, pressures, and gas concentration. RTE computes fluxes given spectrally-resolved optical descriptions and source functions.v1.7 Release notes2023-11-27T00:00:00+00:002023-11-27T00:00:00+00:00https://earth-system-radiation.github.io//rte-rrtmgp/release-notes/2023/11/27/v1.7-Release-notesCommit 3ac0636 +Jekyll2024-05-21T02:50:39+00:00https://earth-system-radiation.github.io//rte-rrtmgp/feed.xmlRTE-RRTMGPRTE+RRTMGP is a set of codes for computing radiative fluxes in planetary atmospheres. RRTMGP uses a k-distribution to provide an optical description (absorption and possibly Rayleigh optical depth) of the gaseous atmosphere, along with the relevant source functions, on a pre-determined spectral grid given temperatures, pressures, and gas concentration. RTE computes fluxes given spectrally-resolved optical descriptions and source functions.v1.7 Release notes2023-11-27T00:00:00+00:002023-11-27T00:00:00+00:00https://earth-system-radiation.github.io//rte-rrtmgp/release-notes/2023/11/27/v1.7-Release-notesCommit 3ac0636 to branch main makes the following changes:

    diff --git a/how-tos/build-and-test.html b/how-tos/build-and-test.html index 3032c3da2..3454566ec 100644 --- a/how-tos/build-and-test.html +++ b/how-tos/build-and-test.html @@ -31,7 +31,7 @@ -
    How to build and run testsRTE+RRTMGP documentationExplanationsTutorialsHow-to guidesReference (technical documentation)
    +
    How to build and run testsRTE+RRTMGP documentationTutorialsReference (technical documentation)ExplanationsHow-to guides
    diff --git a/how-tos/index.html b/how-tos/index.html index 57f6e3833..04d0e6cd7 100644 --- a/how-tos/index.html +++ b/how-tos/index.html @@ -31,7 +31,7 @@ -
    How to build and run testsRTE+RRTMGP documentationExplanationsTutorialsHow-to guidesReference (technical documentation)
    +
    How to build and run testsRTE+RRTMGP documentationTutorialsReference (technical documentation)ExplanationsHow-to guides
    diff --git a/index.html b/index.html index 0241f9f1b..05d807dba 100644 --- a/index.html +++ b/index.html @@ -31,7 +31,7 @@ -
    How to build and run testsRTE+RRTMGP documentationExplanationsTutorialsHow-to guidesReference (technical documentation)
    +
    How to build and run testsRTE+RRTMGP documentationTutorialsReference (technical documentation)ExplanationsHow-to guides
    diff --git a/reference/index.html b/reference/index.html index 6f1da98dd..e1026f544 100644 --- a/reference/index.html +++ b/reference/index.html @@ -31,7 +31,7 @@ -
    How to build and run testsRTE+RRTMGP documentationExplanationsTutorialsHow-to guidesReference (technical documentation)
    +
    How to build and run testsRTE+RRTMGP documentationTutorialsReference (technical documentation)ExplanationsHow-to guides
    diff --git a/reference/rrtmgp-fortran-interface/lists/files.html b/reference/rrtmgp-fortran-interface/lists/files.html index 2be038c9d..d9bbcd28e 100644 --- a/reference/rrtmgp-fortran-interface/lists/files.html +++ b/reference/rrtmgp-fortran-interface/lists/files.html @@ -106,21 +106,21 @@

    Source Files

    - + -sourcefile~mo_aerosol_optics_rrtmgp_merra.f90 - - -mo_aerosol_optics_rrtmgp_merra.F90 +sourcefile~mo_gas_optics_rrtmgp.f90 + + +mo_gas_optics_rrtmgp.F90 - + -sourcefile~mo_gas_optics_rrtmgp.f90 - - -mo_gas_optics_rrtmgp.F90 +sourcefile~mo_aerosol_optics_rrtmgp_merra.f90 + + +mo_aerosol_optics_rrtmgp_merra.F90 diff --git a/reference/rrtmgp-fortran-interface/lists/modules.html b/reference/rrtmgp-fortran-interface/lists/modules.html index b74716a24..ee9220a66 100644 --- a/reference/rrtmgp-fortran-interface/lists/modules.html +++ b/reference/rrtmgp-fortran-interface/lists/modules.html @@ -99,212 +99,212 @@

    Modules

    module~~graph~~ModuleGraph - + -module~mo_gas_optics_rrtmgp - - -mo_gas_optics_rrtmgp +module~mo_cloud_optics_rrtmgp + + +mo_cloud_optics_rrtmgp - + -mo_gas_optics_constants - -mo_gas_optics_constants +mo_rte_config + +mo_rte_config - + -module~mo_gas_optics_rrtmgp->mo_gas_optics_constants - - - - - -mo_gas_optics - -mo_gas_optics - - - -module~mo_gas_optics_rrtmgp->mo_gas_optics - - +module~mo_cloud_optics_rrtmgp->mo_rte_config + + mo_optical_props - -mo_optical_props + +mo_optical_props - - -module~mo_gas_optics_rrtmgp->mo_optical_props - - + + +module~mo_cloud_optics_rrtmgp->mo_optical_props + + + + + +mo_rte_kind + +mo_rte_kind + + + +module~mo_cloud_optics_rrtmgp->mo_rte_kind + + - + mo_rte_util_array_validation - -mo_rte_util_array_validation + +mo_rte_util_array_validation - - -module~mo_gas_optics_rrtmgp->mo_rte_util_array_validation - - + + +module~mo_cloud_optics_rrtmgp->mo_rte_util_array_validation + + - - -mo_rte_util_array - -mo_rte_util_array + + +module~mo_gas_optics_rrtmgp + + +mo_gas_optics_rrtmgp + - - -module~mo_gas_optics_rrtmgp->mo_rte_util_array - - - - -mo_gas_concentrations - -mo_gas_concentrations + + +module~mo_gas_optics_rrtmgp->mo_rte_config + + - + + +mo_gas_optics_rrtmgp_kernels + +mo_gas_optics_rrtmgp_kernels + + -module~mo_gas_optics_rrtmgp->mo_gas_concentrations - - +module~mo_gas_optics_rrtmgp->mo_gas_optics_rrtmgp_kernels + + - - -mo_rte_config - -mo_rte_config + + +module~mo_gas_optics_rrtmgp->mo_optical_props + + - + + +mo_gas_optics_util_string + +mo_gas_optics_util_string + + -module~mo_gas_optics_rrtmgp->mo_rte_config - - +module~mo_gas_optics_rrtmgp->mo_gas_optics_util_string + + + + + +mo_gas_optics + +mo_gas_optics + + + +module~mo_gas_optics_rrtmgp->mo_gas_optics + + - + mo_source_functions - -mo_source_functions + +mo_source_functions - + module~mo_gas_optics_rrtmgp->mo_source_functions - - - - - -mo_rte_kind - -mo_rte_kind + + - + module~mo_gas_optics_rrtmgp->mo_rte_kind - - + + - + + +module~mo_gas_optics_rrtmgp->mo_rte_util_array_validation + + + + + +mo_rte_util_array + +mo_rte_util_array + + + +module~mo_gas_optics_rrtmgp->mo_rte_util_array + + + + -mo_gas_optics_util_string - -mo_gas_optics_util_string +mo_gas_concentrations + +mo_gas_concentrations - - -module~mo_gas_optics_rrtmgp->mo_gas_optics_util_string + + +module~mo_gas_optics_rrtmgp->mo_gas_concentrations - + -mo_gas_optics_rrtmgp_kernels - -mo_gas_optics_rrtmgp_kernels +mo_gas_optics_constants + +mo_gas_optics_constants - - -module~mo_gas_optics_rrtmgp->mo_gas_optics_rrtmgp_kernels + + +module~mo_gas_optics_rrtmgp->mo_gas_optics_constants - + module~mo_aerosol_optics_rrtmgp_merra - - -mo_aerosol_optics_rrtmgp_merra + + +mo_aerosol_optics_rrtmgp_merra - - -module~mo_aerosol_optics_rrtmgp_merra->mo_optical_props - - - - - -module~mo_aerosol_optics_rrtmgp_merra->mo_rte_util_array_validation - - - - + module~mo_aerosol_optics_rrtmgp_merra->mo_rte_config - - + + + + + +module~mo_aerosol_optics_rrtmgp_merra->mo_optical_props + + - + module~mo_aerosol_optics_rrtmgp_merra->mo_rte_kind - - + + - - -module~mo_cloud_optics_rrtmgp - - -mo_cloud_optics_rrtmgp - - - - - -module~mo_cloud_optics_rrtmgp->mo_optical_props - - - - - -module~mo_cloud_optics_rrtmgp->mo_rte_util_array_validation - - - - + -module~mo_cloud_optics_rrtmgp->mo_rte_config - - - - - -module~mo_cloud_optics_rrtmgp->mo_rte_kind - - +module~mo_aerosol_optics_rrtmgp_merra->mo_rte_util_array_validation + + diff --git a/reference/rrtmgp-fortran-interface/lists/types.html b/reference/rrtmgp-fortran-interface/lists/types.html index 414d42d38..2faa263ca 100644 --- a/reference/rrtmgp-fortran-interface/lists/types.html +++ b/reference/rrtmgp-fortran-interface/lists/types.html @@ -98,12 +98,12 @@

    Derived Types

    type~~graph~~TypeGraph - + -type~ty_cloud_optics_rrtmgp - - -ty_cloud_optics_rrtmgp +type~ty_aerosol_optics_rrtmgp_merra + + +ty_aerosol_optics_rrtmgp_merra @@ -113,31 +113,16 @@

    Derived Types

    ty_optical_props     - - -type~ty_cloud_optics_rrtmgp->ty_optical_props - - - - - -type~ty_aerosol_optics_rrtmgp_merra - - -ty_aerosol_optics_rrtmgp_merra - - - - + type~ty_aerosol_optics_rrtmgp_merra->ty_optical_props - - + + - + type~ty_gas_optics_rrtmgp - + ty_gas_optics_rrtmgp @@ -150,11 +135,26 @@

    Derived Types

    ty_gas_optics     - + type~ty_gas_optics_rrtmgp->ty_gas_optics + + +type~ty_cloud_optics_rrtmgp + + +ty_cloud_optics_rrtmgp + + + + + +type~ty_cloud_optics_rrtmgp->ty_optical_props + + +
@@ -460,504 +460,504 @@

Source Code

! ! Interpolate source function - ! - if(present(tlev)) then - ! - ! present status of optional argument should be passed to source() - ! but isn't with PGI 19.10 - ! - error_msg = source(this, & - ncol, nlay, nband, ngpt, & - play, plev, tlay, tsfc, & - jtemp, jpress, jeta, tropo, fmajor, & - sources, & - tlev) - !$acc exit data delete(tlev) - !$omp target exit data map(release:tlev) - else - error_msg = source(this, & - ncol, nlay, nband, ngpt, & - play, plev, tlay, tsfc, & - jtemp, jpress, jeta, tropo, fmajor, & - sources) - end if - !$acc exit data delete(tsfc) - !$omp target exit data map(release:tsfc) - !$acc exit data delete(jtemp, jpress, tropo, fmajor, jeta) - !$omp target exit data map(release:jtemp, jpress, tropo, fmajor, jeta) - end function gas_optics_int - !------------------------------------------------------------------------------------------ - ! - !> Compute gas optical depth given temperature, pressure, and composition - !> Top-of-atmosphere stellar insolation is also reported - ! - function gas_optics_ext(this, & - play, plev, tlay, gas_desc, & ! mandatory inputs - optical_props, toa_src, & ! mandatory outputs - col_dry) result(error_msg) ! optional input - - class(ty_gas_optics_rrtmgp), intent(in) :: this - real(wp), dimension(:,:), intent(in ) :: play, & !! layer pressures [Pa, mb]; (ncol,nlay) - plev, & !! level pressures [Pa, mb]; (ncol,nlay+1) - tlay !! layer temperatures [K]; (ncol,nlay) - type(ty_gas_concs), intent(in ) :: gas_desc !! Gas volume mixing ratios - ! output - class(ty_optical_props_arry), & - intent(inout) :: optical_props - real(wp), dimension(:,:), intent( out) :: toa_src !! Incoming solar irradiance(ncol,ngpt) - character(len=128) :: error_msg !! Empty if successful - - ! Optional inputs - real(wp), dimension(:,:), intent(in ), & - optional, target :: col_dry ! Column dry amount; dim(ncol,nlay) - ! ---------------------------------------------------------- - ! Local variables - ! Interpolation coefficients for use in source function - integer, dimension(size(play,dim=1), size(play,dim=2)) :: jtemp, jpress - logical(wl), dimension(size(play,dim=1), size(play,dim=2)) :: tropo - real(wp), dimension(2,2,2,size(play,dim=1),size(play,dim=2), get_nflav(this)) :: fmajor - integer, dimension(2, size(play,dim=1),size(play,dim=2), get_nflav(this)) :: jeta - - integer :: ncol, nlay, ngpt, nband, ngas, nflav - integer :: igpt, icol - ! ---------------------------------------------------------- - ncol = size(play,dim=1) - nlay = size(play,dim=2) - ngpt = this%get_ngpt() - nband = this%get_nband() - ngas = this%get_ngas() - nflav = get_nflav(this) - ! - ! Gas optics - ! - !$acc enter data create(jtemp, jpress, tropo, fmajor, jeta) - !$omp target enter data map(alloc:jtemp, jpress, tropo, fmajor, jeta) - error_msg = compute_gas_taus(this, & - ncol, nlay, ngpt, nband, & - play, plev, tlay, gas_desc, & - optical_props, & - jtemp, jpress, jeta, tropo, fmajor, & - col_dry) - !$acc exit data delete(jtemp, jpress, tropo, fmajor, jeta) - !$omp target exit data map(release:jtemp, jpress, tropo, fmajor, jeta) - if(error_msg /= '') return - - ! ---------------------------------------------------------- - ! - ! External source function is constant - ! - !$acc enter data create(toa_src) - !$omp target enter data map(alloc:toa_src) - if(check_extents) then - if(.not. extents_are(toa_src, ncol, ngpt)) & - error_msg = "gas_optics(): array toa_src has wrong size" - end if - if(error_msg /= '') return - - !$acc parallel loop collapse(2) - !$omp target teams distribute parallel do simd collapse(2) - do igpt = 1,ngpt - do icol = 1,ncol - toa_src(icol,igpt) = this%solar_source(igpt) - end do - end do - !$acc exit data copyout(toa_src) - !$omp target exit data map(from:toa_src) - end function gas_optics_ext - !------------------------------------------------------------------------------------------ - ! - ! Returns optical properties and interpolation coefficients - ! - function compute_gas_taus(this, & - ncol, nlay, ngpt, nband, & - play, plev, tlay, gas_desc, & - optical_props, & - jtemp, jpress, jeta, tropo, fmajor, & - col_dry) result(error_msg) - - class(ty_gas_optics_rrtmgp), & - intent(in ) :: this - integer, intent(in ) :: ncol, nlay, ngpt, nband - real(wp), dimension(:,:), intent(in ) :: play, & ! layer pressures [Pa, mb]; (ncol,nlay) - plev, & ! level pressures [Pa, mb]; (ncol,nlay+1) - tlay ! layer temperatures [K]; (ncol,nlay) - type(ty_gas_concs), intent(in ) :: gas_desc ! Gas volume mixing ratios - class(ty_optical_props_arry), intent(inout) :: optical_props !inout because components are allocated - ! Interpolation coefficients for use in internal source function - integer, dimension( ncol, nlay), intent( out) :: jtemp, jpress - integer, dimension(2, ncol, nlay,get_nflav(this)), intent( out) :: jeta - logical(wl), dimension( ncol, nlay), intent( out) :: tropo - real(wp), dimension(2,2,2,ncol, nlay,get_nflav(this)), intent( out) :: fmajor - character(len=128) :: error_msg - - ! Optional inputs - real(wp), dimension(:,:), intent(in ), & - optional, target :: col_dry ! Column dry amount; dim(ncol,nlay) - ! ---------------------------------------------------------- - ! Local variables - real(wp), dimension(ncol,nlay,ngpt) :: tau, tau_rayleigh ! absorption, Rayleigh scattering optical depths - ! Number of molecules per cm^2 - real(wp), dimension(ncol,nlay), target :: col_dry_arr - real(wp), dimension(:,:), pointer :: col_dry_wk - ! - ! Interpolation variables used in major gas but not elsewhere, so don't need exporting - ! - real(wp), dimension(ncol,nlay, this%get_ngas()) :: vmr ! volume mixing ratios - real(wp), dimension(ncol,nlay,0:this%get_ngas()) :: col_gas ! column amounts for each gas, plus col_dry - real(wp), dimension(2, ncol,nlay,get_nflav(this)) :: col_mix ! combination of major species's column amounts - ! index(1) : reference temperature level - ! index(2) : flavor - ! index(3) : layer - real(wp), dimension(2,2, ncol,nlay,get_nflav(this)) :: fminor ! interpolation fractions for minor species - ! index(1) : reference eta level (temperature dependent) - ! index(2) : reference temperature level - ! index(3) : flavor - ! index(4) : layer - integer :: ngas, nflav, neta, npres, ntemp - integer :: icol, ilay, igas - integer :: idx_h2o ! index of water vapor - integer :: nminorlower, nminorklower,nminorupper, nminorkupper - logical :: use_rayl - ! ---------------------------------------------------------- - ! - ! Error checking - ! - use_rayl = allocated(this%krayl) - error_msg = '' - ! Check for initialization - if (.not. this%is_loaded()) then - error_msg = 'ERROR: spectral configuration not loaded' - return - end if - ! - ! Check for presence of key species in ty_gas_concs; return error if any key species are not present - ! - error_msg = this%check_key_species_present(gas_desc) - if (error_msg /= '') return - - ! - ! Check input data sizes and values - ! - !$acc data copyin(play,plev,tlay) create( vmr,col_gas) - !$omp target data map(to:play,plev,tlay) map(alloc:vmr,col_gas) - if(check_extents) then - if(.not. extents_are(play, ncol, nlay )) & - error_msg = "gas_optics(): array play has wrong size" - if(.not. extents_are(tlay, ncol, nlay )) & - error_msg = "gas_optics(): array tlay has wrong size" - if(.not. extents_are(plev, ncol, nlay+1)) & - error_msg = "gas_optics(): array plev has wrong size" - if(optical_props%get_ncol() /= ncol .or. & - optical_props%get_nlay() /= nlay .or. & - optical_props%get_ngpt() /= ngpt) & - error_msg = "gas_optics(): optical properties have the wrong extents" - if(present(col_dry)) then - if(.not. extents_are(col_dry, ncol, nlay)) & - error_msg = "gas_optics(): array col_dry has wrong size" - end if - end if - - if(error_msg == '') then - if(check_values) then - if(any_vals_outside(play, this%press_ref_min,this%press_ref_max)) & - error_msg = "gas_optics(): array play has values outside range" - if(any_vals_less_than(plev, 0._wp)) & - error_msg = "gas_optics(): array plev has values outside range" - if(any_vals_outside(tlay, this%temp_ref_min, this%temp_ref_max)) & - error_msg = "gas_optics(): array tlay has values outside range" - if(present(col_dry)) then - if(any_vals_less_than(col_dry, 0._wp)) & - error_msg = "gas_optics(): array col_dry has values outside range" - end if - end if - end if - - ! ---------------------------------------------------------- - if(error_msg == '') then - ngas = this%get_ngas() - nflav = get_nflav(this) - neta = this%get_neta() - npres = this%get_npres() - ntemp = this%get_ntemp() - ! number of minor contributors, total num absorption coeffs - nminorlower = size(this%minor_scales_with_density_lower) - nminorklower = size(this%kminor_lower, 3) - nminorupper = size(this%minor_scales_with_density_upper) - nminorkupper = size(this%kminor_upper, 3) - ! - ! Fill out the array of volume mixing ratios - ! - do igas = 1, ngas - ! - ! Get vmr if gas is provided in ty_gas_concs - ! - if (any (lower_case(this%gas_names(igas)) == gas_desc%get_gas_names())) then - error_msg = gas_desc%get_vmr(this%gas_names(igas), vmr(:,:,igas)) - endif - end do - end if - - if(error_msg == '') then - -! -! Painful hacks to get code to compile with both the CCE-14 and Nvidia 21.3 compiler -! -#ifdef _CRAYFTN - !$acc enter data copyin(optical_props) -#endif - select type(optical_props) - type is (ty_optical_props_1scl) -#ifndef _CRAYFTN - !$acc enter data copyin(optical_props) -#endif - !$acc enter data create( optical_props%tau) - !$omp target enter data map(alloc:optical_props%tau) - type is (ty_optical_props_2str) -#ifndef _CRAYFTN - !$acc enter data copyin(optical_props) -#endif - !$acc enter data create( optical_props%tau, optical_props%ssa, optical_props%g) - !$omp target enter data map(alloc:optical_props%tau, optical_props%ssa, optical_props%g) - type is (ty_optical_props_nstr) -#ifndef _CRAYFTN - !$acc enter data copyin(optical_props) -#endif - !$acc enter data create( optical_props%tau, optical_props%ssa, optical_props%p) - !$omp target enter data map(alloc:optical_props%tau, optical_props%ssa, optical_props%p) - end select - - ! - ! Compute dry air column amounts (number of molecule per cm^2) if user hasn't provided them - ! - idx_h2o = string_loc_in_array('h2o', this%gas_names) - if (present(col_dry)) then - !$acc enter data copyin(col_dry) - !$omp target enter data map(to:col_dry) - col_dry_wk => col_dry - else - !$acc enter data create( col_dry_arr) - !$omp target enter data map(alloc:col_dry_arr) - col_dry_arr = get_col_dry(vmr(:,:,idx_h2o), plev) ! dry air column amounts computation - col_dry_wk => col_dry_arr - end if - ! - ! compute column gas amounts [molec/cm^2] - ! - !$acc parallel loop gang vector collapse(2) - !$omp target teams distribute parallel do simd collapse(2) - do ilay = 1, nlay - do icol = 1, ncol - col_gas(icol,ilay,0) = col_dry_wk(icol,ilay) - end do - end do - !$acc parallel loop gang vector collapse(3) - !$omp target teams distribute parallel do simd collapse(3) - do igas = 1, ngas - do ilay = 1, nlay - do icol = 1, ncol - col_gas(icol,ilay,igas) = vmr(icol,ilay,igas) * col_dry_wk(icol,ilay) - end do - end do - end do - ! - ! ---- calculate gas optical depths ---- - ! - !$acc data copyout( jtemp, jpress, jeta, tropo, fmajor) create( col_mix, fminor) - !$omp target data map(from:jtemp, jpress, jeta, tropo, fmajor) map(alloc:col_mix, fminor) - call interpolation( & - ncol,nlay, & ! problem dimensions - ngas, nflav, neta, npres, ntemp, & ! interpolation dimensions - this%flavor, & - this%press_ref_log, & - this%temp_ref, & - this%press_ref_log_delta, & - this%temp_ref_min, & - this%temp_ref_delta, & - this%press_ref_trop_log, & - this%vmr_ref, & - play, & - tlay, & - col_gas, & - jtemp, & ! outputs - fmajor,fminor,& - col_mix, & - tropo, & - jeta,jpress) - if (allocated(this%krayl)) then - !$acc data copyin(this%gpoint_flavor, this%krayl) create(tau, tau_rayleigh) - !$omp target data map(to:this%gpoint_flavor, this%krayl) map(alloc:tau, tau_rayleigh) - call zero_array(ncol, nlay, ngpt, tau) - call compute_tau_absorption( & - ncol,nlay,nband,ngpt, & ! dimensions - ngas,nflav,neta,npres,ntemp, & - nminorlower, nminorklower, & ! number of minor contributors, total num absorption coeffs - nminorupper, nminorkupper, & - idx_h2o, & - this%gpoint_flavor, & - this%get_band_lims_gpoint(), & - this%kmajor, & - this%kminor_lower, & - this%kminor_upper, & - this%minor_limits_gpt_lower, & - this%minor_limits_gpt_upper, & - this%minor_scales_with_density_lower, & - this%minor_scales_with_density_upper, & - this%scale_by_complement_lower, & - this%scale_by_complement_upper, & - this%idx_minor_lower, & - this%idx_minor_upper, & - this%idx_minor_scaling_lower, & - this%idx_minor_scaling_upper, & - this%kminor_start_lower, & - this%kminor_start_upper, & - tropo, & - col_mix,fmajor,fminor, & - play,tlay,col_gas, & - jeta,jtemp,jpress, & - tau) - call compute_tau_rayleigh( & !Rayleigh scattering optical depths - ncol,nlay,nband,ngpt, & - ngas,nflav,neta,npres,ntemp, & ! dimensions - this%gpoint_flavor, & - this%get_band_lims_gpoint(), & - this%krayl, & ! inputs from object - idx_h2o, col_dry_wk,col_gas, & - fminor,jeta,tropo,jtemp, & ! local input - tau_rayleigh) - call combine_abs_and_rayleigh(tau, tau_rayleigh, optical_props) - !$acc end data - !$omp end target data - else - call zero_array(ncol, nlay, ngpt, optical_props%tau) - call compute_tau_absorption( & - ncol,nlay,nband,ngpt, & ! dimensions - ngas,nflav,neta,npres,ntemp, & - nminorlower, nminorklower, & ! number of minor contributors, total num absorption coeffs - nminorupper, nminorkupper, & - idx_h2o, & - this%gpoint_flavor, & - this%get_band_lims_gpoint(), & - this%kmajor, & - this%kminor_lower, & - this%kminor_upper, & - this%minor_limits_gpt_lower, & - this%minor_limits_gpt_upper, & - this%minor_scales_with_density_lower, & - this%minor_scales_with_density_upper, & - this%scale_by_complement_lower, & - this%scale_by_complement_upper, & - this%idx_minor_lower, & - this%idx_minor_upper, & - this%idx_minor_scaling_lower, & - this%idx_minor_scaling_upper, & - this%kminor_start_lower, & - this%kminor_start_upper, & - tropo, & - col_mix,fmajor,fminor, & - play,tlay,col_gas, & - jeta,jtemp,jpress, & - optical_props%tau) ! - select type(optical_props) - type is (ty_optical_props_2str) - call zero_array(ncol, nlay, ngpt, optical_props%ssa) - call zero_array(ncol, nlay, ngpt, optical_props%g) - type is (ty_optical_props_nstr) - call zero_array(ncol, nlay, ngpt, optical_props%ssa) - call zero_array(optical_props%get_nmom(), & - ncol, nlay, ngpt, optical_props%p) - end select - end if - !$acc end data - !$omp end target data - if (present(col_dry)) then - !$acc exit data delete( col_dry) - !$omp target exit data map(release:col_dry) - else - !$acc exit data delete( col_dry_arr) - !$omp target exit data map(release:col_dry_arr) - end if - - select type(optical_props) - type is (ty_optical_props_1scl) - !$acc exit data copyout( optical_props%tau) - !$omp target exit data map(from:optical_props%tau) - type is (ty_optical_props_2str) - !$acc exit data copyout( optical_props%tau, optical_props%ssa, optical_props%g) - !$omp target exit data map(from:optical_props%tau, optical_props%ssa, optical_props%g) - type is (ty_optical_props_nstr) - !$acc exit data copyout( optical_props%tau, optical_props%ssa, optical_props%p) - !$omp target exit data map(from:optical_props%tau, optical_props%ssa, optical_props%p) - end select - !$acc exit data delete(optical_props) - - end if - !$acc end data - !$omp end target data - - end function compute_gas_taus - !------------------------------------------------------------------------------------------ - ! - !> Compute the spectral solar source function adjusted to account for solar variability - !> following the NRLSSI2 model of Coddington et al. 2016, doi:10.1175/BAMS-D-14-00265.1. - !> as specified by the facular brightening (mg_index) and sunspot dimming (sb_index) - !> indices provided as input. - !> - !> Users provide the NRLSSI2 facular ("Bremen") index and sunspot ("SPOT67") index. - !> Changing either of these indicies will change the total solar irradiance (TSI) - !> Code in extensions/mo_solar_variability may be used to compute the value of these - !> indices through an average solar cycle - !> Users may also specify the TSI, either alone or in conjunction with the facular and sunspot indices - ! - !------------------------------------------------------------------------------------------ - function set_solar_variability(this, & - mg_index, sb_index, tsi) & - result(error_msg) - ! - !! Updates the spectral distribution and, optionally, - !! the integrated value of the solar source function - !! Modifying either index will change the total solar irradiance - ! - class(ty_gas_optics_rrtmgp), intent(inout) :: this - ! - real(wp), intent(in) :: mg_index !! facular brightening index (NRLSSI2 facular "Bremen" index) - real(wp), intent(in) :: sb_index !! sunspot dimming index (NRLSSI2 sunspot "SPOT67" index) - real(wp), optional, intent(in) :: tsi !! total solar irradiance - character(len=128) :: error_msg !! Empty if successful - ! ---------------------------------------------------------- - integer :: igpt - real(wp), parameter :: a_offset = 0.1495954_wp - real(wp), parameter :: b_offset = 0.00066696_wp - ! ---------------------------------------------------------- - error_msg = "" - if(mg_index < 0._wp) error_msg = 'mg_index out of range' - if(sb_index < 0._wp) error_msg = 'sb_index out of range' - if(error_msg /= "") return - ! - ! Calculate solar source function for provided facular and sunspot indices - ! - !$acc parallel loop - !$omp target teams distribute parallel do simd - do igpt = 1, size(this%solar_source_quiet) - this%solar_source(igpt) = this%solar_source_quiet(igpt) + & - (mg_index - a_offset) * this%solar_source_facular(igpt) + & - (sb_index - b_offset) * this%solar_source_sunspot(igpt) - end do - ! - ! Scale solar source to input TSI value - ! - if (present(tsi)) error_msg = this%set_tsi(tsi) - - end function set_solar_variability - !------------------------------------------------------------------------------------------ - function set_tsi(this, tsi) result(error_msg) - ! - !> Scale the solar source function without changing the spectral distribution - ! - class(ty_gas_optics_rrtmgp), intent(inout) :: this - real(wp), intent(in ) :: tsi !! user-specified total solar irradiance; - character(len=128) :: error_msg !! Empty if successful - - real(wp) :: norm + ! present status of optional argument should be passed to source() + ! but nvfortran (and PGI Fortran before it) do not do so + ! + if(present(tlev)) then + error_msg = source(this, & + ncol, nlay, nband, ngpt, & + play, plev, tlay, tsfc, & + jtemp, jpress, jeta, tropo, fmajor, & + sources, & + tlev) + !$acc exit data delete(tlev) + !$omp target exit data map(release:tlev) + else + error_msg = source(this, & + ncol, nlay, nband, ngpt, & + play, plev, tlay, tsfc, & + jtemp, jpress, jeta, tropo, fmajor, & + sources) + + end if + !$acc exit data delete(tsfc) + !$omp target exit data map(release:tsfc) + !$acc exit data delete(jtemp, jpress, tropo, fmajor, jeta) + !$omp target exit data map(release:jtemp, jpress, tropo, fmajor, jeta) + end function gas_optics_int + !------------------------------------------------------------------------------------------ + ! + !> Compute gas optical depth given temperature, pressure, and composition + !> Top-of-atmosphere stellar insolation is also reported + ! + function gas_optics_ext(this, & + play, plev, tlay, gas_desc, & ! mandatory inputs + optical_props, toa_src, & ! mandatory outputs + col_dry) result(error_msg) ! optional input + + class(ty_gas_optics_rrtmgp), intent(in) :: this + real(wp), dimension(:,:), intent(in ) :: play, & !! layer pressures [Pa, mb]; (ncol,nlay) + plev, & !! level pressures [Pa, mb]; (ncol,nlay+1) + tlay !! layer temperatures [K]; (ncol,nlay) + type(ty_gas_concs), intent(in ) :: gas_desc !! Gas volume mixing ratios + ! output + class(ty_optical_props_arry), & + intent(inout) :: optical_props + real(wp), dimension(:,:), intent( out) :: toa_src !! Incoming solar irradiance(ncol,ngpt) + character(len=128) :: error_msg !! Empty if successful + + ! Optional inputs + real(wp), dimension(:,:), intent(in ), & + optional, target :: col_dry ! Column dry amount; dim(ncol,nlay) + ! ---------------------------------------------------------- + ! Local variables + ! Interpolation coefficients for use in source function + integer, dimension(size(play,dim=1), size(play,dim=2)) :: jtemp, jpress + logical(wl), dimension(size(play,dim=1), size(play,dim=2)) :: tropo + real(wp), dimension(2,2,2,size(play,dim=1),size(play,dim=2), get_nflav(this)) :: fmajor + integer, dimension(2, size(play,dim=1),size(play,dim=2), get_nflav(this)) :: jeta + + integer :: ncol, nlay, ngpt, nband, ngas, nflav + integer :: igpt, icol + ! ---------------------------------------------------------- + ncol = size(play,dim=1) + nlay = size(play,dim=2) + ngpt = this%get_ngpt() + nband = this%get_nband() + ngas = this%get_ngas() + nflav = get_nflav(this) + ! + ! Gas optics + ! + !$acc enter data create(jtemp, jpress, tropo, fmajor, jeta) + !$omp target enter data map(alloc:jtemp, jpress, tropo, fmajor, jeta) + error_msg = compute_gas_taus(this, & + ncol, nlay, ngpt, nband, & + play, plev, tlay, gas_desc, & + optical_props, & + jtemp, jpress, jeta, tropo, fmajor, & + col_dry) + !$acc exit data delete(jtemp, jpress, tropo, fmajor, jeta) + !$omp target exit data map(release:jtemp, jpress, tropo, fmajor, jeta) + if(error_msg /= '') return + + ! ---------------------------------------------------------- + ! + ! External source function is constant + ! + !$acc enter data create(toa_src) + !$omp target enter data map(alloc:toa_src) + if(check_extents) then + if(.not. extents_are(toa_src, ncol, ngpt)) & + error_msg = "gas_optics(): array toa_src has wrong size" + end if + if(error_msg /= '') return + + !$acc parallel loop collapse(2) + !$omp target teams distribute parallel do simd collapse(2) + do igpt = 1,ngpt + do icol = 1,ncol + toa_src(icol,igpt) = this%solar_source(igpt) + end do + end do + !$acc exit data copyout(toa_src) + !$omp target exit data map(from:toa_src) + end function gas_optics_ext + !------------------------------------------------------------------------------------------ + ! + ! Returns optical properties and interpolation coefficients + ! + function compute_gas_taus(this, & + ncol, nlay, ngpt, nband, & + play, plev, tlay, gas_desc, & + optical_props, & + jtemp, jpress, jeta, tropo, fmajor, & + col_dry) result(error_msg) + + class(ty_gas_optics_rrtmgp), & + intent(in ) :: this + integer, intent(in ) :: ncol, nlay, ngpt, nband + real(wp), dimension(:,:), intent(in ) :: play, & ! layer pressures [Pa, mb]; (ncol,nlay) + plev, & ! level pressures [Pa, mb]; (ncol,nlay+1) + tlay ! layer temperatures [K]; (ncol,nlay) + type(ty_gas_concs), intent(in ) :: gas_desc ! Gas volume mixing ratios + class(ty_optical_props_arry), intent(inout) :: optical_props !inout because components are allocated + ! Interpolation coefficients for use in internal source function + integer, dimension( ncol, nlay), intent( out) :: jtemp, jpress + integer, dimension(2, ncol, nlay,get_nflav(this)), intent( out) :: jeta + logical(wl), dimension( ncol, nlay), intent( out) :: tropo + real(wp), dimension(2,2,2,ncol, nlay,get_nflav(this)), intent( out) :: fmajor + character(len=128) :: error_msg + + ! Optional inputs + real(wp), dimension(:,:), intent(in ), & + optional, target :: col_dry ! Column dry amount; dim(ncol,nlay) + ! ---------------------------------------------------------- + ! Local variables + real(wp), dimension(ncol,nlay,ngpt) :: tau, tau_rayleigh ! absorption, Rayleigh scattering optical depths + ! Number of molecules per cm^2 + real(wp), dimension(ncol,nlay), target :: col_dry_arr + real(wp), dimension(:,:), pointer :: col_dry_wk + ! + ! Interpolation variables used in major gas but not elsewhere, so don't need exporting + ! + real(wp), dimension(ncol,nlay, this%get_ngas()) :: vmr ! volume mixing ratios + real(wp), dimension(ncol,nlay,0:this%get_ngas()) :: col_gas ! column amounts for each gas, plus col_dry + real(wp), dimension(2, ncol,nlay,get_nflav(this)) :: col_mix ! combination of major species's column amounts + ! index(1) : reference temperature level + ! index(2) : flavor + ! index(3) : layer + real(wp), dimension(2,2, ncol,nlay,get_nflav(this)) :: fminor ! interpolation fractions for minor species + ! index(1) : reference eta level (temperature dependent) + ! index(2) : reference temperature level + ! index(3) : flavor + ! index(4) : layer + integer :: ngas, nflav, neta, npres, ntemp + integer :: icol, ilay, igas + integer :: idx_h2o ! index of water vapor + integer :: nminorlower, nminorklower,nminorupper, nminorkupper + logical :: use_rayl + ! ---------------------------------------------------------- + ! + ! Error checking + ! + use_rayl = allocated(this%krayl) + error_msg = '' + ! Check for initialization + if (.not. this%is_loaded()) then + error_msg = 'ERROR: spectral configuration not loaded' + return + end if + ! + ! Check for presence of key species in ty_gas_concs; return error if any key species are not present + ! + error_msg = this%check_key_species_present(gas_desc) + if (error_msg /= '') return + + ! + ! Check input data sizes and values + ! + !$acc data copyin(play,plev,tlay) create( vmr,col_gas) + !$omp target data map(to:play,plev,tlay) map(alloc:vmr,col_gas) + if(check_extents) then + if(.not. extents_are(play, ncol, nlay )) & + error_msg = "gas_optics(): array play has wrong size" + if(.not. extents_are(tlay, ncol, nlay )) & + error_msg = "gas_optics(): array tlay has wrong size" + if(.not. extents_are(plev, ncol, nlay+1)) & + error_msg = "gas_optics(): array plev has wrong size" + if(optical_props%get_ncol() /= ncol .or. & + optical_props%get_nlay() /= nlay .or. & + optical_props%get_ngpt() /= ngpt) & + error_msg = "gas_optics(): optical properties have the wrong extents" + if(present(col_dry)) then + if(.not. extents_are(col_dry, ncol, nlay)) & + error_msg = "gas_optics(): array col_dry has wrong size" + end if + end if + + if(error_msg == '') then + if(check_values) then + if(any_vals_outside(play, this%press_ref_min,this%press_ref_max)) & + error_msg = "gas_optics(): array play has values outside range" + if(any_vals_less_than(plev, 0._wp)) & + error_msg = "gas_optics(): array plev has values outside range" + if(any_vals_outside(tlay, this%temp_ref_min, this%temp_ref_max)) & + error_msg = "gas_optics(): array tlay has values outside range" + if(present(col_dry)) then + if(any_vals_less_than(col_dry, 0._wp)) & + error_msg = "gas_optics(): array col_dry has values outside range" + end if + end if + end if + + ! ---------------------------------------------------------- + if(error_msg == '') then + ngas = this%get_ngas() + nflav = get_nflav(this) + neta = this%get_neta() + npres = this%get_npres() + ntemp = this%get_ntemp() + ! number of minor contributors, total num absorption coeffs + nminorlower = size(this%minor_scales_with_density_lower) + nminorklower = size(this%kminor_lower, 3) + nminorupper = size(this%minor_scales_with_density_upper) + nminorkupper = size(this%kminor_upper, 3) + ! + ! Fill out the array of volume mixing ratios + ! + do igas = 1, ngas + ! + ! Get vmr if gas is provided in ty_gas_concs + ! + if (any (lower_case(this%gas_names(igas)) == gas_desc%get_gas_names())) then + error_msg = gas_desc%get_vmr(this%gas_names(igas), vmr(:,:,igas)) + endif + end do + end if + + if(error_msg == '') then + +! +! Painful hacks to get code to compile with both the CCE-14 and Nvidia 21.3 compiler +! +#ifdef _CRAYFTN + !$acc enter data copyin(optical_props) +#endif + select type(optical_props) + type is (ty_optical_props_1scl) +#ifndef _CRAYFTN + !$acc enter data copyin(optical_props) +#endif + !$acc enter data create( optical_props%tau) + !$omp target enter data map(alloc:optical_props%tau) + type is (ty_optical_props_2str) +#ifndef _CRAYFTN + !$acc enter data copyin(optical_props) +#endif + !$acc enter data create( optical_props%tau, optical_props%ssa, optical_props%g) + !$omp target enter data map(alloc:optical_props%tau, optical_props%ssa, optical_props%g) + type is (ty_optical_props_nstr) +#ifndef _CRAYFTN + !$acc enter data copyin(optical_props) +#endif + !$acc enter data create( optical_props%tau, optical_props%ssa, optical_props%p) + !$omp target enter data map(alloc:optical_props%tau, optical_props%ssa, optical_props%p) + end select + + ! + ! Compute dry air column amounts (number of molecule per cm^2) if user hasn't provided them + ! + idx_h2o = string_loc_in_array('h2o', this%gas_names) + if (present(col_dry)) then + !$acc enter data copyin(col_dry) + !$omp target enter data map(to:col_dry) + col_dry_wk => col_dry + else + !$acc enter data create( col_dry_arr) + !$omp target enter data map(alloc:col_dry_arr) + col_dry_arr = get_col_dry(vmr(:,:,idx_h2o), plev) ! dry air column amounts computation + col_dry_wk => col_dry_arr + end if + ! + ! compute column gas amounts [molec/cm^2] + ! + !$acc parallel loop gang vector collapse(2) + !$omp target teams distribute parallel do simd collapse(2) + do ilay = 1, nlay + do icol = 1, ncol + col_gas(icol,ilay,0) = col_dry_wk(icol,ilay) + end do + end do + !$acc parallel loop gang vector collapse(3) + !$omp target teams distribute parallel do simd collapse(3) + do igas = 1, ngas + do ilay = 1, nlay + do icol = 1, ncol + col_gas(icol,ilay,igas) = vmr(icol,ilay,igas) * col_dry_wk(icol,ilay) + end do + end do + end do + ! + ! ---- calculate gas optical depths ---- + ! + !$acc data copyout( jtemp, jpress, jeta, tropo, fmajor) create( col_mix, fminor) + !$omp target data map(from:jtemp, jpress, jeta, tropo, fmajor) map(alloc:col_mix, fminor) + call interpolation( & + ncol,nlay, & ! problem dimensions + ngas, nflav, neta, npres, ntemp, & ! interpolation dimensions + this%flavor, & + this%press_ref_log, & + this%temp_ref, & + this%press_ref_log_delta, & + this%temp_ref_min, & + this%temp_ref_delta, & + this%press_ref_trop_log, & + this%vmr_ref, & + play, & + tlay, & + col_gas, & + jtemp, & ! outputs + fmajor,fminor,& + col_mix, & + tropo, & + jeta,jpress) + if (allocated(this%krayl)) then + !$acc data copyin(this%gpoint_flavor, this%krayl) create(tau, tau_rayleigh) + !$omp target data map(to:this%gpoint_flavor, this%krayl) map(alloc:tau, tau_rayleigh) + call zero_array(ncol, nlay, ngpt, tau) + call compute_tau_absorption( & + ncol,nlay,nband,ngpt, & ! dimensions + ngas,nflav,neta,npres,ntemp, & + nminorlower, nminorklower, & ! number of minor contributors, total num absorption coeffs + nminorupper, nminorkupper, & + idx_h2o, & + this%gpoint_flavor, & + this%get_band_lims_gpoint(), & + this%kmajor, & + this%kminor_lower, & + this%kminor_upper, & + this%minor_limits_gpt_lower, & + this%minor_limits_gpt_upper, & + this%minor_scales_with_density_lower, & + this%minor_scales_with_density_upper, & + this%scale_by_complement_lower, & + this%scale_by_complement_upper, & + this%idx_minor_lower, & + this%idx_minor_upper, & + this%idx_minor_scaling_lower, & + this%idx_minor_scaling_upper, & + this%kminor_start_lower, & + this%kminor_start_upper, & + tropo, & + col_mix,fmajor,fminor, & + play,tlay,col_gas, & + jeta,jtemp,jpress, & + tau) + call compute_tau_rayleigh( & !Rayleigh scattering optical depths + ncol,nlay,nband,ngpt, & + ngas,nflav,neta,npres,ntemp, & ! dimensions + this%gpoint_flavor, & + this%get_band_lims_gpoint(), & + this%krayl, & ! inputs from object + idx_h2o, col_dry_wk,col_gas, & + fminor,jeta,tropo,jtemp, & ! local input + tau_rayleigh) + call combine_abs_and_rayleigh(tau, tau_rayleigh, optical_props) + !$acc end data + !$omp end target data + else + call zero_array(ncol, nlay, ngpt, optical_props%tau) + call compute_tau_absorption( & + ncol,nlay,nband,ngpt, & ! dimensions + ngas,nflav,neta,npres,ntemp, & + nminorlower, nminorklower, & ! number of minor contributors, total num absorption coeffs + nminorupper, nminorkupper, & + idx_h2o, & + this%gpoint_flavor, & + this%get_band_lims_gpoint(), & + this%kmajor, & + this%kminor_lower, & + this%kminor_upper, & + this%minor_limits_gpt_lower, & + this%minor_limits_gpt_upper, & + this%minor_scales_with_density_lower, & + this%minor_scales_with_density_upper, & + this%scale_by_complement_lower, & + this%scale_by_complement_upper, & + this%idx_minor_lower, & + this%idx_minor_upper, & + this%idx_minor_scaling_lower, & + this%idx_minor_scaling_upper, & + this%kminor_start_lower, & + this%kminor_start_upper, & + tropo, & + col_mix,fmajor,fminor, & + play,tlay,col_gas, & + jeta,jtemp,jpress, & + optical_props%tau) ! + select type(optical_props) + type is (ty_optical_props_2str) + call zero_array(ncol, nlay, ngpt, optical_props%ssa) + call zero_array(ncol, nlay, ngpt, optical_props%g) + type is (ty_optical_props_nstr) + call zero_array(ncol, nlay, ngpt, optical_props%ssa) + call zero_array(optical_props%get_nmom(), & + ncol, nlay, ngpt, optical_props%p) + end select + end if + !$acc end data + !$omp end target data + if (present(col_dry)) then + !$acc exit data delete( col_dry) + !$omp target exit data map(release:col_dry) + else + !$acc exit data delete( col_dry_arr) + !$omp target exit data map(release:col_dry_arr) + end if + + select type(optical_props) + type is (ty_optical_props_1scl) + !$acc exit data copyout( optical_props%tau) + !$omp target exit data map(from:optical_props%tau) + type is (ty_optical_props_2str) + !$acc exit data copyout( optical_props%tau, optical_props%ssa, optical_props%g) + !$omp target exit data map(from:optical_props%tau, optical_props%ssa, optical_props%g) + type is (ty_optical_props_nstr) + !$acc exit data copyout( optical_props%tau, optical_props%ssa, optical_props%p) + !$omp target exit data map(from:optical_props%tau, optical_props%ssa, optical_props%p) + end select + !$acc exit data delete(optical_props) + + end if + !$acc end data + !$omp end target data + + end function compute_gas_taus + !------------------------------------------------------------------------------------------ + ! + !> Compute the spectral solar source function adjusted to account for solar variability + !> following the NRLSSI2 model of Coddington et al. 2016, doi:10.1175/BAMS-D-14-00265.1. + !> as specified by the facular brightening (mg_index) and sunspot dimming (sb_index) + !> indices provided as input. + !> + !> Users provide the NRLSSI2 facular ("Bremen") index and sunspot ("SPOT67") index. + !> Changing either of these indicies will change the total solar irradiance (TSI) + !> Code in extensions/mo_solar_variability may be used to compute the value of these + !> indices through an average solar cycle + !> Users may also specify the TSI, either alone or in conjunction with the facular and sunspot indices + ! + !------------------------------------------------------------------------------------------ + function set_solar_variability(this, & + mg_index, sb_index, tsi) & + result(error_msg) + ! + !! Updates the spectral distribution and, optionally, + !! the integrated value of the solar source function + !! Modifying either index will change the total solar irradiance + ! + class(ty_gas_optics_rrtmgp), intent(inout) :: this + ! + real(wp), intent(in) :: mg_index !! facular brightening index (NRLSSI2 facular "Bremen" index) + real(wp), intent(in) :: sb_index !! sunspot dimming index (NRLSSI2 sunspot "SPOT67" index) + real(wp), optional, intent(in) :: tsi !! total solar irradiance + character(len=128) :: error_msg !! Empty if successful + ! ---------------------------------------------------------- + integer :: igpt + real(wp), parameter :: a_offset = 0.1495954_wp + real(wp), parameter :: b_offset = 0.00066696_wp + ! ---------------------------------------------------------- + error_msg = "" + if(mg_index < 0._wp) error_msg = 'mg_index out of range' + if(sb_index < 0._wp) error_msg = 'sb_index out of range' + if(error_msg /= "") return + ! + ! Calculate solar source function for provided facular and sunspot indices + ! + !$acc parallel loop + !$omp target teams distribute parallel do simd + do igpt = 1, size(this%solar_source_quiet) + this%solar_source(igpt) = this%solar_source_quiet(igpt) + & + (mg_index - a_offset) * this%solar_source_facular(igpt) + & + (sb_index - b_offset) * this%solar_source_sunspot(igpt) + end do + ! + ! Scale solar source to input TSI value + ! + if (present(tsi)) error_msg = this%set_tsi(tsi) + + end function set_solar_variability + !------------------------------------------------------------------------------------------ + function set_tsi(this, tsi) result(error_msg) + ! + !> Scale the solar source function without changing the spectral distribution + ! + class(ty_gas_optics_rrtmgp), intent(inout) :: this + real(wp), intent(in ) :: tsi !! user-specified total solar irradiance; + character(len=128) :: error_msg !! Empty if successful + + real(wp) :: norm + integer :: igpt, length ! ---------------------------------------------------------- error_msg = "" if(tsi < 0._wp) then @@ -966,1308 +966,1325 @@

Source Code

! ! Scale the solar source function to the input tsi ! - !$acc kernels - !$omp target - norm = 1._wp/sum(this%solar_source(:)) - this%solar_source(:) = this%solar_source(:) * tsi * norm - !$acc end kernels - !$omp end target - end if + norm = 0._wp + length = size(this%solar_source) + !$acc parallel loop gang vector reduction(+:norm) + !$omp target teams distribute parallel do simd reduction(+:norm) + do igpt = 1, length + norm = norm + this%solar_source(igpt) + end do - end function set_tsi - !------------------------------------------------------------------------------------------ - ! - ! Compute Planck source functions at layer centers and levels - ! - function source(this, & - ncol, nlay, nbnd, ngpt, & - play, plev, tlay, tsfc, & - jtemp, jpress, jeta, tropo, fmajor, & - sources, & ! Planck sources - tlev) & ! optional input - result(error_msg) - ! inputs - class(ty_gas_optics_rrtmgp), intent(in ) :: this - integer, intent(in ) :: ncol, nlay, nbnd, ngpt - real(wp), dimension(ncol,nlay), intent(in ) :: play ! layer pressures [Pa, mb] - real(wp), dimension(ncol,nlay+1), intent(in ) :: plev ! level pressures [Pa, mb] - real(wp), dimension(ncol,nlay), intent(in ) :: tlay ! layer temperatures [K] - real(wp), dimension(ncol), intent(in ) :: tsfc ! surface skin temperatures [K] - ! Interplation coefficients - integer, dimension(ncol,nlay), intent(in ) :: jtemp, jpress - logical(wl), dimension(ncol,nlay), intent(in ) :: tropo - real(wp), dimension(2,2,2,ncol,nlay,get_nflav(this)), & - intent(in ) :: fmajor - integer, dimension(2, ncol,nlay,get_nflav(this)), & - intent(in ) :: jeta - class(ty_source_func_lw ), intent(inout) :: sources - real(wp), dimension(ncol,nlay+1), intent(in ), & - optional, target :: tlev ! level temperatures [K] - character(len=128) :: error_msg - ! ---------------------------------------------------------- - logical(wl) :: top_at_1 - integer :: icol, ilay - ! Variables for temperature at layer edges [K] (ncol, nlay+1) - real(wp), dimension( ncol,nlay+1), target :: tlev_arr - real(wp), dimension(:,:), pointer :: tlev_wk - ! ---------------------------------------------------------- - error_msg = "" - ! - ! Source function needs temperature at interfaces/levels and at layer centers - ! - if (present(tlev)) then - ! Users might have provided these - tlev_wk => tlev - else - tlev_wk => tlev_arr - ! - ! Interpolate temperature to levels if not provided - ! Interpolation and extrapolation at boundaries is weighted by pressure - ! - do icol = 1, ncol - tlev_arr(icol,1) = tlay(icol,1) & - + (plev(icol,1)-play(icol,1))*(tlay(icol,2)-tlay(icol,1)) & - & / (play(icol,2)-play(icol,1)) - end do - do ilay = 2, nlay - do icol = 1, ncol - tlev_arr(icol,ilay) = (play(icol,ilay-1)*tlay(icol,ilay-1)*(plev(icol,ilay )-play(icol,ilay)) & - + play(icol,ilay )*tlay(icol,ilay )*(play(icol,ilay-1)-plev(icol,ilay))) / & - (plev(icol,ilay)*(play(icol,ilay-1) - play(icol,ilay))) - end do - end do - do icol = 1, ncol - tlev_arr(icol,nlay+1) = tlay(icol,nlay) & - + (plev(icol,nlay+1)-play(icol,nlay))*(tlay(icol,nlay)-tlay(icol,nlay-1)) & - / (play(icol,nlay)-play(icol,nlay-1)) - end do - end if - - !------------------------------------------------------------------- - ! Compute internal (Planck) source functions at layers and levels, - ! which depend on mapping from spectral space that creates k-distribution. - !$acc data copyin(sources) copyout( sources%lay_source, sources%lev_source_inc, sources%lev_source_dec) & - !$acc copyout( sources%sfc_source, sources%sfc_source_Jac) - !$omp target data map(from:sources%lay_source, sources%lev_source_inc, sources%lev_source_dec) & - !$omp map(from:sources%sfc_source, sources%sfc_source_Jac) - - !$acc kernels copyout(top_at_1) - !$omp target map(from:top_at_1) - top_at_1 = play(1,1) < play(1, nlay) - !$acc end kernels - !$omp end target - - call compute_Planck_source(ncol, nlay, nbnd, ngpt, & - get_nflav(this), this%get_neta(), this%get_npres(), this%get_ntemp(), this%get_nPlanckTemp(), & - tlay, tlev_wk, tsfc, merge(nlay, 1, top_at_1), & - fmajor, jeta, tropo, jtemp, jpress, & - this%get_gpoint_bands(), this%get_band_lims_gpoint(), this%planck_frac, this%temp_ref_min,& - this%totplnk_delta, this%totplnk, this%gpoint_flavor, & - sources%sfc_source, sources%lay_source, sources%lev_source_inc, sources%lev_source_dec, & - sources%sfc_source_Jac) - !$acc end data - !$omp end target data - end function source - !-------------------------------------------------------------------------------------------------------------------- - ! - ! Initialization - ! - !-------------------------------------------------------------------------------------------------------------------- - ! Initialize object based on data read from netCDF file however the user desires. - ! Rayleigh scattering tables may or may not be present; this is indicated with allocation status - ! This interface is for the internal-sources object -- includes Plank functions and fractions - ! - function load_int(this, available_gases, gas_names, key_species, & - band2gpt, band_lims_wavenum, & - press_ref, press_ref_trop, temp_ref, & - temp_ref_p, temp_ref_t, vmr_ref, & - kmajor, kminor_lower, kminor_upper, & - gas_minor,identifier_minor, & - minor_gases_lower, minor_gases_upper, & - minor_limits_gpt_lower, minor_limits_gpt_upper, & - minor_scales_with_density_lower, & - minor_scales_with_density_upper, & - scaling_gas_lower, scaling_gas_upper, & - scale_by_complement_lower, & - scale_by_complement_upper, & - kminor_start_lower, & - kminor_start_upper, & - totplnk, planck_frac, & - rayl_lower, rayl_upper, & - optimal_angle_fit) result(err_message) - class(ty_gas_optics_rrtmgp), intent(inout) :: this - class(ty_gas_concs), intent(in ) :: available_gases ! Which gases does the host model have available? - character(len=*), dimension(:), intent(in ) :: gas_names - integer, dimension(:,:,:), intent(in ) :: key_species - integer, dimension(:,:), intent(in ) :: band2gpt - real(wp), dimension(:,:), intent(in ) :: band_lims_wavenum - real(wp), dimension(:), intent(in ) :: press_ref, temp_ref - real(wp), intent(in ) :: press_ref_trop, temp_ref_p, temp_ref_t - real(wp), dimension(:,:,:), intent(in ) :: vmr_ref - real(wp), dimension(:,:,:,:), intent(in ) :: kmajor - real(wp), dimension(:,:,:), intent(in ) :: kminor_lower, kminor_upper - real(wp), dimension(:,:), intent(in ) :: totplnk - real(wp), dimension(:,:,:,:), intent(in ) :: planck_frac - real(wp), dimension(:,:,:), intent(in ), & - allocatable :: rayl_lower, rayl_upper - real(wp), dimension(:,:), intent(in ) :: optimal_angle_fit - character(len=*), dimension(:), intent(in ) :: gas_minor,identifier_minor - character(len=*), dimension(:), intent(in ) :: minor_gases_lower, & - minor_gases_upper - integer, dimension(:,:), intent(in ) :: minor_limits_gpt_lower, & - minor_limits_gpt_upper - logical(wl), dimension(:), intent(in ) :: minor_scales_with_density_lower, & - minor_scales_with_density_upper - character(len=*), dimension(:), intent(in ) :: scaling_gas_lower, & - scaling_gas_upper - logical(wl), dimension(:), intent(in ) :: scale_by_complement_lower,& - scale_by_complement_upper - integer, dimension(:), intent(in ) :: kminor_start_lower,& - kminor_start_upper - character(len = 128) :: err_message - ! ---- - !$acc enter data copyin(this) - call this%finalize() - err_message = init_abs_coeffs(this, & - available_gases, & - gas_names, key_species, & - band2gpt, band_lims_wavenum, & - press_ref, temp_ref, & - press_ref_trop, temp_ref_p, temp_ref_t, & - vmr_ref, & - kmajor, kminor_lower, kminor_upper, & - gas_minor,identifier_minor,& - minor_gases_lower, minor_gases_upper, & - minor_limits_gpt_lower, & - minor_limits_gpt_upper, & - minor_scales_with_density_lower, & - minor_scales_with_density_upper, & - scaling_gas_lower, scaling_gas_upper, & - scale_by_complement_lower, & - scale_by_complement_upper, & - kminor_start_lower, & - kminor_start_upper, & - rayl_lower, rayl_upper) - ! Planck function tables - ! - allocate(this%totplnk (size(totplnk, 1), size(totplnk, 2)), & - this%planck_frac (size(planck_frac,4), size(planck_frac,2),size(planck_frac,3), size(planck_frac,1)), & - this%optimal_angle_fit(size(optimal_angle_fit, 1), size(optimal_angle_fit, 2))) - this%totplnk = totplnk -! this%planck_frac = planck_frac - this%planck_frac = RESHAPE(planck_frac,(/size(planck_frac,4), size(planck_frac,2), & - size(planck_frac,3), size(planck_frac,1)/),ORDER =(/4,2,3,1/)) - this%optimal_angle_fit = optimal_angle_fit - !$acc enter data copyin(this%totplnk, this%planck_frac, this%optimal_angle_fit) - !$omp target enter data map(to:this%totplnk, this%planck_frac, this%optimal_angle_fit) - - ! Temperature steps for Planck function interpolation - ! Assumes that temperature minimum and max are the same for the absorption coefficient grid and the - ! Planck grid and the Planck grid is equally spaced - this%totplnk_delta = (this%temp_ref_max-this%temp_ref_min) / (size(this%totplnk,dim=1)-1) - end function load_int - - !-------------------------------------------------------------------------------------------------------------------- - ! - ! Initialize object based on data read from netCDF file however the user desires. - ! Rayleigh scattering tables may or may not be present; this is indicated with allocation status - ! This interface is for the external-sources object -- includes TOA source function table - ! - function load_ext(this, available_gases, gas_names, key_species, & - band2gpt, band_lims_wavenum, & - press_ref, press_ref_trop, temp_ref, & - temp_ref_p, temp_ref_t, vmr_ref, & - kmajor, kminor_lower, kminor_upper, & - gas_minor,identifier_minor, & - minor_gases_lower, minor_gases_upper, & - minor_limits_gpt_lower, minor_limits_gpt_upper, & - minor_scales_with_density_lower, & - minor_scales_with_density_upper, & - scaling_gas_lower, scaling_gas_upper, & - scale_by_complement_lower, & - scale_by_complement_upper, & - kminor_start_lower, & - kminor_start_upper, & - solar_quiet, solar_facular, solar_sunspot, & - tsi_default, mg_default, sb_default, & - rayl_lower, rayl_upper) result(err_message) - class(ty_gas_optics_rrtmgp), intent(inout) :: this - class(ty_gas_concs), intent(in ) :: available_gases ! Which gases does the host model have available? - character(len=*), & - dimension(:), intent(in) :: gas_names - integer, dimension(:,:,:), intent(in) :: key_species - integer, dimension(:,:), intent(in) :: band2gpt - real(wp), dimension(:,:), intent(in) :: band_lims_wavenum - real(wp), dimension(:), intent(in) :: press_ref, temp_ref - real(wp), intent(in) :: press_ref_trop, temp_ref_p, temp_ref_t - real(wp), dimension(:,:,:), intent(in) :: vmr_ref - real(wp), dimension(:,:,:,:), intent(in) :: kmajor - real(wp), dimension(:,:,:), intent(in) :: kminor_lower, kminor_upper - character(len=*), dimension(:), & - intent(in) :: gas_minor, & - identifier_minor - character(len=*), dimension(:), & - intent(in) :: minor_gases_lower, & - minor_gases_upper - integer, dimension(:,:), intent(in) :: & - minor_limits_gpt_lower, & - minor_limits_gpt_upper - logical(wl), dimension(:), intent(in) :: & - minor_scales_with_density_lower, & - minor_scales_with_density_upper - character(len=*),dimension(:),intent(in) :: & - scaling_gas_lower, & - scaling_gas_upper - logical(wl), dimension(:), intent(in) :: & - scale_by_complement_lower, & - scale_by_complement_upper - integer, dimension(:), intent(in) :: & - kminor_start_lower, & - kminor_start_upper - real(wp), dimension(:), intent(in) :: solar_quiet, & - solar_facular, & - solar_sunspot - real(wp), intent(in) :: tsi_default, & - mg_default, sb_default - real(wp), dimension(:,:,:), intent(in), & - allocatable :: rayl_lower, rayl_upper - character(len = 128) err_message - - integer :: ngpt - ! ---- - !$acc enter data copyin(this) - call this%finalize() - err_message = init_abs_coeffs(this, & - available_gases, & - gas_names, key_species, & - band2gpt, band_lims_wavenum, & - press_ref, temp_ref, & - press_ref_trop, temp_ref_p, temp_ref_t, & - vmr_ref, & - kmajor, kminor_lower, kminor_upper, & - gas_minor,identifier_minor, & - minor_gases_lower, minor_gases_upper, & - minor_limits_gpt_lower, & - minor_limits_gpt_upper, & - minor_scales_with_density_lower, & - minor_scales_with_density_upper, & - scaling_gas_lower, scaling_gas_upper, & - scale_by_complement_lower, & - scale_by_complement_upper, & - kminor_start_lower, & - kminor_start_upper, & - rayl_lower, rayl_upper) - if(err_message == "") then - ! - ! Spectral solar irradiance terms init - ! - ngpt = size(solar_quiet) - allocate(this%solar_source_quiet(ngpt), this%solar_source_facular(ngpt), & - this%solar_source_sunspot(ngpt), this%solar_source(ngpt)) - !$acc enter data create( this%solar_source_quiet, this%solar_source_facular, this%solar_source_sunspot, this%solar_source) - !$omp target enter data map(alloc:this%solar_source_quiet, this%solar_source_facular, this%solar_source_sunspot, this%solar_source) - !$acc kernels - !$omp target - this%solar_source_quiet = solar_quiet - this%solar_source_facular = solar_facular - this%solar_source_sunspot = solar_sunspot - !$acc end kernels - !$omp end target - err_message = this%set_solar_variability(mg_default, sb_default) - endif - end function load_ext - !-------------------------------------------------------------------------------------------------------------------- - ! - ! Initialize absorption coefficient arrays, - ! including Rayleigh scattering tables if provided (allocated) - ! - function init_abs_coeffs(this, & - available_gases, & - gas_names, key_species, & - band2gpt, band_lims_wavenum, & - press_ref, temp_ref, & - press_ref_trop, temp_ref_p, temp_ref_t, & - vmr_ref, & - kmajor, kminor_lower, kminor_upper, & - gas_minor,identifier_minor,& - minor_gases_lower, minor_gases_upper, & - minor_limits_gpt_lower, & - minor_limits_gpt_upper, & - minor_scales_with_density_lower, & - minor_scales_with_density_upper, & - scaling_gas_lower, scaling_gas_upper, & - scale_by_complement_lower, & - scale_by_complement_upper, & - kminor_start_lower, & - kminor_start_upper, & - rayl_lower, rayl_upper) result(err_message) - class(ty_gas_optics_rrtmgp), intent(inout) :: this - class(ty_gas_concs), intent(in ) :: available_gases - character(len=*), & - dimension(:), intent(in) :: gas_names - integer, dimension(:,:,:), intent(in) :: key_species - integer, dimension(:,:), intent(in) :: band2gpt - real(wp), dimension(:,:), intent(in) :: band_lims_wavenum - real(wp), dimension(:), intent(in) :: press_ref, temp_ref - real(wp), intent(in) :: press_ref_trop, temp_ref_p, temp_ref_t - real(wp), dimension(:,:,:), intent(in) :: vmr_ref - real(wp), dimension(:,:,:,:), intent(in) :: kmajor - real(wp), dimension(:,:,:), intent(in) :: kminor_lower, kminor_upper - character(len=*), dimension(:), & - intent(in) :: gas_minor, & - identifier_minor - character(len=*), dimension(:), & - intent(in) :: minor_gases_lower, & - minor_gases_upper - integer, dimension(:,:), intent(in) :: minor_limits_gpt_lower, & - minor_limits_gpt_upper - logical(wl), dimension(:), intent(in) :: minor_scales_with_density_lower, & - minor_scales_with_density_upper - character(len=*), dimension(:),& - intent(in) :: scaling_gas_lower, & - scaling_gas_upper - logical(wl), dimension(:), intent(in) :: scale_by_complement_lower, & - scale_by_complement_upper - integer, dimension(:), intent(in) :: kminor_start_lower, & - kminor_start_upper - real(wp), dimension(:,:,:), intent(in), & - allocatable :: rayl_lower, rayl_upper - character(len=128) :: err_message - ! -------------------------------------------------------------------------- - logical, dimension(:), allocatable :: gas_is_present - logical, dimension(:), allocatable :: key_species_present_init - integer, dimension(:,:,:), allocatable :: key_species_red - real(wp), dimension(:,:,:), allocatable :: vmr_ref_red - character(len=256), & - dimension(:), allocatable :: minor_gases_lower_red, & - minor_gases_upper_red - character(len=256), & - dimension(:), allocatable :: scaling_gas_lower_red, & - scaling_gas_upper_red - integer :: i, j, idx - integer :: ngas - ! -------------------------------------- - err_message = this%ty_optical_props%init(band_lims_wavenum, band2gpt) - if(len_trim(err_message) /= 0) return - ! - ! Which gases known to the gas optics are present in the host model (available_gases)? - ! - ngas = size(gas_names) - allocate(gas_is_present(ngas)) - do i = 1, ngas - ! Next line causes a compiler bug in gfortran 11.0.1 on Mac ARM - ! Should replace gas_names with get_gas_names() and make gas_names private in ty_gas_concs - gas_is_present(i) = string_in_array(gas_names(i), available_gases%gas_names) - end do - ! - ! Now the number of gases is the union of those known to the k-distribution and provided - ! by the host model - ! - ngas = count(gas_is_present) + norm = 1._wp/norm + + !$acc parallel loop gang vector + !$omp target teams distribute parallel do simd + do igpt = 1, length + this%solar_source(igpt) = this%solar_source(igpt) * tsi * norm + end do + end if + + end function set_tsi + !------------------------------------------------------------------------------------------ + ! + ! Compute Planck source functions at layer centers and levels + ! + function source(this, & + ncol, nlay, nbnd, ngpt, & + play, plev, tlay, tsfc, & + jtemp, jpress, jeta, tropo, fmajor, & + sources, & ! Planck sources + tlev) & ! optional input + result(error_msg) + ! inputs + class(ty_gas_optics_rrtmgp), intent(in ) :: this + integer, intent(in ) :: ncol, nlay, nbnd, ngpt + real(wp), dimension(ncol,nlay), intent(in ) :: play ! layer pressures [Pa, mb] + real(wp), dimension(ncol,nlay+1), intent(in ) :: plev ! level pressures [Pa, mb] + real(wp), dimension(ncol,nlay), intent(in ) :: tlay ! layer temperatures [K] + real(wp), dimension(ncol), intent(in ) :: tsfc ! surface skin temperatures [K] + ! Interplation coefficients + integer, dimension(ncol,nlay), intent(in ) :: jtemp, jpress + logical(wl), dimension(ncol,nlay), intent(in ) :: tropo + real(wp), dimension(2,2,2,ncol,nlay,get_nflav(this)), & + intent(in ) :: fmajor + integer, dimension(2, ncol,nlay,get_nflav(this)), & + intent(in ) :: jeta + class(ty_source_func_lw ), intent(inout) :: sources + real(wp), dimension(ncol,nlay+1), intent(in ), & + optional, target :: tlev ! level temperatures [K] + character(len=128) :: error_msg + ! ---------------------------------------------------------- + logical(wl) :: top_at_1 + integer :: icol, ilay + ! Variables for temperature at layer edges [K] (ncol, nlay+1) + real(wp), dimension( ncol,nlay+1), target :: tlev_arr + real(wp), dimension(:,:), pointer :: tlev_wk + ! ---------------------------------------------------------- + error_msg = "" + ! + ! Source function needs temperature at interfaces/levels and at layer centers + ! Allocate small local array for tlev unconditionally + ! + !$acc data copyin(sources) copyout( sources%lay_source, sources%lev_source) & + !$acc copyout( sources%sfc_source, sources%sfc_source_Jac) & + !$acc create(tlev_arr) + !$omp target data map(from:sources%lay_source, sources%lev_source) & + !$omp map(from:sources%sfc_source, sources%sfc_source_Jac) & + !$omp map(alloc:tlev_arr) + + if (present(tlev)) then + ! Users might have provided these + tlev_wk => tlev + else + tlev_wk => tlev_arr + ! + ! Interpolate temperature to levels if not provided + ! Interpolation and extrapolation at boundaries is weighted by pressure + ! + !$acc parallel loop gang vector + !$omp target teams distribute parallel do simd + do icol = 1, ncol + tlev_arr(icol,1) = tlay(icol,1) & + + (plev(icol,1)-play(icol,1))*(tlay(icol,2)-tlay(icol,1)) & + / (play(icol,2)-play(icol,1)) + tlev_arr(icol,nlay+1) = tlay(icol,nlay) & + + (plev(icol,nlay+1)-play(icol,nlay))*(tlay(icol,nlay)-tlay(icol,nlay-1)) & + / (play(icol,nlay)-play(icol,nlay-1)) + end do + !$acc parallel loop gang vector collapse(2) + !$omp target teams distribute parallel do simd collapse(2) + do ilay = 2, nlay + do icol = 1, ncol + tlev_arr(icol,ilay) = (play(icol,ilay-1)*tlay(icol,ilay-1)*(plev(icol,ilay )-play(icol,ilay)) & + + play(icol,ilay )*tlay(icol,ilay )*(play(icol,ilay-1)-plev(icol,ilay))) / & + (plev(icol,ilay)*(play(icol,ilay-1) - play(icol,ilay))) + end do + end do + end if + + !------------------------------------------------------------------- + ! Compute internal (Planck) source functions at layers and levels, + ! which depend on mapping from spectral space that creates k-distribution. + + !$acc kernels copyout(top_at_1) + !$omp target map(from:top_at_1) + top_at_1 = play(1,1) < play(1, nlay) + !$acc end kernels + !$omp end target + + call compute_Planck_source(ncol, nlay, nbnd, ngpt, & + get_nflav(this), this%get_neta(), this%get_npres(), this%get_ntemp(), this%get_nPlanckTemp(), & + tlay, tlev_wk, tsfc, merge(nlay, 1, top_at_1), & + fmajor, jeta, tropo, jtemp, jpress, & + this%get_gpoint_bands(), this%get_band_lims_gpoint(), this%planck_frac, this%temp_ref_min,& + this%totplnk_delta, this%totplnk, this%gpoint_flavor, & + sources%sfc_source, sources%lay_source, sources%lev_source, & + sources%sfc_source_Jac) + !$acc end data + !$omp end target data + end function source + !-------------------------------------------------------------------------------------------------------------------- + ! + ! Initialization + ! + !-------------------------------------------------------------------------------------------------------------------- + ! Initialize object based on data read from netCDF file however the user desires. + ! Rayleigh scattering tables may or may not be present; this is indicated with allocation status + ! This interface is for the internal-sources object -- includes Plank functions and fractions + ! + function load_int(this, available_gases, gas_names, key_species, & + band2gpt, band_lims_wavenum, & + press_ref, press_ref_trop, temp_ref, & + temp_ref_p, temp_ref_t, vmr_ref, & + kmajor, kminor_lower, kminor_upper, & + gas_minor,identifier_minor, & + minor_gases_lower, minor_gases_upper, & + minor_limits_gpt_lower, minor_limits_gpt_upper, & + minor_scales_with_density_lower, & + minor_scales_with_density_upper, & + scaling_gas_lower, scaling_gas_upper, & + scale_by_complement_lower, & + scale_by_complement_upper, & + kminor_start_lower, & + kminor_start_upper, & + totplnk, planck_frac, & + rayl_lower, rayl_upper, & + optimal_angle_fit) result(err_message) + class(ty_gas_optics_rrtmgp), intent(inout) :: this + class(ty_gas_concs), intent(in ) :: available_gases ! Which gases does the host model have available? + character(len=*), dimension(:), intent(in ) :: gas_names + integer, dimension(:,:,:), intent(in ) :: key_species + integer, dimension(:,:), intent(in ) :: band2gpt + real(wp), dimension(:,:), intent(in ) :: band_lims_wavenum + real(wp), dimension(:), intent(in ) :: press_ref, temp_ref + real(wp), intent(in ) :: press_ref_trop, temp_ref_p, temp_ref_t + real(wp), dimension(:,:,:), intent(in ) :: vmr_ref + real(wp), dimension(:,:,:,:), intent(in ) :: kmajor + real(wp), dimension(:,:,:), intent(in ) :: kminor_lower, kminor_upper + real(wp), dimension(:,:), intent(in ) :: totplnk + real(wp), dimension(:,:,:,:), intent(in ) :: planck_frac + real(wp), dimension(:,:,:), intent(in ), & + allocatable :: rayl_lower, rayl_upper + real(wp), dimension(:,:), intent(in ) :: optimal_angle_fit + character(len=*), dimension(:), intent(in ) :: gas_minor,identifier_minor + character(len=*), dimension(:), intent(in ) :: minor_gases_lower, & + minor_gases_upper + integer, dimension(:,:), intent(in ) :: minor_limits_gpt_lower, & + minor_limits_gpt_upper + logical(wl), dimension(:), intent(in ) :: minor_scales_with_density_lower, & + minor_scales_with_density_upper + character(len=*), dimension(:), intent(in ) :: scaling_gas_lower, & + scaling_gas_upper + logical(wl), dimension(:), intent(in ) :: scale_by_complement_lower,& + scale_by_complement_upper + integer, dimension(:), intent(in ) :: kminor_start_lower,& + kminor_start_upper + character(len = 128) :: err_message + ! ---- + !$acc enter data copyin(this) + call this%finalize() + err_message = init_abs_coeffs(this, & + available_gases, & + gas_names, key_species, & + band2gpt, band_lims_wavenum, & + press_ref, temp_ref, & + press_ref_trop, temp_ref_p, temp_ref_t, & + vmr_ref, & + kmajor, kminor_lower, kminor_upper, & + gas_minor,identifier_minor,& + minor_gases_lower, minor_gases_upper, & + minor_limits_gpt_lower, & + minor_limits_gpt_upper, & + minor_scales_with_density_lower, & + minor_scales_with_density_upper, & + scaling_gas_lower, scaling_gas_upper, & + scale_by_complement_lower, & + scale_by_complement_upper, & + kminor_start_lower, & + kminor_start_upper, & + rayl_lower, rayl_upper) + ! Planck function tables + ! + allocate(this%totplnk (size(totplnk, 1), size(totplnk, 2)), & + this%planck_frac (size(planck_frac,4), size(planck_frac,2),size(planck_frac,3), size(planck_frac,1)), & + this%optimal_angle_fit(size(optimal_angle_fit, 1), size(optimal_angle_fit, 2))) + this%totplnk = totplnk +! this%planck_frac = planck_frac + this%planck_frac = RESHAPE(planck_frac,(/size(planck_frac,4), size(planck_frac,2), & + size(planck_frac,3), size(planck_frac,1)/),ORDER =(/4,2,3,1/)) + this%optimal_angle_fit = optimal_angle_fit + !$acc enter data copyin(this%totplnk, this%planck_frac, this%optimal_angle_fit) + !$omp target enter data map(to:this%totplnk, this%planck_frac, this%optimal_angle_fit) + + ! Temperature steps for Planck function interpolation + ! Assumes that temperature minimum and max are the same for the absorption coefficient grid and the + ! Planck grid and the Planck grid is equally spaced + this%totplnk_delta = (this%temp_ref_max-this%temp_ref_min) / (size(this%totplnk,dim=1)-1) + end function load_int + + !-------------------------------------------------------------------------------------------------------------------- + ! + ! Initialize object based on data read from netCDF file however the user desires. + ! Rayleigh scattering tables may or may not be present; this is indicated with allocation status + ! This interface is for the external-sources object -- includes TOA source function table + ! + function load_ext(this, available_gases, gas_names, key_species, & + band2gpt, band_lims_wavenum, & + press_ref, press_ref_trop, temp_ref, & + temp_ref_p, temp_ref_t, vmr_ref, & + kmajor, kminor_lower, kminor_upper, & + gas_minor,identifier_minor, & + minor_gases_lower, minor_gases_upper, & + minor_limits_gpt_lower, minor_limits_gpt_upper, & + minor_scales_with_density_lower, & + minor_scales_with_density_upper, & + scaling_gas_lower, scaling_gas_upper, & + scale_by_complement_lower, & + scale_by_complement_upper, & + kminor_start_lower, & + kminor_start_upper, & + solar_quiet, solar_facular, solar_sunspot, & + tsi_default, mg_default, sb_default, & + rayl_lower, rayl_upper) result(err_message) + class(ty_gas_optics_rrtmgp), intent(inout) :: this + class(ty_gas_concs), intent(in ) :: available_gases ! Which gases does the host model have available? + character(len=*), & + dimension(:), intent(in) :: gas_names + integer, dimension(:,:,:), intent(in) :: key_species + integer, dimension(:,:), intent(in) :: band2gpt + real(wp), dimension(:,:), intent(in) :: band_lims_wavenum + real(wp), dimension(:), intent(in) :: press_ref, temp_ref + real(wp), intent(in) :: press_ref_trop, temp_ref_p, temp_ref_t + real(wp), dimension(:,:,:), intent(in) :: vmr_ref + real(wp), dimension(:,:,:,:), intent(in) :: kmajor + real(wp), dimension(:,:,:), intent(in) :: kminor_lower, kminor_upper + character(len=*), dimension(:), & + intent(in) :: gas_minor, & + identifier_minor + character(len=*), dimension(:), & + intent(in) :: minor_gases_lower, & + minor_gases_upper + integer, dimension(:,:), intent(in) :: & + minor_limits_gpt_lower, & + minor_limits_gpt_upper + logical(wl), dimension(:), intent(in) :: & + minor_scales_with_density_lower, & + minor_scales_with_density_upper + character(len=*),dimension(:),intent(in) :: & + scaling_gas_lower, & + scaling_gas_upper + logical(wl), dimension(:), intent(in) :: & + scale_by_complement_lower, & + scale_by_complement_upper + integer, dimension(:), intent(in) :: & + kminor_start_lower, & + kminor_start_upper + real(wp), dimension(:), intent(in) :: solar_quiet, & + solar_facular, & + solar_sunspot + real(wp), intent(in) :: tsi_default, & + mg_default, sb_default + real(wp), dimension(:,:,:), intent(in), & + allocatable :: rayl_lower, rayl_upper + character(len = 128) err_message + + integer :: ngpt + ! ---- + !$acc enter data copyin(this) + call this%finalize() + err_message = init_abs_coeffs(this, & + available_gases, & + gas_names, key_species, & + band2gpt, band_lims_wavenum, & + press_ref, temp_ref, & + press_ref_trop, temp_ref_p, temp_ref_t, & + vmr_ref, & + kmajor, kminor_lower, kminor_upper, & + gas_minor,identifier_minor, & + minor_gases_lower, minor_gases_upper, & + minor_limits_gpt_lower, & + minor_limits_gpt_upper, & + minor_scales_with_density_lower, & + minor_scales_with_density_upper, & + scaling_gas_lower, scaling_gas_upper, & + scale_by_complement_lower, & + scale_by_complement_upper, & + kminor_start_lower, & + kminor_start_upper, & + rayl_lower, rayl_upper) + if(err_message == "") then + ! + ! Spectral solar irradiance terms init + ! + ngpt = size(solar_quiet) + allocate(this%solar_source_quiet(ngpt), this%solar_source_facular(ngpt), & + this%solar_source_sunspot(ngpt), this%solar_source(ngpt)) + !$acc enter data create( this%solar_source_quiet, this%solar_source_facular, this%solar_source_sunspot, this%solar_source) + !$omp target enter data map(alloc:this%solar_source_quiet, this%solar_source_facular, this%solar_source_sunspot, this%solar_source) + !$acc kernels + !$omp target + this%solar_source_quiet = solar_quiet + this%solar_source_facular = solar_facular + this%solar_source_sunspot = solar_sunspot + !$acc end kernels + !$omp end target + err_message = this%set_solar_variability(mg_default, sb_default) + endif + end function load_ext + !-------------------------------------------------------------------------------------------------------------------- + ! + ! Initialize absorption coefficient arrays, + ! including Rayleigh scattering tables if provided (allocated) + ! + function init_abs_coeffs(this, & + available_gases, & + gas_names, key_species, & + band2gpt, band_lims_wavenum, & + press_ref, temp_ref, & + press_ref_trop, temp_ref_p, temp_ref_t, & + vmr_ref, & + kmajor, kminor_lower, kminor_upper, & + gas_minor,identifier_minor,& + minor_gases_lower, minor_gases_upper, & + minor_limits_gpt_lower, & + minor_limits_gpt_upper, & + minor_scales_with_density_lower, & + minor_scales_with_density_upper, & + scaling_gas_lower, scaling_gas_upper, & + scale_by_complement_lower, & + scale_by_complement_upper, & + kminor_start_lower, & + kminor_start_upper, & + rayl_lower, rayl_upper) result(err_message) + class(ty_gas_optics_rrtmgp), intent(inout) :: this + class(ty_gas_concs), intent(in ) :: available_gases + character(len=*), & + dimension(:), intent(in) :: gas_names + integer, dimension(:,:,:), intent(in) :: key_species + integer, dimension(:,:), intent(in) :: band2gpt + real(wp), dimension(:,:), intent(in) :: band_lims_wavenum + real(wp), dimension(:), intent(in) :: press_ref, temp_ref + real(wp), intent(in) :: press_ref_trop, temp_ref_p, temp_ref_t + real(wp), dimension(:,:,:), intent(in) :: vmr_ref + real(wp), dimension(:,:,:,:), intent(in) :: kmajor + real(wp), dimension(:,:,:), intent(in) :: kminor_lower, kminor_upper + character(len=*), dimension(:), & + intent(in) :: gas_minor, & + identifier_minor + character(len=*), dimension(:), & + intent(in) :: minor_gases_lower, & + minor_gases_upper + integer, dimension(:,:), intent(in) :: minor_limits_gpt_lower, & + minor_limits_gpt_upper + logical(wl), dimension(:), intent(in) :: minor_scales_with_density_lower, & + minor_scales_with_density_upper + character(len=*), dimension(:),& + intent(in) :: scaling_gas_lower, & + scaling_gas_upper + logical(wl), dimension(:), intent(in) :: scale_by_complement_lower, & + scale_by_complement_upper + integer, dimension(:), intent(in) :: kminor_start_lower, & + kminor_start_upper + real(wp), dimension(:,:,:), intent(in), & + allocatable :: rayl_lower, rayl_upper + character(len=128) :: err_message + ! -------------------------------------------------------------------------- + logical, dimension(:), allocatable :: gas_is_present + logical, dimension(:), allocatable :: key_species_present_init + integer, dimension(:,:,:), allocatable :: key_species_red + real(wp), dimension(:,:,:), allocatable :: vmr_ref_red + character(len=256), & + dimension(:), allocatable :: minor_gases_lower_red, & + minor_gases_upper_red + character(len=256), & + dimension(:), allocatable :: scaling_gas_lower_red, & + scaling_gas_upper_red + integer :: i, j, idx + integer :: ngas + ! -------------------------------------- + err_message = this%ty_optical_props%init(band_lims_wavenum, band2gpt) + if(len_trim(err_message) /= 0) return ! - ! Initialize the gas optics object, keeping only those gases known to the - ! gas optics and also present in the host model - ! - this%gas_names = pack(gas_names,mask=gas_is_present) - ! Copy-ins below - - allocate(vmr_ref_red(size(vmr_ref,dim=1),0:ngas, & - size(vmr_ref,dim=3))) - ! Gas 0 is used in single-key species method, set to 1.0 (col_dry) - vmr_ref_red(:,0,:) = vmr_ref(:,1,:) - do i = 1, ngas - idx = string_loc_in_array(this%gas_names(i), gas_names) - vmr_ref_red(:,i,:) = vmr_ref(:,idx+1,:) - enddo - call move_alloc(vmr_ref_red, this%vmr_ref) - !$acc enter data copyin(this%vmr_ref, this%gas_names) - !$omp target enter data map(to:this%vmr_ref, this%gas_names) + ! Which gases known to the gas optics are present in the host model (available_gases)? + ! + ngas = size(gas_names) + allocate(gas_is_present(ngas)) + do i = 1, ngas + ! Next line causes a compiler bug in gfortran 11.0.1 on Mac ARM + ! Should replace gas_names with get_gas_names() and make gas_names private in ty_gas_concs + gas_is_present(i) = string_in_array(gas_names(i), available_gases%gas_names) + end do + ! + ! Now the number of gases is the union of those known to the k-distribution and provided + ! by the host model + ! + ngas = count(gas_is_present) + ! + ! Initialize the gas optics object, keeping only those gases known to the + ! gas optics and also present in the host model ! - ! Reduce minor arrays so variables only contain minor gases that are available - ! Reduce size of minor Arrays - ! - call reduce_minor_arrays(available_gases, & - gas_minor,identifier_minor, & - kminor_lower, & - minor_gases_lower, & - minor_limits_gpt_lower, & - minor_scales_with_density_lower, & - scaling_gas_lower, & - scale_by_complement_lower, & - kminor_start_lower, & - this%kminor_lower, & - minor_gases_lower_red, & - this%minor_limits_gpt_lower, & - this%minor_scales_with_density_lower, & - scaling_gas_lower_red, & - this%scale_by_complement_lower, & - this%kminor_start_lower) - call reduce_minor_arrays(available_gases, & - gas_minor,identifier_minor,& - kminor_upper, & - minor_gases_upper, & - minor_limits_gpt_upper, & - minor_scales_with_density_upper, & - scaling_gas_upper, & - scale_by_complement_upper, & - kminor_start_upper, & - this%kminor_upper, & - minor_gases_upper_red, & - this%minor_limits_gpt_upper, & - this%minor_scales_with_density_upper, & - scaling_gas_upper_red, & - this%scale_by_complement_upper, & - this%kminor_start_upper) - !$acc enter data copyin(this%minor_limits_gpt_lower, this%minor_limits_gpt_upper) - !$omp target enter data map(to:this%minor_limits_gpt_lower, this%minor_limits_gpt_upper) - !$acc enter data copyin(this%minor_scales_with_density_lower, this%minor_scales_with_density_upper) - !$omp target enter data map(to:this%minor_scales_with_density_lower, this%minor_scales_with_density_upper) - !$acc enter data copyin(this%scale_by_complement_lower, this%scale_by_complement_upper) - !$omp target enter data map(to:this%scale_by_complement_lower, this%scale_by_complement_upper) - !$acc enter data copyin(this%kminor_start_lower, this%kminor_start_upper) - !$omp target enter data map(to:this%kminor_start_lower, this%kminor_start_upper) - !$acc enter data copyin(this%kminor_lower, this%kminor_upper) - !$omp target enter data map(to:this%kminor_lower, this%kminor_upper) - - ! Arrays not reduced by the presence, or lack thereof, of a gas - allocate(this%press_ref(size(press_ref)), this%temp_ref(size(temp_ref)), & - this%kmajor(size(kmajor,4),size(kmajor,2),size(kmajor,3),size(kmajor,1))) - this%press_ref(:) = press_ref(:) - this%temp_ref(:) = temp_ref(:) - this%kmajor = RESHAPE(kmajor,(/size(kmajor,4),size(kmajor,2),size(kmajor,3),size(kmajor,1)/), ORDER= (/4,2,3,1/)) - !$acc enter data copyin(this%press_ref, this%temp_ref, this%kmajor) - !$omp target enter data map(to:this%press_ref, this%temp_ref, this%kmajor) - - - if(allocated(rayl_lower) .neqv. allocated(rayl_upper)) then - err_message = "rayl_lower and rayl_upper must have the same allocation status" - return - end if - if (allocated(rayl_lower)) then - allocate(this%krayl(size(rayl_lower,dim=3),size(rayl_lower,dim=2),size(rayl_lower,dim=1),2)) - this%krayl(:,:,:,1) = RESHAPE(rayl_lower,(/size(rayl_lower,dim=3),size(rayl_lower,dim=2), & - size(rayl_lower,dim=1)/),ORDER =(/3,2,1/)) - this%krayl(:,:,:,2) = RESHAPE(rayl_upper,(/size(rayl_lower,dim=3),size(rayl_lower,dim=2), & - size(rayl_lower,dim=1)/),ORDER =(/3,2,1/)) - !$acc enter data copyin(this%krayl) - !$omp target enter data map(to:this%krayl) - end if + this%gas_names = pack(gas_names,mask=gas_is_present) + ! Copy-ins below + + allocate(vmr_ref_red(size(vmr_ref,dim=1),0:ngas, & + size(vmr_ref,dim=3))) + ! Gas 0 is used in single-key species method, set to 1.0 (col_dry) + vmr_ref_red(:,0,:) = vmr_ref(:,1,:) + do i = 1, ngas + idx = string_loc_in_array(this%gas_names(i), gas_names) + vmr_ref_red(:,i,:) = vmr_ref(:,idx+1,:) + enddo + call move_alloc(vmr_ref_red, this%vmr_ref) + !$acc enter data copyin(this%vmr_ref, this%gas_names) + !$omp target enter data map(to:this%vmr_ref, this%gas_names) + ! + ! Reduce minor arrays so variables only contain minor gases that are available + ! Reduce size of minor Arrays + ! + call reduce_minor_arrays(available_gases, & + gas_minor,identifier_minor, & + kminor_lower, & + minor_gases_lower, & + minor_limits_gpt_lower, & + minor_scales_with_density_lower, & + scaling_gas_lower, & + scale_by_complement_lower, & + kminor_start_lower, & + this%kminor_lower, & + minor_gases_lower_red, & + this%minor_limits_gpt_lower, & + this%minor_scales_with_density_lower, & + scaling_gas_lower_red, & + this%scale_by_complement_lower, & + this%kminor_start_lower) + call reduce_minor_arrays(available_gases, & + gas_minor,identifier_minor,& + kminor_upper, & + minor_gases_upper, & + minor_limits_gpt_upper, & + minor_scales_with_density_upper, & + scaling_gas_upper, & + scale_by_complement_upper, & + kminor_start_upper, & + this%kminor_upper, & + minor_gases_upper_red, & + this%minor_limits_gpt_upper, & + this%minor_scales_with_density_upper, & + scaling_gas_upper_red, & + this%scale_by_complement_upper, & + this%kminor_start_upper) + !$acc enter data copyin(this%minor_limits_gpt_lower, this%minor_limits_gpt_upper) + !$omp target enter data map(to:this%minor_limits_gpt_lower, this%minor_limits_gpt_upper) + !$acc enter data copyin(this%minor_scales_with_density_lower, this%minor_scales_with_density_upper) + !$omp target enter data map(to:this%minor_scales_with_density_lower, this%minor_scales_with_density_upper) + !$acc enter data copyin(this%scale_by_complement_lower, this%scale_by_complement_upper) + !$omp target enter data map(to:this%scale_by_complement_lower, this%scale_by_complement_upper) + !$acc enter data copyin(this%kminor_start_lower, this%kminor_start_upper) + !$omp target enter data map(to:this%kminor_start_lower, this%kminor_start_upper) + !$acc enter data copyin(this%kminor_lower, this%kminor_upper) + !$omp target enter data map(to:this%kminor_lower, this%kminor_upper) + + ! Arrays not reduced by the presence, or lack thereof, of a gas + allocate(this%press_ref(size(press_ref)), this%temp_ref(size(temp_ref)), & + this%kmajor(size(kmajor,4),size(kmajor,2),size(kmajor,3),size(kmajor,1))) + this%press_ref(:) = press_ref(:) + this%temp_ref(:) = temp_ref(:) + this%kmajor = RESHAPE(kmajor,(/size(kmajor,4),size(kmajor,2),size(kmajor,3),size(kmajor,1)/), ORDER= (/4,2,3,1/)) + !$acc enter data copyin(this%press_ref, this%temp_ref, this%kmajor) + !$omp target enter data map(to:this%press_ref, this%temp_ref, this%kmajor) - ! ---- post processing ---- - ! creates log reference pressure - allocate(this%press_ref_log(size(this%press_ref))) - this%press_ref_log(:) = log(this%press_ref(:)) - !$acc enter data copyin(this%press_ref_log) - !$omp target enter data map(to:this%press_ref_log) - - ! log scale of reference pressure - this%press_ref_trop_log = log(press_ref_trop) - - ! Get index of gas (if present) for determining col_gas - call create_idx_minor(this%gas_names, gas_minor, identifier_minor, minor_gases_lower_red, this%idx_minor_lower) - call create_idx_minor(this%gas_names, gas_minor, identifier_minor, minor_gases_upper_red, this%idx_minor_upper) - ! Get index of gas (if present) that has special treatment in density scaling - call create_idx_minor_scaling(this%gas_names, scaling_gas_lower_red, this%idx_minor_scaling_lower) - call create_idx_minor_scaling(this%gas_names, scaling_gas_upper_red, this%idx_minor_scaling_upper) - !$acc enter data copyin(this%idx_minor_lower, this%idx_minor_upper) - !$omp target enter data map(to:this%idx_minor_lower, this%idx_minor_upper) - !$acc enter data copyin(this%idx_minor_scaling_lower, this%idx_minor_scaling_upper) - !$omp target enter data map(to:this%idx_minor_scaling_lower, this%idx_minor_scaling_upper) - - ! create flavor list - ! Reduce (remap) key_species list; checks that all key gases are present in incoming - call create_key_species_reduce(gas_names,this%gas_names, & - key_species,key_species_red,key_species_present_init) - err_message = check_key_species_present_init(gas_names,key_species_present_init) - if(len_trim(err_message) /= 0) return - ! create flavor list - call create_flavor(key_species_red, this%flavor) - ! create gpoint_flavor list - call create_gpoint_flavor(key_species_red, this%get_gpoint_bands(), this%flavor, this%gpoint_flavor) - !Copy-ins at end of subroutine - - ! minimum, maximum reference temperature, pressure -- assumes low-to-high ordering - ! for T, high-to-low ordering for p - this%temp_ref_min = this%temp_ref (1) - this%temp_ref_max = this%temp_ref (size(this%temp_ref)) - this%press_ref_min = this%press_ref(size(this%press_ref)) - this%press_ref_max = this%press_ref(1) - - ! creates press_ref_log, temp_ref_delta - this%press_ref_log_delta = (log(this%press_ref_min)-log(this%press_ref_max))/(size(this%press_ref)-1) - this%temp_ref_delta = (this%temp_ref_max-this%temp_ref_min)/(size(this%temp_ref)-1) - - ! Which species are key in one or more bands? - ! this%flavor is an index into this%gas_names - ! - if (allocated(this%is_key)) deallocate(this%is_key) ! Shouldn't ever happen... - allocate(this%is_key(this%get_ngas())) - this%is_key(:) = .False. - do j = 1, size(this%flavor, 2) - do i = 1, size(this%flavor, 1) ! extents should be 2 - if (this%flavor(i,j) /= 0) this%is_key(this%flavor(i,j)) = .true. - end do - end do - !$acc enter data copyin(this%flavor, this%gpoint_flavor, this%is_key) - !$omp target enter data map(to:this%flavor, this%gpoint_flavor, this%is_key) - - end function init_abs_coeffs - ! ---------------------------------------------------------------------------------------------------- - function check_key_species_present_init(gas_names, key_species_present_init) result(err_message) - logical, dimension(:), intent(in) :: key_species_present_init - character(len=*), dimension(:), intent(in) :: gas_names - character(len=128) :: err_message - - integer :: i - - err_message='' - do i = 1, size(key_species_present_init) - if(.not. key_species_present_init(i)) & - err_message = ' ' // trim(gas_names(i)) // trim(err_message) - end do - if(len_trim(err_message) > 0) err_message = "gas_optics: required gases" // trim(err_message) // " are not provided" - - end function check_key_species_present_init - !------------------------------------------------------------------------------------------ - ! - ! Ensure that every key gas required by the k-distribution is - ! present in the gas concentration object - ! - function check_key_species_present(this, gas_desc) result(error_msg) - class(ty_gas_optics_rrtmgp), intent(in) :: this - class(ty_gas_concs), intent(in) :: gas_desc - character(len=128) :: error_msg - - ! Local variables - character(len=32), dimension(count(this%is_key(:) )) :: key_gas_names - integer :: igas - ! -------------------------------------- - error_msg = "" - key_gas_names = pack(this%gas_names, mask=this%is_key) - do igas = 1, size(key_gas_names) - ! Next line causes a compiler bug in gfortran 11.0.1 on Mac ARM - ! Should replace gas_names with get_gas_names() and make gas_names private in ty_gas_concs - if(.not. string_in_array(key_gas_names(igas), gas_desc%gas_names)) & - error_msg = ' ' // trim(lower_case(key_gas_names(igas))) // trim(error_msg) - end do - if(len_trim(error_msg) > 0) error_msg = "gas_optics: required gases" // trim(error_msg) // " are not provided" - - end function check_key_species_present - !-------------------------------------------------------------------------------------------------------------------- - ! - ! Inquiry functions - ! - !-------------------------------------------------------------------------------------------------------------------- - ! - !> return true if initialized for internal sources/longwave, false otherwise - ! - pure function source_is_internal(this) - class(ty_gas_optics_rrtmgp), intent(in) :: this - logical :: source_is_internal - source_is_internal = allocated(this%totplnk) .and. allocated(this%planck_frac) - end function source_is_internal - !-------------------------------------------------------------------------------------------------------------------- - ! - !> return true if initialized for external sources/shortwave, false otherwise + + if(allocated(rayl_lower) .neqv. allocated(rayl_upper)) then + err_message = "rayl_lower and rayl_upper must have the same allocation status" + return + end if + if (allocated(rayl_lower)) then + allocate(this%krayl(size(rayl_lower,dim=3),size(rayl_lower,dim=2),size(rayl_lower,dim=1),2)) + this%krayl(:,:,:,1) = RESHAPE(rayl_lower,(/size(rayl_lower,dim=3),size(rayl_lower,dim=2), & + size(rayl_lower,dim=1)/),ORDER =(/3,2,1/)) + this%krayl(:,:,:,2) = RESHAPE(rayl_upper,(/size(rayl_lower,dim=3),size(rayl_lower,dim=2), & + size(rayl_lower,dim=1)/),ORDER =(/3,2,1/)) + !$acc enter data copyin(this%krayl) + !$omp target enter data map(to:this%krayl) + end if + + ! ---- post processing ---- + ! creates log reference pressure + allocate(this%press_ref_log(size(this%press_ref))) + this%press_ref_log(:) = log(this%press_ref(:)) + !$acc enter data copyin(this%press_ref_log) + !$omp target enter data map(to:this%press_ref_log) + + ! log scale of reference pressure + this%press_ref_trop_log = log(press_ref_trop) + + ! Get index of gas (if present) for determining col_gas + call create_idx_minor(this%gas_names, gas_minor, identifier_minor, minor_gases_lower_red, this%idx_minor_lower) + call create_idx_minor(this%gas_names, gas_minor, identifier_minor, minor_gases_upper_red, this%idx_minor_upper) + ! Get index of gas (if present) that has special treatment in density scaling + call create_idx_minor_scaling(this%gas_names, scaling_gas_lower_red, this%idx_minor_scaling_lower) + call create_idx_minor_scaling(this%gas_names, scaling_gas_upper_red, this%idx_minor_scaling_upper) + !$acc enter data copyin(this%idx_minor_lower, this%idx_minor_upper) + !$omp target enter data map(to:this%idx_minor_lower, this%idx_minor_upper) + !$acc enter data copyin(this%idx_minor_scaling_lower, this%idx_minor_scaling_upper) + !$omp target enter data map(to:this%idx_minor_scaling_lower, this%idx_minor_scaling_upper) + + ! create flavor list + ! Reduce (remap) key_species list; checks that all key gases are present in incoming + call create_key_species_reduce(gas_names,this%gas_names, & + key_species,key_species_red,key_species_present_init) + err_message = check_key_species_present_init(gas_names,key_species_present_init) + if(len_trim(err_message) /= 0) return + ! create flavor list + call create_flavor(key_species_red, this%flavor) + ! create gpoint_flavor list + call create_gpoint_flavor(key_species_red, this%get_gpoint_bands(), this%flavor, this%gpoint_flavor) + !Copy-ins at end of subroutine + + ! minimum, maximum reference temperature, pressure -- assumes low-to-high ordering + ! for T, high-to-low ordering for p + this%temp_ref_min = this%temp_ref (1) + this%temp_ref_max = this%temp_ref (size(this%temp_ref)) + this%press_ref_min = this%press_ref(size(this%press_ref)) + this%press_ref_max = this%press_ref(1) + + ! creates press_ref_log, temp_ref_delta + this%press_ref_log_delta = (log(this%press_ref_min)-log(this%press_ref_max))/(size(this%press_ref)-1) + this%temp_ref_delta = (this%temp_ref_max-this%temp_ref_min)/(size(this%temp_ref)-1) + + ! Which species are key in one or more bands? + ! this%flavor is an index into this%gas_names + ! + if (allocated(this%is_key)) deallocate(this%is_key) ! Shouldn't ever happen... + allocate(this%is_key(this%get_ngas())) + this%is_key(:) = .False. + do j = 1, size(this%flavor, 2) + do i = 1, size(this%flavor, 1) ! extents should be 2 + if (this%flavor(i,j) /= 0) this%is_key(this%flavor(i,j)) = .true. + end do + end do + !$acc enter data copyin(this%flavor, this%gpoint_flavor, this%is_key) + !$omp target enter data map(to:this%flavor, this%gpoint_flavor, this%is_key) + + end function init_abs_coeffs + ! ---------------------------------------------------------------------------------------------------- + function check_key_species_present_init(gas_names, key_species_present_init) result(err_message) + logical, dimension(:), intent(in) :: key_species_present_init + character(len=*), dimension(:), intent(in) :: gas_names + character(len=128) :: err_message + + integer :: i + + err_message='' + do i = 1, size(key_species_present_init) + if(.not. key_species_present_init(i)) & + err_message = ' ' // trim(gas_names(i)) // trim(err_message) + end do + if(len_trim(err_message) > 0) err_message = "gas_optics: required gases" // trim(err_message) // " are not provided" + + end function check_key_species_present_init + !------------------------------------------------------------------------------------------ + ! + ! Ensure that every key gas required by the k-distribution is + ! present in the gas concentration object + ! + function check_key_species_present(this, gas_desc) result(error_msg) + class(ty_gas_optics_rrtmgp), intent(in) :: this + class(ty_gas_concs), intent(in) :: gas_desc + character(len=128) :: error_msg + + ! Local variables + character(len=32), dimension(count(this%is_key(:) )) :: key_gas_names + integer :: igas + ! -------------------------------------- + error_msg = "" + key_gas_names = pack(this%gas_names, mask=this%is_key) + do igas = 1, size(key_gas_names) + ! Next line causes a compiler bug in gfortran 11.0.1 on Mac ARM + ! Should replace gas_names with get_gas_names() and make gas_names private in ty_gas_concs + if(.not. string_in_array(key_gas_names(igas), gas_desc%gas_names)) & + error_msg = ' ' // trim(lower_case(key_gas_names(igas))) // trim(error_msg) + end do + if(len_trim(error_msg) > 0) error_msg = "gas_optics: required gases" // trim(error_msg) // " are not provided" + + end function check_key_species_present + !-------------------------------------------------------------------------------------------------------------------- ! - pure function source_is_external(this) - class(ty_gas_optics_rrtmgp), intent(in) :: this - logical :: source_is_external - source_is_external = allocated(this%solar_source) - end function source_is_external - - !-------------------------------------------------------------------------------------------------------------------- - ! - !> return the names of the gases known to the k-distributions - ! - pure function get_gases(this) - class(ty_gas_optics_rrtmgp), intent(in) :: this - character(32), dimension(get_ngas(this)) :: get_gases !! names of the gases known to the k-distributions - - get_gases = this%gas_names - end function get_gases - !-------------------------------------------------------------------------------------------------------------------- - ! - !> return the minimum pressure on the interpolation grids - ! - pure function get_press_min(this) - class(ty_gas_optics_rrtmgp), intent(in) :: this - real(wp) :: get_press_min !! minimum pressure for which the k-dsitribution is valid - - get_press_min = this%press_ref_min - end function get_press_min - - !-------------------------------------------------------------------------------------------------------------------- - ! - !> return the maximum pressure on the interpolation grids - ! - pure function get_press_max(this) - class(ty_gas_optics_rrtmgp), intent(in) :: this - real(wp) :: get_press_max !! maximum pressure for which the k-dsitribution is valid - - get_press_max = this%press_ref_max - end function get_press_max - - !-------------------------------------------------------------------------------------------------------------------- - ! - !> return the minimum temparature on the interpolation grids - ! - pure function get_temp_min(this) - class(ty_gas_optics_rrtmgp), intent(in) :: this - real(wp) :: get_temp_min !! minimum temperature for which the k-dsitribution is valid - - get_temp_min = this%temp_ref_min - end function get_temp_min - - !-------------------------------------------------------------------------------------------------------------------- - ! - !> return the maximum temparature on the interpolation grids - ! - pure function get_temp_max(this) - class(ty_gas_optics_rrtmgp), intent(in) :: this - real(wp) :: get_temp_max !! maximum temperature for which the k-dsitribution is valid - - get_temp_max = this%temp_ref_max - end function get_temp_max - !-------------------------------------------------------------------------------------------------------------------- - ! - !> Utility function, provided for user convenience - !> computes column amounts of dry air using hydrostatic equation - ! - function get_col_dry(vmr_h2o, plev, latitude) result(col_dry) - ! input - real(wp), dimension(:,:), intent(in) :: vmr_h2o ! volume mixing ratio of water vapor to dry air; (ncol,nlay) - real(wp), dimension(:,:), intent(in) :: plev ! Layer boundary pressures [Pa] (ncol,nlay+1) - real(wp), dimension(:), optional, & - intent(in) :: latitude ! Latitude [degrees] (ncol) - ! output - real(wp), dimension(size(plev,dim=1),size(plev,dim=2)-1) :: col_dry ! Column dry amount (ncol,nlay) - ! ------------------------------------------------ - ! first and second term of Helmert formula - real(wp), parameter :: helmert1 = 9.80665_wp - real(wp), parameter :: helmert2 = 0.02586_wp - ! local variables - real(wp), dimension(size(plev,dim=1)) :: g0 ! (ncol) - real(wp):: delta_plev, m_air, fact - integer :: ncol, nlev - integer :: icol, ilev ! nlay = nlev-1 - ! ------------------------------------------------ - ncol = size(plev, dim=1) - nlev = size(plev, dim=2) - !$acc data create(g0) - !$omp target data map(alloc:g0) - if(present(latitude)) then - ! A purely OpenACC implementation would probably compute g0 within the kernel below - !$acc parallel loop - !$omp target teams distribute parallel do simd - do icol = 1, ncol - g0(icol) = helmert1 - helmert2 * cos(2.0_wp * pi * latitude(icol) / 180.0_wp) ! acceleration due to gravity [m/s^2] - end do - else - !$acc parallel loop - !$omp target teams distribute parallel do simd - do icol = 1, ncol - g0(icol) = grav - end do - end if - - !$acc parallel loop gang vector collapse(2) copyin(plev,vmr_h2o) copyout(col_dry) - !$omp target teams distribute parallel do simd collapse(2) map(to:plev,vmr_h2o) map(from:col_dry) - do ilev = 1, nlev-1 - do icol = 1, ncol - delta_plev = abs(plev(icol,ilev) - plev(icol,ilev+1)) - ! Get average mass of moist air per mole of moist air - fact = 1._wp / (1.+vmr_h2o(icol,ilev)) - m_air = (m_dry + m_h2o * vmr_h2o(icol,ilev)) * fact - col_dry(icol,ilev) = 10._wp * delta_plev * avogad * fact/(1000._wp*m_air*100._wp*g0(icol)) - end do - end do - !$acc end data - !$omp end target data - end function get_col_dry - !-------------------------------------------------------------------------------------------------------------------- - ! - !> Compute a transport angle that minimizes flux errors at surface and TOA based on empirical fits - ! - function compute_optimal_angles(this, optical_props, optimal_angles) result(err_msg) - ! input - class(ty_gas_optics_rrtmgp), intent(in ) :: this - class(ty_optical_props_arry), intent(in ) :: optical_props !! Optical properties - real(wp), dimension(:,:), intent( out) :: optimal_angles !! Secant of optical transport angle - character(len=128) :: err_msg !! Empty if successful - !---------------------------- - integer :: ncol, nlay, ngpt - integer :: icol, ilay, igpt, bnd - real(wp) :: t, trans_total -#if defined _CRAYFTN && _RELEASE_MAJOR == 14 && _RELEASE_MINOR == 0 && _RELEASE_PATCHLEVEL == 3 -# define CRAY_WORKAROUND -#endif -#ifdef CRAY_WORKAROUND - integer, allocatable :: bands(:) -#else - integer :: bands(optical_props%get_ngpt()) -#endif - !---------------------------- - ncol = optical_props%get_ncol() - nlay = optical_props%get_nlay() - ngpt = optical_props%get_ngpt() -#ifdef CRAY_WORKAROUND - allocate( bands(ngpt) ) ! In order to work with CCE 14 (it is also better software) -#endif - - err_msg="" - if(.not. this%gpoints_are_equal(optical_props)) & - err_msg = "gas_optics%compute_optimal_angles: optical_props has different spectral discretization than gas_optics" - if(.not. extents_are(optimal_angles, ncol, ngpt)) & - err_msg = "gas_optics%compute_optimal_angles: optimal_angles different dimension (ncol)" - if (err_msg /= "") return - - do igpt = 1, ngpt - bands(igpt) = optical_props%convert_gpt2band(igpt) - enddo - ! - ! column transmissivity - ! - !$acc parallel loop gang vector collapse(2) copyin(bands, optical_props, optical_props%tau) copyout(optimal_angles) - !$omp target teams distribute parallel do simd collapse(2) map(to:bands, optical_props%tau) map(from:optimal_angles) - do icol = 1, ncol - do igpt = 1, ngpt - ! - ! Column transmissivity - ! - t = 0._wp - trans_total = 0._wp - do ilay = 1, nlay - t = t + optical_props%tau(icol,ilay,igpt) - end do - trans_total = exp(-t) - ! - ! Optimal transport angle is a linear fit to column transmissivity - ! - optimal_angles(icol,igpt) = this%optimal_angle_fit(1,bands(igpt))*trans_total + & - this%optimal_angle_fit(2,bands(igpt)) - end do - end do - end function compute_optimal_angles - !-------------------------------------------------------------------------------------------------------------------- - ! - ! Internal procedures - ! - !-------------------------------------------------------------------------------------------------------------------- - pure function rewrite_key_species_pair(key_species_pair) - ! (0,0) becomes (2,2) -- because absorption coefficients for these g-points will be 0. - integer, dimension(2) :: rewrite_key_species_pair - integer, dimension(2), intent(in) :: key_species_pair - rewrite_key_species_pair = key_species_pair - if (all(key_species_pair(:).eq.(/0,0/))) then - rewrite_key_species_pair(:) = (/2,2/) - end if - end function - - ! --------------------------------------------------------------------------------------- - ! true is key_species_pair exists in key_species_list - pure function key_species_pair_exists(key_species_list, key_species_pair) - logical :: key_species_pair_exists - integer, dimension(:,:), intent(in) :: key_species_list - integer, dimension(2), intent(in) :: key_species_pair - integer :: i - do i=1,size(key_species_list,dim=2) - if (all(key_species_list(:,i).eq.key_species_pair(:))) then - key_species_pair_exists = .true. - return - end if - end do - key_species_pair_exists = .false. - end function key_species_pair_exists + ! Inquiry functions + ! + !-------------------------------------------------------------------------------------------------------------------- + ! + !> return true if initialized for internal sources/longwave, false otherwise + ! + pure function source_is_internal(this) + class(ty_gas_optics_rrtmgp), intent(in) :: this + logical :: source_is_internal + source_is_internal = allocated(this%totplnk) .and. allocated(this%planck_frac) + end function source_is_internal + !-------------------------------------------------------------------------------------------------------------------- + ! + !> return true if initialized for external sources/shortwave, false otherwise + ! + pure function source_is_external(this) + class(ty_gas_optics_rrtmgp), intent(in) :: this + logical :: source_is_external + source_is_external = allocated(this%solar_source) + end function source_is_external + + !-------------------------------------------------------------------------------------------------------------------- + ! + !> return the names of the gases known to the k-distributions + ! + pure function get_gases(this) + class(ty_gas_optics_rrtmgp), intent(in) :: this + character(32), dimension(get_ngas(this)) :: get_gases !! names of the gases known to the k-distributions + + get_gases = this%gas_names + end function get_gases + !-------------------------------------------------------------------------------------------------------------------- + ! + !> return the minimum pressure on the interpolation grids + ! + pure function get_press_min(this) + class(ty_gas_optics_rrtmgp), intent(in) :: this + real(wp) :: get_press_min !! minimum pressure for which the k-dsitribution is valid + + get_press_min = this%press_ref_min + end function get_press_min + + !-------------------------------------------------------------------------------------------------------------------- + ! + !> return the maximum pressure on the interpolation grids + ! + pure function get_press_max(this) + class(ty_gas_optics_rrtmgp), intent(in) :: this + real(wp) :: get_press_max !! maximum pressure for which the k-dsitribution is valid + + get_press_max = this%press_ref_max + end function get_press_max + + !-------------------------------------------------------------------------------------------------------------------- + ! + !> return the minimum temparature on the interpolation grids + ! + pure function get_temp_min(this) + class(ty_gas_optics_rrtmgp), intent(in) :: this + real(wp) :: get_temp_min !! minimum temperature for which the k-dsitribution is valid + + get_temp_min = this%temp_ref_min + end function get_temp_min + + !-------------------------------------------------------------------------------------------------------------------- + ! + !> return the maximum temparature on the interpolation grids + ! + pure function get_temp_max(this) + class(ty_gas_optics_rrtmgp), intent(in) :: this + real(wp) :: get_temp_max !! maximum temperature for which the k-dsitribution is valid + + get_temp_max = this%temp_ref_max + end function get_temp_max + !-------------------------------------------------------------------------------------------------------------------- + ! + !> Utility function, provided for user convenience + !> computes column amounts of dry air using hydrostatic equation + ! + function get_col_dry(vmr_h2o, plev, latitude) result(col_dry) + ! input + real(wp), dimension(:,:), intent(in) :: vmr_h2o ! volume mixing ratio of water vapor to dry air; (ncol,nlay) + real(wp), dimension(:,:), intent(in) :: plev ! Layer boundary pressures [Pa] (ncol,nlay+1) + real(wp), dimension(:), optional, & + intent(in) :: latitude ! Latitude [degrees] (ncol) + ! output + real(wp), dimension(size(plev,dim=1),size(plev,dim=2)-1) :: col_dry ! Column dry amount (ncol,nlay) + ! ------------------------------------------------ + ! first and second term of Helmert formula + real(wp), parameter :: helmert1 = 9.80665_wp + real(wp), parameter :: helmert2 = 0.02586_wp + ! local variables + real(wp), dimension(size(plev,dim=1)) :: g0 ! (ncol) + real(wp):: delta_plev, m_air, fact + integer :: ncol, nlev + integer :: icol, ilev ! nlay = nlev-1 + ! ------------------------------------------------ + ncol = size(plev, dim=1) + nlev = size(plev, dim=2) + !$acc data create(g0) + !$omp target data map(alloc:g0) + if(present(latitude)) then + ! A purely OpenACC implementation would probably compute g0 within the kernel below + !$acc parallel loop + !$omp target teams distribute parallel do simd + do icol = 1, ncol + g0(icol) = helmert1 - helmert2 * cos(2.0_wp * pi * latitude(icol) / 180.0_wp) ! acceleration due to gravity [m/s^2] + end do + else + !$acc parallel loop + !$omp target teams distribute parallel do simd + do icol = 1, ncol + g0(icol) = grav + end do + end if + + !$acc parallel loop gang vector collapse(2) copyin(plev,vmr_h2o) copyout(col_dry) + !$omp target teams distribute parallel do simd collapse(2) map(to:plev,vmr_h2o) map(from:col_dry) + do ilev = 1, nlev-1 + do icol = 1, ncol + delta_plev = abs(plev(icol,ilev) - plev(icol,ilev+1)) + ! Get average mass of moist air per mole of moist air + fact = 1._wp / (1.+vmr_h2o(icol,ilev)) + m_air = (m_dry + m_h2o * vmr_h2o(icol,ilev)) * fact + col_dry(icol,ilev) = 10._wp * delta_plev * avogad * fact/(1000._wp*m_air*100._wp*g0(icol)) + end do + end do + !$acc end data + !$omp end target data + end function get_col_dry + !-------------------------------------------------------------------------------------------------------------------- + ! + !> Compute a transport angle that minimizes flux errors at surface and TOA based on empirical fits + ! + function compute_optimal_angles(this, optical_props, optimal_angles) result(err_msg) + ! input + class(ty_gas_optics_rrtmgp), intent(in ) :: this + class(ty_optical_props_arry), intent(in ) :: optical_props !! Optical properties + real(wp), dimension(:,:), intent( out) :: optimal_angles !! Secant of optical transport angle + character(len=128) :: err_msg !! Empty if successful + !---------------------------- + integer :: ncol, nlay, ngpt + integer :: icol, ilay, igpt, bnd + real(wp) :: t, trans_total +#if defined _CRAYFTN && _RELEASE_MAJOR == 14 && _RELEASE_MINOR == 0 && _RELEASE_PATCHLEVEL == 3 +# define CRAY_WORKAROUND +#endif +#ifdef CRAY_WORKAROUND + integer, allocatable :: bands(:) +#else + integer :: bands(optical_props%get_ngpt()) +#endif + !---------------------------- + ncol = optical_props%get_ncol() + nlay = optical_props%get_nlay() + ngpt = optical_props%get_ngpt() +#ifdef CRAY_WORKAROUND + allocate( bands(ngpt) ) ! In order to work with CCE 14 (it is also better software) +#endif + + err_msg="" + if(.not. this%gpoints_are_equal(optical_props)) & + err_msg = "gas_optics%compute_optimal_angles: optical_props has different spectral discretization than gas_optics" + if(.not. extents_are(optimal_angles, ncol, ngpt)) & + err_msg = "gas_optics%compute_optimal_angles: optimal_angles different dimension (ncol)" + if (err_msg /= "") return + + do igpt = 1, ngpt + bands(igpt) = optical_props%convert_gpt2band(igpt) + enddo + ! + ! column transmissivity + ! + !$acc parallel loop gang vector collapse(2) copyin(bands, optical_props, optical_props%tau) copyout(optimal_angles) + !$omp target teams distribute parallel do simd collapse(2) map(to:bands, optical_props%tau) map(from:optimal_angles) + do icol = 1, ncol + do igpt = 1, ngpt + ! + ! Column transmissivity + ! + t = 0._wp + trans_total = 0._wp + do ilay = 1, nlay + t = t + optical_props%tau(icol,ilay,igpt) + end do + trans_total = exp(-t) + ! + ! Optimal transport angle is a linear fit to column transmissivity + ! + optimal_angles(icol,igpt) = this%optimal_angle_fit(1,bands(igpt))*trans_total + & + this%optimal_angle_fit(2,bands(igpt)) + end do + end do + end function compute_optimal_angles + !-------------------------------------------------------------------------------------------------------------------- + ! + ! Internal procedures + ! + !-------------------------------------------------------------------------------------------------------------------- + pure function rewrite_key_species_pair(key_species_pair) + ! (0,0) becomes (2,2) -- because absorption coefficients for these g-points will be 0. + integer, dimension(2) :: rewrite_key_species_pair + integer, dimension(2), intent(in) :: key_species_pair + rewrite_key_species_pair = key_species_pair + if (all(key_species_pair(:).eq.(/0,0/))) then + rewrite_key_species_pair(:) = (/2,2/) + end if + end function + ! --------------------------------------------------------------------------------------- - ! create flavor list -- - ! an unordered array of extent (2,:) containing all possible pairs of key species - ! used in either upper or lower atmos - ! - subroutine create_flavor(key_species, flavor) - integer, dimension(:,:,:), intent(in) :: key_species - integer, dimension(:,:), allocatable, intent(out) :: flavor - integer, dimension(2,size(key_species,3)*2) :: key_species_list - - integer :: ibnd, iatm, i, iflavor - ! prepare list of key_species - i = 1 - do ibnd=1,size(key_species,3) ! bands - do iatm=1,size(key_species,2) ! upper/lower atmosphere - key_species_list(:,i) = key_species(:,iatm,ibnd) - i = i + 1 - end do - end do - ! rewrite single key_species pairs - do i=1,size(key_species_list,2) - key_species_list(:,i) = rewrite_key_species_pair(key_species_list(:,i)) - end do - ! count unique key species pairs - iflavor = 0 - do i=1,size(key_species_list,2) - if (.not.key_species_pair_exists(key_species_list(:,1:i-1),key_species_list(:,i))) then - iflavor = iflavor + 1 - end if - end do - ! fill flavors - allocate(flavor(2,iflavor)) - iflavor = 0 - do i=1,size(key_species_list,2) - if (.not.key_species_pair_exists(key_species_list(:,1:i-1),key_species_list(:,i))) then - iflavor = iflavor + 1 - flavor(:,iflavor) = key_species_list(:,i) - end if - end do - end subroutine create_flavor - ! --------------------------------------------------------------------------------------- - ! - ! create index list for extracting col_gas needed for minor gas optical depth calculations - ! - subroutine create_idx_minor(gas_names, & - gas_minor, identifier_minor, minor_gases_atm, idx_minor_atm) - character(len=*), dimension(:), intent(in) :: gas_names - character(len=*), dimension(:), intent(in) :: & - gas_minor, & - identifier_minor - character(len=*), dimension(:), intent(in) :: minor_gases_atm - integer, dimension(:), allocatable, & - intent(out) :: idx_minor_atm - - ! local - integer :: imnr - integer :: idx_mnr - allocate(idx_minor_atm(size(minor_gases_atm,dim=1))) - do imnr = 1, size(minor_gases_atm,dim=1) ! loop over minor absorbers in each band - ! Find identifying string for minor species in list of possible identifiers (e.g. h2o_slf) - idx_mnr = string_loc_in_array(minor_gases_atm(imnr), identifier_minor) - ! Find name of gas associated with minor species identifier (e.g. h2o) - idx_minor_atm(imnr) = string_loc_in_array(gas_minor(idx_mnr), gas_names) - enddo - end subroutine create_idx_minor - - ! --------------------------------------------------------------------------------------- - ! - ! create index for special treatment in density scaling of minor gases - ! - subroutine create_idx_minor_scaling(gas_names, & - scaling_gas_atm, idx_minor_scaling_atm) - character(len=*), dimension(:), intent(in) :: gas_names - character(len=*), dimension(:), intent(in) :: scaling_gas_atm - integer, dimension(:), allocatable, & - intent(out) :: idx_minor_scaling_atm - - ! local - integer :: imnr - allocate(idx_minor_scaling_atm(size(scaling_gas_atm,dim=1))) - do imnr = 1, size(scaling_gas_atm,dim=1) ! loop over minor absorbers in each band - ! This will be -1 if there's no interacting gas - idx_minor_scaling_atm(imnr) = string_loc_in_array(scaling_gas_atm(imnr), gas_names) - enddo - end subroutine create_idx_minor_scaling - !-------------------------------------------------------------------------------------------------------------------- - ! Is the object ready to use? - ! - pure function is_loaded(this) - class(ty_gas_optics_rrtmgp), intent(in) :: this - logical(wl) :: is_loaded + ! true is key_species_pair exists in key_species_list + pure function key_species_pair_exists(key_species_list, key_species_pair) + logical :: key_species_pair_exists + integer, dimension(:,:), intent(in) :: key_species_list + integer, dimension(2), intent(in) :: key_species_pair + integer :: i + do i=1,size(key_species_list,dim=2) + if (all(key_species_list(:,i).eq.key_species_pair(:))) then + key_species_pair_exists = .true. + return + end if + end do + key_species_pair_exists = .false. + end function key_species_pair_exists + ! --------------------------------------------------------------------------------------- + ! create flavor list -- + ! an unordered array of extent (2,:) containing all possible pairs of key species + ! used in either upper or lower atmos + ! + subroutine create_flavor(key_species, flavor) + integer, dimension(:,:,:), intent(in) :: key_species + integer, dimension(:,:), allocatable, intent(out) :: flavor + integer, dimension(2,size(key_species,3)*2) :: key_species_list + + integer :: ibnd, iatm, i, iflavor + ! prepare list of key_species + i = 1 + do ibnd=1,size(key_species,3) ! bands + do iatm=1,size(key_species,2) ! upper/lower atmosphere + key_species_list(:,i) = key_species(:,iatm,ibnd) + i = i + 1 + end do + end do + ! rewrite single key_species pairs + do i=1,size(key_species_list,2) + key_species_list(:,i) = rewrite_key_species_pair(key_species_list(:,i)) + end do + ! count unique key species pairs + iflavor = 0 + do i=1,size(key_species_list,2) + if (.not.key_species_pair_exists(key_species_list(:,1:i-1),key_species_list(:,i))) then + iflavor = iflavor + 1 + end if + end do + ! fill flavors + allocate(flavor(2,iflavor)) + iflavor = 0 + do i=1,size(key_species_list,2) + if (.not.key_species_pair_exists(key_species_list(:,1:i-1),key_species_list(:,i))) then + iflavor = iflavor + 1 + flavor(:,iflavor) = key_species_list(:,i) + end if + end do + end subroutine create_flavor + ! --------------------------------------------------------------------------------------- + ! + ! create index list for extracting col_gas needed for minor gas optical depth calculations + ! + subroutine create_idx_minor(gas_names, & + gas_minor, identifier_minor, minor_gases_atm, idx_minor_atm) + character(len=*), dimension(:), intent(in) :: gas_names + character(len=*), dimension(:), intent(in) :: & + gas_minor, & + identifier_minor + character(len=*), dimension(:), intent(in) :: minor_gases_atm + integer, dimension(:), allocatable, & + intent(out) :: idx_minor_atm + + ! local + integer :: imnr + integer :: idx_mnr + allocate(idx_minor_atm(size(minor_gases_atm,dim=1))) + do imnr = 1, size(minor_gases_atm,dim=1) ! loop over minor absorbers in each band + ! Find identifying string for minor species in list of possible identifiers (e.g. h2o_slf) + idx_mnr = string_loc_in_array(minor_gases_atm(imnr), identifier_minor) + ! Find name of gas associated with minor species identifier (e.g. h2o) + idx_minor_atm(imnr) = string_loc_in_array(gas_minor(idx_mnr), gas_names) + enddo + end subroutine create_idx_minor + + ! --------------------------------------------------------------------------------------- + ! + ! create index for special treatment in density scaling of minor gases + ! + subroutine create_idx_minor_scaling(gas_names, & + scaling_gas_atm, idx_minor_scaling_atm) + character(len=*), dimension(:), intent(in) :: gas_names + character(len=*), dimension(:), intent(in) :: scaling_gas_atm + integer, dimension(:), allocatable, & + intent(out) :: idx_minor_scaling_atm - is_loaded = allocated(this%kmajor) - end function is_loaded - !-------------------------------------------------------------------------------------------------------------------- - ! - ! Reset the object to un-initialized state - ! - subroutine finalize(this) - class(ty_gas_optics_rrtmgp), intent(inout) :: this - real(wp), dimension(:), allocatable :: press_ref, press_ref_log, temp_ref - - if(this%is_loaded()) then - !$acc exit data delete(this%gas_names, this%vmr_ref, this%flavor) & - !$acc delete(this%gpoint_flavor, this%kmajor) & - !$acc delete(this%minor_limits_gpt_lower) & - !$acc delete(this%minor_scales_with_density_lower, this%scale_by_complement_lower) & - !$acc delete(this%idx_minor_lower, this%idx_minor_scaling_lower) & - !$acc delete(this%kminor_start_lower, this%kminor_lower) & - !$acc delete(this%minor_limits_gpt_upper) & - !$acc delete(this%minor_scales_with_density_upper, this%scale_by_complement_upper) & - !$acc delete(this%idx_minor_upper, this%idx_minor_scaling_upper) & - !$acc delete(this%kminor_start_upper, this%kminor_upper) - !$omp target exit data map(release:this%gas_names, this%vmr_ref, this%flavor) & - !$omp map(release:this%gpoint_flavor, this%kmajor) & - !$omp map(release:this%minor_limits_gpt_lower) & - !$omp map(release:this%minor_scales_with_density_lower, this%scale_by_complement_lower) & - !$omp map(release:this%idx_minor_lower, this%idx_minor_scaling_lower) & - !$omp map(release:this%kminor_start_lower, this%kminor_lower) & - !$omp map(release:this%minor_limits_gpt_upper) & - !$omp map(release:this%minor_scales_with_density_upper, this%scale_by_complement_upper) & - !$omp map(release:this%idx_minor_upper, this%idx_minor_scaling_upper) & - !$omp map(release:this%kminor_start_upper, this%kminor_upper) - deallocate(this%gas_names, this%vmr_ref, this%flavor, this%gpoint_flavor, this%kmajor) - deallocate(this%minor_limits_gpt_lower, & - this%minor_scales_with_density_lower, this%scale_by_complement_lower, & - this%idx_minor_lower, this%idx_minor_scaling_lower, this%kminor_start_lower, this%kminor_lower) - deallocate(this%minor_limits_gpt_upper, & - this%minor_scales_with_density_upper, this%scale_by_complement_upper, & - this%idx_minor_upper, this%idx_minor_scaling_upper, this%kminor_start_upper, this%kminor_upper) - - if(allocated(this%krayl)) then - !$acc exit data delete(this%krayl) - !$omp target exit data map(release:this%krayl) - deallocate(this%krayl) - end if - - if(allocated(this%planck_frac)) then - !$acc exit data delete(this%planck_frac, this%totplnk, this%optimal_angle_fit) - !$omp target exit data map(release:this%planck_frac, this%totplnk, this%optimal_angle_fit) - deallocate(this%planck_frac, this%totplnk, this%optimal_angle_fit) - end if - - if(allocated(this%solar_source)) then - !$acc exit data delete(this%solar_source, this%solar_source_quiet) & - !$acc delete(this%solar_source_facular,this%solar_source_sunspot) - !$omp target exit data map(release:this%solar_source, this%solar_source_quiet) - !$omp map(release:this%solar_source_facular,this%solar_source_sunspot) - deallocate(this%solar_source, & - this%solar_source_quiet, this%solar_source_facular, this%solar_source_sunspot) - end if - !$acc exit data delete(this) - !$omp target exit data map(release:this) - end if - - end subroutine finalize - ! --------------------------------------------------------------------------------------- - subroutine create_key_species_reduce(gas_names,gas_names_red, & - key_species,key_species_red,key_species_present_init) - character(len=*), & - dimension(:), intent(in) :: gas_names - character(len=*), & - dimension(:), intent(in) :: gas_names_red - integer, dimension(:,:,:), intent(in) :: key_species - integer, dimension(:,:,:), allocatable, intent(out) :: key_species_red - - logical, dimension(:), allocatable, intent(out) :: key_species_present_init - integer :: ip, ia, it, np, na, nt - - np = size(key_species,dim=1) - na = size(key_species,dim=2) - nt = size(key_species,dim=3) - allocate(key_species_red(size(key_species,dim=1), & - size(key_species,dim=2), & - size(key_species,dim=3))) - allocate(key_species_present_init(size(gas_names))) - key_species_present_init = .true. - - do ip = 1, np - do ia = 1, na - do it = 1, nt - if (key_species(ip,ia,it) .ne. 0) then - key_species_red(ip,ia,it) = string_loc_in_array(gas_names(key_species(ip,ia,it)),gas_names_red) - if (key_species_red(ip,ia,it) .eq. -1) key_species_present_init(key_species(ip,ia,it)) = .false. - else - key_species_red(ip,ia,it) = key_species(ip,ia,it) - endif - enddo - end do - enddo - - end subroutine create_key_species_reduce - -! --------------------------------------------------------------------------------------- + ! local + integer :: imnr + allocate(idx_minor_scaling_atm(size(scaling_gas_atm,dim=1))) + do imnr = 1, size(scaling_gas_atm,dim=1) ! loop over minor absorbers in each band + ! This will be -1 if there's no interacting gas + idx_minor_scaling_atm(imnr) = string_loc_in_array(scaling_gas_atm(imnr), gas_names) + enddo + end subroutine create_idx_minor_scaling + !-------------------------------------------------------------------------------------------------------------------- + ! Is the object ready to use? + ! + pure function is_loaded(this) + class(ty_gas_optics_rrtmgp), intent(in) :: this + logical(wl) :: is_loaded + + is_loaded = allocated(this%kmajor) + end function is_loaded + !-------------------------------------------------------------------------------------------------------------------- + ! + ! Reset the object to un-initialized state + ! + subroutine finalize(this) + class(ty_gas_optics_rrtmgp), intent(inout) :: this + + if(this%is_loaded()) then + !$acc exit data delete(this%gas_names, this%vmr_ref, this%flavor) & + !$acc delete(this%press_ref, this%press_ref_log, this%temp_ref) & + !$acc delete(this%gpoint_flavor, this%kmajor) & + !$acc delete(this%minor_limits_gpt_lower) & + !$acc delete(this%minor_scales_with_density_lower, this%scale_by_complement_lower) & + !$acc delete(this%idx_minor_lower, this%idx_minor_scaling_lower) & + !$acc delete(this%kminor_start_lower, this%kminor_lower) & + !$acc delete(this%minor_limits_gpt_upper) & + !$acc delete(this%minor_scales_with_density_upper, this%scale_by_complement_upper) & + !$acc delete(this%idx_minor_upper, this%idx_minor_scaling_upper) & + !$acc delete(this%kminor_start_upper, this%kminor_upper) + !$omp target exit data map(release:this%gas_names, this%vmr_ref, this%flavor) & + !$omp map(release:this%press_ref, this%press_ref_log, this%temp_ref) + !$omp map(release:this%gpoint_flavor, this%kmajor) & + !$omp map(release:this%minor_limits_gpt_lower) & + !$omp map(release:this%minor_scales_with_density_lower, this%scale_by_complement_lower) & + !$omp map(release:this%idx_minor_lower, this%idx_minor_scaling_lower) & + !$omp map(release:this%kminor_start_lower, this%kminor_lower) & + !$omp map(release:this%minor_limits_gpt_upper) & + !$omp map(release:this%minor_scales_with_density_upper, this%scale_by_complement_upper) & + !$omp map(release:this%idx_minor_upper, this%idx_minor_scaling_upper) & + !$omp map(release:this%kminor_start_upper, this%kminor_upper) + deallocate(this%gas_names, this%vmr_ref, this%flavor, this%gpoint_flavor, this%kmajor) + deallocate(this%press_ref, this%press_ref_log, this%temp_ref) + deallocate(this%minor_limits_gpt_lower, & + this%minor_scales_with_density_lower, this%scale_by_complement_lower, & + this%idx_minor_lower, this%idx_minor_scaling_lower, this%kminor_start_lower, this%kminor_lower) + deallocate(this%minor_limits_gpt_upper, & + this%minor_scales_with_density_upper, this%scale_by_complement_upper, & + this%idx_minor_upper, this%idx_minor_scaling_upper, this%kminor_start_upper, this%kminor_upper) + + if(allocated(this%krayl)) then + !$acc exit data delete(this%krayl) + !$omp target exit data map(release:this%krayl) + deallocate(this%krayl) + end if + + if(allocated(this%planck_frac)) then + !$acc exit data delete(this%planck_frac, this%totplnk, this%optimal_angle_fit) + !$omp target exit data map(release:this%planck_frac, this%totplnk, this%optimal_angle_fit) + deallocate(this%planck_frac, this%totplnk, this%optimal_angle_fit) + end if + + if(allocated(this%solar_source)) then + !$acc exit data delete(this%solar_source, this%solar_source_quiet) & + !$acc delete(this%solar_source_facular,this%solar_source_sunspot) + !$omp target exit data map(release:this%solar_source, this%solar_source_quiet) + !$omp map(release:this%solar_source_facular,this%solar_source_sunspot) + deallocate(this%solar_source, & + this%solar_source_quiet, this%solar_source_facular, this%solar_source_sunspot) + end if + !$acc exit data delete(this) + !$omp target exit data map(release:this) + end if + + end subroutine finalize + ! --------------------------------------------------------------------------------------- + subroutine create_key_species_reduce(gas_names,gas_names_red, & + key_species,key_species_red,key_species_present_init) + character(len=*), & + dimension(:), intent(in) :: gas_names + character(len=*), & + dimension(:), intent(in) :: gas_names_red + integer, dimension(:,:,:), intent(in) :: key_species + integer, dimension(:,:,:), allocatable, intent(out) :: key_species_red + + logical, dimension(:), allocatable, intent(out) :: key_species_present_init + integer :: ip, ia, it, np, na, nt + + np = size(key_species,dim=1) + na = size(key_species,dim=2) + nt = size(key_species,dim=3) + allocate(key_species_red(size(key_species,dim=1), & + size(key_species,dim=2), & + size(key_species,dim=3))) + allocate(key_species_present_init(size(gas_names))) + key_species_present_init = .true. - subroutine reduce_minor_arrays(available_gases, & - gas_minor,identifier_minor,& - kminor_atm, & - minor_gases_atm, & - minor_limits_gpt_atm, & - minor_scales_with_density_atm, & - scaling_gas_atm, & - scale_by_complement_atm, & - kminor_start_atm, & - kminor_atm_red, & - minor_gases_atm_red, & - minor_limits_gpt_atm_red, & - minor_scales_with_density_atm_red, & - scaling_gas_atm_red, & - scale_by_complement_atm_red, & - kminor_start_atm_red) + do ip = 1, np + do ia = 1, na + do it = 1, nt + if (key_species(ip,ia,it) .ne. 0) then + key_species_red(ip,ia,it) = string_loc_in_array(gas_names(key_species(ip,ia,it)),gas_names_red) + if (key_species_red(ip,ia,it) .eq. -1) key_species_present_init(key_species(ip,ia,it)) = .false. + else + key_species_red(ip,ia,it) = key_species(ip,ia,it) + endif + enddo + end do + enddo + + end subroutine create_key_species_reduce + +! --------------------------------------------------------------------------------------- - class(ty_gas_concs), intent(in) :: available_gases - real(wp), dimension(:,:,:), intent(in) :: kminor_atm - character(len=*), dimension(:), intent(in) :: gas_minor, & - identifier_minor - character(len=*), dimension(:), intent(in) :: minor_gases_atm - integer, dimension(:,:), intent(in) :: minor_limits_gpt_atm - logical(wl), dimension(:), intent(in) :: minor_scales_with_density_atm - character(len=*), dimension(:), intent(in) :: scaling_gas_atm - logical(wl), dimension(:), intent(in) :: scale_by_complement_atm - integer, dimension(:), intent(in) :: kminor_start_atm - real(wp), dimension(:,:,:), allocatable, & - intent(out) :: kminor_atm_red - character(len=*), dimension(:), allocatable, & - intent(out) :: minor_gases_atm_red - integer, dimension(:,:), allocatable, & - intent(out) :: minor_limits_gpt_atm_red - logical(wl), dimension(:), allocatable, & - intent(out) ::minor_scales_with_density_atm_red - character(len=*), dimension(:), allocatable, & - intent(out) ::scaling_gas_atm_red - logical(wl), dimension(:), allocatable, intent(out) :: & - scale_by_complement_atm_red - integer, dimension(:), allocatable, intent(out) :: & - kminor_start_atm_red - - ! Local variables - integer :: i, j, ks - integer :: idx_mnr, nm, tot_g, red_nm - integer :: icnt, n_elim, ng - logical, dimension(:), allocatable :: gas_is_present - integer, dimension(:), allocatable :: indexes - real(wp), dimension(:,:,:), allocatable :: kminor_atm_red_t - - nm = size(minor_gases_atm) - tot_g=0 - allocate(gas_is_present(nm)) - do i = 1, size(minor_gases_atm) - idx_mnr = string_loc_in_array(minor_gases_atm(i), identifier_minor) - ! Next line causes a compiler bug in gfortran 11.0.1 on Mac ARM - ! Should replace gas_names with get_gas_names() and make gas_names private in ty_gas_concs - gas_is_present(i) = string_in_array(gas_minor(idx_mnr),available_gases%gas_names) - if(gas_is_present(i)) then - tot_g = tot_g + (minor_limits_gpt_atm(2,i)-minor_limits_gpt_atm(1,i)+1) - endif - enddo - red_nm = count(gas_is_present) - - allocate(minor_gases_atm_red (red_nm),& - minor_scales_with_density_atm_red(red_nm), & - scaling_gas_atm_red (red_nm), & - scale_by_complement_atm_red (red_nm), & - kminor_start_atm_red (red_nm)) - allocate(minor_limits_gpt_atm_red(2, red_nm)) - allocate(kminor_atm_red_t(tot_g, size(kminor_atm,2), size(kminor_atm,3))) - allocate(kminor_atm_red(size(kminor_atm,3),size(kminor_atm,2),tot_g)) - - if ((red_nm .eq. nm)) then - ! Character data not allowed in OpenACC regions? - minor_gases_atm_red = minor_gases_atm - scaling_gas_atm_red = scaling_gas_atm - kminor_atm_red_t = kminor_atm - minor_limits_gpt_atm_red = minor_limits_gpt_atm - minor_scales_with_density_atm_red = minor_scales_with_density_atm - scale_by_complement_atm_red = scale_by_complement_atm - kminor_start_atm_red = kminor_start_atm - else - allocate(indexes(red_nm)) - ! Find the integer indexes for the gases that are present - indexes = pack([(i, i = 1, size(minor_gases_atm))], mask=gas_is_present) - - minor_gases_atm_red = minor_gases_atm (indexes) - scaling_gas_atm_red = scaling_gas_atm (indexes) - minor_scales_with_density_atm_red = & - minor_scales_with_density_atm(indexes) - scale_by_complement_atm_red = & - scale_by_complement_atm(indexes) - kminor_start_atm_red = kminor_start_atm (indexes) - - icnt = 0 - n_elim = 0 - do i = 1, nm - ng = minor_limits_gpt_atm(2,i)-minor_limits_gpt_atm(1,i)+1 - if(gas_is_present(i)) then - icnt = icnt + 1 - minor_limits_gpt_atm_red(1:2,icnt) = minor_limits_gpt_atm(1:2,i) - kminor_start_atm_red(icnt) = kminor_start_atm(i)-n_elim - ks = kminor_start_atm_red(icnt) - do j = 1, ng - kminor_atm_red_t(kminor_start_atm_red(icnt)+j-1,:,:) = & - kminor_atm(kminor_start_atm(i)+j-1,:,:) - enddo - else - n_elim = n_elim + ng - endif - enddo - endif - - kminor_atm_red = RESHAPE(kminor_atm_red_t,(/size(kminor_atm_red_t,dim=3), & - size(kminor_atm_red_t,dim=2),size(kminor_atm_red_t,dim=1)/), ORDER=(/3,2,1/)) - deallocate(kminor_atm_red_t) - end subroutine reduce_minor_arrays - -! --------------------------------------------------------------------------------------- - ! returns flavor index; -1 if not found - pure function key_species_pair2flavor(flavor, key_species_pair) - integer :: key_species_pair2flavor - integer, dimension(:,:), intent(in) :: flavor - integer, dimension(2), intent(in) :: key_species_pair - integer :: iflav - do iflav=1,size(flavor,2) - if (all(key_species_pair(:).eq.flavor(:,iflav))) then - key_species_pair2flavor = iflav - return - end if - end do - key_species_pair2flavor = -1 - end function key_species_pair2flavor - - ! --------------------------------------------------------------------------------------- - ! - ! create gpoint_flavor list - ! a map pointing from each g-point to the corresponding entry in the "flavor list" - ! - subroutine create_gpoint_flavor(key_species, gpt2band, flavor, gpoint_flavor) - integer, dimension(:,:,:), intent(in) :: key_species - integer, dimension(:), intent(in) :: gpt2band - integer, dimension(:,:), intent(in) :: flavor - integer, dimension(:,:), intent(out), allocatable :: gpoint_flavor - integer :: ngpt, igpt, iatm - ngpt = size(gpt2band) - allocate(gpoint_flavor(2,ngpt)) - do igpt=1,ngpt - do iatm=1,2 - gpoint_flavor(iatm,igpt) = key_species_pair2flavor( & - flavor, & - rewrite_key_species_pair(key_species(:,iatm,gpt2band(igpt))) & - ) - end do - end do - end subroutine create_gpoint_flavor - - !-------------------------------------------------------------------------------------------------------------------- - ! - ! Utility function to combine optical depths from gas absorption and Rayleigh scattering - ! It may be more efficient to combine scattering and absorption optical depths in place - ! rather than storing and processing two large arrays - ! - subroutine combine_abs_and_rayleigh(tau, tau_rayleigh, optical_props) - real(wp), dimension(:,:,:), intent(in ) :: tau - real(wp), dimension(:,:,:), intent(in ) :: tau_rayleigh - class(ty_optical_props_arry), intent(inout) :: optical_props - - integer :: icol, ilay, igpt, ncol, nlay, ngpt, nmom - real(wp) :: t - - ncol = size(tau, 1) - nlay = size(tau, 2) - ngpt = size(tau, 3) - select type(optical_props) - type is (ty_optical_props_1scl) - ! - ! Extinction optical depth - ! - !$acc parallel loop gang vector collapse(3) default(present) - !$omp target teams distribute parallel do simd collapse(3) - do igpt = 1, ngpt - do ilay = 1, nlay - do icol = 1, ncol - optical_props%tau(icol,ilay,igpt) = tau(icol,ilay,igpt) + & - tau_rayleigh(icol,ilay,igpt) - end do - end do - end do - ! - ! asymmetry factor or phase function moments - ! - type is (ty_optical_props_2str) + subroutine reduce_minor_arrays(available_gases, & + gas_minor,identifier_minor,& + kminor_atm, & + minor_gases_atm, & + minor_limits_gpt_atm, & + minor_scales_with_density_atm, & + scaling_gas_atm, & + scale_by_complement_atm, & + kminor_start_atm, & + kminor_atm_red, & + minor_gases_atm_red, & + minor_limits_gpt_atm_red, & + minor_scales_with_density_atm_red, & + scaling_gas_atm_red, & + scale_by_complement_atm_red, & + kminor_start_atm_red) + + class(ty_gas_concs), intent(in) :: available_gases + real(wp), dimension(:,:,:), intent(in) :: kminor_atm + character(len=*), dimension(:), intent(in) :: gas_minor, & + identifier_minor + character(len=*), dimension(:), intent(in) :: minor_gases_atm + integer, dimension(:,:), intent(in) :: minor_limits_gpt_atm + logical(wl), dimension(:), intent(in) :: minor_scales_with_density_atm + character(len=*), dimension(:), intent(in) :: scaling_gas_atm + logical(wl), dimension(:), intent(in) :: scale_by_complement_atm + integer, dimension(:), intent(in) :: kminor_start_atm + real(wp), dimension(:,:,:), allocatable, & + intent(out) :: kminor_atm_red + character(len=*), dimension(:), allocatable, & + intent(out) :: minor_gases_atm_red + integer, dimension(:,:), allocatable, & + intent(out) :: minor_limits_gpt_atm_red + logical(wl), dimension(:), allocatable, & + intent(out) ::minor_scales_with_density_atm_red + character(len=*), dimension(:), allocatable, & + intent(out) ::scaling_gas_atm_red + logical(wl), dimension(:), allocatable, intent(out) :: & + scale_by_complement_atm_red + integer, dimension(:), allocatable, intent(out) :: & + kminor_start_atm_red + + ! Local variables + integer :: i, j, ks + integer :: idx_mnr, nm, tot_g, red_nm + integer :: icnt, n_elim, ng + logical, dimension(:), allocatable :: gas_is_present + integer, dimension(:), allocatable :: indexes + real(wp), dimension(:,:,:), allocatable :: kminor_atm_red_t + + nm = size(minor_gases_atm) + tot_g=0 + allocate(gas_is_present(nm)) + do i = 1, size(minor_gases_atm) + idx_mnr = string_loc_in_array(minor_gases_atm(i), identifier_minor) + ! Next line causes a compiler bug in gfortran 11.0.1 on Mac ARM + ! Should replace gas_names with get_gas_names() and make gas_names private in ty_gas_concs + gas_is_present(i) = string_in_array(gas_minor(idx_mnr),available_gases%gas_names) + if(gas_is_present(i)) then + tot_g = tot_g + (minor_limits_gpt_atm(2,i)-minor_limits_gpt_atm(1,i)+1) + endif + enddo + red_nm = count(gas_is_present) + + allocate(minor_gases_atm_red (red_nm),& + minor_scales_with_density_atm_red(red_nm), & + scaling_gas_atm_red (red_nm), & + scale_by_complement_atm_red (red_nm), & + kminor_start_atm_red (red_nm)) + allocate(minor_limits_gpt_atm_red(2, red_nm)) + allocate(kminor_atm_red_t(tot_g, size(kminor_atm,2), size(kminor_atm,3))) + allocate(kminor_atm_red(size(kminor_atm,3),size(kminor_atm,2),tot_g)) + + if ((red_nm .eq. nm)) then + ! Character data not allowed in OpenACC regions? + minor_gases_atm_red = minor_gases_atm + scaling_gas_atm_red = scaling_gas_atm + kminor_atm_red_t = kminor_atm + minor_limits_gpt_atm_red = minor_limits_gpt_atm + minor_scales_with_density_atm_red = minor_scales_with_density_atm + scale_by_complement_atm_red = scale_by_complement_atm + kminor_start_atm_red = kminor_start_atm + else + allocate(indexes(red_nm)) + ! Find the integer indexes for the gases that are present + indexes = pack([(i, i = 1, size(minor_gases_atm))], mask=gas_is_present) + + minor_gases_atm_red = minor_gases_atm (indexes) + scaling_gas_atm_red = scaling_gas_atm (indexes) + minor_scales_with_density_atm_red = & + minor_scales_with_density_atm(indexes) + scale_by_complement_atm_red = & + scale_by_complement_atm(indexes) + kminor_start_atm_red = kminor_start_atm (indexes) + + icnt = 0 + n_elim = 0 + do i = 1, nm + ng = minor_limits_gpt_atm(2,i)-minor_limits_gpt_atm(1,i)+1 + if(gas_is_present(i)) then + icnt = icnt + 1 + minor_limits_gpt_atm_red(1:2,icnt) = minor_limits_gpt_atm(1:2,i) + kminor_start_atm_red(icnt) = kminor_start_atm(i)-n_elim + ks = kminor_start_atm_red(icnt) + do j = 1, ng + kminor_atm_red_t(kminor_start_atm_red(icnt)+j-1,:,:) = & + kminor_atm(kminor_start_atm(i)+j-1,:,:) + enddo + else + n_elim = n_elim + ng + endif + enddo + endif + + kminor_atm_red = RESHAPE(kminor_atm_red_t,(/size(kminor_atm_red_t,dim=3), & + size(kminor_atm_red_t,dim=2),size(kminor_atm_red_t,dim=1)/), ORDER=(/3,2,1/)) + deallocate(kminor_atm_red_t) + end subroutine reduce_minor_arrays + +! --------------------------------------------------------------------------------------- + ! returns flavor index; -1 if not found + pure function key_species_pair2flavor(flavor, key_species_pair) + integer :: key_species_pair2flavor + integer, dimension(:,:), intent(in) :: flavor + integer, dimension(2), intent(in) :: key_species_pair + integer :: iflav + do iflav=1,size(flavor,2) + if (all(key_species_pair(:).eq.flavor(:,iflav))) then + key_species_pair2flavor = iflav + return + end if + end do + key_species_pair2flavor = -1 + end function key_species_pair2flavor + + ! --------------------------------------------------------------------------------------- + ! + ! create gpoint_flavor list + ! a map pointing from each g-point to the corresponding entry in the "flavor list" + ! + subroutine create_gpoint_flavor(key_species, gpt2band, flavor, gpoint_flavor) + integer, dimension(:,:,:), intent(in) :: key_species + integer, dimension(:), intent(in) :: gpt2band + integer, dimension(:,:), intent(in) :: flavor + integer, dimension(:,:), intent(out), allocatable :: gpoint_flavor + integer :: ngpt, igpt, iatm + ngpt = size(gpt2band) + allocate(gpoint_flavor(2,ngpt)) + do igpt=1,ngpt + do iatm=1,2 + gpoint_flavor(iatm,igpt) = key_species_pair2flavor( & + flavor, & + rewrite_key_species_pair(key_species(:,iatm,gpt2band(igpt))) & + ) + end do + end do + end subroutine create_gpoint_flavor + + !-------------------------------------------------------------------------------------------------------------------- + ! + ! Utility function to combine optical depths from gas absorption and Rayleigh scattering + ! It may be more efficient to combine scattering and absorption optical depths in place + ! rather than storing and processing two large arrays + ! + subroutine combine_abs_and_rayleigh(tau, tau_rayleigh, optical_props) + real(wp), dimension(:,:,:), intent(in ) :: tau + real(wp), dimension(:,:,:), intent(in ) :: tau_rayleigh + class(ty_optical_props_arry), intent(inout) :: optical_props + + integer :: icol, ilay, igpt, ncol, nlay, ngpt, nmom + real(wp) :: t + + ncol = size(tau, 1) + nlay = size(tau, 2) + ngpt = size(tau, 3) + select type(optical_props) + type is (ty_optical_props_1scl) ! - ! Extinction optical depth and single scattering albedo + ! Extinction optical depth ! !$acc parallel loop gang vector collapse(3) default(present) !$omp target teams distribute parallel do simd collapse(3) do igpt = 1, ngpt do ilay = 1, nlay do icol = 1, ncol - t = tau(icol,ilay,igpt) + tau_rayleigh(icol,ilay,igpt) - if(t > 2._wp * tiny(t)) then - optical_props%ssa(icol,ilay,igpt) = tau_rayleigh(icol,ilay,igpt) / t - else - optical_props%ssa(icol,ilay,igpt) = 0._wp - end if - optical_props%tau(icol,ilay,igpt) = t - end do - end do - end do - call zero_array(ncol, nlay, ngpt, optical_props%g) - type is (ty_optical_props_nstr) - ! - ! Extinction optical depth and single scattering albedo - ! - !$acc parallel loop gang vector collapse(3) default(present) - !$omp target teams distribute parallel do simd collapse(3) - do igpt = 1, ngpt - do ilay = 1, nlay - do icol = 1, ncol - t = tau(icol,ilay,igpt) + tau_rayleigh(icol,ilay,igpt) - if(t > 2._wp * tiny(t)) then - optical_props%ssa(icol,ilay,igpt) = tau_rayleigh(icol,ilay,igpt) / t - else - optical_props%ssa(icol,ilay,igpt) = 0._wp - end if - optical_props%tau(icol,ilay,igpt) = t - end do - end do - end do - nmom = size(optical_props%p, 1) - call zero_array(nmom, ncol, nlay, ngpt, optical_props%p) - if(nmom >= 2) then - !$acc parallel loop gang vector collapse(3) default(present) - !$omp target teams distribute parallel do simd collapse(3) - do igpt = 1, ngpt - do ilay = 1, nlay - do icol = 1, ncol - optical_props%p(2,icol,ilay,igpt) = 0.1_wp - end do - end do - end do - end if - end select - end subroutine combine_abs_and_rayleigh - !-------------------------------------------------------------------------------------------------------------------- - ! Sizes of tables: pressure, temperate, eta (mixing fraction) - ! Equivalent routines for the number of gases and flavors (get_ngas(), get_nflav()) are defined above because they're - ! used in function defintions - ! Table kmajor has dimensions (ngpt, neta, npres, ntemp) - !-------------------------------------------------------------------------------------------------------------------- - ! - ! return extent of eta dimension - ! - pure function get_neta(this) - class(ty_gas_optics_rrtmgp), intent(in) :: this - integer :: get_neta - - get_neta = size(this%kmajor,dim=2) - end function - ! -------------------------------------------------------------------------------------- - ! - ! return the number of pressures in reference profile - ! absorption coefficient table is one bigger since a pressure is repeated in upper/lower atmos - ! - pure function get_npres(this) - class(ty_gas_optics_rrtmgp), intent(in) :: this - integer :: get_npres - - get_npres = size(this%kmajor,dim=3)-1 - end function get_npres - ! -------------------------------------------------------------------------------------- - ! - ! return the number of temperatures - ! - pure function get_ntemp(this) - class(ty_gas_optics_rrtmgp), intent(in) :: this - integer :: get_ntemp - - get_ntemp = size(this%kmajor,dim=1) - end function get_ntemp - ! -------------------------------------------------------------------------------------- - ! - ! return the number of temperatures for Planck function - ! - pure function get_nPlanckTemp(this) - class(ty_gas_optics_rrtmgp), intent(in) :: this - integer :: get_nPlanckTemp - - get_nPlanckTemp = size(this%totplnk,dim=1) ! dimensions are Planck-temperature, band - end function get_nPlanckTemp -end module mo_gas_optics_rrtmgp + optical_props%tau(icol,ilay,igpt) = tau(icol,ilay,igpt) + & + tau_rayleigh(icol,ilay,igpt) + end do + end do + end do + ! + ! asymmetry factor or phase function moments + ! + type is (ty_optical_props_2str) + ! + ! Extinction optical depth and single scattering albedo + ! + !$acc parallel loop gang vector collapse(3) default(present) + !$omp target teams distribute parallel do simd collapse(3) + do igpt = 1, ngpt + do ilay = 1, nlay + do icol = 1, ncol + t = tau(icol,ilay,igpt) + tau_rayleigh(icol,ilay,igpt) + if(t > 2._wp * tiny(t)) then + optical_props%ssa(icol,ilay,igpt) = tau_rayleigh(icol,ilay,igpt) / t + else + optical_props%ssa(icol,ilay,igpt) = 0._wp + end if + optical_props%tau(icol,ilay,igpt) = t + end do + end do + end do + call zero_array(ncol, nlay, ngpt, optical_props%g) + type is (ty_optical_props_nstr) + ! + ! Extinction optical depth and single scattering albedo + ! + !$acc parallel loop gang vector collapse(3) default(present) + !$omp target teams distribute parallel do simd collapse(3) + do igpt = 1, ngpt + do ilay = 1, nlay + do icol = 1, ncol + t = tau(icol,ilay,igpt) + tau_rayleigh(icol,ilay,igpt) + if(t > 2._wp * tiny(t)) then + optical_props%ssa(icol,ilay,igpt) = tau_rayleigh(icol,ilay,igpt) / t + else + optical_props%ssa(icol,ilay,igpt) = 0._wp + end if + optical_props%tau(icol,ilay,igpt) = t + end do + end do + end do + nmom = size(optical_props%p, 1) + call zero_array(nmom, ncol, nlay, ngpt, optical_props%p) + if(nmom >= 2) then + !$acc parallel loop gang vector collapse(3) default(present) + !$omp target teams distribute parallel do simd collapse(3) + do igpt = 1, ngpt + do ilay = 1, nlay + do icol = 1, ncol + optical_props%p(2,icol,ilay,igpt) = 0.1_wp + end do + end do + end do + end if + end select + end subroutine combine_abs_and_rayleigh + !-------------------------------------------------------------------------------------------------------------------- + ! Sizes of tables: pressure, temperate, eta (mixing fraction) + ! Equivalent routines for the number of gases and flavors (get_ngas(), get_nflav()) are defined above because they're + ! used in function defintions + ! Table kmajor has dimensions (ngpt, neta, npres, ntemp) + !-------------------------------------------------------------------------------------------------------------------- + ! + ! return extent of eta dimension + ! + pure function get_neta(this) + class(ty_gas_optics_rrtmgp), intent(in) :: this + integer :: get_neta + + get_neta = size(this%kmajor,dim=2) + end function + ! -------------------------------------------------------------------------------------- + ! + ! return the number of pressures in reference profile + ! absorption coefficient table is one bigger since a pressure is repeated in upper/lower atmos + ! + pure function get_npres(this) + class(ty_gas_optics_rrtmgp), intent(in) :: this + integer :: get_npres + + get_npres = size(this%kmajor,dim=3)-1 + end function get_npres + ! -------------------------------------------------------------------------------------- + ! + ! return the number of temperatures + ! + pure function get_ntemp(this) + class(ty_gas_optics_rrtmgp), intent(in) :: this + integer :: get_ntemp + + get_ntemp = size(this%kmajor,dim=1) + end function get_ntemp + ! -------------------------------------------------------------------------------------- + ! + ! return the number of temperatures for Planck function + ! + pure function get_nPlanckTemp(this) + class(ty_gas_optics_rrtmgp), intent(in) :: this + integer :: get_nPlanckTemp + + get_nPlanckTemp = size(this%totplnk,dim=1) ! dimensions are Planck-temperature, band + end function get_nPlanckTemp +end module mo_gas_optics_rrtmgp diff --git a/reference/rrtmgp-fortran-interface/src/mo_gas_optics_rrtmgp.F90 b/reference/rrtmgp-fortran-interface/src/mo_gas_optics_rrtmgp.F90 index 7af8ae543..906c7cccb 100644 --- a/reference/rrtmgp-fortran-interface/src/mo_gas_optics_rrtmgp.F90 +++ b/reference/rrtmgp-fortran-interface/src/mo_gas_optics_rrtmgp.F90 @@ -304,30 +304,29 @@ function gas_optics_int(this, & ! ! Interpolate source function + ! present status of optional argument should be passed to source() + ! but nvfortran (and PGI Fortran before it) do not do so ! - if(present(tlev)) then - ! - ! present status of optional argument should be passed to source() - ! but isn't with PGI 19.10 - ! + if(present(tlev)) then error_msg = source(this, & ncol, nlay, nband, ngpt, & play, plev, tlay, tsfc, & jtemp, jpress, jeta, tropo, fmajor, & sources, & tlev) - !$acc exit data delete(tlev) + !$acc exit data delete(tlev) !$omp target exit data map(release:tlev) - else + else error_msg = source(this, & ncol, nlay, nband, ngpt, & play, plev, tlay, tsfc, & jtemp, jpress, jeta, tropo, fmajor, & sources) - end if - !$acc exit data delete(tsfc) + + end if + !$acc exit data delete(tsfc) !$omp target exit data map(release:tsfc) - !$acc exit data delete(jtemp, jpress, tropo, fmajor, jeta) + !$acc exit data delete(jtemp, jpress, tropo, fmajor, jeta) !$omp target exit data map(release:jtemp, jpress, tropo, fmajor, jeta) end function gas_optics_int !------------------------------------------------------------------------------------------ @@ -802,6 +801,7 @@ function set_tsi(this, tsi) result(error_msg) character(len=128) :: error_msg !! Empty if successful real(wp) :: norm + integer :: igpt, length ! ---------------------------------------------------------- error_msg = "" if(tsi < 0._wp) then @@ -810,12 +810,21 @@ function set_tsi(this, tsi) result(error_msg) ! ! Scale the solar source function to the input tsi ! - !$acc kernels - !$omp target - norm = 1._wp/sum(this%solar_source(:)) - this%solar_source(:) = this%solar_source(:) * tsi * norm - !$acc end kernels - !$omp end target + norm = 0._wp + length = size(this%solar_source) + !$acc parallel loop gang vector reduction(+:norm) + !$omp target teams distribute parallel do simd reduction(+:norm) + do igpt = 1, length + norm = norm + this%solar_source(igpt) + end do + + norm = 1._wp/norm + + !$acc parallel loop gang vector + !$omp target teams distribute parallel do simd + do igpt = 1, length + this%solar_source(igpt) = this%solar_source(igpt) * tsi * norm + end do end if end function set_tsi @@ -858,7 +867,15 @@ function source(this, & error_msg = "" ! ! Source function needs temperature at interfaces/levels and at layer centers + ! Allocate small local array for tlev unconditionally ! + !$acc data copyin(sources) copyout( sources%lay_source, sources%lev_source) & + !$acc copyout( sources%sfc_source, sources%sfc_source_Jac) & + !$acc create(tlev_arr) + !$omp target data map(from:sources%lay_source, sources%lev_source) & + !$omp map(from:sources%sfc_source, sources%sfc_source_Jac) & + !$omp map(alloc:tlev_arr) + if (present(tlev)) then ! Users might have provided these tlev_wk => tlev @@ -868,32 +885,30 @@ function source(this, & ! Interpolate temperature to levels if not provided ! Interpolation and extrapolation at boundaries is weighted by pressure ! + !$acc parallel loop gang vector + !$omp target teams distribute parallel do simd do icol = 1, ncol - tlev_arr(icol,1) = tlay(icol,1) & + tlev_arr(icol,1) = tlay(icol,1) & + (plev(icol,1)-play(icol,1))*(tlay(icol,2)-tlay(icol,1)) & - & / (play(icol,2)-play(icol,1)) + / (play(icol,2)-play(icol,1)) + tlev_arr(icol,nlay+1) = tlay(icol,nlay) & + + (plev(icol,nlay+1)-play(icol,nlay))*(tlay(icol,nlay)-tlay(icol,nlay-1)) & + / (play(icol,nlay)-play(icol,nlay-1)) end do - do ilay = 2, nlay + !$acc parallel loop gang vector collapse(2) + !$omp target teams distribute parallel do simd collapse(2) + do ilay = 2, nlay do icol = 1, ncol tlev_arr(icol,ilay) = (play(icol,ilay-1)*tlay(icol,ilay-1)*(plev(icol,ilay )-play(icol,ilay)) & + play(icol,ilay )*tlay(icol,ilay )*(play(icol,ilay-1)-plev(icol,ilay))) / & (plev(icol,ilay)*(play(icol,ilay-1) - play(icol,ilay))) end do end do - do icol = 1, ncol - tlev_arr(icol,nlay+1) = tlay(icol,nlay) & - + (plev(icol,nlay+1)-play(icol,nlay))*(tlay(icol,nlay)-tlay(icol,nlay-1)) & - / (play(icol,nlay)-play(icol,nlay-1)) - end do end if !------------------------------------------------------------------- ! Compute internal (Planck) source functions at layers and levels, ! which depend on mapping from spectral space that creates k-distribution. - !$acc data copyin(sources) copyout( sources%lay_source, sources%lev_source_inc, sources%lev_source_dec) & - !$acc copyout( sources%sfc_source, sources%sfc_source_Jac) - !$omp target data map(from:sources%lay_source, sources%lev_source_inc, sources%lev_source_dec) & - !$omp map(from:sources%sfc_source, sources%sfc_source_Jac) !$acc kernels copyout(top_at_1) !$omp target map(from:top_at_1) @@ -907,7 +922,7 @@ function source(this, & fmajor, jeta, tropo, jtemp, jpress, & this%get_gpoint_bands(), this%get_band_lims_gpoint(), this%planck_frac, this%temp_ref_min,& this%totplnk_delta, this%totplnk, this%gpoint_flavor, & - sources%sfc_source, sources%lay_source, sources%lev_source_inc, sources%lev_source_dec, & + sources%sfc_source, sources%lay_source, sources%lev_source, & sources%sfc_source_Jac) !$acc end data !$omp end target data @@ -1723,10 +1738,10 @@ end function is_loaded ! subroutine finalize(this) class(ty_gas_optics_rrtmgp), intent(inout) :: this - real(wp), dimension(:), allocatable :: press_ref, press_ref_log, temp_ref if(this%is_loaded()) then !$acc exit data delete(this%gas_names, this%vmr_ref, this%flavor) & + !$acc delete(this%press_ref, this%press_ref_log, this%temp_ref) & !$acc delete(this%gpoint_flavor, this%kmajor) & !$acc delete(this%minor_limits_gpt_lower) & !$acc delete(this%minor_scales_with_density_lower, this%scale_by_complement_lower) & @@ -1737,6 +1752,7 @@ subroutine finalize(this) !$acc delete(this%idx_minor_upper, this%idx_minor_scaling_upper) & !$acc delete(this%kminor_start_upper, this%kminor_upper) !$omp target exit data map(release:this%gas_names, this%vmr_ref, this%flavor) & + !$omp map(release:this%press_ref, this%press_ref_log, this%temp_ref) !$omp map(release:this%gpoint_flavor, this%kmajor) & !$omp map(release:this%minor_limits_gpt_lower) & !$omp map(release:this%minor_scales_with_density_lower, this%scale_by_complement_lower) & @@ -1747,6 +1763,7 @@ subroutine finalize(this) !$omp map(release:this%idx_minor_upper, this%idx_minor_scaling_upper) & !$omp map(release:this%kminor_start_upper, this%kminor_upper) deallocate(this%gas_names, this%vmr_ref, this%flavor, this%gpoint_flavor, this%kmajor) + deallocate(this%press_ref, this%press_ref_log, this%temp_ref) deallocate(this%minor_limits_gpt_lower, & this%minor_scales_with_density_lower, this%scale_by_complement_lower, & this%idx_minor_lower, this%idx_minor_scaling_lower, this%kminor_start_lower, this%kminor_lower) diff --git a/reference/rrtmgp-fortran-interface/tipuesearch/tipuesearch_content.js b/reference/rrtmgp-fortran-interface/tipuesearch/tipuesearch_content.js index 4b02d279e..36892f7fc 100644 --- a/reference/rrtmgp-fortran-interface/tipuesearch/tipuesearch_content.js +++ b/reference/rrtmgp-fortran-interface/tipuesearch/tipuesearch_content.js @@ -1 +1 @@ -var tipuesearch = {"pages":[{"title":" RRTMGP-Fortran ","text":"RRTMGP-Fortran These pages provide a programmer's view of the Fortran user interface to RRTMGP. RRTMGP provides a class ty_gas_optics_rrtmgp that implements\nthe gas_optics() and other procedure(s) defined by the ty_gas_optics abstract class. The class is used to compute the spectrally-varying optical properties of the\ngaseous atmosphere given temperature, pressure, and gas concentrations. Each instance of the\nvariable is \"loaded\" with data from netCDF\nfiles in the $RRTMGP_DATA directory. Depending on the data provided the variable can be used\nor radiation emitted by the atmosphere and surface (\"longwave\") of for for radiation emitted\nby the planet's star (\"shortwave\"). The class implements both the longwave/internal sources and\nshortwave/external sources versions of the gas_optics procedure.\nThe longwave version reports Planck sources at layer centers and layer interfaces (levels)\nwhile the shortwave version reports the spectrally-varying stellar radiation\nCalling the longwave routine (by providing the longwave-relevant arguments)\nwhen the variable has been initialized with shortwave data triggers a run-time error. The user interface uses the ty_gas_concs type\nto represent the volume mixing ratios needed as input. Output suitable for\nscattering emission, two-stream, or multi-stream calculations are provided\ndepending on which sub-class of RTE's ty_optical_props_arry are provided. Planck source functions, if requested, are reported in a variable\nof type ty_source_func_lw. The listings below may not be exhaustive.\nTo see the full listings use the links at the top of the page.\nThere is a search bar in the top right. Return to the Documentation overview or the [reference overview]. Developer Info The RTE+RRTTMGP consortium","tags":"home","loc":"index.html"},{"title":"ty_cloud_optics_rrtmgp – RRTMGP-Fortran ","text":"type, public, extends(ty_optical_props) :: ty_cloud_optics_rrtmgp Inherits type~~ty_cloud_optics_rrtmgp~~InheritsGraph type~ty_cloud_optics_rrtmgp ty_cloud_optics_rrtmgp ty_optical_props ty_optical_props type~ty_cloud_optics_rrtmgp->ty_optical_props Help × Graph Key Nodes of different colours represent the following: Graph Key Type Type This Page's Entity This Page's Entity Solid arrows point from a derived type to the parent type which it\n extends. Dashed arrows point from a derived type to the other\n types it contains as a components, with a label listing the name(s) of\n said component(s). Contents Variables ice_nsteps ice_step_size icergh liq_nsteps liq_step_size lut_asyice lut_asyliq lut_extice lut_extliq lut_ssaice lut_ssaliq pade_asyice pade_asyliq pade_extice pade_extliq pade_sizreg_asyice pade_sizreg_asyliq pade_sizreg_extice pade_sizreg_extliq pade_sizreg_ssaice pade_sizreg_ssaliq pade_ssaice pade_ssaliq radice_lwr radice_upr radliq_lwr radliq_upr Type-Bound Procedures cloud_optics finalize get_max_radius_ice get_max_radius_liq get_min_radius_ice get_min_radius_liq get_num_ice_roughness_types load set_ice_roughness Components Type Visibility Attributes Name Initial integer, public :: ice_nsteps = 0 real(kind=wp), public :: ice_step_size = 0._wp integer, public :: icergh = 0 integer, public :: liq_nsteps = 0 real(kind=wp), public :: liq_step_size = 0._wp real(kind=wp), public, dimension(:,:,: ), allocatable :: lut_asyice real(kind=wp), public, dimension(:,: ), allocatable :: lut_asyliq real(kind=wp), public, dimension(:,:,: ), allocatable :: lut_extice real(kind=wp), public, dimension(:,: ), allocatable :: lut_extliq real(kind=wp), public, dimension(:,:,: ), allocatable :: lut_ssaice real(kind=wp), public, dimension(:,: ), allocatable :: lut_ssaliq real(kind=wp), public, dimension(:,:,:,:), allocatable :: pade_asyice real(kind=wp), public, dimension(:,:,: ), allocatable :: pade_asyliq real(kind=wp), public, dimension(:,:,:,:), allocatable :: pade_extice real(kind=wp), public, dimension(:,:,: ), allocatable :: pade_extliq real(kind=wp), public, dimension(:), allocatable :: pade_sizreg_asyice real(kind=wp), public, dimension(:), allocatable :: pade_sizreg_asyliq real(kind=wp), public, dimension(:), allocatable :: pade_sizreg_extice real(kind=wp), public, dimension(:), allocatable :: pade_sizreg_extliq real(kind=wp), public, dimension(:), allocatable :: pade_sizreg_ssaice real(kind=wp), public, dimension(:), allocatable :: pade_sizreg_ssaliq real(kind=wp), public, dimension(:,:,:,:), allocatable :: pade_ssaice real(kind=wp), public, dimension(:,:,: ), allocatable :: pade_ssaliq real(kind=wp), public :: radice_lwr = 0._wp real(kind=wp), public :: radice_upr = 0._wp real(kind=wp), public :: radliq_lwr = 0._wp real(kind=wp), public :: radliq_upr = 0._wp Type-Bound Procedures procedure, public :: cloud_optics private function cloud_optics(this, clwp, ciwp, reliq, reice, optical_props) result(error_msg) Arguments Type Intent Optional Attributes Name class( ty_cloud_optics_rrtmgp ), intent(in) :: this real(kind=wp), intent(in) :: clwp (:,:) real(kind=wp), intent(in) :: ciwp (:,:) real(kind=wp), intent(in) :: reliq (:,:) real(kind=wp), intent(in) :: reice (:,:) class(ty_optical_props_arry), intent(inout) :: optical_props Return Value character(len=128) procedure, public :: finalize private subroutine finalize(this) Arguments Type Intent Optional Attributes Name class( ty_cloud_optics_rrtmgp ), intent(inout) :: this procedure, public :: get_max_radius_ice private function get_max_radius_ice(this) result(r) Arguments Type Intent Optional Attributes Name class( ty_cloud_optics_rrtmgp ), intent(in) :: this Return Value real(kind=wp) procedure, public :: get_max_radius_liq private function get_max_radius_liq(this) result(r) Arguments Type Intent Optional Attributes Name class( ty_cloud_optics_rrtmgp ), intent(in) :: this Return Value real(kind=wp) procedure, public :: get_min_radius_ice private function get_min_radius_ice(this) result(r) Arguments Type Intent Optional Attributes Name class( ty_cloud_optics_rrtmgp ), intent(in) :: this Return Value real(kind=wp) procedure, public :: get_min_radius_liq private function get_min_radius_liq(this) result(r) Arguments Type Intent Optional Attributes Name class( ty_cloud_optics_rrtmgp ), intent(in) :: this Return Value real(kind=wp) procedure, public :: get_num_ice_roughness_types private function get_num_ice_roughness_types(this) result(i) Arguments Type Intent Optional Attributes Name class( ty_cloud_optics_rrtmgp ), intent(in) :: this Return Value integer generic, public :: load => load_lut, load_pade private function load_lut(this, band_lims_wvn, radliq_lwr, radliq_upr, radice_lwr, radice_upr, lut_extliq, lut_ssaliq, lut_asyliq, lut_extice, lut_ssaice, lut_asyice) result(error_msg) Arguments Type Intent Optional Attributes Name class( ty_cloud_optics_rrtmgp ), intent(inout) :: this real(kind=wp), intent(in), dimension(:,:) :: band_lims_wvn real(kind=wp), intent(in) :: radliq_lwr real(kind=wp), intent(in) :: radliq_upr real(kind=wp), intent(in) :: radice_lwr real(kind=wp), intent(in) :: radice_upr real(kind=wp), intent(in), dimension(:,:) :: lut_extliq real(kind=wp), intent(in), dimension(:,:) :: lut_ssaliq real(kind=wp), intent(in), dimension(:,:) :: lut_asyliq real(kind=wp), intent(in), dimension(:,:,:) :: lut_extice real(kind=wp), intent(in), dimension(:,:,:) :: lut_ssaice real(kind=wp), intent(in), dimension(:,:,:) :: lut_asyice Return Value character(len=128) private function load_pade(this, band_lims_wvn, pade_extliq, pade_ssaliq, pade_asyliq, pade_extice, pade_ssaice, pade_asyice, pade_sizreg_extliq, pade_sizreg_ssaliq, pade_sizreg_asyliq, pade_sizreg_extice, pade_sizreg_ssaice, pade_sizreg_asyice) result(error_msg) Arguments Type Intent Optional Attributes Name class( ty_cloud_optics_rrtmgp ), intent(inout) :: this real(kind=wp), intent(in), dimension(:,:) :: band_lims_wvn real(kind=wp), intent(in), dimension(:,:,:) :: pade_extliq real(kind=wp), intent(in), dimension(:,:,:) :: pade_ssaliq real(kind=wp), intent(in), dimension(:,:,:) :: pade_asyliq real(kind=wp), intent(in), dimension(:,:,:,:) :: pade_extice real(kind=wp), intent(in), dimension(:,:,:,:) :: pade_ssaice real(kind=wp), intent(in), dimension(:,:,:,:) :: pade_asyice real(kind=wp), intent(in), dimension(:) :: pade_sizreg_extliq real(kind=wp), intent(in), dimension(:) :: pade_sizreg_ssaliq real(kind=wp), intent(in), dimension(:) :: pade_sizreg_asyliq real(kind=wp), intent(in), dimension(:) :: pade_sizreg_extice real(kind=wp), intent(in), dimension(:) :: pade_sizreg_ssaice real(kind=wp), intent(in), dimension(:) :: pade_sizreg_asyice Return Value character(len=128) procedure, public :: set_ice_roughness private function set_ice_roughness(this, icergh) result(error_msg) Arguments Type Intent Optional Attributes Name class( ty_cloud_optics_rrtmgp ), intent(inout) :: this integer, intent(in) :: icergh Return Value character(len=128)","tags":"","loc":"type/ty_cloud_optics_rrtmgp.html"},{"title":"ty_gas_optics_rrtmgp – RRTMGP-Fortran ","text":"type, public, extends(ty_gas_optics) :: ty_gas_optics_rrtmgp Inherits type~~ty_gas_optics_rrtmgp~~InheritsGraph type~ty_gas_optics_rrtmgp ty_gas_optics_rrtmgp ty_gas_optics ty_gas_optics type~ty_gas_optics_rrtmgp->ty_gas_optics Help × Graph Key Nodes of different colours represent the following: Graph Key Type Type This Page's Entity This Page's Entity Solid arrows point from a derived type to the parent type which it\n extends. Dashed arrows point from a derived type to the other\n types it contains as a components, with a label listing the name(s) of\n said component(s). Contents Variables flavor gas_names gpoint_flavor idx_minor_lower idx_minor_scaling_lower idx_minor_scaling_upper idx_minor_upper is_key kmajor kminor_lower kminor_start_lower kminor_start_upper kminor_upper krayl minor_limits_gpt_lower minor_limits_gpt_upper minor_scales_with_density_lower minor_scales_with_density_upper optimal_angle_fit planck_frac press_ref press_ref_log press_ref_log_delta press_ref_max press_ref_min press_ref_trop_log scale_by_complement_lower scale_by_complement_upper solar_source solar_source_facular solar_source_quiet solar_source_sunspot temp_ref temp_ref_delta temp_ref_max temp_ref_min totplnk totplnk_delta vmr_ref Type-Bound Procedures compute_optimal_angles finalize gas_optics_ext gas_optics_int get_gases get_ngas get_press_max get_press_min get_temp_max get_temp_min is_loaded load set_solar_variability set_tsi source_is_external source_is_internal Components Type Visibility Attributes Name Initial integer, public, dimension(:,:), allocatable :: flavor character(len=32), public, dimension(:), allocatable :: gas_names integer, public, dimension(:,:), allocatable :: gpoint_flavor integer, public, dimension(:), allocatable :: idx_minor_lower integer, public, dimension(:), allocatable :: idx_minor_scaling_lower integer, public, dimension(:), allocatable :: idx_minor_scaling_upper integer, public, dimension(:), allocatable :: idx_minor_upper logical, public, dimension(:), allocatable :: is_key real(kind=wp), public, dimension(:,:,:,:), allocatable :: kmajor real(kind=wp), public, dimension(:,:,:), allocatable :: kminor_lower integer, public, dimension(:), allocatable :: kminor_start_lower integer, public, dimension(:), allocatable :: kminor_start_upper real(kind=wp), public, dimension(:,:,:), allocatable :: kminor_upper real(kind=wp), public, dimension(:,:,:,:), allocatable :: krayl integer, public, dimension(:,:), allocatable :: minor_limits_gpt_lower integer, public, dimension(:,:), allocatable :: minor_limits_gpt_upper logical(kind=wl), public, dimension(:), allocatable :: minor_scales_with_density_lower logical(kind=wl), public, dimension(:), allocatable :: minor_scales_with_density_upper real(kind=wp), public, dimension(:,:), allocatable :: optimal_angle_fit real(kind=wp), public, dimension(:,:,:,:), allocatable :: planck_frac real(kind=wp), public, dimension(:), allocatable :: press_ref real(kind=wp), public, dimension(:), allocatable :: press_ref_log real(kind=wp), public :: press_ref_log_delta real(kind=wp), public :: press_ref_max real(kind=wp), public :: press_ref_min real(kind=wp), public :: press_ref_trop_log logical(kind=wl), public, dimension(:), allocatable :: scale_by_complement_lower logical(kind=wl), public, dimension(:), allocatable :: scale_by_complement_upper real(kind=wp), public, dimension(:), allocatable :: solar_source real(kind=wp), public, dimension(:), allocatable :: solar_source_facular real(kind=wp), public, dimension(:), allocatable :: solar_source_quiet real(kind=wp), public, dimension(:), allocatable :: solar_source_sunspot real(kind=wp), public, dimension(:), allocatable :: temp_ref real(kind=wp), public :: temp_ref_delta real(kind=wp), public :: temp_ref_max real(kind=wp), public :: temp_ref_min real(kind=wp), public, dimension(:,:), allocatable :: totplnk real(kind=wp), public :: totplnk_delta real(kind=wp), public, dimension(:,:,:), allocatable :: vmr_ref Type-Bound Procedures procedure, public :: compute_optimal_angles private function compute_optimal_angles(this, optical_props, optimal_angles) result(err_msg) Compute a transport angle that minimizes flux errors at surface and TOA based on empirical fits Arguments Type Intent Optional Attributes Name class( ty_gas_optics_rrtmgp ), intent(in) :: this class(ty_optical_props_arry), intent(in) :: optical_props Optical properties real(kind=wp), intent(out), dimension(:,:) :: optimal_angles Secant of optical transport angle Return Value character(len=128) Empty if successful procedure, public :: finalize private subroutine finalize(this) Arguments Type Intent Optional Attributes Name class( ty_gas_optics_rrtmgp ), intent(inout) :: this procedure, public :: gas_optics_ext private function gas_optics_ext(this, play, plev, tlay, gas_desc, optical_props, toa_src, col_dry) result(error_msg) Compute gas optical depth given temperature, pressure, and composition\n Top-of-atmosphere stellar insolation is also reported Arguments Type Intent Optional Attributes Name class( ty_gas_optics_rrtmgp ), intent(in) :: this real(kind=wp), intent(in), dimension(:,:) :: play layer pressures [Pa, mb]; (ncol,nlay)\nlevel pressures [Pa, mb]; (ncol,nlay+1)\nlayer temperatures [K]; (ncol,nlay) real(kind=wp), intent(in), dimension(:,:) :: plev layer pressures [Pa, mb]; (ncol,nlay)\nlevel pressures [Pa, mb]; (ncol,nlay+1)\nlayer temperatures [K]; (ncol,nlay) real(kind=wp), intent(in), dimension(:,:) :: tlay layer pressures [Pa, mb]; (ncol,nlay)\nlevel pressures [Pa, mb]; (ncol,nlay+1)\nlayer temperatures [K]; (ncol,nlay) type(ty_gas_concs), intent(in) :: gas_desc Gas volume mixing ratios class(ty_optical_props_arry), intent(inout) :: optical_props real(kind=wp), intent(out), dimension(:,:) :: toa_src Incoming solar irradiance(ncol,ngpt) real(kind=wp), intent(in), optional dimension(:,:), target :: col_dry Return Value character(len=128) Empty if successful procedure, public :: gas_optics_int private function gas_optics_int(this, play, plev, tlay, tsfc, gas_desc, optical_props, sources, col_dry, tlev) result(error_msg) Compute gas optical depth and Planck source functions,\n given temperature, pressure, and composition Arguments Type Intent Optional Attributes Name class( ty_gas_optics_rrtmgp ), intent(in) :: this real(kind=wp), intent(in), dimension(:,:) :: play layer pressures [Pa, mb]; (ncol,nlay)\nlevel pressures [Pa, mb]; (ncol,nlay+1)\nlayer temperatures [K]; (ncol,nlay) real(kind=wp), intent(in), dimension(:,:) :: plev layer pressures [Pa, mb]; (ncol,nlay)\nlevel pressures [Pa, mb]; (ncol,nlay+1)\nlayer temperatures [K]; (ncol,nlay) real(kind=wp), intent(in), dimension(:,:) :: tlay layer pressures [Pa, mb]; (ncol,nlay)\nlevel pressures [Pa, mb]; (ncol,nlay+1)\nlayer temperatures [K]; (ncol,nlay) real(kind=wp), intent(in), dimension(:) :: tsfc surface skin temperatures [K]; (ncol) type(ty_gas_concs), intent(in) :: gas_desc Gas volume mixing ratios class(ty_optical_props_arry), intent(inout) :: optical_props Optical properties class(ty_source_func_lw), intent(inout) :: sources Planck sources real(kind=wp), intent(in), optional dimension(:,:), target :: col_dry Column dry amount; dim(ncol,nlay)\nlevel temperatures [K]; (ncol,nlay+1) real(kind=wp), intent(in), optional dimension(:,:), target :: tlev Column dry amount; dim(ncol,nlay)\nlevel temperatures [K]; (ncol,nlay+1) Return Value character(len=128) Empty if succssful procedure, public :: get_gases private pure function get_gases(this) return the names of the gases known to the k-distributions Arguments Type Intent Optional Attributes Name class( ty_gas_optics_rrtmgp ), intent(in) :: this Return Value character(len=32),dimension(get_ngas(this)) names of the gases known to the k-distributions procedure, public :: get_ngas private pure function get_ngas(this) Two functions to define array sizes needed by gas_optics() Arguments Type Intent Optional Attributes Name class( ty_gas_optics_rrtmgp ), intent(in) :: this Return Value integer procedure, public :: get_press_max private pure function get_press_max(this) return the maximum pressure on the interpolation grids Arguments Type Intent Optional Attributes Name class( ty_gas_optics_rrtmgp ), intent(in) :: this Return Value real(kind=wp) maximum pressure for which the k-dsitribution is valid procedure, public :: get_press_min private pure function get_press_min(this) return the minimum pressure on the interpolation grids Arguments Type Intent Optional Attributes Name class( ty_gas_optics_rrtmgp ), intent(in) :: this Return Value real(kind=wp) minimum pressure for which the k-dsitribution is valid procedure, public :: get_temp_max private pure function get_temp_max(this) return the maximum temparature on the interpolation grids Arguments Type Intent Optional Attributes Name class( ty_gas_optics_rrtmgp ), intent(in) :: this Return Value real(kind=wp) maximum temperature for which the k-dsitribution is valid procedure, public :: get_temp_min private pure function get_temp_min(this) return the minimum temparature on the interpolation grids Arguments Type Intent Optional Attributes Name class( ty_gas_optics_rrtmgp ), intent(in) :: this Return Value real(kind=wp) minimum temperature for which the k-dsitribution is valid procedure, public :: is_loaded private pure function is_loaded(this) Arguments Type Intent Optional Attributes Name class( ty_gas_optics_rrtmgp ), intent(in) :: this Return Value logical(kind=wl) generic, public :: load => load_int, load_ext private function load_int(this, available_gases, gas_names, key_species, band2gpt, band_lims_wavenum, press_ref, press_ref_trop, temp_ref, temp_ref_p, temp_ref_t, vmr_ref, kmajor, kminor_lower, kminor_upper, gas_minor, identifier_minor, minor_gases_lower, minor_gases_upper, minor_limits_gpt_lower, minor_limits_gpt_upper, minor_scales_with_density_lower, minor_scales_with_density_upper, scaling_gas_lower, scaling_gas_upper, scale_by_complement_lower, scale_by_complement_upper, kminor_start_lower, kminor_start_upper, totplnk, planck_frac, rayl_lower, rayl_upper, optimal_angle_fit) result(err_message) Arguments Type Intent Optional Attributes Name class( ty_gas_optics_rrtmgp ), intent(inout) :: this class(ty_gas_concs), intent(in) :: available_gases character(len=*), intent(in), dimension(:) :: gas_names integer, intent(in), dimension(:,:,:) :: key_species integer, intent(in), dimension(:,:) :: band2gpt real(kind=wp), intent(in), dimension(:,:) :: band_lims_wavenum real(kind=wp), intent(in), dimension(:) :: press_ref real(kind=wp), intent(in) :: press_ref_trop real(kind=wp), intent(in), dimension(:) :: temp_ref real(kind=wp), intent(in) :: temp_ref_p real(kind=wp), intent(in) :: temp_ref_t real(kind=wp), intent(in), dimension(:,:,:) :: vmr_ref real(kind=wp), intent(in), dimension(:,:,:,:) :: kmajor real(kind=wp), intent(in), dimension(:,:,:) :: kminor_lower real(kind=wp), intent(in), dimension(:,:,:) :: kminor_upper character(len=*), intent(in), dimension(:) :: gas_minor character(len=*), intent(in), dimension(:) :: identifier_minor character(len=*), intent(in), dimension(:) :: minor_gases_lower character(len=*), intent(in), dimension(:) :: minor_gases_upper integer, intent(in), dimension(:,:) :: minor_limits_gpt_lower integer, intent(in), dimension(:,:) :: minor_limits_gpt_upper logical(kind=wl), intent(in), dimension(:) :: minor_scales_with_density_lower logical(kind=wl), intent(in), dimension(:) :: minor_scales_with_density_upper character(len=*), intent(in), dimension(:) :: scaling_gas_lower character(len=*), intent(in), dimension(:) :: scaling_gas_upper logical(kind=wl), intent(in), dimension(:) :: scale_by_complement_lower logical(kind=wl), intent(in), dimension(:) :: scale_by_complement_upper integer, intent(in), dimension(:) :: kminor_start_lower integer, intent(in), dimension(:) :: kminor_start_upper real(kind=wp), intent(in), dimension(:,:) :: totplnk real(kind=wp), intent(in), dimension(:,:,:,:) :: planck_frac real(kind=wp), intent(in), dimension(:,:,:), allocatable :: rayl_lower real(kind=wp), intent(in), dimension(:,:,:), allocatable :: rayl_upper real(kind=wp), intent(in), dimension(:,:) :: optimal_angle_fit Return Value character(len=128) private function load_ext(this, available_gases, gas_names, key_species, band2gpt, band_lims_wavenum, press_ref, press_ref_trop, temp_ref, temp_ref_p, temp_ref_t, vmr_ref, kmajor, kminor_lower, kminor_upper, gas_minor, identifier_minor, minor_gases_lower, minor_gases_upper, minor_limits_gpt_lower, minor_limits_gpt_upper, minor_scales_with_density_lower, minor_scales_with_density_upper, scaling_gas_lower, scaling_gas_upper, scale_by_complement_lower, scale_by_complement_upper, kminor_start_lower, kminor_start_upper, solar_quiet, solar_facular, solar_sunspot, tsi_default, mg_default, sb_default, rayl_lower, rayl_upper) result(err_message) Arguments Type Intent Optional Attributes Name class( ty_gas_optics_rrtmgp ), intent(inout) :: this class(ty_gas_concs), intent(in) :: available_gases character(len=*), intent(in), dimension(:) :: gas_names integer, intent(in), dimension(:,:,:) :: key_species integer, intent(in), dimension(:,:) :: band2gpt real(kind=wp), intent(in), dimension(:,:) :: band_lims_wavenum real(kind=wp), intent(in), dimension(:) :: press_ref real(kind=wp), intent(in) :: press_ref_trop real(kind=wp), intent(in), dimension(:) :: temp_ref real(kind=wp), intent(in) :: temp_ref_p real(kind=wp), intent(in) :: temp_ref_t real(kind=wp), intent(in), dimension(:,:,:) :: vmr_ref real(kind=wp), intent(in), dimension(:,:,:,:) :: kmajor real(kind=wp), intent(in), dimension(:,:,:) :: kminor_lower real(kind=wp), intent(in), dimension(:,:,:) :: kminor_upper character(len=*), intent(in), dimension(:) :: gas_minor character(len=*), intent(in), dimension(:) :: identifier_minor character(len=*), intent(in), dimension(:) :: minor_gases_lower character(len=*), intent(in), dimension(:) :: minor_gases_upper integer, intent(in), dimension(:,:) :: minor_limits_gpt_lower integer, intent(in), dimension(:,:) :: minor_limits_gpt_upper logical(kind=wl), intent(in), dimension(:) :: minor_scales_with_density_lower logical(kind=wl), intent(in), dimension(:) :: minor_scales_with_density_upper character(len=*), intent(in), dimension(:) :: scaling_gas_lower character(len=*), intent(in), dimension(:) :: scaling_gas_upper logical(kind=wl), intent(in), dimension(:) :: scale_by_complement_lower logical(kind=wl), intent(in), dimension(:) :: scale_by_complement_upper integer, intent(in), dimension(:) :: kminor_start_lower integer, intent(in), dimension(:) :: kminor_start_upper real(kind=wp), intent(in), dimension(:) :: solar_quiet real(kind=wp), intent(in), dimension(:) :: solar_facular real(kind=wp), intent(in), dimension(:) :: solar_sunspot real(kind=wp), intent(in) :: tsi_default real(kind=wp), intent(in) :: mg_default real(kind=wp), intent(in) :: sb_default real(kind=wp), intent(in), dimension(:,:,:), allocatable :: rayl_lower real(kind=wp), intent(in), dimension(:,:,:), allocatable :: rayl_upper Return Value character(len=128) procedure, public :: set_solar_variability private function set_solar_variability(this, mg_index, sb_index, tsi) result(error_msg) Compute the spectral solar source function adjusted to account for solar variability\n following the NRLSSI2 model of Coddington et al. 2016, doi:10.1175/BAMS-D-14-00265.1.\nas specified by the facular brightening (mg_index) and sunspot dimming (sb_index)\nindices provided as input. Read more… Arguments Type Intent Optional Attributes Name class( ty_gas_optics_rrtmgp ), intent(inout) :: this real(kind=wp), intent(in) :: mg_index facular brightening index (NRLSSI2 facular \"Bremen\" index) real(kind=wp), intent(in) :: sb_index sunspot dimming index (NRLSSI2 sunspot \"SPOT67\" index) real(kind=wp), intent(in), optional :: tsi total solar irradiance Return Value character(len=128) Empty if successful procedure, public :: set_tsi private function set_tsi(this, tsi) result(error_msg) Arguments Type Intent Optional Attributes Name class( ty_gas_optics_rrtmgp ), intent(inout) :: this Scale the solar source function without changing the spectral distribution real(kind=wp), intent(in) :: tsi user-specified total solar irradiance; Return Value character(len=128) Empty if successful procedure, public :: source_is_external private pure function source_is_external(this) return true if initialized for external sources/shortwave, false otherwise Arguments Type Intent Optional Attributes Name class( ty_gas_optics_rrtmgp ), intent(in) :: this Return Value logical procedure, public :: source_is_internal private pure function source_is_internal(this) return true if initialized for internal sources/longwave, false otherwise Arguments Type Intent Optional Attributes Name class( ty_gas_optics_rrtmgp ), intent(in) :: this Return Value logical","tags":"","loc":"type/ty_gas_optics_rrtmgp.html"},{"title":"ty_aerosol_optics_rrtmgp_merra – RRTMGP-Fortran ","text":"type, public, extends(ty_optical_props) :: ty_aerosol_optics_rrtmgp_merra Inherits type~~ty_aerosol_optics_rrtmgp_merra~~InheritsGraph type~ty_aerosol_optics_rrtmgp_merra ty_aerosol_optics_rrtmgp_merra ty_optical_props ty_optical_props type~ty_aerosol_optics_rrtmgp_merra->ty_optical_props Help × Graph Key Nodes of different colours represent the following: Graph Key Type Type This Page's Entity This Page's Entity Solid arrows point from a derived type to the parent type which it\n extends. Dashed arrows point from a derived type to the other\n types it contains as a components, with a label listing the name(s) of\n said component(s). Contents Variables aero_bcar_rh_tbl aero_bcar_tbl aero_dust_tbl aero_ocar_rh_tbl aero_ocar_tbl aero_rh aero_salt_tbl aero_sulf_tbl merra_aero_bin_lims Type-Bound Procedures aerosol_optics finalize load Components Type Visibility Attributes Name Initial real(kind=wp), public, dimension(:,:,: ), allocatable :: aero_bcar_rh_tbl real(kind=wp), public, dimension(:,: ), allocatable :: aero_bcar_tbl real(kind=wp), public, dimension(:,:,: ), allocatable :: aero_dust_tbl real(kind=wp), public, dimension(:,:,: ), allocatable :: aero_ocar_rh_tbl real(kind=wp), public, dimension(:,: ), allocatable :: aero_ocar_tbl real(kind=wp), public, dimension(:), allocatable :: aero_rh (:) real(kind=wp), public, dimension(:,:,:,:), allocatable :: aero_salt_tbl real(kind=wp), public, dimension(:,:,: ), allocatable :: aero_sulf_tbl real(kind=wp), public, dimension(:,:), allocatable :: merra_aero_bin_lims Type-Bound Procedures procedure, public :: aerosol_optics private function aerosol_optics(this, aero_type, aero_size, aero_mass, relhum, optical_props) result(error_msg) Arguments Type Intent Optional Attributes Name class( ty_aerosol_optics_rrtmgp_merra ), intent(in) :: this integer, intent(in) :: aero_type (:,:) real(kind=wp), intent(in) :: aero_size (:,:) real(kind=wp), intent(in) :: aero_mass (:,:) real(kind=wp), intent(in) :: relhum (:,:) class(ty_optical_props_arry), intent(inout) :: optical_props Return Value character(len=128) procedure, public :: finalize private subroutine finalize(this) Arguments Type Intent Optional Attributes Name class( ty_aerosol_optics_rrtmgp_merra ), intent(inout) :: this generic, public :: load => load_lut private function load_lut(this, band_lims_wvn, merra_aero_bin_lims, aero_rh, aero_dust_tbl, aero_salt_tbl, aero_sulf_tbl, aero_bcar_tbl, aero_bcar_rh_tbl, aero_ocar_tbl, aero_ocar_rh_tbl) result(error_msg) Arguments Type Intent Optional Attributes Name class( ty_aerosol_optics_rrtmgp_merra ), intent(inout) :: this real(kind=wp), intent(in), dimension(:,:) :: band_lims_wvn real(kind=wp), intent(in), dimension(:,:) :: merra_aero_bin_lims real(kind=wp), intent(in), dimension(:) :: aero_rh real(kind=wp), intent(in), dimension(:,:,:) :: aero_dust_tbl real(kind=wp), intent(in), dimension(:,:,:,:) :: aero_salt_tbl real(kind=wp), intent(in), dimension(:,:,:) :: aero_sulf_tbl real(kind=wp), intent(in), dimension(:,:) :: aero_bcar_tbl real(kind=wp), intent(in), dimension(:,:,:) :: aero_bcar_rh_tbl real(kind=wp), intent(in), dimension(:,:) :: aero_ocar_tbl real(kind=wp), intent(in), dimension(:,:,:) :: aero_ocar_rh_tbl Return Value character(len=128)","tags":"","loc":"type/ty_aerosol_optics_rrtmgp_merra.html"},{"title":"pade_eval – RRTMGP-Fortran","text":"public interface pade_eval Contents Module Procedures pade_eval_nbnd pade_eval_1 Module Procedures private function pade_eval_nbnd(nbnd, nrads, m, n, irad, re, pade_coeffs) Arguments Type Intent Optional Attributes Name integer, intent(in) :: nbnd integer, intent(in) :: nrads integer, intent(in) :: m integer, intent(in) :: n integer, intent(in) :: irad real(kind=wp), intent(in) :: re real(kind=wp), intent(in), dimension(nbnd, nrads, 0:m+n) :: pade_coeffs Return Value real(kind=wp),dimension(nbnd) private function pade_eval_1(iband, nbnd, nrads, m, n, irad, re, pade_coeffs) Arguments Type Intent Optional Attributes Name integer, intent(in) :: iband integer, intent(in) :: nbnd integer, intent(in) :: nrads integer, intent(in) :: m integer, intent(in) :: n integer, intent(in) :: irad real(kind=wp), intent(in) :: re real(kind=wp), intent(in), dimension(nbnd, nrads, 0:m+n) :: pade_coeffs Return Value real(kind=wp)","tags":"","loc":"interface/pade_eval.html"},{"title":"get_col_dry – RRTMGP-Fortran","text":"public function get_col_dry(vmr_h2o, plev, latitude) result(col_dry) Utility function, provided for user convenience\ncomputes column amounts of dry air using hydrostatic equation Arguments Type Intent Optional Attributes Name real(kind=wp), intent(in), dimension(:,:) :: vmr_h2o real(kind=wp), intent(in), dimension(:,:) :: plev real(kind=wp), intent(in), optional dimension(:) :: latitude Return Value real(kind=wp),dimension(size(plev,dim=1),size(plev,dim=2)-1) Contents None","tags":"","loc":"proc/get_col_dry.html"},{"title":"mo_cloud_optics_rrtmgp – RRTMGP-Fortran","text":"Uses mo_optical_props mo_rte_kind mo_rte_util_array_validation mo_rte_config module~~mo_cloud_optics_rrtmgp~~UsesGraph module~mo_cloud_optics_rrtmgp mo_cloud_optics_rrtmgp mo_optical_props mo_optical_props module~mo_cloud_optics_rrtmgp->mo_optical_props mo_rte_kind mo_rte_kind module~mo_cloud_optics_rrtmgp->mo_rte_kind mo_rte_util_array_validation mo_rte_util_array_validation module~mo_cloud_optics_rrtmgp->mo_rte_util_array_validation mo_rte_config mo_rte_config module~mo_cloud_optics_rrtmgp->mo_rte_config Help × Graph Key Nodes of different colours represent the following: Graph Key Module Module Submodule Submodule Subroutine Subroutine Function Function Program Program This Page's Entity This Page's Entity Solid arrows point from a submodule to the (sub)module which it is\n descended from. Dashed arrows point from a module or program unit to \n modules which it uses. Contents Interfaces pade_eval Derived Types ty_cloud_optics_rrtmgp Interfaces public interface pade_eval private function pade_eval_nbnd(nbnd, nrads, m, n, irad, re, pade_coeffs) Arguments Type Intent Optional Attributes Name integer, intent(in) :: nbnd integer, intent(in) :: nrads integer, intent(in) :: m integer, intent(in) :: n integer, intent(in) :: irad real(kind=wp), intent(in) :: re real(kind=wp), intent(in), dimension(nbnd, nrads, 0:m+n) :: pade_coeffs Return Value real(kind=wp),dimension(nbnd) private function pade_eval_1(iband, nbnd, nrads, m, n, irad, re, pade_coeffs) Arguments Type Intent Optional Attributes Name integer, intent(in) :: iband integer, intent(in) :: nbnd integer, intent(in) :: nrads integer, intent(in) :: m integer, intent(in) :: n integer, intent(in) :: irad real(kind=wp), intent(in) :: re real(kind=wp), intent(in), dimension(nbnd, nrads, 0:m+n) :: pade_coeffs Return Value real(kind=wp) Derived Types type, public, extends(ty_optical_props) :: ty_cloud_optics_rrtmgp Components Type Visibility Attributes Name Initial integer, public :: ice_nsteps = 0 real(kind=wp), public :: ice_step_size = 0._wp integer, public :: icergh = 0 integer, public :: liq_nsteps = 0 real(kind=wp), public :: liq_step_size = 0._wp real(kind=wp), public, dimension(:,:,: ), allocatable :: lut_asyice real(kind=wp), public, dimension(:,: ), allocatable :: lut_asyliq real(kind=wp), public, dimension(:,:,: ), allocatable :: lut_extice real(kind=wp), public, dimension(:,: ), allocatable :: lut_extliq real(kind=wp), public, dimension(:,:,: ), allocatable :: lut_ssaice real(kind=wp), public, dimension(:,: ), allocatable :: lut_ssaliq real(kind=wp), public, dimension(:,:,:,:), allocatable :: pade_asyice real(kind=wp), public, dimension(:,:,: ), allocatable :: pade_asyliq real(kind=wp), public, dimension(:,:,:,:), allocatable :: pade_extice real(kind=wp), public, dimension(:,:,: ), allocatable :: pade_extliq real(kind=wp), public, dimension(:), allocatable :: pade_sizreg_asyice real(kind=wp), public, dimension(:), allocatable :: pade_sizreg_asyliq real(kind=wp), public, dimension(:), allocatable :: pade_sizreg_extice real(kind=wp), public, dimension(:), allocatable :: pade_sizreg_extliq real(kind=wp), public, dimension(:), allocatable :: pade_sizreg_ssaice real(kind=wp), public, dimension(:), allocatable :: pade_sizreg_ssaliq real(kind=wp), public, dimension(:,:,:,:), allocatable :: pade_ssaice real(kind=wp), public, dimension(:,:,: ), allocatable :: pade_ssaliq real(kind=wp), public :: radice_lwr = 0._wp real(kind=wp), public :: radice_upr = 0._wp real(kind=wp), public :: radliq_lwr = 0._wp real(kind=wp), public :: radliq_upr = 0._wp Type-Bound Procedures procedure, public :: cloud_optics procedure, public :: finalize procedure, public :: get_max_radius_ice procedure, public :: get_max_radius_liq procedure, public :: get_min_radius_ice procedure, public :: get_min_radius_liq procedure, public :: get_num_ice_roughness_types generic, public :: load => load_lut, load_pade procedure, public :: set_ice_roughness","tags":"","loc":"module/mo_cloud_optics_rrtmgp.html"},{"title":"mo_gas_optics_rrtmgp – RRTMGP-Fortran","text":"Class implementing the RRTMGP correlated- k distribution Implements a class for computing spectrally-resolved gas optical properties and source functions\n given atmopsheric physical properties (profiles of temperature, pressure, and gas concentrations)\n The class must be initialized with data (provided as a netCDF file) before being used. Two variants apply to internal Planck sources (longwave radiation in the Earth's atmosphere) and to\n external stellar radiation (shortwave radiation in the Earth's atmosphere).\n The variant is chosen based on what information is supplied during initialization.\ncol_dry is the number of molecules per cm-2 of dry air Uses mo_gas_concentrations mo_gas_optics_constants mo_source_functions mo_rte_util_array mo_rte_config mo_rte_util_array_validation mo_rte_kind mo_optical_props mo_gas_optics_util_string mo_gas_optics mo_gas_optics_rrtmgp_kernels module~~mo_gas_optics_rrtmgp~~UsesGraph module~mo_gas_optics_rrtmgp mo_gas_optics_rrtmgp mo_gas_optics_constants mo_gas_optics_constants module~mo_gas_optics_rrtmgp->mo_gas_optics_constants mo_gas_optics mo_gas_optics module~mo_gas_optics_rrtmgp->mo_gas_optics mo_optical_props mo_optical_props module~mo_gas_optics_rrtmgp->mo_optical_props mo_rte_util_array_validation mo_rte_util_array_validation module~mo_gas_optics_rrtmgp->mo_rte_util_array_validation mo_rte_util_array mo_rte_util_array module~mo_gas_optics_rrtmgp->mo_rte_util_array mo_gas_concentrations mo_gas_concentrations module~mo_gas_optics_rrtmgp->mo_gas_concentrations mo_rte_config mo_rte_config module~mo_gas_optics_rrtmgp->mo_rte_config mo_source_functions mo_source_functions module~mo_gas_optics_rrtmgp->mo_source_functions mo_rte_kind mo_rte_kind module~mo_gas_optics_rrtmgp->mo_rte_kind mo_gas_optics_util_string mo_gas_optics_util_string module~mo_gas_optics_rrtmgp->mo_gas_optics_util_string mo_gas_optics_rrtmgp_kernels mo_gas_optics_rrtmgp_kernels module~mo_gas_optics_rrtmgp->mo_gas_optics_rrtmgp_kernels Help × Graph Key Nodes of different colours represent the following: Graph Key Module Module Submodule Submodule Subroutine Subroutine Function Function Program Program This Page's Entity This Page's Entity Solid arrows point from a submodule to the (sub)module which it is\n descended from. Dashed arrows point from a module or program unit to \n modules which it uses. Contents Derived Types ty_gas_optics_rrtmgp Functions get_col_dry Derived Types type, public, extends(ty_gas_optics) :: ty_gas_optics_rrtmgp Components Type Visibility Attributes Name Initial integer, public, dimension(:,:), allocatable :: flavor character(len=32), public, dimension(:), allocatable :: gas_names integer, public, dimension(:,:), allocatable :: gpoint_flavor integer, public, dimension(:), allocatable :: idx_minor_lower integer, public, dimension(:), allocatable :: idx_minor_scaling_lower integer, public, dimension(:), allocatable :: idx_minor_scaling_upper integer, public, dimension(:), allocatable :: idx_minor_upper logical, public, dimension(:), allocatable :: is_key real(kind=wp), public, dimension(:,:,:,:), allocatable :: kmajor real(kind=wp), public, dimension(:,:,:), allocatable :: kminor_lower integer, public, dimension(:), allocatable :: kminor_start_lower integer, public, dimension(:), allocatable :: kminor_start_upper real(kind=wp), public, dimension(:,:,:), allocatable :: kminor_upper real(kind=wp), public, dimension(:,:,:,:), allocatable :: krayl integer, public, dimension(:,:), allocatable :: minor_limits_gpt_lower integer, public, dimension(:,:), allocatable :: minor_limits_gpt_upper logical(kind=wl), public, dimension(:), allocatable :: minor_scales_with_density_lower logical(kind=wl), public, dimension(:), allocatable :: minor_scales_with_density_upper real(kind=wp), public, dimension(:,:), allocatable :: optimal_angle_fit real(kind=wp), public, dimension(:,:,:,:), allocatable :: planck_frac real(kind=wp), public, dimension(:), allocatable :: press_ref real(kind=wp), public, dimension(:), allocatable :: press_ref_log real(kind=wp), public :: press_ref_log_delta real(kind=wp), public :: press_ref_max real(kind=wp), public :: press_ref_min real(kind=wp), public :: press_ref_trop_log logical(kind=wl), public, dimension(:), allocatable :: scale_by_complement_lower logical(kind=wl), public, dimension(:), allocatable :: scale_by_complement_upper real(kind=wp), public, dimension(:), allocatable :: solar_source real(kind=wp), public, dimension(:), allocatable :: solar_source_facular real(kind=wp), public, dimension(:), allocatable :: solar_source_quiet real(kind=wp), public, dimension(:), allocatable :: solar_source_sunspot real(kind=wp), public, dimension(:), allocatable :: temp_ref real(kind=wp), public :: temp_ref_delta real(kind=wp), public :: temp_ref_max real(kind=wp), public :: temp_ref_min real(kind=wp), public, dimension(:,:), allocatable :: totplnk real(kind=wp), public :: totplnk_delta real(kind=wp), public, dimension(:,:,:), allocatable :: vmr_ref Type-Bound Procedures procedure, public :: compute_optimal_angles procedure, public :: finalize procedure, public :: gas_optics_ext procedure, public :: gas_optics_int procedure, public :: get_gases procedure, public :: get_ngas procedure, public :: get_press_max procedure, public :: get_press_min procedure, public :: get_temp_max procedure, public :: get_temp_min procedure, public :: is_loaded generic, public :: load => load_int, load_ext procedure, public :: set_solar_variability procedure, public :: set_tsi procedure, public :: source_is_external procedure, public :: source_is_internal Functions public function get_col_dry (vmr_h2o, plev, latitude) result(col_dry) Utility function, provided for user convenience\ncomputes column amounts of dry air using hydrostatic equation Arguments Type Intent Optional Attributes Name real(kind=wp), intent(in), dimension(:,:) :: vmr_h2o real(kind=wp), intent(in), dimension(:,:) :: plev real(kind=wp), intent(in), optional dimension(:) :: latitude Return Value real(kind=wp),dimension(size(plev,dim=1),size(plev,dim=2)-1)","tags":"","loc":"module/mo_gas_optics_rrtmgp.html"},{"title":"mo_aerosol_optics_rrtmgp_merra – RRTMGP-Fortran","text":"Uses mo_optical_props mo_rte_kind mo_rte_util_array_validation mo_rte_config module~~mo_aerosol_optics_rrtmgp_merra~~UsesGraph module~mo_aerosol_optics_rrtmgp_merra mo_aerosol_optics_rrtmgp_merra mo_optical_props mo_optical_props module~mo_aerosol_optics_rrtmgp_merra->mo_optical_props mo_rte_kind mo_rte_kind module~mo_aerosol_optics_rrtmgp_merra->mo_rte_kind mo_rte_util_array_validation mo_rte_util_array_validation module~mo_aerosol_optics_rrtmgp_merra->mo_rte_util_array_validation mo_rte_config mo_rte_config module~mo_aerosol_optics_rrtmgp_merra->mo_rte_config Help × Graph Key Nodes of different colours represent the following: Graph Key Module Module Submodule Submodule Subroutine Subroutine Function Function Program Program This Page's Entity This Page's Entity Solid arrows point from a submodule to the (sub)module which it is\n descended from. Dashed arrows point from a module or program unit to \n modules which it uses. Contents Variables merra_aero_bcar merra_aero_bcar_rh merra_aero_dust merra_aero_none merra_aero_ocar merra_aero_ocar_rh merra_aero_salt merra_aero_sulf merra_ntype Derived Types ty_aerosol_optics_rrtmgp_merra Variables Type Visibility Attributes Name Initial integer, public, parameter :: merra_aero_bcar = 5 integer, public, parameter :: merra_aero_bcar_rh = 4 integer, public, parameter :: merra_aero_dust = 1 integer, public, parameter :: merra_aero_none = 0 integer, public, parameter :: merra_aero_ocar = 7 integer, public, parameter :: merra_aero_ocar_rh = 6 integer, public, parameter :: merra_aero_salt = 2 integer, public, parameter :: merra_aero_sulf = 3 integer, public, parameter :: merra_ntype = 7 Derived Types type, public, extends(ty_optical_props) :: ty_aerosol_optics_rrtmgp_merra Components Type Visibility Attributes Name Initial real(kind=wp), public, dimension(:,:,: ), allocatable :: aero_bcar_rh_tbl real(kind=wp), public, dimension(:,: ), allocatable :: aero_bcar_tbl real(kind=wp), public, dimension(:,:,: ), allocatable :: aero_dust_tbl real(kind=wp), public, dimension(:,:,: ), allocatable :: aero_ocar_rh_tbl real(kind=wp), public, dimension(:,: ), allocatable :: aero_ocar_tbl real(kind=wp), public, dimension(:), allocatable :: aero_rh (:) real(kind=wp), public, dimension(:,:,:,:), allocatable :: aero_salt_tbl real(kind=wp), public, dimension(:,:,: ), allocatable :: aero_sulf_tbl real(kind=wp), public, dimension(:,:), allocatable :: merra_aero_bin_lims Type-Bound Procedures procedure, public :: aerosol_optics procedure, public :: finalize generic, public :: load => load_lut","tags":"","loc":"module/mo_aerosol_optics_rrtmgp_merra.html"},{"title":"mo_cloud_optics_rrtmgp.F90 – RRTMGP-Fortran","text":"Contents Modules mo_cloud_optics_rrtmgp Source Code mo_cloud_optics_rrtmgp.F90 Source Code ! This code is part of Radiative Transfer for Energetics (RTE) ! ! Contacts: Robert Pincus and Eli Mlawer ! email: rrtmgp@aer.com ! ! Copyright 2015-2018, Atmospheric and Environmental Research and ! Regents of the University of Colorado. All right reserved. ! ! Use and duplication is permitted under the terms of the ! BSD 3-clause license, see http://opensource.org/licenses/BSD-3-Clause ! ------------------------------------------------------------------------------------------------- ! Provides cloud optical properties as a function of effective radius for the RRTMGP bands ! Based on Mie calculations for liquid ! and results from doi:10.1175/JAS-D-12-039.1 for ice with variable surface roughness ! Can use either look-up tables or Pade approximates according to which data has been loaded ! Mike Iacono (AER) is the original author ! ! The class can be used as-is but is also intended as an example of how to extend the RTE framework ! ------------------------------------------------------------------------------------------------- module mo_cloud_optics_rrtmgp use mo_rte_kind , only : wp , wl use mo_rte_config , only : check_values , check_extents use mo_rte_util_array_validation ,& only : any_vals_less_than , any_vals_outside , extents_are use mo_optical_props , only : ty_optical_props , & ty_optical_props_arry , & ty_optical_props_1scl , & ty_optical_props_2str , & ty_optical_props_nstr implicit none interface pade_eval module procedure pade_eval_nbnd , pade_eval_1 end interface pade_eval private ! ----------------------------------------------------------------------------------- type , extends ( ty_optical_props ), public :: ty_cloud_optics_rrtmgp private ! ! Ice surface roughness category - needed for Yang (2013) ice optics parameterization ! integer :: icergh = 0 ! (1 = none, 2 = medium, 3 = high) ! ! Lookup table information ! ! Upper and lower limits of the tables real ( wp ) :: radliq_lwr = 0._wp , radliq_upr = 0._wp real ( wp ) :: radice_lwr = 0._wp , radice_upr = 0._wp ! How many steps in the table? (for convenience) integer :: liq_nsteps = 0 , ice_nsteps = 0 ! How big is each step in the table? real ( wp ) :: liq_step_size = 0._wp , ice_step_size = 0._wp ! ! The tables themselves. ! real ( wp ), dimension (:,: ), allocatable :: lut_extliq , lut_ssaliq , lut_asyliq ! (nsize_liq, nbnd) real ( wp ), dimension (:,:,: ), allocatable :: lut_extice , lut_ssaice , lut_asyice ! (nsize_ice, nbnd, nrghice) ! ! Pade approximant coefficients ! real ( wp ), dimension (:,:,: ), allocatable :: pade_extliq ! (nbnd, nsizereg, ncoeff_ext) real ( wp ), dimension (:,:,: ), allocatable :: pade_ssaliq , pade_asyliq ! (nbnd, nsizereg, ncoeff_ssa_g) real ( wp ), dimension (:,:,:,:), allocatable :: pade_extice ! (nbnd, nsizereg, ncoeff_ext, nrghice) real ( wp ), dimension (:,:,:,:), allocatable :: pade_ssaice , pade_asyice ! (nbnd, nsizereg, ncoeff_ssa_g, nrghice) ! Particle size regimes for Pade formulations real ( wp ), dimension (:), allocatable :: pade_sizreg_extliq , pade_sizreg_ssaliq , pade_sizreg_asyliq ! (nbound) real ( wp ), dimension (:), allocatable :: pade_sizreg_extice , pade_sizreg_ssaice , pade_sizreg_asyice ! (nbound) ! ----- contains generic , public :: load => load_lut , load_pade procedure , public :: finalize procedure , public :: cloud_optics procedure , public :: get_min_radius_liq procedure , public :: get_min_radius_ice procedure , public :: get_max_radius_liq procedure , public :: get_max_radius_ice procedure , public :: get_num_ice_roughness_types procedure , public :: set_ice_roughness ! Internal procedures procedure , private :: load_lut procedure , private :: load_pade end type ty_cloud_optics_rrtmgp contains ! ------------------------------------------------------------------------------ ! ! Routines to load data needed for cloud optics calculations. Two routines: one to load ! lookup-tables and one for coefficients for Pade approximates ! ! ------------------------------------------------------------------------------ function load_lut ( this , band_lims_wvn , & radliq_lwr , radliq_upr , & radice_lwr , radice_upr , & lut_extliq , lut_ssaliq , lut_asyliq , & lut_extice , lut_ssaice , lut_asyice ) result ( error_msg ) class ( ty_cloud_optics_rrtmgp ), intent ( inout ) :: this real ( wp ), dimension (:,:), intent ( in ) :: band_lims_wvn ! Spectral discretization ! Lookup table interpolation constants ! Lower and upper bounds of the tables; also the constant for calculating interpolation indices for liquid real ( wp ), intent ( in ) :: radliq_lwr , radliq_upr real ( wp ), intent ( in ) :: radice_lwr , radice_upr ! LUT coefficients ! Extinction, single-scattering albedo, and asymmetry parameter for liquid and ice respectively real ( wp ), dimension (:,:), intent ( in ) :: lut_extliq , lut_ssaliq , lut_asyliq real ( wp ), dimension (:,:,:), intent ( in ) :: lut_extice , lut_ssaice , lut_asyice character ( len = 128 ) :: error_msg ! ------- ! ! Local variables ! integer :: nbnd , nrghice , nsize_liq , nsize_ice error_msg = this % init ( band_lims_wvn , name = \"RRTMGP cloud optics\" ) ! ! LUT coefficient dimensions ! nsize_liq = size ( lut_extliq , dim = 1 ) nsize_ice = size ( lut_extice , dim = 1 ) nbnd = size ( lut_extliq , dim = 2 ) nrghice = size ( lut_extice , dim = 3 ) ! ! Error checking ! Can we check for consistency between table bounds and _fac? ! if ( nbnd /= this % get_nband ()) & error_msg = \"cloud_optics%init(): number of bands inconsistent between lookup tables, spectral discretization\" if ( size ( lut_extice , 2 ) /= nbnd ) & error_msg = \"cloud_optics%init(): array lut_extice has the wrong number of bands\" if (. not . extents_are ( lut_ssaliq , nsize_liq , nbnd )) & error_msg = \"cloud_optics%init(): array lut_ssaliq isn't consistently sized\" if (. not . extents_are ( lut_asyliq , nsize_liq , nbnd )) & error_msg = \"cloud_optics%init(): array lut_asyliq isn't consistently sized\" if (. not . extents_are ( lut_ssaice , nsize_ice , nbnd , nrghice )) & error_msg = \"cloud_optics%init(): array lut_ssaice isn't consistently sized\" if (. not . extents_are ( lut_asyice , nsize_ice , nbnd , nrghice )) & error_msg = \"cloud_optics%init(): array lut_asyice isn't consistently sized\" if ( error_msg /= \"\" ) return this % liq_nsteps = nsize_liq this % ice_nsteps = nsize_ice this % liq_step_size = ( radliq_upr - radliq_lwr ) / real ( nsize_liq - 1 , wp ) this % ice_step_size = ( radice_upr - radice_lwr ) / real ( nsize_ice - 1 , wp ) ! Allocate LUT coefficients allocate ( this % lut_extliq ( nsize_liq , nbnd ), & this % lut_ssaliq ( nsize_liq , nbnd ), & this % lut_asyliq ( nsize_liq , nbnd ), & this % lut_extice ( nsize_ice , nbnd , nrghice ), & this % lut_ssaice ( nsize_ice , nbnd , nrghice ), & this % lut_asyice ( nsize_ice , nbnd , nrghice )) !$acc enter data create(this) & !$acc create(this%lut_extliq, this%lut_ssaliq, this%lut_asyliq) & !$acc create(this%lut_extice, this%lut_ssaice, this%lut_asyice) !$omp target enter data & !$omp map(alloc:this%lut_extliq, this%lut_ssaliq, this%lut_asyliq) & !$omp map(alloc:this%lut_extice, this%lut_ssaice, this%lut_asyice) ! Load LUT constants this % radliq_lwr = radliq_lwr this % radliq_upr = radliq_upr this % radice_lwr = radice_lwr this % radice_upr = radice_upr ! Load LUT coefficients !$acc kernels !$omp target this % lut_extliq = lut_extliq this % lut_ssaliq = lut_ssaliq this % lut_asyliq = lut_asyliq this % lut_extice = lut_extice this % lut_ssaice = lut_ssaice this % lut_asyice = lut_asyice !$acc end kernels !$omp end target ! ! Set default ice roughness - min values ! error_msg = this % set_ice_roughness ( 1 ) end function load_lut ! ------------------------------------------------------------------------------ ! ! Cloud optics initialization function - Pade ! ! ------------------------------------------------------------------------------ function load_pade ( this , band_lims_wvn , & pade_extliq , pade_ssaliq , pade_asyliq , & pade_extice , pade_ssaice , pade_asyice , & pade_sizreg_extliq , pade_sizreg_ssaliq , pade_sizreg_asyliq , & pade_sizreg_extice , pade_sizreg_ssaice , pade_sizreg_asyice ) & result ( error_msg ) class ( ty_cloud_optics_rrtmgp ), intent ( inout ) :: this ! cloud specification data real ( wp ), dimension (:,:), intent ( in ) :: band_lims_wvn ! Spectral discretization ! ! Pade coefficients: extinction, single-scattering albedo, and asymmetry factor for liquid and ice ! real ( wp ), dimension (:,:,:), intent ( in ) :: pade_extliq , pade_ssaliq , pade_asyliq real ( wp ), dimension (:,:,:,:), intent ( in ) :: pade_extice , pade_ssaice , pade_asyice ! ! Boundaries of size regimes. Liquid and ice are separate; ! extinction is fit to different numbers of size bins than single-scattering albedo and asymmetry factor ! real ( wp ), dimension (:), intent ( in ) :: pade_sizreg_extliq , pade_sizreg_ssaliq , pade_sizreg_asyliq real ( wp ), dimension (:), intent ( in ) :: pade_sizreg_extice , pade_sizreg_ssaice , pade_sizreg_asyice character ( len = 128 ) :: error_msg ! ------- Local ------- integer :: nbnd , nrghice , nsizereg , ncoeff_ext , ncoeff_ssa_g , nbound ! ------- Definitions ------- ! Pade coefficient dimensions nbnd = size ( pade_extliq , dim = 1 ) nsizereg = size ( pade_extliq , dim = 2 ) ncoeff_ext = size ( pade_extliq , dim = 3 ) ncoeff_ssa_g = size ( pade_ssaliq , dim = 3 ) nrghice = size ( pade_extice , dim = 4 ) nbound = size ( pade_sizreg_extliq ) ! The number of size regimes is assumed in the Pade evaluations if ( nsizereg /= 3 ) & error_msg = \"cloud optics: code assumes exactly three size regimes for Pade approximants but data is otherwise\" error_msg = this % init ( band_lims_wvn , name = \"RRTMGP cloud optics\" ) ! ! Error checking ! if ( nbnd /= this % get_nband ()) & error_msg = \"cloud_optics%init(): number of bands inconsistent between lookup tables, spectral discretization\" if (. not . extents_are ( pade_ssaliq , nbnd , nsizereg , ncoeff_ssa_g )) & error_msg = \"cloud_optics%init(): array pade_ssaliq isn't consistently sized\" if (. not . extents_are ( pade_asyliq , nbnd , nsizereg , ncoeff_ssa_g )) & error_msg = \"cloud_optics%init(): array pade_asyliq isn't consistently sized\" if (. not . extents_are ( pade_extice , nbnd , nsizereg , ncoeff_ext , nrghice )) & error_msg = \"cloud_optics%init(): array pade_extice isn't consistently sized\" if (. not . extents_are ( pade_ssaice , nbnd , nsizereg , ncoeff_ssa_g , nrghice )) & error_msg = \"cloud_optics%init(): array pade_ssaice isn't consistently sized\" if (. not . extents_are ( pade_asyice , nbnd , nsizereg , ncoeff_ssa_g , nrghice )) & error_msg = \"cloud_optics%init(): array pade_asyice isn't consistently sized\" if ( any ([ size ( pade_sizreg_ssaliq ), size ( pade_sizreg_asyliq ), & size ( pade_sizreg_extice ), size ( pade_sizreg_ssaice ), size ( pade_sizreg_asyice )] /= nbound )) & error_msg = \"cloud_optics%init(): one or more Pade size regime arrays are inconsistently sized\" if ( nsizereg /= 3 ) & error_msg = \"cloud_optics%init(): Expecting precisely three size regimes for Pade approximants\" if ( error_msg /= \"\" ) return ! ! Consistency among size regimes ! this % radliq_lwr = pade_sizreg_extliq ( 1 ) this % radliq_upr = pade_sizreg_extliq ( nbound ) this % radice_lwr = pade_sizreg_extice ( 1 ) this % radice_upr = pade_sizreg_extice ( nbound ) if ( error_msg /= \"\" ) return if ( any ([ pade_sizreg_ssaliq ( 1 ), pade_sizreg_asyliq ( 1 )] < this % radliq_lwr )) & error_msg = \"cloud_optics%init(): one or more Pade size regimes have inconsistent lowest values\" if ( any ([ pade_sizreg_ssaice ( 1 ), pade_sizreg_asyice ( 1 )] < this % radice_lwr )) & error_msg = \"cloud_optics%init(): one or more Pade size regimes have inconsistent lower values\" if ( any ([ pade_sizreg_ssaliq ( nbound ), pade_sizreg_asyliq ( nbound )] > this % radliq_upr )) & error_msg = \"cloud_optics%init(): one or more Pade size regimes have lowest value less than radliq_upr\" if ( any ([ pade_sizreg_ssaice ( nbound ), pade_sizreg_asyice ( nbound )] > this % radice_upr )) & error_msg = \"cloud_optics%init(): one or more Pade size regimes have lowest value less than radice_upr\" if ( error_msg /= \"\" ) return ! ! Allocate Pade coefficients ! allocate ( this % pade_extliq ( nbnd , nsizereg , ncoeff_ext ), & this % pade_ssaliq ( nbnd , nsizereg , ncoeff_ssa_g ), & this % pade_asyliq ( nbnd , nsizereg , ncoeff_ssa_g ), & this % pade_extice ( nbnd , nsizereg , ncoeff_ext , nrghice ), & this % pade_ssaice ( nbnd , nsizereg , ncoeff_ssa_g , nrghice ), & this % pade_asyice ( nbnd , nsizereg , ncoeff_ssa_g , nrghice )) ! ! Allocate Pade coefficient particle size regime boundaries ! allocate ( this % pade_sizreg_extliq ( nbound ), & this % pade_sizreg_ssaliq ( nbound ), & this % pade_sizreg_asyliq ( nbound ), & this % pade_sizreg_extice ( nbound ), & this % pade_sizreg_ssaice ( nbound ), & this % pade_sizreg_asyice ( nbound )) !$acc enter data create(this) & !$acc create(this%pade_extliq, this%pade_ssaliq, this%pade_asyliq) & !$acc create(this%pade_extice, this%pade_ssaice, this%pade_asyice) & !$acc create(this%pade_sizreg_extliq, this%pade_sizreg_ssaliq, this%pade_sizreg_asyliq) & !$acc create(this%pade_sizreg_extice, this%pade_sizreg_ssaice, this%pade_sizreg_asyice) !$omp target enter data & !$omp map(alloc:this%pade_extliq, this%pade_ssaliq, this%pade_asyliq) & !$omp map(alloc:this%pade_extice, this%pade_ssaice, this%pade_asyice) & !$omp map(alloc:this%pade_sizreg_extliq, this%pade_sizreg_ssaliq, this%pade_sizreg_asyliq) & !$omp map(alloc:this%pade_sizreg_extice, this%pade_sizreg_ssaice, this%pade_sizreg_asyice) ! ! Load data ! !$acc kernels !$omp target this % pade_extliq = pade_extliq this % pade_ssaliq = pade_ssaliq this % pade_asyliq = pade_asyliq this % pade_extice = pade_extice this % pade_ssaice = pade_ssaice this % pade_asyice = pade_asyice this % pade_sizreg_extliq = pade_sizreg_extliq this % pade_sizreg_ssaliq = pade_sizreg_ssaliq this % pade_sizreg_asyliq = pade_sizreg_asyliq this % pade_sizreg_extice = pade_sizreg_extice this % pade_sizreg_ssaice = pade_sizreg_ssaice this % pade_sizreg_asyice = pade_sizreg_asyice !$acc end kernels !$omp end target ! ! Set default ice roughness - min values ! error_msg = this % set_ice_roughness ( 1 ) end function load_pade !-------------------------------------------------------------------------------------------------------------------- ! ! Finalize ! !-------------------------------------------------------------------------------------------------------------------- subroutine finalize ( this ) class ( ty_cloud_optics_rrtmgp ), intent ( inout ) :: this this % radliq_lwr = 0._wp this % radliq_upr = 0._wp this % radice_lwr = 0._wp this % radice_upr = 0._wp ! Lookup table cloud optics coefficients if ( allocated ( this % lut_extliq )) then !$acc exit data delete(this%lut_extliq, this%lut_ssaliq, this%lut_asyliq) & !$acc delete(this%lut_extice, this%lut_ssaice, this%lut_asyice) & !$acc delete(this) !$omp target exit data map(release:this%lut_extliq, this%lut_ssaliq, this%lut_asyliq) & !$omp map(release:this%lut_extice, this%lut_ssaice, this%lut_asyice) deallocate ( this % lut_extliq , this % lut_ssaliq , this % lut_asyliq , & this % lut_extice , this % lut_ssaice , this % lut_asyice ) this % liq_nsteps = 0 this % ice_nsteps = 0 this % liq_step_size = 0._wp this % ice_step_size = 0._wp end if ! Pade cloud optics coefficients if ( allocated ( this % pade_extliq )) then !$acc exit data delete(this%pade_extliq, this%pade_ssaliq, this%pade_asyliq) & !$acc delete(this%pade_extice, this%pade_ssaice, this%pade_asyice) & !$acc delete(this%pade_sizreg_extliq, this%pade_sizreg_ssaliq, this%pade_sizreg_asyliq) & !$acc delete(this%pade_sizreg_extice, this%pade_sizreg_ssaice, this%pade_sizreg_asyice) & !$acc delete(this) !$omp target exit data map(release:this%pade_extliq, this%pade_ssaliq, this%pade_asyliq) & !$omp map(release:this%pade_extice, this%pade_ssaice, this%pade_asyice) & !$omp map(release:this%pade_sizreg_extliq, this%pade_sizreg_ssaliq, this%pade_sizreg_asyliq) & !$omp map(release:this%pade_sizreg_extice, this%pade_sizreg_ssaice, this%pade_sizreg_asyice) deallocate ( this % pade_extliq , this % pade_ssaliq , this % pade_asyliq , & this % pade_extice , this % pade_ssaice , this % pade_asyice , & this % pade_sizreg_extliq , this % pade_sizreg_ssaliq , this % pade_sizreg_asyliq , & this % pade_sizreg_extice , this % pade_sizreg_ssaice , this % pade_sizreg_asyice ) end if end subroutine finalize ! ------------------------------------------------------------------------------ ! ! Derive cloud optical properties from provided cloud physical properties ! ! ------------------------------------------------------------------------------ ! ! Compute single-scattering properties ! function cloud_optics ( this , & clwp , ciwp , reliq , reice , & optical_props ) result ( error_msg ) class ( ty_cloud_optics_rrtmgp ), & intent ( in ) :: this real ( wp ), intent ( in ) :: clwp (:,:), & ! cloud liquid water path (g/m2) ciwp (:,:), & ! cloud ice water path (g/m2) reliq (:,:), & ! cloud liquid particle effective size (microns) reice (:,:) ! cloud ice particle effective radius (microns) class ( ty_optical_props_arry ), & intent ( inout ) :: optical_props ! Dimensions: (ncol,nlay,nbnd) character ( len = 128 ) :: error_msg ! ------- Local ------- logical ( wl ), dimension ( size ( clwp , 1 ), size ( clwp , 2 )) :: liqmsk , icemsk real ( wp ), dimension ( size ( clwp , 1 ), size ( clwp , 2 ), this % get_nband ()) :: & ltau , ltaussa , ltaussag , itau , itaussa , itaussag ! Optical properties: tau, tau*ssa, tau*ssa*g ! liquid and ice separately integer :: ncol , nlay , nbnd integer :: nsizereg integer :: icol , ilay , ibnd ! scalars for total tau, tau*ssa real ( wp ) :: tau , taussa ! ---------------------------------------- ! ! Error checking ! ! ---------------------------------------- error_msg = '' if (. not .( allocated ( this % lut_extliq ) . or . allocated ( this % pade_extliq ))) then error_msg = 'cloud optics: no data has been initialized' return end if ncol = size ( clwp , 1 ) nlay = size ( clwp , 2 ) nbnd = this % get_nband () ! ! Array sizes ! if ( check_extents ) then if ( size ( liqmsk , 1 ) /= ncol . or . size ( liqmsk , 2 ) /= nlay ) & error_msg = \"cloud optics: liqmask has wrong extents\" if ( size ( icemsk , 1 ) /= ncol . or . size ( icemsk , 2 ) /= nlay ) & error_msg = \"cloud optics: icemsk has wrong extents\" if ( size ( ciwp , 1 ) /= ncol . or . size ( ciwp , 2 ) /= nlay ) & error_msg = \"cloud optics: ciwp has wrong extents\" if ( size ( reliq , 1 ) /= ncol . or . size ( reliq , 2 ) /= nlay ) & error_msg = \"cloud optics: reliq has wrong extents\" if ( size ( reice , 1 ) /= ncol . or . size ( reice , 2 ) /= nlay ) & error_msg = \"cloud optics: reice has wrong extents\" if ( optical_props % get_ncol () /= ncol . or . optical_props % get_nlay () /= nlay ) & error_msg = \"cloud optics: optical_props have wrong extents\" if ( error_msg /= \"\" ) return end if ! ! Spectral consistency ! if ( check_values ) then if (. not . this % bands_are_equal ( optical_props )) & error_msg = \"cloud optics: optical properties don't have the same band structure\" if ( optical_props % get_nband () /= optical_props % get_ngpt () ) & error_msg = \"cloud optics: optical properties must be requested by band not g-points\" if ( error_msg /= \"\" ) return end if !$acc data copyin(clwp, ciwp, reliq, reice) & !$acc create(ltau, ltaussa, ltaussag, itau, itaussa, itaussag) & !$acc create(liqmsk,icemsk) !$omp target data map(to:clwp, ciwp, reliq, reice) & !$omp map(alloc:ltau, ltaussa, ltaussag, itau, itaussa, itaussag) & !$omp map(alloc:liqmsk, icemsk) ! ! Cloud masks; don't need value re values if there's no cloud ! !$acc parallel loop gang vector default(present) collapse(2) !$omp target teams distribute parallel do simd collapse(2) do ilay = 1 , nlay do icol = 1 , ncol liqmsk ( icol , ilay ) = clwp ( icol , ilay ) > 0._wp icemsk ( icol , ilay ) = ciwp ( icol , ilay ) > 0._wp end do end do ! ! Particle size, liquid/ice water paths ! if ( check_values ) then if ( any_vals_outside ( reliq , liqmsk , this % radliq_lwr , this % radliq_upr )) & error_msg = 'cloud optics: liquid effective radius is out of bounds' if ( any_vals_outside ( reice , icemsk , this % radice_lwr , this % radice_upr )) & error_msg = 'cloud optics: ice effective radius is out of bounds' if ( any_vals_less_than ( clwp , liqmsk , 0._wp ) . or . any_vals_less_than ( ciwp , icemsk , 0._wp )) & error_msg = 'cloud optics: negative clwp or ciwp where clouds are supposed to be' end if if ( error_msg == \"\" ) then ! ! ! ---------------------------------------- ! ! The tables and Pade coefficients determing extinction coeffient, single-scattering albedo, ! and asymmetry parameter g as a function of effective raduis ! We compute the optical depth tau (=exintinction coeff * condensed water path) ! and the products tau*ssa and tau*ssa*g for liquid and ice cloud separately. ! These are used to determine the optical properties of ice and water cloud together. ! We could compute the properties for liquid and ice separately and ! use ty_optical_props_arry%increment but this involves substantially more division. ! if ( allocated ( this % lut_extliq )) then ! ! Liquid ! call compute_all_from_table ( ncol , nlay , nbnd , liqmsk , clwp , reliq , & this % liq_nsteps , this % liq_step_size , this % radliq_lwr , & this % lut_extliq , this % lut_ssaliq , this % lut_asyliq , & ltau , ltaussa , ltaussag ) ! ! Ice ! call compute_all_from_table ( ncol , nlay , nbnd , icemsk , ciwp , reice , & this % ice_nsteps , this % ice_step_size , this % radice_lwr , & this % lut_extice (:,:, this % icergh ), & this % lut_ssaice (:,:, this % icergh ), & this % lut_asyice (:,:, this % icergh ), & itau , itaussa , itaussag ) else ! ! Cloud optical properties from Pade coefficient method ! Hard coded assumptions: order of approximants, three size regimes ! nsizereg = size ( this % pade_extliq , 2 ) call compute_all_from_pade ( ncol , nlay , nbnd , nsizereg , & liqmsk , clwp , reliq , & 2 , 3 , this % pade_sizreg_extliq , this % pade_extliq , & 2 , 2 , this % pade_sizreg_ssaliq , this % pade_ssaliq , & 2 , 2 , this % pade_sizreg_asyliq , this % pade_asyliq , & ltau , ltaussa , ltaussag ) call compute_all_from_pade ( ncol , nlay , nbnd , nsizereg , & icemsk , ciwp , reice , & 2 , 3 , this % pade_sizreg_extice , this % pade_extice (:,:,:, this % icergh ), & 2 , 2 , this % pade_sizreg_ssaice , this % pade_ssaice (:,:,:, this % icergh ), & 2 , 2 , this % pade_sizreg_asyice , this % pade_asyice (:,:,:, this % icergh ), & itau , itaussa , itaussag ) endif ! ! Combine liquid and ice contributions into total cloud optical properties ! See also the increment routines in mo_optical_props_kernels ! select type ( optical_props ) type is ( ty_optical_props_1scl ) !$acc parallel loop gang vector default(present) collapse(3) & !$acc copyin(optical_props) copyout(optical_props%tau) !$omp target teams distribute parallel do simd collapse(3) & !$omp map(from:optical_props%tau) do ibnd = 1 , nbnd do ilay = 1 , nlay do icol = 1 , ncol ! Absorption optical depth = (1-ssa) * tau = tau - taussa optical_props % tau ( icol , ilay , ibnd ) = ( ltau ( icol , ilay , ibnd ) - ltaussa ( icol , ilay , ibnd )) + & ( itau ( icol , ilay , ibnd ) - itaussa ( icol , ilay , ibnd )) end do end do end do type is ( ty_optical_props_2str ) !$acc parallel loop gang vector default(present) collapse(3) & !$acc copyin(optical_props) copyout(optical_props%tau, optical_props%ssa, optical_props%g) !$omp target teams distribute parallel do simd collapse(3) & !$omp map(from:optical_props%tau, optical_props%ssa, optical_props%g) do ibnd = 1 , nbnd do ilay = 1 , nlay do icol = 1 , ncol tau = ltau ( icol , ilay , ibnd ) + itau ( icol , ilay , ibnd ) taussa = ltaussa ( icol , ilay , ibnd ) + itaussa ( icol , ilay , ibnd ) optical_props % g ( icol , ilay , ibnd ) = ( ltaussag ( icol , ilay , ibnd ) + itaussag ( icol , ilay , ibnd )) / & max ( epsilon ( tau ), taussa ) optical_props % ssa ( icol , ilay , ibnd ) = taussa / max ( epsilon ( tau ), tau ) optical_props % tau ( icol , ilay , ibnd ) = tau end do end do end do type is ( ty_optical_props_nstr ) error_msg = \"cloud optics: n-stream calculations not yet supported\" end select end if !$acc end data !$omp end target data end function cloud_optics !-------------------------------------------------------------------------------------------------------------------- ! ! Inquiry functions ! !-------------------------------------------------------------------------------------------------------------------- function set_ice_roughness ( this , icergh ) result ( error_msg ) class ( ty_cloud_optics_rrtmgp ), intent ( inout ) :: this integer , intent ( in ) :: icergh character ( len = 128 ) :: error_msg error_msg = \"\" if (. not . allocated ( this % pade_extice ) . and . . not . allocated ( this % lut_extice )) & error_msg = \"cloud_optics%set_ice_roughness(): can't set before initialization\" if ( icergh < 1 . or . icergh > this % get_num_ice_roughness_types ()) & error_msg = 'cloud optics: cloud ice surface roughness flag is out of bounds' if ( error_msg /= \"\" ) return this % icergh = icergh end function set_ice_roughness !----------------------------------------------- function get_num_ice_roughness_types ( this ) result ( i ) class ( ty_cloud_optics_rrtmgp ), intent ( in ) :: this integer :: i i = 0 if ( allocated ( this % pade_extice )) i = size ( this % pade_extice , dim = 4 ) if ( allocated ( this % lut_extice )) i = size ( this % lut_extice , dim = 3 ) end function get_num_ice_roughness_types !----------------------------------------------- function get_min_radius_liq ( this ) result ( r ) class ( ty_cloud_optics_rrtmgp ), intent ( in ) :: this real ( wp ) :: r r = this % radliq_lwr end function get_min_radius_liq !----------------------------------------------- function get_max_radius_liq ( this ) result ( r ) class ( ty_cloud_optics_rrtmgp ), intent ( in ) :: this real ( wp ) :: r r = this % radliq_upr end function get_max_radius_liq !----------------------------------------------- function get_min_radius_ice ( this ) result ( r ) class ( ty_cloud_optics_rrtmgp ), intent ( in ) :: this real ( wp ) :: r r = this % radice_lwr end function get_min_radius_ice !----------------------------------------------- function get_max_radius_ice ( this ) result ( r ) class ( ty_cloud_optics_rrtmgp ), intent ( in ) :: this real ( wp ) :: r r = this % radice_upr end function get_max_radius_ice !-------------------------------------------------------------------------------------------------------------------- ! ! Ancillary functions ! !-------------------------------------------------------------------------------------------------------------------- ! ! Linearly interpolate values from a lookup table with \"nsteps\" evenly-spaced ! elements starting at \"offset.\" The table's second dimension is band. ! Returns 0 where the mask is false. ! We could also try gather/scatter for efficiency ! subroutine compute_all_from_table ( ncol , nlay , nbnd , mask , lwp , re , & nsteps , step_size , offset , & tau_table , ssa_table , asy_table , & tau , taussa , taussag ) integer , intent ( in ) :: ncol , nlay , nbnd , nsteps logical ( wl ), dimension ( ncol , nlay ), intent ( in ) :: mask real ( wp ), dimension ( ncol , nlay ), intent ( in ) :: lwp , re real ( wp ), intent ( in ) :: step_size , offset real ( wp ), dimension ( nsteps , nbnd ), intent ( in ) :: tau_table , ssa_table , asy_table real ( wp ), dimension ( ncol , nlay , nbnd ) :: tau , taussa , taussag ! --------------------------- integer :: icol , ilay , ibnd integer :: index real ( wp ) :: fint real ( wp ) :: t , ts ! tau, tau*ssa, tau*ssa*g ! --------------------------- !$acc parallel loop gang vector default(present) collapse(3) !$omp target teams distribute parallel do simd collapse(3) do ibnd = 1 , nbnd do ilay = 1 , nlay do icol = 1 , ncol if ( mask ( icol , ilay )) then index = min ( floor (( re ( icol , ilay ) - offset ) / step_size ) + 1 , nsteps - 1 ) fint = ( re ( icol , ilay ) - offset ) / step_size - ( index - 1 ) t = lwp ( icol , ilay ) * & ( tau_table ( index , ibnd ) + fint * ( tau_table ( index + 1 , ibnd ) - tau_table ( index , ibnd ))) ts = t * & ( ssa_table ( index , ibnd ) + fint * ( ssa_table ( index + 1 , ibnd ) - ssa_table ( index , ibnd ))) taussag ( icol , ilay , ibnd ) = & ts * & ( asy_table ( index , ibnd ) + fint * ( asy_table ( index + 1 , ibnd ) - asy_table ( index , ibnd ))) taussa ( icol , ilay , ibnd ) = ts tau ( icol , ilay , ibnd ) = t else tau ( icol , ilay , ibnd ) = 0._wp taussa ( icol , ilay , ibnd ) = 0._wp taussag ( icol , ilay , ibnd ) = 0._wp end if end do end do end do end subroutine compute_all_from_table ! ! Pade functions ! !--------------------------------------------------------------------------- subroutine compute_all_from_pade ( ncol , nlay , nbnd , nsizes , & mask , lwp , re , & m_ext , n_ext , re_bounds_ext , coeffs_ext , & m_ssa , n_ssa , re_bounds_ssa , coeffs_ssa , & m_asy , n_asy , re_bounds_asy , coeffs_asy , & tau , taussa , taussag ) integer , intent ( in ) :: ncol , nlay , nbnd , nsizes logical ( wl ), & dimension ( ncol , nlay ), intent ( in ) :: mask real ( wp ), dimension ( ncol , nlay ), intent ( in ) :: lwp , re real ( wp ), dimension ( nsizes + 1 ), intent ( in ) :: re_bounds_ext , re_bounds_ssa , re_bounds_asy integer , intent ( in ) :: m_ext , n_ext real ( wp ), dimension ( nbnd , nsizes , 0 : m_ext + n_ext ), & intent ( in ) :: coeffs_ext integer , intent ( in ) :: m_ssa , n_ssa real ( wp ), dimension ( nbnd , nsizes , 0 : m_ssa + n_ssa ), & intent ( in ) :: coeffs_ssa integer , intent ( in ) :: m_asy , n_asy real ( wp ), dimension ( nbnd , nsizes , 0 : m_asy + n_asy ), & intent ( in ) :: coeffs_asy real ( wp ), dimension ( ncol , nlay , nbnd ) :: tau , taussa , taussag ! --------------------------- integer :: icol , ilay , ibnd , irad real ( wp ) :: t , ts !$acc parallel loop gang vector default(present) collapse(3) !$omp target teams distribute parallel do simd collapse(3) do ibnd = 1 , nbnd do ilay = 1 , nlay do icol = 1 , ncol if ( mask ( icol , ilay )) then ! ! Finds index into size regime table ! This works only if there are precisely three size regimes (four bounds) and it's ! previously guaranteed that size_bounds(1) <= size <= size_bounds(4) ! irad = min ( floor (( re ( icol , ilay ) - re_bounds_ext ( 2 )) / re_bounds_ext ( 3 )) + 2 , 3 ) t = lwp ( icol , ilay ) * & pade_eval ( ibnd , nbnd , nsizes , m_ext , n_ext , irad , re ( icol , ilay ), coeffs_ext ) irad = min ( floor (( re ( icol , ilay ) - re_bounds_ssa ( 2 )) / re_bounds_ssa ( 3 )) + 2 , 3 ) ! Pade approximants for co-albedo can sometimes be negative ts = t * ( 1._wp - max ( 0._wp , & pade_eval ( ibnd , nbnd , nsizes , m_ssa , n_ssa , irad , re ( icol , ilay ), coeffs_ssa ))) irad = min ( floor (( re ( icol , ilay ) - re_bounds_asy ( 2 )) / re_bounds_asy ( 3 )) + 2 , 3 ) taussag ( icol , ilay , ibnd ) = & ts * & pade_eval ( ibnd , nbnd , nsizes , m_asy , n_asy , irad , re ( icol , ilay ), coeffs_asy ) taussa ( icol , ilay , ibnd ) = ts tau ( icol , ilay , ibnd ) = t else tau ( icol , ilay , ibnd ) = 0._wp taussa ( icol , ilay , ibnd ) = 0._wp taussag ( icol , ilay , ibnd ) = 0._wp end if end do end do end do end subroutine compute_all_from_pade !--------------------------------------------------------------------------- ! ! Evaluate Pade approximant of order [m/n] ! function pade_eval_nbnd ( nbnd , nrads , m , n , irad , re , pade_coeffs ) integer , intent ( in ) :: nbnd , nrads , m , n , irad real ( wp ), dimension ( nbnd , nrads , 0 : m + n ), & intent ( in ) :: pade_coeffs real ( wp ), intent ( in ) :: re real ( wp ), dimension ( nbnd ) :: pade_eval_nbnd integer :: iband real ( wp ) :: numer , denom integer :: i do iband = 1 , nbnd denom = pade_coeffs ( iband , irad , n + m ) do i = n - 1 + m , 1 + m , - 1 denom = pade_coeffs ( iband , irad , i ) + re * denom end do denom = 1._wp + re * denom numer = pade_coeffs ( iband , irad , m ) do i = m - 1 , 1 , - 1 numer = pade_coeffs ( iband , irad , i ) + re * numer end do numer = pade_coeffs ( iband , irad , 0 ) + re * numer pade_eval_nbnd ( iband ) = numer / denom end do end function pade_eval_nbnd !--------------------------------------------------------------------------- ! ! Evaluate Pade approximant of order [m/n] ! function pade_eval_1 ( iband , nbnd , nrads , m , n , irad , re , pade_coeffs ) !$acc routine seq !$omp declare target ! integer , intent ( in ) :: iband , nbnd , nrads , m , n , irad real ( wp ), dimension ( nbnd , nrads , 0 : m + n ), & intent ( in ) :: pade_coeffs real ( wp ), intent ( in ) :: re real ( wp ) :: pade_eval_1 real ( wp ) :: numer , denom integer :: i denom = pade_coeffs ( iband , irad , n + m ) do i = n - 1 + m , 1 + m , - 1 denom = pade_coeffs ( iband , irad , i ) + re * denom end do denom = 1._wp + re * denom numer = pade_coeffs ( iband , irad , m ) do i = m - 1 , 1 , - 1 numer = pade_coeffs ( iband , irad , i ) + re * numer end do numer = pade_coeffs ( iband , irad , 0 ) + re * numer pade_eval_1 = numer / denom end function pade_eval_1 end module mo_cloud_optics_rrtmgp","tags":"","loc":"sourcefile/mo_cloud_optics_rrtmgp.f90.html"},{"title":"mo_gas_optics_rrtmgp.F90 – RRTMGP-Fortran","text":"Contents Modules mo_gas_optics_rrtmgp Source Code mo_gas_optics_rrtmgp.F90 Source Code ! This code is part of RRTM for GCM Applications - Parallel (RRTMGP) ! ! Contacts: Robert Pincus and Eli Mlawer ! email: rrtmgp@aer.com ! ! Copyright 2015-, Atmospheric and Environmental Research, ! Regents of the University of Colorado, Trustees of Columbia University. All right reserved. ! ! Use and duplication is permitted under the terms of the ! BSD 3-clause license, see http://opensource.org/licenses/BSD-3-Clause ! ------------------------------------------------------------------------------------------------- ! !> ## Class implementing the RRTMGP correlated-_k_ distribution !> !> Implements a class for computing spectrally-resolved gas optical properties and source functions !> given atmopsheric physical properties (profiles of temperature, pressure, and gas concentrations) !> The class must be initialized with data (provided as a netCDF file) before being used. !> !> Two variants apply to internal Planck sources (longwave radiation in the Earth's atmosphere) and to !> external stellar radiation (shortwave radiation in the Earth's atmosphere). !> The variant is chosen based on what information is supplied during initialization. ! (It might make more sense to define two sub-classes) ! ! ------------------------------------------------------------------------------------------------- module mo_gas_optics_rrtmgp use mo_rte_kind , only : wp , wl use mo_rte_config , only : check_extents , check_values use mo_rte_util_array , only : zero_array use mo_rte_util_array_validation , & only : any_vals_less_than , any_vals_outside , extents_are use mo_optical_props , only : ty_optical_props use mo_source_functions , only : ty_source_func_lw use mo_gas_optics_rrtmgp_kernels , & only : interpolation , compute_tau_absorption , compute_tau_rayleigh , compute_Planck_source use mo_gas_optics_constants , only : avogad , m_dry , m_h2o , grav use mo_gas_optics_util_string , only : lower_case , string_in_array , string_loc_in_array use mo_gas_concentrations , only : ty_gas_concs use mo_optical_props , only : ty_optical_props_arry , ty_optical_props_1scl , ty_optical_props_2str , ty_optical_props_nstr use mo_gas_optics , only : ty_gas_optics implicit none private real ( wp ), parameter :: pi = acos ( - 1._wp ) ! ------------------------------------------------------------------------------------------------- type , extends ( ty_gas_optics ), public :: ty_gas_optics_rrtmgp private ! ! RRTMGP computes absorption in each band arising from ! two major species in each band, which are combined to make ! a relative mixing ratio eta and a total column amount (col_mix) ! contributions from zero or more minor species whose concentrations ! may be scaled by other components of the atmosphere ! ! Absorption coefficients are interpolated from tables on a pressure/temperature/(eta) grid ! ! ------------------------------------ ! Interpolation variables: Temperature and pressure grids ! real ( wp ), dimension (:), allocatable :: press_ref , press_ref_log , temp_ref ! ! Derived and stored for convenience: ! Min and max for temperature and pressure intepolation grids ! difference in ln pressure between consecutive reference levels ! log of reference pressure separating the lower and upper atmosphere ! real ( wp ) :: press_ref_min , press_ref_max , & temp_ref_min , temp_ref_max real ( wp ) :: press_ref_log_delta , temp_ref_delta , press_ref_trop_log ! ------------------------------------ ! Major absorbers (\"key species\") ! Each unique set of major species is called a flavor. ! ! Names and reference volume mixing ratios of major gases ! character ( 32 ), dimension (:), allocatable :: gas_names ! gas names real ( wp ), dimension (:,:,:), allocatable :: vmr_ref ! vmr_ref(lower or upper atmosphere, gas, temp) ! ! Which two gases are in each flavor? By index ! integer , dimension (:,:), allocatable :: flavor ! major species pair; (2,nflav) ! ! Which flavor for each g-point? One each for lower, upper atmosphere ! integer , dimension (:,:), allocatable :: gpoint_flavor ! flavor = gpoint_flavor(2, g-point) ! ! Major gas absorption coefficients ! real ( wp ), dimension (:,:,:,:), allocatable :: kmajor ! kmajor(g-point,eta,pressure,temperature) ! ! ------------------------------------ ! Minor species, independently for upper and lower atmospheres ! Array extents in the n_minor dimension will differ between upper and lower atmospheres ! Each contribution has starting and ending g-points ! integer , dimension (:,:), allocatable :: minor_limits_gpt_lower , & minor_limits_gpt_upper ! ! Minor gas contributions might be scaled by other gas amounts; if so we need to know ! the total density and whether the contribution is scaled by the partner gas ! or its complement (i.e. all other gases) ! Water vapor self- and foreign continua work like this, as do ! all collision-induced abosption pairs ! logical ( wl ), dimension (:), allocatable :: minor_scales_with_density_lower , & minor_scales_with_density_upper logical ( wl ), dimension (:), allocatable :: scale_by_complement_lower , scale_by_complement_upper integer , dimension (:), allocatable :: idx_minor_lower , idx_minor_upper integer , dimension (:), allocatable :: idx_minor_scaling_lower , idx_minor_scaling_upper ! ! Index into table of absorption coefficients ! integer , dimension (:), allocatable :: kminor_start_lower , kminor_start_upper ! ! The absorption coefficients themselves ! real ( wp ), dimension (:,:,:), allocatable :: kminor_lower , kminor_upper ! kminor_lower(n_minor,eta,temperature) ! ! ----------------------------------------------------------------------------------- ! ! Rayleigh scattering coefficients ! real ( wp ), dimension (:,:,:,:), allocatable :: krayl ! krayl(g-point,eta,temperature,upper/lower atmosphere) ! ! ----------------------------------------------------------------------------------- ! Planck function spectral mapping ! Allocated only when gas optics object is internal-source ! real ( wp ), dimension (:,:,:,:), allocatable :: planck_frac ! stored fraction of Planck irradiance in band for given g-point ! planck_frac(g-point, eta, pressure, temperature) real ( wp ), dimension (:,:), allocatable :: totplnk ! integrated Planck irradiance by band; (Planck temperatures,band) real ( wp ) :: totplnk_delta ! temperature steps in totplnk real ( wp ), dimension (:,:), allocatable :: optimal_angle_fit ! coefficients of linear function ! of vertical path clear-sky transmittance that is used to ! determine the secant of single angle used for the ! no-scattering calculation, ! optimal_angle_fit(coefficient, band) ! ----------------------------------------------------------------------------------- ! Solar source function spectral mapping with solar variability capability ! Allocated when gas optics object is external-source ! n-solar-terms: quiet sun, facular brightening and sunspot dimming components ! following the NRLSSI2 model of Coddington et al. 2016, doi:10.1175/BAMS-D-14-00265.1. ! real ( wp ), dimension (:), allocatable :: solar_source ! incoming solar irradiance, computed from other three terms (g-point) real ( wp ), dimension (:), allocatable :: solar_source_quiet ! incoming solar irradiance, quiet sun term (g-point) real ( wp ), dimension (:), allocatable :: solar_source_facular ! incoming solar irradiance, facular term (g-point) real ( wp ), dimension (:), allocatable :: solar_source_sunspot ! incoming solar irradiance, sunspot term (g-point) ! ! ----------------------------------------------------------------------------------- ! Ancillary ! ----------------------------------------------------------------------------------- ! Index into %gas_names -- is this a key species in any band? logical , dimension (:), allocatable :: is_key ! ----------------------------------------------------------------------------------- contains ! Type-bound procedures ! Public procedures ! public interface generic , public :: load => load_int , load_ext procedure , public :: source_is_internal procedure , public :: source_is_external procedure , public :: is_loaded procedure , public :: finalize procedure , public :: get_ngas procedure , public :: get_gases procedure , public :: get_press_min procedure , public :: get_press_max procedure , public :: get_temp_min procedure , public :: get_temp_max procedure , public :: compute_optimal_angles procedure , public :: set_solar_variability procedure , public :: set_tsi ! Internal procedures procedure , private :: load_int procedure , private :: load_ext procedure , public :: gas_optics_int procedure , public :: gas_optics_ext procedure , private :: check_key_species_present ! Interpolation table dimensions procedure , private :: get_nflav procedure , private :: get_neta procedure , private :: get_npres procedure , private :: get_ntemp procedure , private :: get_nPlanckTemp end type ty_gas_optics_rrtmgp ! ------------------------------------------------------------------------------------------------- ! !> col_dry is the number of molecules per cm-2 of dry air ! public :: get_col_dry ! Utility function, not type-bound contains ! -------------------------------------------------------------------------------------- ! ! Public procedures ! ! -------------------------------------------------------------------------------------- ! !> Two functions to define array sizes needed by gas_optics() ! pure function get_ngas ( this ) ! return the number of gases registered in the spectral configuration class ( ty_gas_optics_rrtmgp ), intent ( in ) :: this integer :: get_ngas get_ngas = size ( this % gas_names ) end function get_ngas !-------------------------------------------------------------------------------------------------------------------- ! !> return the number of distinct major gas pairs in the spectral bands (referred to as !> \"flavors\" - all bands have a flavor even if there is one or no major gas) ! pure function get_nflav ( this ) class ( ty_gas_optics_rrtmgp ), intent ( in ) :: this integer :: get_nflav get_nflav = size ( this % flavor , dim = 2 ) end function get_nflav !-------------------------------------------------------------------------------------------------------------------- ! !> Compute gas optical depth and Planck source functions, !> given temperature, pressure, and composition ! function gas_optics_int ( this , & play , plev , tlay , tsfc , gas_desc , & optical_props , sources , & col_dry , tlev ) result ( error_msg ) ! inputs class ( ty_gas_optics_rrtmgp ), intent ( in ) :: this real ( wp ), dimension (:,:), intent ( in ) :: play , & !! layer pressures [Pa, mb]; (ncol,nlay) plev , & !! level pressures [Pa, mb]; (ncol,nlay+1) tlay !! layer temperatures [K]; (ncol,nlay) real ( wp ), dimension (:), intent ( in ) :: tsfc !! surface skin temperatures [K]; (ncol) type ( ty_gas_concs ), intent ( in ) :: gas_desc !! Gas volume mixing ratios ! output class ( ty_optical_props_arry ), & intent ( inout ) :: optical_props !! Optical properties class ( ty_source_func_lw ), & intent ( inout ) :: sources !! Planck sources character ( len = 128 ) :: error_msg !! Empty if succssful ! Optional inputs real ( wp ), dimension (:,:), intent ( in ), & optional , target :: col_dry , & !! Column dry amount; dim(ncol,nlay) tlev !! level temperatures [K]; (ncol,nlay+1) ! ---------------------------------------------------------- ! Local variables ! Interpolation coefficients for use in source function integer , dimension ( size ( play , dim = 1 ), size ( play , dim = 2 )) :: jtemp , jpress logical ( wl ), dimension ( size ( play , dim = 1 ), size ( play , dim = 2 )) :: tropo real ( wp ), dimension ( 2 , 2 , 2 , size ( play , dim = 1 ), size ( play , dim = 2 ), get_nflav ( this )) :: fmajor integer , dimension ( 2 , size ( play , dim = 1 ), size ( play , dim = 2 ), get_nflav ( this )) :: jeta integer :: ncol , nlay , ngpt , nband ! ---------------------------------------------------------- ncol = size ( play , dim = 1 ) nlay = size ( play , dim = 2 ) ngpt = this % get_ngpt () nband = this % get_nband () ! ! Gas optics ! !$acc enter data create(jtemp, jpress, tropo, fmajor, jeta) !$omp target enter data map(alloc:jtemp, jpress, tropo, fmajor, jeta) error_msg = compute_gas_taus ( this , & ncol , nlay , ngpt , nband , & play , plev , tlay , gas_desc , & optical_props , & jtemp , jpress , jeta , tropo , fmajor , & col_dry ) if ( error_msg /= '' ) return ! ---------------------------------------------------------- ! ! External source -- check arrays sizes and values ! input data sizes and values ! !$acc enter data copyin(tsfc, tlev) ! Should be fine even if tlev is not supplied !$omp target enter data map(to:tsfc, tlev) if ( check_extents ) then if (. not . extents_are ( tsfc , ncol )) & error_msg = \"gas_optics(): array tsfc has wrong size\" if ( present ( tlev )) then if (. not . extents_are ( tlev , ncol , nlay + 1 )) & error_msg = \"gas_optics(): array tlev has wrong size\" end if ! ! output extents ! if ( any ([ sources % get_ncol (), sources % get_nlay (), sources % get_ngpt ()] /= [ ncol , nlay , ngpt ])) & error_msg = \"gas_optics%gas_optics: source function arrays inconsistently sized\" end if if ( error_msg /= '' ) return if ( check_values ) then if ( any_vals_outside ( tsfc , this % temp_ref_min , this % temp_ref_max )) & error_msg = \"gas_optics(): array tsfc has values outside range\" if ( present ( tlev )) then if ( any_vals_outside ( tlev , this % temp_ref_min , this % temp_ref_max )) & error_msg = \"gas_optics(): array tlev has values outside range\" end if end if if ( error_msg /= '' ) return ! ! Interpolate source function ! if ( present ( tlev )) then ! ! present status of optional argument should be passed to source() ! but isn't with PGI 19.10 ! error_msg = source ( this , & ncol , nlay , nband , ngpt , & play , plev , tlay , tsfc , & jtemp , jpress , jeta , tropo , fmajor , & sources , & tlev ) !$acc exit data delete(tlev) !$omp target exit data map(release:tlev) else error_msg = source ( this , & ncol , nlay , nband , ngpt , & play , plev , tlay , tsfc , & jtemp , jpress , jeta , tropo , fmajor , & sources ) end if !$acc exit data delete(tsfc) !$omp target exit data map(release:tsfc) !$acc exit data delete(jtemp, jpress, tropo, fmajor, jeta) !$omp target exit data map(release:jtemp, jpress, tropo, fmajor, jeta) end function gas_optics_int !------------------------------------------------------------------------------------------ ! !> Compute gas optical depth given temperature, pressure, and composition !> Top-of-atmosphere stellar insolation is also reported ! function gas_optics_ext ( this , & play , plev , tlay , gas_desc , & ! mandatory inputs optical_props , toa_src , & ! mandatory outputs col_dry ) result ( error_msg ) ! optional input class ( ty_gas_optics_rrtmgp ), intent ( in ) :: this real ( wp ), dimension (:,:), intent ( in ) :: play , & !! layer pressures [Pa, mb]; (ncol,nlay) plev , & !! level pressures [Pa, mb]; (ncol,nlay+1) tlay !! layer temperatures [K]; (ncol,nlay) type ( ty_gas_concs ), intent ( in ) :: gas_desc !! Gas volume mixing ratios ! output class ( ty_optical_props_arry ), & intent ( inout ) :: optical_props real ( wp ), dimension (:,:), intent ( out ) :: toa_src !! Incoming solar irradiance(ncol,ngpt) character ( len = 128 ) :: error_msg !! Empty if successful ! Optional inputs real ( wp ), dimension (:,:), intent ( in ), & optional , target :: col_dry ! Column dry amount; dim(ncol,nlay) ! ---------------------------------------------------------- ! Local variables ! Interpolation coefficients for use in source function integer , dimension ( size ( play , dim = 1 ), size ( play , dim = 2 )) :: jtemp , jpress logical ( wl ), dimension ( size ( play , dim = 1 ), size ( play , dim = 2 )) :: tropo real ( wp ), dimension ( 2 , 2 , 2 , size ( play , dim = 1 ), size ( play , dim = 2 ), get_nflav ( this )) :: fmajor integer , dimension ( 2 , size ( play , dim = 1 ), size ( play , dim = 2 ), get_nflav ( this )) :: jeta integer :: ncol , nlay , ngpt , nband , ngas , nflav integer :: igpt , icol ! ---------------------------------------------------------- ncol = size ( play , dim = 1 ) nlay = size ( play , dim = 2 ) ngpt = this % get_ngpt () nband = this % get_nband () ngas = this % get_ngas () nflav = get_nflav ( this ) ! ! Gas optics ! !$acc enter data create(jtemp, jpress, tropo, fmajor, jeta) !$omp target enter data map(alloc:jtemp, jpress, tropo, fmajor, jeta) error_msg = compute_gas_taus ( this , & ncol , nlay , ngpt , nband , & play , plev , tlay , gas_desc , & optical_props , & jtemp , jpress , jeta , tropo , fmajor , & col_dry ) !$acc exit data delete(jtemp, jpress, tropo, fmajor, jeta) !$omp target exit data map(release:jtemp, jpress, tropo, fmajor, jeta) if ( error_msg /= '' ) return ! ---------------------------------------------------------- ! ! External source function is constant ! !$acc enter data create(toa_src) !$omp target enter data map(alloc:toa_src) if ( check_extents ) then if (. not . extents_are ( toa_src , ncol , ngpt )) & error_msg = \"gas_optics(): array toa_src has wrong size\" end if if ( error_msg /= '' ) return !$acc parallel loop collapse(2) !$omp target teams distribute parallel do simd collapse(2) do igpt = 1 , ngpt do icol = 1 , ncol toa_src ( icol , igpt ) = this % solar_source ( igpt ) end do end do !$acc exit data copyout(toa_src) !$omp target exit data map(from:toa_src) end function gas_optics_ext !------------------------------------------------------------------------------------------ ! ! Returns optical properties and interpolation coefficients ! function compute_gas_taus ( this , & ncol , nlay , ngpt , nband , & play , plev , tlay , gas_desc , & optical_props , & jtemp , jpress , jeta , tropo , fmajor , & col_dry ) result ( error_msg ) class ( ty_gas_optics_rrtmgp ), & intent ( in ) :: this integer , intent ( in ) :: ncol , nlay , ngpt , nband real ( wp ), dimension (:,:), intent ( in ) :: play , & ! layer pressures [Pa, mb]; (ncol,nlay) plev , & ! level pressures [Pa, mb]; (ncol,nlay+1) tlay ! layer temperatures [K]; (ncol,nlay) type ( ty_gas_concs ), intent ( in ) :: gas_desc ! Gas volume mixing ratios class ( ty_optical_props_arry ), intent ( inout ) :: optical_props !inout because components are allocated ! Interpolation coefficients for use in internal source function integer , dimension ( ncol , nlay ), intent ( out ) :: jtemp , jpress integer , dimension ( 2 , ncol , nlay , get_nflav ( this )), intent ( out ) :: jeta logical ( wl ), dimension ( ncol , nlay ), intent ( out ) :: tropo real ( wp ), dimension ( 2 , 2 , 2 , ncol , nlay , get_nflav ( this )), intent ( out ) :: fmajor character ( len = 128 ) :: error_msg ! Optional inputs real ( wp ), dimension (:,:), intent ( in ), & optional , target :: col_dry ! Column dry amount; dim(ncol,nlay) ! ---------------------------------------------------------- ! Local variables real ( wp ), dimension ( ncol , nlay , ngpt ) :: tau , tau_rayleigh ! absorption, Rayleigh scattering optical depths ! Number of molecules per cm^2 real ( wp ), dimension ( ncol , nlay ), target :: col_dry_arr real ( wp ), dimension (:,:), pointer :: col_dry_wk ! ! Interpolation variables used in major gas but not elsewhere, so don't need exporting ! real ( wp ), dimension ( ncol , nlay , this % get_ngas ()) :: vmr ! volume mixing ratios real ( wp ), dimension ( ncol , nlay , 0 : this % get_ngas ()) :: col_gas ! column amounts for each gas, plus col_dry real ( wp ), dimension ( 2 , ncol , nlay , get_nflav ( this )) :: col_mix ! combination of major species's column amounts ! index(1) : reference temperature level ! index(2) : flavor ! index(3) : layer real ( wp ), dimension ( 2 , 2 , ncol , nlay , get_nflav ( this )) :: fminor ! interpolation fractions for minor species ! index(1) : reference eta level (temperature dependent) ! index(2) : reference temperature level ! index(3) : flavor ! index(4) : layer integer :: ngas , nflav , neta , npres , ntemp integer :: icol , ilay , igas integer :: idx_h2o ! index of water vapor integer :: nminorlower , nminorklower , nminorupper , nminorkupper logical :: use_rayl ! ---------------------------------------------------------- ! ! Error checking ! use_rayl = allocated ( this % krayl ) error_msg = '' ! Check for initialization if (. not . this % is_loaded ()) then error_msg = 'ERROR: spectral configuration not loaded' return end if ! ! Check for presence of key species in ty_gas_concs; return error if any key species are not present ! error_msg = this % check_key_species_present ( gas_desc ) if ( error_msg /= '' ) return ! ! Check input data sizes and values ! !$acc data copyin(play,plev,tlay) create( vmr,col_gas) !$omp target data map(to:play,plev,tlay) map(alloc:vmr,col_gas) if ( check_extents ) then if (. not . extents_are ( play , ncol , nlay )) & error_msg = \"gas_optics(): array play has wrong size\" if (. not . extents_are ( tlay , ncol , nlay )) & error_msg = \"gas_optics(): array tlay has wrong size\" if (. not . extents_are ( plev , ncol , nlay + 1 )) & error_msg = \"gas_optics(): array plev has wrong size\" if ( optical_props % get_ncol () /= ncol . or . & optical_props % get_nlay () /= nlay . or . & optical_props % get_ngpt () /= ngpt ) & error_msg = \"gas_optics(): optical properties have the wrong extents\" if ( present ( col_dry )) then if (. not . extents_are ( col_dry , ncol , nlay )) & error_msg = \"gas_optics(): array col_dry has wrong size\" end if end if if ( error_msg == '' ) then if ( check_values ) then if ( any_vals_outside ( play , this % press_ref_min , this % press_ref_max )) & error_msg = \"gas_optics(): array play has values outside range\" if ( any_vals_less_than ( plev , 0._wp )) & error_msg = \"gas_optics(): array plev has values outside range\" if ( any_vals_outside ( tlay , this % temp_ref_min , this % temp_ref_max )) & error_msg = \"gas_optics(): array tlay has values outside range\" if ( present ( col_dry )) then if ( any_vals_less_than ( col_dry , 0._wp )) & error_msg = \"gas_optics(): array col_dry has values outside range\" end if end if end if ! ---------------------------------------------------------- if ( error_msg == '' ) then ngas = this % get_ngas () nflav = get_nflav ( this ) neta = this % get_neta () npres = this % get_npres () ntemp = this % get_ntemp () ! number of minor contributors, total num absorption coeffs nminorlower = size ( this % minor_scales_with_density_lower ) nminorklower = size ( this % kminor_lower , 3 ) nminorupper = size ( this % minor_scales_with_density_upper ) nminorkupper = size ( this % kminor_upper , 3 ) ! ! Fill out the array of volume mixing ratios ! do igas = 1 , ngas ! ! Get vmr if gas is provided in ty_gas_concs ! if ( any ( lower_case ( this % gas_names ( igas )) == gas_desc % get_gas_names ())) then error_msg = gas_desc % get_vmr ( this % gas_names ( igas ), vmr (:,:, igas )) endif end do end if if ( error_msg == '' ) then ! ! Painful hacks to get code to compile with both the CCE-14 and Nvidia 21.3 compiler ! #ifdef _CRAYFTN !$acc enter data copyin(optical_props) #endif select type ( optical_props ) type is ( ty_optical_props_1scl ) #ifndef _CRAYFTN !$acc enter data copyin(optical_props) #endif !$acc enter data create( optical_props%tau) !$omp target enter data map(alloc:optical_props%tau) type is ( ty_optical_props_2str ) #ifndef _CRAYFTN !$acc enter data copyin(optical_props) #endif !$acc enter data create( optical_props%tau, optical_props%ssa, optical_props%g) !$omp target enter data map(alloc:optical_props%tau, optical_props%ssa, optical_props%g) type is ( ty_optical_props_nstr ) #ifndef _CRAYFTN !$acc enter data copyin(optical_props) #endif !$acc enter data create( optical_props%tau, optical_props%ssa, optical_props%p) !$omp target enter data map(alloc:optical_props%tau, optical_props%ssa, optical_props%p) end select ! ! Compute dry air column amounts (number of molecule per cm^2) if user hasn't provided them ! idx_h2o = string_loc_in_array ( 'h2o' , this % gas_names ) if ( present ( col_dry )) then !$acc enter data copyin(col_dry) !$omp target enter data map(to:col_dry) col_dry_wk => col_dry else !$acc enter data create( col_dry_arr) !$omp target enter data map(alloc:col_dry_arr) col_dry_arr = get_col_dry ( vmr (:,:, idx_h2o ), plev ) ! dry air column amounts computation col_dry_wk => col_dry_arr end if ! ! compute column gas amounts [molec/cm^2] ! !$acc parallel loop gang vector collapse(2) !$omp target teams distribute parallel do simd collapse(2) do ilay = 1 , nlay do icol = 1 , ncol col_gas ( icol , ilay , 0 ) = col_dry_wk ( icol , ilay ) end do end do !$acc parallel loop gang vector collapse(3) !$omp target teams distribute parallel do simd collapse(3) do igas = 1 , ngas do ilay = 1 , nlay do icol = 1 , ncol col_gas ( icol , ilay , igas ) = vmr ( icol , ilay , igas ) * col_dry_wk ( icol , ilay ) end do end do end do ! ! ---- calculate gas optical depths ---- ! !$acc data copyout( jtemp, jpress, jeta, tropo, fmajor) create( col_mix, fminor) !$omp target data map(from:jtemp, jpress, jeta, tropo, fmajor) map(alloc:col_mix, fminor) call interpolation ( & ncol , nlay , & ! problem dimensions ngas , nflav , neta , npres , ntemp , & ! interpolation dimensions this % flavor , & this % press_ref_log , & this % temp_ref , & this % press_ref_log_delta , & this % temp_ref_min , & this % temp_ref_delta , & this % press_ref_trop_log , & this % vmr_ref , & play , & tlay , & col_gas , & jtemp , & ! outputs fmajor , fminor ,& col_mix , & tropo , & jeta , jpress ) if ( allocated ( this % krayl )) then !$acc data copyin(this%gpoint_flavor, this%krayl) create(tau, tau_rayleigh) !$omp target data map(to:this%gpoint_flavor, this%krayl) map(alloc:tau, tau_rayleigh) call zero_array ( ncol , nlay , ngpt , tau ) call compute_tau_absorption ( & ncol , nlay , nband , ngpt , & ! dimensions ngas , nflav , neta , npres , ntemp , & nminorlower , nminorklower , & ! number of minor contributors, total num absorption coeffs nminorupper , nminorkupper , & idx_h2o , & this % gpoint_flavor , & this % get_band_lims_gpoint (), & this % kmajor , & this % kminor_lower , & this % kminor_upper , & this % minor_limits_gpt_lower , & this % minor_limits_gpt_upper , & this % minor_scales_with_density_lower , & this % minor_scales_with_density_upper , & this % scale_by_complement_lower , & this % scale_by_complement_upper , & this % idx_minor_lower , & this % idx_minor_upper , & this % idx_minor_scaling_lower , & this % idx_minor_scaling_upper , & this % kminor_start_lower , & this % kminor_start_upper , & tropo , & col_mix , fmajor , fminor , & play , tlay , col_gas , & jeta , jtemp , jpress , & tau ) call compute_tau_rayleigh ( & !Rayleigh scattering optical depths ncol , nlay , nband , ngpt , & ngas , nflav , neta , npres , ntemp , & ! dimensions this % gpoint_flavor , & this % get_band_lims_gpoint (), & this % krayl , & ! inputs from object idx_h2o , col_dry_wk , col_gas , & fminor , jeta , tropo , jtemp , & ! local input tau_rayleigh ) call combine_abs_and_rayleigh ( tau , tau_rayleigh , optical_props ) !$acc end data !$omp end target data else call zero_array ( ncol , nlay , ngpt , optical_props % tau ) call compute_tau_absorption ( & ncol , nlay , nband , ngpt , & ! dimensions ngas , nflav , neta , npres , ntemp , & nminorlower , nminorklower , & ! number of minor contributors, total num absorption coeffs nminorupper , nminorkupper , & idx_h2o , & this % gpoint_flavor , & this % get_band_lims_gpoint (), & this % kmajor , & this % kminor_lower , & this % kminor_upper , & this % minor_limits_gpt_lower , & this % minor_limits_gpt_upper , & this % minor_scales_with_density_lower , & this % minor_scales_with_density_upper , & this % scale_by_complement_lower , & this % scale_by_complement_upper , & this % idx_minor_lower , & this % idx_minor_upper , & this % idx_minor_scaling_lower , & this % idx_minor_scaling_upper , & this % kminor_start_lower , & this % kminor_start_upper , & tropo , & col_mix , fmajor , fminor , & play , tlay , col_gas , & jeta , jtemp , jpress , & optical_props % tau ) ! select type ( optical_props ) type is ( ty_optical_props_2str ) call zero_array ( ncol , nlay , ngpt , optical_props % ssa ) call zero_array ( ncol , nlay , ngpt , optical_props % g ) type is ( ty_optical_props_nstr ) call zero_array ( ncol , nlay , ngpt , optical_props % ssa ) call zero_array ( optical_props % get_nmom (), & ncol , nlay , ngpt , optical_props % p ) end select end if !$acc end data !$omp end target data if ( present ( col_dry )) then !$acc exit data delete( col_dry) !$omp target exit data map(release:col_dry) else !$acc exit data delete( col_dry_arr) !$omp target exit data map(release:col_dry_arr) end if select type ( optical_props ) type is ( ty_optical_props_1scl ) !$acc exit data copyout( optical_props%tau) !$omp target exit data map(from:optical_props%tau) type is ( ty_optical_props_2str ) !$acc exit data copyout( optical_props%tau, optical_props%ssa, optical_props%g) !$omp target exit data map(from:optical_props%tau, optical_props%ssa, optical_props%g) type is ( ty_optical_props_nstr ) !$acc exit data copyout( optical_props%tau, optical_props%ssa, optical_props%p) !$omp target exit data map(from:optical_props%tau, optical_props%ssa, optical_props%p) end select !$acc exit data delete(optical_props) end if !$acc end data !$omp end target data end function compute_gas_taus !------------------------------------------------------------------------------------------ ! !> Compute the spectral solar source function adjusted to account for solar variability !> following the NRLSSI2 model of Coddington et al. 2016, doi:10.1175/BAMS-D-14-00265.1. !> as specified by the facular brightening (mg_index) and sunspot dimming (sb_index) !> indices provided as input. !> !> Users provide the NRLSSI2 facular (\"Bremen\") index and sunspot (\"SPOT67\") index. !> Changing either of these indicies will change the total solar irradiance (TSI) !> Code in extensions/mo_solar_variability may be used to compute the value of these !> indices through an average solar cycle !> Users may also specify the TSI, either alone or in conjunction with the facular and sunspot indices ! !------------------------------------------------------------------------------------------ function set_solar_variability ( this , & mg_index , sb_index , tsi ) & result ( error_msg ) ! !! Updates the spectral distribution and, optionally, !! the integrated value of the solar source function !! Modifying either index will change the total solar irradiance ! class ( ty_gas_optics_rrtmgp ), intent ( inout ) :: this ! real ( wp ), intent ( in ) :: mg_index !! facular brightening index (NRLSSI2 facular \"Bremen\" index) real ( wp ), intent ( in ) :: sb_index !! sunspot dimming index (NRLSSI2 sunspot \"SPOT67\" index) real ( wp ), optional , intent ( in ) :: tsi !! total solar irradiance character ( len = 128 ) :: error_msg !! Empty if successful ! ---------------------------------------------------------- integer :: igpt real ( wp ), parameter :: a_offset = 0.1495954_wp real ( wp ), parameter :: b_offset = 0.00066696_wp ! ---------------------------------------------------------- error_msg = \"\" if ( mg_index < 0._wp ) error_msg = 'mg_index out of range' if ( sb_index < 0._wp ) error_msg = 'sb_index out of range' if ( error_msg /= \"\" ) return ! ! Calculate solar source function for provided facular and sunspot indices ! !$acc parallel loop !$omp target teams distribute parallel do simd do igpt = 1 , size ( this % solar_source_quiet ) this % solar_source ( igpt ) = this % solar_source_quiet ( igpt ) + & ( mg_index - a_offset ) * this % solar_source_facular ( igpt ) + & ( sb_index - b_offset ) * this % solar_source_sunspot ( igpt ) end do ! ! Scale solar source to input TSI value ! if ( present ( tsi )) error_msg = this % set_tsi ( tsi ) end function set_solar_variability !------------------------------------------------------------------------------------------ function set_tsi ( this , tsi ) result ( error_msg ) ! !> Scale the solar source function without changing the spectral distribution ! class ( ty_gas_optics_rrtmgp ), intent ( inout ) :: this real ( wp ), intent ( in ) :: tsi !! user-specified total solar irradiance; character ( len = 128 ) :: error_msg !! Empty if successful real ( wp ) :: norm ! ---------------------------------------------------------- error_msg = \"\" if ( tsi < 0._wp ) then error_msg = 'tsi out of range' else ! ! Scale the solar source function to the input tsi ! !$acc kernels !$omp target norm = 1._wp / sum ( this % solar_source (:)) this % solar_source (:) = this % solar_source (:) * tsi * norm !$acc end kernels !$omp end target end if end function set_tsi !------------------------------------------------------------------------------------------ ! ! Compute Planck source functions at layer centers and levels ! function source ( this , & ncol , nlay , nbnd , ngpt , & play , plev , tlay , tsfc , & jtemp , jpress , jeta , tropo , fmajor , & sources , & ! Planck sources tlev ) & ! optional input result ( error_msg ) ! inputs class ( ty_gas_optics_rrtmgp ), intent ( in ) :: this integer , intent ( in ) :: ncol , nlay , nbnd , ngpt real ( wp ), dimension ( ncol , nlay ), intent ( in ) :: play ! layer pressures [Pa, mb] real ( wp ), dimension ( ncol , nlay + 1 ), intent ( in ) :: plev ! level pressures [Pa, mb] real ( wp ), dimension ( ncol , nlay ), intent ( in ) :: tlay ! layer temperatures [K] real ( wp ), dimension ( ncol ), intent ( in ) :: tsfc ! surface skin temperatures [K] ! Interplation coefficients integer , dimension ( ncol , nlay ), intent ( in ) :: jtemp , jpress logical ( wl ), dimension ( ncol , nlay ), intent ( in ) :: tropo real ( wp ), dimension ( 2 , 2 , 2 , ncol , nlay , get_nflav ( this )), & intent ( in ) :: fmajor integer , dimension ( 2 , ncol , nlay , get_nflav ( this )), & intent ( in ) :: jeta class ( ty_source_func_lw ), intent ( inout ) :: sources real ( wp ), dimension ( ncol , nlay + 1 ), intent ( in ), & optional , target :: tlev ! level temperatures [K] character ( len = 128 ) :: error_msg ! ---------------------------------------------------------- logical ( wl ) :: top_at_1 integer :: icol , ilay ! Variables for temperature at layer edges [K] (ncol, nlay+1) real ( wp ), dimension ( ncol , nlay + 1 ), target :: tlev_arr real ( wp ), dimension (:,:), pointer :: tlev_wk ! ---------------------------------------------------------- error_msg = \"\" ! ! Source function needs temperature at interfaces/levels and at layer centers ! if ( present ( tlev )) then ! Users might have provided these tlev_wk => tlev else tlev_wk => tlev_arr ! ! Interpolate temperature to levels if not provided ! Interpolation and extrapolation at boundaries is weighted by pressure ! do icol = 1 , ncol tlev_arr ( icol , 1 ) = tlay ( icol , 1 ) & + ( plev ( icol , 1 ) - play ( icol , 1 )) * ( tlay ( icol , 2 ) - tlay ( icol , 1 )) & & / ( play ( icol , 2 ) - play ( icol , 1 )) end do do ilay = 2 , nlay do icol = 1 , ncol tlev_arr ( icol , ilay ) = ( play ( icol , ilay - 1 ) * tlay ( icol , ilay - 1 ) * ( plev ( icol , ilay ) - play ( icol , ilay )) & + play ( icol , ilay ) * tlay ( icol , ilay ) * ( play ( icol , ilay - 1 ) - plev ( icol , ilay ))) / & ( plev ( icol , ilay ) * ( play ( icol , ilay - 1 ) - play ( icol , ilay ))) end do end do do icol = 1 , ncol tlev_arr ( icol , nlay + 1 ) = tlay ( icol , nlay ) & + ( plev ( icol , nlay + 1 ) - play ( icol , nlay )) * ( tlay ( icol , nlay ) - tlay ( icol , nlay - 1 )) & / ( play ( icol , nlay ) - play ( icol , nlay - 1 )) end do end if !------------------------------------------------------------------- ! Compute internal (Planck) source functions at layers and levels, ! which depend on mapping from spectral space that creates k-distribution. !$acc data copyin(sources) copyout( sources%lay_source, sources%lev_source_inc, sources%lev_source_dec) & !$acc copyout( sources%sfc_source, sources%sfc_source_Jac) !$omp target data map(from:sources%lay_source, sources%lev_source_inc, sources%lev_source_dec) & !$omp map(from:sources%sfc_source, sources%sfc_source_Jac) !$acc kernels copyout(top_at_1) !$omp target map(from:top_at_1) top_at_1 = play ( 1 , 1 ) < play ( 1 , nlay ) !$acc end kernels !$omp end target call compute_Planck_source ( ncol , nlay , nbnd , ngpt , & get_nflav ( this ), this % get_neta (), this % get_npres (), this % get_ntemp (), this % get_nPlanckTemp (), & tlay , tlev_wk , tsfc , merge ( nlay , 1 , top_at_1 ), & fmajor , jeta , tropo , jtemp , jpress , & this % get_gpoint_bands (), this % get_band_lims_gpoint (), this % planck_frac , this % temp_ref_min ,& this % totplnk_delta , this % totplnk , this % gpoint_flavor , & sources % sfc_source , sources % lay_source , sources % lev_source_inc , sources % lev_source_dec , & sources % sfc_source_Jac ) !$acc end data !$omp end target data end function source !-------------------------------------------------------------------------------------------------------------------- ! ! Initialization ! !-------------------------------------------------------------------------------------------------------------------- ! Initialize object based on data read from netCDF file however the user desires. ! Rayleigh scattering tables may or may not be present; this is indicated with allocation status ! This interface is for the internal-sources object -- includes Plank functions and fractions ! function load_int ( this , available_gases , gas_names , key_species , & band2gpt , band_lims_wavenum , & press_ref , press_ref_trop , temp_ref , & temp_ref_p , temp_ref_t , vmr_ref , & kmajor , kminor_lower , kminor_upper , & gas_minor , identifier_minor , & minor_gases_lower , minor_gases_upper , & minor_limits_gpt_lower , minor_limits_gpt_upper , & minor_scales_with_density_lower , & minor_scales_with_density_upper , & scaling_gas_lower , scaling_gas_upper , & scale_by_complement_lower , & scale_by_complement_upper , & kminor_start_lower , & kminor_start_upper , & totplnk , planck_frac , & rayl_lower , rayl_upper , & optimal_angle_fit ) result ( err_message ) class ( ty_gas_optics_rrtmgp ), intent ( inout ) :: this class ( ty_gas_concs ), intent ( in ) :: available_gases ! Which gases does the host model have available? character ( len =* ), dimension (:), intent ( in ) :: gas_names integer , dimension (:,:,:), intent ( in ) :: key_species integer , dimension (:,:), intent ( in ) :: band2gpt real ( wp ), dimension (:,:), intent ( in ) :: band_lims_wavenum real ( wp ), dimension (:), intent ( in ) :: press_ref , temp_ref real ( wp ), intent ( in ) :: press_ref_trop , temp_ref_p , temp_ref_t real ( wp ), dimension (:,:,:), intent ( in ) :: vmr_ref real ( wp ), dimension (:,:,:,:), intent ( in ) :: kmajor real ( wp ), dimension (:,:,:), intent ( in ) :: kminor_lower , kminor_upper real ( wp ), dimension (:,:), intent ( in ) :: totplnk real ( wp ), dimension (:,:,:,:), intent ( in ) :: planck_frac real ( wp ), dimension (:,:,:), intent ( in ), & allocatable :: rayl_lower , rayl_upper real ( wp ), dimension (:,:), intent ( in ) :: optimal_angle_fit character ( len =* ), dimension (:), intent ( in ) :: gas_minor , identifier_minor character ( len =* ), dimension (:), intent ( in ) :: minor_gases_lower , & minor_gases_upper integer , dimension (:,:), intent ( in ) :: minor_limits_gpt_lower , & minor_limits_gpt_upper logical ( wl ), dimension (:), intent ( in ) :: minor_scales_with_density_lower , & minor_scales_with_density_upper character ( len =* ), dimension (:), intent ( in ) :: scaling_gas_lower , & scaling_gas_upper logical ( wl ), dimension (:), intent ( in ) :: scale_by_complement_lower ,& scale_by_complement_upper integer , dimension (:), intent ( in ) :: kminor_start_lower ,& kminor_start_upper character ( len = 128 ) :: err_message ! ---- !$acc enter data copyin(this) call this % finalize () err_message = init_abs_coeffs ( this , & available_gases , & gas_names , key_species , & band2gpt , band_lims_wavenum , & press_ref , temp_ref , & press_ref_trop , temp_ref_p , temp_ref_t , & vmr_ref , & kmajor , kminor_lower , kminor_upper , & gas_minor , identifier_minor ,& minor_gases_lower , minor_gases_upper , & minor_limits_gpt_lower , & minor_limits_gpt_upper , & minor_scales_with_density_lower , & minor_scales_with_density_upper , & scaling_gas_lower , scaling_gas_upper , & scale_by_complement_lower , & scale_by_complement_upper , & kminor_start_lower , & kminor_start_upper , & rayl_lower , rayl_upper ) ! Planck function tables ! allocate ( this % totplnk ( size ( totplnk , 1 ), size ( totplnk , 2 )), & this % planck_frac ( size ( planck_frac , 4 ), size ( planck_frac , 2 ), size ( planck_frac , 3 ), size ( planck_frac , 1 )), & this % optimal_angle_fit ( size ( optimal_angle_fit , 1 ), size ( optimal_angle_fit , 2 ))) this % totplnk = totplnk ! this%planck_frac = planck_frac this % planck_frac = RESHAPE ( planck_frac ,( / size ( planck_frac , 4 ), size ( planck_frac , 2 ), & size ( planck_frac , 3 ), size ( planck_frac , 1 ) / ), ORDER = ( / 4 , 2 , 3 , 1 / )) this % optimal_angle_fit = optimal_angle_fit !$acc enter data copyin(this%totplnk, this%planck_frac, this%optimal_angle_fit) !$omp target enter data map(to:this%totplnk, this%planck_frac, this%optimal_angle_fit) ! Temperature steps for Planck function interpolation ! Assumes that temperature minimum and max are the same for the absorption coefficient grid and the ! Planck grid and the Planck grid is equally spaced this % totplnk_delta = ( this % temp_ref_max - this % temp_ref_min ) / ( size ( this % totplnk , dim = 1 ) - 1 ) end function load_int !-------------------------------------------------------------------------------------------------------------------- ! ! Initialize object based on data read from netCDF file however the user desires. ! Rayleigh scattering tables may or may not be present; this is indicated with allocation status ! This interface is for the external-sources object -- includes TOA source function table ! function load_ext ( this , available_gases , gas_names , key_species , & band2gpt , band_lims_wavenum , & press_ref , press_ref_trop , temp_ref , & temp_ref_p , temp_ref_t , vmr_ref , & kmajor , kminor_lower , kminor_upper , & gas_minor , identifier_minor , & minor_gases_lower , minor_gases_upper , & minor_limits_gpt_lower , minor_limits_gpt_upper , & minor_scales_with_density_lower , & minor_scales_with_density_upper , & scaling_gas_lower , scaling_gas_upper , & scale_by_complement_lower , & scale_by_complement_upper , & kminor_start_lower , & kminor_start_upper , & solar_quiet , solar_facular , solar_sunspot , & tsi_default , mg_default , sb_default , & rayl_lower , rayl_upper ) result ( err_message ) class ( ty_gas_optics_rrtmgp ), intent ( inout ) :: this class ( ty_gas_concs ), intent ( in ) :: available_gases ! Which gases does the host model have available? character ( len =* ), & dimension (:), intent ( in ) :: gas_names integer , dimension (:,:,:), intent ( in ) :: key_species integer , dimension (:,:), intent ( in ) :: band2gpt real ( wp ), dimension (:,:), intent ( in ) :: band_lims_wavenum real ( wp ), dimension (:), intent ( in ) :: press_ref , temp_ref real ( wp ), intent ( in ) :: press_ref_trop , temp_ref_p , temp_ref_t real ( wp ), dimension (:,:,:), intent ( in ) :: vmr_ref real ( wp ), dimension (:,:,:,:), intent ( in ) :: kmajor real ( wp ), dimension (:,:,:), intent ( in ) :: kminor_lower , kminor_upper character ( len =* ), dimension (:), & intent ( in ) :: gas_minor , & identifier_minor character ( len =* ), dimension (:), & intent ( in ) :: minor_gases_lower , & minor_gases_upper integer , dimension (:,:), intent ( in ) :: & minor_limits_gpt_lower , & minor_limits_gpt_upper logical ( wl ), dimension (:), intent ( in ) :: & minor_scales_with_density_lower , & minor_scales_with_density_upper character ( len =* ), dimension (:), intent ( in ) :: & scaling_gas_lower , & scaling_gas_upper logical ( wl ), dimension (:), intent ( in ) :: & scale_by_complement_lower , & scale_by_complement_upper integer , dimension (:), intent ( in ) :: & kminor_start_lower , & kminor_start_upper real ( wp ), dimension (:), intent ( in ) :: solar_quiet , & solar_facular , & solar_sunspot real ( wp ), intent ( in ) :: tsi_default , & mg_default , sb_default real ( wp ), dimension (:,:,:), intent ( in ), & allocatable :: rayl_lower , rayl_upper character ( len = 128 ) err_message integer :: ngpt ! ---- !$acc enter data copyin(this) call this % finalize () err_message = init_abs_coeffs ( this , & available_gases , & gas_names , key_species , & band2gpt , band_lims_wavenum , & press_ref , temp_ref , & press_ref_trop , temp_ref_p , temp_ref_t , & vmr_ref , & kmajor , kminor_lower , kminor_upper , & gas_minor , identifier_minor , & minor_gases_lower , minor_gases_upper , & minor_limits_gpt_lower , & minor_limits_gpt_upper , & minor_scales_with_density_lower , & minor_scales_with_density_upper , & scaling_gas_lower , scaling_gas_upper , & scale_by_complement_lower , & scale_by_complement_upper , & kminor_start_lower , & kminor_start_upper , & rayl_lower , rayl_upper ) if ( err_message == \"\" ) then ! ! Spectral solar irradiance terms init ! ngpt = size ( solar_quiet ) allocate ( this % solar_source_quiet ( ngpt ), this % solar_source_facular ( ngpt ), & this % solar_source_sunspot ( ngpt ), this % solar_source ( ngpt )) !$acc enter data create( this%solar_source_quiet, this%solar_source_facular, this%solar_source_sunspot, this%solar_source) !$omp target enter data map(alloc:this%solar_source_quiet, this%solar_source_facular, this%solar_source_sunspot, this%solar_source) !$acc kernels !$omp target this % solar_source_quiet = solar_quiet this % solar_source_facular = solar_facular this % solar_source_sunspot = solar_sunspot !$acc end kernels !$omp end target err_message = this % set_solar_variability ( mg_default , sb_default ) endif end function load_ext !-------------------------------------------------------------------------------------------------------------------- ! ! Initialize absorption coefficient arrays, ! including Rayleigh scattering tables if provided (allocated) ! function init_abs_coeffs ( this , & available_gases , & gas_names , key_species , & band2gpt , band_lims_wavenum , & press_ref , temp_ref , & press_ref_trop , temp_ref_p , temp_ref_t , & vmr_ref , & kmajor , kminor_lower , kminor_upper , & gas_minor , identifier_minor ,& minor_gases_lower , minor_gases_upper , & minor_limits_gpt_lower , & minor_limits_gpt_upper , & minor_scales_with_density_lower , & minor_scales_with_density_upper , & scaling_gas_lower , scaling_gas_upper , & scale_by_complement_lower , & scale_by_complement_upper , & kminor_start_lower , & kminor_start_upper , & rayl_lower , rayl_upper ) result ( err_message ) class ( ty_gas_optics_rrtmgp ), intent ( inout ) :: this class ( ty_gas_concs ), intent ( in ) :: available_gases character ( len =* ), & dimension (:), intent ( in ) :: gas_names integer , dimension (:,:,:), intent ( in ) :: key_species integer , dimension (:,:), intent ( in ) :: band2gpt real ( wp ), dimension (:,:), intent ( in ) :: band_lims_wavenum real ( wp ), dimension (:), intent ( in ) :: press_ref , temp_ref real ( wp ), intent ( in ) :: press_ref_trop , temp_ref_p , temp_ref_t real ( wp ), dimension (:,:,:), intent ( in ) :: vmr_ref real ( wp ), dimension (:,:,:,:), intent ( in ) :: kmajor real ( wp ), dimension (:,:,:), intent ( in ) :: kminor_lower , kminor_upper character ( len =* ), dimension (:), & intent ( in ) :: gas_minor , & identifier_minor character ( len =* ), dimension (:), & intent ( in ) :: minor_gases_lower , & minor_gases_upper integer , dimension (:,:), intent ( in ) :: minor_limits_gpt_lower , & minor_limits_gpt_upper logical ( wl ), dimension (:), intent ( in ) :: minor_scales_with_density_lower , & minor_scales_with_density_upper character ( len =* ), dimension (:),& intent ( in ) :: scaling_gas_lower , & scaling_gas_upper logical ( wl ), dimension (:), intent ( in ) :: scale_by_complement_lower , & scale_by_complement_upper integer , dimension (:), intent ( in ) :: kminor_start_lower , & kminor_start_upper real ( wp ), dimension (:,:,:), intent ( in ), & allocatable :: rayl_lower , rayl_upper character ( len = 128 ) :: err_message ! -------------------------------------------------------------------------- logical , dimension (:), allocatable :: gas_is_present logical , dimension (:), allocatable :: key_species_present_init integer , dimension (:,:,:), allocatable :: key_species_red real ( wp ), dimension (:,:,:), allocatable :: vmr_ref_red character ( len = 256 ), & dimension (:), allocatable :: minor_gases_lower_red , & minor_gases_upper_red character ( len = 256 ), & dimension (:), allocatable :: scaling_gas_lower_red , & scaling_gas_upper_red integer :: i , j , idx integer :: ngas ! -------------------------------------- err_message = this % ty_optical_props % init ( band_lims_wavenum , band2gpt ) if ( len_trim ( err_message ) /= 0 ) return ! ! Which gases known to the gas optics are present in the host model (available_gases)? ! ngas = size ( gas_names ) allocate ( gas_is_present ( ngas )) do i = 1 , ngas ! Next line causes a compiler bug in gfortran 11.0.1 on Mac ARM ! Should replace gas_names with get_gas_names() and make gas_names private in ty_gas_concs gas_is_present ( i ) = string_in_array ( gas_names ( i ), available_gases % gas_names ) end do ! ! Now the number of gases is the union of those known to the k-distribution and provided ! by the host model ! ngas = count ( gas_is_present ) ! ! Initialize the gas optics object, keeping only those gases known to the ! gas optics and also present in the host model ! this % gas_names = pack ( gas_names , mask = gas_is_present ) ! Copy-ins below allocate ( vmr_ref_red ( size ( vmr_ref , dim = 1 ), 0 : ngas , & size ( vmr_ref , dim = 3 ))) ! Gas 0 is used in single-key species method, set to 1.0 (col_dry) vmr_ref_red (:, 0 ,:) = vmr_ref (:, 1 ,:) do i = 1 , ngas idx = string_loc_in_array ( this % gas_names ( i ), gas_names ) vmr_ref_red (:, i ,:) = vmr_ref (:, idx + 1 ,:) enddo call move_alloc ( vmr_ref_red , this % vmr_ref ) !$acc enter data copyin(this%vmr_ref, this%gas_names) !$omp target enter data map(to:this%vmr_ref, this%gas_names) ! ! Reduce minor arrays so variables only contain minor gases that are available ! Reduce size of minor Arrays ! call reduce_minor_arrays ( available_gases , & gas_minor , identifier_minor , & kminor_lower , & minor_gases_lower , & minor_limits_gpt_lower , & minor_scales_with_density_lower , & scaling_gas_lower , & scale_by_complement_lower , & kminor_start_lower , & this % kminor_lower , & minor_gases_lower_red , & this % minor_limits_gpt_lower , & this % minor_scales_with_density_lower , & scaling_gas_lower_red , & this % scale_by_complement_lower , & this % kminor_start_lower ) call reduce_minor_arrays ( available_gases , & gas_minor , identifier_minor ,& kminor_upper , & minor_gases_upper , & minor_limits_gpt_upper , & minor_scales_with_density_upper , & scaling_gas_upper , & scale_by_complement_upper , & kminor_start_upper , & this % kminor_upper , & minor_gases_upper_red , & this % minor_limits_gpt_upper , & this % minor_scales_with_density_upper , & scaling_gas_upper_red , & this % scale_by_complement_upper , & this % kminor_start_upper ) !$acc enter data copyin(this%minor_limits_gpt_lower, this%minor_limits_gpt_upper) !$omp target enter data map(to:this%minor_limits_gpt_lower, this%minor_limits_gpt_upper) !$acc enter data copyin(this%minor_scales_with_density_lower, this%minor_scales_with_density_upper) !$omp target enter data map(to:this%minor_scales_with_density_lower, this%minor_scales_with_density_upper) !$acc enter data copyin(this%scale_by_complement_lower, this%scale_by_complement_upper) !$omp target enter data map(to:this%scale_by_complement_lower, this%scale_by_complement_upper) !$acc enter data copyin(this%kminor_start_lower, this%kminor_start_upper) !$omp target enter data map(to:this%kminor_start_lower, this%kminor_start_upper) !$acc enter data copyin(this%kminor_lower, this%kminor_upper) !$omp target enter data map(to:this%kminor_lower, this%kminor_upper) ! Arrays not reduced by the presence, or lack thereof, of a gas allocate ( this % press_ref ( size ( press_ref )), this % temp_ref ( size ( temp_ref )), & this % kmajor ( size ( kmajor , 4 ), size ( kmajor , 2 ), size ( kmajor , 3 ), size ( kmajor , 1 ))) this % press_ref (:) = press_ref (:) this % temp_ref (:) = temp_ref (:) this % kmajor = RESHAPE ( kmajor ,( / size ( kmajor , 4 ), size ( kmajor , 2 ), size ( kmajor , 3 ), size ( kmajor , 1 ) / ), ORDER = ( / 4 , 2 , 3 , 1 / )) !$acc enter data copyin(this%press_ref, this%temp_ref, this%kmajor) !$omp target enter data map(to:this%press_ref, this%temp_ref, this%kmajor) if ( allocated ( rayl_lower ) . neqv . allocated ( rayl_upper )) then err_message = \"rayl_lower and rayl_upper must have the same allocation status\" return end if if ( allocated ( rayl_lower )) then allocate ( this % krayl ( size ( rayl_lower , dim = 3 ), size ( rayl_lower , dim = 2 ), size ( rayl_lower , dim = 1 ), 2 )) this % krayl (:,:,:, 1 ) = RESHAPE ( rayl_lower ,( / size ( rayl_lower , dim = 3 ), size ( rayl_lower , dim = 2 ), & size ( rayl_lower , dim = 1 ) / ), ORDER = ( / 3 , 2 , 1 / )) this % krayl (:,:,:, 2 ) = RESHAPE ( rayl_upper ,( / size ( rayl_lower , dim = 3 ), size ( rayl_lower , dim = 2 ), & size ( rayl_lower , dim = 1 ) / ), ORDER = ( / 3 , 2 , 1 / )) !$acc enter data copyin(this%krayl) !$omp target enter data map(to:this%krayl) end if ! ---- post processing ---- ! creates log reference pressure allocate ( this % press_ref_log ( size ( this % press_ref ))) this % press_ref_log (:) = log ( this % press_ref (:)) !$acc enter data copyin(this%press_ref_log) !$omp target enter data map(to:this%press_ref_log) ! log scale of reference pressure this % press_ref_trop_log = log ( press_ref_trop ) ! Get index of gas (if present) for determining col_gas call create_idx_minor ( this % gas_names , gas_minor , identifier_minor , minor_gases_lower_red , this % idx_minor_lower ) call create_idx_minor ( this % gas_names , gas_minor , identifier_minor , minor_gases_upper_red , this % idx_minor_upper ) ! Get index of gas (if present) that has special treatment in density scaling call create_idx_minor_scaling ( this % gas_names , scaling_gas_lower_red , this % idx_minor_scaling_lower ) call create_idx_minor_scaling ( this % gas_names , scaling_gas_upper_red , this % idx_minor_scaling_upper ) !$acc enter data copyin(this%idx_minor_lower, this%idx_minor_upper) !$omp target enter data map(to:this%idx_minor_lower, this%idx_minor_upper) !$acc enter data copyin(this%idx_minor_scaling_lower, this%idx_minor_scaling_upper) !$omp target enter data map(to:this%idx_minor_scaling_lower, this%idx_minor_scaling_upper) ! create flavor list ! Reduce (remap) key_species list; checks that all key gases are present in incoming call create_key_species_reduce ( gas_names , this % gas_names , & key_species , key_species_red , key_species_present_init ) err_message = check_key_species_present_init ( gas_names , key_species_present_init ) if ( len_trim ( err_message ) /= 0 ) return ! create flavor list call create_flavor ( key_species_red , this % flavor ) ! create gpoint_flavor list call create_gpoint_flavor ( key_species_red , this % get_gpoint_bands (), this % flavor , this % gpoint_flavor ) !Copy-ins at end of subroutine ! minimum, maximum reference temperature, pressure -- assumes low-to-high ordering ! for T, high-to-low ordering for p this % temp_ref_min = this % temp_ref ( 1 ) this % temp_ref_max = this % temp_ref ( size ( this % temp_ref )) this % press_ref_min = this % press_ref ( size ( this % press_ref )) this % press_ref_max = this % press_ref ( 1 ) ! creates press_ref_log, temp_ref_delta this % press_ref_log_delta = ( log ( this % press_ref_min ) - log ( this % press_ref_max )) / ( size ( this % press_ref ) - 1 ) this % temp_ref_delta = ( this % temp_ref_max - this % temp_ref_min ) / ( size ( this % temp_ref ) - 1 ) ! Which species are key in one or more bands? ! this%flavor is an index into this%gas_names ! if ( allocated ( this % is_key )) deallocate ( this % is_key ) ! Shouldn't ever happen... allocate ( this % is_key ( this % get_ngas ())) this % is_key (:) = . False . do j = 1 , size ( this % flavor , 2 ) do i = 1 , size ( this % flavor , 1 ) ! extents should be 2 if ( this % flavor ( i , j ) /= 0 ) this % is_key ( this % flavor ( i , j )) = . true . end do end do !$acc enter data copyin(this%flavor, this%gpoint_flavor, this%is_key) !$omp target enter data map(to:this%flavor, this%gpoint_flavor, this%is_key) end function init_abs_coeffs ! ---------------------------------------------------------------------------------------------------- function check_key_species_present_init ( gas_names , key_species_present_init ) result ( err_message ) logical , dimension (:), intent ( in ) :: key_species_present_init character ( len =* ), dimension (:), intent ( in ) :: gas_names character ( len = 128 ) :: err_message integer :: i err_message = '' do i = 1 , size ( key_species_present_init ) if (. not . key_species_present_init ( i )) & err_message = ' ' // trim ( gas_names ( i )) // trim ( err_message ) end do if ( len_trim ( err_message ) > 0 ) err_message = \"gas_optics: required gases\" // trim ( err_message ) // \" are not provided\" end function check_key_species_present_init !------------------------------------------------------------------------------------------ ! ! Ensure that every key gas required by the k-distribution is ! present in the gas concentration object ! function check_key_species_present ( this , gas_desc ) result ( error_msg ) class ( ty_gas_optics_rrtmgp ), intent ( in ) :: this class ( ty_gas_concs ), intent ( in ) :: gas_desc character ( len = 128 ) :: error_msg ! Local variables character ( len = 32 ), dimension ( count ( this % is_key (:) )) :: key_gas_names integer :: igas ! -------------------------------------- error_msg = \"\" key_gas_names = pack ( this % gas_names , mask = this % is_key ) do igas = 1 , size ( key_gas_names ) ! Next line causes a compiler bug in gfortran 11.0.1 on Mac ARM ! Should replace gas_names with get_gas_names() and make gas_names private in ty_gas_concs if (. not . string_in_array ( key_gas_names ( igas ), gas_desc % gas_names )) & error_msg = ' ' // trim ( lower_case ( key_gas_names ( igas ))) // trim ( error_msg ) end do if ( len_trim ( error_msg ) > 0 ) error_msg = \"gas_optics: required gases\" // trim ( error_msg ) // \" are not provided\" end function check_key_species_present !-------------------------------------------------------------------------------------------------------------------- ! ! Inquiry functions ! !-------------------------------------------------------------------------------------------------------------------- ! !> return true if initialized for internal sources/longwave, false otherwise ! pure function source_is_internal ( this ) class ( ty_gas_optics_rrtmgp ), intent ( in ) :: this logical :: source_is_internal source_is_internal = allocated ( this % totplnk ) . and . allocated ( this % planck_frac ) end function source_is_internal !-------------------------------------------------------------------------------------------------------------------- ! !> return true if initialized for external sources/shortwave, false otherwise ! pure function source_is_external ( this ) class ( ty_gas_optics_rrtmgp ), intent ( in ) :: this logical :: source_is_external source_is_external = allocated ( this % solar_source ) end function source_is_external !-------------------------------------------------------------------------------------------------------------------- ! !> return the names of the gases known to the k-distributions ! pure function get_gases ( this ) class ( ty_gas_optics_rrtmgp ), intent ( in ) :: this character ( 32 ), dimension ( get_ngas ( this )) :: get_gases !! names of the gases known to the k-distributions get_gases = this % gas_names end function get_gases !-------------------------------------------------------------------------------------------------------------------- ! !> return the minimum pressure on the interpolation grids ! pure function get_press_min ( this ) class ( ty_gas_optics_rrtmgp ), intent ( in ) :: this real ( wp ) :: get_press_min !! minimum pressure for which the k-dsitribution is valid get_press_min = this % press_ref_min end function get_press_min !-------------------------------------------------------------------------------------------------------------------- ! !> return the maximum pressure on the interpolation grids ! pure function get_press_max ( this ) class ( ty_gas_optics_rrtmgp ), intent ( in ) :: this real ( wp ) :: get_press_max !! maximum pressure for which the k-dsitribution is valid get_press_max = this % press_ref_max end function get_press_max !-------------------------------------------------------------------------------------------------------------------- ! !> return the minimum temparature on the interpolation grids ! pure function get_temp_min ( this ) class ( ty_gas_optics_rrtmgp ), intent ( in ) :: this real ( wp ) :: get_temp_min !! minimum temperature for which the k-dsitribution is valid get_temp_min = this % temp_ref_min end function get_temp_min !-------------------------------------------------------------------------------------------------------------------- ! !> return the maximum temparature on the interpolation grids ! pure function get_temp_max ( this ) class ( ty_gas_optics_rrtmgp ), intent ( in ) :: this real ( wp ) :: get_temp_max !! maximum temperature for which the k-dsitribution is valid get_temp_max = this % temp_ref_max end function get_temp_max !-------------------------------------------------------------------------------------------------------------------- ! !> Utility function, provided for user convenience !> computes column amounts of dry air using hydrostatic equation ! function get_col_dry ( vmr_h2o , plev , latitude ) result ( col_dry ) ! input real ( wp ), dimension (:,:), intent ( in ) :: vmr_h2o ! volume mixing ratio of water vapor to dry air; (ncol,nlay) real ( wp ), dimension (:,:), intent ( in ) :: plev ! Layer boundary pressures [Pa] (ncol,nlay+1) real ( wp ), dimension (:), optional , & intent ( in ) :: latitude ! Latitude [degrees] (ncol) ! output real ( wp ), dimension ( size ( plev , dim = 1 ), size ( plev , dim = 2 ) - 1 ) :: col_dry ! Column dry amount (ncol,nlay) ! ------------------------------------------------ ! first and second term of Helmert formula real ( wp ), parameter :: helmert1 = 9.80665_wp real ( wp ), parameter :: helmert2 = 0.02586_wp ! local variables real ( wp ), dimension ( size ( plev , dim = 1 )) :: g0 ! (ncol) real ( wp ) :: delta_plev , m_air , fact integer :: ncol , nlev integer :: icol , ilev ! nlay = nlev-1 ! ------------------------------------------------ ncol = size ( plev , dim = 1 ) nlev = size ( plev , dim = 2 ) !$acc data create(g0) !$omp target data map(alloc:g0) if ( present ( latitude )) then ! A purely OpenACC implementation would probably compute g0 within the kernel below !$acc parallel loop !$omp target teams distribute parallel do simd do icol = 1 , ncol g0 ( icol ) = helmert1 - helmert2 * cos ( 2.0_wp * pi * latitude ( icol ) / 18 0.0_wp ) ! acceleration due to gravity [m/s^2] end do else !$acc parallel loop !$omp target teams distribute parallel do simd do icol = 1 , ncol g0 ( icol ) = grav end do end if !$acc parallel loop gang vector collapse(2) copyin(plev,vmr_h2o) copyout(col_dry) !$omp target teams distribute parallel do simd collapse(2) map(to:plev,vmr_h2o) map(from:col_dry) do ilev = 1 , nlev - 1 do icol = 1 , ncol delta_plev = abs ( plev ( icol , ilev ) - plev ( icol , ilev + 1 )) ! Get average mass of moist air per mole of moist air fact = 1._wp / ( 1. + vmr_h2o ( icol , ilev )) m_air = ( m_dry + m_h2o * vmr_h2o ( icol , ilev )) * fact col_dry ( icol , ilev ) = 1 0._wp * delta_plev * avogad * fact / ( 100 0._wp * m_air * 10 0._wp * g0 ( icol )) end do end do !$acc end data !$omp end target data end function get_col_dry !-------------------------------------------------------------------------------------------------------------------- ! !> Compute a transport angle that minimizes flux errors at surface and TOA based on empirical fits ! function compute_optimal_angles ( this , optical_props , optimal_angles ) result ( err_msg ) ! input class ( ty_gas_optics_rrtmgp ), intent ( in ) :: this class ( ty_optical_props_arry ), intent ( in ) :: optical_props !! Optical properties real ( wp ), dimension (:,:), intent ( out ) :: optimal_angles !! Secant of optical transport angle character ( len = 128 ) :: err_msg !! Empty if successful !---------------------------- integer :: ncol , nlay , ngpt integer :: icol , ilay , igpt , bnd real ( wp ) :: t , trans_total #if defined _CRAYFTN && _RELEASE_MAJOR == 14 && _RELEASE_MINOR == 0 && _RELEASE_PATCHLEVEL == 3 # define CRAY_WORKAROUND #endif #ifdef CRAY_WORKAROUND integer , allocatable :: bands (:) #else integer :: bands ( optical_props % get_ngpt ()) #endif !---------------------------- ncol = optical_props % get_ncol () nlay = optical_props % get_nlay () ngpt = optical_props % get_ngpt () #ifdef CRAY_WORKAROUND allocate ( bands ( ngpt ) ) ! In order to work with CCE 14 (it is also better software) #endif err_msg = \"\" if (. not . this % gpoints_are_equal ( optical_props )) & err_msg = \"gas_optics%compute_optimal_angles: optical_props has different spectral discretization than gas_optics\" if (. not . extents_are ( optimal_angles , ncol , ngpt )) & err_msg = \"gas_optics%compute_optimal_angles: optimal_angles different dimension (ncol)\" if ( err_msg /= \"\" ) return do igpt = 1 , ngpt bands ( igpt ) = optical_props % convert_gpt2band ( igpt ) enddo ! ! column transmissivity ! !$acc parallel loop gang vector collapse(2) copyin(bands, optical_props, optical_props%tau) copyout(optimal_angles) !$omp target teams distribute parallel do simd collapse(2) map(to:bands, optical_props%tau) map(from:optimal_angles) do icol = 1 , ncol do igpt = 1 , ngpt ! ! Column transmissivity ! t = 0._wp trans_total = 0._wp do ilay = 1 , nlay t = t + optical_props % tau ( icol , ilay , igpt ) end do trans_total = exp ( - t ) ! ! Optimal transport angle is a linear fit to column transmissivity ! optimal_angles ( icol , igpt ) = this % optimal_angle_fit ( 1 , bands ( igpt )) * trans_total + & this % optimal_angle_fit ( 2 , bands ( igpt )) end do end do end function compute_optimal_angles !-------------------------------------------------------------------------------------------------------------------- ! ! Internal procedures ! !-------------------------------------------------------------------------------------------------------------------- pure function rewrite_key_species_pair ( key_species_pair ) ! (0,0) becomes (2,2) -- because absorption coefficients for these g-points will be 0. integer , dimension ( 2 ) :: rewrite_key_species_pair integer , dimension ( 2 ), intent ( in ) :: key_species_pair rewrite_key_species_pair = key_species_pair if ( all ( key_species_pair (:). eq .( / 0 , 0 / ))) then rewrite_key_species_pair (:) = ( / 2 , 2 / ) end if end function ! --------------------------------------------------------------------------------------- ! true is key_species_pair exists in key_species_list pure function key_species_pair_exists ( key_species_list , key_species_pair ) logical :: key_species_pair_exists integer , dimension (:,:), intent ( in ) :: key_species_list integer , dimension ( 2 ), intent ( in ) :: key_species_pair integer :: i do i = 1 , size ( key_species_list , dim = 2 ) if ( all ( key_species_list (:, i ). eq . key_species_pair (:))) then key_species_pair_exists = . true . return end if end do key_species_pair_exists = . false . end function key_species_pair_exists ! --------------------------------------------------------------------------------------- ! create flavor list -- ! an unordered array of extent (2,:) containing all possible pairs of key species ! used in either upper or lower atmos ! subroutine create_flavor ( key_species , flavor ) integer , dimension (:,:,:), intent ( in ) :: key_species integer , dimension (:,:), allocatable , intent ( out ) :: flavor integer , dimension ( 2 , size ( key_species , 3 ) * 2 ) :: key_species_list integer :: ibnd , iatm , i , iflavor ! prepare list of key_species i = 1 do ibnd = 1 , size ( key_species , 3 ) ! bands do iatm = 1 , size ( key_species , 2 ) ! upper/lower atmosphere key_species_list (:, i ) = key_species (:, iatm , ibnd ) i = i + 1 end do end do ! rewrite single key_species pairs do i = 1 , size ( key_species_list , 2 ) key_species_list (:, i ) = rewrite_key_species_pair ( key_species_list (:, i )) end do ! count unique key species pairs iflavor = 0 do i = 1 , size ( key_species_list , 2 ) if (. not . key_species_pair_exists ( key_species_list (:, 1 : i - 1 ), key_species_list (:, i ))) then iflavor = iflavor + 1 end if end do ! fill flavors allocate ( flavor ( 2 , iflavor )) iflavor = 0 do i = 1 , size ( key_species_list , 2 ) if (. not . key_species_pair_exists ( key_species_list (:, 1 : i - 1 ), key_species_list (:, i ))) then iflavor = iflavor + 1 flavor (:, iflavor ) = key_species_list (:, i ) end if end do end subroutine create_flavor ! --------------------------------------------------------------------------------------- ! ! create index list for extracting col_gas needed for minor gas optical depth calculations ! subroutine create_idx_minor ( gas_names , & gas_minor , identifier_minor , minor_gases_atm , idx_minor_atm ) character ( len =* ), dimension (:), intent ( in ) :: gas_names character ( len =* ), dimension (:), intent ( in ) :: & gas_minor , & identifier_minor character ( len =* ), dimension (:), intent ( in ) :: minor_gases_atm integer , dimension (:), allocatable , & intent ( out ) :: idx_minor_atm ! local integer :: imnr integer :: idx_mnr allocate ( idx_minor_atm ( size ( minor_gases_atm , dim = 1 ))) do imnr = 1 , size ( minor_gases_atm , dim = 1 ) ! loop over minor absorbers in each band ! Find identifying string for minor species in list of possible identifiers (e.g. h2o_slf) idx_mnr = string_loc_in_array ( minor_gases_atm ( imnr ), identifier_minor ) ! Find name of gas associated with minor species identifier (e.g. h2o) idx_minor_atm ( imnr ) = string_loc_in_array ( gas_minor ( idx_mnr ), gas_names ) enddo end subroutine create_idx_minor ! --------------------------------------------------------------------------------------- ! ! create index for special treatment in density scaling of minor gases ! subroutine create_idx_minor_scaling ( gas_names , & scaling_gas_atm , idx_minor_scaling_atm ) character ( len =* ), dimension (:), intent ( in ) :: gas_names character ( len =* ), dimension (:), intent ( in ) :: scaling_gas_atm integer , dimension (:), allocatable , & intent ( out ) :: idx_minor_scaling_atm ! local integer :: imnr allocate ( idx_minor_scaling_atm ( size ( scaling_gas_atm , dim = 1 ))) do imnr = 1 , size ( scaling_gas_atm , dim = 1 ) ! loop over minor absorbers in each band ! This will be -1 if there's no interacting gas idx_minor_scaling_atm ( imnr ) = string_loc_in_array ( scaling_gas_atm ( imnr ), gas_names ) enddo end subroutine create_idx_minor_scaling !-------------------------------------------------------------------------------------------------------------------- ! Is the object ready to use? ! pure function is_loaded ( this ) class ( ty_gas_optics_rrtmgp ), intent ( in ) :: this logical ( wl ) :: is_loaded is_loaded = allocated ( this % kmajor ) end function is_loaded !-------------------------------------------------------------------------------------------------------------------- ! ! Reset the object to un-initialized state ! subroutine finalize ( this ) class ( ty_gas_optics_rrtmgp ), intent ( inout ) :: this real ( wp ), dimension (:), allocatable :: press_ref , press_ref_log , temp_ref if ( this % is_loaded ()) then !$acc exit data delete(this%gas_names, this%vmr_ref, this%flavor) & !$acc delete(this%gpoint_flavor, this%kmajor) & !$acc delete(this%minor_limits_gpt_lower) & !$acc delete(this%minor_scales_with_density_lower, this%scale_by_complement_lower) & !$acc delete(this%idx_minor_lower, this%idx_minor_scaling_lower) & !$acc delete(this%kminor_start_lower, this%kminor_lower) & !$acc delete(this%minor_limits_gpt_upper) & !$acc delete(this%minor_scales_with_density_upper, this%scale_by_complement_upper) & !$acc delete(this%idx_minor_upper, this%idx_minor_scaling_upper) & !$acc delete(this%kminor_start_upper, this%kminor_upper) !$omp target exit data map(release:this%gas_names, this%vmr_ref, this%flavor) & !$omp map(release:this%gpoint_flavor, this%kmajor) & !$omp map(release:this%minor_limits_gpt_lower) & !$omp map(release:this%minor_scales_with_density_lower, this%scale_by_complement_lower) & !$omp map(release:this%idx_minor_lower, this%idx_minor_scaling_lower) & !$omp map(release:this%kminor_start_lower, this%kminor_lower) & !$omp map(release:this%minor_limits_gpt_upper) & !$omp map(release:this%minor_scales_with_density_upper, this%scale_by_complement_upper) & !$omp map(release:this%idx_minor_upper, this%idx_minor_scaling_upper) & !$omp map(release:this%kminor_start_upper, this%kminor_upper) deallocate ( this % gas_names , this % vmr_ref , this % flavor , this % gpoint_flavor , this % kmajor ) deallocate ( this % minor_limits_gpt_lower , & this % minor_scales_with_density_lower , this % scale_by_complement_lower , & this % idx_minor_lower , this % idx_minor_scaling_lower , this % kminor_start_lower , this % kminor_lower ) deallocate ( this % minor_limits_gpt_upper , & this % minor_scales_with_density_upper , this % scale_by_complement_upper , & this % idx_minor_upper , this % idx_minor_scaling_upper , this % kminor_start_upper , this % kminor_upper ) if ( allocated ( this % krayl )) then !$acc exit data delete(this%krayl) !$omp target exit data map(release:this%krayl) deallocate ( this % krayl ) end if if ( allocated ( this % planck_frac )) then !$acc exit data delete(this%planck_frac, this%totplnk, this%optimal_angle_fit) !$omp target exit data map(release:this%planck_frac, this%totplnk, this%optimal_angle_fit) deallocate ( this % planck_frac , this % totplnk , this % optimal_angle_fit ) end if if ( allocated ( this % solar_source )) then !$acc exit data delete(this%solar_source, this%solar_source_quiet) & !$acc delete(this%solar_source_facular,this%solar_source_sunspot) !$omp target exit data map(release:this%solar_source, this%solar_source_quiet) !$omp map(release:this%solar_source_facular,this%solar_source_sunspot) deallocate ( this % solar_source , & this % solar_source_quiet , this % solar_source_facular , this % solar_source_sunspot ) end if !$acc exit data delete(this) !$omp target exit data map(release:this) end if end subroutine finalize ! --------------------------------------------------------------------------------------- subroutine create_key_species_reduce ( gas_names , gas_names_red , & key_species , key_species_red , key_species_present_init ) character ( len =* ), & dimension (:), intent ( in ) :: gas_names character ( len =* ), & dimension (:), intent ( in ) :: gas_names_red integer , dimension (:,:,:), intent ( in ) :: key_species integer , dimension (:,:,:), allocatable , intent ( out ) :: key_species_red logical , dimension (:), allocatable , intent ( out ) :: key_species_present_init integer :: ip , ia , it , np , na , nt np = size ( key_species , dim = 1 ) na = size ( key_species , dim = 2 ) nt = size ( key_species , dim = 3 ) allocate ( key_species_red ( size ( key_species , dim = 1 ), & size ( key_species , dim = 2 ), & size ( key_species , dim = 3 ))) allocate ( key_species_present_init ( size ( gas_names ))) key_species_present_init = . true . do ip = 1 , np do ia = 1 , na do it = 1 , nt if ( key_species ( ip , ia , it ) . ne . 0 ) then key_species_red ( ip , ia , it ) = string_loc_in_array ( gas_names ( key_species ( ip , ia , it )), gas_names_red ) if ( key_species_red ( ip , ia , it ) . eq . - 1 ) key_species_present_init ( key_species ( ip , ia , it )) = . false . else key_species_red ( ip , ia , it ) = key_species ( ip , ia , it ) endif enddo end do enddo end subroutine create_key_species_reduce ! --------------------------------------------------------------------------------------- subroutine reduce_minor_arrays ( available_gases , & gas_minor , identifier_minor ,& kminor_atm , & minor_gases_atm , & minor_limits_gpt_atm , & minor_scales_with_density_atm , & scaling_gas_atm , & scale_by_complement_atm , & kminor_start_atm , & kminor_atm_red , & minor_gases_atm_red , & minor_limits_gpt_atm_red , & minor_scales_with_density_atm_red , & scaling_gas_atm_red , & scale_by_complement_atm_red , & kminor_start_atm_red ) class ( ty_gas_concs ), intent ( in ) :: available_gases real ( wp ), dimension (:,:,:), intent ( in ) :: kminor_atm character ( len =* ), dimension (:), intent ( in ) :: gas_minor , & identifier_minor character ( len =* ), dimension (:), intent ( in ) :: minor_gases_atm integer , dimension (:,:), intent ( in ) :: minor_limits_gpt_atm logical ( wl ), dimension (:), intent ( in ) :: minor_scales_with_density_atm character ( len =* ), dimension (:), intent ( in ) :: scaling_gas_atm logical ( wl ), dimension (:), intent ( in ) :: scale_by_complement_atm integer , dimension (:), intent ( in ) :: kminor_start_atm real ( wp ), dimension (:,:,:), allocatable , & intent ( out ) :: kminor_atm_red character ( len =* ), dimension (:), allocatable , & intent ( out ) :: minor_gases_atm_red integer , dimension (:,:), allocatable , & intent ( out ) :: minor_limits_gpt_atm_red logical ( wl ), dimension (:), allocatable , & intent ( out ) :: minor_scales_with_density_atm_red character ( len =* ), dimension (:), allocatable , & intent ( out ) :: scaling_gas_atm_red logical ( wl ), dimension (:), allocatable , intent ( out ) :: & scale_by_complement_atm_red integer , dimension (:), allocatable , intent ( out ) :: & kminor_start_atm_red ! Local variables integer :: i , j , ks integer :: idx_mnr , nm , tot_g , red_nm integer :: icnt , n_elim , ng logical , dimension (:), allocatable :: gas_is_present integer , dimension (:), allocatable :: indexes real ( wp ), dimension (:,:,:), allocatable :: kminor_atm_red_t nm = size ( minor_gases_atm ) tot_g = 0 allocate ( gas_is_present ( nm )) do i = 1 , size ( minor_gases_atm ) idx_mnr = string_loc_in_array ( minor_gases_atm ( i ), identifier_minor ) ! Next line causes a compiler bug in gfortran 11.0.1 on Mac ARM ! Should replace gas_names with get_gas_names() and make gas_names private in ty_gas_concs gas_is_present ( i ) = string_in_array ( gas_minor ( idx_mnr ), available_gases % gas_names ) if ( gas_is_present ( i )) then tot_g = tot_g + ( minor_limits_gpt_atm ( 2 , i ) - minor_limits_gpt_atm ( 1 , i ) + 1 ) endif enddo red_nm = count ( gas_is_present ) allocate ( minor_gases_atm_red ( red_nm ),& minor_scales_with_density_atm_red ( red_nm ), & scaling_gas_atm_red ( red_nm ), & scale_by_complement_atm_red ( red_nm ), & kminor_start_atm_red ( red_nm )) allocate ( minor_limits_gpt_atm_red ( 2 , red_nm )) allocate ( kminor_atm_red_t ( tot_g , size ( kminor_atm , 2 ), size ( kminor_atm , 3 ))) allocate ( kminor_atm_red ( size ( kminor_atm , 3 ), size ( kminor_atm , 2 ), tot_g )) if (( red_nm . eq . nm )) then ! Character data not allowed in OpenACC regions? minor_gases_atm_red = minor_gases_atm scaling_gas_atm_red = scaling_gas_atm kminor_atm_red_t = kminor_atm minor_limits_gpt_atm_red = minor_limits_gpt_atm minor_scales_with_density_atm_red = minor_scales_with_density_atm scale_by_complement_atm_red = scale_by_complement_atm kminor_start_atm_red = kminor_start_atm else allocate ( indexes ( red_nm )) ! Find the integer indexes for the gases that are present indexes = pack ([( i , i = 1 , size ( minor_gases_atm ))], mask = gas_is_present ) minor_gases_atm_red = minor_gases_atm ( indexes ) scaling_gas_atm_red = scaling_gas_atm ( indexes ) minor_scales_with_density_atm_red = & minor_scales_with_density_atm ( indexes ) scale_by_complement_atm_red = & scale_by_complement_atm ( indexes ) kminor_start_atm_red = kminor_start_atm ( indexes ) icnt = 0 n_elim = 0 do i = 1 , nm ng = minor_limits_gpt_atm ( 2 , i ) - minor_limits_gpt_atm ( 1 , i ) + 1 if ( gas_is_present ( i )) then icnt = icnt + 1 minor_limits_gpt_atm_red ( 1 : 2 , icnt ) = minor_limits_gpt_atm ( 1 : 2 , i ) kminor_start_atm_red ( icnt ) = kminor_start_atm ( i ) - n_elim ks = kminor_start_atm_red ( icnt ) do j = 1 , ng kminor_atm_red_t ( kminor_start_atm_red ( icnt ) + j - 1 ,:,:) = & kminor_atm ( kminor_start_atm ( i ) + j - 1 ,:,:) enddo else n_elim = n_elim + ng endif enddo endif kminor_atm_red = RESHAPE ( kminor_atm_red_t ,( / size ( kminor_atm_red_t , dim = 3 ), & size ( kminor_atm_red_t , dim = 2 ), size ( kminor_atm_red_t , dim = 1 ) / ), ORDER = ( / 3 , 2 , 1 / )) deallocate ( kminor_atm_red_t ) end subroutine reduce_minor_arrays ! --------------------------------------------------------------------------------------- ! returns flavor index; -1 if not found pure function key_species_pair2flavor ( flavor , key_species_pair ) integer :: key_species_pair2flavor integer , dimension (:,:), intent ( in ) :: flavor integer , dimension ( 2 ), intent ( in ) :: key_species_pair integer :: iflav do iflav = 1 , size ( flavor , 2 ) if ( all ( key_species_pair (:). eq . flavor (:, iflav ))) then key_species_pair2flavor = iflav return end if end do key_species_pair2flavor = - 1 end function key_species_pair2flavor ! --------------------------------------------------------------------------------------- ! ! create gpoint_flavor list ! a map pointing from each g-point to the corresponding entry in the \"flavor list\" ! subroutine create_gpoint_flavor ( key_species , gpt2band , flavor , gpoint_flavor ) integer , dimension (:,:,:), intent ( in ) :: key_species integer , dimension (:), intent ( in ) :: gpt2band integer , dimension (:,:), intent ( in ) :: flavor integer , dimension (:,:), intent ( out ), allocatable :: gpoint_flavor integer :: ngpt , igpt , iatm ngpt = size ( gpt2band ) allocate ( gpoint_flavor ( 2 , ngpt )) do igpt = 1 , ngpt do iatm = 1 , 2 gpoint_flavor ( iatm , igpt ) = key_species_pair2flavor ( & flavor , & rewrite_key_species_pair ( key_species (:, iatm , gpt2band ( igpt ))) & ) end do end do end subroutine create_gpoint_flavor !-------------------------------------------------------------------------------------------------------------------- ! ! Utility function to combine optical depths from gas absorption and Rayleigh scattering ! It may be more efficient to combine scattering and absorption optical depths in place ! rather than storing and processing two large arrays ! subroutine combine_abs_and_rayleigh ( tau , tau_rayleigh , optical_props ) real ( wp ), dimension (:,:,:), intent ( in ) :: tau real ( wp ), dimension (:,:,:), intent ( in ) :: tau_rayleigh class ( ty_optical_props_arry ), intent ( inout ) :: optical_props integer :: icol , ilay , igpt , ncol , nlay , ngpt , nmom real ( wp ) :: t ncol = size ( tau , 1 ) nlay = size ( tau , 2 ) ngpt = size ( tau , 3 ) select type ( optical_props ) type is ( ty_optical_props_1scl ) ! ! Extinction optical depth ! !$acc parallel loop gang vector collapse(3) default(present) !$omp target teams distribute parallel do simd collapse(3) do igpt = 1 , ngpt do ilay = 1 , nlay do icol = 1 , ncol optical_props % tau ( icol , ilay , igpt ) = tau ( icol , ilay , igpt ) + & tau_rayleigh ( icol , ilay , igpt ) end do end do end do ! ! asymmetry factor or phase function moments ! type is ( ty_optical_props_2str ) ! ! Extinction optical depth and single scattering albedo ! !$acc parallel loop gang vector collapse(3) default(present) !$omp target teams distribute parallel do simd collapse(3) do igpt = 1 , ngpt do ilay = 1 , nlay do icol = 1 , ncol t = tau ( icol , ilay , igpt ) + tau_rayleigh ( icol , ilay , igpt ) if ( t > 2._wp * tiny ( t )) then optical_props % ssa ( icol , ilay , igpt ) = tau_rayleigh ( icol , ilay , igpt ) / t else optical_props % ssa ( icol , ilay , igpt ) = 0._wp end if optical_props % tau ( icol , ilay , igpt ) = t end do end do end do call zero_array ( ncol , nlay , ngpt , optical_props % g ) type is ( ty_optical_props_nstr ) ! ! Extinction optical depth and single scattering albedo ! !$acc parallel loop gang vector collapse(3) default(present) !$omp target teams distribute parallel do simd collapse(3) do igpt = 1 , ngpt do ilay = 1 , nlay do icol = 1 , ncol t = tau ( icol , ilay , igpt ) + tau_rayleigh ( icol , ilay , igpt ) if ( t > 2._wp * tiny ( t )) then optical_props % ssa ( icol , ilay , igpt ) = tau_rayleigh ( icol , ilay , igpt ) / t else optical_props % ssa ( icol , ilay , igpt ) = 0._wp end if optical_props % tau ( icol , ilay , igpt ) = t end do end do end do nmom = size ( optical_props % p , 1 ) call zero_array ( nmom , ncol , nlay , ngpt , optical_props % p ) if ( nmom >= 2 ) then !$acc parallel loop gang vector collapse(3) default(present) !$omp target teams distribute parallel do simd collapse(3) do igpt = 1 , ngpt do ilay = 1 , nlay do icol = 1 , ncol optical_props % p ( 2 , icol , ilay , igpt ) = 0.1_wp end do end do end do end if end select end subroutine combine_abs_and_rayleigh !-------------------------------------------------------------------------------------------------------------------- ! Sizes of tables: pressure, temperate, eta (mixing fraction) ! Equivalent routines for the number of gases and flavors (get_ngas(), get_nflav()) are defined above because they're ! used in function defintions ! Table kmajor has dimensions (ngpt, neta, npres, ntemp) !-------------------------------------------------------------------------------------------------------------------- ! ! return extent of eta dimension ! pure function get_neta ( this ) class ( ty_gas_optics_rrtmgp ), intent ( in ) :: this integer :: get_neta get_neta = size ( this % kmajor , dim = 2 ) end function ! -------------------------------------------------------------------------------------- ! ! return the number of pressures in reference profile ! absorption coefficient table is one bigger since a pressure is repeated in upper/lower atmos ! pure function get_npres ( this ) class ( ty_gas_optics_rrtmgp ), intent ( in ) :: this integer :: get_npres get_npres = size ( this % kmajor , dim = 3 ) - 1 end function get_npres ! -------------------------------------------------------------------------------------- ! ! return the number of temperatures ! pure function get_ntemp ( this ) class ( ty_gas_optics_rrtmgp ), intent ( in ) :: this integer :: get_ntemp get_ntemp = size ( this % kmajor , dim = 1 ) end function get_ntemp ! -------------------------------------------------------------------------------------- ! ! return the number of temperatures for Planck function ! pure function get_nPlanckTemp ( this ) class ( ty_gas_optics_rrtmgp ), intent ( in ) :: this integer :: get_nPlanckTemp get_nPlanckTemp = size ( this % totplnk , dim = 1 ) ! dimensions are Planck-temperature, band end function get_nPlanckTemp end module mo_gas_optics_rrtmgp","tags":"","loc":"sourcefile/mo_gas_optics_rrtmgp.f90.html"},{"title":"mo_aerosol_optics_rrtmgp_merra.F90 – RRTMGP-Fortran","text":"Contents Modules mo_aerosol_optics_rrtmgp_merra Source Code mo_aerosol_optics_rrtmgp_merra.F90 Source Code ! This code is part of Radiative Transfer for Energetics (RTE) ! ! Contacts: Robert Pincus and Eli Mlawer ! email: rrtmgp@aer.com ! ! Copyright 2015-2018, Atmospheric and Environmental Research and ! Regents of the University of Colorado. All right reserved. ! ! Use and duplication is permitted under the terms of the ! BSD 3-clause license, see http://opensource.org/licenses/BSD-3-Clause ! ------------------------------------------------------------------------------------------------- ! Provides aerosol optical properties as a function of aerosol size (radius), aerosol mass, ! and relative humidity for the RRTMGP spectral bands. ! Based on climatoligical aerosol optical properties used in MERRA2 as derived from the ! GOCART model for 15 aerosol types, including dust and sea salt each for five size bins, ! one sulfate type, and both hydrophobic and hydrophilic black carbon and organic carbon. ! Input aerosol optical data are stored in look-up tables. ! ! References for the gocart interactive aerosols: ! Chin et al., jgr, 2000 (https://doi.org/10.1029/2000jd900384) ! Chin et al., jas, 2002 (https://doi.org/10.1175/1520-0469(2002)059<0461:TAOTFT>2.0.CO;2) ! Colarco et al., jgr, 2010 (https://doi.org/10.1029/2009jd012820) ! ! References for merra2 aerosol reanalysis: ! Randles et al., j. clim., 2017 (https://doi.org/10.1175/jcli-d-16-0609.1) ! Buchard et al., j. clim., 2017 (https://doi.org/10.1175/jcli-d-16-0613.1) ! ! The class can be used as-is but is also intended as an example of how to extend the RTE framework ! ------------------------------------------------------------------------------------------------- module mo_aerosol_optics_rrtmgp_merra use mo_rte_kind , only : wp , wl use mo_rte_config , only : check_extents , check_values use mo_rte_util_array_validation ,& only : extents_are , any_vals_outside use mo_optical_props , only : ty_optical_props , & ty_optical_props_arry , & ty_optical_props_1scl , & ty_optical_props_2str , & ty_optical_props_nstr implicit none ! MERRA2/GOCART aerosol types integer , parameter , public :: merra_ntype = 7 ! Number of MERRA aerosol types integer , parameter , public :: merra_aero_none = 0 ! no aerosal integer , parameter , public :: merra_aero_dust = 1 ! dust integer , parameter , public :: merra_aero_salt = 2 ! Salt integer , parameter , public :: merra_aero_sulf = 3 ! sulfate integer , parameter , public :: merra_aero_bcar_rh = 4 ! black carbon, hydrophilic integer , parameter , public :: merra_aero_bcar = 5 ! black carbon, hydrophobic integer , parameter , public :: merra_aero_ocar_rh = 6 ! organic carbon, hydrophilic integer , parameter , public :: merra_aero_ocar = 7 ! organic carbon, hydrophobic ! index identifiers for aerosol optical property tables integer , parameter , private :: ext = 1 ! extinction integer , parameter , private :: ssa = 2 ! single scattering albedo integer , parameter , private :: g = 3 ! asymmetry parameter private ! ----------------------------------------------------------------------------------- type , extends ( ty_optical_props ), public :: ty_aerosol_optics_rrtmgp_merra private ! ! Lookup table information ! ! Table upper and lower aerosol size (radius) bin limits (microns) real ( wp ), dimension (:,:), allocatable :: merra_aero_bin_lims ! Dimensions (pair,nbin) ! Table relative humidity values real ( wp ), dimension (:), allocatable :: aero_rh (:) ! ! The aerosol tables themselves. ! extinction (m2/kg) ! single scattering albedo (unitless) ! asymmetry parameter (unitless) ! real ( wp ), dimension (:,:,: ), allocatable :: aero_dust_tbl ! ext, ssa, g (nval, nbin, nbnd) real ( wp ), dimension (:,:,:,:), allocatable :: aero_salt_tbl ! ext, ssa, g (nval, nrh, nbin, nbnd) real ( wp ), dimension (:,:,: ), allocatable :: aero_sulf_tbl ! ext, ssa, g (nval, nrh, nbnd) real ( wp ), dimension (:,: ), allocatable :: aero_bcar_tbl ! ext, ssa, g (nval, nbnd) real ( wp ), dimension (:,:,: ), allocatable :: aero_bcar_rh_tbl ! ext, ssa, g (nval, nrh, nbnd) real ( wp ), dimension (:,: ), allocatable :: aero_ocar_tbl ! ext, ssa, g (nval, nbnd) real ( wp ), dimension (:,:,: ), allocatable :: aero_ocar_rh_tbl ! ext, ssa, g (nval, nrh, nbnd) ! ! ----- contains generic , public :: load => load_lut procedure , public :: finalize procedure , public :: aerosol_optics ! Internal procedures procedure , private :: load_lut end type ty_aerosol_optics_rrtmgp_merra contains ! ------------------------------------------------------------------------------ ! ! Routines to load data needed for aerosol optics calculations from lookup-tables. ! ! ------------------------------------------------------------------------------ function load_lut ( this , band_lims_wvn , & merra_aero_bin_lims , aero_rh , & aero_dust_tbl , aero_salt_tbl , aero_sulf_tbl , & aero_bcar_tbl , aero_bcar_rh_tbl , & aero_ocar_tbl , aero_ocar_rh_tbl ) & result ( error_msg ) class ( ty_aerosol_optics_rrtmgp_merra ), & intent ( inout ) :: this real ( wp ), dimension (:,:), intent ( in ) :: band_lims_wvn ! spectral discretization ! Lookup table interpolation constants real ( wp ), dimension (:,:), intent ( in ) :: merra_aero_bin_lims ! aerosol lut size bin limiits (pair,nbin) real ( wp ), dimension (:), intent ( in ) :: aero_rh ! relative humidity LUT dimension values ! LUT coefficients ! Extinction, single-scattering albedo, and asymmetry parameter for aerosol types real ( wp ), dimension (:,:,:), intent ( in ) :: aero_dust_tbl real ( wp ), dimension (:,:,:,:), intent ( in ) :: aero_salt_tbl real ( wp ), dimension (:,:,:), intent ( in ) :: aero_sulf_tbl real ( wp ), dimension (:,:), intent ( in ) :: aero_bcar_tbl real ( wp ), dimension (:,:,:), intent ( in ) :: aero_bcar_rh_tbl real ( wp ), dimension (:,:), intent ( in ) :: aero_ocar_tbl real ( wp ), dimension (:,:,:), intent ( in ) :: aero_ocar_rh_tbl character ( len = 128 ) :: error_msg ! ------- ! ! Local variables ! integer :: npair , nval , nrh , nbin , nband error_msg = this % init ( band_lims_wvn , name = \"RRTMGP aerosol optics\" ) ! ! LUT coefficient dimensions ! npair = size ( merra_aero_bin_lims , dim = 1 ) nval = size ( aero_salt_tbl , dim = 1 ) nrh = size ( aero_salt_tbl , dim = 2 ) nbin = size ( aero_salt_tbl , dim = 3 ) nband = size ( aero_salt_tbl , dim = 4 ) ! ! Error checking ! if ( check_extents ) then error_msg = '' if (. not . extents_are ( aero_dust_tbl , nval , nbin , nband )) & error_msg = \"aerosol_optics%load_lut(): array aero_dust_tbl isn't consistently sized\" if (. not . extents_are ( aero_salt_tbl , nval , nrh , nbin , nband )) & error_msg = \"aerosol_optics%load_lut(): array aero_salt_tbl isn't consistently sized\" if (. not . extents_are ( aero_sulf_tbl , nval , nrh , nband )) & error_msg = \"aerosol_optics%load_lut(): array aero_sulf_tbl isn't consistently sized\" if (. not . extents_are ( aero_bcar_rh_tbl , nval , nrh , nband )) & error_msg = \"aerosol_optics%load_lut(): array aero_bcar_rh_tbl isn't consistently sized\" if (. not . extents_are ( aero_bcar_tbl , nval , nband )) & error_msg = \"aerosol_optics%load_lut(): array aero_bcar_tbl isn't consistently sized\" if (. not . extents_are ( aero_ocar_rh_tbl , nval , nrh , nband )) & error_msg = \"aerosol_optics%load_lut(): array aero_ocar_rh_tbl isn't consistently sized\" if (. not . extents_are ( aero_ocar_tbl , nval , nband )) & error_msg = \"aerosol_optics%load_lut(): array aero_ocar_tbl isn't consistently sized\" if ( error_msg /= \"\" ) return endif ! Allocate LUT parameters allocate ( this % merra_aero_bin_lims ( npair , nbin )) allocate ( this % aero_rh ( nrh )) ! Allocate LUT coefficients allocate ( this % aero_dust_tbl ( nval , nbin , nband ), & this % aero_salt_tbl ( nrh , nval , nbin , nband ), & this % aero_sulf_tbl ( nrh , nval , nband ), & this % aero_bcar_tbl ( nval , nband ), & this % aero_bcar_rh_tbl ( nrh , nval , nband ), & this % aero_ocar_tbl ( nval , nband ), & this % aero_ocar_rh_tbl ( nrh , nval , nband )) ! Copy LUT coefficients this % merra_aero_bin_lims = merra_aero_bin_lims this % aero_rh = aero_rh this % aero_dust_tbl = aero_dust_tbl this % aero_bcar_tbl = aero_bcar_tbl this % aero_ocar_tbl = aero_ocar_tbl this % aero_salt_tbl = reshape ( aero_salt_tbl , shape = ( / nrh , nval , nbin , nband / ), order = ( / 2 , 1 , 3 , 4 / ) ) this % aero_sulf_tbl = reshape ( aero_sulf_tbl , shape = ( / nrh , nval , nband / ), order = ( / 2 , 1 , 3 / ) ) this % aero_bcar_rh_tbl = reshape ( aero_bcar_rh_tbl , shape = ( / nrh , nval , nband / ), order = ( / 2 , 1 , 3 / ) ) this % aero_ocar_rh_tbl = reshape ( aero_ocar_rh_tbl , shape = ( / nrh , nval , nband / ), order = ( / 2 , 1 , 3 / ) ) !$acc enter data create(this) & !$acc copyin(this%aero_dust_tbl, this%aero_salt_tbl, this%aero_sulf_tbl) & !$acc copyin(this%aero_bcar_tbl, this%aero_bcar_rh_tbl) & !$acc copyin(this%aero_ocar_tbl, this%aero_ocar_rh_tbl) & !$acc copyin(this%merra_aero_bin_lims, this%aero_rh) !$omp target enter data & !$omp map(to:this%aero_dust_tbl, this%aero_salt_tbl, this%aero_sulf_tbl) & !$omp map(to:this%aero_bcar_tbl, this%aero_bcar_rh_tbl) & !$omp map(to:this%aero_ocar_tbl, this%aero_ocar_rh_tbl) & !$omp map(to:this%merra_aero_bin_lims, this%aero_rh) end function load_lut !-------------------------------------------------------------------------------------------------------------------- ! ! Finalize ! !-------------------------------------------------------------------------------------------------------------------- subroutine finalize ( this ) class ( ty_aerosol_optics_rrtmgp_merra ), intent ( inout ) :: this ! Lookup table aerosol optics interpolation arrays if ( allocated ( this % merra_aero_bin_lims )) then deallocate ( this % merra_aero_bin_lims , this % aero_rh ) !$acc exit data delete( this%merra_aero_bin_lims, this%aero_rh) !$omp target exit data map(release:this%merra_aero_bin_lims, this%aero_rh) end if ! Lookup table aerosol optics coefficients if ( allocated ( this % aero_dust_tbl )) then !$acc exit data delete(this%aero_dust_tbl, this%aero_salt_tbl, this%aero_sulf_tbl) & !$acc delete(this%aero_bcar_tbl, this%aero_bcar_rh_tbl) & !$acc delete(this%aero_ocar_tbl, this%aero_ocar_rh_tbl) & !$acc delete(this) !$omp target exit data map(release:this%aero_dust_tbl, this%aero_salt_tbl, this%aero_sulf_tbl) & !$omp map(release:this%aero_bcar_tbl, this%aero_bcar_rh_tbl) & !$omp map(release:this%aero_ocar_tbl, this%aero_ocar_rh_tbl) deallocate ( this % aero_dust_tbl , this % aero_salt_tbl , this % aero_sulf_tbl , & this % aero_bcar_tbl , this % aero_bcar_rh_tbl , & this % aero_ocar_tbl , this % aero_ocar_rh_tbl ) end if end subroutine finalize ! ------------------------------------------------------------------------------ ! ! Derive aerosol optical properties from provided aerosol input properties ! ! ------------------------------------------------------------------------------ ! ! Compute single-scattering properties ! function aerosol_optics ( this , aero_type , aero_size , aero_mass , relhum , & optical_props ) result ( error_msg ) class ( ty_aerosol_optics_rrtmgp_merra ), & intent ( in ) :: this integer , intent ( in ) :: aero_type (:,:) ! MERRA2/GOCART aerosol type ! Dimensions: (ncol,nlay) ! 1 = merra_aero_dust (dust) ! 2 = merra_aero_salt (salt) ! 3 = merra_aero_sulf (sulfate) ! 4 = merra_aero_bcar_rh (black carbon, hydrophilic) ! 5 = merra_aero_bcar (black carbon, hydrophobic) ! 6 = merra_aero_ocar_rh (organic carbon, hydrophilic) ! 7 = merra_aero_ocar (organic carbon, hydrophobic) real ( wp ), intent ( in ) :: aero_size (:,:) ! aerosol size (radius) for dust and sea-salt (microns) ! Dimensions: (ncol,nlay) real ( wp ), intent ( in ) :: aero_mass (:,:) ! aerosol mass column (kg/m2) ! Dimensions: (ncol,nlay) real ( wp ), intent ( in ) :: relhum (:,:) ! relative humidity (fraction, 0-1) ! Dimensions: (ncol,nlay) class ( ty_optical_props_arry ), & intent ( inout ) :: optical_props ! Dimensions: (ncol,nlay,nbnd) character ( len = 128 ) :: error_msg ! ------- Local ------- logical ( wl ), dimension ( size ( aero_type , 1 ), size ( aero_type , 2 )) :: aeromsk real ( wp ), dimension ( size ( aero_type , 1 ), size ( aero_type , 2 ), size ( this % aero_dust_tbl , 3 )) :: & atau , ataussa , ataussag integer :: ncol , nlay , npair , nbin , nrh , nval , nbnd integer :: icol , ilay , ibnd , ibin ! scalars for total tau, tau*ssa real ( wp ) :: tau , taussa ! Scalars to work around OpenACC/OMP issues real ( wp ) :: minSize , maxSize ! ---------------------------------------- ! ! Error checking ! ! ---------------------------------------- error_msg = '' if (. not .( allocated ( this % aero_dust_tbl ))) then error_msg = 'aerosol optics: no data has been initialized' return end if ncol = size ( aero_type , 1 ) nlay = size ( aero_type , 2 ) npair = size ( this % merra_aero_bin_lims , 1 ) nbin = size ( this % merra_aero_bin_lims , 2 ) nrh = size ( this % aero_rh , 1 ) nval = size ( this % aero_dust_tbl , 1 ) nbnd = size ( this % aero_dust_tbl , 3 ) !$acc update host(this%merra_aero_bin_lims) !$omp target update from(this%merra_aero_bin_lims) minSize = this % merra_aero_bin_lims ( 1 , 1 ) maxSize = this % merra_aero_bin_lims ( 2 , nbin ) ! ! Array sizes ! if ( check_extents ) then error_msg = '' if (. not . extents_are ( aero_type , ncol , nlay )) & error_msg = \"aerosol optics: aero_type isn't consistenly sized\" if (. not . extents_are ( aero_size , ncol , nlay )) & error_msg = \"aerosol optics: aero_size isn't consistenly sized\" if (. not . extents_are ( aero_mass , ncol , nlay )) & error_msg = \"aerosol optics: aero_mass isn't consistenly sized\" if (. not . extents_are ( relhum , ncol , nlay )) & error_msg = \"aerosol optics: relhum isn't consistenly sized\" if ( optical_props % get_ncol () /= ncol . or . optical_props % get_nlay () /= nlay ) & error_msg = \"aerosol optics: optical_props have wrong extents\" if ( error_msg /= \"\" ) return end if ! ! Spectral consistency ! if ( check_values ) then if (. not . this % bands_are_equal ( optical_props )) & error_msg = \"aerosol optics: optical properties don't have the same band structure\" if ( optical_props % get_nband () /= optical_props % get_ngpt () ) & error_msg = \"aerosol optics: optical properties must be requested by band not g-points\" if ( any_int_vals_outside_2D ( aero_type , merra_aero_none , merra_ntype )) & error_msg = 'aerosol optics: aerosol type is out of bounds' if ( error_msg /= \"\" ) return end if !$acc data copyin(aero_type, aero_size, aero_mass, relhum) !$omp target data map(to:aero_type, aero_size, aero_mass, relhum) ! ! Aerosol mask; don't need aerosol optics if there's no aerosol ! !$acc data create(aeromsk) !$omp target data map(alloc:aeromsk) !$acc parallel loop default(present) collapse(2) !$omp target teams distribute parallel do simd collapse(2) do ilay = 1 , nlay do icol = 1 , ncol aeromsk ( icol , ilay ) = aero_type ( icol , ilay ) > 0 end do end do ! ! Aerosol size, relative humidity ! if ( check_values ) then if ( any_vals_outside ( aero_size , aeromsk , minSize , maxSize )) & error_msg = 'aerosol optics: requested aerosol size is out of bounds' if ( any_vals_outside ( relhum , aeromsk , 0._wp , 1._wp )) & error_msg = 'aerosol optics: relative humidity fraction is out of bounds' end if ! Release aerosol mask !$acc end data !$omp end target data if ( error_msg == \"\" ) then !$acc data create(atau, ataussa, ataussag) !$omp target data map(alloc:atau, ataussa, ataussag) ! ! ! ---------------------------------------- ! ! The lookup tables determining extinction coefficient, single-scattering albedo, ! and asymmetry parameter g as a function of aerosol type, aerosol size and ! relative humidity. ! We compute the optical depth tau (= exintinction coeff * aerosol mass ) and the ! products tau*ssa and tau*ssa*g separately for each aerosol type requested. ! These are used to determine the aerosol optical properties. ! if ( allocated ( this % aero_dust_tbl )) then ! ! Aerosol ! call compute_all_from_table ( ncol , nlay , npair , nval , nrh , nbin , nbnd , & aero_type , aero_size , aero_mass , relhum , & this % merra_aero_bin_lims , this % aero_rh , & this % aero_dust_tbl , this % aero_salt_tbl , this % aero_sulf_tbl , & this % aero_bcar_rh_tbl , this % aero_bcar_tbl , & this % aero_ocar_rh_tbl , this % aero_ocar_tbl , & atau , ataussa , ataussag ) endif ! ! Derive total aerosol optical properties ! See also the increment routines in mo_optical_props_kernels ! select type ( optical_props ) type is ( ty_optical_props_1scl ) !$acc parallel loop gang vector default(present) collapse(3) & !$acc copyin(optical_props) copyout(optical_props%tau) !$omp target teams distribute parallel do simd collapse(3) & !$omp map(from:optical_props%tau) do ibnd = 1 , nbnd do ilay = 1 , nlay do icol = 1 , ncol ! Absorption optical depth = (1-ssa) * tau = tau - taussa optical_props % tau ( icol , ilay , ibnd ) = ( atau ( icol , ilay , ibnd ) - ataussa ( icol , ilay , ibnd )) end do end do end do type is ( ty_optical_props_2str ) !$acc parallel loop gang vector default(present) collapse(3) & !$acc copyin(optical_props) copyout(optical_props%tau, optical_props%ssa, optical_props%g) !$omp target teams distribute parallel do simd collapse(3) & !$omp map(from:optical_props%tau, optical_props%ssa, optical_props%g) do ibnd = 1 , nbnd do ilay = 1 , nlay do icol = 1 , ncol tau = atau ( icol , ilay , ibnd ) taussa = ataussa ( icol , ilay , ibnd ) optical_props % tau ( icol , ilay , ibnd ) = tau optical_props % ssa ( icol , ilay , ibnd ) = taussa / max ( epsilon ( tau ), tau ) optical_props % g ( icol , ilay , ibnd ) = ( ataussag ( icol , ilay , ibnd )) & / max ( epsilon ( tau ), taussa ) end do end do end do type is ( ty_optical_props_nstr ) error_msg = \"aerosol optics: n-stream calculations not yet supported\" end select !$acc end data !$omp end target data end if !$acc end data !$omp end target data end function aerosol_optics !-------------------------------------------------------------------------------------------------------------------- ! ! Ancillary functions ! !-------------------------------------------------------------------------------------------------------------------- ! ! For size dimension, select size bin appropriate for the requested aerosol size. ! For rh dimension, linearly interpolate values from a lookup table with \"nrh\" ! unevenly-spaced elements \"aero_rh\". The last dimension for all tables is band. ! Returns zero where no aerosol is present. ! subroutine compute_all_from_table ( ncol , nlay , npair , nval , nrh , nbin , nbnd , & type , size , mass , rh , & merra_aero_bin_lims , aero_rh , & aero_dust_tbl , aero_salt_tbl , aero_sulf_tbl , & aero_bcar_rh_tbl , aero_bcar_tbl , & aero_ocar_rh_tbl , aero_ocar_tbl , & tau , taussa , taussag ) integer , intent ( in ) :: ncol , nlay , npair , nval , nrh , nbin , nbnd integer , dimension ( ncol , nlay ), intent ( in ) :: type real ( wp ), dimension ( ncol , nlay ), intent ( in ) :: size , mass , rh real ( wp ), dimension ( npair , nbin ), intent ( in ) :: merra_aero_bin_lims real ( wp ), dimension ( nrh ), intent ( in ) :: aero_rh real ( wp ), dimension ( nval , nbin , nbnd ), intent ( in ) :: aero_dust_tbl real ( wp ), dimension ( nrh , nval , nbin , nbnd ), intent ( in ) :: aero_salt_tbl real ( wp ), dimension ( nrh , nval , nbnd ), intent ( in ) :: aero_sulf_tbl real ( wp ), dimension ( nrh , nval , nbnd ), intent ( in ) :: aero_bcar_rh_tbl real ( wp ), dimension ( nval , nbnd ), intent ( in ) :: aero_bcar_tbl real ( wp ), dimension ( nrh , nval , nbnd ), intent ( in ) :: aero_ocar_rh_tbl real ( wp ), dimension ( nval , nbnd ), intent ( in ) :: aero_ocar_tbl real ( wp ), dimension ( ncol , nlay , nbnd ), intent ( out ) :: tau , taussa , taussag ! --------------------------- integer :: icol , ilay , ibnd , ibin , i integer :: itype , irh1 , irh2 real ( wp ) :: drh0 , drh1 , rdrh real ( wp ) :: t , ts , tsg ! tau, tau*ssa, tau*ssa*g ! --------------------------- !$acc parallel loop gang vector default(present) collapse(3) !$omp target teams distribute parallel do simd collapse(3) do ibnd = 1 , nbnd do ilay = 1 , nlay do icol = 1 , ncol ! Sequential loop to find size bin do i = 1 , nbin if ( size ( icol , ilay ) . ge . merra_aero_bin_lims ( 1 , i ) . and . & size ( icol , ilay ) . le . merra_aero_bin_lims ( 2 , i )) then ibin = i endif enddo itype = type ( icol , ilay ) ! relative humidity linear interpolation coefficients if ( itype . ne . merra_aero_none ) then irh2 = 1 do while ( rh ( icol , ilay ) . gt . aero_rh ( irh2 )) irh2 = irh2 + 1 if ( irh2 . gt . nrh ) exit enddo irh1 = max ( 1 , irh2 - 1 ) irh2 = min ( nrh , irh2 ) drh0 = aero_rh ( irh2 ) - aero_rh ( irh1 ) drh1 = rh ( icol , ilay ) - aero_rh ( irh1 ) if ( irh1 == irh2 ) then rdrh = 0._wp else rdrh = drh1 / drh0 endif endif ! Set aerosol optical properties where aerosol present. Use aerosol type array as the mask. select case ( itype ) ! dust case ( merra_aero_dust ) tau ( icol , ilay , ibnd ) = mass ( icol , ilay ) * aero_dust_tbl ( ext , ibin , ibnd ) taussa ( icol , ilay , ibnd ) = tau ( icol , ilay , ibnd ) * aero_dust_tbl ( ssa , ibin , ibnd ) taussag ( icol , ilay , ibnd ) = taussa ( icol , ilay , ibnd ) * aero_dust_tbl ( g , ibin , ibnd ) ! sea-salt case ( merra_aero_salt ) tau ( icol , ilay , ibnd ) = mass ( icol , ilay ) * & linear_interp_aero_table ( aero_salt_tbl (:, ext , ibin , ibnd ), irh1 , irh2 , rdrh ) taussa ( icol , ilay , ibnd ) = tau ( icol , ilay , ibnd ) * & linear_interp_aero_table ( aero_salt_tbl (:, ssa , ibin , ibnd ), irh1 , irh2 , rdrh ) taussag ( icol , ilay , ibnd ) = taussa ( icol , ilay , ibnd ) * & linear_interp_aero_table ( aero_salt_tbl (:, g , ibin , ibnd ), irh1 , irh2 , rdrh ) ! sulfate case ( merra_aero_sulf ) tau ( icol , ilay , ibnd ) = mass ( icol , ilay ) * & linear_interp_aero_table ( aero_sulf_tbl (:, ext , ibnd ), irh1 , irh2 , rdrh ) taussa ( icol , ilay , ibnd ) = tau ( icol , ilay , ibnd ) * & linear_interp_aero_table ( aero_sulf_tbl (:, ssa , ibnd ), irh1 , irh2 , rdrh ) taussag ( icol , ilay , ibnd ) = taussa ( icol , ilay , ibnd ) * & linear_interp_aero_table ( aero_sulf_tbl (:, g , ibnd ), irh1 , irh2 , rdrh ) ! black carbon - hydrophilic case ( merra_aero_bcar_rh ) tau ( icol , ilay , ibnd ) = mass ( icol , ilay ) * & linear_interp_aero_table ( aero_bcar_rh_tbl (:, ext , ibnd ), irh1 , irh2 , rdrh ) taussa ( icol , ilay , ibnd ) = tau ( icol , ilay , ibnd ) * & linear_interp_aero_table ( aero_bcar_rh_tbl (:, ssa , ibnd ), irh1 , irh2 , rdrh ) taussag ( icol , ilay , ibnd ) = taussa ( icol , ilay , ibnd ) * & linear_interp_aero_table ( aero_bcar_rh_tbl (:, g , ibnd ), irh1 , irh2 , rdrh ) ! black carbon - hydrophobic case ( merra_aero_bcar ) tau ( icol , ilay , ibnd ) = mass ( icol , ilay ) * aero_bcar_tbl ( ext , ibnd ) taussa ( icol , ilay , ibnd ) = tau ( icol , ilay , ibnd ) * aero_bcar_tbl ( ssa , ibnd ) taussag ( icol , ilay , ibnd ) = taussa ( icol , ilay , ibnd ) * aero_bcar_tbl ( g , ibnd ) ! organic carbon - hydrophilic case ( merra_aero_ocar_rh ) tau ( icol , ilay , ibnd ) = mass ( icol , ilay ) * & linear_interp_aero_table ( aero_ocar_rh_tbl (:, ext , ibnd ), irh1 , irh2 , rdrh ) taussa ( icol , ilay , ibnd ) = tau ( icol , ilay , ibnd ) * & linear_interp_aero_table ( aero_ocar_rh_tbl (:, ssa , ibnd ), irh1 , irh2 , rdrh ) taussag ( icol , ilay , ibnd ) = taussa ( icol , ilay , ibnd ) * & linear_interp_aero_table ( aero_ocar_rh_tbl (:, g , ibnd ), irh1 , irh2 , rdrh ) ! organic carbon - hydrophobic case ( merra_aero_ocar ) tau ( icol , ilay , ibnd ) = mass ( icol , ilay ) * aero_ocar_tbl ( ext , ibnd ) taussa ( icol , ilay , ibnd ) = tau ( icol , ilay , ibnd ) * aero_ocar_tbl ( ssa , ibnd ) taussag ( icol , ilay , ibnd ) = taussa ( icol , ilay , ibnd ) * aero_ocar_tbl ( g , ibnd ) ! no aerosol case default tau ( icol , ilay , ibnd ) = 0._wp taussa ( icol , ilay , ibnd ) = 0._wp taussag ( icol , ilay , ibnd ) = 0._wp end select end do end do end do end subroutine compute_all_from_table !-------------------------------------------------------------------------------------------------------------------- ! ! Function for linearly interpolating MERRA aerosol optics tables in the rh dimension for ! a single parameter, aerosol type, spectral band, and size bin. Interpolation is performed ! only where aerosol in present using aerosol type as the mask. ! function linear_interp_aero_table ( table , index1 , index2 , weight ) result ( value ) !$acc routine seq !$omp declare target integer , intent ( in ) :: index1 , index2 real ( wp ), intent ( in ) :: weight real ( wp ), dimension (:), intent ( in ) :: table real ( wp ) :: value value = table ( index1 ) + weight * ( table ( index2 ) - table ( index1 )) end function linear_interp_aero_table ! ---------------------------------------------------------- logical function any_int_vals_outside_2D ( array , checkMin , checkMax ) integer , dimension (:,:), intent ( in ) :: array integer , intent ( in ) :: checkMin , checkMax integer :: minValue , maxValue !$acc kernels copyin(array) !$omp target map(to:array) map(from:minValue, maxValue) minValue = minval ( array ) maxValue = maxval ( array ) !$acc end kernels !$omp end target any_int_vals_outside_2D = minValue < checkMin . or . maxValue > checkMax end function any_int_vals_outside_2D end module mo_aerosol_optics_rrtmgp_merra","tags":"","loc":"sourcefile/mo_aerosol_optics_rrtmgp_merra.f90.html"}]} \ No newline at end of file +var tipuesearch = {"pages":[{"title":" RRTMGP-Fortran ","text":"RRTMGP-Fortran These pages provide a programmer's view of the Fortran user interface to RRTMGP. RRTMGP provides a class ty_gas_optics_rrtmgp that implements\nthe gas_optics() and other procedure(s) defined by the ty_gas_optics abstract class. The class is used to compute the spectrally-varying optical properties of the\ngaseous atmosphere given temperature, pressure, and gas concentrations. Each instance of the\nvariable is \"loaded\" with data from netCDF\nfiles in the $RRTMGP_DATA directory. Depending on the data provided the variable can be used\nor radiation emitted by the atmosphere and surface (\"longwave\") of for for radiation emitted\nby the planet's star (\"shortwave\"). The class implements both the longwave/internal sources and\nshortwave/external sources versions of the gas_optics procedure.\nThe longwave version reports Planck sources at layer centers and layer interfaces (levels)\nwhile the shortwave version reports the spectrally-varying stellar radiation\nCalling the longwave routine (by providing the longwave-relevant arguments)\nwhen the variable has been initialized with shortwave data triggers a run-time error. The user interface uses the ty_gas_concs type\nto represent the volume mixing ratios needed as input. Output suitable for\nscattering emission, two-stream, or multi-stream calculations are provided\ndepending on which sub-class of RTE's ty_optical_props_arry are provided. Planck source functions, if requested, are reported in a variable\nof type ty_source_func_lw. The listings below may not be exhaustive.\nTo see the full listings use the links at the top of the page.\nThere is a search bar in the top right. Return to the Documentation overview or the [reference overview]. Developer Info The RTE+RRTTMGP consortium","tags":"home","loc":"index.html"},{"title":"ty_aerosol_optics_rrtmgp_merra – RRTMGP-Fortran ","text":"type, public, extends(ty_optical_props) :: ty_aerosol_optics_rrtmgp_merra Inherits type~~ty_aerosol_optics_rrtmgp_merra~~InheritsGraph type~ty_aerosol_optics_rrtmgp_merra ty_aerosol_optics_rrtmgp_merra ty_optical_props ty_optical_props type~ty_aerosol_optics_rrtmgp_merra->ty_optical_props Help × Graph Key Nodes of different colours represent the following: Graph Key Type Type This Page's Entity This Page's Entity Solid arrows point from a derived type to the parent type which it\n extends. Dashed arrows point from a derived type to the other\n types it contains as a components, with a label listing the name(s) of\n said component(s). Contents Variables aero_bcar_rh_tbl aero_bcar_tbl aero_dust_tbl aero_ocar_rh_tbl aero_ocar_tbl aero_rh aero_salt_tbl aero_sulf_tbl merra_aero_bin_lims Type-Bound Procedures aerosol_optics finalize load Components Type Visibility Attributes Name Initial real(kind=wp), public, dimension(:,:,: ), allocatable :: aero_bcar_rh_tbl real(kind=wp), public, dimension(:,: ), allocatable :: aero_bcar_tbl real(kind=wp), public, dimension(:,:,: ), allocatable :: aero_dust_tbl real(kind=wp), public, dimension(:,:,: ), allocatable :: aero_ocar_rh_tbl real(kind=wp), public, dimension(:,: ), allocatable :: aero_ocar_tbl real(kind=wp), public, dimension(:), allocatable :: aero_rh (:) real(kind=wp), public, dimension(:,:,:,:), allocatable :: aero_salt_tbl real(kind=wp), public, dimension(:,:,: ), allocatable :: aero_sulf_tbl real(kind=wp), public, dimension(:,:), allocatable :: merra_aero_bin_lims Type-Bound Procedures procedure, public :: aerosol_optics private function aerosol_optics(this, aero_type, aero_size, aero_mass, relhum, optical_props) result(error_msg) Arguments Type Intent Optional Attributes Name class( ty_aerosol_optics_rrtmgp_merra ), intent(in) :: this integer, intent(in) :: aero_type (:,:) real(kind=wp), intent(in) :: aero_size (:,:) real(kind=wp), intent(in) :: aero_mass (:,:) real(kind=wp), intent(in) :: relhum (:,:) class(ty_optical_props_arry), intent(inout) :: optical_props Return Value character(len=128) procedure, public :: finalize private subroutine finalize(this) Arguments Type Intent Optional Attributes Name class( ty_aerosol_optics_rrtmgp_merra ), intent(inout) :: this generic, public :: load => load_lut private function load_lut(this, band_lims_wvn, merra_aero_bin_lims, aero_rh, aero_dust_tbl, aero_salt_tbl, aero_sulf_tbl, aero_bcar_tbl, aero_bcar_rh_tbl, aero_ocar_tbl, aero_ocar_rh_tbl) result(error_msg) Arguments Type Intent Optional Attributes Name class( ty_aerosol_optics_rrtmgp_merra ), intent(inout) :: this real(kind=wp), intent(in), dimension(:,:) :: band_lims_wvn real(kind=wp), intent(in), dimension(:,:) :: merra_aero_bin_lims real(kind=wp), intent(in), dimension(:) :: aero_rh real(kind=wp), intent(in), dimension(:,:,:) :: aero_dust_tbl real(kind=wp), intent(in), dimension(:,:,:,:) :: aero_salt_tbl real(kind=wp), intent(in), dimension(:,:,:) :: aero_sulf_tbl real(kind=wp), intent(in), dimension(:,:) :: aero_bcar_tbl real(kind=wp), intent(in), dimension(:,:,:) :: aero_bcar_rh_tbl real(kind=wp), intent(in), dimension(:,:) :: aero_ocar_tbl real(kind=wp), intent(in), dimension(:,:,:) :: aero_ocar_rh_tbl Return Value character(len=128)","tags":"","loc":"type/ty_aerosol_optics_rrtmgp_merra.html"},{"title":"ty_cloud_optics_rrtmgp – RRTMGP-Fortran ","text":"type, public, extends(ty_optical_props) :: ty_cloud_optics_rrtmgp Inherits type~~ty_cloud_optics_rrtmgp~~InheritsGraph type~ty_cloud_optics_rrtmgp ty_cloud_optics_rrtmgp ty_optical_props ty_optical_props type~ty_cloud_optics_rrtmgp->ty_optical_props Help × Graph Key Nodes of different colours represent the following: Graph Key Type Type This Page's Entity This Page's Entity Solid arrows point from a derived type to the parent type which it\n extends. Dashed arrows point from a derived type to the other\n types it contains as a components, with a label listing the name(s) of\n said component(s). Contents Variables ice_nsteps ice_step_size icergh liq_nsteps liq_step_size lut_asyice lut_asyliq lut_extice lut_extliq lut_ssaice lut_ssaliq pade_asyice pade_asyliq pade_extice pade_extliq pade_sizreg_asyice pade_sizreg_asyliq pade_sizreg_extice pade_sizreg_extliq pade_sizreg_ssaice pade_sizreg_ssaliq pade_ssaice pade_ssaliq radice_lwr radice_upr radliq_lwr radliq_upr Type-Bound Procedures cloud_optics finalize get_max_radius_ice get_max_radius_liq get_min_radius_ice get_min_radius_liq get_num_ice_roughness_types load set_ice_roughness Components Type Visibility Attributes Name Initial integer, public :: ice_nsteps = 0 real(kind=wp), public :: ice_step_size = 0._wp integer, public :: icergh = 0 integer, public :: liq_nsteps = 0 real(kind=wp), public :: liq_step_size = 0._wp real(kind=wp), public, dimension(:,:,: ), allocatable :: lut_asyice real(kind=wp), public, dimension(:,: ), allocatable :: lut_asyliq real(kind=wp), public, dimension(:,:,: ), allocatable :: lut_extice real(kind=wp), public, dimension(:,: ), allocatable :: lut_extliq real(kind=wp), public, dimension(:,:,: ), allocatable :: lut_ssaice real(kind=wp), public, dimension(:,: ), allocatable :: lut_ssaliq real(kind=wp), public, dimension(:,:,:,:), allocatable :: pade_asyice real(kind=wp), public, dimension(:,:,: ), allocatable :: pade_asyliq real(kind=wp), public, dimension(:,:,:,:), allocatable :: pade_extice real(kind=wp), public, dimension(:,:,: ), allocatable :: pade_extliq real(kind=wp), public, dimension(:), allocatable :: pade_sizreg_asyice real(kind=wp), public, dimension(:), allocatable :: pade_sizreg_asyliq real(kind=wp), public, dimension(:), allocatable :: pade_sizreg_extice real(kind=wp), public, dimension(:), allocatable :: pade_sizreg_extliq real(kind=wp), public, dimension(:), allocatable :: pade_sizreg_ssaice real(kind=wp), public, dimension(:), allocatable :: pade_sizreg_ssaliq real(kind=wp), public, dimension(:,:,:,:), allocatable :: pade_ssaice real(kind=wp), public, dimension(:,:,: ), allocatable :: pade_ssaliq real(kind=wp), public :: radice_lwr = 0._wp real(kind=wp), public :: radice_upr = 0._wp real(kind=wp), public :: radliq_lwr = 0._wp real(kind=wp), public :: radliq_upr = 0._wp Type-Bound Procedures procedure, public :: cloud_optics private function cloud_optics(this, clwp, ciwp, reliq, reice, optical_props) result(error_msg) Arguments Type Intent Optional Attributes Name class( ty_cloud_optics_rrtmgp ), intent(in) :: this real(kind=wp), intent(in) :: clwp (:,:) real(kind=wp), intent(in) :: ciwp (:,:) real(kind=wp), intent(in) :: reliq (:,:) real(kind=wp), intent(in) :: reice (:,:) class(ty_optical_props_arry), intent(inout) :: optical_props Return Value character(len=128) procedure, public :: finalize private subroutine finalize(this) Arguments Type Intent Optional Attributes Name class( ty_cloud_optics_rrtmgp ), intent(inout) :: this procedure, public :: get_max_radius_ice private function get_max_radius_ice(this) result(r) Arguments Type Intent Optional Attributes Name class( ty_cloud_optics_rrtmgp ), intent(in) :: this Return Value real(kind=wp) procedure, public :: get_max_radius_liq private function get_max_radius_liq(this) result(r) Arguments Type Intent Optional Attributes Name class( ty_cloud_optics_rrtmgp ), intent(in) :: this Return Value real(kind=wp) procedure, public :: get_min_radius_ice private function get_min_radius_ice(this) result(r) Arguments Type Intent Optional Attributes Name class( ty_cloud_optics_rrtmgp ), intent(in) :: this Return Value real(kind=wp) procedure, public :: get_min_radius_liq private function get_min_radius_liq(this) result(r) Arguments Type Intent Optional Attributes Name class( ty_cloud_optics_rrtmgp ), intent(in) :: this Return Value real(kind=wp) procedure, public :: get_num_ice_roughness_types private function get_num_ice_roughness_types(this) result(i) Arguments Type Intent Optional Attributes Name class( ty_cloud_optics_rrtmgp ), intent(in) :: this Return Value integer generic, public :: load => load_lut, load_pade private function load_lut(this, band_lims_wvn, radliq_lwr, radliq_upr, radice_lwr, radice_upr, lut_extliq, lut_ssaliq, lut_asyliq, lut_extice, lut_ssaice, lut_asyice) result(error_msg) Arguments Type Intent Optional Attributes Name class( ty_cloud_optics_rrtmgp ), intent(inout) :: this real(kind=wp), intent(in), dimension(:,:) :: band_lims_wvn real(kind=wp), intent(in) :: radliq_lwr real(kind=wp), intent(in) :: radliq_upr real(kind=wp), intent(in) :: radice_lwr real(kind=wp), intent(in) :: radice_upr real(kind=wp), intent(in), dimension(:,:) :: lut_extliq real(kind=wp), intent(in), dimension(:,:) :: lut_ssaliq real(kind=wp), intent(in), dimension(:,:) :: lut_asyliq real(kind=wp), intent(in), dimension(:,:,:) :: lut_extice real(kind=wp), intent(in), dimension(:,:,:) :: lut_ssaice real(kind=wp), intent(in), dimension(:,:,:) :: lut_asyice Return Value character(len=128) private function load_pade(this, band_lims_wvn, pade_extliq, pade_ssaliq, pade_asyliq, pade_extice, pade_ssaice, pade_asyice, pade_sizreg_extliq, pade_sizreg_ssaliq, pade_sizreg_asyliq, pade_sizreg_extice, pade_sizreg_ssaice, pade_sizreg_asyice) result(error_msg) Arguments Type Intent Optional Attributes Name class( ty_cloud_optics_rrtmgp ), intent(inout) :: this real(kind=wp), intent(in), dimension(:,:) :: band_lims_wvn real(kind=wp), intent(in), dimension(:,:,:) :: pade_extliq real(kind=wp), intent(in), dimension(:,:,:) :: pade_ssaliq real(kind=wp), intent(in), dimension(:,:,:) :: pade_asyliq real(kind=wp), intent(in), dimension(:,:,:,:) :: pade_extice real(kind=wp), intent(in), dimension(:,:,:,:) :: pade_ssaice real(kind=wp), intent(in), dimension(:,:,:,:) :: pade_asyice real(kind=wp), intent(in), dimension(:) :: pade_sizreg_extliq real(kind=wp), intent(in), dimension(:) :: pade_sizreg_ssaliq real(kind=wp), intent(in), dimension(:) :: pade_sizreg_asyliq real(kind=wp), intent(in), dimension(:) :: pade_sizreg_extice real(kind=wp), intent(in), dimension(:) :: pade_sizreg_ssaice real(kind=wp), intent(in), dimension(:) :: pade_sizreg_asyice Return Value character(len=128) procedure, public :: set_ice_roughness private function set_ice_roughness(this, icergh) result(error_msg) Arguments Type Intent Optional Attributes Name class( ty_cloud_optics_rrtmgp ), intent(inout) :: this integer, intent(in) :: icergh Return Value character(len=128)","tags":"","loc":"type/ty_cloud_optics_rrtmgp.html"},{"title":"ty_gas_optics_rrtmgp – RRTMGP-Fortran ","text":"type, public, extends(ty_gas_optics) :: ty_gas_optics_rrtmgp Inherits type~~ty_gas_optics_rrtmgp~~InheritsGraph type~ty_gas_optics_rrtmgp ty_gas_optics_rrtmgp ty_gas_optics ty_gas_optics type~ty_gas_optics_rrtmgp->ty_gas_optics Help × Graph Key Nodes of different colours represent the following: Graph Key Type Type This Page's Entity This Page's Entity Solid arrows point from a derived type to the parent type which it\n extends. Dashed arrows point from a derived type to the other\n types it contains as a components, with a label listing the name(s) of\n said component(s). Contents Variables flavor gas_names gpoint_flavor idx_minor_lower idx_minor_scaling_lower idx_minor_scaling_upper idx_minor_upper is_key kmajor kminor_lower kminor_start_lower kminor_start_upper kminor_upper krayl minor_limits_gpt_lower minor_limits_gpt_upper minor_scales_with_density_lower minor_scales_with_density_upper optimal_angle_fit planck_frac press_ref press_ref_log press_ref_log_delta press_ref_max press_ref_min press_ref_trop_log scale_by_complement_lower scale_by_complement_upper solar_source solar_source_facular solar_source_quiet solar_source_sunspot temp_ref temp_ref_delta temp_ref_max temp_ref_min totplnk totplnk_delta vmr_ref Type-Bound Procedures compute_optimal_angles finalize gas_optics_ext gas_optics_int get_gases get_ngas get_press_max get_press_min get_temp_max get_temp_min is_loaded load set_solar_variability set_tsi source_is_external source_is_internal Components Type Visibility Attributes Name Initial integer, public, dimension(:,:), allocatable :: flavor character(len=32), public, dimension(:), allocatable :: gas_names integer, public, dimension(:,:), allocatable :: gpoint_flavor integer, public, dimension(:), allocatable :: idx_minor_lower integer, public, dimension(:), allocatable :: idx_minor_scaling_lower integer, public, dimension(:), allocatable :: idx_minor_scaling_upper integer, public, dimension(:), allocatable :: idx_minor_upper logical, public, dimension(:), allocatable :: is_key real(kind=wp), public, dimension(:,:,:,:), allocatable :: kmajor real(kind=wp), public, dimension(:,:,:), allocatable :: kminor_lower integer, public, dimension(:), allocatable :: kminor_start_lower integer, public, dimension(:), allocatable :: kminor_start_upper real(kind=wp), public, dimension(:,:,:), allocatable :: kminor_upper real(kind=wp), public, dimension(:,:,:,:), allocatable :: krayl integer, public, dimension(:,:), allocatable :: minor_limits_gpt_lower integer, public, dimension(:,:), allocatable :: minor_limits_gpt_upper logical(kind=wl), public, dimension(:), allocatable :: minor_scales_with_density_lower logical(kind=wl), public, dimension(:), allocatable :: minor_scales_with_density_upper real(kind=wp), public, dimension(:,:), allocatable :: optimal_angle_fit real(kind=wp), public, dimension(:,:,:,:), allocatable :: planck_frac real(kind=wp), public, dimension(:), allocatable :: press_ref real(kind=wp), public, dimension(:), allocatable :: press_ref_log real(kind=wp), public :: press_ref_log_delta real(kind=wp), public :: press_ref_max real(kind=wp), public :: press_ref_min real(kind=wp), public :: press_ref_trop_log logical(kind=wl), public, dimension(:), allocatable :: scale_by_complement_lower logical(kind=wl), public, dimension(:), allocatable :: scale_by_complement_upper real(kind=wp), public, dimension(:), allocatable :: solar_source real(kind=wp), public, dimension(:), allocatable :: solar_source_facular real(kind=wp), public, dimension(:), allocatable :: solar_source_quiet real(kind=wp), public, dimension(:), allocatable :: solar_source_sunspot real(kind=wp), public, dimension(:), allocatable :: temp_ref real(kind=wp), public :: temp_ref_delta real(kind=wp), public :: temp_ref_max real(kind=wp), public :: temp_ref_min real(kind=wp), public, dimension(:,:), allocatable :: totplnk real(kind=wp), public :: totplnk_delta real(kind=wp), public, dimension(:,:,:), allocatable :: vmr_ref Type-Bound Procedures procedure, public :: compute_optimal_angles private function compute_optimal_angles(this, optical_props, optimal_angles) result(err_msg) Compute a transport angle that minimizes flux errors at surface and TOA based on empirical fits Arguments Type Intent Optional Attributes Name class( ty_gas_optics_rrtmgp ), intent(in) :: this class(ty_optical_props_arry), intent(in) :: optical_props Optical properties real(kind=wp), intent(out), dimension(:,:) :: optimal_angles Secant of optical transport angle Return Value character(len=128) Empty if successful procedure, public :: finalize private subroutine finalize(this) Arguments Type Intent Optional Attributes Name class( ty_gas_optics_rrtmgp ), intent(inout) :: this procedure, public :: gas_optics_ext private function gas_optics_ext(this, play, plev, tlay, gas_desc, optical_props, toa_src, col_dry) result(error_msg) Compute gas optical depth given temperature, pressure, and composition\n Top-of-atmosphere stellar insolation is also reported Arguments Type Intent Optional Attributes Name class( ty_gas_optics_rrtmgp ), intent(in) :: this real(kind=wp), intent(in), dimension(:,:) :: play layer pressures [Pa, mb]; (ncol,nlay)\nlevel pressures [Pa, mb]; (ncol,nlay+1)\nlayer temperatures [K]; (ncol,nlay) real(kind=wp), intent(in), dimension(:,:) :: plev layer pressures [Pa, mb]; (ncol,nlay)\nlevel pressures [Pa, mb]; (ncol,nlay+1)\nlayer temperatures [K]; (ncol,nlay) real(kind=wp), intent(in), dimension(:,:) :: tlay layer pressures [Pa, mb]; (ncol,nlay)\nlevel pressures [Pa, mb]; (ncol,nlay+1)\nlayer temperatures [K]; (ncol,nlay) type(ty_gas_concs), intent(in) :: gas_desc Gas volume mixing ratios class(ty_optical_props_arry), intent(inout) :: optical_props real(kind=wp), intent(out), dimension(:,:) :: toa_src Incoming solar irradiance(ncol,ngpt) real(kind=wp), intent(in), optional dimension(:,:), target :: col_dry Return Value character(len=128) Empty if successful procedure, public :: gas_optics_int private function gas_optics_int(this, play, plev, tlay, tsfc, gas_desc, optical_props, sources, col_dry, tlev) result(error_msg) Compute gas optical depth and Planck source functions,\n given temperature, pressure, and composition Arguments Type Intent Optional Attributes Name class( ty_gas_optics_rrtmgp ), intent(in) :: this real(kind=wp), intent(in), dimension(:,:) :: play layer pressures [Pa, mb]; (ncol,nlay)\nlevel pressures [Pa, mb]; (ncol,nlay+1)\nlayer temperatures [K]; (ncol,nlay) real(kind=wp), intent(in), dimension(:,:) :: plev layer pressures [Pa, mb]; (ncol,nlay)\nlevel pressures [Pa, mb]; (ncol,nlay+1)\nlayer temperatures [K]; (ncol,nlay) real(kind=wp), intent(in), dimension(:,:) :: tlay layer pressures [Pa, mb]; (ncol,nlay)\nlevel pressures [Pa, mb]; (ncol,nlay+1)\nlayer temperatures [K]; (ncol,nlay) real(kind=wp), intent(in), dimension(:) :: tsfc surface skin temperatures [K]; (ncol) type(ty_gas_concs), intent(in) :: gas_desc Gas volume mixing ratios class(ty_optical_props_arry), intent(inout) :: optical_props Optical properties class(ty_source_func_lw), intent(inout) :: sources Planck sources real(kind=wp), intent(in), optional dimension(:,:), target :: col_dry Column dry amount; dim(ncol,nlay)\nlevel temperatures [K]; (ncol,nlay+1) real(kind=wp), intent(in), optional dimension(:,:), target :: tlev Column dry amount; dim(ncol,nlay)\nlevel temperatures [K]; (ncol,nlay+1) Return Value character(len=128) Empty if succssful procedure, public :: get_gases private pure function get_gases(this) return the names of the gases known to the k-distributions Arguments Type Intent Optional Attributes Name class( ty_gas_optics_rrtmgp ), intent(in) :: this Return Value character(len=32),dimension(get_ngas(this)) names of the gases known to the k-distributions procedure, public :: get_ngas private pure function get_ngas(this) Two functions to define array sizes needed by gas_optics() Arguments Type Intent Optional Attributes Name class( ty_gas_optics_rrtmgp ), intent(in) :: this Return Value integer procedure, public :: get_press_max private pure function get_press_max(this) return the maximum pressure on the interpolation grids Arguments Type Intent Optional Attributes Name class( ty_gas_optics_rrtmgp ), intent(in) :: this Return Value real(kind=wp) maximum pressure for which the k-dsitribution is valid procedure, public :: get_press_min private pure function get_press_min(this) return the minimum pressure on the interpolation grids Arguments Type Intent Optional Attributes Name class( ty_gas_optics_rrtmgp ), intent(in) :: this Return Value real(kind=wp) minimum pressure for which the k-dsitribution is valid procedure, public :: get_temp_max private pure function get_temp_max(this) return the maximum temparature on the interpolation grids Arguments Type Intent Optional Attributes Name class( ty_gas_optics_rrtmgp ), intent(in) :: this Return Value real(kind=wp) maximum temperature for which the k-dsitribution is valid procedure, public :: get_temp_min private pure function get_temp_min(this) return the minimum temparature on the interpolation grids Arguments Type Intent Optional Attributes Name class( ty_gas_optics_rrtmgp ), intent(in) :: this Return Value real(kind=wp) minimum temperature for which the k-dsitribution is valid procedure, public :: is_loaded private pure function is_loaded(this) Arguments Type Intent Optional Attributes Name class( ty_gas_optics_rrtmgp ), intent(in) :: this Return Value logical(kind=wl) generic, public :: load => load_int, load_ext private function load_int(this, available_gases, gas_names, key_species, band2gpt, band_lims_wavenum, press_ref, press_ref_trop, temp_ref, temp_ref_p, temp_ref_t, vmr_ref, kmajor, kminor_lower, kminor_upper, gas_minor, identifier_minor, minor_gases_lower, minor_gases_upper, minor_limits_gpt_lower, minor_limits_gpt_upper, minor_scales_with_density_lower, minor_scales_with_density_upper, scaling_gas_lower, scaling_gas_upper, scale_by_complement_lower, scale_by_complement_upper, kminor_start_lower, kminor_start_upper, totplnk, planck_frac, rayl_lower, rayl_upper, optimal_angle_fit) result(err_message) Arguments Type Intent Optional Attributes Name class( ty_gas_optics_rrtmgp ), intent(inout) :: this class(ty_gas_concs), intent(in) :: available_gases character(len=*), intent(in), dimension(:) :: gas_names integer, intent(in), dimension(:,:,:) :: key_species integer, intent(in), dimension(:,:) :: band2gpt real(kind=wp), intent(in), dimension(:,:) :: band_lims_wavenum real(kind=wp), intent(in), dimension(:) :: press_ref real(kind=wp), intent(in) :: press_ref_trop real(kind=wp), intent(in), dimension(:) :: temp_ref real(kind=wp), intent(in) :: temp_ref_p real(kind=wp), intent(in) :: temp_ref_t real(kind=wp), intent(in), dimension(:,:,:) :: vmr_ref real(kind=wp), intent(in), dimension(:,:,:,:) :: kmajor real(kind=wp), intent(in), dimension(:,:,:) :: kminor_lower real(kind=wp), intent(in), dimension(:,:,:) :: kminor_upper character(len=*), intent(in), dimension(:) :: gas_minor character(len=*), intent(in), dimension(:) :: identifier_minor character(len=*), intent(in), dimension(:) :: minor_gases_lower character(len=*), intent(in), dimension(:) :: minor_gases_upper integer, intent(in), dimension(:,:) :: minor_limits_gpt_lower integer, intent(in), dimension(:,:) :: minor_limits_gpt_upper logical(kind=wl), intent(in), dimension(:) :: minor_scales_with_density_lower logical(kind=wl), intent(in), dimension(:) :: minor_scales_with_density_upper character(len=*), intent(in), dimension(:) :: scaling_gas_lower character(len=*), intent(in), dimension(:) :: scaling_gas_upper logical(kind=wl), intent(in), dimension(:) :: scale_by_complement_lower logical(kind=wl), intent(in), dimension(:) :: scale_by_complement_upper integer, intent(in), dimension(:) :: kminor_start_lower integer, intent(in), dimension(:) :: kminor_start_upper real(kind=wp), intent(in), dimension(:,:) :: totplnk real(kind=wp), intent(in), dimension(:,:,:,:) :: planck_frac real(kind=wp), intent(in), dimension(:,:,:), allocatable :: rayl_lower real(kind=wp), intent(in), dimension(:,:,:), allocatable :: rayl_upper real(kind=wp), intent(in), dimension(:,:) :: optimal_angle_fit Return Value character(len=128) private function load_ext(this, available_gases, gas_names, key_species, band2gpt, band_lims_wavenum, press_ref, press_ref_trop, temp_ref, temp_ref_p, temp_ref_t, vmr_ref, kmajor, kminor_lower, kminor_upper, gas_minor, identifier_minor, minor_gases_lower, minor_gases_upper, minor_limits_gpt_lower, minor_limits_gpt_upper, minor_scales_with_density_lower, minor_scales_with_density_upper, scaling_gas_lower, scaling_gas_upper, scale_by_complement_lower, scale_by_complement_upper, kminor_start_lower, kminor_start_upper, solar_quiet, solar_facular, solar_sunspot, tsi_default, mg_default, sb_default, rayl_lower, rayl_upper) result(err_message) Arguments Type Intent Optional Attributes Name class( ty_gas_optics_rrtmgp ), intent(inout) :: this class(ty_gas_concs), intent(in) :: available_gases character(len=*), intent(in), dimension(:) :: gas_names integer, intent(in), dimension(:,:,:) :: key_species integer, intent(in), dimension(:,:) :: band2gpt real(kind=wp), intent(in), dimension(:,:) :: band_lims_wavenum real(kind=wp), intent(in), dimension(:) :: press_ref real(kind=wp), intent(in) :: press_ref_trop real(kind=wp), intent(in), dimension(:) :: temp_ref real(kind=wp), intent(in) :: temp_ref_p real(kind=wp), intent(in) :: temp_ref_t real(kind=wp), intent(in), dimension(:,:,:) :: vmr_ref real(kind=wp), intent(in), dimension(:,:,:,:) :: kmajor real(kind=wp), intent(in), dimension(:,:,:) :: kminor_lower real(kind=wp), intent(in), dimension(:,:,:) :: kminor_upper character(len=*), intent(in), dimension(:) :: gas_minor character(len=*), intent(in), dimension(:) :: identifier_minor character(len=*), intent(in), dimension(:) :: minor_gases_lower character(len=*), intent(in), dimension(:) :: minor_gases_upper integer, intent(in), dimension(:,:) :: minor_limits_gpt_lower integer, intent(in), dimension(:,:) :: minor_limits_gpt_upper logical(kind=wl), intent(in), dimension(:) :: minor_scales_with_density_lower logical(kind=wl), intent(in), dimension(:) :: minor_scales_with_density_upper character(len=*), intent(in), dimension(:) :: scaling_gas_lower character(len=*), intent(in), dimension(:) :: scaling_gas_upper logical(kind=wl), intent(in), dimension(:) :: scale_by_complement_lower logical(kind=wl), intent(in), dimension(:) :: scale_by_complement_upper integer, intent(in), dimension(:) :: kminor_start_lower integer, intent(in), dimension(:) :: kminor_start_upper real(kind=wp), intent(in), dimension(:) :: solar_quiet real(kind=wp), intent(in), dimension(:) :: solar_facular real(kind=wp), intent(in), dimension(:) :: solar_sunspot real(kind=wp), intent(in) :: tsi_default real(kind=wp), intent(in) :: mg_default real(kind=wp), intent(in) :: sb_default real(kind=wp), intent(in), dimension(:,:,:), allocatable :: rayl_lower real(kind=wp), intent(in), dimension(:,:,:), allocatable :: rayl_upper Return Value character(len=128) procedure, public :: set_solar_variability private function set_solar_variability(this, mg_index, sb_index, tsi) result(error_msg) Compute the spectral solar source function adjusted to account for solar variability\n following the NRLSSI2 model of Coddington et al. 2016, doi:10.1175/BAMS-D-14-00265.1.\nas specified by the facular brightening (mg_index) and sunspot dimming (sb_index)\nindices provided as input. Read more… Arguments Type Intent Optional Attributes Name class( ty_gas_optics_rrtmgp ), intent(inout) :: this real(kind=wp), intent(in) :: mg_index facular brightening index (NRLSSI2 facular \"Bremen\" index) real(kind=wp), intent(in) :: sb_index sunspot dimming index (NRLSSI2 sunspot \"SPOT67\" index) real(kind=wp), intent(in), optional :: tsi total solar irradiance Return Value character(len=128) Empty if successful procedure, public :: set_tsi private function set_tsi(this, tsi) result(error_msg) Arguments Type Intent Optional Attributes Name class( ty_gas_optics_rrtmgp ), intent(inout) :: this Scale the solar source function without changing the spectral distribution real(kind=wp), intent(in) :: tsi user-specified total solar irradiance; Return Value character(len=128) Empty if successful procedure, public :: source_is_external private pure function source_is_external(this) return true if initialized for external sources/shortwave, false otherwise Arguments Type Intent Optional Attributes Name class( ty_gas_optics_rrtmgp ), intent(in) :: this Return Value logical procedure, public :: source_is_internal private pure function source_is_internal(this) return true if initialized for internal sources/longwave, false otherwise Arguments Type Intent Optional Attributes Name class( ty_gas_optics_rrtmgp ), intent(in) :: this Return Value logical","tags":"","loc":"type/ty_gas_optics_rrtmgp.html"},{"title":"pade_eval – RRTMGP-Fortran","text":"public interface pade_eval Contents Module Procedures pade_eval_nbnd pade_eval_1 Module Procedures private function pade_eval_nbnd(nbnd, nrads, m, n, irad, re, pade_coeffs) Arguments Type Intent Optional Attributes Name integer, intent(in) :: nbnd integer, intent(in) :: nrads integer, intent(in) :: m integer, intent(in) :: n integer, intent(in) :: irad real(kind=wp), intent(in) :: re real(kind=wp), intent(in), dimension(nbnd, nrads, 0:m+n) :: pade_coeffs Return Value real(kind=wp),dimension(nbnd) private function pade_eval_1(iband, nbnd, nrads, m, n, irad, re, pade_coeffs) Arguments Type Intent Optional Attributes Name integer, intent(in) :: iband integer, intent(in) :: nbnd integer, intent(in) :: nrads integer, intent(in) :: m integer, intent(in) :: n integer, intent(in) :: irad real(kind=wp), intent(in) :: re real(kind=wp), intent(in), dimension(nbnd, nrads, 0:m+n) :: pade_coeffs Return Value real(kind=wp)","tags":"","loc":"interface/pade_eval.html"},{"title":"get_col_dry – RRTMGP-Fortran","text":"public function get_col_dry(vmr_h2o, plev, latitude) result(col_dry) Utility function, provided for user convenience\ncomputes column amounts of dry air using hydrostatic equation Arguments Type Intent Optional Attributes Name real(kind=wp), intent(in), dimension(:,:) :: vmr_h2o real(kind=wp), intent(in), dimension(:,:) :: plev real(kind=wp), intent(in), optional dimension(:) :: latitude Return Value real(kind=wp),dimension(size(plev,dim=1),size(plev,dim=2)-1) Contents None","tags":"","loc":"proc/get_col_dry.html"},{"title":"mo_aerosol_optics_rrtmgp_merra – RRTMGP-Fortran","text":"Uses mo_rte_config mo_rte_kind mo_optical_props mo_rte_util_array_validation module~~mo_aerosol_optics_rrtmgp_merra~~UsesGraph module~mo_aerosol_optics_rrtmgp_merra mo_aerosol_optics_rrtmgp_merra mo_rte_config mo_rte_config module~mo_aerosol_optics_rrtmgp_merra->mo_rte_config mo_rte_kind mo_rte_kind module~mo_aerosol_optics_rrtmgp_merra->mo_rte_kind mo_optical_props mo_optical_props module~mo_aerosol_optics_rrtmgp_merra->mo_optical_props mo_rte_util_array_validation mo_rte_util_array_validation module~mo_aerosol_optics_rrtmgp_merra->mo_rte_util_array_validation Help × Graph Key Nodes of different colours represent the following: Graph Key Module Module Submodule Submodule Subroutine Subroutine Function Function Program Program This Page's Entity This Page's Entity Solid arrows point from a submodule to the (sub)module which it is\n descended from. Dashed arrows point from a module or program unit to \n modules which it uses. Contents Variables merra_aero_bcar merra_aero_bcar_rh merra_aero_dust merra_aero_none merra_aero_ocar merra_aero_ocar_rh merra_aero_salt merra_aero_sulf merra_ntype Derived Types ty_aerosol_optics_rrtmgp_merra Variables Type Visibility Attributes Name Initial integer, public, parameter :: merra_aero_bcar = 5 integer, public, parameter :: merra_aero_bcar_rh = 4 integer, public, parameter :: merra_aero_dust = 1 integer, public, parameter :: merra_aero_none = 0 integer, public, parameter :: merra_aero_ocar = 7 integer, public, parameter :: merra_aero_ocar_rh = 6 integer, public, parameter :: merra_aero_salt = 2 integer, public, parameter :: merra_aero_sulf = 3 integer, public, parameter :: merra_ntype = 7 Derived Types type, public, extends(ty_optical_props) :: ty_aerosol_optics_rrtmgp_merra Components Type Visibility Attributes Name Initial real(kind=wp), public, dimension(:,:,: ), allocatable :: aero_bcar_rh_tbl real(kind=wp), public, dimension(:,: ), allocatable :: aero_bcar_tbl real(kind=wp), public, dimension(:,:,: ), allocatable :: aero_dust_tbl real(kind=wp), public, dimension(:,:,: ), allocatable :: aero_ocar_rh_tbl real(kind=wp), public, dimension(:,: ), allocatable :: aero_ocar_tbl real(kind=wp), public, dimension(:), allocatable :: aero_rh (:) real(kind=wp), public, dimension(:,:,:,:), allocatable :: aero_salt_tbl real(kind=wp), public, dimension(:,:,: ), allocatable :: aero_sulf_tbl real(kind=wp), public, dimension(:,:), allocatable :: merra_aero_bin_lims Type-Bound Procedures procedure, public :: aerosol_optics procedure, public :: finalize generic, public :: load => load_lut","tags":"","loc":"module/mo_aerosol_optics_rrtmgp_merra.html"},{"title":"mo_cloud_optics_rrtmgp – RRTMGP-Fortran","text":"Uses mo_rte_config mo_rte_kind mo_optical_props mo_rte_util_array_validation module~~mo_cloud_optics_rrtmgp~~UsesGraph module~mo_cloud_optics_rrtmgp mo_cloud_optics_rrtmgp mo_rte_config mo_rte_config module~mo_cloud_optics_rrtmgp->mo_rte_config mo_rte_kind mo_rte_kind module~mo_cloud_optics_rrtmgp->mo_rte_kind mo_optical_props mo_optical_props module~mo_cloud_optics_rrtmgp->mo_optical_props mo_rte_util_array_validation mo_rte_util_array_validation module~mo_cloud_optics_rrtmgp->mo_rte_util_array_validation Help × Graph Key Nodes of different colours represent the following: Graph Key Module Module Submodule Submodule Subroutine Subroutine Function Function Program Program This Page's Entity This Page's Entity Solid arrows point from a submodule to the (sub)module which it is\n descended from. Dashed arrows point from a module or program unit to \n modules which it uses. Contents Interfaces pade_eval Derived Types ty_cloud_optics_rrtmgp Interfaces public interface pade_eval private function pade_eval_nbnd(nbnd, nrads, m, n, irad, re, pade_coeffs) Arguments Type Intent Optional Attributes Name integer, intent(in) :: nbnd integer, intent(in) :: nrads integer, intent(in) :: m integer, intent(in) :: n integer, intent(in) :: irad real(kind=wp), intent(in) :: re real(kind=wp), intent(in), dimension(nbnd, nrads, 0:m+n) :: pade_coeffs Return Value real(kind=wp),dimension(nbnd) private function pade_eval_1(iband, nbnd, nrads, m, n, irad, re, pade_coeffs) Arguments Type Intent Optional Attributes Name integer, intent(in) :: iband integer, intent(in) :: nbnd integer, intent(in) :: nrads integer, intent(in) :: m integer, intent(in) :: n integer, intent(in) :: irad real(kind=wp), intent(in) :: re real(kind=wp), intent(in), dimension(nbnd, nrads, 0:m+n) :: pade_coeffs Return Value real(kind=wp) Derived Types type, public, extends(ty_optical_props) :: ty_cloud_optics_rrtmgp Components Type Visibility Attributes Name Initial integer, public :: ice_nsteps = 0 real(kind=wp), public :: ice_step_size = 0._wp integer, public :: icergh = 0 integer, public :: liq_nsteps = 0 real(kind=wp), public :: liq_step_size = 0._wp real(kind=wp), public, dimension(:,:,: ), allocatable :: lut_asyice real(kind=wp), public, dimension(:,: ), allocatable :: lut_asyliq real(kind=wp), public, dimension(:,:,: ), allocatable :: lut_extice real(kind=wp), public, dimension(:,: ), allocatable :: lut_extliq real(kind=wp), public, dimension(:,:,: ), allocatable :: lut_ssaice real(kind=wp), public, dimension(:,: ), allocatable :: lut_ssaliq real(kind=wp), public, dimension(:,:,:,:), allocatable :: pade_asyice real(kind=wp), public, dimension(:,:,: ), allocatable :: pade_asyliq real(kind=wp), public, dimension(:,:,:,:), allocatable :: pade_extice real(kind=wp), public, dimension(:,:,: ), allocatable :: pade_extliq real(kind=wp), public, dimension(:), allocatable :: pade_sizreg_asyice real(kind=wp), public, dimension(:), allocatable :: pade_sizreg_asyliq real(kind=wp), public, dimension(:), allocatable :: pade_sizreg_extice real(kind=wp), public, dimension(:), allocatable :: pade_sizreg_extliq real(kind=wp), public, dimension(:), allocatable :: pade_sizreg_ssaice real(kind=wp), public, dimension(:), allocatable :: pade_sizreg_ssaliq real(kind=wp), public, dimension(:,:,:,:), allocatable :: pade_ssaice real(kind=wp), public, dimension(:,:,: ), allocatable :: pade_ssaliq real(kind=wp), public :: radice_lwr = 0._wp real(kind=wp), public :: radice_upr = 0._wp real(kind=wp), public :: radliq_lwr = 0._wp real(kind=wp), public :: radliq_upr = 0._wp Type-Bound Procedures procedure, public :: cloud_optics procedure, public :: finalize procedure, public :: get_max_radius_ice procedure, public :: get_max_radius_liq procedure, public :: get_min_radius_ice procedure, public :: get_min_radius_liq procedure, public :: get_num_ice_roughness_types generic, public :: load => load_lut, load_pade procedure, public :: set_ice_roughness","tags":"","loc":"module/mo_cloud_optics_rrtmgp.html"},{"title":"mo_gas_optics_rrtmgp – RRTMGP-Fortran","text":"Class implementing the RRTMGP correlated- k distribution Implements a class for computing spectrally-resolved gas optical properties and source functions\n given atmopsheric physical properties (profiles of temperature, pressure, and gas concentrations)\n The class must be initialized with data (provided as a netCDF file) before being used. Two variants apply to internal Planck sources (longwave radiation in the Earth's atmosphere) and to\n external stellar radiation (shortwave radiation in the Earth's atmosphere).\n The variant is chosen based on what information is supplied during initialization.\ncol_dry is the number of molecules per cm-2 of dry air Uses mo_rte_config mo_gas_optics_rrtmgp_kernels mo_rte_util_array mo_gas_optics_util_string mo_gas_concentrations mo_gas_optics mo_rte_kind mo_gas_optics_constants mo_rte_util_array_validation mo_optical_props mo_source_functions module~~mo_gas_optics_rrtmgp~~UsesGraph module~mo_gas_optics_rrtmgp mo_gas_optics_rrtmgp mo_rte_config mo_rte_config module~mo_gas_optics_rrtmgp->mo_rte_config mo_gas_optics mo_gas_optics module~mo_gas_optics_rrtmgp->mo_gas_optics mo_gas_optics_rrtmgp_kernels mo_gas_optics_rrtmgp_kernels module~mo_gas_optics_rrtmgp->mo_gas_optics_rrtmgp_kernels mo_optical_props mo_optical_props module~mo_gas_optics_rrtmgp->mo_optical_props mo_gas_optics_util_string mo_gas_optics_util_string module~mo_gas_optics_rrtmgp->mo_gas_optics_util_string mo_source_functions mo_source_functions module~mo_gas_optics_rrtmgp->mo_source_functions mo_rte_util_array mo_rte_util_array module~mo_gas_optics_rrtmgp->mo_rte_util_array mo_gas_concentrations mo_gas_concentrations module~mo_gas_optics_rrtmgp->mo_gas_concentrations mo_rte_kind mo_rte_kind module~mo_gas_optics_rrtmgp->mo_rte_kind mo_gas_optics_constants mo_gas_optics_constants module~mo_gas_optics_rrtmgp->mo_gas_optics_constants mo_rte_util_array_validation mo_rte_util_array_validation module~mo_gas_optics_rrtmgp->mo_rte_util_array_validation Help × Graph Key Nodes of different colours represent the following: Graph Key Module Module Submodule Submodule Subroutine Subroutine Function Function Program Program This Page's Entity This Page's Entity Solid arrows point from a submodule to the (sub)module which it is\n descended from. Dashed arrows point from a module or program unit to \n modules which it uses. Contents Derived Types ty_gas_optics_rrtmgp Functions get_col_dry Derived Types type, public, extends(ty_gas_optics) :: ty_gas_optics_rrtmgp Components Type Visibility Attributes Name Initial integer, public, dimension(:,:), allocatable :: flavor character(len=32), public, dimension(:), allocatable :: gas_names integer, public, dimension(:,:), allocatable :: gpoint_flavor integer, public, dimension(:), allocatable :: idx_minor_lower integer, public, dimension(:), allocatable :: idx_minor_scaling_lower integer, public, dimension(:), allocatable :: idx_minor_scaling_upper integer, public, dimension(:), allocatable :: idx_minor_upper logical, public, dimension(:), allocatable :: is_key real(kind=wp), public, dimension(:,:,:,:), allocatable :: kmajor real(kind=wp), public, dimension(:,:,:), allocatable :: kminor_lower integer, public, dimension(:), allocatable :: kminor_start_lower integer, public, dimension(:), allocatable :: kminor_start_upper real(kind=wp), public, dimension(:,:,:), allocatable :: kminor_upper real(kind=wp), public, dimension(:,:,:,:), allocatable :: krayl integer, public, dimension(:,:), allocatable :: minor_limits_gpt_lower integer, public, dimension(:,:), allocatable :: minor_limits_gpt_upper logical(kind=wl), public, dimension(:), allocatable :: minor_scales_with_density_lower logical(kind=wl), public, dimension(:), allocatable :: minor_scales_with_density_upper real(kind=wp), public, dimension(:,:), allocatable :: optimal_angle_fit real(kind=wp), public, dimension(:,:,:,:), allocatable :: planck_frac real(kind=wp), public, dimension(:), allocatable :: press_ref real(kind=wp), public, dimension(:), allocatable :: press_ref_log real(kind=wp), public :: press_ref_log_delta real(kind=wp), public :: press_ref_max real(kind=wp), public :: press_ref_min real(kind=wp), public :: press_ref_trop_log logical(kind=wl), public, dimension(:), allocatable :: scale_by_complement_lower logical(kind=wl), public, dimension(:), allocatable :: scale_by_complement_upper real(kind=wp), public, dimension(:), allocatable :: solar_source real(kind=wp), public, dimension(:), allocatable :: solar_source_facular real(kind=wp), public, dimension(:), allocatable :: solar_source_quiet real(kind=wp), public, dimension(:), allocatable :: solar_source_sunspot real(kind=wp), public, dimension(:), allocatable :: temp_ref real(kind=wp), public :: temp_ref_delta real(kind=wp), public :: temp_ref_max real(kind=wp), public :: temp_ref_min real(kind=wp), public, dimension(:,:), allocatable :: totplnk real(kind=wp), public :: totplnk_delta real(kind=wp), public, dimension(:,:,:), allocatable :: vmr_ref Type-Bound Procedures procedure, public :: compute_optimal_angles procedure, public :: finalize procedure, public :: gas_optics_ext procedure, public :: gas_optics_int procedure, public :: get_gases procedure, public :: get_ngas procedure, public :: get_press_max procedure, public :: get_press_min procedure, public :: get_temp_max procedure, public :: get_temp_min procedure, public :: is_loaded generic, public :: load => load_int, load_ext procedure, public :: set_solar_variability procedure, public :: set_tsi procedure, public :: source_is_external procedure, public :: source_is_internal Functions public function get_col_dry (vmr_h2o, plev, latitude) result(col_dry) Utility function, provided for user convenience\ncomputes column amounts of dry air using hydrostatic equation Arguments Type Intent Optional Attributes Name real(kind=wp), intent(in), dimension(:,:) :: vmr_h2o real(kind=wp), intent(in), dimension(:,:) :: plev real(kind=wp), intent(in), optional dimension(:) :: latitude Return Value real(kind=wp),dimension(size(plev,dim=1),size(plev,dim=2)-1)","tags":"","loc":"module/mo_gas_optics_rrtmgp.html"},{"title":"mo_aerosol_optics_rrtmgp_merra.F90 – RRTMGP-Fortran","text":"Contents Modules mo_aerosol_optics_rrtmgp_merra Source Code mo_aerosol_optics_rrtmgp_merra.F90 Source Code ! This code is part of Radiative Transfer for Energetics (RTE) ! ! Contacts: Robert Pincus and Eli Mlawer ! email: rrtmgp@aer.com ! ! Copyright 2015-2018, Atmospheric and Environmental Research and ! Regents of the University of Colorado. All right reserved. ! ! Use and duplication is permitted under the terms of the ! BSD 3-clause license, see http://opensource.org/licenses/BSD-3-Clause ! ------------------------------------------------------------------------------------------------- ! Provides aerosol optical properties as a function of aerosol size (radius), aerosol mass, ! and relative humidity for the RRTMGP spectral bands. ! Based on climatoligical aerosol optical properties used in MERRA2 as derived from the ! GOCART model for 15 aerosol types, including dust and sea salt each for five size bins, ! one sulfate type, and both hydrophobic and hydrophilic black carbon and organic carbon. ! Input aerosol optical data are stored in look-up tables. ! ! References for the gocart interactive aerosols: ! Chin et al., jgr, 2000 (https://doi.org/10.1029/2000jd900384) ! Chin et al., jas, 2002 (https://doi.org/10.1175/1520-0469(2002)059<0461:TAOTFT>2.0.CO;2) ! Colarco et al., jgr, 2010 (https://doi.org/10.1029/2009jd012820) ! ! References for merra2 aerosol reanalysis: ! Randles et al., j. clim., 2017 (https://doi.org/10.1175/jcli-d-16-0609.1) ! Buchard et al., j. clim., 2017 (https://doi.org/10.1175/jcli-d-16-0613.1) ! ! The class can be used as-is but is also intended as an example of how to extend the RTE framework ! ------------------------------------------------------------------------------------------------- module mo_aerosol_optics_rrtmgp_merra use mo_rte_kind , only : wp , wl use mo_rte_config , only : check_extents , check_values use mo_rte_util_array_validation ,& only : extents_are , any_vals_outside use mo_optical_props , only : ty_optical_props , & ty_optical_props_arry , & ty_optical_props_1scl , & ty_optical_props_2str , & ty_optical_props_nstr implicit none ! MERRA2/GOCART aerosol types integer , parameter , public :: merra_ntype = 7 ! Number of MERRA aerosol types integer , parameter , public :: merra_aero_none = 0 ! no aerosal integer , parameter , public :: merra_aero_dust = 1 ! dust integer , parameter , public :: merra_aero_salt = 2 ! Salt integer , parameter , public :: merra_aero_sulf = 3 ! sulfate integer , parameter , public :: merra_aero_bcar_rh = 4 ! black carbon, hydrophilic integer , parameter , public :: merra_aero_bcar = 5 ! black carbon, hydrophobic integer , parameter , public :: merra_aero_ocar_rh = 6 ! organic carbon, hydrophilic integer , parameter , public :: merra_aero_ocar = 7 ! organic carbon, hydrophobic ! index identifiers for aerosol optical property tables integer , parameter , private :: ext = 1 ! extinction integer , parameter , private :: ssa = 2 ! single scattering albedo integer , parameter , private :: g = 3 ! asymmetry parameter private ! ----------------------------------------------------------------------------------- type , extends ( ty_optical_props ), public :: ty_aerosol_optics_rrtmgp_merra private ! ! Lookup table information ! ! Table upper and lower aerosol size (radius) bin limits (microns) real ( wp ), dimension (:,:), allocatable :: merra_aero_bin_lims ! Dimensions (pair,nbin) ! Table relative humidity values real ( wp ), dimension (:), allocatable :: aero_rh (:) ! ! The aerosol tables themselves. ! extinction (m2/kg) ! single scattering albedo (unitless) ! asymmetry parameter (unitless) ! real ( wp ), dimension (:,:,: ), allocatable :: aero_dust_tbl ! ext, ssa, g (nval, nbin, nbnd) real ( wp ), dimension (:,:,:,:), allocatable :: aero_salt_tbl ! ext, ssa, g (nval, nrh, nbin, nbnd) real ( wp ), dimension (:,:,: ), allocatable :: aero_sulf_tbl ! ext, ssa, g (nval, nrh, nbnd) real ( wp ), dimension (:,: ), allocatable :: aero_bcar_tbl ! ext, ssa, g (nval, nbnd) real ( wp ), dimension (:,:,: ), allocatable :: aero_bcar_rh_tbl ! ext, ssa, g (nval, nrh, nbnd) real ( wp ), dimension (:,: ), allocatable :: aero_ocar_tbl ! ext, ssa, g (nval, nbnd) real ( wp ), dimension (:,:,: ), allocatable :: aero_ocar_rh_tbl ! ext, ssa, g (nval, nrh, nbnd) ! ! ----- contains generic , public :: load => load_lut procedure , public :: finalize procedure , public :: aerosol_optics ! Internal procedures procedure , private :: load_lut end type ty_aerosol_optics_rrtmgp_merra contains ! ------------------------------------------------------------------------------ ! ! Routines to load data needed for aerosol optics calculations from lookup-tables. ! ! ------------------------------------------------------------------------------ function load_lut ( this , band_lims_wvn , & merra_aero_bin_lims , aero_rh , & aero_dust_tbl , aero_salt_tbl , aero_sulf_tbl , & aero_bcar_tbl , aero_bcar_rh_tbl , & aero_ocar_tbl , aero_ocar_rh_tbl ) & result ( error_msg ) class ( ty_aerosol_optics_rrtmgp_merra ), & intent ( inout ) :: this real ( wp ), dimension (:,:), intent ( in ) :: band_lims_wvn ! spectral discretization ! Lookup table interpolation constants real ( wp ), dimension (:,:), intent ( in ) :: merra_aero_bin_lims ! aerosol lut size bin limiits (pair,nbin) real ( wp ), dimension (:), intent ( in ) :: aero_rh ! relative humidity LUT dimension values ! LUT coefficients ! Extinction, single-scattering albedo, and asymmetry parameter for aerosol types real ( wp ), dimension (:,:,:), intent ( in ) :: aero_dust_tbl real ( wp ), dimension (:,:,:,:), intent ( in ) :: aero_salt_tbl real ( wp ), dimension (:,:,:), intent ( in ) :: aero_sulf_tbl real ( wp ), dimension (:,:), intent ( in ) :: aero_bcar_tbl real ( wp ), dimension (:,:,:), intent ( in ) :: aero_bcar_rh_tbl real ( wp ), dimension (:,:), intent ( in ) :: aero_ocar_tbl real ( wp ), dimension (:,:,:), intent ( in ) :: aero_ocar_rh_tbl character ( len = 128 ) :: error_msg ! ------- ! ! Local variables ! integer :: npair , nval , nrh , nbin , nband error_msg = this % init ( band_lims_wvn , name = \"RRTMGP aerosol optics\" ) ! ! LUT coefficient dimensions ! npair = size ( merra_aero_bin_lims , dim = 1 ) nval = size ( aero_salt_tbl , dim = 1 ) nrh = size ( aero_salt_tbl , dim = 2 ) nbin = size ( aero_salt_tbl , dim = 3 ) nband = size ( aero_salt_tbl , dim = 4 ) ! ! Error checking ! if ( check_extents ) then error_msg = '' if (. not . extents_are ( aero_dust_tbl , nval , nbin , nband )) & error_msg = \"aerosol_optics%load_lut(): array aero_dust_tbl isn't consistently sized\" if (. not . extents_are ( aero_salt_tbl , nval , nrh , nbin , nband )) & error_msg = \"aerosol_optics%load_lut(): array aero_salt_tbl isn't consistently sized\" if (. not . extents_are ( aero_sulf_tbl , nval , nrh , nband )) & error_msg = \"aerosol_optics%load_lut(): array aero_sulf_tbl isn't consistently sized\" if (. not . extents_are ( aero_bcar_rh_tbl , nval , nrh , nband )) & error_msg = \"aerosol_optics%load_lut(): array aero_bcar_rh_tbl isn't consistently sized\" if (. not . extents_are ( aero_bcar_tbl , nval , nband )) & error_msg = \"aerosol_optics%load_lut(): array aero_bcar_tbl isn't consistently sized\" if (. not . extents_are ( aero_ocar_rh_tbl , nval , nrh , nband )) & error_msg = \"aerosol_optics%load_lut(): array aero_ocar_rh_tbl isn't consistently sized\" if (. not . extents_are ( aero_ocar_tbl , nval , nband )) & error_msg = \"aerosol_optics%load_lut(): array aero_ocar_tbl isn't consistently sized\" if ( error_msg /= \"\" ) return endif ! Allocate LUT parameters allocate ( this % merra_aero_bin_lims ( npair , nbin )) allocate ( this % aero_rh ( nrh )) ! Allocate LUT coefficients allocate ( this % aero_dust_tbl ( nval , nbin , nband ), & this % aero_salt_tbl ( nrh , nval , nbin , nband ), & this % aero_sulf_tbl ( nrh , nval , nband ), & this % aero_bcar_tbl ( nval , nband ), & this % aero_bcar_rh_tbl ( nrh , nval , nband ), & this % aero_ocar_tbl ( nval , nband ), & this % aero_ocar_rh_tbl ( nrh , nval , nband )) ! Copy LUT coefficients this % merra_aero_bin_lims = merra_aero_bin_lims this % aero_rh = aero_rh this % aero_dust_tbl = aero_dust_tbl this % aero_bcar_tbl = aero_bcar_tbl this % aero_ocar_tbl = aero_ocar_tbl this % aero_salt_tbl = reshape ( aero_salt_tbl , shape = ( / nrh , nval , nbin , nband / ), order = ( / 2 , 1 , 3 , 4 / ) ) this % aero_sulf_tbl = reshape ( aero_sulf_tbl , shape = ( / nrh , nval , nband / ), order = ( / 2 , 1 , 3 / ) ) this % aero_bcar_rh_tbl = reshape ( aero_bcar_rh_tbl , shape = ( / nrh , nval , nband / ), order = ( / 2 , 1 , 3 / ) ) this % aero_ocar_rh_tbl = reshape ( aero_ocar_rh_tbl , shape = ( / nrh , nval , nband / ), order = ( / 2 , 1 , 3 / ) ) !$acc enter data create(this) & !$acc copyin(this%aero_dust_tbl, this%aero_salt_tbl, this%aero_sulf_tbl) & !$acc copyin(this%aero_bcar_tbl, this%aero_bcar_rh_tbl) & !$acc copyin(this%aero_ocar_tbl, this%aero_ocar_rh_tbl) & !$acc copyin(this%merra_aero_bin_lims, this%aero_rh) !$omp target enter data & !$omp map(to:this%aero_dust_tbl, this%aero_salt_tbl, this%aero_sulf_tbl) & !$omp map(to:this%aero_bcar_tbl, this%aero_bcar_rh_tbl) & !$omp map(to:this%aero_ocar_tbl, this%aero_ocar_rh_tbl) & !$omp map(to:this%merra_aero_bin_lims, this%aero_rh) end function load_lut !-------------------------------------------------------------------------------------------------------------------- ! ! Finalize ! !-------------------------------------------------------------------------------------------------------------------- subroutine finalize ( this ) class ( ty_aerosol_optics_rrtmgp_merra ), intent ( inout ) :: this ! Lookup table aerosol optics interpolation arrays if ( allocated ( this % merra_aero_bin_lims )) then deallocate ( this % merra_aero_bin_lims , this % aero_rh ) !$acc exit data delete( this%merra_aero_bin_lims, this%aero_rh) !$omp target exit data map(release:this%merra_aero_bin_lims, this%aero_rh) end if ! Lookup table aerosol optics coefficients if ( allocated ( this % aero_dust_tbl )) then !$acc exit data delete(this%aero_dust_tbl, this%aero_salt_tbl, this%aero_sulf_tbl) & !$acc delete(this%aero_bcar_tbl, this%aero_bcar_rh_tbl) & !$acc delete(this%aero_ocar_tbl, this%aero_ocar_rh_tbl) & !$acc delete(this) !$omp target exit data map(release:this%aero_dust_tbl, this%aero_salt_tbl, this%aero_sulf_tbl) & !$omp map(release:this%aero_bcar_tbl, this%aero_bcar_rh_tbl) & !$omp map(release:this%aero_ocar_tbl, this%aero_ocar_rh_tbl) deallocate ( this % aero_dust_tbl , this % aero_salt_tbl , this % aero_sulf_tbl , & this % aero_bcar_tbl , this % aero_bcar_rh_tbl , & this % aero_ocar_tbl , this % aero_ocar_rh_tbl ) end if end subroutine finalize ! ------------------------------------------------------------------------------ ! ! Derive aerosol optical properties from provided aerosol input properties ! ! ------------------------------------------------------------------------------ ! ! Compute single-scattering properties ! function aerosol_optics ( this , aero_type , aero_size , aero_mass , relhum , & optical_props ) result ( error_msg ) class ( ty_aerosol_optics_rrtmgp_merra ), & intent ( in ) :: this integer , intent ( in ) :: aero_type (:,:) ! MERRA2/GOCART aerosol type ! Dimensions: (ncol,nlay) ! 1 = merra_aero_dust (dust) ! 2 = merra_aero_salt (salt) ! 3 = merra_aero_sulf (sulfate) ! 4 = merra_aero_bcar_rh (black carbon, hydrophilic) ! 5 = merra_aero_bcar (black carbon, hydrophobic) ! 6 = merra_aero_ocar_rh (organic carbon, hydrophilic) ! 7 = merra_aero_ocar (organic carbon, hydrophobic) real ( wp ), intent ( in ) :: aero_size (:,:) ! aerosol size (radius) for dust and sea-salt (microns) ! Dimensions: (ncol,nlay) real ( wp ), intent ( in ) :: aero_mass (:,:) ! aerosol mass column (kg/m2) ! Dimensions: (ncol,nlay) real ( wp ), intent ( in ) :: relhum (:,:) ! relative humidity (fraction, 0-1) ! Dimensions: (ncol,nlay) class ( ty_optical_props_arry ), & intent ( inout ) :: optical_props ! Dimensions: (ncol,nlay,nbnd) character ( len = 128 ) :: error_msg ! ------- Local ------- logical ( wl ), dimension ( size ( aero_type , 1 ), size ( aero_type , 2 )) :: aeromsk real ( wp ), dimension ( size ( aero_type , 1 ), size ( aero_type , 2 ), size ( this % aero_dust_tbl , 3 )) :: & atau , ataussa , ataussag integer :: ncol , nlay , npair , nbin , nrh , nval , nbnd integer :: icol , ilay , ibnd , ibin ! scalars for total tau, tau*ssa real ( wp ) :: tau , taussa ! Scalars to work around OpenACC/OMP issues real ( wp ) :: minSize , maxSize ! ---------------------------------------- ! ! Error checking ! ! ---------------------------------------- error_msg = '' if (. not .( allocated ( this % aero_dust_tbl ))) then error_msg = 'aerosol optics: no data has been initialized' return end if ncol = size ( aero_type , 1 ) nlay = size ( aero_type , 2 ) npair = size ( this % merra_aero_bin_lims , 1 ) nbin = size ( this % merra_aero_bin_lims , 2 ) nrh = size ( this % aero_rh , 1 ) nval = size ( this % aero_dust_tbl , 1 ) nbnd = size ( this % aero_dust_tbl , 3 ) !$acc update host(this%merra_aero_bin_lims) !$omp target update from(this%merra_aero_bin_lims) minSize = this % merra_aero_bin_lims ( 1 , 1 ) maxSize = this % merra_aero_bin_lims ( 2 , nbin ) ! ! Array sizes ! if ( check_extents ) then error_msg = '' if (. not . extents_are ( aero_type , ncol , nlay )) & error_msg = \"aerosol optics: aero_type isn't consistenly sized\" if (. not . extents_are ( aero_size , ncol , nlay )) & error_msg = \"aerosol optics: aero_size isn't consistenly sized\" if (. not . extents_are ( aero_mass , ncol , nlay )) & error_msg = \"aerosol optics: aero_mass isn't consistenly sized\" if (. not . extents_are ( relhum , ncol , nlay )) & error_msg = \"aerosol optics: relhum isn't consistenly sized\" if ( optical_props % get_ncol () /= ncol . or . optical_props % get_nlay () /= nlay ) & error_msg = \"aerosol optics: optical_props have wrong extents\" if ( error_msg /= \"\" ) return end if ! ! Spectral consistency ! if ( check_values ) then if (. not . this % bands_are_equal ( optical_props )) & error_msg = \"aerosol optics: optical properties don't have the same band structure\" if ( optical_props % get_nband () /= optical_props % get_ngpt () ) & error_msg = \"aerosol optics: optical properties must be requested by band not g-points\" if ( any_int_vals_outside_2D ( aero_type , merra_aero_none , merra_ntype )) & error_msg = 'aerosol optics: aerosol type is out of bounds' if ( error_msg /= \"\" ) return end if !$acc data copyin(aero_type, aero_size, aero_mass, relhum) !$omp target data map(to:aero_type, aero_size, aero_mass, relhum) ! ! Aerosol mask; don't need aerosol optics if there's no aerosol ! !$acc data create(aeromsk) !$omp target data map(alloc:aeromsk) !$acc parallel loop default(present) collapse(2) !$omp target teams distribute parallel do simd collapse(2) do ilay = 1 , nlay do icol = 1 , ncol aeromsk ( icol , ilay ) = aero_type ( icol , ilay ) > 0 end do end do ! ! Aerosol size, relative humidity ! if ( check_values ) then if ( any_vals_outside ( aero_size , aeromsk , minSize , maxSize )) & error_msg = 'aerosol optics: requested aerosol size is out of bounds' if ( any_vals_outside ( relhum , aeromsk , 0._wp , 1._wp )) & error_msg = 'aerosol optics: relative humidity fraction is out of bounds' end if ! Release aerosol mask !$acc end data !$omp end target data if ( error_msg == \"\" ) then !$acc data create(atau, ataussa, ataussag) !$omp target data map(alloc:atau, ataussa, ataussag) ! ! ! ---------------------------------------- ! ! The lookup tables determining extinction coefficient, single-scattering albedo, ! and asymmetry parameter g as a function of aerosol type, aerosol size and ! relative humidity. ! We compute the optical depth tau (= exintinction coeff * aerosol mass ) and the ! products tau*ssa and tau*ssa*g separately for each aerosol type requested. ! These are used to determine the aerosol optical properties. ! if ( allocated ( this % aero_dust_tbl )) then ! ! Aerosol ! call compute_all_from_table ( ncol , nlay , npair , nval , nrh , nbin , nbnd , & aero_type , aero_size , aero_mass , relhum , & this % merra_aero_bin_lims , this % aero_rh , & this % aero_dust_tbl , this % aero_salt_tbl , this % aero_sulf_tbl , & this % aero_bcar_rh_tbl , this % aero_bcar_tbl , & this % aero_ocar_rh_tbl , this % aero_ocar_tbl , & atau , ataussa , ataussag ) endif ! ! Derive total aerosol optical properties ! See also the increment routines in mo_optical_props_kernels ! select type ( optical_props ) type is ( ty_optical_props_1scl ) !$acc parallel loop gang vector default(present) collapse(3) & !$acc copyin(optical_props) copyout(optical_props%tau) !$omp target teams distribute parallel do simd collapse(3) & !$omp map(from:optical_props%tau) do ibnd = 1 , nbnd do ilay = 1 , nlay do icol = 1 , ncol ! Absorption optical depth = (1-ssa) * tau = tau - taussa optical_props % tau ( icol , ilay , ibnd ) = ( atau ( icol , ilay , ibnd ) - ataussa ( icol , ilay , ibnd )) end do end do end do type is ( ty_optical_props_2str ) !$acc parallel loop gang vector default(present) collapse(3) & !$acc copyin(optical_props) copyout(optical_props%tau, optical_props%ssa, optical_props%g) !$omp target teams distribute parallel do simd collapse(3) & !$omp map(from:optical_props%tau, optical_props%ssa, optical_props%g) do ibnd = 1 , nbnd do ilay = 1 , nlay do icol = 1 , ncol tau = atau ( icol , ilay , ibnd ) taussa = ataussa ( icol , ilay , ibnd ) optical_props % tau ( icol , ilay , ibnd ) = tau optical_props % ssa ( icol , ilay , ibnd ) = taussa / max ( epsilon ( tau ), tau ) optical_props % g ( icol , ilay , ibnd ) = ( ataussag ( icol , ilay , ibnd )) & / max ( epsilon ( tau ), taussa ) end do end do end do type is ( ty_optical_props_nstr ) error_msg = \"aerosol optics: n-stream calculations not yet supported\" end select !$acc end data !$omp end target data end if !$acc end data !$omp end target data end function aerosol_optics !-------------------------------------------------------------------------------------------------------------------- ! ! Ancillary functions ! !-------------------------------------------------------------------------------------------------------------------- ! ! For size dimension, select size bin appropriate for the requested aerosol size. ! For rh dimension, linearly interpolate values from a lookup table with \"nrh\" ! unevenly-spaced elements \"aero_rh\". The last dimension for all tables is band. ! Returns zero where no aerosol is present. ! subroutine compute_all_from_table ( ncol , nlay , npair , nval , nrh , nbin , nbnd , & type , size , mass , rh , & merra_aero_bin_lims , aero_rh , & aero_dust_tbl , aero_salt_tbl , aero_sulf_tbl , & aero_bcar_rh_tbl , aero_bcar_tbl , & aero_ocar_rh_tbl , aero_ocar_tbl , & tau , taussa , taussag ) integer , intent ( in ) :: ncol , nlay , npair , nval , nrh , nbin , nbnd integer , dimension ( ncol , nlay ), intent ( in ) :: type real ( wp ), dimension ( ncol , nlay ), intent ( in ) :: size , mass , rh real ( wp ), dimension ( npair , nbin ), intent ( in ) :: merra_aero_bin_lims real ( wp ), dimension ( nrh ), intent ( in ) :: aero_rh real ( wp ), dimension ( nval , nbin , nbnd ), intent ( in ) :: aero_dust_tbl real ( wp ), dimension ( nrh , nval , nbin , nbnd ), intent ( in ) :: aero_salt_tbl real ( wp ), dimension ( nrh , nval , nbnd ), intent ( in ) :: aero_sulf_tbl real ( wp ), dimension ( nrh , nval , nbnd ), intent ( in ) :: aero_bcar_rh_tbl real ( wp ), dimension ( nval , nbnd ), intent ( in ) :: aero_bcar_tbl real ( wp ), dimension ( nrh , nval , nbnd ), intent ( in ) :: aero_ocar_rh_tbl real ( wp ), dimension ( nval , nbnd ), intent ( in ) :: aero_ocar_tbl real ( wp ), dimension ( ncol , nlay , nbnd ), intent ( out ) :: tau , taussa , taussag ! --------------------------- integer :: icol , ilay , ibnd , ibin , i integer :: itype , irh1 , irh2 real ( wp ) :: drh0 , drh1 , rdrh real ( wp ) :: t , ts , tsg ! tau, tau*ssa, tau*ssa*g ! --------------------------- !$acc parallel loop gang vector default(present) collapse(3) !$omp target teams distribute parallel do simd collapse(3) do ibnd = 1 , nbnd do ilay = 1 , nlay do icol = 1 , ncol ! Sequential loop to find size bin do i = 1 , nbin if ( size ( icol , ilay ) . ge . merra_aero_bin_lims ( 1 , i ) . and . & size ( icol , ilay ) . le . merra_aero_bin_lims ( 2 , i )) then ibin = i endif enddo itype = type ( icol , ilay ) ! relative humidity linear interpolation coefficients if ( itype . ne . merra_aero_none ) then irh2 = 1 do while ( rh ( icol , ilay ) . gt . aero_rh ( irh2 )) irh2 = irh2 + 1 if ( irh2 . gt . nrh ) exit enddo irh1 = max ( 1 , irh2 - 1 ) irh2 = min ( nrh , irh2 ) drh0 = aero_rh ( irh2 ) - aero_rh ( irh1 ) drh1 = rh ( icol , ilay ) - aero_rh ( irh1 ) if ( irh1 == irh2 ) then rdrh = 0._wp else rdrh = drh1 / drh0 endif endif ! Set aerosol optical properties where aerosol present. Use aerosol type array as the mask. select case ( itype ) ! dust case ( merra_aero_dust ) tau ( icol , ilay , ibnd ) = mass ( icol , ilay ) * aero_dust_tbl ( ext , ibin , ibnd ) taussa ( icol , ilay , ibnd ) = tau ( icol , ilay , ibnd ) * aero_dust_tbl ( ssa , ibin , ibnd ) taussag ( icol , ilay , ibnd ) = taussa ( icol , ilay , ibnd ) * aero_dust_tbl ( g , ibin , ibnd ) ! sea-salt case ( merra_aero_salt ) tau ( icol , ilay , ibnd ) = mass ( icol , ilay ) * & linear_interp_aero_table ( aero_salt_tbl (:, ext , ibin , ibnd ), irh1 , irh2 , rdrh ) taussa ( icol , ilay , ibnd ) = tau ( icol , ilay , ibnd ) * & linear_interp_aero_table ( aero_salt_tbl (:, ssa , ibin , ibnd ), irh1 , irh2 , rdrh ) taussag ( icol , ilay , ibnd ) = taussa ( icol , ilay , ibnd ) * & linear_interp_aero_table ( aero_salt_tbl (:, g , ibin , ibnd ), irh1 , irh2 , rdrh ) ! sulfate case ( merra_aero_sulf ) tau ( icol , ilay , ibnd ) = mass ( icol , ilay ) * & linear_interp_aero_table ( aero_sulf_tbl (:, ext , ibnd ), irh1 , irh2 , rdrh ) taussa ( icol , ilay , ibnd ) = tau ( icol , ilay , ibnd ) * & linear_interp_aero_table ( aero_sulf_tbl (:, ssa , ibnd ), irh1 , irh2 , rdrh ) taussag ( icol , ilay , ibnd ) = taussa ( icol , ilay , ibnd ) * & linear_interp_aero_table ( aero_sulf_tbl (:, g , ibnd ), irh1 , irh2 , rdrh ) ! black carbon - hydrophilic case ( merra_aero_bcar_rh ) tau ( icol , ilay , ibnd ) = mass ( icol , ilay ) * & linear_interp_aero_table ( aero_bcar_rh_tbl (:, ext , ibnd ), irh1 , irh2 , rdrh ) taussa ( icol , ilay , ibnd ) = tau ( icol , ilay , ibnd ) * & linear_interp_aero_table ( aero_bcar_rh_tbl (:, ssa , ibnd ), irh1 , irh2 , rdrh ) taussag ( icol , ilay , ibnd ) = taussa ( icol , ilay , ibnd ) * & linear_interp_aero_table ( aero_bcar_rh_tbl (:, g , ibnd ), irh1 , irh2 , rdrh ) ! black carbon - hydrophobic case ( merra_aero_bcar ) tau ( icol , ilay , ibnd ) = mass ( icol , ilay ) * aero_bcar_tbl ( ext , ibnd ) taussa ( icol , ilay , ibnd ) = tau ( icol , ilay , ibnd ) * aero_bcar_tbl ( ssa , ibnd ) taussag ( icol , ilay , ibnd ) = taussa ( icol , ilay , ibnd ) * aero_bcar_tbl ( g , ibnd ) ! organic carbon - hydrophilic case ( merra_aero_ocar_rh ) tau ( icol , ilay , ibnd ) = mass ( icol , ilay ) * & linear_interp_aero_table ( aero_ocar_rh_tbl (:, ext , ibnd ), irh1 , irh2 , rdrh ) taussa ( icol , ilay , ibnd ) = tau ( icol , ilay , ibnd ) * & linear_interp_aero_table ( aero_ocar_rh_tbl (:, ssa , ibnd ), irh1 , irh2 , rdrh ) taussag ( icol , ilay , ibnd ) = taussa ( icol , ilay , ibnd ) * & linear_interp_aero_table ( aero_ocar_rh_tbl (:, g , ibnd ), irh1 , irh2 , rdrh ) ! organic carbon - hydrophobic case ( merra_aero_ocar ) tau ( icol , ilay , ibnd ) = mass ( icol , ilay ) * aero_ocar_tbl ( ext , ibnd ) taussa ( icol , ilay , ibnd ) = tau ( icol , ilay , ibnd ) * aero_ocar_tbl ( ssa , ibnd ) taussag ( icol , ilay , ibnd ) = taussa ( icol , ilay , ibnd ) * aero_ocar_tbl ( g , ibnd ) ! no aerosol case default tau ( icol , ilay , ibnd ) = 0._wp taussa ( icol , ilay , ibnd ) = 0._wp taussag ( icol , ilay , ibnd ) = 0._wp end select end do end do end do end subroutine compute_all_from_table !-------------------------------------------------------------------------------------------------------------------- ! ! Function for linearly interpolating MERRA aerosol optics tables in the rh dimension for ! a single parameter, aerosol type, spectral band, and size bin. Interpolation is performed ! only where aerosol in present using aerosol type as the mask. ! function linear_interp_aero_table ( table , index1 , index2 , weight ) result ( value ) !$acc routine seq !$omp declare target integer , intent ( in ) :: index1 , index2 real ( wp ), intent ( in ) :: weight real ( wp ), dimension (:), intent ( in ) :: table real ( wp ) :: value value = table ( index1 ) + weight * ( table ( index2 ) - table ( index1 )) end function linear_interp_aero_table ! ---------------------------------------------------------- logical function any_int_vals_outside_2D ( array , checkMin , checkMax ) integer , dimension (:,:), intent ( in ) :: array integer , intent ( in ) :: checkMin , checkMax integer :: minValue , maxValue !$acc kernels copyin(array) !$omp target map(to:array) map(from:minValue, maxValue) minValue = minval ( array ) maxValue = maxval ( array ) !$acc end kernels !$omp end target any_int_vals_outside_2D = minValue < checkMin . or . maxValue > checkMax end function any_int_vals_outside_2D end module mo_aerosol_optics_rrtmgp_merra","tags":"","loc":"sourcefile/mo_aerosol_optics_rrtmgp_merra.f90.html"},{"title":"mo_cloud_optics_rrtmgp.F90 – RRTMGP-Fortran","text":"Contents Modules mo_cloud_optics_rrtmgp Source Code mo_cloud_optics_rrtmgp.F90 Source Code ! This code is part of Radiative Transfer for Energetics (RTE) ! ! Contacts: Robert Pincus and Eli Mlawer ! email: rrtmgp@aer.com ! ! Copyright 2015-2018, Atmospheric and Environmental Research and ! Regents of the University of Colorado. All right reserved. ! ! Use and duplication is permitted under the terms of the ! BSD 3-clause license, see http://opensource.org/licenses/BSD-3-Clause ! ------------------------------------------------------------------------------------------------- ! Provides cloud optical properties as a function of effective radius for the RRTMGP bands ! Based on Mie calculations for liquid ! and results from doi:10.1175/JAS-D-12-039.1 for ice with variable surface roughness ! Can use either look-up tables or Pade approximates according to which data has been loaded ! Mike Iacono (AER) is the original author ! ! The class can be used as-is but is also intended as an example of how to extend the RTE framework ! ------------------------------------------------------------------------------------------------- module mo_cloud_optics_rrtmgp use mo_rte_kind , only : wp , wl use mo_rte_config , only : check_values , check_extents use mo_rte_util_array_validation ,& only : any_vals_less_than , any_vals_outside , extents_are use mo_optical_props , only : ty_optical_props , & ty_optical_props_arry , & ty_optical_props_1scl , & ty_optical_props_2str , & ty_optical_props_nstr implicit none interface pade_eval module procedure pade_eval_nbnd , pade_eval_1 end interface pade_eval private ! ----------------------------------------------------------------------------------- type , extends ( ty_optical_props ), public :: ty_cloud_optics_rrtmgp private ! ! Ice surface roughness category - needed for Yang (2013) ice optics parameterization ! integer :: icergh = 0 ! (1 = none, 2 = medium, 3 = high) ! ! Lookup table information ! ! Upper and lower limits of the tables real ( wp ) :: radliq_lwr = 0._wp , radliq_upr = 0._wp real ( wp ) :: radice_lwr = 0._wp , radice_upr = 0._wp ! How many steps in the table? (for convenience) integer :: liq_nsteps = 0 , ice_nsteps = 0 ! How big is each step in the table? real ( wp ) :: liq_step_size = 0._wp , ice_step_size = 0._wp ! ! The tables themselves. ! real ( wp ), dimension (:,: ), allocatable :: lut_extliq , lut_ssaliq , lut_asyliq ! (nsize_liq, nbnd) real ( wp ), dimension (:,:,: ), allocatable :: lut_extice , lut_ssaice , lut_asyice ! (nsize_ice, nbnd, nrghice) ! ! Pade approximant coefficients ! real ( wp ), dimension (:,:,: ), allocatable :: pade_extliq ! (nbnd, nsizereg, ncoeff_ext) real ( wp ), dimension (:,:,: ), allocatable :: pade_ssaliq , pade_asyliq ! (nbnd, nsizereg, ncoeff_ssa_g) real ( wp ), dimension (:,:,:,:), allocatable :: pade_extice ! (nbnd, nsizereg, ncoeff_ext, nrghice) real ( wp ), dimension (:,:,:,:), allocatable :: pade_ssaice , pade_asyice ! (nbnd, nsizereg, ncoeff_ssa_g, nrghice) ! Particle size regimes for Pade formulations real ( wp ), dimension (:), allocatable :: pade_sizreg_extliq , pade_sizreg_ssaliq , pade_sizreg_asyliq ! (nbound) real ( wp ), dimension (:), allocatable :: pade_sizreg_extice , pade_sizreg_ssaice , pade_sizreg_asyice ! (nbound) ! ----- contains generic , public :: load => load_lut , load_pade procedure , public :: finalize procedure , public :: cloud_optics procedure , public :: get_min_radius_liq procedure , public :: get_min_radius_ice procedure , public :: get_max_radius_liq procedure , public :: get_max_radius_ice procedure , public :: get_num_ice_roughness_types procedure , public :: set_ice_roughness ! Internal procedures procedure , private :: load_lut procedure , private :: load_pade end type ty_cloud_optics_rrtmgp contains ! ------------------------------------------------------------------------------ ! ! Routines to load data needed for cloud optics calculations. Two routines: one to load ! lookup-tables and one for coefficients for Pade approximates ! ! ------------------------------------------------------------------------------ function load_lut ( this , band_lims_wvn , & radliq_lwr , radliq_upr , & radice_lwr , radice_upr , & lut_extliq , lut_ssaliq , lut_asyliq , & lut_extice , lut_ssaice , lut_asyice ) result ( error_msg ) class ( ty_cloud_optics_rrtmgp ), intent ( inout ) :: this real ( wp ), dimension (:,:), intent ( in ) :: band_lims_wvn ! Spectral discretization ! Lookup table interpolation constants ! Lower and upper bounds of the tables; also the constant for calculating interpolation indices for liquid real ( wp ), intent ( in ) :: radliq_lwr , radliq_upr real ( wp ), intent ( in ) :: radice_lwr , radice_upr ! LUT coefficients ! Extinction, single-scattering albedo, and asymmetry parameter for liquid and ice respectively real ( wp ), dimension (:,:), intent ( in ) :: lut_extliq , lut_ssaliq , lut_asyliq real ( wp ), dimension (:,:,:), intent ( in ) :: lut_extice , lut_ssaice , lut_asyice character ( len = 128 ) :: error_msg ! ------- ! ! Local variables ! integer :: nbnd , nrghice , nsize_liq , nsize_ice error_msg = this % init ( band_lims_wvn , name = \"RRTMGP cloud optics\" ) ! ! LUT coefficient dimensions ! nsize_liq = size ( lut_extliq , dim = 1 ) nsize_ice = size ( lut_extice , dim = 1 ) nbnd = size ( lut_extliq , dim = 2 ) nrghice = size ( lut_extice , dim = 3 ) ! ! Error checking ! Can we check for consistency between table bounds and _fac? ! if ( nbnd /= this % get_nband ()) & error_msg = \"cloud_optics%init(): number of bands inconsistent between lookup tables, spectral discretization\" if ( size ( lut_extice , 2 ) /= nbnd ) & error_msg = \"cloud_optics%init(): array lut_extice has the wrong number of bands\" if (. not . extents_are ( lut_ssaliq , nsize_liq , nbnd )) & error_msg = \"cloud_optics%init(): array lut_ssaliq isn't consistently sized\" if (. not . extents_are ( lut_asyliq , nsize_liq , nbnd )) & error_msg = \"cloud_optics%init(): array lut_asyliq isn't consistently sized\" if (. not . extents_are ( lut_ssaice , nsize_ice , nbnd , nrghice )) & error_msg = \"cloud_optics%init(): array lut_ssaice isn't consistently sized\" if (. not . extents_are ( lut_asyice , nsize_ice , nbnd , nrghice )) & error_msg = \"cloud_optics%init(): array lut_asyice isn't consistently sized\" if ( error_msg /= \"\" ) return this % liq_nsteps = nsize_liq this % ice_nsteps = nsize_ice this % liq_step_size = ( radliq_upr - radliq_lwr ) / real ( nsize_liq - 1 , wp ) this % ice_step_size = ( radice_upr - radice_lwr ) / real ( nsize_ice - 1 , wp ) ! Allocate LUT coefficients allocate ( this % lut_extliq ( nsize_liq , nbnd ), & this % lut_ssaliq ( nsize_liq , nbnd ), & this % lut_asyliq ( nsize_liq , nbnd ), & this % lut_extice ( nsize_ice , nbnd , nrghice ), & this % lut_ssaice ( nsize_ice , nbnd , nrghice ), & this % lut_asyice ( nsize_ice , nbnd , nrghice )) !$acc enter data create(this) & !$acc create(this%lut_extliq, this%lut_ssaliq, this%lut_asyliq) & !$acc create(this%lut_extice, this%lut_ssaice, this%lut_asyice) !$omp target enter data & !$omp map(alloc:this%lut_extliq, this%lut_ssaliq, this%lut_asyliq) & !$omp map(alloc:this%lut_extice, this%lut_ssaice, this%lut_asyice) ! Load LUT constants this % radliq_lwr = radliq_lwr this % radliq_upr = radliq_upr this % radice_lwr = radice_lwr this % radice_upr = radice_upr ! Load LUT coefficients !$acc kernels !$omp target this % lut_extliq = lut_extliq this % lut_ssaliq = lut_ssaliq this % lut_asyliq = lut_asyliq this % lut_extice = lut_extice this % lut_ssaice = lut_ssaice this % lut_asyice = lut_asyice !$acc end kernels !$omp end target ! ! Set default ice roughness - min values ! error_msg = this % set_ice_roughness ( 1 ) end function load_lut ! ------------------------------------------------------------------------------ ! ! Cloud optics initialization function - Pade ! ! ------------------------------------------------------------------------------ function load_pade ( this , band_lims_wvn , & pade_extliq , pade_ssaliq , pade_asyliq , & pade_extice , pade_ssaice , pade_asyice , & pade_sizreg_extliq , pade_sizreg_ssaliq , pade_sizreg_asyliq , & pade_sizreg_extice , pade_sizreg_ssaice , pade_sizreg_asyice ) & result ( error_msg ) class ( ty_cloud_optics_rrtmgp ), intent ( inout ) :: this ! cloud specification data real ( wp ), dimension (:,:), intent ( in ) :: band_lims_wvn ! Spectral discretization ! ! Pade coefficients: extinction, single-scattering albedo, and asymmetry factor for liquid and ice ! real ( wp ), dimension (:,:,:), intent ( in ) :: pade_extliq , pade_ssaliq , pade_asyliq real ( wp ), dimension (:,:,:,:), intent ( in ) :: pade_extice , pade_ssaice , pade_asyice ! ! Boundaries of size regimes. Liquid and ice are separate; ! extinction is fit to different numbers of size bins than single-scattering albedo and asymmetry factor ! real ( wp ), dimension (:), intent ( in ) :: pade_sizreg_extliq , pade_sizreg_ssaliq , pade_sizreg_asyliq real ( wp ), dimension (:), intent ( in ) :: pade_sizreg_extice , pade_sizreg_ssaice , pade_sizreg_asyice character ( len = 128 ) :: error_msg ! ------- Local ------- integer :: nbnd , nrghice , nsizereg , ncoeff_ext , ncoeff_ssa_g , nbound ! ------- Definitions ------- ! Pade coefficient dimensions nbnd = size ( pade_extliq , dim = 1 ) nsizereg = size ( pade_extliq , dim = 2 ) ncoeff_ext = size ( pade_extliq , dim = 3 ) ncoeff_ssa_g = size ( pade_ssaliq , dim = 3 ) nrghice = size ( pade_extice , dim = 4 ) nbound = size ( pade_sizreg_extliq ) ! The number of size regimes is assumed in the Pade evaluations if ( nsizereg /= 3 ) & error_msg = \"cloud optics: code assumes exactly three size regimes for Pade approximants but data is otherwise\" error_msg = this % init ( band_lims_wvn , name = \"RRTMGP cloud optics\" ) ! ! Error checking ! if ( nbnd /= this % get_nband ()) & error_msg = \"cloud_optics%init(): number of bands inconsistent between lookup tables, spectral discretization\" if (. not . extents_are ( pade_ssaliq , nbnd , nsizereg , ncoeff_ssa_g )) & error_msg = \"cloud_optics%init(): array pade_ssaliq isn't consistently sized\" if (. not . extents_are ( pade_asyliq , nbnd , nsizereg , ncoeff_ssa_g )) & error_msg = \"cloud_optics%init(): array pade_asyliq isn't consistently sized\" if (. not . extents_are ( pade_extice , nbnd , nsizereg , ncoeff_ext , nrghice )) & error_msg = \"cloud_optics%init(): array pade_extice isn't consistently sized\" if (. not . extents_are ( pade_ssaice , nbnd , nsizereg , ncoeff_ssa_g , nrghice )) & error_msg = \"cloud_optics%init(): array pade_ssaice isn't consistently sized\" if (. not . extents_are ( pade_asyice , nbnd , nsizereg , ncoeff_ssa_g , nrghice )) & error_msg = \"cloud_optics%init(): array pade_asyice isn't consistently sized\" if ( any ([ size ( pade_sizreg_ssaliq ), size ( pade_sizreg_asyliq ), & size ( pade_sizreg_extice ), size ( pade_sizreg_ssaice ), size ( pade_sizreg_asyice )] /= nbound )) & error_msg = \"cloud_optics%init(): one or more Pade size regime arrays are inconsistently sized\" if ( nsizereg /= 3 ) & error_msg = \"cloud_optics%init(): Expecting precisely three size regimes for Pade approximants\" if ( error_msg /= \"\" ) return ! ! Consistency among size regimes ! this % radliq_lwr = pade_sizreg_extliq ( 1 ) this % radliq_upr = pade_sizreg_extliq ( nbound ) this % radice_lwr = pade_sizreg_extice ( 1 ) this % radice_upr = pade_sizreg_extice ( nbound ) if ( error_msg /= \"\" ) return if ( any ([ pade_sizreg_ssaliq ( 1 ), pade_sizreg_asyliq ( 1 )] < this % radliq_lwr )) & error_msg = \"cloud_optics%init(): one or more Pade size regimes have inconsistent lowest values\" if ( any ([ pade_sizreg_ssaice ( 1 ), pade_sizreg_asyice ( 1 )] < this % radice_lwr )) & error_msg = \"cloud_optics%init(): one or more Pade size regimes have inconsistent lower values\" if ( any ([ pade_sizreg_ssaliq ( nbound ), pade_sizreg_asyliq ( nbound )] > this % radliq_upr )) & error_msg = \"cloud_optics%init(): one or more Pade size regimes have lowest value less than radliq_upr\" if ( any ([ pade_sizreg_ssaice ( nbound ), pade_sizreg_asyice ( nbound )] > this % radice_upr )) & error_msg = \"cloud_optics%init(): one or more Pade size regimes have lowest value less than radice_upr\" if ( error_msg /= \"\" ) return ! ! Allocate Pade coefficients ! allocate ( this % pade_extliq ( nbnd , nsizereg , ncoeff_ext ), & this % pade_ssaliq ( nbnd , nsizereg , ncoeff_ssa_g ), & this % pade_asyliq ( nbnd , nsizereg , ncoeff_ssa_g ), & this % pade_extice ( nbnd , nsizereg , ncoeff_ext , nrghice ), & this % pade_ssaice ( nbnd , nsizereg , ncoeff_ssa_g , nrghice ), & this % pade_asyice ( nbnd , nsizereg , ncoeff_ssa_g , nrghice )) ! ! Allocate Pade coefficient particle size regime boundaries ! allocate ( this % pade_sizreg_extliq ( nbound ), & this % pade_sizreg_ssaliq ( nbound ), & this % pade_sizreg_asyliq ( nbound ), & this % pade_sizreg_extice ( nbound ), & this % pade_sizreg_ssaice ( nbound ), & this % pade_sizreg_asyice ( nbound )) !$acc enter data create(this) & !$acc create(this%pade_extliq, this%pade_ssaliq, this%pade_asyliq) & !$acc create(this%pade_extice, this%pade_ssaice, this%pade_asyice) & !$acc create(this%pade_sizreg_extliq, this%pade_sizreg_ssaliq, this%pade_sizreg_asyliq) & !$acc create(this%pade_sizreg_extice, this%pade_sizreg_ssaice, this%pade_sizreg_asyice) !$omp target enter data & !$omp map(alloc:this%pade_extliq, this%pade_ssaliq, this%pade_asyliq) & !$omp map(alloc:this%pade_extice, this%pade_ssaice, this%pade_asyice) & !$omp map(alloc:this%pade_sizreg_extliq, this%pade_sizreg_ssaliq, this%pade_sizreg_asyliq) & !$omp map(alloc:this%pade_sizreg_extice, this%pade_sizreg_ssaice, this%pade_sizreg_asyice) ! ! Load data ! !$acc kernels !$omp target this % pade_extliq = pade_extliq this % pade_ssaliq = pade_ssaliq this % pade_asyliq = pade_asyliq this % pade_extice = pade_extice this % pade_ssaice = pade_ssaice this % pade_asyice = pade_asyice this % pade_sizreg_extliq = pade_sizreg_extliq this % pade_sizreg_ssaliq = pade_sizreg_ssaliq this % pade_sizreg_asyliq = pade_sizreg_asyliq this % pade_sizreg_extice = pade_sizreg_extice this % pade_sizreg_ssaice = pade_sizreg_ssaice this % pade_sizreg_asyice = pade_sizreg_asyice !$acc end kernels !$omp end target ! ! Set default ice roughness - min values ! error_msg = this % set_ice_roughness ( 1 ) end function load_pade !-------------------------------------------------------------------------------------------------------------------- ! ! Finalize ! !-------------------------------------------------------------------------------------------------------------------- subroutine finalize ( this ) class ( ty_cloud_optics_rrtmgp ), intent ( inout ) :: this this % radliq_lwr = 0._wp this % radliq_upr = 0._wp this % radice_lwr = 0._wp this % radice_upr = 0._wp ! Lookup table cloud optics coefficients if ( allocated ( this % lut_extliq )) then !$acc exit data delete(this%lut_extliq, this%lut_ssaliq, this%lut_asyliq) & !$acc delete(this%lut_extice, this%lut_ssaice, this%lut_asyice) & !$acc delete(this) !$omp target exit data map(release:this%lut_extliq, this%lut_ssaliq, this%lut_asyliq) & !$omp map(release:this%lut_extice, this%lut_ssaice, this%lut_asyice) deallocate ( this % lut_extliq , this % lut_ssaliq , this % lut_asyliq , & this % lut_extice , this % lut_ssaice , this % lut_asyice ) this % liq_nsteps = 0 this % ice_nsteps = 0 this % liq_step_size = 0._wp this % ice_step_size = 0._wp end if ! Pade cloud optics coefficients if ( allocated ( this % pade_extliq )) then !$acc exit data delete(this%pade_extliq, this%pade_ssaliq, this%pade_asyliq) & !$acc delete(this%pade_extice, this%pade_ssaice, this%pade_asyice) & !$acc delete(this%pade_sizreg_extliq, this%pade_sizreg_ssaliq, this%pade_sizreg_asyliq) & !$acc delete(this%pade_sizreg_extice, this%pade_sizreg_ssaice, this%pade_sizreg_asyice) & !$acc delete(this) !$omp target exit data map(release:this%pade_extliq, this%pade_ssaliq, this%pade_asyliq) & !$omp map(release:this%pade_extice, this%pade_ssaice, this%pade_asyice) & !$omp map(release:this%pade_sizreg_extliq, this%pade_sizreg_ssaliq, this%pade_sizreg_asyliq) & !$omp map(release:this%pade_sizreg_extice, this%pade_sizreg_ssaice, this%pade_sizreg_asyice) deallocate ( this % pade_extliq , this % pade_ssaliq , this % pade_asyliq , & this % pade_extice , this % pade_ssaice , this % pade_asyice , & this % pade_sizreg_extliq , this % pade_sizreg_ssaliq , this % pade_sizreg_asyliq , & this % pade_sizreg_extice , this % pade_sizreg_ssaice , this % pade_sizreg_asyice ) end if end subroutine finalize ! ------------------------------------------------------------------------------ ! ! Derive cloud optical properties from provided cloud physical properties ! ! ------------------------------------------------------------------------------ ! ! Compute single-scattering properties ! function cloud_optics ( this , & clwp , ciwp , reliq , reice , & optical_props ) result ( error_msg ) class ( ty_cloud_optics_rrtmgp ), & intent ( in ) :: this real ( wp ), intent ( in ) :: clwp (:,:), & ! cloud liquid water path (g/m2) ciwp (:,:), & ! cloud ice water path (g/m2) reliq (:,:), & ! cloud liquid particle effective size (microns) reice (:,:) ! cloud ice particle effective radius (microns) class ( ty_optical_props_arry ), & intent ( inout ) :: optical_props ! Dimensions: (ncol,nlay,nbnd) character ( len = 128 ) :: error_msg ! ------- Local ------- logical ( wl ), dimension ( size ( clwp , 1 ), size ( clwp , 2 )) :: liqmsk , icemsk real ( wp ), dimension ( size ( clwp , 1 ), size ( clwp , 2 ), this % get_nband ()) :: & ltau , ltaussa , ltaussag , itau , itaussa , itaussag ! Optical properties: tau, tau*ssa, tau*ssa*g ! liquid and ice separately integer :: ncol , nlay , nbnd integer :: nsizereg integer :: icol , ilay , ibnd ! scalars for total tau, tau*ssa real ( wp ) :: tau , taussa ! ---------------------------------------- ! ! Error checking ! ! ---------------------------------------- error_msg = '' if (. not .( allocated ( this % lut_extliq ) . or . allocated ( this % pade_extliq ))) then error_msg = 'cloud optics: no data has been initialized' return end if ncol = size ( clwp , 1 ) nlay = size ( clwp , 2 ) nbnd = this % get_nband () ! ! Array sizes ! if ( check_extents ) then if ( size ( liqmsk , 1 ) /= ncol . or . size ( liqmsk , 2 ) /= nlay ) & error_msg = \"cloud optics: liqmask has wrong extents\" if ( size ( icemsk , 1 ) /= ncol . or . size ( icemsk , 2 ) /= nlay ) & error_msg = \"cloud optics: icemsk has wrong extents\" if ( size ( ciwp , 1 ) /= ncol . or . size ( ciwp , 2 ) /= nlay ) & error_msg = \"cloud optics: ciwp has wrong extents\" if ( size ( reliq , 1 ) /= ncol . or . size ( reliq , 2 ) /= nlay ) & error_msg = \"cloud optics: reliq has wrong extents\" if ( size ( reice , 1 ) /= ncol . or . size ( reice , 2 ) /= nlay ) & error_msg = \"cloud optics: reice has wrong extents\" if ( optical_props % get_ncol () /= ncol . or . optical_props % get_nlay () /= nlay ) & error_msg = \"cloud optics: optical_props have wrong extents\" if ( error_msg /= \"\" ) return end if ! ! Spectral consistency ! if ( check_values ) then if (. not . this % bands_are_equal ( optical_props )) & error_msg = \"cloud optics: optical properties don't have the same band structure\" if ( optical_props % get_nband () /= optical_props % get_ngpt () ) & error_msg = \"cloud optics: optical properties must be requested by band not g-points\" if ( error_msg /= \"\" ) return end if !$acc data copyin(clwp, ciwp, reliq, reice) & !$acc create(ltau, ltaussa, ltaussag, itau, itaussa, itaussag) & !$acc create(liqmsk,icemsk) !$omp target data map(to:clwp, ciwp, reliq, reice) & !$omp map(alloc:ltau, ltaussa, ltaussag, itau, itaussa, itaussag) & !$omp map(alloc:liqmsk, icemsk) ! ! Cloud masks; don't need value re values if there's no cloud ! !$acc parallel loop gang vector default(present) collapse(2) !$omp target teams distribute parallel do simd collapse(2) do ilay = 1 , nlay do icol = 1 , ncol liqmsk ( icol , ilay ) = clwp ( icol , ilay ) > 0._wp icemsk ( icol , ilay ) = ciwp ( icol , ilay ) > 0._wp end do end do ! ! Particle size, liquid/ice water paths ! if ( check_values ) then if ( any_vals_outside ( reliq , liqmsk , this % radliq_lwr , this % radliq_upr )) & error_msg = 'cloud optics: liquid effective radius is out of bounds' if ( any_vals_outside ( reice , icemsk , this % radice_lwr , this % radice_upr )) & error_msg = 'cloud optics: ice effective radius is out of bounds' if ( any_vals_less_than ( clwp , liqmsk , 0._wp ) . or . any_vals_less_than ( ciwp , icemsk , 0._wp )) & error_msg = 'cloud optics: negative clwp or ciwp where clouds are supposed to be' end if if ( error_msg == \"\" ) then ! ! ! ---------------------------------------- ! ! The tables and Pade coefficients determing extinction coeffient, single-scattering albedo, ! and asymmetry parameter g as a function of effective raduis ! We compute the optical depth tau (=exintinction coeff * condensed water path) ! and the products tau*ssa and tau*ssa*g for liquid and ice cloud separately. ! These are used to determine the optical properties of ice and water cloud together. ! We could compute the properties for liquid and ice separately and ! use ty_optical_props_arry%increment but this involves substantially more division. ! if ( allocated ( this % lut_extliq )) then ! ! Liquid ! call compute_all_from_table ( ncol , nlay , nbnd , liqmsk , clwp , reliq , & this % liq_nsteps , this % liq_step_size , this % radliq_lwr , & this % lut_extliq , this % lut_ssaliq , this % lut_asyliq , & ltau , ltaussa , ltaussag ) ! ! Ice ! call compute_all_from_table ( ncol , nlay , nbnd , icemsk , ciwp , reice , & this % ice_nsteps , this % ice_step_size , this % radice_lwr , & this % lut_extice (:,:, this % icergh ), & this % lut_ssaice (:,:, this % icergh ), & this % lut_asyice (:,:, this % icergh ), & itau , itaussa , itaussag ) else ! ! Cloud optical properties from Pade coefficient method ! Hard coded assumptions: order of approximants, three size regimes ! nsizereg = size ( this % pade_extliq , 2 ) call compute_all_from_pade ( ncol , nlay , nbnd , nsizereg , & liqmsk , clwp , reliq , & 2 , 3 , this % pade_sizreg_extliq , this % pade_extliq , & 2 , 2 , this % pade_sizreg_ssaliq , this % pade_ssaliq , & 2 , 2 , this % pade_sizreg_asyliq , this % pade_asyliq , & ltau , ltaussa , ltaussag ) call compute_all_from_pade ( ncol , nlay , nbnd , nsizereg , & icemsk , ciwp , reice , & 2 , 3 , this % pade_sizreg_extice , this % pade_extice (:,:,:, this % icergh ), & 2 , 2 , this % pade_sizreg_ssaice , this % pade_ssaice (:,:,:, this % icergh ), & 2 , 2 , this % pade_sizreg_asyice , this % pade_asyice (:,:,:, this % icergh ), & itau , itaussa , itaussag ) endif ! ! Combine liquid and ice contributions into total cloud optical properties ! See also the increment routines in mo_optical_props_kernels ! select type ( optical_props ) type is ( ty_optical_props_1scl ) !$acc parallel loop gang vector default(present) collapse(3) & !$acc copyin(optical_props) copyout(optical_props%tau) !$omp target teams distribute parallel do simd collapse(3) & !$omp map(from:optical_props%tau) do ibnd = 1 , nbnd do ilay = 1 , nlay do icol = 1 , ncol ! Absorption optical depth = (1-ssa) * tau = tau - taussa optical_props % tau ( icol , ilay , ibnd ) = ( ltau ( icol , ilay , ibnd ) - ltaussa ( icol , ilay , ibnd )) + & ( itau ( icol , ilay , ibnd ) - itaussa ( icol , ilay , ibnd )) end do end do end do type is ( ty_optical_props_2str ) !$acc parallel loop gang vector default(present) collapse(3) & !$acc copyin(optical_props) copyout(optical_props%tau, optical_props%ssa, optical_props%g) !$omp target teams distribute parallel do simd collapse(3) & !$omp map(from:optical_props%tau, optical_props%ssa, optical_props%g) do ibnd = 1 , nbnd do ilay = 1 , nlay do icol = 1 , ncol tau = ltau ( icol , ilay , ibnd ) + itau ( icol , ilay , ibnd ) taussa = ltaussa ( icol , ilay , ibnd ) + itaussa ( icol , ilay , ibnd ) optical_props % g ( icol , ilay , ibnd ) = ( ltaussag ( icol , ilay , ibnd ) + itaussag ( icol , ilay , ibnd )) / & max ( epsilon ( tau ), taussa ) optical_props % ssa ( icol , ilay , ibnd ) = taussa / max ( epsilon ( tau ), tau ) optical_props % tau ( icol , ilay , ibnd ) = tau end do end do end do type is ( ty_optical_props_nstr ) error_msg = \"cloud optics: n-stream calculations not yet supported\" end select end if !$acc end data !$omp end target data end function cloud_optics !-------------------------------------------------------------------------------------------------------------------- ! ! Inquiry functions ! !-------------------------------------------------------------------------------------------------------------------- function set_ice_roughness ( this , icergh ) result ( error_msg ) class ( ty_cloud_optics_rrtmgp ), intent ( inout ) :: this integer , intent ( in ) :: icergh character ( len = 128 ) :: error_msg error_msg = \"\" if (. not . allocated ( this % pade_extice ) . and . . not . allocated ( this % lut_extice )) & error_msg = \"cloud_optics%set_ice_roughness(): can't set before initialization\" if ( icergh < 1 . or . icergh > this % get_num_ice_roughness_types ()) & error_msg = 'cloud optics: cloud ice surface roughness flag is out of bounds' if ( error_msg /= \"\" ) return this % icergh = icergh end function set_ice_roughness !----------------------------------------------- function get_num_ice_roughness_types ( this ) result ( i ) class ( ty_cloud_optics_rrtmgp ), intent ( in ) :: this integer :: i i = 0 if ( allocated ( this % pade_extice )) i = size ( this % pade_extice , dim = 4 ) if ( allocated ( this % lut_extice )) i = size ( this % lut_extice , dim = 3 ) end function get_num_ice_roughness_types !----------------------------------------------- function get_min_radius_liq ( this ) result ( r ) class ( ty_cloud_optics_rrtmgp ), intent ( in ) :: this real ( wp ) :: r r = this % radliq_lwr end function get_min_radius_liq !----------------------------------------------- function get_max_radius_liq ( this ) result ( r ) class ( ty_cloud_optics_rrtmgp ), intent ( in ) :: this real ( wp ) :: r r = this % radliq_upr end function get_max_radius_liq !----------------------------------------------- function get_min_radius_ice ( this ) result ( r ) class ( ty_cloud_optics_rrtmgp ), intent ( in ) :: this real ( wp ) :: r r = this % radice_lwr end function get_min_radius_ice !----------------------------------------------- function get_max_radius_ice ( this ) result ( r ) class ( ty_cloud_optics_rrtmgp ), intent ( in ) :: this real ( wp ) :: r r = this % radice_upr end function get_max_radius_ice !-------------------------------------------------------------------------------------------------------------------- ! ! Ancillary functions ! !-------------------------------------------------------------------------------------------------------------------- ! ! Linearly interpolate values from a lookup table with \"nsteps\" evenly-spaced ! elements starting at \"offset.\" The table's second dimension is band. ! Returns 0 where the mask is false. ! We could also try gather/scatter for efficiency ! subroutine compute_all_from_table ( ncol , nlay , nbnd , mask , lwp , re , & nsteps , step_size , offset , & tau_table , ssa_table , asy_table , & tau , taussa , taussag ) integer , intent ( in ) :: ncol , nlay , nbnd , nsteps logical ( wl ), dimension ( ncol , nlay ), intent ( in ) :: mask real ( wp ), dimension ( ncol , nlay ), intent ( in ) :: lwp , re real ( wp ), intent ( in ) :: step_size , offset real ( wp ), dimension ( nsteps , nbnd ), intent ( in ) :: tau_table , ssa_table , asy_table real ( wp ), dimension ( ncol , nlay , nbnd ) :: tau , taussa , taussag ! --------------------------- integer :: icol , ilay , ibnd integer :: index real ( wp ) :: fint real ( wp ) :: t , ts ! tau, tau*ssa, tau*ssa*g ! --------------------------- !$acc parallel loop gang vector default(present) collapse(3) !$omp target teams distribute parallel do simd collapse(3) do ibnd = 1 , nbnd do ilay = 1 , nlay do icol = 1 , ncol if ( mask ( icol , ilay )) then index = min ( floor (( re ( icol , ilay ) - offset ) / step_size ) + 1 , nsteps - 1 ) fint = ( re ( icol , ilay ) - offset ) / step_size - ( index - 1 ) t = lwp ( icol , ilay ) * & ( tau_table ( index , ibnd ) + fint * ( tau_table ( index + 1 , ibnd ) - tau_table ( index , ibnd ))) ts = t * & ( ssa_table ( index , ibnd ) + fint * ( ssa_table ( index + 1 , ibnd ) - ssa_table ( index , ibnd ))) taussag ( icol , ilay , ibnd ) = & ts * & ( asy_table ( index , ibnd ) + fint * ( asy_table ( index + 1 , ibnd ) - asy_table ( index , ibnd ))) taussa ( icol , ilay , ibnd ) = ts tau ( icol , ilay , ibnd ) = t else tau ( icol , ilay , ibnd ) = 0._wp taussa ( icol , ilay , ibnd ) = 0._wp taussag ( icol , ilay , ibnd ) = 0._wp end if end do end do end do end subroutine compute_all_from_table ! ! Pade functions ! !--------------------------------------------------------------------------- subroutine compute_all_from_pade ( ncol , nlay , nbnd , nsizes , & mask , lwp , re , & m_ext , n_ext , re_bounds_ext , coeffs_ext , & m_ssa , n_ssa , re_bounds_ssa , coeffs_ssa , & m_asy , n_asy , re_bounds_asy , coeffs_asy , & tau , taussa , taussag ) integer , intent ( in ) :: ncol , nlay , nbnd , nsizes logical ( wl ), & dimension ( ncol , nlay ), intent ( in ) :: mask real ( wp ), dimension ( ncol , nlay ), intent ( in ) :: lwp , re real ( wp ), dimension ( nsizes + 1 ), intent ( in ) :: re_bounds_ext , re_bounds_ssa , re_bounds_asy integer , intent ( in ) :: m_ext , n_ext real ( wp ), dimension ( nbnd , nsizes , 0 : m_ext + n_ext ), & intent ( in ) :: coeffs_ext integer , intent ( in ) :: m_ssa , n_ssa real ( wp ), dimension ( nbnd , nsizes , 0 : m_ssa + n_ssa ), & intent ( in ) :: coeffs_ssa integer , intent ( in ) :: m_asy , n_asy real ( wp ), dimension ( nbnd , nsizes , 0 : m_asy + n_asy ), & intent ( in ) :: coeffs_asy real ( wp ), dimension ( ncol , nlay , nbnd ) :: tau , taussa , taussag ! --------------------------- integer :: icol , ilay , ibnd , irad real ( wp ) :: t , ts !$acc parallel loop gang vector default(present) collapse(3) !$omp target teams distribute parallel do simd collapse(3) do ibnd = 1 , nbnd do ilay = 1 , nlay do icol = 1 , ncol if ( mask ( icol , ilay )) then ! ! Finds index into size regime table ! This works only if there are precisely three size regimes (four bounds) and it's ! previously guaranteed that size_bounds(1) <= size <= size_bounds(4) ! irad = min ( floor (( re ( icol , ilay ) - re_bounds_ext ( 2 )) / re_bounds_ext ( 3 )) + 2 , 3 ) t = lwp ( icol , ilay ) * & pade_eval ( ibnd , nbnd , nsizes , m_ext , n_ext , irad , re ( icol , ilay ), coeffs_ext ) irad = min ( floor (( re ( icol , ilay ) - re_bounds_ssa ( 2 )) / re_bounds_ssa ( 3 )) + 2 , 3 ) ! Pade approximants for co-albedo can sometimes be negative ts = t * ( 1._wp - max ( 0._wp , & pade_eval ( ibnd , nbnd , nsizes , m_ssa , n_ssa , irad , re ( icol , ilay ), coeffs_ssa ))) irad = min ( floor (( re ( icol , ilay ) - re_bounds_asy ( 2 )) / re_bounds_asy ( 3 )) + 2 , 3 ) taussag ( icol , ilay , ibnd ) = & ts * & pade_eval ( ibnd , nbnd , nsizes , m_asy , n_asy , irad , re ( icol , ilay ), coeffs_asy ) taussa ( icol , ilay , ibnd ) = ts tau ( icol , ilay , ibnd ) = t else tau ( icol , ilay , ibnd ) = 0._wp taussa ( icol , ilay , ibnd ) = 0._wp taussag ( icol , ilay , ibnd ) = 0._wp end if end do end do end do end subroutine compute_all_from_pade !--------------------------------------------------------------------------- ! ! Evaluate Pade approximant of order [m/n] ! function pade_eval_nbnd ( nbnd , nrads , m , n , irad , re , pade_coeffs ) integer , intent ( in ) :: nbnd , nrads , m , n , irad real ( wp ), dimension ( nbnd , nrads , 0 : m + n ), & intent ( in ) :: pade_coeffs real ( wp ), intent ( in ) :: re real ( wp ), dimension ( nbnd ) :: pade_eval_nbnd integer :: iband real ( wp ) :: numer , denom integer :: i do iband = 1 , nbnd denom = pade_coeffs ( iband , irad , n + m ) do i = n - 1 + m , 1 + m , - 1 denom = pade_coeffs ( iband , irad , i ) + re * denom end do denom = 1._wp + re * denom numer = pade_coeffs ( iband , irad , m ) do i = m - 1 , 1 , - 1 numer = pade_coeffs ( iband , irad , i ) + re * numer end do numer = pade_coeffs ( iband , irad , 0 ) + re * numer pade_eval_nbnd ( iband ) = numer / denom end do end function pade_eval_nbnd !--------------------------------------------------------------------------- ! ! Evaluate Pade approximant of order [m/n] ! function pade_eval_1 ( iband , nbnd , nrads , m , n , irad , re , pade_coeffs ) !$acc routine seq !$omp declare target ! integer , intent ( in ) :: iband , nbnd , nrads , m , n , irad real ( wp ), dimension ( nbnd , nrads , 0 : m + n ), & intent ( in ) :: pade_coeffs real ( wp ), intent ( in ) :: re real ( wp ) :: pade_eval_1 real ( wp ) :: numer , denom integer :: i denom = pade_coeffs ( iband , irad , n + m ) do i = n - 1 + m , 1 + m , - 1 denom = pade_coeffs ( iband , irad , i ) + re * denom end do denom = 1._wp + re * denom numer = pade_coeffs ( iband , irad , m ) do i = m - 1 , 1 , - 1 numer = pade_coeffs ( iband , irad , i ) + re * numer end do numer = pade_coeffs ( iband , irad , 0 ) + re * numer pade_eval_1 = numer / denom end function pade_eval_1 end module mo_cloud_optics_rrtmgp","tags":"","loc":"sourcefile/mo_cloud_optics_rrtmgp.f90.html"},{"title":"mo_gas_optics_rrtmgp.F90 – RRTMGP-Fortran","text":"Contents Modules mo_gas_optics_rrtmgp Source Code mo_gas_optics_rrtmgp.F90 Source Code ! This code is part of RRTM for GCM Applications - Parallel (RRTMGP) ! ! Contacts: Robert Pincus and Eli Mlawer ! email: rrtmgp@aer.com ! ! Copyright 2015-, Atmospheric and Environmental Research, ! Regents of the University of Colorado, Trustees of Columbia University. All right reserved. ! ! Use and duplication is permitted under the terms of the ! BSD 3-clause license, see http://opensource.org/licenses/BSD-3-Clause ! ------------------------------------------------------------------------------------------------- ! !> ## Class implementing the RRTMGP correlated-_k_ distribution !> !> Implements a class for computing spectrally-resolved gas optical properties and source functions !> given atmopsheric physical properties (profiles of temperature, pressure, and gas concentrations) !> The class must be initialized with data (provided as a netCDF file) before being used. !> !> Two variants apply to internal Planck sources (longwave radiation in the Earth's atmosphere) and to !> external stellar radiation (shortwave radiation in the Earth's atmosphere). !> The variant is chosen based on what information is supplied during initialization. ! (It might make more sense to define two sub-classes) ! ! ------------------------------------------------------------------------------------------------- module mo_gas_optics_rrtmgp use mo_rte_kind , only : wp , wl use mo_rte_config , only : check_extents , check_values use mo_rte_util_array , only : zero_array use mo_rte_util_array_validation , & only : any_vals_less_than , any_vals_outside , extents_are use mo_optical_props , only : ty_optical_props use mo_source_functions , only : ty_source_func_lw use mo_gas_optics_rrtmgp_kernels , & only : interpolation , compute_tau_absorption , compute_tau_rayleigh , compute_Planck_source use mo_gas_optics_constants , only : avogad , m_dry , m_h2o , grav use mo_gas_optics_util_string , only : lower_case , string_in_array , string_loc_in_array use mo_gas_concentrations , only : ty_gas_concs use mo_optical_props , only : ty_optical_props_arry , ty_optical_props_1scl , ty_optical_props_2str , ty_optical_props_nstr use mo_gas_optics , only : ty_gas_optics implicit none private real ( wp ), parameter :: pi = acos ( - 1._wp ) ! ------------------------------------------------------------------------------------------------- type , extends ( ty_gas_optics ), public :: ty_gas_optics_rrtmgp private ! ! RRTMGP computes absorption in each band arising from ! two major species in each band, which are combined to make ! a relative mixing ratio eta and a total column amount (col_mix) ! contributions from zero or more minor species whose concentrations ! may be scaled by other components of the atmosphere ! ! Absorption coefficients are interpolated from tables on a pressure/temperature/(eta) grid ! ! ------------------------------------ ! Interpolation variables: Temperature and pressure grids ! real ( wp ), dimension (:), allocatable :: press_ref , press_ref_log , temp_ref ! ! Derived and stored for convenience: ! Min and max for temperature and pressure intepolation grids ! difference in ln pressure between consecutive reference levels ! log of reference pressure separating the lower and upper atmosphere ! real ( wp ) :: press_ref_min , press_ref_max , & temp_ref_min , temp_ref_max real ( wp ) :: press_ref_log_delta , temp_ref_delta , press_ref_trop_log ! ------------------------------------ ! Major absorbers (\"key species\") ! Each unique set of major species is called a flavor. ! ! Names and reference volume mixing ratios of major gases ! character ( 32 ), dimension (:), allocatable :: gas_names ! gas names real ( wp ), dimension (:,:,:), allocatable :: vmr_ref ! vmr_ref(lower or upper atmosphere, gas, temp) ! ! Which two gases are in each flavor? By index ! integer , dimension (:,:), allocatable :: flavor ! major species pair; (2,nflav) ! ! Which flavor for each g-point? One each for lower, upper atmosphere ! integer , dimension (:,:), allocatable :: gpoint_flavor ! flavor = gpoint_flavor(2, g-point) ! ! Major gas absorption coefficients ! real ( wp ), dimension (:,:,:,:), allocatable :: kmajor ! kmajor(g-point,eta,pressure,temperature) ! ! ------------------------------------ ! Minor species, independently for upper and lower atmospheres ! Array extents in the n_minor dimension will differ between upper and lower atmospheres ! Each contribution has starting and ending g-points ! integer , dimension (:,:), allocatable :: minor_limits_gpt_lower , & minor_limits_gpt_upper ! ! Minor gas contributions might be scaled by other gas amounts; if so we need to know ! the total density and whether the contribution is scaled by the partner gas ! or its complement (i.e. all other gases) ! Water vapor self- and foreign continua work like this, as do ! all collision-induced abosption pairs ! logical ( wl ), dimension (:), allocatable :: minor_scales_with_density_lower , & minor_scales_with_density_upper logical ( wl ), dimension (:), allocatable :: scale_by_complement_lower , scale_by_complement_upper integer , dimension (:), allocatable :: idx_minor_lower , idx_minor_upper integer , dimension (:), allocatable :: idx_minor_scaling_lower , idx_minor_scaling_upper ! ! Index into table of absorption coefficients ! integer , dimension (:), allocatable :: kminor_start_lower , kminor_start_upper ! ! The absorption coefficients themselves ! real ( wp ), dimension (:,:,:), allocatable :: kminor_lower , kminor_upper ! kminor_lower(n_minor,eta,temperature) ! ! ----------------------------------------------------------------------------------- ! ! Rayleigh scattering coefficients ! real ( wp ), dimension (:,:,:,:), allocatable :: krayl ! krayl(g-point,eta,temperature,upper/lower atmosphere) ! ! ----------------------------------------------------------------------------------- ! Planck function spectral mapping ! Allocated only when gas optics object is internal-source ! real ( wp ), dimension (:,:,:,:), allocatable :: planck_frac ! stored fraction of Planck irradiance in band for given g-point ! planck_frac(g-point, eta, pressure, temperature) real ( wp ), dimension (:,:), allocatable :: totplnk ! integrated Planck irradiance by band; (Planck temperatures,band) real ( wp ) :: totplnk_delta ! temperature steps in totplnk real ( wp ), dimension (:,:), allocatable :: optimal_angle_fit ! coefficients of linear function ! of vertical path clear-sky transmittance that is used to ! determine the secant of single angle used for the ! no-scattering calculation, ! optimal_angle_fit(coefficient, band) ! ----------------------------------------------------------------------------------- ! Solar source function spectral mapping with solar variability capability ! Allocated when gas optics object is external-source ! n-solar-terms: quiet sun, facular brightening and sunspot dimming components ! following the NRLSSI2 model of Coddington et al. 2016, doi:10.1175/BAMS-D-14-00265.1. ! real ( wp ), dimension (:), allocatable :: solar_source ! incoming solar irradiance, computed from other three terms (g-point) real ( wp ), dimension (:), allocatable :: solar_source_quiet ! incoming solar irradiance, quiet sun term (g-point) real ( wp ), dimension (:), allocatable :: solar_source_facular ! incoming solar irradiance, facular term (g-point) real ( wp ), dimension (:), allocatable :: solar_source_sunspot ! incoming solar irradiance, sunspot term (g-point) ! ! ----------------------------------------------------------------------------------- ! Ancillary ! ----------------------------------------------------------------------------------- ! Index into %gas_names -- is this a key species in any band? logical , dimension (:), allocatable :: is_key ! ----------------------------------------------------------------------------------- contains ! Type-bound procedures ! Public procedures ! public interface generic , public :: load => load_int , load_ext procedure , public :: source_is_internal procedure , public :: source_is_external procedure , public :: is_loaded procedure , public :: finalize procedure , public :: get_ngas procedure , public :: get_gases procedure , public :: get_press_min procedure , public :: get_press_max procedure , public :: get_temp_min procedure , public :: get_temp_max procedure , public :: compute_optimal_angles procedure , public :: set_solar_variability procedure , public :: set_tsi ! Internal procedures procedure , private :: load_int procedure , private :: load_ext procedure , public :: gas_optics_int procedure , public :: gas_optics_ext procedure , private :: check_key_species_present ! Interpolation table dimensions procedure , private :: get_nflav procedure , private :: get_neta procedure , private :: get_npres procedure , private :: get_ntemp procedure , private :: get_nPlanckTemp end type ty_gas_optics_rrtmgp ! ------------------------------------------------------------------------------------------------- ! !> col_dry is the number of molecules per cm-2 of dry air ! public :: get_col_dry ! Utility function, not type-bound contains ! -------------------------------------------------------------------------------------- ! ! Public procedures ! ! -------------------------------------------------------------------------------------- ! !> Two functions to define array sizes needed by gas_optics() ! pure function get_ngas ( this ) ! return the number of gases registered in the spectral configuration class ( ty_gas_optics_rrtmgp ), intent ( in ) :: this integer :: get_ngas get_ngas = size ( this % gas_names ) end function get_ngas !-------------------------------------------------------------------------------------------------------------------- ! !> return the number of distinct major gas pairs in the spectral bands (referred to as !> \"flavors\" - all bands have a flavor even if there is one or no major gas) ! pure function get_nflav ( this ) class ( ty_gas_optics_rrtmgp ), intent ( in ) :: this integer :: get_nflav get_nflav = size ( this % flavor , dim = 2 ) end function get_nflav !-------------------------------------------------------------------------------------------------------------------- ! !> Compute gas optical depth and Planck source functions, !> given temperature, pressure, and composition ! function gas_optics_int ( this , & play , plev , tlay , tsfc , gas_desc , & optical_props , sources , & col_dry , tlev ) result ( error_msg ) ! inputs class ( ty_gas_optics_rrtmgp ), intent ( in ) :: this real ( wp ), dimension (:,:), intent ( in ) :: play , & !! layer pressures [Pa, mb]; (ncol,nlay) plev , & !! level pressures [Pa, mb]; (ncol,nlay+1) tlay !! layer temperatures [K]; (ncol,nlay) real ( wp ), dimension (:), intent ( in ) :: tsfc !! surface skin temperatures [K]; (ncol) type ( ty_gas_concs ), intent ( in ) :: gas_desc !! Gas volume mixing ratios ! output class ( ty_optical_props_arry ), & intent ( inout ) :: optical_props !! Optical properties class ( ty_source_func_lw ), & intent ( inout ) :: sources !! Planck sources character ( len = 128 ) :: error_msg !! Empty if succssful ! Optional inputs real ( wp ), dimension (:,:), intent ( in ), & optional , target :: col_dry , & !! Column dry amount; dim(ncol,nlay) tlev !! level temperatures [K]; (ncol,nlay+1) ! ---------------------------------------------------------- ! Local variables ! Interpolation coefficients for use in source function integer , dimension ( size ( play , dim = 1 ), size ( play , dim = 2 )) :: jtemp , jpress logical ( wl ), dimension ( size ( play , dim = 1 ), size ( play , dim = 2 )) :: tropo real ( wp ), dimension ( 2 , 2 , 2 , size ( play , dim = 1 ), size ( play , dim = 2 ), get_nflav ( this )) :: fmajor integer , dimension ( 2 , size ( play , dim = 1 ), size ( play , dim = 2 ), get_nflav ( this )) :: jeta integer :: ncol , nlay , ngpt , nband ! ---------------------------------------------------------- ncol = size ( play , dim = 1 ) nlay = size ( play , dim = 2 ) ngpt = this % get_ngpt () nband = this % get_nband () ! ! Gas optics ! !$acc enter data create(jtemp, jpress, tropo, fmajor, jeta) !$omp target enter data map(alloc:jtemp, jpress, tropo, fmajor, jeta) error_msg = compute_gas_taus ( this , & ncol , nlay , ngpt , nband , & play , plev , tlay , gas_desc , & optical_props , & jtemp , jpress , jeta , tropo , fmajor , & col_dry ) if ( error_msg /= '' ) return ! ---------------------------------------------------------- ! ! External source -- check arrays sizes and values ! input data sizes and values ! !$acc enter data copyin(tsfc, tlev) ! Should be fine even if tlev is not supplied !$omp target enter data map(to:tsfc, tlev) if ( check_extents ) then if (. not . extents_are ( tsfc , ncol )) & error_msg = \"gas_optics(): array tsfc has wrong size\" if ( present ( tlev )) then if (. not . extents_are ( tlev , ncol , nlay + 1 )) & error_msg = \"gas_optics(): array tlev has wrong size\" end if ! ! output extents ! if ( any ([ sources % get_ncol (), sources % get_nlay (), sources % get_ngpt ()] /= [ ncol , nlay , ngpt ])) & error_msg = \"gas_optics%gas_optics: source function arrays inconsistently sized\" end if if ( error_msg /= '' ) return if ( check_values ) then if ( any_vals_outside ( tsfc , this % temp_ref_min , this % temp_ref_max )) & error_msg = \"gas_optics(): array tsfc has values outside range\" if ( present ( tlev )) then if ( any_vals_outside ( tlev , this % temp_ref_min , this % temp_ref_max )) & error_msg = \"gas_optics(): array tlev has values outside range\" end if end if if ( error_msg /= '' ) return ! ! Interpolate source function ! present status of optional argument should be passed to source() ! but nvfortran (and PGI Fortran before it) do not do so ! if ( present ( tlev )) then error_msg = source ( this , & ncol , nlay , nband , ngpt , & play , plev , tlay , tsfc , & jtemp , jpress , jeta , tropo , fmajor , & sources , & tlev ) !$acc exit data delete(tlev) !$omp target exit data map(release:tlev) else error_msg = source ( this , & ncol , nlay , nband , ngpt , & play , plev , tlay , tsfc , & jtemp , jpress , jeta , tropo , fmajor , & sources ) end if !$acc exit data delete(tsfc) !$omp target exit data map(release:tsfc) !$acc exit data delete(jtemp, jpress, tropo, fmajor, jeta) !$omp target exit data map(release:jtemp, jpress, tropo, fmajor, jeta) end function gas_optics_int !------------------------------------------------------------------------------------------ ! !> Compute gas optical depth given temperature, pressure, and composition !> Top-of-atmosphere stellar insolation is also reported ! function gas_optics_ext ( this , & play , plev , tlay , gas_desc , & ! mandatory inputs optical_props , toa_src , & ! mandatory outputs col_dry ) result ( error_msg ) ! optional input class ( ty_gas_optics_rrtmgp ), intent ( in ) :: this real ( wp ), dimension (:,:), intent ( in ) :: play , & !! layer pressures [Pa, mb]; (ncol,nlay) plev , & !! level pressures [Pa, mb]; (ncol,nlay+1) tlay !! layer temperatures [K]; (ncol,nlay) type ( ty_gas_concs ), intent ( in ) :: gas_desc !! Gas volume mixing ratios ! output class ( ty_optical_props_arry ), & intent ( inout ) :: optical_props real ( wp ), dimension (:,:), intent ( out ) :: toa_src !! Incoming solar irradiance(ncol,ngpt) character ( len = 128 ) :: error_msg !! Empty if successful ! Optional inputs real ( wp ), dimension (:,:), intent ( in ), & optional , target :: col_dry ! Column dry amount; dim(ncol,nlay) ! ---------------------------------------------------------- ! Local variables ! Interpolation coefficients for use in source function integer , dimension ( size ( play , dim = 1 ), size ( play , dim = 2 )) :: jtemp , jpress logical ( wl ), dimension ( size ( play , dim = 1 ), size ( play , dim = 2 )) :: tropo real ( wp ), dimension ( 2 , 2 , 2 , size ( play , dim = 1 ), size ( play , dim = 2 ), get_nflav ( this )) :: fmajor integer , dimension ( 2 , size ( play , dim = 1 ), size ( play , dim = 2 ), get_nflav ( this )) :: jeta integer :: ncol , nlay , ngpt , nband , ngas , nflav integer :: igpt , icol ! ---------------------------------------------------------- ncol = size ( play , dim = 1 ) nlay = size ( play , dim = 2 ) ngpt = this % get_ngpt () nband = this % get_nband () ngas = this % get_ngas () nflav = get_nflav ( this ) ! ! Gas optics ! !$acc enter data create(jtemp, jpress, tropo, fmajor, jeta) !$omp target enter data map(alloc:jtemp, jpress, tropo, fmajor, jeta) error_msg = compute_gas_taus ( this , & ncol , nlay , ngpt , nband , & play , plev , tlay , gas_desc , & optical_props , & jtemp , jpress , jeta , tropo , fmajor , & col_dry ) !$acc exit data delete(jtemp, jpress, tropo, fmajor, jeta) !$omp target exit data map(release:jtemp, jpress, tropo, fmajor, jeta) if ( error_msg /= '' ) return ! ---------------------------------------------------------- ! ! External source function is constant ! !$acc enter data create(toa_src) !$omp target enter data map(alloc:toa_src) if ( check_extents ) then if (. not . extents_are ( toa_src , ncol , ngpt )) & error_msg = \"gas_optics(): array toa_src has wrong size\" end if if ( error_msg /= '' ) return !$acc parallel loop collapse(2) !$omp target teams distribute parallel do simd collapse(2) do igpt = 1 , ngpt do icol = 1 , ncol toa_src ( icol , igpt ) = this % solar_source ( igpt ) end do end do !$acc exit data copyout(toa_src) !$omp target exit data map(from:toa_src) end function gas_optics_ext !------------------------------------------------------------------------------------------ ! ! Returns optical properties and interpolation coefficients ! function compute_gas_taus ( this , & ncol , nlay , ngpt , nband , & play , plev , tlay , gas_desc , & optical_props , & jtemp , jpress , jeta , tropo , fmajor , & col_dry ) result ( error_msg ) class ( ty_gas_optics_rrtmgp ), & intent ( in ) :: this integer , intent ( in ) :: ncol , nlay , ngpt , nband real ( wp ), dimension (:,:), intent ( in ) :: play , & ! layer pressures [Pa, mb]; (ncol,nlay) plev , & ! level pressures [Pa, mb]; (ncol,nlay+1) tlay ! layer temperatures [K]; (ncol,nlay) type ( ty_gas_concs ), intent ( in ) :: gas_desc ! Gas volume mixing ratios class ( ty_optical_props_arry ), intent ( inout ) :: optical_props !inout because components are allocated ! Interpolation coefficients for use in internal source function integer , dimension ( ncol , nlay ), intent ( out ) :: jtemp , jpress integer , dimension ( 2 , ncol , nlay , get_nflav ( this )), intent ( out ) :: jeta logical ( wl ), dimension ( ncol , nlay ), intent ( out ) :: tropo real ( wp ), dimension ( 2 , 2 , 2 , ncol , nlay , get_nflav ( this )), intent ( out ) :: fmajor character ( len = 128 ) :: error_msg ! Optional inputs real ( wp ), dimension (:,:), intent ( in ), & optional , target :: col_dry ! Column dry amount; dim(ncol,nlay) ! ---------------------------------------------------------- ! Local variables real ( wp ), dimension ( ncol , nlay , ngpt ) :: tau , tau_rayleigh ! absorption, Rayleigh scattering optical depths ! Number of molecules per cm^2 real ( wp ), dimension ( ncol , nlay ), target :: col_dry_arr real ( wp ), dimension (:,:), pointer :: col_dry_wk ! ! Interpolation variables used in major gas but not elsewhere, so don't need exporting ! real ( wp ), dimension ( ncol , nlay , this % get_ngas ()) :: vmr ! volume mixing ratios real ( wp ), dimension ( ncol , nlay , 0 : this % get_ngas ()) :: col_gas ! column amounts for each gas, plus col_dry real ( wp ), dimension ( 2 , ncol , nlay , get_nflav ( this )) :: col_mix ! combination of major species's column amounts ! index(1) : reference temperature level ! index(2) : flavor ! index(3) : layer real ( wp ), dimension ( 2 , 2 , ncol , nlay , get_nflav ( this )) :: fminor ! interpolation fractions for minor species ! index(1) : reference eta level (temperature dependent) ! index(2) : reference temperature level ! index(3) : flavor ! index(4) : layer integer :: ngas , nflav , neta , npres , ntemp integer :: icol , ilay , igas integer :: idx_h2o ! index of water vapor integer :: nminorlower , nminorklower , nminorupper , nminorkupper logical :: use_rayl ! ---------------------------------------------------------- ! ! Error checking ! use_rayl = allocated ( this % krayl ) error_msg = '' ! Check for initialization if (. not . this % is_loaded ()) then error_msg = 'ERROR: spectral configuration not loaded' return end if ! ! Check for presence of key species in ty_gas_concs; return error if any key species are not present ! error_msg = this % check_key_species_present ( gas_desc ) if ( error_msg /= '' ) return ! ! Check input data sizes and values ! !$acc data copyin(play,plev,tlay) create( vmr,col_gas) !$omp target data map(to:play,plev,tlay) map(alloc:vmr,col_gas) if ( check_extents ) then if (. not . extents_are ( play , ncol , nlay )) & error_msg = \"gas_optics(): array play has wrong size\" if (. not . extents_are ( tlay , ncol , nlay )) & error_msg = \"gas_optics(): array tlay has wrong size\" if (. not . extents_are ( plev , ncol , nlay + 1 )) & error_msg = \"gas_optics(): array plev has wrong size\" if ( optical_props % get_ncol () /= ncol . or . & optical_props % get_nlay () /= nlay . or . & optical_props % get_ngpt () /= ngpt ) & error_msg = \"gas_optics(): optical properties have the wrong extents\" if ( present ( col_dry )) then if (. not . extents_are ( col_dry , ncol , nlay )) & error_msg = \"gas_optics(): array col_dry has wrong size\" end if end if if ( error_msg == '' ) then if ( check_values ) then if ( any_vals_outside ( play , this % press_ref_min , this % press_ref_max )) & error_msg = \"gas_optics(): array play has values outside range\" if ( any_vals_less_than ( plev , 0._wp )) & error_msg = \"gas_optics(): array plev has values outside range\" if ( any_vals_outside ( tlay , this % temp_ref_min , this % temp_ref_max )) & error_msg = \"gas_optics(): array tlay has values outside range\" if ( present ( col_dry )) then if ( any_vals_less_than ( col_dry , 0._wp )) & error_msg = \"gas_optics(): array col_dry has values outside range\" end if end if end if ! ---------------------------------------------------------- if ( error_msg == '' ) then ngas = this % get_ngas () nflav = get_nflav ( this ) neta = this % get_neta () npres = this % get_npres () ntemp = this % get_ntemp () ! number of minor contributors, total num absorption coeffs nminorlower = size ( this % minor_scales_with_density_lower ) nminorklower = size ( this % kminor_lower , 3 ) nminorupper = size ( this % minor_scales_with_density_upper ) nminorkupper = size ( this % kminor_upper , 3 ) ! ! Fill out the array of volume mixing ratios ! do igas = 1 , ngas ! ! Get vmr if gas is provided in ty_gas_concs ! if ( any ( lower_case ( this % gas_names ( igas )) == gas_desc % get_gas_names ())) then error_msg = gas_desc % get_vmr ( this % gas_names ( igas ), vmr (:,:, igas )) endif end do end if if ( error_msg == '' ) then ! ! Painful hacks to get code to compile with both the CCE-14 and Nvidia 21.3 compiler ! #ifdef _CRAYFTN !$acc enter data copyin(optical_props) #endif select type ( optical_props ) type is ( ty_optical_props_1scl ) #ifndef _CRAYFTN !$acc enter data copyin(optical_props) #endif !$acc enter data create( optical_props%tau) !$omp target enter data map(alloc:optical_props%tau) type is ( ty_optical_props_2str ) #ifndef _CRAYFTN !$acc enter data copyin(optical_props) #endif !$acc enter data create( optical_props%tau, optical_props%ssa, optical_props%g) !$omp target enter data map(alloc:optical_props%tau, optical_props%ssa, optical_props%g) type is ( ty_optical_props_nstr ) #ifndef _CRAYFTN !$acc enter data copyin(optical_props) #endif !$acc enter data create( optical_props%tau, optical_props%ssa, optical_props%p) !$omp target enter data map(alloc:optical_props%tau, optical_props%ssa, optical_props%p) end select ! ! Compute dry air column amounts (number of molecule per cm^2) if user hasn't provided them ! idx_h2o = string_loc_in_array ( 'h2o' , this % gas_names ) if ( present ( col_dry )) then !$acc enter data copyin(col_dry) !$omp target enter data map(to:col_dry) col_dry_wk => col_dry else !$acc enter data create( col_dry_arr) !$omp target enter data map(alloc:col_dry_arr) col_dry_arr = get_col_dry ( vmr (:,:, idx_h2o ), plev ) ! dry air column amounts computation col_dry_wk => col_dry_arr end if ! ! compute column gas amounts [molec/cm^2] ! !$acc parallel loop gang vector collapse(2) !$omp target teams distribute parallel do simd collapse(2) do ilay = 1 , nlay do icol = 1 , ncol col_gas ( icol , ilay , 0 ) = col_dry_wk ( icol , ilay ) end do end do !$acc parallel loop gang vector collapse(3) !$omp target teams distribute parallel do simd collapse(3) do igas = 1 , ngas do ilay = 1 , nlay do icol = 1 , ncol col_gas ( icol , ilay , igas ) = vmr ( icol , ilay , igas ) * col_dry_wk ( icol , ilay ) end do end do end do ! ! ---- calculate gas optical depths ---- ! !$acc data copyout( jtemp, jpress, jeta, tropo, fmajor) create( col_mix, fminor) !$omp target data map(from:jtemp, jpress, jeta, tropo, fmajor) map(alloc:col_mix, fminor) call interpolation ( & ncol , nlay , & ! problem dimensions ngas , nflav , neta , npres , ntemp , & ! interpolation dimensions this % flavor , & this % press_ref_log , & this % temp_ref , & this % press_ref_log_delta , & this % temp_ref_min , & this % temp_ref_delta , & this % press_ref_trop_log , & this % vmr_ref , & play , & tlay , & col_gas , & jtemp , & ! outputs fmajor , fminor ,& col_mix , & tropo , & jeta , jpress ) if ( allocated ( this % krayl )) then !$acc data copyin(this%gpoint_flavor, this%krayl) create(tau, tau_rayleigh) !$omp target data map(to:this%gpoint_flavor, this%krayl) map(alloc:tau, tau_rayleigh) call zero_array ( ncol , nlay , ngpt , tau ) call compute_tau_absorption ( & ncol , nlay , nband , ngpt , & ! dimensions ngas , nflav , neta , npres , ntemp , & nminorlower , nminorklower , & ! number of minor contributors, total num absorption coeffs nminorupper , nminorkupper , & idx_h2o , & this % gpoint_flavor , & this % get_band_lims_gpoint (), & this % kmajor , & this % kminor_lower , & this % kminor_upper , & this % minor_limits_gpt_lower , & this % minor_limits_gpt_upper , & this % minor_scales_with_density_lower , & this % minor_scales_with_density_upper , & this % scale_by_complement_lower , & this % scale_by_complement_upper , & this % idx_minor_lower , & this % idx_minor_upper , & this % idx_minor_scaling_lower , & this % idx_minor_scaling_upper , & this % kminor_start_lower , & this % kminor_start_upper , & tropo , & col_mix , fmajor , fminor , & play , tlay , col_gas , & jeta , jtemp , jpress , & tau ) call compute_tau_rayleigh ( & !Rayleigh scattering optical depths ncol , nlay , nband , ngpt , & ngas , nflav , neta , npres , ntemp , & ! dimensions this % gpoint_flavor , & this % get_band_lims_gpoint (), & this % krayl , & ! inputs from object idx_h2o , col_dry_wk , col_gas , & fminor , jeta , tropo , jtemp , & ! local input tau_rayleigh ) call combine_abs_and_rayleigh ( tau , tau_rayleigh , optical_props ) !$acc end data !$omp end target data else call zero_array ( ncol , nlay , ngpt , optical_props % tau ) call compute_tau_absorption ( & ncol , nlay , nband , ngpt , & ! dimensions ngas , nflav , neta , npres , ntemp , & nminorlower , nminorklower , & ! number of minor contributors, total num absorption coeffs nminorupper , nminorkupper , & idx_h2o , & this % gpoint_flavor , & this % get_band_lims_gpoint (), & this % kmajor , & this % kminor_lower , & this % kminor_upper , & this % minor_limits_gpt_lower , & this % minor_limits_gpt_upper , & this % minor_scales_with_density_lower , & this % minor_scales_with_density_upper , & this % scale_by_complement_lower , & this % scale_by_complement_upper , & this % idx_minor_lower , & this % idx_minor_upper , & this % idx_minor_scaling_lower , & this % idx_minor_scaling_upper , & this % kminor_start_lower , & this % kminor_start_upper , & tropo , & col_mix , fmajor , fminor , & play , tlay , col_gas , & jeta , jtemp , jpress , & optical_props % tau ) ! select type ( optical_props ) type is ( ty_optical_props_2str ) call zero_array ( ncol , nlay , ngpt , optical_props % ssa ) call zero_array ( ncol , nlay , ngpt , optical_props % g ) type is ( ty_optical_props_nstr ) call zero_array ( ncol , nlay , ngpt , optical_props % ssa ) call zero_array ( optical_props % get_nmom (), & ncol , nlay , ngpt , optical_props % p ) end select end if !$acc end data !$omp end target data if ( present ( col_dry )) then !$acc exit data delete( col_dry) !$omp target exit data map(release:col_dry) else !$acc exit data delete( col_dry_arr) !$omp target exit data map(release:col_dry_arr) end if select type ( optical_props ) type is ( ty_optical_props_1scl ) !$acc exit data copyout( optical_props%tau) !$omp target exit data map(from:optical_props%tau) type is ( ty_optical_props_2str ) !$acc exit data copyout( optical_props%tau, optical_props%ssa, optical_props%g) !$omp target exit data map(from:optical_props%tau, optical_props%ssa, optical_props%g) type is ( ty_optical_props_nstr ) !$acc exit data copyout( optical_props%tau, optical_props%ssa, optical_props%p) !$omp target exit data map(from:optical_props%tau, optical_props%ssa, optical_props%p) end select !$acc exit data delete(optical_props) end if !$acc end data !$omp end target data end function compute_gas_taus !------------------------------------------------------------------------------------------ ! !> Compute the spectral solar source function adjusted to account for solar variability !> following the NRLSSI2 model of Coddington et al. 2016, doi:10.1175/BAMS-D-14-00265.1. !> as specified by the facular brightening (mg_index) and sunspot dimming (sb_index) !> indices provided as input. !> !> Users provide the NRLSSI2 facular (\"Bremen\") index and sunspot (\"SPOT67\") index. !> Changing either of these indicies will change the total solar irradiance (TSI) !> Code in extensions/mo_solar_variability may be used to compute the value of these !> indices through an average solar cycle !> Users may also specify the TSI, either alone or in conjunction with the facular and sunspot indices ! !------------------------------------------------------------------------------------------ function set_solar_variability ( this , & mg_index , sb_index , tsi ) & result ( error_msg ) ! !! Updates the spectral distribution and, optionally, !! the integrated value of the solar source function !! Modifying either index will change the total solar irradiance ! class ( ty_gas_optics_rrtmgp ), intent ( inout ) :: this ! real ( wp ), intent ( in ) :: mg_index !! facular brightening index (NRLSSI2 facular \"Bremen\" index) real ( wp ), intent ( in ) :: sb_index !! sunspot dimming index (NRLSSI2 sunspot \"SPOT67\" index) real ( wp ), optional , intent ( in ) :: tsi !! total solar irradiance character ( len = 128 ) :: error_msg !! Empty if successful ! ---------------------------------------------------------- integer :: igpt real ( wp ), parameter :: a_offset = 0.1495954_wp real ( wp ), parameter :: b_offset = 0.00066696_wp ! ---------------------------------------------------------- error_msg = \"\" if ( mg_index < 0._wp ) error_msg = 'mg_index out of range' if ( sb_index < 0._wp ) error_msg = 'sb_index out of range' if ( error_msg /= \"\" ) return ! ! Calculate solar source function for provided facular and sunspot indices ! !$acc parallel loop !$omp target teams distribute parallel do simd do igpt = 1 , size ( this % solar_source_quiet ) this % solar_source ( igpt ) = this % solar_source_quiet ( igpt ) + & ( mg_index - a_offset ) * this % solar_source_facular ( igpt ) + & ( sb_index - b_offset ) * this % solar_source_sunspot ( igpt ) end do ! ! Scale solar source to input TSI value ! if ( present ( tsi )) error_msg = this % set_tsi ( tsi ) end function set_solar_variability !------------------------------------------------------------------------------------------ function set_tsi ( this , tsi ) result ( error_msg ) ! !> Scale the solar source function without changing the spectral distribution ! class ( ty_gas_optics_rrtmgp ), intent ( inout ) :: this real ( wp ), intent ( in ) :: tsi !! user-specified total solar irradiance; character ( len = 128 ) :: error_msg !! Empty if successful real ( wp ) :: norm integer :: igpt , length ! ---------------------------------------------------------- error_msg = \"\" if ( tsi < 0._wp ) then error_msg = 'tsi out of range' else ! ! Scale the solar source function to the input tsi ! norm = 0._wp length = size ( this % solar_source ) !$acc parallel loop gang vector reduction(+:norm) !$omp target teams distribute parallel do simd reduction(+:norm) do igpt = 1 , length norm = norm + this % solar_source ( igpt ) end do norm = 1._wp / norm !$acc parallel loop gang vector !$omp target teams distribute parallel do simd do igpt = 1 , length this % solar_source ( igpt ) = this % solar_source ( igpt ) * tsi * norm end do end if end function set_tsi !------------------------------------------------------------------------------------------ ! ! Compute Planck source functions at layer centers and levels ! function source ( this , & ncol , nlay , nbnd , ngpt , & play , plev , tlay , tsfc , & jtemp , jpress , jeta , tropo , fmajor , & sources , & ! Planck sources tlev ) & ! optional input result ( error_msg ) ! inputs class ( ty_gas_optics_rrtmgp ), intent ( in ) :: this integer , intent ( in ) :: ncol , nlay , nbnd , ngpt real ( wp ), dimension ( ncol , nlay ), intent ( in ) :: play ! layer pressures [Pa, mb] real ( wp ), dimension ( ncol , nlay + 1 ), intent ( in ) :: plev ! level pressures [Pa, mb] real ( wp ), dimension ( ncol , nlay ), intent ( in ) :: tlay ! layer temperatures [K] real ( wp ), dimension ( ncol ), intent ( in ) :: tsfc ! surface skin temperatures [K] ! Interplation coefficients integer , dimension ( ncol , nlay ), intent ( in ) :: jtemp , jpress logical ( wl ), dimension ( ncol , nlay ), intent ( in ) :: tropo real ( wp ), dimension ( 2 , 2 , 2 , ncol , nlay , get_nflav ( this )), & intent ( in ) :: fmajor integer , dimension ( 2 , ncol , nlay , get_nflav ( this )), & intent ( in ) :: jeta class ( ty_source_func_lw ), intent ( inout ) :: sources real ( wp ), dimension ( ncol , nlay + 1 ), intent ( in ), & optional , target :: tlev ! level temperatures [K] character ( len = 128 ) :: error_msg ! ---------------------------------------------------------- logical ( wl ) :: top_at_1 integer :: icol , ilay ! Variables for temperature at layer edges [K] (ncol, nlay+1) real ( wp ), dimension ( ncol , nlay + 1 ), target :: tlev_arr real ( wp ), dimension (:,:), pointer :: tlev_wk ! ---------------------------------------------------------- error_msg = \"\" ! ! Source function needs temperature at interfaces/levels and at layer centers ! Allocate small local array for tlev unconditionally ! !$acc data copyin(sources) copyout( sources%lay_source, sources%lev_source) & !$acc copyout( sources%sfc_source, sources%sfc_source_Jac) & !$acc create(tlev_arr) !$omp target data map(from:sources%lay_source, sources%lev_source) & !$omp map(from:sources%sfc_source, sources%sfc_source_Jac) & !$omp map(alloc:tlev_arr) if ( present ( tlev )) then ! Users might have provided these tlev_wk => tlev else tlev_wk => tlev_arr ! ! Interpolate temperature to levels if not provided ! Interpolation and extrapolation at boundaries is weighted by pressure ! !$acc parallel loop gang vector !$omp target teams distribute parallel do simd do icol = 1 , ncol tlev_arr ( icol , 1 ) = tlay ( icol , 1 ) & + ( plev ( icol , 1 ) - play ( icol , 1 )) * ( tlay ( icol , 2 ) - tlay ( icol , 1 )) & / ( play ( icol , 2 ) - play ( icol , 1 )) tlev_arr ( icol , nlay + 1 ) = tlay ( icol , nlay ) & + ( plev ( icol , nlay + 1 ) - play ( icol , nlay )) * ( tlay ( icol , nlay ) - tlay ( icol , nlay - 1 )) & / ( play ( icol , nlay ) - play ( icol , nlay - 1 )) end do !$acc parallel loop gang vector collapse(2) !$omp target teams distribute parallel do simd collapse(2) do ilay = 2 , nlay do icol = 1 , ncol tlev_arr ( icol , ilay ) = ( play ( icol , ilay - 1 ) * tlay ( icol , ilay - 1 ) * ( plev ( icol , ilay ) - play ( icol , ilay )) & + play ( icol , ilay ) * tlay ( icol , ilay ) * ( play ( icol , ilay - 1 ) - plev ( icol , ilay ))) / & ( plev ( icol , ilay ) * ( play ( icol , ilay - 1 ) - play ( icol , ilay ))) end do end do end if !------------------------------------------------------------------- ! Compute internal (Planck) source functions at layers and levels, ! which depend on mapping from spectral space that creates k-distribution. !$acc kernels copyout(top_at_1) !$omp target map(from:top_at_1) top_at_1 = play ( 1 , 1 ) < play ( 1 , nlay ) !$acc end kernels !$omp end target call compute_Planck_source ( ncol , nlay , nbnd , ngpt , & get_nflav ( this ), this % get_neta (), this % get_npres (), this % get_ntemp (), this % get_nPlanckTemp (), & tlay , tlev_wk , tsfc , merge ( nlay , 1 , top_at_1 ), & fmajor , jeta , tropo , jtemp , jpress , & this % get_gpoint_bands (), this % get_band_lims_gpoint (), this % planck_frac , this % temp_ref_min ,& this % totplnk_delta , this % totplnk , this % gpoint_flavor , & sources % sfc_source , sources % lay_source , sources % lev_source , & sources % sfc_source_Jac ) !$acc end data !$omp end target data end function source !-------------------------------------------------------------------------------------------------------------------- ! ! Initialization ! !-------------------------------------------------------------------------------------------------------------------- ! Initialize object based on data read from netCDF file however the user desires. ! Rayleigh scattering tables may or may not be present; this is indicated with allocation status ! This interface is for the internal-sources object -- includes Plank functions and fractions ! function load_int ( this , available_gases , gas_names , key_species , & band2gpt , band_lims_wavenum , & press_ref , press_ref_trop , temp_ref , & temp_ref_p , temp_ref_t , vmr_ref , & kmajor , kminor_lower , kminor_upper , & gas_minor , identifier_minor , & minor_gases_lower , minor_gases_upper , & minor_limits_gpt_lower , minor_limits_gpt_upper , & minor_scales_with_density_lower , & minor_scales_with_density_upper , & scaling_gas_lower , scaling_gas_upper , & scale_by_complement_lower , & scale_by_complement_upper , & kminor_start_lower , & kminor_start_upper , & totplnk , planck_frac , & rayl_lower , rayl_upper , & optimal_angle_fit ) result ( err_message ) class ( ty_gas_optics_rrtmgp ), intent ( inout ) :: this class ( ty_gas_concs ), intent ( in ) :: available_gases ! Which gases does the host model have available? character ( len =* ), dimension (:), intent ( in ) :: gas_names integer , dimension (:,:,:), intent ( in ) :: key_species integer , dimension (:,:), intent ( in ) :: band2gpt real ( wp ), dimension (:,:), intent ( in ) :: band_lims_wavenum real ( wp ), dimension (:), intent ( in ) :: press_ref , temp_ref real ( wp ), intent ( in ) :: press_ref_trop , temp_ref_p , temp_ref_t real ( wp ), dimension (:,:,:), intent ( in ) :: vmr_ref real ( wp ), dimension (:,:,:,:), intent ( in ) :: kmajor real ( wp ), dimension (:,:,:), intent ( in ) :: kminor_lower , kminor_upper real ( wp ), dimension (:,:), intent ( in ) :: totplnk real ( wp ), dimension (:,:,:,:), intent ( in ) :: planck_frac real ( wp ), dimension (:,:,:), intent ( in ), & allocatable :: rayl_lower , rayl_upper real ( wp ), dimension (:,:), intent ( in ) :: optimal_angle_fit character ( len =* ), dimension (:), intent ( in ) :: gas_minor , identifier_minor character ( len =* ), dimension (:), intent ( in ) :: minor_gases_lower , & minor_gases_upper integer , dimension (:,:), intent ( in ) :: minor_limits_gpt_lower , & minor_limits_gpt_upper logical ( wl ), dimension (:), intent ( in ) :: minor_scales_with_density_lower , & minor_scales_with_density_upper character ( len =* ), dimension (:), intent ( in ) :: scaling_gas_lower , & scaling_gas_upper logical ( wl ), dimension (:), intent ( in ) :: scale_by_complement_lower ,& scale_by_complement_upper integer , dimension (:), intent ( in ) :: kminor_start_lower ,& kminor_start_upper character ( len = 128 ) :: err_message ! ---- !$acc enter data copyin(this) call this % finalize () err_message = init_abs_coeffs ( this , & available_gases , & gas_names , key_species , & band2gpt , band_lims_wavenum , & press_ref , temp_ref , & press_ref_trop , temp_ref_p , temp_ref_t , & vmr_ref , & kmajor , kminor_lower , kminor_upper , & gas_minor , identifier_minor ,& minor_gases_lower , minor_gases_upper , & minor_limits_gpt_lower , & minor_limits_gpt_upper , & minor_scales_with_density_lower , & minor_scales_with_density_upper , & scaling_gas_lower , scaling_gas_upper , & scale_by_complement_lower , & scale_by_complement_upper , & kminor_start_lower , & kminor_start_upper , & rayl_lower , rayl_upper ) ! Planck function tables ! allocate ( this % totplnk ( size ( totplnk , 1 ), size ( totplnk , 2 )), & this % planck_frac ( size ( planck_frac , 4 ), size ( planck_frac , 2 ), size ( planck_frac , 3 ), size ( planck_frac , 1 )), & this % optimal_angle_fit ( size ( optimal_angle_fit , 1 ), size ( optimal_angle_fit , 2 ))) this % totplnk = totplnk ! this%planck_frac = planck_frac this % planck_frac = RESHAPE ( planck_frac ,( / size ( planck_frac , 4 ), size ( planck_frac , 2 ), & size ( planck_frac , 3 ), size ( planck_frac , 1 ) / ), ORDER = ( / 4 , 2 , 3 , 1 / )) this % optimal_angle_fit = optimal_angle_fit !$acc enter data copyin(this%totplnk, this%planck_frac, this%optimal_angle_fit) !$omp target enter data map(to:this%totplnk, this%planck_frac, this%optimal_angle_fit) ! Temperature steps for Planck function interpolation ! Assumes that temperature minimum and max are the same for the absorption coefficient grid and the ! Planck grid and the Planck grid is equally spaced this % totplnk_delta = ( this % temp_ref_max - this % temp_ref_min ) / ( size ( this % totplnk , dim = 1 ) - 1 ) end function load_int !-------------------------------------------------------------------------------------------------------------------- ! ! Initialize object based on data read from netCDF file however the user desires. ! Rayleigh scattering tables may or may not be present; this is indicated with allocation status ! This interface is for the external-sources object -- includes TOA source function table ! function load_ext ( this , available_gases , gas_names , key_species , & band2gpt , band_lims_wavenum , & press_ref , press_ref_trop , temp_ref , & temp_ref_p , temp_ref_t , vmr_ref , & kmajor , kminor_lower , kminor_upper , & gas_minor , identifier_minor , & minor_gases_lower , minor_gases_upper , & minor_limits_gpt_lower , minor_limits_gpt_upper , & minor_scales_with_density_lower , & minor_scales_with_density_upper , & scaling_gas_lower , scaling_gas_upper , & scale_by_complement_lower , & scale_by_complement_upper , & kminor_start_lower , & kminor_start_upper , & solar_quiet , solar_facular , solar_sunspot , & tsi_default , mg_default , sb_default , & rayl_lower , rayl_upper ) result ( err_message ) class ( ty_gas_optics_rrtmgp ), intent ( inout ) :: this class ( ty_gas_concs ), intent ( in ) :: available_gases ! Which gases does the host model have available? character ( len =* ), & dimension (:), intent ( in ) :: gas_names integer , dimension (:,:,:), intent ( in ) :: key_species integer , dimension (:,:), intent ( in ) :: band2gpt real ( wp ), dimension (:,:), intent ( in ) :: band_lims_wavenum real ( wp ), dimension (:), intent ( in ) :: press_ref , temp_ref real ( wp ), intent ( in ) :: press_ref_trop , temp_ref_p , temp_ref_t real ( wp ), dimension (:,:,:), intent ( in ) :: vmr_ref real ( wp ), dimension (:,:,:,:), intent ( in ) :: kmajor real ( wp ), dimension (:,:,:), intent ( in ) :: kminor_lower , kminor_upper character ( len =* ), dimension (:), & intent ( in ) :: gas_minor , & identifier_minor character ( len =* ), dimension (:), & intent ( in ) :: minor_gases_lower , & minor_gases_upper integer , dimension (:,:), intent ( in ) :: & minor_limits_gpt_lower , & minor_limits_gpt_upper logical ( wl ), dimension (:), intent ( in ) :: & minor_scales_with_density_lower , & minor_scales_with_density_upper character ( len =* ), dimension (:), intent ( in ) :: & scaling_gas_lower , & scaling_gas_upper logical ( wl ), dimension (:), intent ( in ) :: & scale_by_complement_lower , & scale_by_complement_upper integer , dimension (:), intent ( in ) :: & kminor_start_lower , & kminor_start_upper real ( wp ), dimension (:), intent ( in ) :: solar_quiet , & solar_facular , & solar_sunspot real ( wp ), intent ( in ) :: tsi_default , & mg_default , sb_default real ( wp ), dimension (:,:,:), intent ( in ), & allocatable :: rayl_lower , rayl_upper character ( len = 128 ) err_message integer :: ngpt ! ---- !$acc enter data copyin(this) call this % finalize () err_message = init_abs_coeffs ( this , & available_gases , & gas_names , key_species , & band2gpt , band_lims_wavenum , & press_ref , temp_ref , & press_ref_trop , temp_ref_p , temp_ref_t , & vmr_ref , & kmajor , kminor_lower , kminor_upper , & gas_minor , identifier_minor , & minor_gases_lower , minor_gases_upper , & minor_limits_gpt_lower , & minor_limits_gpt_upper , & minor_scales_with_density_lower , & minor_scales_with_density_upper , & scaling_gas_lower , scaling_gas_upper , & scale_by_complement_lower , & scale_by_complement_upper , & kminor_start_lower , & kminor_start_upper , & rayl_lower , rayl_upper ) if ( err_message == \"\" ) then ! ! Spectral solar irradiance terms init ! ngpt = size ( solar_quiet ) allocate ( this % solar_source_quiet ( ngpt ), this % solar_source_facular ( ngpt ), & this % solar_source_sunspot ( ngpt ), this % solar_source ( ngpt )) !$acc enter data create( this%solar_source_quiet, this%solar_source_facular, this%solar_source_sunspot, this%solar_source) !$omp target enter data map(alloc:this%solar_source_quiet, this%solar_source_facular, this%solar_source_sunspot, this%solar_source) !$acc kernels !$omp target this % solar_source_quiet = solar_quiet this % solar_source_facular = solar_facular this % solar_source_sunspot = solar_sunspot !$acc end kernels !$omp end target err_message = this % set_solar_variability ( mg_default , sb_default ) endif end function load_ext !-------------------------------------------------------------------------------------------------------------------- ! ! Initialize absorption coefficient arrays, ! including Rayleigh scattering tables if provided (allocated) ! function init_abs_coeffs ( this , & available_gases , & gas_names , key_species , & band2gpt , band_lims_wavenum , & press_ref , temp_ref , & press_ref_trop , temp_ref_p , temp_ref_t , & vmr_ref , & kmajor , kminor_lower , kminor_upper , & gas_minor , identifier_minor ,& minor_gases_lower , minor_gases_upper , & minor_limits_gpt_lower , & minor_limits_gpt_upper , & minor_scales_with_density_lower , & minor_scales_with_density_upper , & scaling_gas_lower , scaling_gas_upper , & scale_by_complement_lower , & scale_by_complement_upper , & kminor_start_lower , & kminor_start_upper , & rayl_lower , rayl_upper ) result ( err_message ) class ( ty_gas_optics_rrtmgp ), intent ( inout ) :: this class ( ty_gas_concs ), intent ( in ) :: available_gases character ( len =* ), & dimension (:), intent ( in ) :: gas_names integer , dimension (:,:,:), intent ( in ) :: key_species integer , dimension (:,:), intent ( in ) :: band2gpt real ( wp ), dimension (:,:), intent ( in ) :: band_lims_wavenum real ( wp ), dimension (:), intent ( in ) :: press_ref , temp_ref real ( wp ), intent ( in ) :: press_ref_trop , temp_ref_p , temp_ref_t real ( wp ), dimension (:,:,:), intent ( in ) :: vmr_ref real ( wp ), dimension (:,:,:,:), intent ( in ) :: kmajor real ( wp ), dimension (:,:,:), intent ( in ) :: kminor_lower , kminor_upper character ( len =* ), dimension (:), & intent ( in ) :: gas_minor , & identifier_minor character ( len =* ), dimension (:), & intent ( in ) :: minor_gases_lower , & minor_gases_upper integer , dimension (:,:), intent ( in ) :: minor_limits_gpt_lower , & minor_limits_gpt_upper logical ( wl ), dimension (:), intent ( in ) :: minor_scales_with_density_lower , & minor_scales_with_density_upper character ( len =* ), dimension (:),& intent ( in ) :: scaling_gas_lower , & scaling_gas_upper logical ( wl ), dimension (:), intent ( in ) :: scale_by_complement_lower , & scale_by_complement_upper integer , dimension (:), intent ( in ) :: kminor_start_lower , & kminor_start_upper real ( wp ), dimension (:,:,:), intent ( in ), & allocatable :: rayl_lower , rayl_upper character ( len = 128 ) :: err_message ! -------------------------------------------------------------------------- logical , dimension (:), allocatable :: gas_is_present logical , dimension (:), allocatable :: key_species_present_init integer , dimension (:,:,:), allocatable :: key_species_red real ( wp ), dimension (:,:,:), allocatable :: vmr_ref_red character ( len = 256 ), & dimension (:), allocatable :: minor_gases_lower_red , & minor_gases_upper_red character ( len = 256 ), & dimension (:), allocatable :: scaling_gas_lower_red , & scaling_gas_upper_red integer :: i , j , idx integer :: ngas ! -------------------------------------- err_message = this % ty_optical_props % init ( band_lims_wavenum , band2gpt ) if ( len_trim ( err_message ) /= 0 ) return ! ! Which gases known to the gas optics are present in the host model (available_gases)? ! ngas = size ( gas_names ) allocate ( gas_is_present ( ngas )) do i = 1 , ngas ! Next line causes a compiler bug in gfortran 11.0.1 on Mac ARM ! Should replace gas_names with get_gas_names() and make gas_names private in ty_gas_concs gas_is_present ( i ) = string_in_array ( gas_names ( i ), available_gases % gas_names ) end do ! ! Now the number of gases is the union of those known to the k-distribution and provided ! by the host model ! ngas = count ( gas_is_present ) ! ! Initialize the gas optics object, keeping only those gases known to the ! gas optics and also present in the host model ! this % gas_names = pack ( gas_names , mask = gas_is_present ) ! Copy-ins below allocate ( vmr_ref_red ( size ( vmr_ref , dim = 1 ), 0 : ngas , & size ( vmr_ref , dim = 3 ))) ! Gas 0 is used in single-key species method, set to 1.0 (col_dry) vmr_ref_red (:, 0 ,:) = vmr_ref (:, 1 ,:) do i = 1 , ngas idx = string_loc_in_array ( this % gas_names ( i ), gas_names ) vmr_ref_red (:, i ,:) = vmr_ref (:, idx + 1 ,:) enddo call move_alloc ( vmr_ref_red , this % vmr_ref ) !$acc enter data copyin(this%vmr_ref, this%gas_names) !$omp target enter data map(to:this%vmr_ref, this%gas_names) ! ! Reduce minor arrays so variables only contain minor gases that are available ! Reduce size of minor Arrays ! call reduce_minor_arrays ( available_gases , & gas_minor , identifier_minor , & kminor_lower , & minor_gases_lower , & minor_limits_gpt_lower , & minor_scales_with_density_lower , & scaling_gas_lower , & scale_by_complement_lower , & kminor_start_lower , & this % kminor_lower , & minor_gases_lower_red , & this % minor_limits_gpt_lower , & this % minor_scales_with_density_lower , & scaling_gas_lower_red , & this % scale_by_complement_lower , & this % kminor_start_lower ) call reduce_minor_arrays ( available_gases , & gas_minor , identifier_minor ,& kminor_upper , & minor_gases_upper , & minor_limits_gpt_upper , & minor_scales_with_density_upper , & scaling_gas_upper , & scale_by_complement_upper , & kminor_start_upper , & this % kminor_upper , & minor_gases_upper_red , & this % minor_limits_gpt_upper , & this % minor_scales_with_density_upper , & scaling_gas_upper_red , & this % scale_by_complement_upper , & this % kminor_start_upper ) !$acc enter data copyin(this%minor_limits_gpt_lower, this%minor_limits_gpt_upper) !$omp target enter data map(to:this%minor_limits_gpt_lower, this%minor_limits_gpt_upper) !$acc enter data copyin(this%minor_scales_with_density_lower, this%minor_scales_with_density_upper) !$omp target enter data map(to:this%minor_scales_with_density_lower, this%minor_scales_with_density_upper) !$acc enter data copyin(this%scale_by_complement_lower, this%scale_by_complement_upper) !$omp target enter data map(to:this%scale_by_complement_lower, this%scale_by_complement_upper) !$acc enter data copyin(this%kminor_start_lower, this%kminor_start_upper) !$omp target enter data map(to:this%kminor_start_lower, this%kminor_start_upper) !$acc enter data copyin(this%kminor_lower, this%kminor_upper) !$omp target enter data map(to:this%kminor_lower, this%kminor_upper) ! Arrays not reduced by the presence, or lack thereof, of a gas allocate ( this % press_ref ( size ( press_ref )), this % temp_ref ( size ( temp_ref )), & this % kmajor ( size ( kmajor , 4 ), size ( kmajor , 2 ), size ( kmajor , 3 ), size ( kmajor , 1 ))) this % press_ref (:) = press_ref (:) this % temp_ref (:) = temp_ref (:) this % kmajor = RESHAPE ( kmajor ,( / size ( kmajor , 4 ), size ( kmajor , 2 ), size ( kmajor , 3 ), size ( kmajor , 1 ) / ), ORDER = ( / 4 , 2 , 3 , 1 / )) !$acc enter data copyin(this%press_ref, this%temp_ref, this%kmajor) !$omp target enter data map(to:this%press_ref, this%temp_ref, this%kmajor) if ( allocated ( rayl_lower ) . neqv . allocated ( rayl_upper )) then err_message = \"rayl_lower and rayl_upper must have the same allocation status\" return end if if ( allocated ( rayl_lower )) then allocate ( this % krayl ( size ( rayl_lower , dim = 3 ), size ( rayl_lower , dim = 2 ), size ( rayl_lower , dim = 1 ), 2 )) this % krayl (:,:,:, 1 ) = RESHAPE ( rayl_lower ,( / size ( rayl_lower , dim = 3 ), size ( rayl_lower , dim = 2 ), & size ( rayl_lower , dim = 1 ) / ), ORDER = ( / 3 , 2 , 1 / )) this % krayl (:,:,:, 2 ) = RESHAPE ( rayl_upper ,( / size ( rayl_lower , dim = 3 ), size ( rayl_lower , dim = 2 ), & size ( rayl_lower , dim = 1 ) / ), ORDER = ( / 3 , 2 , 1 / )) !$acc enter data copyin(this%krayl) !$omp target enter data map(to:this%krayl) end if ! ---- post processing ---- ! creates log reference pressure allocate ( this % press_ref_log ( size ( this % press_ref ))) this % press_ref_log (:) = log ( this % press_ref (:)) !$acc enter data copyin(this%press_ref_log) !$omp target enter data map(to:this%press_ref_log) ! log scale of reference pressure this % press_ref_trop_log = log ( press_ref_trop ) ! Get index of gas (if present) for determining col_gas call create_idx_minor ( this % gas_names , gas_minor , identifier_minor , minor_gases_lower_red , this % idx_minor_lower ) call create_idx_minor ( this % gas_names , gas_minor , identifier_minor , minor_gases_upper_red , this % idx_minor_upper ) ! Get index of gas (if present) that has special treatment in density scaling call create_idx_minor_scaling ( this % gas_names , scaling_gas_lower_red , this % idx_minor_scaling_lower ) call create_idx_minor_scaling ( this % gas_names , scaling_gas_upper_red , this % idx_minor_scaling_upper ) !$acc enter data copyin(this%idx_minor_lower, this%idx_minor_upper) !$omp target enter data map(to:this%idx_minor_lower, this%idx_minor_upper) !$acc enter data copyin(this%idx_minor_scaling_lower, this%idx_minor_scaling_upper) !$omp target enter data map(to:this%idx_minor_scaling_lower, this%idx_minor_scaling_upper) ! create flavor list ! Reduce (remap) key_species list; checks that all key gases are present in incoming call create_key_species_reduce ( gas_names , this % gas_names , & key_species , key_species_red , key_species_present_init ) err_message = check_key_species_present_init ( gas_names , key_species_present_init ) if ( len_trim ( err_message ) /= 0 ) return ! create flavor list call create_flavor ( key_species_red , this % flavor ) ! create gpoint_flavor list call create_gpoint_flavor ( key_species_red , this % get_gpoint_bands (), this % flavor , this % gpoint_flavor ) !Copy-ins at end of subroutine ! minimum, maximum reference temperature, pressure -- assumes low-to-high ordering ! for T, high-to-low ordering for p this % temp_ref_min = this % temp_ref ( 1 ) this % temp_ref_max = this % temp_ref ( size ( this % temp_ref )) this % press_ref_min = this % press_ref ( size ( this % press_ref )) this % press_ref_max = this % press_ref ( 1 ) ! creates press_ref_log, temp_ref_delta this % press_ref_log_delta = ( log ( this % press_ref_min ) - log ( this % press_ref_max )) / ( size ( this % press_ref ) - 1 ) this % temp_ref_delta = ( this % temp_ref_max - this % temp_ref_min ) / ( size ( this % temp_ref ) - 1 ) ! Which species are key in one or more bands? ! this%flavor is an index into this%gas_names ! if ( allocated ( this % is_key )) deallocate ( this % is_key ) ! Shouldn't ever happen... allocate ( this % is_key ( this % get_ngas ())) this % is_key (:) = . False . do j = 1 , size ( this % flavor , 2 ) do i = 1 , size ( this % flavor , 1 ) ! extents should be 2 if ( this % flavor ( i , j ) /= 0 ) this % is_key ( this % flavor ( i , j )) = . true . end do end do !$acc enter data copyin(this%flavor, this%gpoint_flavor, this%is_key) !$omp target enter data map(to:this%flavor, this%gpoint_flavor, this%is_key) end function init_abs_coeffs ! ---------------------------------------------------------------------------------------------------- function check_key_species_present_init ( gas_names , key_species_present_init ) result ( err_message ) logical , dimension (:), intent ( in ) :: key_species_present_init character ( len =* ), dimension (:), intent ( in ) :: gas_names character ( len = 128 ) :: err_message integer :: i err_message = '' do i = 1 , size ( key_species_present_init ) if (. not . key_species_present_init ( i )) & err_message = ' ' // trim ( gas_names ( i )) // trim ( err_message ) end do if ( len_trim ( err_message ) > 0 ) err_message = \"gas_optics: required gases\" // trim ( err_message ) // \" are not provided\" end function check_key_species_present_init !------------------------------------------------------------------------------------------ ! ! Ensure that every key gas required by the k-distribution is ! present in the gas concentration object ! function check_key_species_present ( this , gas_desc ) result ( error_msg ) class ( ty_gas_optics_rrtmgp ), intent ( in ) :: this class ( ty_gas_concs ), intent ( in ) :: gas_desc character ( len = 128 ) :: error_msg ! Local variables character ( len = 32 ), dimension ( count ( this % is_key (:) )) :: key_gas_names integer :: igas ! -------------------------------------- error_msg = \"\" key_gas_names = pack ( this % gas_names , mask = this % is_key ) do igas = 1 , size ( key_gas_names ) ! Next line causes a compiler bug in gfortran 11.0.1 on Mac ARM ! Should replace gas_names with get_gas_names() and make gas_names private in ty_gas_concs if (. not . string_in_array ( key_gas_names ( igas ), gas_desc % gas_names )) & error_msg = ' ' // trim ( lower_case ( key_gas_names ( igas ))) // trim ( error_msg ) end do if ( len_trim ( error_msg ) > 0 ) error_msg = \"gas_optics: required gases\" // trim ( error_msg ) // \" are not provided\" end function check_key_species_present !-------------------------------------------------------------------------------------------------------------------- ! ! Inquiry functions ! !-------------------------------------------------------------------------------------------------------------------- ! !> return true if initialized for internal sources/longwave, false otherwise ! pure function source_is_internal ( this ) class ( ty_gas_optics_rrtmgp ), intent ( in ) :: this logical :: source_is_internal source_is_internal = allocated ( this % totplnk ) . and . allocated ( this % planck_frac ) end function source_is_internal !-------------------------------------------------------------------------------------------------------------------- ! !> return true if initialized for external sources/shortwave, false otherwise ! pure function source_is_external ( this ) class ( ty_gas_optics_rrtmgp ), intent ( in ) :: this logical :: source_is_external source_is_external = allocated ( this % solar_source ) end function source_is_external !-------------------------------------------------------------------------------------------------------------------- ! !> return the names of the gases known to the k-distributions ! pure function get_gases ( this ) class ( ty_gas_optics_rrtmgp ), intent ( in ) :: this character ( 32 ), dimension ( get_ngas ( this )) :: get_gases !! names of the gases known to the k-distributions get_gases = this % gas_names end function get_gases !-------------------------------------------------------------------------------------------------------------------- ! !> return the minimum pressure on the interpolation grids ! pure function get_press_min ( this ) class ( ty_gas_optics_rrtmgp ), intent ( in ) :: this real ( wp ) :: get_press_min !! minimum pressure for which the k-dsitribution is valid get_press_min = this % press_ref_min end function get_press_min !-------------------------------------------------------------------------------------------------------------------- ! !> return the maximum pressure on the interpolation grids ! pure function get_press_max ( this ) class ( ty_gas_optics_rrtmgp ), intent ( in ) :: this real ( wp ) :: get_press_max !! maximum pressure for which the k-dsitribution is valid get_press_max = this % press_ref_max end function get_press_max !-------------------------------------------------------------------------------------------------------------------- ! !> return the minimum temparature on the interpolation grids ! pure function get_temp_min ( this ) class ( ty_gas_optics_rrtmgp ), intent ( in ) :: this real ( wp ) :: get_temp_min !! minimum temperature for which the k-dsitribution is valid get_temp_min = this % temp_ref_min end function get_temp_min !-------------------------------------------------------------------------------------------------------------------- ! !> return the maximum temparature on the interpolation grids ! pure function get_temp_max ( this ) class ( ty_gas_optics_rrtmgp ), intent ( in ) :: this real ( wp ) :: get_temp_max !! maximum temperature for which the k-dsitribution is valid get_temp_max = this % temp_ref_max end function get_temp_max !-------------------------------------------------------------------------------------------------------------------- ! !> Utility function, provided for user convenience !> computes column amounts of dry air using hydrostatic equation ! function get_col_dry ( vmr_h2o , plev , latitude ) result ( col_dry ) ! input real ( wp ), dimension (:,:), intent ( in ) :: vmr_h2o ! volume mixing ratio of water vapor to dry air; (ncol,nlay) real ( wp ), dimension (:,:), intent ( in ) :: plev ! Layer boundary pressures [Pa] (ncol,nlay+1) real ( wp ), dimension (:), optional , & intent ( in ) :: latitude ! Latitude [degrees] (ncol) ! output real ( wp ), dimension ( size ( plev , dim = 1 ), size ( plev , dim = 2 ) - 1 ) :: col_dry ! Column dry amount (ncol,nlay) ! ------------------------------------------------ ! first and second term of Helmert formula real ( wp ), parameter :: helmert1 = 9.80665_wp real ( wp ), parameter :: helmert2 = 0.02586_wp ! local variables real ( wp ), dimension ( size ( plev , dim = 1 )) :: g0 ! (ncol) real ( wp ) :: delta_plev , m_air , fact integer :: ncol , nlev integer :: icol , ilev ! nlay = nlev-1 ! ------------------------------------------------ ncol = size ( plev , dim = 1 ) nlev = size ( plev , dim = 2 ) !$acc data create(g0) !$omp target data map(alloc:g0) if ( present ( latitude )) then ! A purely OpenACC implementation would probably compute g0 within the kernel below !$acc parallel loop !$omp target teams distribute parallel do simd do icol = 1 , ncol g0 ( icol ) = helmert1 - helmert2 * cos ( 2.0_wp * pi * latitude ( icol ) / 18 0.0_wp ) ! acceleration due to gravity [m/s^2] end do else !$acc parallel loop !$omp target teams distribute parallel do simd do icol = 1 , ncol g0 ( icol ) = grav end do end if !$acc parallel loop gang vector collapse(2) copyin(plev,vmr_h2o) copyout(col_dry) !$omp target teams distribute parallel do simd collapse(2) map(to:plev,vmr_h2o) map(from:col_dry) do ilev = 1 , nlev - 1 do icol = 1 , ncol delta_plev = abs ( plev ( icol , ilev ) - plev ( icol , ilev + 1 )) ! Get average mass of moist air per mole of moist air fact = 1._wp / ( 1. + vmr_h2o ( icol , ilev )) m_air = ( m_dry + m_h2o * vmr_h2o ( icol , ilev )) * fact col_dry ( icol , ilev ) = 1 0._wp * delta_plev * avogad * fact / ( 100 0._wp * m_air * 10 0._wp * g0 ( icol )) end do end do !$acc end data !$omp end target data end function get_col_dry !-------------------------------------------------------------------------------------------------------------------- ! !> Compute a transport angle that minimizes flux errors at surface and TOA based on empirical fits ! function compute_optimal_angles ( this , optical_props , optimal_angles ) result ( err_msg ) ! input class ( ty_gas_optics_rrtmgp ), intent ( in ) :: this class ( ty_optical_props_arry ), intent ( in ) :: optical_props !! Optical properties real ( wp ), dimension (:,:), intent ( out ) :: optimal_angles !! Secant of optical transport angle character ( len = 128 ) :: err_msg !! Empty if successful !---------------------------- integer :: ncol , nlay , ngpt integer :: icol , ilay , igpt , bnd real ( wp ) :: t , trans_total #if defined _CRAYFTN && _RELEASE_MAJOR == 14 && _RELEASE_MINOR == 0 && _RELEASE_PATCHLEVEL == 3 # define CRAY_WORKAROUND #endif #ifdef CRAY_WORKAROUND integer , allocatable :: bands (:) #else integer :: bands ( optical_props % get_ngpt ()) #endif !---------------------------- ncol = optical_props % get_ncol () nlay = optical_props % get_nlay () ngpt = optical_props % get_ngpt () #ifdef CRAY_WORKAROUND allocate ( bands ( ngpt ) ) ! In order to work with CCE 14 (it is also better software) #endif err_msg = \"\" if (. not . this % gpoints_are_equal ( optical_props )) & err_msg = \"gas_optics%compute_optimal_angles: optical_props has different spectral discretization than gas_optics\" if (. not . extents_are ( optimal_angles , ncol , ngpt )) & err_msg = \"gas_optics%compute_optimal_angles: optimal_angles different dimension (ncol)\" if ( err_msg /= \"\" ) return do igpt = 1 , ngpt bands ( igpt ) = optical_props % convert_gpt2band ( igpt ) enddo ! ! column transmissivity ! !$acc parallel loop gang vector collapse(2) copyin(bands, optical_props, optical_props%tau) copyout(optimal_angles) !$omp target teams distribute parallel do simd collapse(2) map(to:bands, optical_props%tau) map(from:optimal_angles) do icol = 1 , ncol do igpt = 1 , ngpt ! ! Column transmissivity ! t = 0._wp trans_total = 0._wp do ilay = 1 , nlay t = t + optical_props % tau ( icol , ilay , igpt ) end do trans_total = exp ( - t ) ! ! Optimal transport angle is a linear fit to column transmissivity ! optimal_angles ( icol , igpt ) = this % optimal_angle_fit ( 1 , bands ( igpt )) * trans_total + & this % optimal_angle_fit ( 2 , bands ( igpt )) end do end do end function compute_optimal_angles !-------------------------------------------------------------------------------------------------------------------- ! ! Internal procedures ! !-------------------------------------------------------------------------------------------------------------------- pure function rewrite_key_species_pair ( key_species_pair ) ! (0,0) becomes (2,2) -- because absorption coefficients for these g-points will be 0. integer , dimension ( 2 ) :: rewrite_key_species_pair integer , dimension ( 2 ), intent ( in ) :: key_species_pair rewrite_key_species_pair = key_species_pair if ( all ( key_species_pair (:). eq .( / 0 , 0 / ))) then rewrite_key_species_pair (:) = ( / 2 , 2 / ) end if end function ! --------------------------------------------------------------------------------------- ! true is key_species_pair exists in key_species_list pure function key_species_pair_exists ( key_species_list , key_species_pair ) logical :: key_species_pair_exists integer , dimension (:,:), intent ( in ) :: key_species_list integer , dimension ( 2 ), intent ( in ) :: key_species_pair integer :: i do i = 1 , size ( key_species_list , dim = 2 ) if ( all ( key_species_list (:, i ). eq . key_species_pair (:))) then key_species_pair_exists = . true . return end if end do key_species_pair_exists = . false . end function key_species_pair_exists ! --------------------------------------------------------------------------------------- ! create flavor list -- ! an unordered array of extent (2,:) containing all possible pairs of key species ! used in either upper or lower atmos ! subroutine create_flavor ( key_species , flavor ) integer , dimension (:,:,:), intent ( in ) :: key_species integer , dimension (:,:), allocatable , intent ( out ) :: flavor integer , dimension ( 2 , size ( key_species , 3 ) * 2 ) :: key_species_list integer :: ibnd , iatm , i , iflavor ! prepare list of key_species i = 1 do ibnd = 1 , size ( key_species , 3 ) ! bands do iatm = 1 , size ( key_species , 2 ) ! upper/lower atmosphere key_species_list (:, i ) = key_species (:, iatm , ibnd ) i = i + 1 end do end do ! rewrite single key_species pairs do i = 1 , size ( key_species_list , 2 ) key_species_list (:, i ) = rewrite_key_species_pair ( key_species_list (:, i )) end do ! count unique key species pairs iflavor = 0 do i = 1 , size ( key_species_list , 2 ) if (. not . key_species_pair_exists ( key_species_list (:, 1 : i - 1 ), key_species_list (:, i ))) then iflavor = iflavor + 1 end if end do ! fill flavors allocate ( flavor ( 2 , iflavor )) iflavor = 0 do i = 1 , size ( key_species_list , 2 ) if (. not . key_species_pair_exists ( key_species_list (:, 1 : i - 1 ), key_species_list (:, i ))) then iflavor = iflavor + 1 flavor (:, iflavor ) = key_species_list (:, i ) end if end do end subroutine create_flavor ! --------------------------------------------------------------------------------------- ! ! create index list for extracting col_gas needed for minor gas optical depth calculations ! subroutine create_idx_minor ( gas_names , & gas_minor , identifier_minor , minor_gases_atm , idx_minor_atm ) character ( len =* ), dimension (:), intent ( in ) :: gas_names character ( len =* ), dimension (:), intent ( in ) :: & gas_minor , & identifier_minor character ( len =* ), dimension (:), intent ( in ) :: minor_gases_atm integer , dimension (:), allocatable , & intent ( out ) :: idx_minor_atm ! local integer :: imnr integer :: idx_mnr allocate ( idx_minor_atm ( size ( minor_gases_atm , dim = 1 ))) do imnr = 1 , size ( minor_gases_atm , dim = 1 ) ! loop over minor absorbers in each band ! Find identifying string for minor species in list of possible identifiers (e.g. h2o_slf) idx_mnr = string_loc_in_array ( minor_gases_atm ( imnr ), identifier_minor ) ! Find name of gas associated with minor species identifier (e.g. h2o) idx_minor_atm ( imnr ) = string_loc_in_array ( gas_minor ( idx_mnr ), gas_names ) enddo end subroutine create_idx_minor ! --------------------------------------------------------------------------------------- ! ! create index for special treatment in density scaling of minor gases ! subroutine create_idx_minor_scaling ( gas_names , & scaling_gas_atm , idx_minor_scaling_atm ) character ( len =* ), dimension (:), intent ( in ) :: gas_names character ( len =* ), dimension (:), intent ( in ) :: scaling_gas_atm integer , dimension (:), allocatable , & intent ( out ) :: idx_minor_scaling_atm ! local integer :: imnr allocate ( idx_minor_scaling_atm ( size ( scaling_gas_atm , dim = 1 ))) do imnr = 1 , size ( scaling_gas_atm , dim = 1 ) ! loop over minor absorbers in each band ! This will be -1 if there's no interacting gas idx_minor_scaling_atm ( imnr ) = string_loc_in_array ( scaling_gas_atm ( imnr ), gas_names ) enddo end subroutine create_idx_minor_scaling !-------------------------------------------------------------------------------------------------------------------- ! Is the object ready to use? ! pure function is_loaded ( this ) class ( ty_gas_optics_rrtmgp ), intent ( in ) :: this logical ( wl ) :: is_loaded is_loaded = allocated ( this % kmajor ) end function is_loaded !-------------------------------------------------------------------------------------------------------------------- ! ! Reset the object to un-initialized state ! subroutine finalize ( this ) class ( ty_gas_optics_rrtmgp ), intent ( inout ) :: this if ( this % is_loaded ()) then !$acc exit data delete(this%gas_names, this%vmr_ref, this%flavor) & !$acc delete(this%press_ref, this%press_ref_log, this%temp_ref) & !$acc delete(this%gpoint_flavor, this%kmajor) & !$acc delete(this%minor_limits_gpt_lower) & !$acc delete(this%minor_scales_with_density_lower, this%scale_by_complement_lower) & !$acc delete(this%idx_minor_lower, this%idx_minor_scaling_lower) & !$acc delete(this%kminor_start_lower, this%kminor_lower) & !$acc delete(this%minor_limits_gpt_upper) & !$acc delete(this%minor_scales_with_density_upper, this%scale_by_complement_upper) & !$acc delete(this%idx_minor_upper, this%idx_minor_scaling_upper) & !$acc delete(this%kminor_start_upper, this%kminor_upper) !$omp target exit data map(release:this%gas_names, this%vmr_ref, this%flavor) & !$omp map(release:this%press_ref, this%press_ref_log, this%temp_ref) !$omp map(release:this%gpoint_flavor, this%kmajor) & !$omp map(release:this%minor_limits_gpt_lower) & !$omp map(release:this%minor_scales_with_density_lower, this%scale_by_complement_lower) & !$omp map(release:this%idx_minor_lower, this%idx_minor_scaling_lower) & !$omp map(release:this%kminor_start_lower, this%kminor_lower) & !$omp map(release:this%minor_limits_gpt_upper) & !$omp map(release:this%minor_scales_with_density_upper, this%scale_by_complement_upper) & !$omp map(release:this%idx_minor_upper, this%idx_minor_scaling_upper) & !$omp map(release:this%kminor_start_upper, this%kminor_upper) deallocate ( this % gas_names , this % vmr_ref , this % flavor , this % gpoint_flavor , this % kmajor ) deallocate ( this % press_ref , this % press_ref_log , this % temp_ref ) deallocate ( this % minor_limits_gpt_lower , & this % minor_scales_with_density_lower , this % scale_by_complement_lower , & this % idx_minor_lower , this % idx_minor_scaling_lower , this % kminor_start_lower , this % kminor_lower ) deallocate ( this % minor_limits_gpt_upper , & this % minor_scales_with_density_upper , this % scale_by_complement_upper , & this % idx_minor_upper , this % idx_minor_scaling_upper , this % kminor_start_upper , this % kminor_upper ) if ( allocated ( this % krayl )) then !$acc exit data delete(this%krayl) !$omp target exit data map(release:this%krayl) deallocate ( this % krayl ) end if if ( allocated ( this % planck_frac )) then !$acc exit data delete(this%planck_frac, this%totplnk, this%optimal_angle_fit) !$omp target exit data map(release:this%planck_frac, this%totplnk, this%optimal_angle_fit) deallocate ( this % planck_frac , this % totplnk , this % optimal_angle_fit ) end if if ( allocated ( this % solar_source )) then !$acc exit data delete(this%solar_source, this%solar_source_quiet) & !$acc delete(this%solar_source_facular,this%solar_source_sunspot) !$omp target exit data map(release:this%solar_source, this%solar_source_quiet) !$omp map(release:this%solar_source_facular,this%solar_source_sunspot) deallocate ( this % solar_source , & this % solar_source_quiet , this % solar_source_facular , this % solar_source_sunspot ) end if !$acc exit data delete(this) !$omp target exit data map(release:this) end if end subroutine finalize ! --------------------------------------------------------------------------------------- subroutine create_key_species_reduce ( gas_names , gas_names_red , & key_species , key_species_red , key_species_present_init ) character ( len =* ), & dimension (:), intent ( in ) :: gas_names character ( len =* ), & dimension (:), intent ( in ) :: gas_names_red integer , dimension (:,:,:), intent ( in ) :: key_species integer , dimension (:,:,:), allocatable , intent ( out ) :: key_species_red logical , dimension (:), allocatable , intent ( out ) :: key_species_present_init integer :: ip , ia , it , np , na , nt np = size ( key_species , dim = 1 ) na = size ( key_species , dim = 2 ) nt = size ( key_species , dim = 3 ) allocate ( key_species_red ( size ( key_species , dim = 1 ), & size ( key_species , dim = 2 ), & size ( key_species , dim = 3 ))) allocate ( key_species_present_init ( size ( gas_names ))) key_species_present_init = . true . do ip = 1 , np do ia = 1 , na do it = 1 , nt if ( key_species ( ip , ia , it ) . ne . 0 ) then key_species_red ( ip , ia , it ) = string_loc_in_array ( gas_names ( key_species ( ip , ia , it )), gas_names_red ) if ( key_species_red ( ip , ia , it ) . eq . - 1 ) key_species_present_init ( key_species ( ip , ia , it )) = . false . else key_species_red ( ip , ia , it ) = key_species ( ip , ia , it ) endif enddo end do enddo end subroutine create_key_species_reduce ! --------------------------------------------------------------------------------------- subroutine reduce_minor_arrays ( available_gases , & gas_minor , identifier_minor ,& kminor_atm , & minor_gases_atm , & minor_limits_gpt_atm , & minor_scales_with_density_atm , & scaling_gas_atm , & scale_by_complement_atm , & kminor_start_atm , & kminor_atm_red , & minor_gases_atm_red , & minor_limits_gpt_atm_red , & minor_scales_with_density_atm_red , & scaling_gas_atm_red , & scale_by_complement_atm_red , & kminor_start_atm_red ) class ( ty_gas_concs ), intent ( in ) :: available_gases real ( wp ), dimension (:,:,:), intent ( in ) :: kminor_atm character ( len =* ), dimension (:), intent ( in ) :: gas_minor , & identifier_minor character ( len =* ), dimension (:), intent ( in ) :: minor_gases_atm integer , dimension (:,:), intent ( in ) :: minor_limits_gpt_atm logical ( wl ), dimension (:), intent ( in ) :: minor_scales_with_density_atm character ( len =* ), dimension (:), intent ( in ) :: scaling_gas_atm logical ( wl ), dimension (:), intent ( in ) :: scale_by_complement_atm integer , dimension (:), intent ( in ) :: kminor_start_atm real ( wp ), dimension (:,:,:), allocatable , & intent ( out ) :: kminor_atm_red character ( len =* ), dimension (:), allocatable , & intent ( out ) :: minor_gases_atm_red integer , dimension (:,:), allocatable , & intent ( out ) :: minor_limits_gpt_atm_red logical ( wl ), dimension (:), allocatable , & intent ( out ) :: minor_scales_with_density_atm_red character ( len =* ), dimension (:), allocatable , & intent ( out ) :: scaling_gas_atm_red logical ( wl ), dimension (:), allocatable , intent ( out ) :: & scale_by_complement_atm_red integer , dimension (:), allocatable , intent ( out ) :: & kminor_start_atm_red ! Local variables integer :: i , j , ks integer :: idx_mnr , nm , tot_g , red_nm integer :: icnt , n_elim , ng logical , dimension (:), allocatable :: gas_is_present integer , dimension (:), allocatable :: indexes real ( wp ), dimension (:,:,:), allocatable :: kminor_atm_red_t nm = size ( minor_gases_atm ) tot_g = 0 allocate ( gas_is_present ( nm )) do i = 1 , size ( minor_gases_atm ) idx_mnr = string_loc_in_array ( minor_gases_atm ( i ), identifier_minor ) ! Next line causes a compiler bug in gfortran 11.0.1 on Mac ARM ! Should replace gas_names with get_gas_names() and make gas_names private in ty_gas_concs gas_is_present ( i ) = string_in_array ( gas_minor ( idx_mnr ), available_gases % gas_names ) if ( gas_is_present ( i )) then tot_g = tot_g + ( minor_limits_gpt_atm ( 2 , i ) - minor_limits_gpt_atm ( 1 , i ) + 1 ) endif enddo red_nm = count ( gas_is_present ) allocate ( minor_gases_atm_red ( red_nm ),& minor_scales_with_density_atm_red ( red_nm ), & scaling_gas_atm_red ( red_nm ), & scale_by_complement_atm_red ( red_nm ), & kminor_start_atm_red ( red_nm )) allocate ( minor_limits_gpt_atm_red ( 2 , red_nm )) allocate ( kminor_atm_red_t ( tot_g , size ( kminor_atm , 2 ), size ( kminor_atm , 3 ))) allocate ( kminor_atm_red ( size ( kminor_atm , 3 ), size ( kminor_atm , 2 ), tot_g )) if (( red_nm . eq . nm )) then ! Character data not allowed in OpenACC regions? minor_gases_atm_red = minor_gases_atm scaling_gas_atm_red = scaling_gas_atm kminor_atm_red_t = kminor_atm minor_limits_gpt_atm_red = minor_limits_gpt_atm minor_scales_with_density_atm_red = minor_scales_with_density_atm scale_by_complement_atm_red = scale_by_complement_atm kminor_start_atm_red = kminor_start_atm else allocate ( indexes ( red_nm )) ! Find the integer indexes for the gases that are present indexes = pack ([( i , i = 1 , size ( minor_gases_atm ))], mask = gas_is_present ) minor_gases_atm_red = minor_gases_atm ( indexes ) scaling_gas_atm_red = scaling_gas_atm ( indexes ) minor_scales_with_density_atm_red = & minor_scales_with_density_atm ( indexes ) scale_by_complement_atm_red = & scale_by_complement_atm ( indexes ) kminor_start_atm_red = kminor_start_atm ( indexes ) icnt = 0 n_elim = 0 do i = 1 , nm ng = minor_limits_gpt_atm ( 2 , i ) - minor_limits_gpt_atm ( 1 , i ) + 1 if ( gas_is_present ( i )) then icnt = icnt + 1 minor_limits_gpt_atm_red ( 1 : 2 , icnt ) = minor_limits_gpt_atm ( 1 : 2 , i ) kminor_start_atm_red ( icnt ) = kminor_start_atm ( i ) - n_elim ks = kminor_start_atm_red ( icnt ) do j = 1 , ng kminor_atm_red_t ( kminor_start_atm_red ( icnt ) + j - 1 ,:,:) = & kminor_atm ( kminor_start_atm ( i ) + j - 1 ,:,:) enddo else n_elim = n_elim + ng endif enddo endif kminor_atm_red = RESHAPE ( kminor_atm_red_t ,( / size ( kminor_atm_red_t , dim = 3 ), & size ( kminor_atm_red_t , dim = 2 ), size ( kminor_atm_red_t , dim = 1 ) / ), ORDER = ( / 3 , 2 , 1 / )) deallocate ( kminor_atm_red_t ) end subroutine reduce_minor_arrays ! --------------------------------------------------------------------------------------- ! returns flavor index; -1 if not found pure function key_species_pair2flavor ( flavor , key_species_pair ) integer :: key_species_pair2flavor integer , dimension (:,:), intent ( in ) :: flavor integer , dimension ( 2 ), intent ( in ) :: key_species_pair integer :: iflav do iflav = 1 , size ( flavor , 2 ) if ( all ( key_species_pair (:). eq . flavor (:, iflav ))) then key_species_pair2flavor = iflav return end if end do key_species_pair2flavor = - 1 end function key_species_pair2flavor ! --------------------------------------------------------------------------------------- ! ! create gpoint_flavor list ! a map pointing from each g-point to the corresponding entry in the \"flavor list\" ! subroutine create_gpoint_flavor ( key_species , gpt2band , flavor , gpoint_flavor ) integer , dimension (:,:,:), intent ( in ) :: key_species integer , dimension (:), intent ( in ) :: gpt2band integer , dimension (:,:), intent ( in ) :: flavor integer , dimension (:,:), intent ( out ), allocatable :: gpoint_flavor integer :: ngpt , igpt , iatm ngpt = size ( gpt2band ) allocate ( gpoint_flavor ( 2 , ngpt )) do igpt = 1 , ngpt do iatm = 1 , 2 gpoint_flavor ( iatm , igpt ) = key_species_pair2flavor ( & flavor , & rewrite_key_species_pair ( key_species (:, iatm , gpt2band ( igpt ))) & ) end do end do end subroutine create_gpoint_flavor !-------------------------------------------------------------------------------------------------------------------- ! ! Utility function to combine optical depths from gas absorption and Rayleigh scattering ! It may be more efficient to combine scattering and absorption optical depths in place ! rather than storing and processing two large arrays ! subroutine combine_abs_and_rayleigh ( tau , tau_rayleigh , optical_props ) real ( wp ), dimension (:,:,:), intent ( in ) :: tau real ( wp ), dimension (:,:,:), intent ( in ) :: tau_rayleigh class ( ty_optical_props_arry ), intent ( inout ) :: optical_props integer :: icol , ilay , igpt , ncol , nlay , ngpt , nmom real ( wp ) :: t ncol = size ( tau , 1 ) nlay = size ( tau , 2 ) ngpt = size ( tau , 3 ) select type ( optical_props ) type is ( ty_optical_props_1scl ) ! ! Extinction optical depth ! !$acc parallel loop gang vector collapse(3) default(present) !$omp target teams distribute parallel do simd collapse(3) do igpt = 1 , ngpt do ilay = 1 , nlay do icol = 1 , ncol optical_props % tau ( icol , ilay , igpt ) = tau ( icol , ilay , igpt ) + & tau_rayleigh ( icol , ilay , igpt ) end do end do end do ! ! asymmetry factor or phase function moments ! type is ( ty_optical_props_2str ) ! ! Extinction optical depth and single scattering albedo ! !$acc parallel loop gang vector collapse(3) default(present) !$omp target teams distribute parallel do simd collapse(3) do igpt = 1 , ngpt do ilay = 1 , nlay do icol = 1 , ncol t = tau ( icol , ilay , igpt ) + tau_rayleigh ( icol , ilay , igpt ) if ( t > 2._wp * tiny ( t )) then optical_props % ssa ( icol , ilay , igpt ) = tau_rayleigh ( icol , ilay , igpt ) / t else optical_props % ssa ( icol , ilay , igpt ) = 0._wp end if optical_props % tau ( icol , ilay , igpt ) = t end do end do end do call zero_array ( ncol , nlay , ngpt , optical_props % g ) type is ( ty_optical_props_nstr ) ! ! Extinction optical depth and single scattering albedo ! !$acc parallel loop gang vector collapse(3) default(present) !$omp target teams distribute parallel do simd collapse(3) do igpt = 1 , ngpt do ilay = 1 , nlay do icol = 1 , ncol t = tau ( icol , ilay , igpt ) + tau_rayleigh ( icol , ilay , igpt ) if ( t > 2._wp * tiny ( t )) then optical_props % ssa ( icol , ilay , igpt ) = tau_rayleigh ( icol , ilay , igpt ) / t else optical_props % ssa ( icol , ilay , igpt ) = 0._wp end if optical_props % tau ( icol , ilay , igpt ) = t end do end do end do nmom = size ( optical_props % p , 1 ) call zero_array ( nmom , ncol , nlay , ngpt , optical_props % p ) if ( nmom >= 2 ) then !$acc parallel loop gang vector collapse(3) default(present) !$omp target teams distribute parallel do simd collapse(3) do igpt = 1 , ngpt do ilay = 1 , nlay do icol = 1 , ncol optical_props % p ( 2 , icol , ilay , igpt ) = 0.1_wp end do end do end do end if end select end subroutine combine_abs_and_rayleigh !-------------------------------------------------------------------------------------------------------------------- ! Sizes of tables: pressure, temperate, eta (mixing fraction) ! Equivalent routines for the number of gases and flavors (get_ngas(), get_nflav()) are defined above because they're ! used in function defintions ! Table kmajor has dimensions (ngpt, neta, npres, ntemp) !-------------------------------------------------------------------------------------------------------------------- ! ! return extent of eta dimension ! pure function get_neta ( this ) class ( ty_gas_optics_rrtmgp ), intent ( in ) :: this integer :: get_neta get_neta = size ( this % kmajor , dim = 2 ) end function ! -------------------------------------------------------------------------------------- ! ! return the number of pressures in reference profile ! absorption coefficient table is one bigger since a pressure is repeated in upper/lower atmos ! pure function get_npres ( this ) class ( ty_gas_optics_rrtmgp ), intent ( in ) :: this integer :: get_npres get_npres = size ( this % kmajor , dim = 3 ) - 1 end function get_npres ! -------------------------------------------------------------------------------------- ! ! return the number of temperatures ! pure function get_ntemp ( this ) class ( ty_gas_optics_rrtmgp ), intent ( in ) :: this integer :: get_ntemp get_ntemp = size ( this % kmajor , dim = 1 ) end function get_ntemp ! -------------------------------------------------------------------------------------- ! ! return the number of temperatures for Planck function ! pure function get_nPlanckTemp ( this ) class ( ty_gas_optics_rrtmgp ), intent ( in ) :: this integer :: get_nPlanckTemp get_nPlanckTemp = size ( this % totplnk , dim = 1 ) ! dimensions are Planck-temperature, band end function get_nPlanckTemp end module mo_gas_optics_rrtmgp","tags":"","loc":"sourcefile/mo_gas_optics_rrtmgp.f90.html"}]} \ No newline at end of file diff --git a/reference/rrtmgp-fortran-interface/type/ty_aerosol_optics_rrtmgp_merra.html b/reference/rrtmgp-fortran-interface/type/ty_aerosol_optics_rrtmgp_merra.html index 183d9cf8d..b8d810fe2 100644 --- a/reference/rrtmgp-fortran-interface/type/ty_aerosol_optics_rrtmgp_merra.html +++ b/reference/rrtmgp-fortran-interface/type/ty_aerosol_optics_rrtmgp_merra.html @@ -87,7 +87,7 @@

ty_aerosol_optics_rrtmgp_merra
  • 17 statements + title="

    17.3% of total for derived types.

    Including implementation: 196 statements, 20.2% of total for derived types.">17 statements
  • Source File
    • @@ -133,8 +133,8 @@

    Contents

    @@ -245,8 +245,8 @@

    Contents

    @@ -369,7 +369,7 @@

    Return Value character(len=128)

    -

    procedure, public :: finalize

    +

    procedure, public :: finalize

    • private subroutine finalize(this)

      @@ -391,7 +391,7 @@

      Arguments

      -

      generic, public :: load => load_lut

      +

      generic, public :: load => load_lut

      • private function load_lut(this, band_lims_wvn, merra_aero_bin_lims, aero_rh, aero_dust_tbl, aero_salt_tbl, aero_sulf_tbl, aero_bcar_tbl, aero_bcar_rh_tbl, aero_ocar_tbl, aero_ocar_rh_tbl) result(error_msg)

        diff --git a/reference/rrtmgp-fortran-interface/type/ty_cloud_optics_rrtmgp.html b/reference/rrtmgp-fortran-interface/type/ty_cloud_optics_rrtmgp.html index 9d0651cc5..c9d89a210 100644 --- a/reference/rrtmgp-fortran-interface/type/ty_cloud_optics_rrtmgp.html +++ b/reference/rrtmgp-fortran-interface/type/ty_cloud_optics_rrtmgp.html @@ -87,7 +87,7 @@

        ty_cloud_optics_rrtmgp
      • 28 statements + title="

        28.6% of total for derived types.

        Including implementation: 341 statements, 35.2% of total for derived types.">28 statements
      • Source File

      @@ -151,13 +151,13 @@

      Contents

      @@ -287,13 +287,13 @@

      Contents

      @@ -507,7 +507,7 @@

      Return Value character(len=128)

      -

      procedure, public :: finalize

      +

      procedure, public :: finalize

      • private subroutine finalize(this)

        @@ -644,7 +644,7 @@

        Return Value integer

      -

      generic, public :: load => load_lut, load_pade

      +

      generic, public :: load => load_lut, load_pade

      • private function load_lut(this, band_lims_wvn, radliq_lwr, radliq_upr, radice_lwr, radice_upr, lut_extliq, lut_ssaliq, lut_asyliq, lut_extice, lut_ssaice, lut_asyice) result(error_msg)

        diff --git a/reference/rrtmgp-fortran-interface/type/ty_gas_optics_rrtmgp.html b/reference/rrtmgp-fortran-interface/type/ty_gas_optics_rrtmgp.html index 3e68f59f8..9578a3cf1 100644 --- a/reference/rrtmgp-fortran-interface/type/ty_gas_optics_rrtmgp.html +++ b/reference/rrtmgp-fortran-interface/type/ty_gas_optics_rrtmgp.html @@ -87,7 +87,7 @@

        ty_gas_optics_rrtmgp
      • 53 statements + title="

        54.1% of total for derived types.

        Including implementation: 431 statements, 44.5% of total for derived types.">53 statements
      • Source File

      @@ -163,7 +163,7 @@

      Contents

      compute_optimal_angles - finalize + finalize gas_optics_ext gas_optics_int get_gases @@ -173,7 +173,7 @@

      Contents

      get_temp_max get_temp_min is_loaded - load + load set_solar_variability set_tsi source_is_external @@ -318,7 +318,7 @@

      Contents

      compute_optimal_angles - finalize + finalize gas_optics_ext gas_optics_int get_gases @@ -328,7 +328,7 @@

      Contents

      get_temp_max get_temp_min is_loaded - load + load set_solar_variability set_tsi source_is_external @@ -588,7 +588,7 @@

      Return Value character(len=128)

      Empty if successful<

      -

      procedure, public :: finalize

      +

      procedure, public :: finalize

      • private subroutine finalize(this)

        @@ -937,7 +937,7 @@

        Return Value logical(kind=wl)

      -

      generic, public :: load => load_int, load_ext

      +

      generic, public :: load => load_int, load_ext

      • private function load_int(this, available_gases, gas_names, key_species, band2gpt, band_lims_wavenum, press_ref, press_ref_trop, temp_ref, temp_ref_p, temp_ref_t, vmr_ref, kmajor, kminor_lower, kminor_upper, gas_minor, identifier_minor, minor_gases_lower, minor_gases_upper, minor_limits_gpt_lower, minor_limits_gpt_upper, minor_scales_with_density_lower, minor_scales_with_density_upper, scaling_gas_lower, scaling_gas_upper, scale_by_complement_lower, scale_by_complement_upper, kminor_start_lower, kminor_start_upper, totplnk, planck_frac, rayl_lower, rayl_upper, optimal_angle_fit) result(err_message)

        diff --git a/reference/rrtmgp-kernels/index.html b/reference/rrtmgp-kernels/index.html index bcb554763..e9d7a1117 100644 --- a/reference/rrtmgp-kernels/index.html +++ b/reference/rrtmgp-kernels/index.html @@ -49,14 +49,14 @@ aria-haspopup="true" aria-expanded="false">Contents
        • - +
      @@ -103,19 +103,25 @@

      The RTE+RRTTMGP consortium

      Source Files

      Modules

      Procedures

      diff --git a/reference/rrtmgp-kernels/interface/compute_planck_source.html b/reference/rrtmgp-kernels/interface/compute_planck_source.html new file mode 100644 index 000000000..5a7d02324 --- /dev/null +++ b/reference/rrtmgp-kernels/interface/compute_planck_source.html @@ -0,0 +1,358 @@ + + + + + + + + + + + + compute_Planck_source – RRTMGP kernels + + + + + + + + + + + + + + + + + + + + +
      +
      +

      compute_Planck_source + Interface +

      +
      +
      +
      + +
        +
      1. mo_gas_optics_rrtmgp_kernels.F90
        2. +
      2. mo_gas_optics_rrtmgp_kernels
        3. +
      3. compute_Planck_source
        4. +
      +
      +
      +
      + + +
      + +
      + + +
      +

      interface
      + public subroutine compute_Planck_source(ncol, nlay, nbnd, ngpt, nflav, neta, npres, ntemp, nPlanckTemp, tlay, tlev, tsfc, sfc_lay, fmajor, jeta, tropo, jtemp, jpress, gpoint_bands, band_lims_gpt, pfracin, temp_ref_min, totplnk_delta, totplnk, gpoint_flavor, sfc_src, lay_src, lev_src, sfc_source_Jac) bind(C, name="0")

      + + + +

      Arguments

      +
      + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
      TypeIntentOptionalAttributesName
      integer,intent(in) ::ncol

      input dimensions

      integer,intent(in) ::nlay

      input dimensions

      integer,intent(in) ::nbnd

      input dimensions

      integer,intent(in) ::ngpt

      input dimensions

      integer,intent(in) ::nflav

      table dimensions

      integer,intent(in) ::neta

      table dimensions

      integer,intent(in) ::npres

      table dimensions

      integer,intent(in) ::ntemp

      table dimensions

      integer,intent(in) ::nPlanckTemp

      table dimensions

      real(kind=wp),intent(in), dimension(ncol,nlay )::tlay

      temperature at layer centers (K)

      real(kind=wp),intent(in), dimension(ncol,nlay+1)::tlev

      temperature at interfaces (K)

      real(kind=wp),intent(in), dimension(ncol )::tsfc

      surface temperture

      integer,intent(in) ::sfc_lay

      index into surface layer

      real(kind=wp),intent(in), dimension(2,2,2,ncol,nlay,nflav)::fmajor

      interpolation weights for major gases - computed in interpolation()

      integer,intent(in), dimension(2, ncol,nlay,nflav)::jeta

      interpolation indexes in eta - computed in interpolation()

      logical(kind=wl),intent(in), dimension( ncol,nlay)::tropo

      use upper- or lower-atmospheric tables?

      integer,intent(in), dimension( ncol,nlay)::jtemp

      interpolation indexes in temperature and pressure - computed in interpolation()

      integer,intent(in), dimension( ncol,nlay)::jpress

      interpolation indexes in temperature and pressure - computed in interpolation()

      integer,intent(in), dimension(ngpt)::gpoint_bands

      band to which each g-point belongs

      integer,intent(in), dimension(2, nbnd)::band_lims_gpt

      start and end g-point for each band

      real(kind=wp),intent(in), dimension(ntemp,neta,npres+1,ngpt)::pfracin

      Fraction of the Planck function in each g-point

      real(kind=wp),intent(in) ::temp_ref_min

      interpolation constants

      real(kind=wp),intent(in) ::totplnk_delta

      interpolation constants

      real(kind=wp),intent(in), dimension(nPlanckTemp,nbnd)::totplnk

      Total Planck function by band at each temperature

      integer,intent(in), dimension(2,ngpt)::gpoint_flavor

      major gas flavor (pair) by upper/lower, g-point

      real(kind=wp),intent(out), dimension(ncol, ngpt)::sfc_src

      Planck emssion from the surface

      real(kind=wp),intent(out), dimension(ncol,nlay, ngpt)::lay_src

      Planck emssion from layer centers

      real(kind=wp),intent(out), dimension(ncol,nlay+1,ngpt)::lev_src

      Planck emission at layer boundaries

      real(kind=wp),intent(out), dimension(ncol, ngpt)::sfc_source_Jac

      Jacobian (derivative) of the surface Planck source with respect to surface temperature

      + +
      + +
    + + +
    + +
    +
    +
    +

    RRTMGP kernels was developed by The RTE+RRTTMGP consortium
    © 2024 Creative Commons License +

    +
    +
    +

    + Documentation generated by + FORD +

    +
    +
    +
    +
    +
    + + + + + + + + + + + + + + + + + + + \ No newline at end of file diff --git a/reference/rrtmgp-kernels/interface/compute_tau_absorption.html b/reference/rrtmgp-kernels/interface/compute_tau_absorption.html new file mode 100644 index 000000000..1d5a92aba --- /dev/null +++ b/reference/rrtmgp-kernels/interface/compute_tau_absorption.html @@ -0,0 +1,436 @@ + + + + + + + + + + + + compute_tau_absorption – RRTMGP kernels + + + + + + + + + + + + + + + + + + + + +
    +
    +

    compute_tau_absorption + Interface +

    +
    +
    +
    + +
      +
    1. mo_gas_optics_rrtmgp_kernels.F90
      2. +
    2. mo_gas_optics_rrtmgp_kernels
      3. +
    3. compute_tau_absorption
      4. +
    +
    +
    +
    + + +
    + +
    + + +
    +

    interface
    + public subroutine compute_tau_absorption(ncol, nlay, nbnd, ngpt, ngas, nflav, neta, npres, ntemp, nminorlower, nminorklower, nminorupper, nminorkupper, idx_h2o, gpoint_flavor, band_lims_gpt, kmajor, kminor_lower, kminor_upper, minor_limits_gpt_lower, minor_limits_gpt_upper, minor_scales_with_density_lower, minor_scales_with_density_upper, scale_by_complement_lower, scale_by_complement_upper, idx_minor_lower, idx_minor_upper, idx_minor_scaling_lower, idx_minor_scaling_upper, kminor_start_lower, kminor_start_upper, tropo, col_mix, fmajor, fminor, play, tlay, col_gas, jeta, jtemp, jpress, tau) bind(C, name="0")

    + + + +

    Arguments

    + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
    TypeIntentOptionalAttributesName
    integer,intent(in) ::ncol

    array sizes

    integer,intent(in) ::nlay

    array sizes

    integer,intent(in) ::nbnd

    array sizes

    integer,intent(in) ::ngpt

    array sizes

    integer,intent(in) ::ngas

    tables sizes

    integer,intent(in) ::nflav

    tables sizes

    integer,intent(in) ::neta

    tables sizes

    integer,intent(in) ::npres

    tables sizes

    integer,intent(in) ::ntemp

    tables sizes

    integer,intent(in) ::nminorlower

    table sizes

    integer,intent(in) ::nminorklower

    table sizes

    integer,intent(in) ::nminorupper

    table sizes

    integer,intent(in) ::nminorkupper

    table sizes

    integer,intent(in) ::idx_h2o

    index of water vapor in col_gas

    integer,intent(in), dimension(2,ngpt)::gpoint_flavor

    major gas flavor (pair) by upper/lower, g-point

    integer,intent(in), dimension(2,nbnd)::band_lims_gpt

    beginning and ending g-point for each band

    real(kind=wp),intent(in), dimension(ntemp,neta,npres+1,ngpt)::kmajor

    absorption coefficient table - major gases

    real(kind=wp),intent(in), dimension(ntemp,neta,nminorklower)::kminor_lower

    absorption coefficient table - minor gases, lower atmosphere

    real(kind=wp),intent(in), dimension(ntemp,neta,nminorkupper)::kminor_upper

    absorption coefficient table - minor gases, upper atmosphere

    integer,intent(in), dimension(2,nminorlower)::minor_limits_gpt_lower

    beginning and ending g-point for each minor gas

    integer,intent(in), dimension(2,nminorupper)::minor_limits_gpt_upper
    logical(kind=wl),intent(in), dimension( nminorlower)::minor_scales_with_density_lower

    generic treatment of minor gases - scales with density (e.g. continuum, collision-induced absorption)?

    logical(kind=wl),intent(in), dimension( nminorupper)::minor_scales_with_density_upper
    logical(kind=wl),intent(in), dimension( nminorlower)::scale_by_complement_lower

    generic treatment of minor gases - scale by density (e.g. self-continuum) or complement?

    logical(kind=wl),intent(in), dimension( nminorupper)::scale_by_complement_upper
    integer,intent(in), dimension( nminorlower)::idx_minor_lower

    index of each minor gas in col_gas

    integer,intent(in), dimension( nminorupper)::idx_minor_upper
    integer,intent(in), dimension( nminorlower)::idx_minor_scaling_lower

    for this minor gas, index of the "scaling gas" in col_gas

    integer,intent(in), dimension( nminorupper)::idx_minor_scaling_upper
    integer,intent(in), dimension( nminorlower)::kminor_start_lower

    starting g-point index in minor gas absorption table

    integer,intent(in), dimension( nminorupper)::kminor_start_upper
    logical(kind=wl),intent(in), dimension(ncol,nlay)::tropo

    use upper- or lower-atmospheric tables?

    real(kind=wp),intent(in), dimension(2, ncol,nlay,nflav )::col_mix

    combination of major species's column amounts - computed in interpolation()

    real(kind=wp),intent(in), dimension(2,2,2,ncol,nlay,nflav )::fmajor

    interpolation weights for major gases - computed in interpolation()

    real(kind=wp),intent(in), dimension(2,2, ncol,nlay,nflav )::fminor

    interpolation weights for minor gases - computed in interpolation()

    real(kind=wp),intent(in), dimension( ncol,nlay )::play

    input temperature and pressure

    real(kind=wp),intent(in), dimension( ncol,nlay )::tlay

    input temperature and pressure

    real(kind=wp),intent(in), dimension( ncol,nlay,0:ngas)::col_gas

    input column gas amount (molecules/cm^2)

    integer,intent(in), dimension(2, ncol,nlay,nflav )::jeta

    interpolation indexes in eta - computed in interpolation()

    integer,intent(in), dimension( ncol,nlay )::jtemp

    interpolation indexes in temperature - computed in interpolation()

    integer,intent(in), dimension( ncol,nlay )::jpress

    interpolation indexes in pressure - computed in interpolation()

    real(kind=wp),intent(inout), dimension(ncol,nlay,ngpt)::tau

    aborption optional depth

    + +
    + +
    +
    + +
    +
    +
    +
    +
    +

    RRTMGP kernels was developed by The RTE+RRTTMGP consortium
    © 2024 Creative Commons License +

    +
    +
    +

    + Documentation generated by + FORD +

    +
    +
    +
    +
    +
    + + + + + + + + + + + + + + + + + + + \ No newline at end of file diff --git a/reference/rrtmgp-kernels/interface/compute_tau_rayleigh.html b/reference/rrtmgp-kernels/interface/compute_tau_rayleigh.html new file mode 100644 index 000000000..93ed8a520 --- /dev/null +++ b/reference/rrtmgp-kernels/interface/compute_tau_rayleigh.html @@ -0,0 +1,304 @@ + + + + + + + + + + + + compute_tau_rayleigh – RRTMGP kernels + + + + + + + + + + + + + + + + + + + + +
    +
    +

    compute_tau_rayleigh + Interface +

    +
    +
    +
    + +
      +
    1. mo_gas_optics_rrtmgp_kernels.F90
      2. +
    2. mo_gas_optics_rrtmgp_kernels
      3. +
    3. compute_tau_rayleigh
      4. +
    +
    +
    +
    + + +
    + +
    + + +
    +

    interface
    + public subroutine compute_tau_rayleigh(ncol, nlay, nbnd, ngpt, ngas, nflav, neta, npres, ntemp, gpoint_flavor, band_lims_gpt, krayl, idx_h2o, col_dry, col_gas, fminor, jeta, tropo, jtemp, tau_rayleigh) bind(C, name="0")

    + + + +

    Arguments

    + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
    TypeIntentOptionalAttributesName
    integer,intent(in) ::ncol

    input dimensions

    integer,intent(in) ::nlay

    input dimensions

    integer,intent(in) ::nbnd

    input dimensions

    integer,intent(in) ::ngpt

    input dimensions

    integer,intent(in) ::ngas

    table dimensions

    integer,intent(in) ::nflav

    table dimensions

    integer,intent(in) ::neta

    table dimensions

    integer,intent(in) ::npres

    table dimensions

    integer,intent(in) ::ntemp

    table dimensions

    integer,intent(in), dimension(2,ngpt)::gpoint_flavor

    major gas flavor (pair) by upper/lower, g-point

    integer,intent(in), dimension(2,nbnd)::band_lims_gpt

    start and end g-point for each band

    real(kind=wp),intent(in), dimension(ntemp,neta,ngpt,2)::krayl

    Rayleigh scattering coefficients

    integer,intent(in) ::idx_h2o

    index of water vapor in col_gas

    real(kind=wp),intent(in), dimension(ncol,nlay)::col_dry

    column amount of dry air

    real(kind=wp),intent(in), dimension(ncol,nlay,0:ngas)::col_gas

    input column gas amount (molecules/cm^2)

    real(kind=wp),intent(in), dimension(2,2,ncol,nlay,nflav)::fminor

    interpolation weights for major gases - computed in interpolation()

    integer,intent(in), dimension(2, ncol,nlay,nflav)::jeta

    interpolation indexes in eta - computed in interpolation()

    logical(kind=wl),intent(in), dimension(ncol,nlay)::tropo

    use upper- or lower-atmospheric tables?

    integer,intent(in), dimension(ncol,nlay)::jtemp

    interpolation indexes in temperature - computed in interpolation()

    real(kind=wp),intent(out), dimension(ncol,nlay,ngpt)::tau_rayleigh

    Rayleigh optical depth

    + +
    + +
    +
    + +
    +
    +
    +
    +
    +

    RRTMGP kernels was developed by The RTE+RRTTMGP consortium
    © 2024 Creative Commons License +

    +
    +
    +

    + Documentation generated by + FORD +

    +
    +
    +
    +
    +
    + + + + + + + + + + + + + + + + + + + \ No newline at end of file diff --git a/reference/rrtmgp-kernels/interface/interpolation.html b/reference/rrtmgp-kernels/interface/interpolation.html new file mode 100644 index 000000000..af463c85c --- /dev/null +++ b/reference/rrtmgp-kernels/interface/interpolation.html @@ -0,0 +1,334 @@ + + + + + + + + + + + + interpolation – RRTMGP kernels + + + + + + + + + + + + + + + + + + + + +
    +
    +

    interpolation + Interface +

    +
    +
    +
    + +
      +
    1. mo_gas_optics_rrtmgp_kernels.F90
      2. +
    2. mo_gas_optics_rrtmgp_kernels
      3. +
    3. interpolation
      4. +
    +
    +
    +
    + + +
    + +
    + + +
    +

    interface
    + public subroutine interpolation(ncol, nlay, ngas, nflav, neta, npres, ntemp, flavor, press_ref_log, temp_ref, press_ref_log_delta, temp_ref_min, temp_ref_delta, press_ref_trop_log, vmr_ref, play, tlay, col_gas, jtemp, fmajor, fminor, col_mix, tropo, jeta, jpress) bind(C, name="0")

    + + + +

    Arguments

    + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
    TypeIntentOptionalAttributesName
    integer,intent(in) ::ncol

    physical domain size

    integer,intent(in) ::nlay

    physical domain size

    integer,intent(in) ::ngas

    k-distribution table dimensions

    integer,intent(in) ::nflav

    k-distribution table dimensions

    integer,intent(in) ::neta

    k-distribution table dimensions

    integer,intent(in) ::npres

    k-distribution table dimensions

    integer,intent(in) ::ntemp

    k-distribution table dimensions

    integer,intent(in), dimension(2,nflav)::flavor

    index into vmr_ref of major gases for each flavor

    real(kind=wp),intent(in), dimension(npres)::press_ref_log

    log of pressure dimension in RRTMGP tables

    real(kind=wp),intent(in), dimension(ntemp)::temp_ref

    temperature dimension in RRTMGP tables

    real(kind=wp),intent(in) ::press_ref_log_delta

    constants related to RRTMGP tables

    real(kind=wp),intent(in) ::temp_ref_min

    constants related to RRTMGP tables

    real(kind=wp),intent(in) ::temp_ref_delta

    constants related to RRTMGP tables

    real(kind=wp),intent(in) ::press_ref_trop_log

    constants related to RRTMGP tables

    real(kind=wp),intent(in), dimension(2,0:ngas,ntemp)::vmr_ref

    reference volume mixing ratios used in compute "binary species parameter" eta

    real(kind=wp),intent(in), dimension(ncol,nlay)::play

    input pressure (Pa?) and temperature (K)

    real(kind=wp),intent(in), dimension(ncol,nlay)::tlay

    input pressure (Pa?) and temperature (K)

    real(kind=wp),intent(in), dimension(ncol,nlay,0:ngas)::col_gas

    input column gas amount - molecules/cm^2

    integer,intent(out), dimension(ncol,nlay)::jtemp

    temperature and pressure interpolation indexes

    real(kind=wp),intent(out), dimension(2,2,2,ncol,nlay,nflav)::fmajor

    Interpolation weights in pressure, eta, strat/trop

    real(kind=wp),intent(out), dimension(2,2, ncol,nlay,nflav)::fminor

    Interpolation fraction in eta, strat/trop

    real(kind=wp),intent(out), dimension(2, ncol,nlay,nflav)::col_mix

    combination of major species's column amounts (first index is strat/trop)

    logical(kind=wl),intent(out), dimension(ncol,nlay)::tropo

    use lower (or upper) atmosphere tables

    integer,intent(out), dimension(2, ncol,nlay,nflav)::jeta

    Index for binary species interpolation

    integer,intent(out), dimension(ncol,nlay)::jpress

    temperature and pressure interpolation indexes

    + +
    + +
    +
    + +
    +
    +
    +
    +
    +

    RRTMGP kernels was developed by The RTE+RRTTMGP consortium
    © 2024 Creative Commons License +

    +
    +
    +

    + Documentation generated by + FORD +

    +
    +
    +
    +
    +
    + + + + + + + + + + + + + + + + + + + \ No newline at end of file diff --git a/reference/rrtmgp-kernels/lists/files.html b/reference/rrtmgp-kernels/lists/files.html new file mode 100644 index 000000000..4a0419614 --- /dev/null +++ b/reference/rrtmgp-kernels/lists/files.html @@ -0,0 +1,199 @@ + + + + + + + + + + + All Files – RRTMGP kernels + + + + + + + + + + + + + + + + + + + + + +
    +
    +
    +

    Source Files

    + + + + + +
    FileDescription
    mo_gas_optics_rrtmgp_kernels.F90
    mo_gas_optics_rrtmgp_kernels.F90
    +
    + + + + + +file~~graph~~FileGraph + + + +sourcefile~mo_gas_optics_rrtmgp_kernels.f90 + + +mo_gas_optics_rrtmgp_kernels.F90 + + + + + +sourcefile~mo_gas_optics_rrtmgp_kernels.f90~2 + + +mo_gas_optics_rrtmgp_kernels.F90 + + + + + +
    +
    +
    +
    +
    +
    +
    +
    +

    RRTMGP kernels was developed by The RTE+RRTTMGP consortium
    © 2024 Creative Commons License +

    +
    +
    +

    + Documentation generated by + FORD +

    +
    +
    +
    +
    +
    + + + + + + + + + + + + + + + + + + + \ No newline at end of file diff --git a/reference/rrtmgp-kernels/lists/modules.html b/reference/rrtmgp-kernels/lists/modules.html index 4a4fa2af5..f944ecc56 100644 --- a/reference/rrtmgp-kernels/lists/modules.html +++ b/reference/rrtmgp-kernels/lists/modules.html @@ -50,14 +50,14 @@ aria-haspopup="true" aria-expanded="false">Contents - + @@ -81,7 +81,8 @@

    Modules

    ModuleSource FileDescription mo_gas_optics_rrtmgp_kernelsmo_gas_optics_rrtmgp_kernels.F90Read more… - + mo_gas_optics_rrtmgp_kernelsmo_gas_optics_rrtmgp_kernels.F90 +
    @@ -96,11 +97,14 @@

    Modules

    module~mo_gas_optics_rrtmgp_kernels - -mo_gas_optics_rrtmgp_kernels + + +mo_gas_optics_rrtmgp_kernels + + - + mo_rte_util_array mo_rte_util_array @@ -108,11 +112,11 @@

    Modules

    module~mo_gas_optics_rrtmgp_kernels->mo_rte_util_array - - + + - + mo_rte_kind mo_rte_kind @@ -120,8 +124,29 @@

    Modules

    module~mo_gas_optics_rrtmgp_kernels->mo_rte_kind - - + + + + + +module~mo_gas_optics_rrtmgp_kernels~2 + + +mo_gas_optics_rrtmgp_kernels + + + + + +module~mo_gas_optics_rrtmgp_kernels~2->mo_rte_util_array + + + + + +module~mo_gas_optics_rrtmgp_kernels~2->mo_rte_kind + +     diff --git a/reference/rrtmgp-kernels/lists/procedures.html b/reference/rrtmgp-kernels/lists/procedures.html index 358355793..55979aab9 100644 --- a/reference/rrtmgp-kernels/lists/procedures.html +++ b/reference/rrtmgp-kernels/lists/procedures.html @@ -50,14 +50,14 @@ aria-haspopup="true" aria-expanded="false">Contents - + @@ -81,12 +81,16 @@

    Procedures

    ProcedureLocationProcedure TypeDescription compute_Planck_sourcemo_gas_optics_rrtmgp_kernelsSubroutine + compute_Planck_sourcemo_gas_optics_rrtmgp_kernelsInterface compute_tau_absorptionmo_gas_optics_rrtmgp_kernelsSubroutine

    Compute minor and major species optical depth using pre-computed interpolation coefficients (jeta,jtemp,jpress) and weights (fmajor, fminor)

    + compute_tau_absorptionmo_gas_optics_rrtmgp_kernelsInterface compute_tau_rayleighmo_gas_optics_rrtmgp_kernelsSubroutine + compute_tau_rayleighmo_gas_optics_rrtmgp_kernelsInterface interpolationmo_gas_optics_rrtmgp_kernelsSubroutine

    Compute interpolation coefficients for calculations of major optical depths, minor optical depths, Rayleigh, and Planck fractions

    + interpolationmo_gas_optics_rrtmgp_kernelsInterface
    Procedures - - + + call~~graph~~CallGraph - - + + +proc~compute_tau_absorption + + +compute_tau_absorption + + + + + +interface~compute_tau_rayleigh + + +compute_tau_rayleigh + + + + + +interface~interpolation + + +interpolation + + + + + proc~interpolation - - -interpolation + + +interpolation - + float - -float + +float proc~interpolation->float - - + + - + proc~compute_tau_rayleigh - - -compute_tau_rayleigh + + +compute_tau_rayleigh - - -proc~compute_tau_absorption - - -compute_tau_absorption + + +interface~compute_tau_absorption + + +compute_tau_absorption - + proc~compute_planck_source - - -compute_Planck_source + + +compute_Planck_source + + + + + +interface~compute_planck_source + + +compute_Planck_source diff --git a/reference/rrtmgp-kernels/module/mo_gas_optics_rrtmgp_kernels.html b/reference/rrtmgp-kernels/module/mo_gas_optics_rrtmgp_kernels.html index 29fd9e644..1aea3179e 100644 --- a/reference/rrtmgp-kernels/module/mo_gas_optics_rrtmgp_kernels.html +++ b/reference/rrtmgp-kernels/module/mo_gas_optics_rrtmgp_kernels.html @@ -49,14 +49,14 @@ aria-haspopup="true" aria-expanded="false">Contents - + @@ -85,7 +85,7 @@

    mo_gas_optics_rrtmgp_kernels
  • 353 statements + title="77.3% of total for modules and submodules.">360 statements
  • Source File
    • @@ -283,7 +283,7 @@

    Contents

    Subroutines

    -

    public subroutine compute_Planck_source(ncol, nlay, nbnd, ngpt, nflav, neta, npres, ntemp, nPlanckTemp, tlay, tlev, tsfc, sfc_lay, fmajor, jeta, tropo, jtemp, jpress, gpoint_bands, band_lims_gpt, pfracin, temp_ref_min, totplnk_delta, totplnk, gpoint_flavor, sfc_src, lay_src, lev_src_inc, lev_src_dec, sfc_source_Jac) bind(C, name="0")

    +

    public subroutine compute_Planck_source(ncol, nlay, nbnd, ngpt, nflav, neta, npres, ntemp, nPlanckTemp, tlay, tlev, tsfc, sfc_lay, fmajor, jeta, tropo, jtemp, jpress, gpoint_bands, band_lims_gpt, pfracin, temp_ref_min, totplnk_delta, totplnk, gpoint_flavor, sfc_src, lay_src, lev_src, sfc_source_Jac) bind(C, name="0")

    Arguments

    @@ -442,31 +442,25 @@

    Arguments

    - - + + - - + + - - - - - - - - + + - + diff --git a/reference/rrtmgp-kernels/module/mo_gas_optics_rrtmgp_kernels~2.html b/reference/rrtmgp-kernels/module/mo_gas_optics_rrtmgp_kernels~2.html new file mode 100644 index 000000000..27d52cb12 --- /dev/null +++ b/reference/rrtmgp-kernels/module/mo_gas_optics_rrtmgp_kernels~2.html @@ -0,0 +1,1089 @@ + + + + + + + + + + + mo_gas_optics_rrtmgp_kernels – RRTMGP kernels + + + + + + + + + + + + + + + + + + + + +
    +
    +

    mo_gas_optics_rrtmgp_kernels + Module +

    +
    +
    +
    + +
      +
    1. mo_gas_optics_rrtmgp_kernels.F90
      2. +
    2. mo_gas_optics_rrtmgp_kernels
      3. +
    +
    +
    +
    + + +
    + +
    + + +
    + +
    +
    +

    Uses

    +
    +
      +
    • +
        +
      • mo_rte_util_array
        • +
      • mo_rte_kind
        • +
      +
      • +
    • +
      + + + + + +module~~mo_gas_optics_rrtmgp_kernels~2~~UsesGraph + + + +module~mo_gas_optics_rrtmgp_kernels~2 + +mo_gas_optics_rrtmgp_kernels + + + +mo_rte_util_array + +mo_rte_util_array + + + +module~mo_gas_optics_rrtmgp_kernels~2->mo_rte_util_array + + + + + +mo_rte_kind + +mo_rte_kind + + + +module~mo_gas_optics_rrtmgp_kernels~2->mo_rte_kind + + + + + +
      +
      • +
    +
    + + +
    + +
    +

    Contents

    + +
    +

    Interfaces

    + +
    + +
    +
    + + + + +
    +

    Interfaces

    +
    +

    interface

    +
      +
    • +

      public subroutine compute_Planck_source(ncol, nlay, nbnd, ngpt, nflav, neta, npres, ntemp, nPlanckTemp, tlay, tlev, tsfc, sfc_lay, fmajor, jeta, tropo, jtemp, jpress, gpoint_bands, band_lims_gpt, pfracin, temp_ref_min, totplnk_delta, totplnk, gpoint_flavor, sfc_src, lay_src, lev_src, sfc_source_Jac) bind(C, name="0")

      +

      Arguments

    real(kind=wp), intent(out), dimension(ncol, ngpt)::sfc_src

    Planck emssion from the surface

    		dimension(ncol, ngpt)::sfc_src

    Planck emission from the surface

    real(kind=wp), intent(out), dimension(ncol,nlay,ngpt)::lay_src

    Planck emssion from layer centers

    		 dimension(ncol,nlay, ngpt)::lay_src

    Planck emission from layer centers
    real(kind=wp), intent(out), dimension(ncol,nlay,ngpt)::lev_src_inc

    Planck emission at layer boundaries, using spectral mapping in the direction of propagation

    real(kind=wp),intent(out), dimension(ncol,nlay,ngpt)::lev_src_dec

    Planck emission at layer boundaries, using spectral mapping in the direction of propagation

    		dimension(ncol,nlay+1,ngpt)::lev_src

    Planck emission from layer boundaries
    real(kind=wp), intent(out), dimension(ncol, ngpt):: dimension(ncol, ngpt):: sfc_source_Jac

    Jacobian (derivative) of the surface Planck source with respect to surface temperature

    + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
    TypeIntentOptionalAttributesName
    integer,intent(in) ::ncol

    input dimensions

    integer,intent(in) ::nlay

    input dimensions

    integer,intent(in) ::nbnd

    input dimensions

    integer,intent(in) ::ngpt

    input dimensions

    integer,intent(in) ::nflav

    table dimensions

    integer,intent(in) ::neta

    table dimensions

    integer,intent(in) ::npres

    table dimensions

    integer,intent(in) ::ntemp

    table dimensions

    integer,intent(in) ::nPlanckTemp

    table dimensions

    real(kind=wp),intent(in), dimension(ncol,nlay )::tlay

    temperature at layer centers (K)

    real(kind=wp),intent(in), dimension(ncol,nlay+1)::tlev

    temperature at interfaces (K)

    real(kind=wp),intent(in), dimension(ncol )::tsfc

    surface temperture

    integer,intent(in) ::sfc_lay

    index into surface layer

    real(kind=wp),intent(in), dimension(2,2,2,ncol,nlay,nflav)::fmajor

    interpolation weights for major gases - computed in interpolation()

    integer,intent(in), dimension(2, ncol,nlay,nflav)::jeta

    interpolation indexes in eta - computed in interpolation()

    logical(kind=wl),intent(in), dimension( ncol,nlay)::tropo

    use upper- or lower-atmospheric tables?

    integer,intent(in), dimension( ncol,nlay)::jtemp

    interpolation indexes in temperature and pressure - computed in interpolation()

    integer,intent(in), dimension( ncol,nlay)::jpress

    interpolation indexes in temperature and pressure - computed in interpolation()

    integer,intent(in), dimension(ngpt)::gpoint_bands

    band to which each g-point belongs

    integer,intent(in), dimension(2, nbnd)::band_lims_gpt

    start and end g-point for each band

    real(kind=wp),intent(in), dimension(ntemp,neta,npres+1,ngpt)::pfracin

    Fraction of the Planck function in each g-point

    real(kind=wp),intent(in) ::temp_ref_min

    interpolation constants

    real(kind=wp),intent(in) ::totplnk_delta

    interpolation constants

    real(kind=wp),intent(in), dimension(nPlanckTemp,nbnd)::totplnk

    Total Planck function by band at each temperature

    integer,intent(in), dimension(2,ngpt)::gpoint_flavor

    major gas flavor (pair) by upper/lower, g-point

    real(kind=wp),intent(out), dimension(ncol, ngpt)::sfc_src

    Planck emssion from the surface

    real(kind=wp),intent(out), dimension(ncol,nlay, ngpt)::lay_src

    Planck emssion from layer centers

    real(kind=wp),intent(out), dimension(ncol,nlay+1,ngpt)::lev_src

    Planck emission at layer boundaries

    real(kind=wp),intent(out), dimension(ncol, ngpt)::sfc_source_Jac

    Jacobian (derivative) of the surface Planck source with respect to surface temperature

    + + + + +
    + +
    +

    interface

    +
      +
    • +

      public subroutine compute_tau_absorption(ncol, nlay, nbnd, ngpt, ngas, nflav, neta, npres, ntemp, nminorlower, nminorklower, nminorupper, nminorkupper, idx_h2o, gpoint_flavor, band_lims_gpt, kmajor, kminor_lower, kminor_upper, minor_limits_gpt_lower, minor_limits_gpt_upper, minor_scales_with_density_lower, minor_scales_with_density_upper, scale_by_complement_lower, scale_by_complement_upper, idx_minor_lower, idx_minor_upper, idx_minor_scaling_lower, idx_minor_scaling_upper, kminor_start_lower, kminor_start_upper, tropo, col_mix, fmajor, fminor, play, tlay, col_gas, jeta, jtemp, jpress, tau) bind(C, name="0")

      +

      Arguments

      + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
      TypeIntentOptionalAttributesName
      integer,intent(in) ::ncol

      array sizes

      integer,intent(in) ::nlay

      array sizes

      integer,intent(in) ::nbnd

      array sizes

      integer,intent(in) ::ngpt

      array sizes

      integer,intent(in) ::ngas

      tables sizes

      integer,intent(in) ::nflav

      tables sizes

      integer,intent(in) ::neta

      tables sizes

      integer,intent(in) ::npres

      tables sizes

      integer,intent(in) ::ntemp

      tables sizes

      integer,intent(in) ::nminorlower

      table sizes

      integer,intent(in) ::nminorklower

      table sizes

      integer,intent(in) ::nminorupper

      table sizes

      integer,intent(in) ::nminorkupper

      table sizes

      integer,intent(in) ::idx_h2o

      index of water vapor in col_gas

      integer,intent(in), dimension(2,ngpt)::gpoint_flavor

      major gas flavor (pair) by upper/lower, g-point

      integer,intent(in), dimension(2,nbnd)::band_lims_gpt

      beginning and ending g-point for each band

      real(kind=wp),intent(in), dimension(ntemp,neta,npres+1,ngpt)::kmajor

      absorption coefficient table - major gases

      real(kind=wp),intent(in), dimension(ntemp,neta,nminorklower)::kminor_lower

      absorption coefficient table - minor gases, lower atmosphere

      real(kind=wp),intent(in), dimension(ntemp,neta,nminorkupper)::kminor_upper

      absorption coefficient table - minor gases, upper atmosphere

      integer,intent(in), dimension(2,nminorlower)::minor_limits_gpt_lower

      beginning and ending g-point for each minor gas

      integer,intent(in), dimension(2,nminorupper)::minor_limits_gpt_upper
      logical(kind=wl),intent(in), dimension( nminorlower)::minor_scales_with_density_lower

      generic treatment of minor gases - scales with density (e.g. continuum, collision-induced absorption)?

      logical(kind=wl),intent(in), dimension( nminorupper)::minor_scales_with_density_upper
      logical(kind=wl),intent(in), dimension( nminorlower)::scale_by_complement_lower

      generic treatment of minor gases - scale by density (e.g. self-continuum) or complement?

      logical(kind=wl),intent(in), dimension( nminorupper)::scale_by_complement_upper
      integer,intent(in), dimension( nminorlower)::idx_minor_lower

      index of each minor gas in col_gas

      integer,intent(in), dimension( nminorupper)::idx_minor_upper
      integer,intent(in), dimension( nminorlower)::idx_minor_scaling_lower

      for this minor gas, index of the "scaling gas" in col_gas

      integer,intent(in), dimension( nminorupper)::idx_minor_scaling_upper
      integer,intent(in), dimension( nminorlower)::kminor_start_lower

      starting g-point index in minor gas absorption table

      integer,intent(in), dimension( nminorupper)::kminor_start_upper
      logical(kind=wl),intent(in), dimension(ncol,nlay)::tropo

      use upper- or lower-atmospheric tables?

      real(kind=wp),intent(in), dimension(2, ncol,nlay,nflav )::col_mix

      combination of major species's column amounts - computed in interpolation()

      real(kind=wp),intent(in), dimension(2,2,2,ncol,nlay,nflav )::fmajor

      interpolation weights for major gases - computed in interpolation()

      real(kind=wp),intent(in), dimension(2,2, ncol,nlay,nflav )::fminor

      interpolation weights for minor gases - computed in interpolation()

      real(kind=wp),intent(in), dimension( ncol,nlay )::play

      input temperature and pressure

      real(kind=wp),intent(in), dimension( ncol,nlay )::tlay

      input temperature and pressure

      real(kind=wp),intent(in), dimension( ncol,nlay,0:ngas)::col_gas

      input column gas amount (molecules/cm^2)

      integer,intent(in), dimension(2, ncol,nlay,nflav )::jeta

      interpolation indexes in eta - computed in interpolation()

      integer,intent(in), dimension( ncol,nlay )::jtemp

      interpolation indexes in temperature - computed in interpolation()

      integer,intent(in), dimension( ncol,nlay )::jpress

      interpolation indexes in pressure - computed in interpolation()

      real(kind=wp),intent(inout), dimension(ncol,nlay,ngpt)::tau

      aborption optional depth

      + + +
      • +
    +
    + +
    +

    interface

    +
      +
    • +

      public subroutine compute_tau_rayleigh(ncol, nlay, nbnd, ngpt, ngas, nflav, neta, npres, ntemp, gpoint_flavor, band_lims_gpt, krayl, idx_h2o, col_dry, col_gas, fminor, jeta, tropo, jtemp, tau_rayleigh) bind(C, name="0")

      +

      Arguments

      + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
      TypeIntentOptionalAttributesName
      integer,intent(in) ::ncol

      input dimensions

      integer,intent(in) ::nlay

      input dimensions

      integer,intent(in) ::nbnd

      input dimensions

      integer,intent(in) ::ngpt

      input dimensions

      integer,intent(in) ::ngas

      table dimensions

      integer,intent(in) ::nflav

      table dimensions

      integer,intent(in) ::neta

      table dimensions

      integer,intent(in) ::npres

      table dimensions

      integer,intent(in) ::ntemp

      table dimensions

      integer,intent(in), dimension(2,ngpt)::gpoint_flavor

      major gas flavor (pair) by upper/lower, g-point

      integer,intent(in), dimension(2,nbnd)::band_lims_gpt

      start and end g-point for each band

      real(kind=wp),intent(in), dimension(ntemp,neta,ngpt,2)::krayl

      Rayleigh scattering coefficients

      integer,intent(in) ::idx_h2o

      index of water vapor in col_gas

      real(kind=wp),intent(in), dimension(ncol,nlay)::col_dry

      column amount of dry air

      real(kind=wp),intent(in), dimension(ncol,nlay,0:ngas)::col_gas

      input column gas amount (molecules/cm^2)

      real(kind=wp),intent(in), dimension(2,2,ncol,nlay,nflav)::fminor

      interpolation weights for major gases - computed in interpolation()

      integer,intent(in), dimension(2, ncol,nlay,nflav)::jeta

      interpolation indexes in eta - computed in interpolation()

      logical(kind=wl),intent(in), dimension(ncol,nlay)::tropo

      use upper- or lower-atmospheric tables?

      integer,intent(in), dimension(ncol,nlay)::jtemp

      interpolation indexes in temperature - computed in interpolation()

      real(kind=wp),intent(out), dimension(ncol,nlay,ngpt)::tau_rayleigh

      Rayleigh optical depth

      + + +
      • +
    +
    + +
    +

    interface

    +
      +
    • +

      public subroutine interpolation(ncol, nlay, ngas, nflav, neta, npres, ntemp, flavor, press_ref_log, temp_ref, press_ref_log_delta, temp_ref_min, temp_ref_delta, press_ref_trop_log, vmr_ref, play, tlay, col_gas, jtemp, fmajor, fminor, col_mix, tropo, jeta, jpress) bind(C, name="0")

      +

      Arguments

      + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
      TypeIntentOptionalAttributesName
      integer,intent(in) ::ncol

      physical domain size

      integer,intent(in) ::nlay

      physical domain size

      integer,intent(in) ::ngas

      k-distribution table dimensions

      integer,intent(in) ::nflav

      k-distribution table dimensions

      integer,intent(in) ::neta

      k-distribution table dimensions

      integer,intent(in) ::npres

      k-distribution table dimensions

      integer,intent(in) ::ntemp

      k-distribution table dimensions

      integer,intent(in), dimension(2,nflav)::flavor

      index into vmr_ref of major gases for each flavor

      real(kind=wp),intent(in), dimension(npres)::press_ref_log

      log of pressure dimension in RRTMGP tables

      real(kind=wp),intent(in), dimension(ntemp)::temp_ref

      temperature dimension in RRTMGP tables

      real(kind=wp),intent(in) ::press_ref_log_delta

      constants related to RRTMGP tables

      real(kind=wp),intent(in) ::temp_ref_min

      constants related to RRTMGP tables

      real(kind=wp),intent(in) ::temp_ref_delta

      constants related to RRTMGP tables

      real(kind=wp),intent(in) ::press_ref_trop_log

      constants related to RRTMGP tables

      real(kind=wp),intent(in), dimension(2,0:ngas,ntemp)::vmr_ref

      reference volume mixing ratios used in compute "binary species parameter" eta

      real(kind=wp),intent(in), dimension(ncol,nlay)::play

      input pressure (Pa?) and temperature (K)

      real(kind=wp),intent(in), dimension(ncol,nlay)::tlay

      input pressure (Pa?) and temperature (K)

      real(kind=wp),intent(in), dimension(ncol,nlay,0:ngas)::col_gas

      input column gas amount - molecules/cm^2

      integer,intent(out), dimension(ncol,nlay)::jtemp

      temperature and pressure interpolation indexes

      real(kind=wp),intent(out), dimension(2,2,2,ncol,nlay,nflav)::fmajor

      Interpolation weights in pressure, eta, strat/trop

      real(kind=wp),intent(out), dimension(2,2, ncol,nlay,nflav)::fminor

      Interpolation fraction in eta, strat/trop

      real(kind=wp),intent(out), dimension(2, ncol,nlay,nflav)::col_mix

      combination of major species's column amounts (first index is strat/trop)

      logical(kind=wl),intent(out), dimension(ncol,nlay)::tropo

      use lower (or upper) atmosphere tables

      integer,intent(out), dimension(2, ncol,nlay,nflav)::jeta

      Index for binary species interpolation

      integer,intent(out), dimension(ncol,nlay)::jpress

      temperature and pressure interpolation indexes

      + + +
      • +
    +
    + +
    +
    + + + + + +
    +
    + +
    + +
    +
    +
    +

    RRTMGP kernels was developed by The RTE+RRTTMGP consortium
    © 2024 Creative Commons License +

    +
    +
    +

    + Documentation generated by + FORD +

    +
    +
    +
    +
    +
    + + + + + + + + + + + + + + + + + + + \ No newline at end of file diff --git a/reference/rrtmgp-kernels/proc/compute_planck_source.html b/reference/rrtmgp-kernels/proc/compute_planck_source.html index a93756537..714933a39 100644 --- a/reference/rrtmgp-kernels/proc/compute_planck_source.html +++ b/reference/rrtmgp-kernels/proc/compute_planck_source.html @@ -49,14 +49,14 @@ aria-haspopup="true" aria-expanded="false">Contents - + @@ -85,7 +85,7 @@

    compute_Planck_source
  • 85 statements + title="27.6% of total for procedures.">92 statements
  • Source File
    • @@ -117,7 +117,7 @@

    Contents

    -

    public subroutine compute_Planck_source(ncol, nlay, nbnd, ngpt, nflav, neta, npres, ntemp, nPlanckTemp, tlay, tlev, tsfc, sfc_lay, fmajor, jeta, tropo, jtemp, jpress, gpoint_bands, band_lims_gpt, pfracin, temp_ref_min, totplnk_delta, totplnk, gpoint_flavor, sfc_src, lay_src, lev_src_inc, lev_src_dec, sfc_source_Jac) bind(C, name="0")

    +

    public subroutine compute_Planck_source(ncol, nlay, nbnd, ngpt, nflav, neta, npres, ntemp, nPlanckTemp, tlay, tlev, tsfc, sfc_lay, fmajor, jeta, tropo, jtemp, jpress, gpoint_bands, band_lims_gpt, pfracin, temp_ref_min, totplnk_delta, totplnk, gpoint_flavor, sfc_src, lay_src, lev_src, sfc_source_Jac) bind(C, name="0")

    @@ -278,31 +278,25 @@

    Arguments

    real(kind=wp), intent(out), - dimension(ncol, ngpt):: - sfc_src

    Planck emssion from the surface

    + dimension(ncol, ngpt):: + sfc_src

    Planck emission from the surface

    real(kind=wp), intent(out), - dimension(ncol,nlay,ngpt):: - lay_src

    Planck emssion from layer centers

    + dimension(ncol,nlay, ngpt):: + lay_src

    Planck emission from layer centers

    - real(kind=wp), + real(kind=wp), intent(out), - dimension(ncol,nlay,ngpt):: - lev_src_inc

    Planck emission at layer boundaries, using spectral mapping in the direction of propagation

    - - - real(kind=wp), -intent(out), - dimension(ncol,nlay,ngpt):: - lev_src_dec

    Planck emission at layer boundaries, using spectral mapping in the direction of propagation

    + dimension(ncol,nlay+1,ngpt):: + lev_src

    Planck emission from layer boundaries

    real(kind=wp), intent(out), - dimension(ncol, ngpt):: + dimension(ncol, ngpt):: sfc_source_Jac

    Jacobian (derivative) of the surface Planck source with respect to surface temperature

    diff --git a/reference/rrtmgp-kernels/proc/compute_tau_absorption.html b/reference/rrtmgp-kernels/proc/compute_tau_absorption.html index 01ccaf514..8fe6b7c5d 100644 --- a/reference/rrtmgp-kernels/proc/compute_tau_absorption.html +++ b/reference/rrtmgp-kernels/proc/compute_tau_absorption.html @@ -49,14 +49,14 @@ aria-haspopup="true" aria-expanded="false">Contents - + @@ -85,7 +85,7 @@

    compute_tau_absorption
  • 50 statements + title="15.0% of total for procedures.">50 statements
  • Source File
    • diff --git a/reference/rrtmgp-kernels/proc/compute_tau_rayleigh.html b/reference/rrtmgp-kernels/proc/compute_tau_rayleigh.html index 5f8d6fb48..aa6da150f 100644 --- a/reference/rrtmgp-kernels/proc/compute_tau_rayleigh.html +++ b/reference/rrtmgp-kernels/proc/compute_tau_rayleigh.html @@ -49,14 +49,14 @@ aria-haspopup="true" aria-expanded="false">Contents - + @@ -85,7 +85,7 @@

    compute_tau_rayleigh
  • 30 statements + title=" 9.0% of total for procedures.">30 statements
  • Source File
    • diff --git a/reference/rrtmgp-kernels/proc/interpolation.html b/reference/rrtmgp-kernels/proc/interpolation.html index c2c4f70a5..ed70faa92 100644 --- a/reference/rrtmgp-kernels/proc/interpolation.html +++ b/reference/rrtmgp-kernels/proc/interpolation.html @@ -49,14 +49,14 @@ aria-haspopup="true" aria-expanded="false">Contents - + @@ -85,7 +85,7 @@

    interpolation
  • 62 statements + title="18.6% of total for procedures.">62 statements
  • Source File
    • diff --git a/reference/rrtmgp-kernels/search.html b/reference/rrtmgp-kernels/search.html index 79fb25cc9..1a00c5fba 100644 --- a/reference/rrtmgp-kernels/search.html +++ b/reference/rrtmgp-kernels/search.html @@ -50,14 +50,14 @@ aria-haspopup="true" aria-expanded="false">Contents - + diff --git a/reference/rrtmgp-kernels/sourcefile/mo_gas_optics_rrtmgp_kernels.f90.html b/reference/rrtmgp-kernels/sourcefile/mo_gas_optics_rrtmgp_kernels.f90.html index 5784e6ec7..e02e6479e 100644 --- a/reference/rrtmgp-kernels/sourcefile/mo_gas_optics_rrtmgp_kernels.f90.html +++ b/reference/rrtmgp-kernels/sourcefile/mo_gas_optics_rrtmgp_kernels.f90.html @@ -49,14 +49,14 @@ aria-haspopup="true" aria-expanded="false">Contents - + @@ -85,7 +85,7 @@

    mo_gas_optics_rrtmgp_kernels.F90
  • 353 statements + title="77.3% of total for source files.">360 statements
  • Source File
    • @@ -725,7 +725,7 @@

    Source Code

    fmajor, jeta, tropo, jtemp, jpress, & gpoint_bands, band_lims_gpt, & pfracin, temp_ref_min, totplnk_delta, totplnk, gpoint_flavor, & - sfc_src, lay_src, lev_src_inc, lev_src_dec, sfc_source_Jac) bind(C, name="rrtmgp_compute_Planck_source") + sfc_src, lay_src, lev_src, sfc_source_Jac) bind(C, name="rrtmgp_compute_Planck_source") integer, intent(in) :: ncol, nlay, nbnd, ngpt !! input dimensions integer, intent(in) :: nflav, neta, npres, ntemp, nPlanckTemp @@ -751,190 +751,198 @@

    Source Code

    real(wp), dimension(nPlanckTemp,nbnd), intent(in) :: totplnk !! Total Planck function by band at each temperature integer, dimension(2,ngpt), intent(in) :: gpoint_flavor !! major gas flavor (pair) by upper/lower, g-point - real(wp), dimension(ncol, ngpt), intent(out) :: sfc_src !! Planck emssion from the surface - real(wp), dimension(ncol,nlay,ngpt), intent(out) :: lay_src !! Planck emssion from layer centers - real(wp), dimension(ncol,nlay,ngpt), intent(out) :: lev_src_inc, lev_src_dec - !! Planck emission at layer boundaries, using spectral mapping in the direction of propagation - real(wp), dimension(ncol, ngpt), intent(out) :: sfc_source_Jac - !! Jacobian (derivative) of the surface Planck source with respect to surface temperature - ! ----------------- - ! local - real(wp), parameter :: delta_Tsurf = 1.0_wp - - integer :: ilay, icol, igpt, ibnd, itropo, iflav - integer :: gptS, gptE - real(wp), dimension(2), parameter :: one = [1._wp, 1._wp] - real(wp) :: pfrac (ncol,nlay ,ngpt) - real(wp) :: planck_function(ncol,nlay+1,nbnd) - ! ----------------- - - ! Calculation of fraction of band's Planck irradiance associated with each g-point - do ibnd = 1, nbnd - gptS = band_lims_gpt(1, ibnd) - gptE = band_lims_gpt(2, ibnd) - do ilay = 1, nlay - do icol = 1, ncol - ! itropo = 1 lower atmosphere; itropo = 2 upper atmosphere - itropo = merge(1,2,tropo(icol,ilay)) - iflav = gpoint_flavor(itropo, gptS) !eta interpolation depends on band's flavor - pfrac(icol,ilay,gptS:gptE) = & - ! interpolation in temperature, pressure, and eta - interpolate3D_byflav(one, fmajor(:,:,:,icol,ilay,iflav), pfracin, & - band_lims_gpt(1, ibnd), band_lims_gpt(2, ibnd), & - jeta(:,icol,ilay,iflav), jtemp(icol,ilay),jpress(icol,ilay)+itropo) - end do ! column - end do ! layer - end do ! band - - ! - ! Planck function by band for the surface - ! Compute surface source irradiance for g-point, equals band irradiance x fraction for g-point - ! - do icol = 1, ncol - planck_function(icol,1,1:nbnd) = interpolate1D(tsfc(icol), temp_ref_min, totplnk_delta, totplnk) - planck_function(icol,2,1:nbnd) = interpolate1D(tsfc(icol) + delta_Tsurf, temp_ref_min, totplnk_delta, totplnk) - ! - ! Map to g-points - ! - do ibnd = 1, nbnd - gptS = band_lims_gpt(1, ibnd) - gptE = band_lims_gpt(2, ibnd) - do igpt = gptS, gptE - sfc_src(icol,igpt) = pfrac(icol,sfc_lay,igpt) * planck_function(icol,1,ibnd) - sfc_source_Jac(icol, igpt) = pfrac(icol,sfc_lay,igpt) * & - (planck_function(icol, 2, ibnd) - planck_function(icol,1,ibnd)) - end do - end do - end do !icol - - do ilay = 1, nlay - do icol = 1, ncol - ! Compute layer source irradiance for g-point, equals band irradiance x fraction for g-point - planck_function(icol,ilay,1:nbnd) = interpolate1D(tlay(icol,ilay), temp_ref_min, totplnk_delta, totplnk) - end do - end do - - ! - ! Map to g-points - ! - do ibnd = 1, nbnd - gptS = band_lims_gpt(1, ibnd) - gptE = band_lims_gpt(2, ibnd) - do igpt = gptS, gptE - do ilay = 1, nlay - do icol = 1, ncol - lay_src(icol,ilay,igpt) = pfrac(icol,ilay,igpt) * planck_function(icol,ilay,ibnd) - end do - end do - end do - end do - - ! compute level source irradiances for each g-point, one each for upward and downward paths - do ilay = 1, nlay - do icol = 1, ncol - planck_function(icol, 1,1:nbnd) = interpolate1D(tlev(icol, 1),temp_ref_min, totplnk_delta, totplnk) - planck_function(icol,ilay+1,1:nbnd) = interpolate1D(tlev(icol,ilay+1),temp_ref_min, totplnk_delta, totplnk) - end do - end do - - ! - ! Map to g-points - ! - do ibnd = 1, nbnd - gptS = band_lims_gpt(1, ibnd) - gptE = band_lims_gpt(2, ibnd) - do igpt = gptS, gptE - do ilay = 1, nlay - do icol = 1, ncol - lev_src_inc(icol,ilay,igpt) = pfrac(icol,ilay,igpt) *planck_function(icol,ilay+1,ibnd) - lev_src_dec(icol,ilay,igpt) = pfrac(icol,ilay,igpt) *planck_function(icol,ilay ,ibnd) - end do - end do - end do - end do - - end subroutine compute_Planck_source - ! ---------------------------------------------------------- - ! - ! One dimensional interpolation -- return all values along second table dimension - ! - pure function interpolate1D(val, offset, delta, table) result(res) - ! input - real(wp), intent(in) :: val, & ! axis value at which to evaluate table - offset, & ! minimum of table axis - delta ! step size of table axis - real(wp), dimension(:,:), & - intent(in) :: table ! dimensions (axis, values) - ! output - real(wp), dimension(size(table,dim=2)) :: res - - ! local - real(wp) :: val0 ! fraction index adjusted by offset and delta - integer :: index ! index term - real(wp) :: frac ! fractional term - ! ------------------------------------- - val0 = (val - offset) / delta - frac = val0 - int(val0) ! get fractional part - index = min(size(table,dim=1)-1, max(1, int(val0)+1)) ! limit the index range - res(:) = table(index,:) + frac * (table(index+1,:) - table(index,:)) - end function interpolate1D - ! ---------------------------------------------------------- - ! This function returns a range of values from a subset (in gpoint) of the k table - ! - pure function interpolate2D_byflav(fminor, k, gptS, gptE, jeta, jtemp) result(res) - real(wp), dimension(2,2), intent(in) :: fminor ! interpolation fractions for minor species - ! index(1) : reference eta level (temperature dependent) - ! index(2) : reference temperature level - real(wp), dimension(:,:,:), intent(in) :: k ! (g-point, eta, temp) - integer, intent(in) :: gptS, gptE, jtemp ! interpolation index for temperature - integer, dimension(2), intent(in) :: jeta ! interpolation index for binary species parameter (eta) - real(wp), dimension(gptE-gptS+1) :: res ! the result - - ! Local variable - integer :: igpt - ! each code block is for a different reference temperature - - do igpt = 1, gptE-gptS+1 - res(igpt) = fminor(1,1) * k(jtemp , jeta(1) , gptS+igpt-1) + & - fminor(2,1) * k(jtemp , jeta(1)+1, gptS+igpt-1) + & - fminor(1,2) * k(jtemp+1, jeta(2) , gptS+igpt-1) + & - fminor(2,2) * k(jtemp+1, jeta(2)+1, gptS+igpt-1) - end do - - end function interpolate2D_byflav - ! ---------------------------------------------------------- - pure function interpolate3D_byflav(scaling, fmajor, k, gptS, gptE, jeta, jtemp, jpress) result(res) - real(wp), dimension(2), intent(in) :: scaling - real(wp), dimension(2,2,2), intent(in) :: fmajor ! interpolation fractions for major species - ! index(1) : reference eta level (temperature dependent) - ! index(2) : reference pressure level - ! index(3) : reference temperature level - real(wp), dimension(:,:,:,:),intent(in) :: k ! (temp,eta,press,gpt) - integer, intent(in) :: gptS, gptE - integer, dimension(2), intent(in) :: jeta ! interpolation index for binary species parameter (eta) - integer, intent(in) :: jtemp ! interpolation index for temperature - integer, intent(in) :: jpress ! interpolation index for pressure - real(wp), dimension(gptS:gptE) :: res ! the result - - ! Local variable - integer :: igpt - ! each code block is for a different reference temperature - do igpt = gptS, gptE - res(igpt) = & - scaling(1) * & - ( fmajor(1,1,1) * k(jtemp, jeta(1) , jpress-1, igpt) + & - fmajor(2,1,1) * k(jtemp, jeta(1)+1, jpress-1, igpt) + & - fmajor(1,2,1) * k(jtemp, jeta(1) , jpress , igpt) + & - fmajor(2,2,1) * k(jtemp, jeta(1)+1, jpress , igpt) ) + & - scaling(2) * & - ( fmajor(1,1,2) * k(jtemp+1, jeta(2) , jpress-1, igpt) + & - fmajor(2,1,2) * k(jtemp+1, jeta(2)+1, jpress-1, igpt) + & - fmajor(1,2,2) * k(jtemp+1, jeta(2) , jpress , igpt) + & - fmajor(2,2,2) * k(jtemp+1, jeta(2)+1, jpress , igpt) ) - end do - end function interpolate3D_byflav - -end module mo_gas_optics_rrtmgp_kernels + real(wp), dimension(ncol, ngpt), intent(out) :: sfc_src !! Planck emission from the surface + real(wp), dimension(ncol,nlay, ngpt), intent(out) :: lay_src !! Planck emission from layer centers + real(wp), dimension(ncol,nlay+1,ngpt), intent(out) :: lev_src !! Planck emission from layer boundaries + real(wp), dimension(ncol, ngpt), intent(out) :: sfc_source_Jac + !! Jacobian (derivative) of the surface Planck source with respect to surface temperature + ! ----------------- + ! local + real(wp), parameter :: delta_Tsurf = 1.0_wp + + integer :: ilay, icol, igpt, ibnd, itropo, iflav + integer :: gptS, gptE + real(wp), dimension(2), parameter :: one = [1._wp, 1._wp] + real(wp) :: pfrac (ncol,nlay ,ngpt) + real(wp) :: planck_function(ncol,nlay+1,nbnd) + ! ----------------- + + ! Calculation of fraction of band's Planck irradiance associated with each g-point + do ibnd = 1, nbnd + gptS = band_lims_gpt(1, ibnd) + gptE = band_lims_gpt(2, ibnd) + do ilay = 1, nlay + do icol = 1, ncol + ! itropo = 1 lower atmosphere; itropo = 2 upper atmosphere + itropo = merge(1,2,tropo(icol,ilay)) + iflav = gpoint_flavor(itropo, gptS) !eta interpolation depends on band's flavor + pfrac(icol,ilay,gptS:gptE) = & + ! interpolation in temperature, pressure, and eta + interpolate3D_byflav(one, fmajor(:,:,:,icol,ilay,iflav), pfracin, & + band_lims_gpt(1, ibnd), band_lims_gpt(2, ibnd), & + jeta(:,icol,ilay,iflav), jtemp(icol,ilay),jpress(icol,ilay)+itropo) + end do ! column + end do ! layer + end do ! band + + ! + ! Planck function by band for the surface + ! Compute surface source irradiance for g-point, equals band irradiance x fraction for g-point + ! + do icol = 1, ncol + planck_function(icol,1,1:nbnd) = interpolate1D(tsfc(icol), temp_ref_min, totplnk_delta, totplnk) + planck_function(icol,2,1:nbnd) = interpolate1D(tsfc(icol) + delta_Tsurf, temp_ref_min, totplnk_delta, totplnk) + ! + ! Map to g-points + ! + do ibnd = 1, nbnd + gptS = band_lims_gpt(1, ibnd) + gptE = band_lims_gpt(2, ibnd) + do igpt = gptS, gptE + sfc_src(icol,igpt) = pfrac(icol,sfc_lay,igpt) * planck_function(icol,1,ibnd) + sfc_source_Jac(icol, igpt) = pfrac(icol,sfc_lay,igpt) * & + (planck_function(icol, 2, ibnd) - planck_function(icol,1,ibnd)) + end do + end do + end do !icol + + do ilay = 1, nlay + do icol = 1, ncol + ! Compute layer source irradiance for g-point, equals band irradiance x fraction for g-point + planck_function(icol,ilay,1:nbnd) = interpolate1D(tlay(icol,ilay), temp_ref_min, totplnk_delta, totplnk) + end do + end do + + ! + ! Map to g-points + ! + do ibnd = 1, nbnd + gptS = band_lims_gpt(1, ibnd) + gptE = band_lims_gpt(2, ibnd) + do igpt = gptS, gptE + do ilay = 1, nlay + do icol = 1, ncol + lay_src(icol,ilay,igpt) = pfrac(icol,ilay,igpt) * planck_function(icol,ilay,ibnd) + end do + end do + end do + end do + + ! compute level source irradiances for each g-point + do icol = 1, ncol + planck_function (icol, 1,1:nbnd) = interpolate1D(tlev(icol, 1),temp_ref_min, totplnk_delta, totplnk) + end do + do ilay = 1, nlay + do icol = 1, ncol + planck_function(icol,ilay+1,1:nbnd) = interpolate1D(tlev(icol,ilay+1),temp_ref_min, totplnk_delta, totplnk) + end do + end do + + ! + ! Map to g-points + ! + do ibnd = 1, nbnd + gptS = band_lims_gpt(1, ibnd) + gptE = band_lims_gpt(2, ibnd) + do igpt = gptS, gptE + do icol = 1, ncol + lev_src(icol, 1,igpt) = pfrac(icol, 1,igpt) * planck_function(icol, 1,ibnd) + end do + do ilay = 2, nlay + do icol = 1, ncol + lev_src(icol,ilay,igpt) = sqrt(pfrac(icol,ilay-1, igpt) * & + pfrac(icol,ilay, igpt)) & + * planck_function(icol,ilay, ibnd) + end do + end do + do icol = 1, ncol + lev_src(icol,nlay+1,igpt) = pfrac(icol,nlay,igpt) * planck_function(icol,nlay+1,ibnd) + end do + end do + end do + + end subroutine compute_Planck_source + ! ---------------------------------------------------------- + ! + ! One dimensional interpolation -- return all values along second table dimension + ! + pure function interpolate1D(val, offset, delta, table) result(res) + ! input + real(wp), intent(in) :: val, & ! axis value at which to evaluate table + offset, & ! minimum of table axis + delta ! step size of table axis + real(wp), dimension(:,:), & + intent(in) :: table ! dimensions (axis, values) + ! output + real(wp), dimension(size(table,dim=2)) :: res + + ! local + real(wp) :: val0 ! fraction index adjusted by offset and delta + integer :: index ! index term + real(wp) :: frac ! fractional term + ! ------------------------------------- + val0 = (val - offset) / delta + frac = val0 - int(val0) ! get fractional part + index = min(size(table,dim=1)-1, max(1, int(val0)+1)) ! limit the index range + res(:) = table(index,:) + frac * (table(index+1,:) - table(index,:)) + end function interpolate1D + ! ---------------------------------------------------------- + ! This function returns a range of values from a subset (in gpoint) of the k table + ! + pure function interpolate2D_byflav(fminor, k, gptS, gptE, jeta, jtemp) result(res) + real(wp), dimension(2,2), intent(in) :: fminor ! interpolation fractions for minor species + ! index(1) : reference eta level (temperature dependent) + ! index(2) : reference temperature level + real(wp), dimension(:,:,:), intent(in) :: k ! (g-point, eta, temp) + integer, intent(in) :: gptS, gptE, jtemp ! interpolation index for temperature + integer, dimension(2), intent(in) :: jeta ! interpolation index for binary species parameter (eta) + real(wp), dimension(gptE-gptS+1) :: res ! the result + + ! Local variable + integer :: igpt + ! each code block is for a different reference temperature + + do igpt = 1, gptE-gptS+1 + res(igpt) = fminor(1,1) * k(jtemp , jeta(1) , gptS+igpt-1) + & + fminor(2,1) * k(jtemp , jeta(1)+1, gptS+igpt-1) + & + fminor(1,2) * k(jtemp+1, jeta(2) , gptS+igpt-1) + & + fminor(2,2) * k(jtemp+1, jeta(2)+1, gptS+igpt-1) + end do + + end function interpolate2D_byflav + ! ---------------------------------------------------------- + pure function interpolate3D_byflav(scaling, fmajor, k, gptS, gptE, jeta, jtemp, jpress) result(res) + real(wp), dimension(2), intent(in) :: scaling + real(wp), dimension(2,2,2), intent(in) :: fmajor ! interpolation fractions for major species + ! index(1) : reference eta level (temperature dependent) + ! index(2) : reference pressure level + ! index(3) : reference temperature level + real(wp), dimension(:,:,:,:),intent(in) :: k ! (temp,eta,press,gpt) + integer, intent(in) :: gptS, gptE + integer, dimension(2), intent(in) :: jeta ! interpolation index for binary species parameter (eta) + integer, intent(in) :: jtemp ! interpolation index for temperature + integer, intent(in) :: jpress ! interpolation index for pressure + real(wp), dimension(gptS:gptE) :: res ! the result + + ! Local variable + integer :: igpt + ! each code block is for a different reference temperature + do igpt = gptS, gptE + res(igpt) = & + scaling(1) * & + ( fmajor(1,1,1) * k(jtemp, jeta(1) , jpress-1, igpt) + & + fmajor(2,1,1) * k(jtemp, jeta(1)+1, jpress-1, igpt) + & + fmajor(1,2,1) * k(jtemp, jeta(1) , jpress , igpt) + & + fmajor(2,2,1) * k(jtemp, jeta(1)+1, jpress , igpt) ) + & + scaling(2) * & + ( fmajor(1,1,2) * k(jtemp+1, jeta(2) , jpress-1, igpt) + & + fmajor(2,1,2) * k(jtemp+1, jeta(2)+1, jpress-1, igpt) + & + fmajor(1,2,2) * k(jtemp+1, jeta(2) , jpress , igpt) + & + fmajor(2,2,2) * k(jtemp+1, jeta(2)+1, jpress , igpt) ) + end do + end function interpolate3D_byflav + +end module mo_gas_optics_rrtmgp_kernels
    diff --git a/reference/rrtmgp-kernels/sourcefile/mo_gas_optics_rrtmgp_kernels.f90~2.html b/reference/rrtmgp-kernels/sourcefile/mo_gas_optics_rrtmgp_kernels.f90~2.html new file mode 100644 index 000000000..040fe7990 --- /dev/null +++ b/reference/rrtmgp-kernels/sourcefile/mo_gas_optics_rrtmgp_kernels.f90~2.html @@ -0,0 +1,452 @@ + + + + + + + + + + + mo_gas_optics_rrtmgp_kernels.F90 – RRTMGP kernels + + + + + + + + + + + + + + + + + + + + +
    +
    +

    mo_gas_optics_rrtmgp_kernels.F90 + Source File +

    +
    +
    +
    + +
      +
    1. mo_gas_optics_rrtmgp_kernels.F90
      2. +
    +
    +
    +
    + + +
    +
    + +
    + +
    + +
    +

    Contents

    + +
    +

    Modules

    + +
    +
    +

    Source Code

    +
    + mo_gas_optics_rrtmgp_kernels.F90 +
    +
    + +
    +
    + +
    +

    Source Code

    + 
    module mo_gas_optics_rrtmgp_kernels
+  use mo_rte_kind,      only : wp, wl
+  use mo_rte_util_array,only : zero_array
+  implicit none
+  private
+  public :: interpolation, compute_tau_absorption, compute_tau_rayleigh, compute_Planck_source
+  ! ------------------------------------------------------------------------------------------------------------------
+  interface 
+    subroutine interpolation( &
+                ncol,nlay,ngas,nflav,neta, npres, ntemp, &
+                flavor,                                  &
+                press_ref_log, temp_ref,press_ref_log_delta,    &
+                temp_ref_min,temp_ref_delta,press_ref_trop_log, &
+                vmr_ref,                                        &
+                play,tlay,col_gas,                              &
+                jtemp,fmajor,fminor,col_mix,tropo,jeta,jpress) bind(C, name="rrtmgp_interpolation")
+      use mo_rte_kind,      only : wp, wl
+      ! input dimensions
+      integer,                            intent(in) :: ncol,nlay
+        !! physical domain size
+      integer,                            intent(in) :: ngas,nflav,neta,npres,ntemp
+        !! k-distribution table dimensions 
+      integer,     dimension(2,nflav),    intent(in) :: flavor
+        !! index into vmr_ref of major gases for each flavor
+      real(wp),    dimension(npres),      intent(in) :: press_ref_log
+        !! log of pressure dimension in RRTMGP tables 
+      real(wp),    dimension(ntemp),      intent(in) :: temp_ref
+        !! temperature dimension in RRTMGP tables 
+      real(wp),                           intent(in) :: press_ref_log_delta, &
+                                                        temp_ref_min, temp_ref_delta, &
+                                                        press_ref_trop_log
+        !! constants related to RRTMGP tables
+      real(wp),    dimension(2,0:ngas,ntemp), intent(in) :: vmr_ref
+        !! reference volume mixing ratios used in compute "binary species parameter" eta
+
+      ! inputs from profile or parent function
+      real(wp),    dimension(ncol,nlay),        intent(in) :: play, tlay
+        !! input pressure (Pa?) and temperature (K)
+      real(wp),    dimension(ncol,nlay,0:ngas), intent(in) :: col_gas
+        !! input column gas amount - molecules/cm^2 
+      ! outputs
+      integer,     dimension(ncol,nlay), intent(out) :: jtemp, jpress
+        !! temperature and pressure interpolation indexes 
+      logical(wl), dimension(ncol,nlay), intent(out) :: tropo
+        !! use lower (or upper) atmosphere tables 
+      integer,     dimension(2,    ncol,nlay,nflav), intent(out) :: jeta
+        !! Index for binary species interpolation 
+#if !defined(__INTEL_LLVM_COMPILER) && __INTEL_COMPILER >= 2021
+    ! A performance-hitting workaround for the vectorization problem reported in
+    ! https://github.com/earth-system-radiation/rte-rrtmgp/issues/159
+    ! The known affected compilers are Intel Fortran Compiler Classic
+    ! 2021.4, 2021.5 and 2022.1. We do not limit the workaround to these
+    ! versions because it is not clear when the compiler bug will be fixed, see
+    ! https://community.intel.com/t5/Intel-Fortran-Compiler/Compiler-vectorization-bug/m-p/1362591.
+    ! We, however, limit the workaround to the Classic versions only since the
+    ! problem is not confirmed for the Intel Fortran Compiler oneAPI (a.k.a
+    ! 'ifx'), which does not mean there is none though.
+    real(wp),    dimension(:,       :,   :,    :), intent(out) :: col_mix
+#else
+      real(wp),    dimension(2,    ncol,nlay,nflav), intent(out) :: col_mix
+        !! combination of major species's column amounts (first index is strat/trop)
+#endif
+      real(wp),    dimension(2,2,2,ncol,nlay,nflav), intent(out) :: fmajor
+        !! Interpolation weights in pressure, eta, strat/trop 
+      real(wp),    dimension(2,2,  ncol,nlay,nflav), intent(out) :: fminor
+        !! Interpolation fraction in eta, strat/trop 
+    end subroutine interpolation
+  end interface 
+  ! ------------------------------------------------------------------------------------------------------------------
+  interface
+    subroutine compute_tau_absorption(                &
+                  ncol,nlay,nbnd,ngpt,                &  ! dimensions
+                  ngas,nflav,neta,npres,ntemp,        &
+                  nminorlower, nminorklower,          & ! number of minor contributors, total num absorption coeffs
+                  nminorupper, nminorkupper,          &
+                  idx_h2o,                            &
+                  gpoint_flavor,                      &
+                  band_lims_gpt,                      &
+                  kmajor,                             &
+                  kminor_lower,                       &
+                  kminor_upper,                       &
+                  minor_limits_gpt_lower,             &
+                  minor_limits_gpt_upper,             &
+                  minor_scales_with_density_lower,    &
+                  minor_scales_with_density_upper,    &
+                  scale_by_complement_lower,          &
+                  scale_by_complement_upper,          &
+                  idx_minor_lower,                    &
+                  idx_minor_upper,                    &
+                  idx_minor_scaling_lower,            &
+                  idx_minor_scaling_upper,            &
+                  kminor_start_lower,                 &
+                  kminor_start_upper,                 &
+                  tropo,                              &
+                  col_mix,fmajor,fminor,              &
+                  play,tlay,col_gas,                  &
+                  jeta,jtemp,jpress,                  &
+                  tau) bind(C, name="rrtmgp_compute_tau_absorption")
+      ! ---------------------
+      use mo_rte_kind,      only : wp, wl
+      ! input dimensions
+      integer,                                intent(in) :: ncol,nlay,nbnd,ngpt         !! array sizes 
+      integer,                                intent(in) :: ngas,nflav,neta,npres,ntemp !! tables sizes 
+      integer,                                intent(in) :: nminorlower, nminorklower,nminorupper, nminorkupper
+                                                            !! table sizes
+      integer,                                intent(in) :: idx_h2o                     !! index of water vapor in col_gas
+      ! ---------------------
+      ! inputs from object
+      integer,     dimension(2,ngpt),                  intent(in) :: gpoint_flavor
+        !! major gas flavor (pair) by upper/lower, g-point
+      integer,     dimension(2,nbnd),                  intent(in) :: band_lims_gpt
+        !! beginning and ending g-point for each band 
+      real(wp),    dimension(ntemp,neta,npres+1,ngpt), intent(in) :: kmajor
+        !! absorption coefficient table - major gases 
+      real(wp),    dimension(ntemp,neta,nminorklower), intent(in) :: kminor_lower
+        !! absorption coefficient table - minor gases, lower atmosphere 
+      real(wp),    dimension(ntemp,neta,nminorkupper), intent(in) :: kminor_upper
+        !! absorption coefficient table - minor gases, upper atmosphere 
+      integer,     dimension(2,nminorlower),           intent(in) :: minor_limits_gpt_lower
+        !! beginning and ending g-point for each minor gas 
+      integer,     dimension(2,nminorupper),           intent(in) :: minor_limits_gpt_upper
+      logical(wl), dimension(  nminorlower),           intent(in) :: minor_scales_with_density_lower
+        !! generic treatment of minor gases - scales with density (e.g. continuum, collision-induced absorption)?
+      logical(wl), dimension(  nminorupper),           intent(in) :: minor_scales_with_density_upper
+      logical(wl), dimension(  nminorlower),           intent(in) :: scale_by_complement_lower
+        !! generic treatment of minor gases - scale by density (e.g. self-continuum) or complement?  
+      logical(wl), dimension(  nminorupper),           intent(in) :: scale_by_complement_upper
+      integer,     dimension(  nminorlower),           intent(in) :: idx_minor_lower  
+        !! index of each minor gas in col_gas
+      integer,     dimension(  nminorupper),           intent(in) :: idx_minor_upper
+      integer,     dimension(  nminorlower),           intent(in) :: idx_minor_scaling_lower 
+        !! for this minor gas, index of the "scaling gas" in col_gas 
+      integer,     dimension(  nminorupper),           intent(in) :: idx_minor_scaling_upper
+      integer,     dimension(  nminorlower),           intent(in) :: kminor_start_lower 
+        !! starting g-point index in minor gas absorption table
+      integer,     dimension(  nminorupper),           intent(in) :: kminor_start_upper
+      logical(wl), dimension(ncol,nlay),               intent(in) :: tropo
+        !! use upper- or lower-atmospheric tables? 
+      ! ---------------------
+      ! inputs from profile or parent function
+      real(wp), dimension(2,    ncol,nlay,nflav       ), intent(in) :: col_mix
+        !! combination of major species's column amounts - computed in interpolation() 
+      real(wp), dimension(2,2,2,ncol,nlay,nflav       ), intent(in) :: fmajor
+        !! interpolation weights for major gases - computed in interpolation() 
+      real(wp), dimension(2,2,  ncol,nlay,nflav       ), intent(in) :: fminor
+        !! interpolation weights for minor gases - computed in interpolation() 
+      real(wp), dimension(            ncol,nlay       ), intent(in) :: play, tlay 
+        !! input temperature and pressure 
+      real(wp), dimension(            ncol,nlay,0:ngas), intent(in) :: col_gas
+        !! input column gas amount (molecules/cm^2) 
+      integer,  dimension(2,    ncol,nlay,nflav       ), intent(in) :: jeta
+        !! interpolation indexes in eta - computed in interpolation() 
+      integer,  dimension(            ncol,nlay       ), intent(in) :: jtemp
+        !! interpolation indexes in temperature - computed in interpolation() 
+      integer,  dimension(            ncol,nlay       ), intent(in) :: jpress
+        !! interpolation indexes in pressure  - computed in interpolation() 
+      ! ---------------------
+      ! output - optical depth
+      real(wp), dimension(ncol,nlay,ngpt), intent(inout) :: tau !! aborption optional depth 
+    end subroutine compute_tau_absorption
+  end interface 
+  ! ------------------------------------------------------------------------------------------------------------------
+  interface
+    subroutine compute_tau_rayleigh(ncol,nlay,nbnd,ngpt,         &
+                                    ngas,nflav,neta,npres,ntemp, &
+                                    gpoint_flavor,band_lims_gpt, &
+                                    krayl,                       &
+                                    idx_h2o, col_dry,col_gas,    &
+                                    fminor,jeta,tropo,jtemp,     &
+                                    tau_rayleigh) bind(C, name="rrtmgp_compute_tau_rayleigh")
+      use mo_rte_kind,      only : wp, wl
+      integer,                                     intent(in ) :: ncol,nlay,nbnd,ngpt
+        !! input dimensions 
+      integer,                                     intent(in ) :: ngas,nflav,neta,npres,ntemp
+        !! table dimensions 
+      integer,     dimension(2,ngpt),              intent(in ) :: gpoint_flavor 
+        !! major gas flavor (pair) by upper/lower, g-point
+      integer,     dimension(2,nbnd),              intent(in ) :: band_lims_gpt
+        !! start and end g-point for each band
+      real(wp),    dimension(ntemp,neta,ngpt,2),   intent(in ) :: krayl
+        !! Rayleigh scattering coefficients 
+      integer,                                     intent(in ) :: idx_h2o
+        !! index of water vapor in col_gas
+      real(wp),    dimension(ncol,nlay),           intent(in ) :: col_dry
+        !! column amount of dry air 
+      real(wp),    dimension(ncol,nlay,0:ngas),    intent(in ) :: col_gas
+        !! input column gas amount  (molecules/cm^2)
+      real(wp),    dimension(2,2,ncol,nlay,nflav), intent(in ) :: fminor
+        !! interpolation weights for major gases - computed in interpolation() 
+      integer,     dimension(2,  ncol,nlay,nflav), intent(in ) :: jeta
+        !! interpolation indexes in eta - computed in interpolation() 
+      logical(wl), dimension(ncol,nlay),           intent(in ) :: tropo
+        !! use upper- or lower-atmospheric tables? 
+      integer,     dimension(ncol,nlay),           intent(in ) :: jtemp
+        !! interpolation indexes in temperature - computed in interpolation() 
+      ! outputs
+      real(wp),    dimension(ncol,nlay,ngpt),      intent(out) :: tau_rayleigh
+        !! Rayleigh optical depth 
+    end subroutine compute_tau_rayleigh
+  end interface
+  ! ------------------------------------------------------------------------------------------------------------------
+  interface 
+    subroutine compute_Planck_source(                        &
+                      ncol, nlay, nbnd, ngpt,                &
+                      nflav, neta, npres, ntemp, nPlanckTemp,&
+                      tlay, tlev, tsfc, sfc_lay,             &
+                      fmajor, jeta, tropo, jtemp, jpress,    &
+                      gpoint_bands, band_lims_gpt,           &
+                      pfracin, temp_ref_min, totplnk_delta, totplnk, gpoint_flavor, &
+                      sfc_src, lay_src, lev_src, sfc_source_Jac) bind(C, name="rrtmgp_compute_Planck_source")
+      use mo_rte_kind,      only : wp, wl
+      integer,                                    intent(in) :: ncol, nlay, nbnd, ngpt
+        !! input dimensions 
+      integer,                                    intent(in) :: nflav, neta, npres, ntemp, nPlanckTemp
+        !! table dimensions 
+      real(wp),    dimension(ncol,nlay  ),        intent(in) :: tlay !! temperature at layer centers (K)
+      real(wp),    dimension(ncol,nlay+1),        intent(in) :: tlev !! temperature at interfaces (K)
+      real(wp),    dimension(ncol       ),        intent(in) :: tsfc !! surface temperture 
+      integer,                                    intent(in) :: sfc_lay !! index into surface layer 
+      ! Interpolation variables
+      real(wp),    dimension(2,2,2,ncol,nlay,nflav), intent(in) :: fmajor
+        !! interpolation weights for major gases - computed in interpolation() 
+      integer,     dimension(2,    ncol,nlay,nflav), intent(in) :: jeta
+        !! interpolation indexes in eta - computed in interpolation() 
+      logical(wl), dimension(            ncol,nlay), intent(in) :: tropo
+        !! use upper- or lower-atmospheric tables? 
+      integer,     dimension(            ncol,nlay), intent(in) :: jtemp, jpress
+        !! interpolation indexes in temperature and pressure - computed in interpolation() 
+      ! Table-specific
+      integer, dimension(ngpt),                     intent(in) :: gpoint_bands  !! band to which each g-point belongs
+      integer, dimension(2, nbnd),                  intent(in) :: band_lims_gpt !! start and end g-point for each band
+      real(wp), dimension(ntemp,neta,npres+1,ngpt), intent(in) :: pfracin       !! Fraction of the Planck function in each g-point
+      real(wp),                                     intent(in) :: temp_ref_min, totplnk_delta !! interpolation constants
+      real(wp), dimension(nPlanckTemp,nbnd),        intent(in) :: totplnk       !! Total Planck function by band at each temperature 
+      integer,  dimension(2,ngpt),                  intent(in) :: gpoint_flavor !! major gas flavor (pair) by upper/lower, g-point
+
+      real(wp), dimension(ncol,       ngpt), intent(out) :: sfc_src  !! Planck emssion from the surface 
+      real(wp), dimension(ncol,nlay,  ngpt), intent(out) :: lay_src  !! Planck emssion from layer centers
+      real(wp), dimension(ncol,nlay+1,ngpt), intent(out) :: lev_src  !! Planck emission at layer boundaries
+      real(wp), dimension(ncol,       ngpt), intent(out) :: sfc_source_Jac 
+        !! Jacobian (derivative) of the surface Planck source with respect to surface temperature 
+    end subroutine compute_Planck_source
+  end interface
+  ! ------------------------------------------------------------------------------------------------------------------
+end module mo_gas_optics_rrtmgp_kernels
+
    + +
    +
    +
    + +
    +
    +
    +
    +
    +

    RRTMGP kernels was developed by The RTE+RRTTMGP consortium
    © 2024 Creative Commons License +

    +
    +
    +

    + Documentation generated by + FORD +

    +
    +
    +
    +
    +
    + + + + + + + + + + + + + + + + + + + \ No newline at end of file diff --git a/reference/rrtmgp-kernels/src/mo_gas_optics_rrtmgp_kernels.F90 b/reference/rrtmgp-kernels/src/mo_gas_optics_rrtmgp_kernels.F90 index e9adff780..9272bb16e 100644 --- a/reference/rrtmgp-kernels/src/mo_gas_optics_rrtmgp_kernels.F90 +++ b/reference/rrtmgp-kernels/src/mo_gas_optics_rrtmgp_kernels.F90 @@ -1,40 +1,12 @@ -! This code is part of -! RRTM for GCM Applications - Parallel (RRTMGP) -! -! Eli Mlawer and Robert Pincus -! Andre Wehe and Jennifer Delamere -! email: rrtmgp@aer.com -! -! Copyright 2015-, Atmospheric and Environmental Research, -! Regents of the University of Colorado, Trustees of Columbia University. All right reserved. -! -! Use and duplication is permitted under the terms of the -! BSD 3-clause license, see http://opensource.org/licenses/BSD-3-Clause -! ------------------------------------------------------------------------------------------------- -!> -!> ## Numeric calculations for gas optics. Absorption and Rayleigh optical depths, Planck source functions. -!> -!> - Interpolation coefficients are computed, then used in subsequent routines. -!> - All applications will call compute_tau_absorption(); -!> compute_tau_rayleigh() and/or compute_Planck_source() will be called depending on the -!> configuration of the k-distribution. -!> - The details of the interpolation scheme are not particaulrly important as long as arrays including -!> tables are passed consisently between kernels. -!> -! ------------------------------------------------------------------------------------------------- - module mo_gas_optics_rrtmgp_kernels use mo_rte_kind, only : wp, wl use mo_rte_util_array,only : zero_array implicit none private public :: interpolation, compute_tau_absorption, compute_tau_rayleigh, compute_Planck_source -contains - ! -------------------------------------------------------------------------------------- - !> Compute interpolation coefficients - !> for calculations of major optical depths, minor optical depths, Rayleigh, - !> and Planck fractions - subroutine interpolation( & + ! ------------------------------------------------------------------------------------------------------------------ + interface + subroutine interpolation( & ncol,nlay,ngas,nflav,neta, npres, ntemp, & flavor, & press_ref_log, temp_ref,press_ref_log_delta, & @@ -42,37 +14,38 @@ subroutine interpolation( & vmr_ref, & play,tlay,col_gas, & jtemp,fmajor,fminor,col_mix,tropo,jeta,jpress) bind(C, name="rrtmgp_interpolation") - ! input dimensions - integer, intent(in) :: ncol,nlay - !! physical domain size - integer, intent(in) :: ngas,nflav,neta,npres,ntemp - !! k-distribution table dimensions - integer, dimension(2,nflav), intent(in) :: flavor - !! index into vmr_ref of major gases for each flavor - real(wp), dimension(npres), intent(in) :: press_ref_log - !! log of pressure dimension in RRTMGP tables - real(wp), dimension(ntemp), intent(in) :: temp_ref - !! temperature dimension in RRTMGP tables - real(wp), intent(in) :: press_ref_log_delta, & - temp_ref_min, temp_ref_delta, & - press_ref_trop_log - !! constants related to RRTMGP tables - real(wp), dimension(2,0:ngas,ntemp), intent(in) :: vmr_ref - !! reference volume mixing ratios used in compute "binary species parameter" eta - - ! inputs from profile or parent function - real(wp), dimension(ncol,nlay), intent(in) :: play, tlay - !! input pressure (Pa?) and temperature (K) - real(wp), dimension(ncol,nlay,0:ngas), intent(in) :: col_gas - !! input column gas amount - molecules/cm^2 - ! outputs - integer, dimension(ncol,nlay), intent(out) :: jtemp, jpress - !! temperature and pressure interpolation indexes - logical(wl), dimension(ncol,nlay), intent(out) :: tropo - !! use lower (or upper) atmosphere tables - integer, dimension(2, ncol,nlay,nflav), intent(out) :: jeta - !! Index for binary species interpolation -#if !defined(__INTEL_LLVM_COMPILER) && __INTEL_COMPILER >= 1910 + use mo_rte_kind, only : wp, wl + ! input dimensions + integer, intent(in) :: ncol,nlay + !! physical domain size + integer, intent(in) :: ngas,nflav,neta,npres,ntemp + !! k-distribution table dimensions + integer, dimension(2,nflav), intent(in) :: flavor + !! index into vmr_ref of major gases for each flavor + real(wp), dimension(npres), intent(in) :: press_ref_log + !! log of pressure dimension in RRTMGP tables + real(wp), dimension(ntemp), intent(in) :: temp_ref + !! temperature dimension in RRTMGP tables + real(wp), intent(in) :: press_ref_log_delta, & + temp_ref_min, temp_ref_delta, & + press_ref_trop_log + !! constants related to RRTMGP tables + real(wp), dimension(2,0:ngas,ntemp), intent(in) :: vmr_ref + !! reference volume mixing ratios used in compute "binary species parameter" eta + + ! inputs from profile or parent function + real(wp), dimension(ncol,nlay), intent(in) :: play, tlay + !! input pressure (Pa?) and temperature (K) + real(wp), dimension(ncol,nlay,0:ngas), intent(in) :: col_gas + !! input column gas amount - molecules/cm^2 + ! outputs + integer, dimension(ncol,nlay), intent(out) :: jtemp, jpress + !! temperature and pressure interpolation indexes + logical(wl), dimension(ncol,nlay), intent(out) :: tropo + !! use lower (or upper) atmosphere tables + integer, dimension(2, ncol,nlay,nflav), intent(out) :: jeta + !! Index for binary species interpolation +#if !defined(__INTEL_LLVM_COMPILER) && __INTEL_COMPILER >= 2021 ! A performance-hitting workaround for the vectorization problem reported in ! https://github.com/earth-system-radiation/rte-rrtmgp/issues/159 ! The known affected compilers are Intel Fortran Compiler Classic @@ -84,700 +57,189 @@ subroutine interpolation( & ! 'ifx'), which does not mean there is none though. real(wp), dimension(:, :, :, :), intent(out) :: col_mix #else - real(wp), dimension(2, ncol,nlay,nflav), intent(out) :: col_mix - !! combination of major species's column amounts (first index is strat/trop) + real(wp), dimension(2, ncol,nlay,nflav), intent(out) :: col_mix + !! combination of major species's column amounts (first index is strat/trop) #endif - real(wp), dimension(2,2,2,ncol,nlay,nflav), intent(out) :: fmajor - !! Interpolation weights in pressure, eta, strat/trop - real(wp), dimension(2,2, ncol,nlay,nflav), intent(out) :: fminor - !! Interpolation fraction in eta, strat/trop - ! ----------------- - ! local - real(wp), dimension(ncol,nlay) :: ftemp, fpress ! interpolation fraction for temperature, pressure - real(wp) :: locpress ! needed to find location in pressure grid - real(wp) :: ratio_eta_half ! ratio of vmrs of major species that defines eta=0.5 - ! for given flavor and reference temperature level - real(wp) :: eta, feta ! binary_species_parameter, interpolation variable for eta - real(wp) :: loceta ! needed to find location in eta grid - real(wp) :: ftemp_term - ! ----------------- - ! local indexes - integer :: icol, ilay, iflav, igases(2), itropo, itemp - - do ilay = 1, nlay - do icol = 1, ncol - ! index and factor for temperature interpolation - jtemp(icol,ilay) = int((tlay(icol,ilay) - (temp_ref_min - temp_ref_delta)) / temp_ref_delta) - jtemp(icol,ilay) = min(ntemp - 1, max(1, jtemp(icol,ilay))) ! limit the index range - ftemp(icol,ilay) = (tlay(icol,ilay) - temp_ref(jtemp(icol,ilay))) / temp_ref_delta - - ! index and factor for pressure interpolation - locpress = 1._wp + (log(play(icol,ilay)) - press_ref_log(1)) / press_ref_log_delta - jpress(icol,ilay) = min(npres-1, max(1, int(locpress))) - fpress(icol,ilay) = locpress - float(jpress(icol,ilay)) - - ! determine if in lower or upper part of atmosphere - tropo(icol,ilay) = log(play(icol,ilay)) > press_ref_trop_log - end do - end do - - do iflav = 1, nflav - igases(:) = flavor(:,iflav) - do ilay = 1, nlay - do icol = 1, ncol - ! itropo = 1 lower atmosphere; itropo = 2 upper atmosphere - itropo = merge(1,2,tropo(icol,ilay)) - ! loop over implemented combinations of major species - do itemp = 1, 2 - ! compute interpolation fractions needed for lower, then upper reference temperature level - ! compute binary species parameter (eta) for flavor and temperature and - ! associated interpolation index and factors - ratio_eta_half = vmr_ref(itropo,igases(1),(jtemp(icol,ilay)+itemp-1)) / & - vmr_ref(itropo,igases(2),(jtemp(icol,ilay)+itemp-1)) - col_mix(itemp,icol,ilay,iflav) = col_gas(icol,ilay,igases(1)) + ratio_eta_half * col_gas(icol,ilay,igases(2)) - ! Keep this commented lines. Fortran does allow for - ! substantial optimizations and in this merge cases may - ! happen that all expressions are evaluated and so create - ! a division by zero. In the if construct this should be - ! save. Merge is the way to do it in general inside of - ! loops, but sometimes it may not work. - ! - ! eta = merge(col_gas(icol,ilay,igases(1)) / col_mix(itemp,icol,ilay,iflav), 0.5_wp, & - ! col_mix(itemp,icol,ilay,iflav) > 2._wp * tiny(col_mix)) - ! - ! In essence: do not turn it back to merge(...)! - if (col_mix(itemp,icol,ilay,iflav) > 2._wp * tiny(col_mix)) then - eta = col_gas(icol,ilay,igases(1)) / col_mix(itemp,icol,ilay,iflav) - else - eta = 0.5_wp - endif - loceta = eta * float(neta-1) - jeta(itemp,icol,ilay,iflav) = min(int(loceta)+1, neta-1) - feta = mod(loceta, 1.0_wp) - ! compute interpolation fractions needed for minor species - ! ftemp_term = (1._wp-ftemp(icol,ilay)) for itemp = 1, ftemp(icol,ilay) for itemp=2 - ftemp_term = (real(2-itemp, wp) + real(2*itemp-3, wp) * ftemp(icol,ilay)) - fminor(1,itemp,icol,ilay,iflav) = (1._wp-feta) * ftemp_term - fminor(2,itemp,icol,ilay,iflav) = feta * ftemp_term - ! compute interpolation fractions needed for major species - fmajor(1,1,itemp,icol,ilay,iflav) = (1._wp-fpress(icol,ilay)) * fminor(1,itemp,icol,ilay,iflav) - fmajor(2,1,itemp,icol,ilay,iflav) = (1._wp-fpress(icol,ilay)) * fminor(2,itemp,icol,ilay,iflav) - fmajor(1,2,itemp,icol,ilay,iflav) = fpress(icol,ilay) * fminor(1,itemp,icol,ilay,iflav) - fmajor(2,2,itemp,icol,ilay,iflav) = fpress(icol,ilay) * fminor(2,itemp,icol,ilay,iflav) - end do ! reference temperatures - end do ! icol - end do ! ilay - end do ! iflav - - end subroutine interpolation - ! -------------------------------------------------------------------------------------- - ! - !> Compute minor and major species optical depth using pre-computed interpolation coefficients - !> (jeta,jtemp,jpress) and weights (fmajor, fminor) - ! - subroutine compute_tau_absorption( & - ncol,nlay,nbnd,ngpt, & ! dimensions - ngas,nflav,neta,npres,ntemp, & - nminorlower, nminorklower, & ! number of minor contributors, total num absorption coeffs - nminorupper, nminorkupper, & - idx_h2o, & - gpoint_flavor, & - band_lims_gpt, & - kmajor, & - kminor_lower, & - kminor_upper, & - minor_limits_gpt_lower, & - minor_limits_gpt_upper, & - minor_scales_with_density_lower, & - minor_scales_with_density_upper, & - scale_by_complement_lower, & - scale_by_complement_upper, & - idx_minor_lower, & - idx_minor_upper, & - idx_minor_scaling_lower, & - idx_minor_scaling_upper, & - kminor_start_lower, & - kminor_start_upper, & - tropo, & - col_mix,fmajor,fminor, & - play,tlay,col_gas, & - jeta,jtemp,jpress, & - tau) bind(C, name="rrtmgp_compute_tau_absorption") - ! --------------------- - ! input dimensions - integer, intent(in) :: ncol,nlay,nbnd,ngpt !! array sizes - integer, intent(in) :: ngas,nflav,neta,npres,ntemp !! tables sizes - integer, intent(in) :: nminorlower, nminorklower,nminorupper, nminorkupper - !! table sizes - integer, intent(in) :: idx_h2o !! index of water vapor in col_gas - ! --------------------- - ! inputs from object - integer, dimension(2,ngpt), intent(in) :: gpoint_flavor - !! major gas flavor (pair) by upper/lower, g-point - integer, dimension(2,nbnd), intent(in) :: band_lims_gpt - !! beginning and ending g-point for each band - real(wp), dimension(ntemp,neta,npres+1,ngpt), intent(in) :: kmajor - !! absorption coefficient table - major gases - real(wp), dimension(ntemp,neta,nminorklower), intent(in) :: kminor_lower - !! absorption coefficient table - minor gases, lower atmosphere - real(wp), dimension(ntemp,neta,nminorkupper), intent(in) :: kminor_upper - !! absorption coefficient table - minor gases, upper atmosphere - integer, dimension(2,nminorlower), intent(in) :: minor_limits_gpt_lower - !! beginning and ending g-point for each minor gas - integer, dimension(2,nminorupper), intent(in) :: minor_limits_gpt_upper - logical(wl), dimension( nminorlower), intent(in) :: minor_scales_with_density_lower - !! generic treatment of minor gases - scales with density (e.g. continuum, collision-induced absorption)? - logical(wl), dimension( nminorupper), intent(in) :: minor_scales_with_density_upper - logical(wl), dimension( nminorlower), intent(in) :: scale_by_complement_lower - !! generic treatment of minor gases - scale by density (e.g. self-continuum) or complement? - logical(wl), dimension( nminorupper), intent(in) :: scale_by_complement_upper - integer, dimension( nminorlower), intent(in) :: idx_minor_lower - !! index of each minor gas in col_gas - integer, dimension( nminorupper), intent(in) :: idx_minor_upper - integer, dimension( nminorlower), intent(in) :: idx_minor_scaling_lower - !! for this minor gas, index of the "scaling gas" in col_gas - integer, dimension( nminorupper), intent(in) :: idx_minor_scaling_upper - integer, dimension( nminorlower), intent(in) :: kminor_start_lower - !! starting g-point index in minor gas absorption table - integer, dimension( nminorupper), intent(in) :: kminor_start_upper - logical(wl), dimension(ncol,nlay), intent(in) :: tropo - !! use upper- or lower-atmospheric tables? - ! --------------------- - ! inputs from profile or parent function - real(wp), dimension(2, ncol,nlay,nflav ), intent(in) :: col_mix - !! combination of major species's column amounts - computed in interpolation() - real(wp), dimension(2,2,2,ncol,nlay,nflav ), intent(in) :: fmajor - !! interpolation weights for major gases - computed in interpolation() - real(wp), dimension(2,2, ncol,nlay,nflav ), intent(in) :: fminor - !! interpolation weights for minor gases - computed in interpolation() - real(wp), dimension( ncol,nlay ), intent(in) :: play, tlay - !! input temperature and pressure - real(wp), dimension( ncol,nlay,0:ngas), intent(in) :: col_gas - !! input column gas amount (molecules/cm^2) - integer, dimension(2, ncol,nlay,nflav ), intent(in) :: jeta - !! interpolation indexes in eta - computed in interpolation() - integer, dimension( ncol,nlay ), intent(in) :: jtemp - !! interpolation indexes in temperature - computed in interpolation() - integer, dimension( ncol,nlay ), intent(in) :: jpress - !! interpolation indexes in pressure - computed in interpolation() - ! --------------------- - ! output - optical depth - real(wp), dimension(ncol,nlay,ngpt), intent(inout) :: tau !! aborption optional depth - ! --------------------- - ! Local variables - ! - logical :: top_at_1 - integer, dimension(ncol,2) :: itropo_lower, itropo_upper - ! ---------------------------------------------------------------- - - ! --------------------- - ! Layer limits of upper, lower atmospheres - ! --------------------- - top_at_1 = play(1,1) < play(1, nlay) - if(top_at_1) then - itropo_lower(:, 1) = minloc(play, dim=2, mask=tropo) - itropo_lower(:, 2) = nlay - itropo_upper(:, 1) = 1 - itropo_upper(:, 2) = maxloc(play, dim=2, mask=(.not. tropo)) - else - itropo_lower(:, 1) = 1 - itropo_lower(:, 2) = minloc(play, dim=2, mask= tropo) - itropo_upper(:, 1) = maxloc(play, dim=2, mask=(.not. tropo)) - itropo_upper(:, 2) = nlay - end if - ! --------------------- - ! Major Species - ! --------------------- - call gas_optical_depths_major( & - ncol,nlay,nbnd,ngpt, & ! dimensions - nflav,neta,npres,ntemp, & - gpoint_flavor, & - band_lims_gpt, & - kmajor, & - col_mix,fmajor, & - jeta,tropo,jtemp,jpress, & - tau) - ! --------------------- - ! Minor Species - lower - ! --------------------- - call gas_optical_depths_minor( & - ncol,nlay,ngpt, & ! dimensions - ngas,nflav,ntemp,neta, & - nminorlower,nminorklower, & - idx_h2o, & - gpoint_flavor(1,:), & - kminor_lower, & - minor_limits_gpt_lower, & - minor_scales_with_density_lower, & - scale_by_complement_lower, & - idx_minor_lower, & - idx_minor_scaling_lower, & - kminor_start_lower, & - play, tlay, & - col_gas,fminor,jeta, & - itropo_lower,jtemp, & - tau) - ! --------------------- - ! Minor Species - upper - ! --------------------- - call gas_optical_depths_minor( & - ncol,nlay,ngpt, & ! dimensions - ngas,nflav,ntemp,neta, & - nminorupper,nminorkupper, & - idx_h2o, & - gpoint_flavor(2,:), & - kminor_upper, & - minor_limits_gpt_upper, & - minor_scales_with_density_upper, & - scale_by_complement_upper, & - idx_minor_upper, & - idx_minor_scaling_upper, & - kminor_start_upper, & - play, tlay, & - col_gas,fminor,jeta, & - itropo_upper,jtemp, & - tau) - end subroutine compute_tau_absorption - ! -------------------------------------------------------------------------------------- - - ! -------------------------------------------------------------------------------------- - ! - ! compute minor species optical depths - ! - subroutine gas_optical_depths_major(ncol,nlay,nbnd,ngpt,& - nflav,neta,npres,ntemp, & ! dimensions - gpoint_flavor, band_lims_gpt, & ! inputs from object - kmajor, & - col_mix,fmajor, & - jeta,tropo,jtemp,jpress, & ! local input - tau) - ! input dimensions - integer, intent(in) :: ncol, nlay, nbnd, ngpt, nflav,neta,npres,ntemp ! dimensions - - ! inputs from object - integer, dimension(2,ngpt), intent(in) :: gpoint_flavor - integer, dimension(2,nbnd), intent(in) :: band_lims_gpt ! start and end g-point for each band - real(wp), dimension(ntemp,neta,npres+1,ngpt), intent(in) :: kmajor - - ! inputs from profile or parent function - real(wp), dimension(2, ncol,nlay,nflav), intent(in) :: col_mix - real(wp), dimension(2,2,2,ncol,nlay,nflav), intent(in) :: fmajor - integer, dimension(2, ncol,nlay,nflav), intent(in) :: jeta - logical(wl), dimension(ncol,nlay), intent(in) :: tropo - integer, dimension(ncol,nlay), intent(in) :: jtemp, jpress - - ! outputs - real(wp), dimension(ncol,nlay,ngpt), intent(inout) :: tau - ! ----------------- - ! local variables - real(wp) :: tau_major(ngpt) ! major species optical depth - ! local index - integer :: icol, ilay, iflav, ibnd, itropo - integer :: gptS, gptE - - ! optical depth calculation for major species - do ibnd = 1, nbnd - gptS = band_lims_gpt(1, ibnd) - gptE = band_lims_gpt(2, ibnd) - do ilay = 1, nlay - do icol = 1, ncol - ! itropo = 1 lower atmosphere; itropo = 2 upper atmosphere - itropo = merge(1,2,tropo(icol,ilay)) - iflav = gpoint_flavor(itropo, gptS) !eta interpolation depends on band's flavor - tau_major(gptS:gptE) = & - ! interpolation in temperature, pressure, and eta - interpolate3D_byflav(col_mix(:,icol,ilay,iflav), & - fmajor(:,:,:,icol,ilay,iflav), kmajor, & - band_lims_gpt(1, ibnd), band_lims_gpt(2, ibnd), & - jeta(:,icol,ilay,iflav), jtemp(icol,ilay),jpress(icol,ilay)+itropo) - tau(icol,ilay,gptS:gptE) = tau(icol,ilay,gptS:gptE) + tau_major(gptS:gptE) - end do - end do - end do - - end subroutine gas_optical_depths_major - - ! ---------------------------------------------------------- - ! - ! compute minor species optical depths - ! - subroutine gas_optical_depths_minor(ncol,nlay,ngpt, & - ngas,nflav,ntemp,neta, & - nminor,nminork, & - idx_h2o, & - gpt_flv, & - kminor, & - minor_limits_gpt, & - minor_scales_with_density, & - scale_by_complement, & - idx_minor, idx_minor_scaling, & - kminor_start, & - play, tlay, & - col_gas,fminor,jeta, & - layer_limits,jtemp, & - tau) - integer, intent(in ) :: ncol,nlay,ngpt - integer, intent(in ) :: ngas,nflav - integer, intent(in ) :: ntemp,neta,nminor,nminork - integer, intent(in ) :: idx_h2o - integer, dimension(ngpt), intent(in ) :: gpt_flv - real(wp), dimension(ntemp,neta,nminork), intent(in ) :: kminor - integer, dimension(2,nminor), intent(in ) :: minor_limits_gpt - logical(wl), dimension( nminor), intent(in ) :: minor_scales_with_density - logical(wl), dimension( nminor), intent(in ) :: scale_by_complement - integer, dimension( nminor), intent(in ) :: kminor_start - integer, dimension( nminor), intent(in ) :: idx_minor, idx_minor_scaling - real(wp), dimension(ncol,nlay), intent(in ) :: play, tlay - real(wp), dimension(ncol,nlay,0:ngas), intent(in ) :: col_gas - real(wp), dimension(2,2,ncol,nlay,nflav), intent(in ) :: fminor - integer, dimension(2, ncol,nlay,nflav), intent(in ) :: jeta - integer, dimension(ncol, 2), intent(in ) :: layer_limits - integer, dimension(ncol,nlay), intent(in ) :: jtemp - real(wp), dimension(ncol,nlay,ngpt), intent(inout) :: tau - ! ----------------- - ! local variables - real(wp), parameter :: PaTohPa = 0.01_wp - real(wp) :: vmr_fact, dry_fact ! conversion from column abundance to dry vol. mixing ratio; - real(wp) :: scaling ! optical depth - integer :: icol, ilay, iflav, imnr - integer :: gptS, gptE - real(wp), dimension(ngpt) :: tau_minor - ! ----------------- - ! - ! Guard against layer limits being 0 -- that means don't do anything i.e. there are no - ! layers with pressures in the upper or lower atmosphere respectively - ! First check skips the routine entirely if all columns are out of bounds... - ! - - if(any(layer_limits(:,1) > 0)) then - do imnr = 1, size(scale_by_complement,dim=1) ! loop over minor absorbers in each band - do icol = 1, ncol - ! - ! This check skips individual columns with no pressures in range - ! - if(layer_limits(icol,1) > 0) then - do ilay = layer_limits(icol,1), layer_limits(icol,2) - ! - ! Scaling of minor gas absortion coefficient begins with column amount of minor gas - ! - scaling = col_gas(icol,ilay,idx_minor(imnr)) - ! - ! Density scaling (e.g. for h2o continuum, collision-induced absorption) - ! - if (minor_scales_with_density(imnr)) then - ! - ! NOTE: P needed in hPa to properly handle density scaling. - ! - scaling = scaling * (PaTohPa*play(icol,ilay)/tlay(icol,ilay)) - if(idx_minor_scaling(imnr) > 0) then ! there is a second gas that affects this gas's absorption - vmr_fact = 1._wp / col_gas(icol,ilay,0) - dry_fact = 1._wp / (1._wp + col_gas(icol,ilay,idx_h2o) * vmr_fact) - ! scale by density of special gas - if (scale_by_complement(imnr)) then ! scale by densities of all gases but the special one - scaling = scaling * (1._wp - col_gas(icol,ilay,idx_minor_scaling(imnr)) * vmr_fact * dry_fact) - else - scaling = scaling * (col_gas(icol,ilay,idx_minor_scaling(imnr)) * vmr_fact * dry_fact) - endif - endif - endif - ! - ! Interpolation of absorption coefficient and calculation of optical depth - ! - ! Which gpoint range does this minor gas affect? - gptS = minor_limits_gpt(1,imnr) - gptE = minor_limits_gpt(2,imnr) - iflav = gpt_flv(gptS) - tau_minor(gptS:gptE) = scaling * & - interpolate2D_byflav(fminor(:,:,icol,ilay,iflav), & - kminor, & - kminor_start(imnr), kminor_start(imnr)+(gptE-gptS), & - jeta(:,icol,ilay,iflav), jtemp(icol,ilay)) - tau(icol,ilay,gptS:gptE) = tau(icol,ilay,gptS:gptE) + tau_minor(gptS:gptE) - enddo - end if - enddo - enddo - end if - - end subroutine gas_optical_depths_minor - ! ---------------------------------------------------------- - ! - ! compute Rayleigh scattering optical depths - ! - subroutine compute_tau_rayleigh(ncol,nlay,nbnd,ngpt, & - ngas,nflav,neta,npres,ntemp, & - gpoint_flavor,band_lims_gpt, & - krayl, & - idx_h2o, col_dry,col_gas, & - fminor,jeta,tropo,jtemp, & - tau_rayleigh) bind(C, name="rrtmgp_compute_tau_rayleigh") - integer, intent(in ) :: ncol,nlay,nbnd,ngpt - !! input dimensions - integer, intent(in ) :: ngas,nflav,neta,npres,ntemp - !! table dimensions - integer, dimension(2,ngpt), intent(in ) :: gpoint_flavor - !! major gas flavor (pair) by upper/lower, g-point - integer, dimension(2,nbnd), intent(in ) :: band_lims_gpt - !! start and end g-point for each band - real(wp), dimension(ntemp,neta,ngpt,2), intent(in ) :: krayl - !! Rayleigh scattering coefficients - integer, intent(in ) :: idx_h2o - !! index of water vapor in col_gas - real(wp), dimension(ncol,nlay), intent(in ) :: col_dry - !! column amount of dry air - real(wp), dimension(ncol,nlay,0:ngas), intent(in ) :: col_gas - !! input column gas amount (molecules/cm^2) - real(wp), dimension(2,2,ncol,nlay,nflav), intent(in ) :: fminor - !! interpolation weights for major gases - computed in interpolation() - integer, dimension(2, ncol,nlay,nflav), intent(in ) :: jeta - !! interpolation indexes in eta - computed in interpolation() - logical(wl), dimension(ncol,nlay), intent(in ) :: tropo - !! use upper- or lower-atmospheric tables? - integer, dimension(ncol,nlay), intent(in ) :: jtemp - !! interpolation indexes in temperature - computed in interpolation() - ! outputs - real(wp), dimension(ncol,nlay,ngpt), intent(out) :: tau_rayleigh - !! Rayleigh optical depth - ! ----------------- - ! local variables - real(wp) :: k(ngpt) ! rayleigh scattering coefficient - integer :: icol, ilay, iflav, ibnd, gptS, gptE - integer :: itropo - ! ----------------- - - do ibnd = 1, nbnd - gptS = band_lims_gpt(1, ibnd) - gptE = band_lims_gpt(2, ibnd) - do ilay = 1, nlay - do icol = 1, ncol - itropo = merge(1,2,tropo(icol,ilay)) ! itropo = 1 lower atmosphere;itropo = 2 upper atmosphere - iflav = gpoint_flavor(itropo, gptS) !eta interpolation depends on band's flavor - k(gptS:gptE) = interpolate2D_byflav(fminor(:,:,icol,ilay,iflav), & - krayl(:,:,:,itropo), & - gptS, gptE, jeta(:,icol,ilay,iflav), jtemp(icol,ilay)) - tau_rayleigh(icol,ilay,gptS:gptE) = k(gptS:gptE) * & - (col_gas(icol,ilay,idx_h2o)+col_dry(icol,ilay)) - end do - end do - end do - - end subroutine compute_tau_rayleigh - - ! ---------------------------------------------------------- - subroutine compute_Planck_source( & - ncol, nlay, nbnd, ngpt, & - nflav, neta, npres, ntemp, nPlanckTemp,& - tlay, tlev, tsfc, sfc_lay, & - fmajor, jeta, tropo, jtemp, jpress, & - gpoint_bands, band_lims_gpt, & - pfracin, temp_ref_min, totplnk_delta, totplnk, gpoint_flavor, & - sfc_src, lay_src, lev_src_inc, lev_src_dec, sfc_source_Jac) bind(C, name="rrtmgp_compute_Planck_source") - integer, intent(in) :: ncol, nlay, nbnd, ngpt - !! input dimensions - integer, intent(in) :: nflav, neta, npres, ntemp, nPlanckTemp - !! table dimensions - real(wp), dimension(ncol,nlay ), intent(in) :: tlay !! temperature at layer centers (K) - real(wp), dimension(ncol,nlay+1), intent(in) :: tlev !! temperature at interfaces (K) - real(wp), dimension(ncol ), intent(in) :: tsfc !! surface temperture - integer, intent(in) :: sfc_lay !! index into surface layer - ! Interpolation variables - real(wp), dimension(2,2,2,ncol,nlay,nflav), intent(in) :: fmajor - !! interpolation weights for major gases - computed in interpolation() - integer, dimension(2, ncol,nlay,nflav), intent(in) :: jeta - !! interpolation indexes in eta - computed in interpolation() - logical(wl), dimension( ncol,nlay), intent(in) :: tropo - !! use upper- or lower-atmospheric tables? - integer, dimension( ncol,nlay), intent(in) :: jtemp, jpress - !! interpolation indexes in temperature and pressure - computed in interpolation() - ! Table-specific - integer, dimension(ngpt), intent(in) :: gpoint_bands !! band to which each g-point belongs - integer, dimension(2, nbnd), intent(in) :: band_lims_gpt !! start and end g-point for each band - real(wp), intent(in) :: temp_ref_min, totplnk_delta !! interpolation constants - real(wp), dimension(ntemp,neta,npres+1,ngpt), intent(in) :: pfracin !! Fraction of the Planck function in each g-point - real(wp), dimension(nPlanckTemp,nbnd), intent(in) :: totplnk !! Total Planck function by band at each temperature - integer, dimension(2,ngpt), intent(in) :: gpoint_flavor !! major gas flavor (pair) by upper/lower, g-point - - real(wp), dimension(ncol, ngpt), intent(out) :: sfc_src !! Planck emssion from the surface - real(wp), dimension(ncol,nlay,ngpt), intent(out) :: lay_src !! Planck emssion from layer centers - real(wp), dimension(ncol,nlay,ngpt), intent(out) :: lev_src_inc, lev_src_dec - !! Planck emission at layer boundaries, using spectral mapping in the direction of propagation - real(wp), dimension(ncol, ngpt), intent(out) :: sfc_source_Jac - !! Jacobian (derivative) of the surface Planck source with respect to surface temperature - ! ----------------- - ! local - real(wp), parameter :: delta_Tsurf = 1.0_wp - - integer :: ilay, icol, igpt, ibnd, itropo, iflav - integer :: gptS, gptE - real(wp), dimension(2), parameter :: one = [1._wp, 1._wp] - real(wp) :: pfrac (ncol,nlay ,ngpt) - real(wp) :: planck_function(ncol,nlay+1,nbnd) - ! ----------------- - - ! Calculation of fraction of band's Planck irradiance associated with each g-point - do ibnd = 1, nbnd - gptS = band_lims_gpt(1, ibnd) - gptE = band_lims_gpt(2, ibnd) - do ilay = 1, nlay - do icol = 1, ncol - ! itropo = 1 lower atmosphere; itropo = 2 upper atmosphere - itropo = merge(1,2,tropo(icol,ilay)) - iflav = gpoint_flavor(itropo, gptS) !eta interpolation depends on band's flavor - pfrac(icol,ilay,gptS:gptE) = & - ! interpolation in temperature, pressure, and eta - interpolate3D_byflav(one, fmajor(:,:,:,icol,ilay,iflav), pfracin, & - band_lims_gpt(1, ibnd), band_lims_gpt(2, ibnd), & - jeta(:,icol,ilay,iflav), jtemp(icol,ilay),jpress(icol,ilay)+itropo) - end do ! column - end do ! layer - end do ! band - - ! - ! Planck function by band for the surface - ! Compute surface source irradiance for g-point, equals band irradiance x fraction for g-point - ! - do icol = 1, ncol - planck_function(icol,1,1:nbnd) = interpolate1D(tsfc(icol), temp_ref_min, totplnk_delta, totplnk) - planck_function(icol,2,1:nbnd) = interpolate1D(tsfc(icol) + delta_Tsurf, temp_ref_min, totplnk_delta, totplnk) - ! - ! Map to g-points - ! - do ibnd = 1, nbnd - gptS = band_lims_gpt(1, ibnd) - gptE = band_lims_gpt(2, ibnd) - do igpt = gptS, gptE - sfc_src(icol,igpt) = pfrac(icol,sfc_lay,igpt) * planck_function(icol,1,ibnd) - sfc_source_Jac(icol, igpt) = pfrac(icol,sfc_lay,igpt) * & - (planck_function(icol, 2, ibnd) - planck_function(icol,1,ibnd)) - end do - end do - end do !icol - - do ilay = 1, nlay - do icol = 1, ncol - ! Compute layer source irradiance for g-point, equals band irradiance x fraction for g-point - planck_function(icol,ilay,1:nbnd) = interpolate1D(tlay(icol,ilay), temp_ref_min, totplnk_delta, totplnk) - end do - end do - - ! - ! Map to g-points - ! - do ibnd = 1, nbnd - gptS = band_lims_gpt(1, ibnd) - gptE = band_lims_gpt(2, ibnd) - do igpt = gptS, gptE - do ilay = 1, nlay - do icol = 1, ncol - lay_src(icol,ilay,igpt) = pfrac(icol,ilay,igpt) * planck_function(icol,ilay,ibnd) - end do - end do - end do - end do - - ! compute level source irradiances for each g-point, one each for upward and downward paths - do ilay = 1, nlay - do icol = 1, ncol - planck_function(icol, 1,1:nbnd) = interpolate1D(tlev(icol, 1),temp_ref_min, totplnk_delta, totplnk) - planck_function(icol,ilay+1,1:nbnd) = interpolate1D(tlev(icol,ilay+1),temp_ref_min, totplnk_delta, totplnk) - end do - end do - - ! - ! Map to g-points - ! - do ibnd = 1, nbnd - gptS = band_lims_gpt(1, ibnd) - gptE = band_lims_gpt(2, ibnd) - do igpt = gptS, gptE - do ilay = 1, nlay - do icol = 1, ncol - lev_src_inc(icol,ilay,igpt) = pfrac(icol,ilay,igpt) *planck_function(icol,ilay+1,ibnd) - lev_src_dec(icol,ilay,igpt) = pfrac(icol,ilay,igpt) *planck_function(icol,ilay ,ibnd) - end do - end do - end do - end do - - end subroutine compute_Planck_source - ! ---------------------------------------------------------- - ! - ! One dimensional interpolation -- return all values along second table dimension - ! - pure function interpolate1D(val, offset, delta, table) result(res) - ! input - real(wp), intent(in) :: val, & ! axis value at which to evaluate table - offset, & ! minimum of table axis - delta ! step size of table axis - real(wp), dimension(:,:), & - intent(in) :: table ! dimensions (axis, values) - ! output - real(wp), dimension(size(table,dim=2)) :: res - - ! local - real(wp) :: val0 ! fraction index adjusted by offset and delta - integer :: index ! index term - real(wp) :: frac ! fractional term - ! ------------------------------------- - val0 = (val - offset) / delta - frac = val0 - int(val0) ! get fractional part - index = min(size(table,dim=1)-1, max(1, int(val0)+1)) ! limit the index range - res(:) = table(index,:) + frac * (table(index+1,:) - table(index,:)) - end function interpolate1D - ! ---------------------------------------------------------- - ! This function returns a range of values from a subset (in gpoint) of the k table - ! - pure function interpolate2D_byflav(fminor, k, gptS, gptE, jeta, jtemp) result(res) - real(wp), dimension(2,2), intent(in) :: fminor ! interpolation fractions for minor species - ! index(1) : reference eta level (temperature dependent) - ! index(2) : reference temperature level - real(wp), dimension(:,:,:), intent(in) :: k ! (g-point, eta, temp) - integer, intent(in) :: gptS, gptE, jtemp ! interpolation index for temperature - integer, dimension(2), intent(in) :: jeta ! interpolation index for binary species parameter (eta) - real(wp), dimension(gptE-gptS+1) :: res ! the result - - ! Local variable - integer :: igpt - ! each code block is for a different reference temperature - - do igpt = 1, gptE-gptS+1 - res(igpt) = fminor(1,1) * k(jtemp , jeta(1) , gptS+igpt-1) + & - fminor(2,1) * k(jtemp , jeta(1)+1, gptS+igpt-1) + & - fminor(1,2) * k(jtemp+1, jeta(2) , gptS+igpt-1) + & - fminor(2,2) * k(jtemp+1, jeta(2)+1, gptS+igpt-1) - end do - - end function interpolate2D_byflav - ! ---------------------------------------------------------- - pure function interpolate3D_byflav(scaling, fmajor, k, gptS, gptE, jeta, jtemp, jpress) result(res) - real(wp), dimension(2), intent(in) :: scaling - real(wp), dimension(2,2,2), intent(in) :: fmajor ! interpolation fractions for major species - ! index(1) : reference eta level (temperature dependent) - ! index(2) : reference pressure level - ! index(3) : reference temperature level - real(wp), dimension(:,:,:,:),intent(in) :: k ! (temp,eta,press,gpt) - integer, intent(in) :: gptS, gptE - integer, dimension(2), intent(in) :: jeta ! interpolation index for binary species parameter (eta) - integer, intent(in) :: jtemp ! interpolation index for temperature - integer, intent(in) :: jpress ! interpolation index for pressure - real(wp), dimension(gptS:gptE) :: res ! the result - - ! Local variable - integer :: igpt - ! each code block is for a different reference temperature - do igpt = gptS, gptE - res(igpt) = & - scaling(1) * & - ( fmajor(1,1,1) * k(jtemp, jeta(1) , jpress-1, igpt) + & - fmajor(2,1,1) * k(jtemp, jeta(1)+1, jpress-1, igpt) + & - fmajor(1,2,1) * k(jtemp, jeta(1) , jpress , igpt) + & - fmajor(2,2,1) * k(jtemp, jeta(1)+1, jpress , igpt) ) + & - scaling(2) * & - ( fmajor(1,1,2) * k(jtemp+1, jeta(2) , jpress-1, igpt) + & - fmajor(2,1,2) * k(jtemp+1, jeta(2)+1, jpress-1, igpt) + & - fmajor(1,2,2) * k(jtemp+1, jeta(2) , jpress , igpt) + & - fmajor(2,2,2) * k(jtemp+1, jeta(2)+1, jpress , igpt) ) - end do - end function interpolate3D_byflav - + real(wp), dimension(2,2,2,ncol,nlay,nflav), intent(out) :: fmajor + !! Interpolation weights in pressure, eta, strat/trop + real(wp), dimension(2,2, ncol,nlay,nflav), intent(out) :: fminor + !! Interpolation fraction in eta, strat/trop + end subroutine interpolation + end interface + ! ------------------------------------------------------------------------------------------------------------------ + interface + subroutine compute_tau_absorption( & + ncol,nlay,nbnd,ngpt, & ! dimensions + ngas,nflav,neta,npres,ntemp, & + nminorlower, nminorklower, & ! number of minor contributors, total num absorption coeffs + nminorupper, nminorkupper, & + idx_h2o, & + gpoint_flavor, & + band_lims_gpt, & + kmajor, & + kminor_lower, & + kminor_upper, & + minor_limits_gpt_lower, & + minor_limits_gpt_upper, & + minor_scales_with_density_lower, & + minor_scales_with_density_upper, & + scale_by_complement_lower, & + scale_by_complement_upper, & + idx_minor_lower, & + idx_minor_upper, & + idx_minor_scaling_lower, & + idx_minor_scaling_upper, & + kminor_start_lower, & + kminor_start_upper, & + tropo, & + col_mix,fmajor,fminor, & + play,tlay,col_gas, & + jeta,jtemp,jpress, & + tau) bind(C, name="rrtmgp_compute_tau_absorption") + ! --------------------- + use mo_rte_kind, only : wp, wl + ! input dimensions + integer, intent(in) :: ncol,nlay,nbnd,ngpt !! array sizes + integer, intent(in) :: ngas,nflav,neta,npres,ntemp !! tables sizes + integer, intent(in) :: nminorlower, nminorklower,nminorupper, nminorkupper + !! table sizes + integer, intent(in) :: idx_h2o !! index of water vapor in col_gas + ! --------------------- + ! inputs from object + integer, dimension(2,ngpt), intent(in) :: gpoint_flavor + !! major gas flavor (pair) by upper/lower, g-point + integer, dimension(2,nbnd), intent(in) :: band_lims_gpt + !! beginning and ending g-point for each band + real(wp), dimension(ntemp,neta,npres+1,ngpt), intent(in) :: kmajor + !! absorption coefficient table - major gases + real(wp), dimension(ntemp,neta,nminorklower), intent(in) :: kminor_lower + !! absorption coefficient table - minor gases, lower atmosphere + real(wp), dimension(ntemp,neta,nminorkupper), intent(in) :: kminor_upper + !! absorption coefficient table - minor gases, upper atmosphere + integer, dimension(2,nminorlower), intent(in) :: minor_limits_gpt_lower + !! beginning and ending g-point for each minor gas + integer, dimension(2,nminorupper), intent(in) :: minor_limits_gpt_upper + logical(wl), dimension( nminorlower), intent(in) :: minor_scales_with_density_lower + !! generic treatment of minor gases - scales with density (e.g. continuum, collision-induced absorption)? + logical(wl), dimension( nminorupper), intent(in) :: minor_scales_with_density_upper + logical(wl), dimension( nminorlower), intent(in) :: scale_by_complement_lower + !! generic treatment of minor gases - scale by density (e.g. self-continuum) or complement? + logical(wl), dimension( nminorupper), intent(in) :: scale_by_complement_upper + integer, dimension( nminorlower), intent(in) :: idx_minor_lower + !! index of each minor gas in col_gas + integer, dimension( nminorupper), intent(in) :: idx_minor_upper + integer, dimension( nminorlower), intent(in) :: idx_minor_scaling_lower + !! for this minor gas, index of the "scaling gas" in col_gas + integer, dimension( nminorupper), intent(in) :: idx_minor_scaling_upper + integer, dimension( nminorlower), intent(in) :: kminor_start_lower + !! starting g-point index in minor gas absorption table + integer, dimension( nminorupper), intent(in) :: kminor_start_upper + logical(wl), dimension(ncol,nlay), intent(in) :: tropo + !! use upper- or lower-atmospheric tables? + ! --------------------- + ! inputs from profile or parent function + real(wp), dimension(2, ncol,nlay,nflav ), intent(in) :: col_mix + !! combination of major species's column amounts - computed in interpolation() + real(wp), dimension(2,2,2,ncol,nlay,nflav ), intent(in) :: fmajor + !! interpolation weights for major gases - computed in interpolation() + real(wp), dimension(2,2, ncol,nlay,nflav ), intent(in) :: fminor + !! interpolation weights for minor gases - computed in interpolation() + real(wp), dimension( ncol,nlay ), intent(in) :: play, tlay + !! input temperature and pressure + real(wp), dimension( ncol,nlay,0:ngas), intent(in) :: col_gas + !! input column gas amount (molecules/cm^2) + integer, dimension(2, ncol,nlay,nflav ), intent(in) :: jeta + !! interpolation indexes in eta - computed in interpolation() + integer, dimension( ncol,nlay ), intent(in) :: jtemp + !! interpolation indexes in temperature - computed in interpolation() + integer, dimension( ncol,nlay ), intent(in) :: jpress + !! interpolation indexes in pressure - computed in interpolation() + ! --------------------- + ! output - optical depth + real(wp), dimension(ncol,nlay,ngpt), intent(inout) :: tau !! aborption optional depth + end subroutine compute_tau_absorption + end interface + ! ------------------------------------------------------------------------------------------------------------------ + interface + subroutine compute_tau_rayleigh(ncol,nlay,nbnd,ngpt, & + ngas,nflav,neta,npres,ntemp, & + gpoint_flavor,band_lims_gpt, & + krayl, & + idx_h2o, col_dry,col_gas, & + fminor,jeta,tropo,jtemp, & + tau_rayleigh) bind(C, name="rrtmgp_compute_tau_rayleigh") + use mo_rte_kind, only : wp, wl + integer, intent(in ) :: ncol,nlay,nbnd,ngpt + !! input dimensions + integer, intent(in ) :: ngas,nflav,neta,npres,ntemp + !! table dimensions + integer, dimension(2,ngpt), intent(in ) :: gpoint_flavor + !! major gas flavor (pair) by upper/lower, g-point + integer, dimension(2,nbnd), intent(in ) :: band_lims_gpt + !! start and end g-point for each band + real(wp), dimension(ntemp,neta,ngpt,2), intent(in ) :: krayl + !! Rayleigh scattering coefficients + integer, intent(in ) :: idx_h2o + !! index of water vapor in col_gas + real(wp), dimension(ncol,nlay), intent(in ) :: col_dry + !! column amount of dry air + real(wp), dimension(ncol,nlay,0:ngas), intent(in ) :: col_gas + !! input column gas amount (molecules/cm^2) + real(wp), dimension(2,2,ncol,nlay,nflav), intent(in ) :: fminor + !! interpolation weights for major gases - computed in interpolation() + integer, dimension(2, ncol,nlay,nflav), intent(in ) :: jeta + !! interpolation indexes in eta - computed in interpolation() + logical(wl), dimension(ncol,nlay), intent(in ) :: tropo + !! use upper- or lower-atmospheric tables? + integer, dimension(ncol,nlay), intent(in ) :: jtemp + !! interpolation indexes in temperature - computed in interpolation() + ! outputs + real(wp), dimension(ncol,nlay,ngpt), intent(out) :: tau_rayleigh + !! Rayleigh optical depth + end subroutine compute_tau_rayleigh + end interface + ! ------------------------------------------------------------------------------------------------------------------ + interface + subroutine compute_Planck_source( & + ncol, nlay, nbnd, ngpt, & + nflav, neta, npres, ntemp, nPlanckTemp,& + tlay, tlev, tsfc, sfc_lay, & + fmajor, jeta, tropo, jtemp, jpress, & + gpoint_bands, band_lims_gpt, & + pfracin, temp_ref_min, totplnk_delta, totplnk, gpoint_flavor, & + sfc_src, lay_src, lev_src, sfc_source_Jac) bind(C, name="rrtmgp_compute_Planck_source") + use mo_rte_kind, only : wp, wl + integer, intent(in) :: ncol, nlay, nbnd, ngpt + !! input dimensions + integer, intent(in) :: nflav, neta, npres, ntemp, nPlanckTemp + !! table dimensions + real(wp), dimension(ncol,nlay ), intent(in) :: tlay !! temperature at layer centers (K) + real(wp), dimension(ncol,nlay+1), intent(in) :: tlev !! temperature at interfaces (K) + real(wp), dimension(ncol ), intent(in) :: tsfc !! surface temperture + integer, intent(in) :: sfc_lay !! index into surface layer + ! Interpolation variables + real(wp), dimension(2,2,2,ncol,nlay,nflav), intent(in) :: fmajor + !! interpolation weights for major gases - computed in interpolation() + integer, dimension(2, ncol,nlay,nflav), intent(in) :: jeta + !! interpolation indexes in eta - computed in interpolation() + logical(wl), dimension( ncol,nlay), intent(in) :: tropo + !! use upper- or lower-atmospheric tables? + integer, dimension( ncol,nlay), intent(in) :: jtemp, jpress + !! interpolation indexes in temperature and pressure - computed in interpolation() + ! Table-specific + integer, dimension(ngpt), intent(in) :: gpoint_bands !! band to which each g-point belongs + integer, dimension(2, nbnd), intent(in) :: band_lims_gpt !! start and end g-point for each band + real(wp), dimension(ntemp,neta,npres+1,ngpt), intent(in) :: pfracin !! Fraction of the Planck function in each g-point + real(wp), intent(in) :: temp_ref_min, totplnk_delta !! interpolation constants + real(wp), dimension(nPlanckTemp,nbnd), intent(in) :: totplnk !! Total Planck function by band at each temperature + integer, dimension(2,ngpt), intent(in) :: gpoint_flavor !! major gas flavor (pair) by upper/lower, g-point + + real(wp), dimension(ncol, ngpt), intent(out) :: sfc_src !! Planck emssion from the surface + real(wp), dimension(ncol,nlay, ngpt), intent(out) :: lay_src !! Planck emssion from layer centers + real(wp), dimension(ncol,nlay+1,ngpt), intent(out) :: lev_src !! Planck emission at layer boundaries + real(wp), dimension(ncol, ngpt), intent(out) :: sfc_source_Jac + !! Jacobian (derivative) of the surface Planck source with respect to surface temperature + end subroutine compute_Planck_source + end interface + ! ------------------------------------------------------------------------------------------------------------------ end module mo_gas_optics_rrtmgp_kernels diff --git a/reference/rrtmgp-kernels/tipuesearch/tipuesearch_content.js b/reference/rrtmgp-kernels/tipuesearch/tipuesearch_content.js index 7a9cd3dd7..1741e2cbd 100644 --- a/reference/rrtmgp-kernels/tipuesearch/tipuesearch_content.js +++ b/reference/rrtmgp-kernels/tipuesearch/tipuesearch_content.js @@ -1 +1 @@ -var tipuesearch = {"pages":[{"title":" RRTMGP kernels ","text":"RRTMGP kernels These pages document the low-level computational kernels used by RRTMGP. The listings below may not be exhaustive.\nTo see the full listings use the links at the top of the page.\nThere is a search bar in the top right. Return to the Documentation overview or the reference overview . Developer Info The RTE+RRTTMGP consortium","tags":"home","loc":"index.html"},{"title":"compute_Planck_source – RRTMGP kernels","text":"public subroutine compute_Planck_source(ncol, nlay, nbnd, ngpt, nflav, neta, npres, ntemp, nPlanckTemp, tlay, tlev, tsfc, sfc_lay, fmajor, jeta, tropo, jtemp, jpress, gpoint_bands, band_lims_gpt, pfracin, temp_ref_min, totplnk_delta, totplnk, gpoint_flavor, sfc_src, lay_src, lev_src_inc, lev_src_dec, sfc_source_Jac) bind(C, name=\"0\") Arguments Type Intent Optional Attributes Name integer, intent(in) :: ncol input dimensions integer, intent(in) :: nlay input dimensions integer, intent(in) :: nbnd input dimensions integer, intent(in) :: ngpt input dimensions integer, intent(in) :: nflav table dimensions integer, intent(in) :: neta table dimensions integer, intent(in) :: npres table dimensions integer, intent(in) :: ntemp table dimensions integer, intent(in) :: nPlanckTemp table dimensions real(kind=wp), intent(in), dimension(ncol,nlay ) :: tlay temperature at layer centers (K) real(kind=wp), intent(in), dimension(ncol,nlay+1) :: tlev temperature at interfaces (K) real(kind=wp), intent(in), dimension(ncol ) :: tsfc surface temperture integer, intent(in) :: sfc_lay index into surface layer real(kind=wp), intent(in), dimension(2,2,2,ncol,nlay,nflav) :: fmajor interpolation weights for major gases - computed in interpolation() integer, intent(in), dimension(2, ncol,nlay,nflav) :: jeta interpolation indexes in eta - computed in interpolation() logical(kind=wl), intent(in), dimension( ncol,nlay) :: tropo use upper- or lower-atmospheric tables? integer, intent(in), dimension( ncol,nlay) :: jtemp interpolation indexes in temperature and pressure - computed in interpolation() integer, intent(in), dimension( ncol,nlay) :: jpress interpolation indexes in temperature and pressure - computed in interpolation() integer, intent(in), dimension(ngpt) :: gpoint_bands band to which each g-point belongs integer, intent(in), dimension(2, nbnd) :: band_lims_gpt start and end g-point for each band real(kind=wp), intent(in), dimension(ntemp,neta,npres+1,ngpt) :: pfracin Fraction of the Planck function in each g-point real(kind=wp), intent(in) :: temp_ref_min interpolation constants real(kind=wp), intent(in) :: totplnk_delta interpolation constants real(kind=wp), intent(in), dimension(nPlanckTemp,nbnd) :: totplnk Total Planck function by band at each temperature integer, intent(in), dimension(2,ngpt) :: gpoint_flavor major gas flavor (pair) by upper/lower, g-point real(kind=wp), intent(out), dimension(ncol, ngpt) :: sfc_src Planck emssion from the surface real(kind=wp), intent(out), dimension(ncol,nlay,ngpt) :: lay_src Planck emssion from layer centers real(kind=wp), intent(out), dimension(ncol,nlay,ngpt) :: lev_src_inc Planck emission at layer boundaries, using spectral mapping in the direction of propagation real(kind=wp), intent(out), dimension(ncol,nlay,ngpt) :: lev_src_dec Planck emission at layer boundaries, using spectral mapping in the direction of propagation real(kind=wp), intent(out), dimension(ncol, ngpt) :: sfc_source_Jac Jacobian (derivative) of the surface Planck source with respect to surface temperature Contents None","tags":"","loc":"proc/compute_planck_source.html"},{"title":"compute_tau_absorption – RRTMGP kernels","text":"public subroutine compute_tau_absorption(ncol, nlay, nbnd, ngpt, ngas, nflav, neta, npres, ntemp, nminorlower, nminorklower, nminorupper, nminorkupper, idx_h2o, gpoint_flavor, band_lims_gpt, kmajor, kminor_lower, kminor_upper, minor_limits_gpt_lower, minor_limits_gpt_upper, minor_scales_with_density_lower, minor_scales_with_density_upper, scale_by_complement_lower, scale_by_complement_upper, idx_minor_lower, idx_minor_upper, idx_minor_scaling_lower, idx_minor_scaling_upper, kminor_start_lower, kminor_start_upper, tropo, col_mix, fmajor, fminor, play, tlay, col_gas, jeta, jtemp, jpress, tau) bind(C, name=\"0\") Compute minor and major species optical depth using pre-computed interpolation coefficients\n (jeta,jtemp,jpress) and weights (fmajor, fminor) Arguments Type Intent Optional Attributes Name integer, intent(in) :: ncol array sizes integer, intent(in) :: nlay array sizes integer, intent(in) :: nbnd array sizes integer, intent(in) :: ngpt array sizes integer, intent(in) :: ngas tables sizes integer, intent(in) :: nflav tables sizes integer, intent(in) :: neta tables sizes integer, intent(in) :: npres tables sizes integer, intent(in) :: ntemp tables sizes integer, intent(in) :: nminorlower table sizes integer, intent(in) :: nminorklower table sizes integer, intent(in) :: nminorupper table sizes integer, intent(in) :: nminorkupper table sizes integer, intent(in) :: idx_h2o index of water vapor in col_gas integer, intent(in), dimension(2,ngpt) :: gpoint_flavor major gas flavor (pair) by upper/lower, g-point integer, intent(in), dimension(2,nbnd) :: band_lims_gpt beginning and ending g-point for each band real(kind=wp), intent(in), dimension(ntemp,neta,npres+1,ngpt) :: kmajor absorption coefficient table - major gases real(kind=wp), intent(in), dimension(ntemp,neta,nminorklower) :: kminor_lower absorption coefficient table - minor gases, lower atmosphere real(kind=wp), intent(in), dimension(ntemp,neta,nminorkupper) :: kminor_upper absorption coefficient table - minor gases, upper atmosphere integer, intent(in), dimension(2,nminorlower) :: minor_limits_gpt_lower beginning and ending g-point for each minor gas integer, intent(in), dimension(2,nminorupper) :: minor_limits_gpt_upper logical(kind=wl), intent(in), dimension( nminorlower) :: minor_scales_with_density_lower generic treatment of minor gases - scales with density (e.g. continuum, collision-induced absorption)? logical(kind=wl), intent(in), dimension( nminorupper) :: minor_scales_with_density_upper logical(kind=wl), intent(in), dimension( nminorlower) :: scale_by_complement_lower generic treatment of minor gases - scale by density (e.g. self-continuum) or complement? logical(kind=wl), intent(in), dimension( nminorupper) :: scale_by_complement_upper integer, intent(in), dimension( nminorlower) :: idx_minor_lower index of each minor gas in col_gas integer, intent(in), dimension( nminorupper) :: idx_minor_upper integer, intent(in), dimension( nminorlower) :: idx_minor_scaling_lower for this minor gas, index of the \"scaling gas\" in col_gas integer, intent(in), dimension( nminorupper) :: idx_minor_scaling_upper integer, intent(in), dimension( nminorlower) :: kminor_start_lower starting g-point index in minor gas absorption table integer, intent(in), dimension( nminorupper) :: kminor_start_upper logical(kind=wl), intent(in), dimension(ncol,nlay) :: tropo use upper- or lower-atmospheric tables? real(kind=wp), intent(in), dimension(2, ncol,nlay,nflav ) :: col_mix combination of major species's column amounts - computed in interpolation() real(kind=wp), intent(in), dimension(2,2,2,ncol,nlay,nflav ) :: fmajor interpolation weights for major gases - computed in interpolation() real(kind=wp), intent(in), dimension(2,2, ncol,nlay,nflav ) :: fminor interpolation weights for minor gases - computed in interpolation() real(kind=wp), intent(in), dimension( ncol,nlay ) :: play input temperature and pressure real(kind=wp), intent(in), dimension( ncol,nlay ) :: tlay input temperature and pressure real(kind=wp), intent(in), dimension( ncol,nlay,0:ngas) :: col_gas input column gas amount (molecules/cm^2) integer, intent(in), dimension(2, ncol,nlay,nflav ) :: jeta interpolation indexes in eta - computed in interpolation() integer, intent(in), dimension( ncol,nlay ) :: jtemp interpolation indexes in temperature - computed in interpolation() integer, intent(in), dimension( ncol,nlay ) :: jpress interpolation indexes in pressure - computed in interpolation() real(kind=wp), intent(inout), dimension(ncol,nlay,ngpt) :: tau aborption optional depth Contents None","tags":"","loc":"proc/compute_tau_absorption.html"},{"title":"compute_tau_rayleigh – RRTMGP kernels","text":"public subroutine compute_tau_rayleigh(ncol, nlay, nbnd, ngpt, ngas, nflav, neta, npres, ntemp, gpoint_flavor, band_lims_gpt, krayl, idx_h2o, col_dry, col_gas, fminor, jeta, tropo, jtemp, tau_rayleigh) bind(C, name=\"0\") Arguments Type Intent Optional Attributes Name integer, intent(in) :: ncol input dimensions integer, intent(in) :: nlay input dimensions integer, intent(in) :: nbnd input dimensions integer, intent(in) :: ngpt input dimensions integer, intent(in) :: ngas table dimensions integer, intent(in) :: nflav table dimensions integer, intent(in) :: neta table dimensions integer, intent(in) :: npres table dimensions integer, intent(in) :: ntemp table dimensions integer, intent(in), dimension(2,ngpt) :: gpoint_flavor major gas flavor (pair) by upper/lower, g-point integer, intent(in), dimension(2,nbnd) :: band_lims_gpt start and end g-point for each band real(kind=wp), intent(in), dimension(ntemp,neta,ngpt,2) :: krayl Rayleigh scattering coefficients integer, intent(in) :: idx_h2o index of water vapor in col_gas real(kind=wp), intent(in), dimension(ncol,nlay) :: col_dry column amount of dry air real(kind=wp), intent(in), dimension(ncol,nlay,0:ngas) :: col_gas input column gas amount (molecules/cm^2) real(kind=wp), intent(in), dimension(2,2,ncol,nlay,nflav) :: fminor interpolation weights for major gases - computed in interpolation() integer, intent(in), dimension(2, ncol,nlay,nflav) :: jeta interpolation indexes in eta - computed in interpolation() logical(kind=wl), intent(in), dimension(ncol,nlay) :: tropo use upper- or lower-atmospheric tables? integer, intent(in), dimension(ncol,nlay) :: jtemp interpolation indexes in temperature - computed in interpolation() real(kind=wp), intent(out), dimension(ncol,nlay,ngpt) :: tau_rayleigh Rayleigh optical depth Contents None","tags":"","loc":"proc/compute_tau_rayleigh.html"},{"title":"interpolation – RRTMGP kernels","text":"public subroutine interpolation(ncol, nlay, ngas, nflav, neta, npres, ntemp, flavor, press_ref_log, temp_ref, press_ref_log_delta, temp_ref_min, temp_ref_delta, press_ref_trop_log, vmr_ref, play, tlay, col_gas, jtemp, fmajor, fminor, col_mix, tropo, jeta, jpress) bind(C, name=\"0\") Compute interpolation coefficients\nfor calculations of major optical depths, minor optical depths, Rayleigh,\nand Planck fractions Arguments Type Intent Optional Attributes Name integer, intent(in) :: ncol physical domain size integer, intent(in) :: nlay physical domain size integer, intent(in) :: ngas k-distribution table dimensions integer, intent(in) :: nflav k-distribution table dimensions integer, intent(in) :: neta k-distribution table dimensions integer, intent(in) :: npres k-distribution table dimensions integer, intent(in) :: ntemp k-distribution table dimensions integer, intent(in), dimension(2,nflav) :: flavor index into vmr_ref of major gases for each flavor real(kind=wp), intent(in), dimension(npres) :: press_ref_log log of pressure dimension in RRTMGP tables real(kind=wp), intent(in), dimension(ntemp) :: temp_ref temperature dimension in RRTMGP tables real(kind=wp), intent(in) :: press_ref_log_delta constants related to RRTMGP tables real(kind=wp), intent(in) :: temp_ref_min constants related to RRTMGP tables real(kind=wp), intent(in) :: temp_ref_delta constants related to RRTMGP tables real(kind=wp), intent(in) :: press_ref_trop_log constants related to RRTMGP tables real(kind=wp), intent(in), dimension(2,0:ngas,ntemp) :: vmr_ref reference volume mixing ratios used in compute \"binary species parameter\" eta real(kind=wp), intent(in), dimension(ncol,nlay) :: play input pressure (Pa?) and temperature (K) real(kind=wp), intent(in), dimension(ncol,nlay) :: tlay input pressure (Pa?) and temperature (K) real(kind=wp), intent(in), dimension(ncol,nlay,0:ngas) :: col_gas input column gas amount - molecules/cm^2 integer, intent(out), dimension(ncol,nlay) :: jtemp temperature and pressure interpolation indexes real(kind=wp), intent(out), dimension(2,2,2,ncol,nlay,nflav) :: fmajor Interpolation weights in pressure, eta, strat/trop real(kind=wp), intent(out), dimension(2,2, ncol,nlay,nflav) :: fminor Interpolation fraction in eta, strat/trop real(kind=wp), intent(out), dimension(2, ncol,nlay,nflav) :: col_mix combination of major species's column amounts (first index is strat/trop) logical(kind=wl), intent(out), dimension(ncol,nlay) :: tropo use lower (or upper) atmosphere tables integer, intent(out), dimension(2, ncol,nlay,nflav) :: jeta Index for binary species interpolation integer, intent(out), dimension(ncol,nlay) :: jpress temperature and pressure interpolation indexes Calls proc~~interpolation~~CallsGraph proc~interpolation interpolation float float proc~interpolation->float Help × Graph Key Nodes of different colours represent the following: Graph Key Subroutine Subroutine Function Function Interface Interface Unknown Procedure Type Unknown Procedure Type Program Program This Page's Entity This Page's Entity Solid arrows point from a procedure to one which it calls. Dashed \n arrows point from an interface to procedures which implement that interface.\n This could include the module procedures in a generic interface or the\n implementation in a submodule of an interface in a parent module. Contents None","tags":"","loc":"proc/interpolation.html"},{"title":"mo_gas_optics_rrtmgp_kernels – RRTMGP kernels","text":"Numeric calculations for gas optics. Absorption and Rayleigh optical depths, Planck source functions. Interpolation coefficients are computed, then used in subsequent routines. All applications will call compute_tau_absorption(); \n compute_tau_rayleigh() and/or compute_Planck_source() will be called depending on the \n configuration of the k-distribution. The details of the interpolation scheme are not particaulrly important as long as arrays including \n tables are passed consisently between kernels. Uses mo_rte_util_array mo_rte_kind module~~mo_gas_optics_rrtmgp_kernels~~UsesGraph module~mo_gas_optics_rrtmgp_kernels mo_gas_optics_rrtmgp_kernels mo_rte_util_array mo_rte_util_array module~mo_gas_optics_rrtmgp_kernels->mo_rte_util_array mo_rte_kind mo_rte_kind module~mo_gas_optics_rrtmgp_kernels->mo_rte_kind Help × Graph Key Nodes of different colours represent the following: Graph Key Module Module Submodule Submodule Subroutine Subroutine Function Function Program Program This Page's Entity This Page's Entity Solid arrows point from a submodule to the (sub)module which it is\n descended from. Dashed arrows point from a module or program unit to \n modules which it uses. Contents Subroutines compute_Planck_source compute_tau_absorption compute_tau_rayleigh interpolation Subroutines public subroutine compute_Planck_source (ncol, nlay, nbnd, ngpt, nflav, neta, npres, ntemp, nPlanckTemp, tlay, tlev, tsfc, sfc_lay, fmajor, jeta, tropo, jtemp, jpress, gpoint_bands, band_lims_gpt, pfracin, temp_ref_min, totplnk_delta, totplnk, gpoint_flavor, sfc_src, lay_src, lev_src_inc, lev_src_dec, sfc_source_Jac) bind(C, name=\"0\") Arguments Type Intent Optional Attributes Name integer, intent(in) :: ncol input dimensions integer, intent(in) :: nlay input dimensions integer, intent(in) :: nbnd input dimensions integer, intent(in) :: ngpt input dimensions integer, intent(in) :: nflav table dimensions integer, intent(in) :: neta table dimensions integer, intent(in) :: npres table dimensions integer, intent(in) :: ntemp table dimensions integer, intent(in) :: nPlanckTemp table dimensions real(kind=wp), intent(in), dimension(ncol,nlay ) :: tlay temperature at layer centers (K) real(kind=wp), intent(in), dimension(ncol,nlay+1) :: tlev temperature at interfaces (K) real(kind=wp), intent(in), dimension(ncol ) :: tsfc surface temperture integer, intent(in) :: sfc_lay index into surface layer real(kind=wp), intent(in), dimension(2,2,2,ncol,nlay,nflav) :: fmajor interpolation weights for major gases - computed in interpolation() integer, intent(in), dimension(2, ncol,nlay,nflav) :: jeta interpolation indexes in eta - computed in interpolation() logical(kind=wl), intent(in), dimension( ncol,nlay) :: tropo use upper- or lower-atmospheric tables? integer, intent(in), dimension( ncol,nlay) :: jtemp interpolation indexes in temperature and pressure - computed in interpolation() integer, intent(in), dimension( ncol,nlay) :: jpress interpolation indexes in temperature and pressure - computed in interpolation() integer, intent(in), dimension(ngpt) :: gpoint_bands band to which each g-point belongs integer, intent(in), dimension(2, nbnd) :: band_lims_gpt start and end g-point for each band real(kind=wp), intent(in), dimension(ntemp,neta,npres+1,ngpt) :: pfracin Fraction of the Planck function in each g-point real(kind=wp), intent(in) :: temp_ref_min interpolation constants real(kind=wp), intent(in) :: totplnk_delta interpolation constants real(kind=wp), intent(in), dimension(nPlanckTemp,nbnd) :: totplnk Total Planck function by band at each temperature integer, intent(in), dimension(2,ngpt) :: gpoint_flavor major gas flavor (pair) by upper/lower, g-point real(kind=wp), intent(out), dimension(ncol, ngpt) :: sfc_src Planck emssion from the surface real(kind=wp), intent(out), dimension(ncol,nlay,ngpt) :: lay_src Planck emssion from layer centers real(kind=wp), intent(out), dimension(ncol,nlay,ngpt) :: lev_src_inc Planck emission at layer boundaries, using spectral mapping in the direction of propagation real(kind=wp), intent(out), dimension(ncol,nlay,ngpt) :: lev_src_dec Planck emission at layer boundaries, using spectral mapping in the direction of propagation real(kind=wp), intent(out), dimension(ncol, ngpt) :: sfc_source_Jac Jacobian (derivative) of the surface Planck source with respect to surface temperature public subroutine compute_tau_absorption (ncol, nlay, nbnd, ngpt, ngas, nflav, neta, npres, ntemp, nminorlower, nminorklower, nminorupper, nminorkupper, idx_h2o, gpoint_flavor, band_lims_gpt, kmajor, kminor_lower, kminor_upper, minor_limits_gpt_lower, minor_limits_gpt_upper, minor_scales_with_density_lower, minor_scales_with_density_upper, scale_by_complement_lower, scale_by_complement_upper, idx_minor_lower, idx_minor_upper, idx_minor_scaling_lower, idx_minor_scaling_upper, kminor_start_lower, kminor_start_upper, tropo, col_mix, fmajor, fminor, play, tlay, col_gas, jeta, jtemp, jpress, tau) bind(C, name=\"0\") Compute minor and major species optical depth using pre-computed interpolation coefficients\n (jeta,jtemp,jpress) and weights (fmajor, fminor) Arguments Type Intent Optional Attributes Name integer, intent(in) :: ncol array sizes integer, intent(in) :: nlay array sizes integer, intent(in) :: nbnd array sizes integer, intent(in) :: ngpt array sizes integer, intent(in) :: ngas tables sizes integer, intent(in) :: nflav tables sizes integer, intent(in) :: neta tables sizes integer, intent(in) :: npres tables sizes integer, intent(in) :: ntemp tables sizes integer, intent(in) :: nminorlower table sizes integer, intent(in) :: nminorklower table sizes integer, intent(in) :: nminorupper table sizes integer, intent(in) :: nminorkupper table sizes integer, intent(in) :: idx_h2o index of water vapor in col_gas integer, intent(in), dimension(2,ngpt) :: gpoint_flavor major gas flavor (pair) by upper/lower, g-point integer, intent(in), dimension(2,nbnd) :: band_lims_gpt beginning and ending g-point for each band real(kind=wp), intent(in), dimension(ntemp,neta,npres+1,ngpt) :: kmajor absorption coefficient table - major gases real(kind=wp), intent(in), dimension(ntemp,neta,nminorklower) :: kminor_lower absorption coefficient table - minor gases, lower atmosphere real(kind=wp), intent(in), dimension(ntemp,neta,nminorkupper) :: kminor_upper absorption coefficient table - minor gases, upper atmosphere integer, intent(in), dimension(2,nminorlower) :: minor_limits_gpt_lower beginning and ending g-point for each minor gas integer, intent(in), dimension(2,nminorupper) :: minor_limits_gpt_upper logical(kind=wl), intent(in), dimension( nminorlower) :: minor_scales_with_density_lower generic treatment of minor gases - scales with density (e.g. continuum, collision-induced absorption)? logical(kind=wl), intent(in), dimension( nminorupper) :: minor_scales_with_density_upper logical(kind=wl), intent(in), dimension( nminorlower) :: scale_by_complement_lower generic treatment of minor gases - scale by density (e.g. self-continuum) or complement? logical(kind=wl), intent(in), dimension( nminorupper) :: scale_by_complement_upper integer, intent(in), dimension( nminorlower) :: idx_minor_lower index of each minor gas in col_gas integer, intent(in), dimension( nminorupper) :: idx_minor_upper integer, intent(in), dimension( nminorlower) :: idx_minor_scaling_lower for this minor gas, index of the \"scaling gas\" in col_gas integer, intent(in), dimension( nminorupper) :: idx_minor_scaling_upper integer, intent(in), dimension( nminorlower) :: kminor_start_lower starting g-point index in minor gas absorption table integer, intent(in), dimension( nminorupper) :: kminor_start_upper logical(kind=wl), intent(in), dimension(ncol,nlay) :: tropo use upper- or lower-atmospheric tables? real(kind=wp), intent(in), dimension(2, ncol,nlay,nflav ) :: col_mix combination of major species's column amounts - computed in interpolation() real(kind=wp), intent(in), dimension(2,2,2,ncol,nlay,nflav ) :: fmajor interpolation weights for major gases - computed in interpolation() real(kind=wp), intent(in), dimension(2,2, ncol,nlay,nflav ) :: fminor interpolation weights for minor gases - computed in interpolation() real(kind=wp), intent(in), dimension( ncol,nlay ) :: play input temperature and pressure real(kind=wp), intent(in), dimension( ncol,nlay ) :: tlay input temperature and pressure real(kind=wp), intent(in), dimension( ncol,nlay,0:ngas) :: col_gas input column gas amount (molecules/cm^2) integer, intent(in), dimension(2, ncol,nlay,nflav ) :: jeta interpolation indexes in eta - computed in interpolation() integer, intent(in), dimension( ncol,nlay ) :: jtemp interpolation indexes in temperature - computed in interpolation() integer, intent(in), dimension( ncol,nlay ) :: jpress interpolation indexes in pressure - computed in interpolation() real(kind=wp), intent(inout), dimension(ncol,nlay,ngpt) :: tau aborption optional depth public subroutine compute_tau_rayleigh (ncol, nlay, nbnd, ngpt, ngas, nflav, neta, npres, ntemp, gpoint_flavor, band_lims_gpt, krayl, idx_h2o, col_dry, col_gas, fminor, jeta, tropo, jtemp, tau_rayleigh) bind(C, name=\"0\") Arguments Type Intent Optional Attributes Name integer, intent(in) :: ncol input dimensions integer, intent(in) :: nlay input dimensions integer, intent(in) :: nbnd input dimensions integer, intent(in) :: ngpt input dimensions integer, intent(in) :: ngas table dimensions integer, intent(in) :: nflav table dimensions integer, intent(in) :: neta table dimensions integer, intent(in) :: npres table dimensions integer, intent(in) :: ntemp table dimensions integer, intent(in), dimension(2,ngpt) :: gpoint_flavor major gas flavor (pair) by upper/lower, g-point integer, intent(in), dimension(2,nbnd) :: band_lims_gpt start and end g-point for each band real(kind=wp), intent(in), dimension(ntemp,neta,ngpt,2) :: krayl Rayleigh scattering coefficients integer, intent(in) :: idx_h2o index of water vapor in col_gas real(kind=wp), intent(in), dimension(ncol,nlay) :: col_dry column amount of dry air real(kind=wp), intent(in), dimension(ncol,nlay,0:ngas) :: col_gas input column gas amount (molecules/cm^2) real(kind=wp), intent(in), dimension(2,2,ncol,nlay,nflav) :: fminor interpolation weights for major gases - computed in interpolation() integer, intent(in), dimension(2, ncol,nlay,nflav) :: jeta interpolation indexes in eta - computed in interpolation() logical(kind=wl), intent(in), dimension(ncol,nlay) :: tropo use upper- or lower-atmospheric tables? integer, intent(in), dimension(ncol,nlay) :: jtemp interpolation indexes in temperature - computed in interpolation() real(kind=wp), intent(out), dimension(ncol,nlay,ngpt) :: tau_rayleigh Rayleigh optical depth public subroutine interpolation (ncol, nlay, ngas, nflav, neta, npres, ntemp, flavor, press_ref_log, temp_ref, press_ref_log_delta, temp_ref_min, temp_ref_delta, press_ref_trop_log, vmr_ref, play, tlay, col_gas, jtemp, fmajor, fminor, col_mix, tropo, jeta, jpress) bind(C, name=\"0\") Compute interpolation coefficients\nfor calculations of major optical depths, minor optical depths, Rayleigh,\nand Planck fractions Arguments Type Intent Optional Attributes Name integer, intent(in) :: ncol physical domain size integer, intent(in) :: nlay physical domain size integer, intent(in) :: ngas k-distribution table dimensions integer, intent(in) :: nflav k-distribution table dimensions integer, intent(in) :: neta k-distribution table dimensions integer, intent(in) :: npres k-distribution table dimensions integer, intent(in) :: ntemp k-distribution table dimensions integer, intent(in), dimension(2,nflav) :: flavor index into vmr_ref of major gases for each flavor real(kind=wp), intent(in), dimension(npres) :: press_ref_log log of pressure dimension in RRTMGP tables real(kind=wp), intent(in), dimension(ntemp) :: temp_ref temperature dimension in RRTMGP tables real(kind=wp), intent(in) :: press_ref_log_delta constants related to RRTMGP tables real(kind=wp), intent(in) :: temp_ref_min constants related to RRTMGP tables real(kind=wp), intent(in) :: temp_ref_delta constants related to RRTMGP tables real(kind=wp), intent(in) :: press_ref_trop_log constants related to RRTMGP tables real(kind=wp), intent(in), dimension(2,0:ngas,ntemp) :: vmr_ref reference volume mixing ratios used in compute \"binary species parameter\" eta real(kind=wp), intent(in), dimension(ncol,nlay) :: play input pressure (Pa?) and temperature (K) real(kind=wp), intent(in), dimension(ncol,nlay) :: tlay input pressure (Pa?) and temperature (K) real(kind=wp), intent(in), dimension(ncol,nlay,0:ngas) :: col_gas input column gas amount - molecules/cm^2 integer, intent(out), dimension(ncol,nlay) :: jtemp temperature and pressure interpolation indexes real(kind=wp), intent(out), dimension(2,2,2,ncol,nlay,nflav) :: fmajor Interpolation weights in pressure, eta, strat/trop real(kind=wp), intent(out), dimension(2,2, ncol,nlay,nflav) :: fminor Interpolation fraction in eta, strat/trop real(kind=wp), intent(out), dimension(2, ncol,nlay,nflav) :: col_mix combination of major species's column amounts (first index is strat/trop) logical(kind=wl), intent(out), dimension(ncol,nlay) :: tropo use lower (or upper) atmosphere tables integer, intent(out), dimension(2, ncol,nlay,nflav) :: jeta Index for binary species interpolation integer, intent(out), dimension(ncol,nlay) :: jpress temperature and pressure interpolation indexes","tags":"","loc":"module/mo_gas_optics_rrtmgp_kernels.html"},{"title":"mo_gas_optics_rrtmgp_kernels.F90 – RRTMGP kernels","text":"Contents Modules mo_gas_optics_rrtmgp_kernels Source Code mo_gas_optics_rrtmgp_kernels.F90 Source Code ! This code is part of ! RRTM for GCM Applications - Parallel (RRTMGP) ! ! Eli Mlawer and Robert Pincus ! Andre Wehe and Jennifer Delamere ! email: rrtmgp@aer.com ! ! Copyright 2015-, Atmospheric and Environmental Research, ! Regents of the University of Colorado, Trustees of Columbia University. All right reserved. ! ! Use and duplication is permitted under the terms of the ! BSD 3-clause license, see http://opensource.org/licenses/BSD-3-Clause ! ------------------------------------------------------------------------------------------------- !> !> ## Numeric calculations for gas optics. Absorption and Rayleigh optical depths, Planck source functions. !> !> - Interpolation coefficients are computed, then used in subsequent routines. !> - All applications will call compute_tau_absorption(); !> compute_tau_rayleigh() and/or compute_Planck_source() will be called depending on the !> configuration of the k-distribution. !> - The details of the interpolation scheme are not particaulrly important as long as arrays including !> tables are passed consisently between kernels. !> ! ------------------------------------------------------------------------------------------------- module mo_gas_optics_rrtmgp_kernels use mo_rte_kind , only : wp , wl use mo_rte_util_array , only : zero_array implicit none private public :: interpolation , compute_tau_absorption , compute_tau_rayleigh , compute_Planck_source contains ! -------------------------------------------------------------------------------------- !> Compute interpolation coefficients !> for calculations of major optical depths, minor optical depths, Rayleigh, !> and Planck fractions subroutine interpolation ( & ncol , nlay , ngas , nflav , neta , npres , ntemp , & flavor , & press_ref_log , temp_ref , press_ref_log_delta , & temp_ref_min , temp_ref_delta , press_ref_trop_log , & vmr_ref , & play , tlay , col_gas , & jtemp , fmajor , fminor , col_mix , tropo , jeta , jpress ) bind ( C , name = \"rrtmgp_interpolation\" ) ! input dimensions integer , intent ( in ) :: ncol , nlay !! physical domain size integer , intent ( in ) :: ngas , nflav , neta , npres , ntemp !! k-distribution table dimensions integer , dimension ( 2 , nflav ), intent ( in ) :: flavor !! index into vmr_ref of major gases for each flavor real ( wp ), dimension ( npres ), intent ( in ) :: press_ref_log !! log of pressure dimension in RRTMGP tables real ( wp ), dimension ( ntemp ), intent ( in ) :: temp_ref !! temperature dimension in RRTMGP tables real ( wp ), intent ( in ) :: press_ref_log_delta , & temp_ref_min , temp_ref_delta , & press_ref_trop_log !! constants related to RRTMGP tables real ( wp ), dimension ( 2 , 0 : ngas , ntemp ), intent ( in ) :: vmr_ref !! reference volume mixing ratios used in compute \"binary species parameter\" eta ! inputs from profile or parent function real ( wp ), dimension ( ncol , nlay ), intent ( in ) :: play , tlay !! input pressure (Pa?) and temperature (K) real ( wp ), dimension ( ncol , nlay , 0 : ngas ), intent ( in ) :: col_gas !! input column gas amount - molecules/cm^2 ! outputs integer , dimension ( ncol , nlay ), intent ( out ) :: jtemp , jpress !! temperature and pressure interpolation indexes logical ( wl ), dimension ( ncol , nlay ), intent ( out ) :: tropo !! use lower (or upper) atmosphere tables integer , dimension ( 2 , ncol , nlay , nflav ), intent ( out ) :: jeta !! Index for binary species interpolation #if !defined(__INTEL_LLVM_COMPILER) && __INTEL_COMPILER >= 1910 ! A performance-hitting workaround for the vectorization problem reported in ! https://github.com/earth-system-radiation/rte-rrtmgp/issues/159 ! The known affected compilers are Intel Fortran Compiler Classic ! 2021.4, 2021.5 and 2022.1. We do not limit the workaround to these ! versions because it is not clear when the compiler bug will be fixed, see ! https://community.intel.com/t5/Intel-Fortran-Compiler/Compiler-vectorization-bug/m-p/1362591. ! We, however, limit the workaround to the Classic versions only since the ! problem is not confirmed for the Intel Fortran Compiler oneAPI (a.k.a ! 'ifx'), which does not mean there is none though. real ( wp ), dimension (:, :, :, :), intent ( out ) :: col_mix #else real ( wp ), dimension ( 2 , ncol , nlay , nflav ), intent ( out ) :: col_mix !! combination of major species's column amounts (first index is strat/trop) #endif real ( wp ), dimension ( 2 , 2 , 2 , ncol , nlay , nflav ), intent ( out ) :: fmajor !! Interpolation weights in pressure, eta, strat/trop real ( wp ), dimension ( 2 , 2 , ncol , nlay , nflav ), intent ( out ) :: fminor !! Interpolation fraction in eta, strat/trop ! ----------------- ! local real ( wp ), dimension ( ncol , nlay ) :: ftemp , fpress ! interpolation fraction for temperature, pressure real ( wp ) :: locpress ! needed to find location in pressure grid real ( wp ) :: ratio_eta_half ! ratio of vmrs of major species that defines eta=0.5 ! for given flavor and reference temperature level real ( wp ) :: eta , feta ! binary_species_parameter, interpolation variable for eta real ( wp ) :: loceta ! needed to find location in eta grid real ( wp ) :: ftemp_term ! ----------------- ! local indexes integer :: icol , ilay , iflav , igases ( 2 ), itropo , itemp do ilay = 1 , nlay do icol = 1 , ncol ! index and factor for temperature interpolation jtemp ( icol , ilay ) = int (( tlay ( icol , ilay ) - ( temp_ref_min - temp_ref_delta )) / temp_ref_delta ) jtemp ( icol , ilay ) = min ( ntemp - 1 , max ( 1 , jtemp ( icol , ilay ))) ! limit the index range ftemp ( icol , ilay ) = ( tlay ( icol , ilay ) - temp_ref ( jtemp ( icol , ilay ))) / temp_ref_delta ! index and factor for pressure interpolation locpress = 1._wp + ( log ( play ( icol , ilay )) - press_ref_log ( 1 )) / press_ref_log_delta jpress ( icol , ilay ) = min ( npres - 1 , max ( 1 , int ( locpress ))) fpress ( icol , ilay ) = locpress - float ( jpress ( icol , ilay )) ! determine if in lower or upper part of atmosphere tropo ( icol , ilay ) = log ( play ( icol , ilay )) > press_ref_trop_log end do end do do iflav = 1 , nflav igases (:) = flavor (:, iflav ) do ilay = 1 , nlay do icol = 1 , ncol ! itropo = 1 lower atmosphere; itropo = 2 upper atmosphere itropo = merge ( 1 , 2 , tropo ( icol , ilay )) ! loop over implemented combinations of major species do itemp = 1 , 2 ! compute interpolation fractions needed for lower, then upper reference temperature level ! compute binary species parameter (eta) for flavor and temperature and ! associated interpolation index and factors ratio_eta_half = vmr_ref ( itropo , igases ( 1 ),( jtemp ( icol , ilay ) + itemp - 1 )) / & vmr_ref ( itropo , igases ( 2 ),( jtemp ( icol , ilay ) + itemp - 1 )) col_mix ( itemp , icol , ilay , iflav ) = col_gas ( icol , ilay , igases ( 1 )) + ratio_eta_half * col_gas ( icol , ilay , igases ( 2 )) ! Keep this commented lines. Fortran does allow for ! substantial optimizations and in this merge cases may ! happen that all expressions are evaluated and so create ! a division by zero. In the if construct this should be ! save. Merge is the way to do it in general inside of ! loops, but sometimes it may not work. ! ! eta = merge(col_gas(icol,ilay,igases(1)) / col_mix(itemp,icol,ilay,iflav), 0.5_wp, & ! col_mix(itemp,icol,ilay,iflav) > 2._wp * tiny(col_mix)) ! ! In essence: do not turn it back to merge(...)! if ( col_mix ( itemp , icol , ilay , iflav ) > 2._wp * tiny ( col_mix )) then eta = col_gas ( icol , ilay , igases ( 1 )) / col_mix ( itemp , icol , ilay , iflav ) else eta = 0.5_wp endif loceta = eta * float ( neta - 1 ) jeta ( itemp , icol , ilay , iflav ) = min ( int ( loceta ) + 1 , neta - 1 ) feta = mod ( loceta , 1.0_wp ) ! compute interpolation fractions needed for minor species ! ftemp_term = (1._wp-ftemp(icol,ilay)) for itemp = 1, ftemp(icol,ilay) for itemp=2 ftemp_term = ( real ( 2 - itemp , wp ) + real ( 2 * itemp - 3 , wp ) * ftemp ( icol , ilay )) fminor ( 1 , itemp , icol , ilay , iflav ) = ( 1._wp - feta ) * ftemp_term fminor ( 2 , itemp , icol , ilay , iflav ) = feta * ftemp_term ! compute interpolation fractions needed for major species fmajor ( 1 , 1 , itemp , icol , ilay , iflav ) = ( 1._wp - fpress ( icol , ilay )) * fminor ( 1 , itemp , icol , ilay , iflav ) fmajor ( 2 , 1 , itemp , icol , ilay , iflav ) = ( 1._wp - fpress ( icol , ilay )) * fminor ( 2 , itemp , icol , ilay , iflav ) fmajor ( 1 , 2 , itemp , icol , ilay , iflav ) = fpress ( icol , ilay ) * fminor ( 1 , itemp , icol , ilay , iflav ) fmajor ( 2 , 2 , itemp , icol , ilay , iflav ) = fpress ( icol , ilay ) * fminor ( 2 , itemp , icol , ilay , iflav ) end do ! reference temperatures end do ! icol end do ! ilay end do ! iflav end subroutine interpolation ! -------------------------------------------------------------------------------------- ! !> Compute minor and major species optical depth using pre-computed interpolation coefficients !> (jeta,jtemp,jpress) and weights (fmajor, fminor) ! subroutine compute_tau_absorption ( & ncol , nlay , nbnd , ngpt , & ! dimensions ngas , nflav , neta , npres , ntemp , & nminorlower , nminorklower , & ! number of minor contributors, total num absorption coeffs nminorupper , nminorkupper , & idx_h2o , & gpoint_flavor , & band_lims_gpt , & kmajor , & kminor_lower , & kminor_upper , & minor_limits_gpt_lower , & minor_limits_gpt_upper , & minor_scales_with_density_lower , & minor_scales_with_density_upper , & scale_by_complement_lower , & scale_by_complement_upper , & idx_minor_lower , & idx_minor_upper , & idx_minor_scaling_lower , & idx_minor_scaling_upper , & kminor_start_lower , & kminor_start_upper , & tropo , & col_mix , fmajor , fminor , & play , tlay , col_gas , & jeta , jtemp , jpress , & tau ) bind ( C , name = \"rrtmgp_compute_tau_absorption\" ) ! --------------------- ! input dimensions integer , intent ( in ) :: ncol , nlay , nbnd , ngpt !! array sizes integer , intent ( in ) :: ngas , nflav , neta , npres , ntemp !! tables sizes integer , intent ( in ) :: nminorlower , nminorklower , nminorupper , nminorkupper !! table sizes integer , intent ( in ) :: idx_h2o !! index of water vapor in col_gas ! --------------------- ! inputs from object integer , dimension ( 2 , ngpt ), intent ( in ) :: gpoint_flavor !! major gas flavor (pair) by upper/lower, g-point integer , dimension ( 2 , nbnd ), intent ( in ) :: band_lims_gpt !! beginning and ending g-point for each band real ( wp ), dimension ( ntemp , neta , npres + 1 , ngpt ), intent ( in ) :: kmajor !! absorption coefficient table - major gases real ( wp ), dimension ( ntemp , neta , nminorklower ), intent ( in ) :: kminor_lower !! absorption coefficient table - minor gases, lower atmosphere real ( wp ), dimension ( ntemp , neta , nminorkupper ), intent ( in ) :: kminor_upper !! absorption coefficient table - minor gases, upper atmosphere integer , dimension ( 2 , nminorlower ), intent ( in ) :: minor_limits_gpt_lower !! beginning and ending g-point for each minor gas integer , dimension ( 2 , nminorupper ), intent ( in ) :: minor_limits_gpt_upper logical ( wl ), dimension ( nminorlower ), intent ( in ) :: minor_scales_with_density_lower !! generic treatment of minor gases - scales with density (e.g. continuum, collision-induced absorption)? logical ( wl ), dimension ( nminorupper ), intent ( in ) :: minor_scales_with_density_upper logical ( wl ), dimension ( nminorlower ), intent ( in ) :: scale_by_complement_lower !! generic treatment of minor gases - scale by density (e.g. self-continuum) or complement? logical ( wl ), dimension ( nminorupper ), intent ( in ) :: scale_by_complement_upper integer , dimension ( nminorlower ), intent ( in ) :: idx_minor_lower !! index of each minor gas in col_gas integer , dimension ( nminorupper ), intent ( in ) :: idx_minor_upper integer , dimension ( nminorlower ), intent ( in ) :: idx_minor_scaling_lower !! for this minor gas, index of the \"scaling gas\" in col_gas integer , dimension ( nminorupper ), intent ( in ) :: idx_minor_scaling_upper integer , dimension ( nminorlower ), intent ( in ) :: kminor_start_lower !! starting g-point index in minor gas absorption table integer , dimension ( nminorupper ), intent ( in ) :: kminor_start_upper logical ( wl ), dimension ( ncol , nlay ), intent ( in ) :: tropo !! use upper- or lower-atmospheric tables? ! --------------------- ! inputs from profile or parent function real ( wp ), dimension ( 2 , ncol , nlay , nflav ), intent ( in ) :: col_mix !! combination of major species's column amounts - computed in interpolation() real ( wp ), dimension ( 2 , 2 , 2 , ncol , nlay , nflav ), intent ( in ) :: fmajor !! interpolation weights for major gases - computed in interpolation() real ( wp ), dimension ( 2 , 2 , ncol , nlay , nflav ), intent ( in ) :: fminor !! interpolation weights for minor gases - computed in interpolation() real ( wp ), dimension ( ncol , nlay ), intent ( in ) :: play , tlay !! input temperature and pressure real ( wp ), dimension ( ncol , nlay , 0 : ngas ), intent ( in ) :: col_gas !! input column gas amount (molecules/cm^2) integer , dimension ( 2 , ncol , nlay , nflav ), intent ( in ) :: jeta !! interpolation indexes in eta - computed in interpolation() integer , dimension ( ncol , nlay ), intent ( in ) :: jtemp !! interpolation indexes in temperature - computed in interpolation() integer , dimension ( ncol , nlay ), intent ( in ) :: jpress !! interpolation indexes in pressure - computed in interpolation() ! --------------------- ! output - optical depth real ( wp ), dimension ( ncol , nlay , ngpt ), intent ( inout ) :: tau !! aborption optional depth ! --------------------- ! Local variables ! logical :: top_at_1 integer , dimension ( ncol , 2 ) :: itropo_lower , itropo_upper ! ---------------------------------------------------------------- ! --------------------- ! Layer limits of upper, lower atmospheres ! --------------------- top_at_1 = play ( 1 , 1 ) < play ( 1 , nlay ) if ( top_at_1 ) then itropo_lower (:, 1 ) = minloc ( play , dim = 2 , mask = tropo ) itropo_lower (:, 2 ) = nlay itropo_upper (:, 1 ) = 1 itropo_upper (:, 2 ) = maxloc ( play , dim = 2 , mask = (. not . tropo )) else itropo_lower (:, 1 ) = 1 itropo_lower (:, 2 ) = minloc ( play , dim = 2 , mask = tropo ) itropo_upper (:, 1 ) = maxloc ( play , dim = 2 , mask = (. not . tropo )) itropo_upper (:, 2 ) = nlay end if ! --------------------- ! Major Species ! --------------------- call gas_optical_depths_major ( & ncol , nlay , nbnd , ngpt , & ! dimensions nflav , neta , npres , ntemp , & gpoint_flavor , & band_lims_gpt , & kmajor , & col_mix , fmajor , & jeta , tropo , jtemp , jpress , & tau ) ! --------------------- ! Minor Species - lower ! --------------------- call gas_optical_depths_minor ( & ncol , nlay , ngpt , & ! dimensions ngas , nflav , ntemp , neta , & nminorlower , nminorklower , & idx_h2o , & gpoint_flavor ( 1 ,:), & kminor_lower , & minor_limits_gpt_lower , & minor_scales_with_density_lower , & scale_by_complement_lower , & idx_minor_lower , & idx_minor_scaling_lower , & kminor_start_lower , & play , tlay , & col_gas , fminor , jeta , & itropo_lower , jtemp , & tau ) ! --------------------- ! Minor Species - upper ! --------------------- call gas_optical_depths_minor ( & ncol , nlay , ngpt , & ! dimensions ngas , nflav , ntemp , neta , & nminorupper , nminorkupper , & idx_h2o , & gpoint_flavor ( 2 ,:), & kminor_upper , & minor_limits_gpt_upper , & minor_scales_with_density_upper , & scale_by_complement_upper , & idx_minor_upper , & idx_minor_scaling_upper , & kminor_start_upper , & play , tlay , & col_gas , fminor , jeta , & itropo_upper , jtemp , & tau ) end subroutine compute_tau_absorption ! -------------------------------------------------------------------------------------- ! -------------------------------------------------------------------------------------- ! ! compute minor species optical depths ! subroutine gas_optical_depths_major ( ncol , nlay , nbnd , ngpt ,& nflav , neta , npres , ntemp , & ! dimensions gpoint_flavor , band_lims_gpt , & ! inputs from object kmajor , & col_mix , fmajor , & jeta , tropo , jtemp , jpress , & ! local input tau ) ! input dimensions integer , intent ( in ) :: ncol , nlay , nbnd , ngpt , nflav , neta , npres , ntemp ! dimensions ! inputs from object integer , dimension ( 2 , ngpt ), intent ( in ) :: gpoint_flavor integer , dimension ( 2 , nbnd ), intent ( in ) :: band_lims_gpt ! start and end g-point for each band real ( wp ), dimension ( ntemp , neta , npres + 1 , ngpt ), intent ( in ) :: kmajor ! inputs from profile or parent function real ( wp ), dimension ( 2 , ncol , nlay , nflav ), intent ( in ) :: col_mix real ( wp ), dimension ( 2 , 2 , 2 , ncol , nlay , nflav ), intent ( in ) :: fmajor integer , dimension ( 2 , ncol , nlay , nflav ), intent ( in ) :: jeta logical ( wl ), dimension ( ncol , nlay ), intent ( in ) :: tropo integer , dimension ( ncol , nlay ), intent ( in ) :: jtemp , jpress ! outputs real ( wp ), dimension ( ncol , nlay , ngpt ), intent ( inout ) :: tau ! ----------------- ! local variables real ( wp ) :: tau_major ( ngpt ) ! major species optical depth ! local index integer :: icol , ilay , iflav , ibnd , itropo integer :: gptS , gptE ! optical depth calculation for major species do ibnd = 1 , nbnd gptS = band_lims_gpt ( 1 , ibnd ) gptE = band_lims_gpt ( 2 , ibnd ) do ilay = 1 , nlay do icol = 1 , ncol ! itropo = 1 lower atmosphere; itropo = 2 upper atmosphere itropo = merge ( 1 , 2 , tropo ( icol , ilay )) iflav = gpoint_flavor ( itropo , gptS ) !eta interpolation depends on band's flavor tau_major ( gptS : gptE ) = & ! interpolation in temperature, pressure, and eta interpolate3D_byflav ( col_mix (:, icol , ilay , iflav ), & fmajor (:,:,:, icol , ilay , iflav ), kmajor , & band_lims_gpt ( 1 , ibnd ), band_lims_gpt ( 2 , ibnd ), & jeta (:, icol , ilay , iflav ), jtemp ( icol , ilay ), jpress ( icol , ilay ) + itropo ) tau ( icol , ilay , gptS : gptE ) = tau ( icol , ilay , gptS : gptE ) + tau_major ( gptS : gptE ) end do end do end do end subroutine gas_optical_depths_major ! ---------------------------------------------------------- ! ! compute minor species optical depths ! subroutine gas_optical_depths_minor ( ncol , nlay , ngpt , & ngas , nflav , ntemp , neta , & nminor , nminork , & idx_h2o , & gpt_flv , & kminor , & minor_limits_gpt , & minor_scales_with_density , & scale_by_complement , & idx_minor , idx_minor_scaling , & kminor_start , & play , tlay , & col_gas , fminor , jeta , & layer_limits , jtemp , & tau ) integer , intent ( in ) :: ncol , nlay , ngpt integer , intent ( in ) :: ngas , nflav integer , intent ( in ) :: ntemp , neta , nminor , nminork integer , intent ( in ) :: idx_h2o integer , dimension ( ngpt ), intent ( in ) :: gpt_flv real ( wp ), dimension ( ntemp , neta , nminork ), intent ( in ) :: kminor integer , dimension ( 2 , nminor ), intent ( in ) :: minor_limits_gpt logical ( wl ), dimension ( nminor ), intent ( in ) :: minor_scales_with_density logical ( wl ), dimension ( nminor ), intent ( in ) :: scale_by_complement integer , dimension ( nminor ), intent ( in ) :: kminor_start integer , dimension ( nminor ), intent ( in ) :: idx_minor , idx_minor_scaling real ( wp ), dimension ( ncol , nlay ), intent ( in ) :: play , tlay real ( wp ), dimension ( ncol , nlay , 0 : ngas ), intent ( in ) :: col_gas real ( wp ), dimension ( 2 , 2 , ncol , nlay , nflav ), intent ( in ) :: fminor integer , dimension ( 2 , ncol , nlay , nflav ), intent ( in ) :: jeta integer , dimension ( ncol , 2 ), intent ( in ) :: layer_limits integer , dimension ( ncol , nlay ), intent ( in ) :: jtemp real ( wp ), dimension ( ncol , nlay , ngpt ), intent ( inout ) :: tau ! ----------------- ! local variables real ( wp ), parameter :: PaTohPa = 0.01_wp real ( wp ) :: vmr_fact , dry_fact ! conversion from column abundance to dry vol. mixing ratio; real ( wp ) :: scaling ! optical depth integer :: icol , ilay , iflav , imnr integer :: gptS , gptE real ( wp ), dimension ( ngpt ) :: tau_minor ! ----------------- ! ! Guard against layer limits being 0 -- that means don't do anything i.e. there are no ! layers with pressures in the upper or lower atmosphere respectively ! First check skips the routine entirely if all columns are out of bounds... ! if ( any ( layer_limits (:, 1 ) > 0 )) then do imnr = 1 , size ( scale_by_complement , dim = 1 ) ! loop over minor absorbers in each band do icol = 1 , ncol ! ! This check skips individual columns with no pressures in range ! if ( layer_limits ( icol , 1 ) > 0 ) then do ilay = layer_limits ( icol , 1 ), layer_limits ( icol , 2 ) ! ! Scaling of minor gas absortion coefficient begins with column amount of minor gas ! scaling = col_gas ( icol , ilay , idx_minor ( imnr )) ! ! Density scaling (e.g. for h2o continuum, collision-induced absorption) ! if ( minor_scales_with_density ( imnr )) then ! ! NOTE: P needed in hPa to properly handle density scaling. ! scaling = scaling * ( PaTohPa * play ( icol , ilay ) / tlay ( icol , ilay )) if ( idx_minor_scaling ( imnr ) > 0 ) then ! there is a second gas that affects this gas's absorption vmr_fact = 1._wp / col_gas ( icol , ilay , 0 ) dry_fact = 1._wp / ( 1._wp + col_gas ( icol , ilay , idx_h2o ) * vmr_fact ) ! scale by density of special gas if ( scale_by_complement ( imnr )) then ! scale by densities of all gases but the special one scaling = scaling * ( 1._wp - col_gas ( icol , ilay , idx_minor_scaling ( imnr )) * vmr_fact * dry_fact ) else scaling = scaling * ( col_gas ( icol , ilay , idx_minor_scaling ( imnr )) * vmr_fact * dry_fact ) endif endif endif ! ! Interpolation of absorption coefficient and calculation of optical depth ! ! Which gpoint range does this minor gas affect? gptS = minor_limits_gpt ( 1 , imnr ) gptE = minor_limits_gpt ( 2 , imnr ) iflav = gpt_flv ( gptS ) tau_minor ( gptS : gptE ) = scaling * & interpolate2D_byflav ( fminor (:,:, icol , ilay , iflav ), & kminor , & kminor_start ( imnr ), kminor_start ( imnr ) + ( gptE - gptS ), & jeta (:, icol , ilay , iflav ), jtemp ( icol , ilay )) tau ( icol , ilay , gptS : gptE ) = tau ( icol , ilay , gptS : gptE ) + tau_minor ( gptS : gptE ) enddo end if enddo enddo end if end subroutine gas_optical_depths_minor ! ---------------------------------------------------------- ! ! compute Rayleigh scattering optical depths ! subroutine compute_tau_rayleigh ( ncol , nlay , nbnd , ngpt , & ngas , nflav , neta , npres , ntemp , & gpoint_flavor , band_lims_gpt , & krayl , & idx_h2o , col_dry , col_gas , & fminor , jeta , tropo , jtemp , & tau_rayleigh ) bind ( C , name = \"rrtmgp_compute_tau_rayleigh\" ) integer , intent ( in ) :: ncol , nlay , nbnd , ngpt !! input dimensions integer , intent ( in ) :: ngas , nflav , neta , npres , ntemp !! table dimensions integer , dimension ( 2 , ngpt ), intent ( in ) :: gpoint_flavor !! major gas flavor (pair) by upper/lower, g-point integer , dimension ( 2 , nbnd ), intent ( in ) :: band_lims_gpt !! start and end g-point for each band real ( wp ), dimension ( ntemp , neta , ngpt , 2 ), intent ( in ) :: krayl !! Rayleigh scattering coefficients integer , intent ( in ) :: idx_h2o !! index of water vapor in col_gas real ( wp ), dimension ( ncol , nlay ), intent ( in ) :: col_dry !! column amount of dry air real ( wp ), dimension ( ncol , nlay , 0 : ngas ), intent ( in ) :: col_gas !! input column gas amount (molecules/cm^2) real ( wp ), dimension ( 2 , 2 , ncol , nlay , nflav ), intent ( in ) :: fminor !! interpolation weights for major gases - computed in interpolation() integer , dimension ( 2 , ncol , nlay , nflav ), intent ( in ) :: jeta !! interpolation indexes in eta - computed in interpolation() logical ( wl ), dimension ( ncol , nlay ), intent ( in ) :: tropo !! use upper- or lower-atmospheric tables? integer , dimension ( ncol , nlay ), intent ( in ) :: jtemp !! interpolation indexes in temperature - computed in interpolation() ! outputs real ( wp ), dimension ( ncol , nlay , ngpt ), intent ( out ) :: tau_rayleigh !! Rayleigh optical depth ! ----------------- ! local variables real ( wp ) :: k ( ngpt ) ! rayleigh scattering coefficient integer :: icol , ilay , iflav , ibnd , gptS , gptE integer :: itropo ! ----------------- do ibnd = 1 , nbnd gptS = band_lims_gpt ( 1 , ibnd ) gptE = band_lims_gpt ( 2 , ibnd ) do ilay = 1 , nlay do icol = 1 , ncol itropo = merge ( 1 , 2 , tropo ( icol , ilay )) ! itropo = 1 lower atmosphere;itropo = 2 upper atmosphere iflav = gpoint_flavor ( itropo , gptS ) !eta interpolation depends on band's flavor k ( gptS : gptE ) = interpolate2D_byflav ( fminor (:,:, icol , ilay , iflav ), & krayl (:,:,:, itropo ), & gptS , gptE , jeta (:, icol , ilay , iflav ), jtemp ( icol , ilay )) tau_rayleigh ( icol , ilay , gptS : gptE ) = k ( gptS : gptE ) * & ( col_gas ( icol , ilay , idx_h2o ) + col_dry ( icol , ilay )) end do end do end do end subroutine compute_tau_rayleigh ! ---------------------------------------------------------- subroutine compute_Planck_source ( & ncol , nlay , nbnd , ngpt , & nflav , neta , npres , ntemp , nPlanckTemp ,& tlay , tlev , tsfc , sfc_lay , & fmajor , jeta , tropo , jtemp , jpress , & gpoint_bands , band_lims_gpt , & pfracin , temp_ref_min , totplnk_delta , totplnk , gpoint_flavor , & sfc_src , lay_src , lev_src_inc , lev_src_dec , sfc_source_Jac ) bind ( C , name = \"rrtmgp_compute_Planck_source\" ) integer , intent ( in ) :: ncol , nlay , nbnd , ngpt !! input dimensions integer , intent ( in ) :: nflav , neta , npres , ntemp , nPlanckTemp !! table dimensions real ( wp ), dimension ( ncol , nlay ), intent ( in ) :: tlay !! temperature at layer centers (K) real ( wp ), dimension ( ncol , nlay + 1 ), intent ( in ) :: tlev !! temperature at interfaces (K) real ( wp ), dimension ( ncol ), intent ( in ) :: tsfc !! surface temperture integer , intent ( in ) :: sfc_lay !! index into surface layer ! Interpolation variables real ( wp ), dimension ( 2 , 2 , 2 , ncol , nlay , nflav ), intent ( in ) :: fmajor !! interpolation weights for major gases - computed in interpolation() integer , dimension ( 2 , ncol , nlay , nflav ), intent ( in ) :: jeta !! interpolation indexes in eta - computed in interpolation() logical ( wl ), dimension ( ncol , nlay ), intent ( in ) :: tropo !! use upper- or lower-atmospheric tables? integer , dimension ( ncol , nlay ), intent ( in ) :: jtemp , jpress !! interpolation indexes in temperature and pressure - computed in interpolation() ! Table-specific integer , dimension ( ngpt ), intent ( in ) :: gpoint_bands !! band to which each g-point belongs integer , dimension ( 2 , nbnd ), intent ( in ) :: band_lims_gpt !! start and end g-point for each band real ( wp ), intent ( in ) :: temp_ref_min , totplnk_delta !! interpolation constants real ( wp ), dimension ( ntemp , neta , npres + 1 , ngpt ), intent ( in ) :: pfracin !! Fraction of the Planck function in each g-point real ( wp ), dimension ( nPlanckTemp , nbnd ), intent ( in ) :: totplnk !! Total Planck function by band at each temperature integer , dimension ( 2 , ngpt ), intent ( in ) :: gpoint_flavor !! major gas flavor (pair) by upper/lower, g-point real ( wp ), dimension ( ncol , ngpt ), intent ( out ) :: sfc_src !! Planck emssion from the surface real ( wp ), dimension ( ncol , nlay , ngpt ), intent ( out ) :: lay_src !! Planck emssion from layer centers real ( wp ), dimension ( ncol , nlay , ngpt ), intent ( out ) :: lev_src_inc , lev_src_dec !! Planck emission at layer boundaries, using spectral mapping in the direction of propagation real ( wp ), dimension ( ncol , ngpt ), intent ( out ) :: sfc_source_Jac !! Jacobian (derivative) of the surface Planck source with respect to surface temperature ! ----------------- ! local real ( wp ), parameter :: delta_Tsurf = 1.0_wp integer :: ilay , icol , igpt , ibnd , itropo , iflav integer :: gptS , gptE real ( wp ), dimension ( 2 ), parameter :: one = [ 1._wp , 1._wp ] real ( wp ) :: pfrac ( ncol , nlay , ngpt ) real ( wp ) :: planck_function ( ncol , nlay + 1 , nbnd ) ! ----------------- ! Calculation of fraction of band's Planck irradiance associated with each g-point do ibnd = 1 , nbnd gptS = band_lims_gpt ( 1 , ibnd ) gptE = band_lims_gpt ( 2 , ibnd ) do ilay = 1 , nlay do icol = 1 , ncol ! itropo = 1 lower atmosphere; itropo = 2 upper atmosphere itropo = merge ( 1 , 2 , tropo ( icol , ilay )) iflav = gpoint_flavor ( itropo , gptS ) !eta interpolation depends on band's flavor pfrac ( icol , ilay , gptS : gptE ) = & ! interpolation in temperature, pressure, and eta interpolate3D_byflav ( one , fmajor (:,:,:, icol , ilay , iflav ), pfracin , & band_lims_gpt ( 1 , ibnd ), band_lims_gpt ( 2 , ibnd ), & jeta (:, icol , ilay , iflav ), jtemp ( icol , ilay ), jpress ( icol , ilay ) + itropo ) end do ! column end do ! layer end do ! band ! ! Planck function by band for the surface ! Compute surface source irradiance for g-point, equals band irradiance x fraction for g-point ! do icol = 1 , ncol planck_function ( icol , 1 , 1 : nbnd ) = interpolate1D ( tsfc ( icol ), temp_ref_min , totplnk_delta , totplnk ) planck_function ( icol , 2 , 1 : nbnd ) = interpolate1D ( tsfc ( icol ) + delta_Tsurf , temp_ref_min , totplnk_delta , totplnk ) ! ! Map to g-points ! do ibnd = 1 , nbnd gptS = band_lims_gpt ( 1 , ibnd ) gptE = band_lims_gpt ( 2 , ibnd ) do igpt = gptS , gptE sfc_src ( icol , igpt ) = pfrac ( icol , sfc_lay , igpt ) * planck_function ( icol , 1 , ibnd ) sfc_source_Jac ( icol , igpt ) = pfrac ( icol , sfc_lay , igpt ) * & ( planck_function ( icol , 2 , ibnd ) - planck_function ( icol , 1 , ibnd )) end do end do end do !icol do ilay = 1 , nlay do icol = 1 , ncol ! Compute layer source irradiance for g-point, equals band irradiance x fraction for g-point planck_function ( icol , ilay , 1 : nbnd ) = interpolate1D ( tlay ( icol , ilay ), temp_ref_min , totplnk_delta , totplnk ) end do end do ! ! Map to g-points ! do ibnd = 1 , nbnd gptS = band_lims_gpt ( 1 , ibnd ) gptE = band_lims_gpt ( 2 , ibnd ) do igpt = gptS , gptE do ilay = 1 , nlay do icol = 1 , ncol lay_src ( icol , ilay , igpt ) = pfrac ( icol , ilay , igpt ) * planck_function ( icol , ilay , ibnd ) end do end do end do end do ! compute level source irradiances for each g-point, one each for upward and downward paths do ilay = 1 , nlay do icol = 1 , ncol planck_function ( icol , 1 , 1 : nbnd ) = interpolate1D ( tlev ( icol , 1 ), temp_ref_min , totplnk_delta , totplnk ) planck_function ( icol , ilay + 1 , 1 : nbnd ) = interpolate1D ( tlev ( icol , ilay + 1 ), temp_ref_min , totplnk_delta , totplnk ) end do end do ! ! Map to g-points ! do ibnd = 1 , nbnd gptS = band_lims_gpt ( 1 , ibnd ) gptE = band_lims_gpt ( 2 , ibnd ) do igpt = gptS , gptE do ilay = 1 , nlay do icol = 1 , ncol lev_src_inc ( icol , ilay , igpt ) = pfrac ( icol , ilay , igpt ) * planck_function ( icol , ilay + 1 , ibnd ) lev_src_dec ( icol , ilay , igpt ) = pfrac ( icol , ilay , igpt ) * planck_function ( icol , ilay , ibnd ) end do end do end do end do end subroutine compute_Planck_source ! ---------------------------------------------------------- ! ! One dimensional interpolation -- return all values along second table dimension ! pure function interpolate1D ( val , offset , delta , table ) result ( res ) ! input real ( wp ), intent ( in ) :: val , & ! axis value at which to evaluate table offset , & ! minimum of table axis delta ! step size of table axis real ( wp ), dimension (:,:), & intent ( in ) :: table ! dimensions (axis, values) ! output real ( wp ), dimension ( size ( table , dim = 2 )) :: res ! local real ( wp ) :: val0 ! fraction index adjusted by offset and delta integer :: index ! index term real ( wp ) :: frac ! fractional term ! ------------------------------------- val0 = ( val - offset ) / delta frac = val0 - int ( val0 ) ! get fractional part index = min ( size ( table , dim = 1 ) - 1 , max ( 1 , int ( val0 ) + 1 )) ! limit the index range res (:) = table ( index ,:) + frac * ( table ( index + 1 ,:) - table ( index ,:)) end function interpolate1D ! ---------------------------------------------------------- ! This function returns a range of values from a subset (in gpoint) of the k table ! pure function interpolate2D_byflav ( fminor , k , gptS , gptE , jeta , jtemp ) result ( res ) real ( wp ), dimension ( 2 , 2 ), intent ( in ) :: fminor ! interpolation fractions for minor species ! index(1) : reference eta level (temperature dependent) ! index(2) : reference temperature level real ( wp ), dimension (:,:,:), intent ( in ) :: k ! (g-point, eta, temp) integer , intent ( in ) :: gptS , gptE , jtemp ! interpolation index for temperature integer , dimension ( 2 ), intent ( in ) :: jeta ! interpolation index for binary species parameter (eta) real ( wp ), dimension ( gptE - gptS + 1 ) :: res ! the result ! Local variable integer :: igpt ! each code block is for a different reference temperature do igpt = 1 , gptE - gptS + 1 res ( igpt ) = fminor ( 1 , 1 ) * k ( jtemp , jeta ( 1 ) , gptS + igpt - 1 ) + & fminor ( 2 , 1 ) * k ( jtemp , jeta ( 1 ) + 1 , gptS + igpt - 1 ) + & fminor ( 1 , 2 ) * k ( jtemp + 1 , jeta ( 2 ) , gptS + igpt - 1 ) + & fminor ( 2 , 2 ) * k ( jtemp + 1 , jeta ( 2 ) + 1 , gptS + igpt - 1 ) end do end function interpolate2D_byflav ! ---------------------------------------------------------- pure function interpolate3D_byflav ( scaling , fmajor , k , gptS , gptE , jeta , jtemp , jpress ) result ( res ) real ( wp ), dimension ( 2 ), intent ( in ) :: scaling real ( wp ), dimension ( 2 , 2 , 2 ), intent ( in ) :: fmajor ! interpolation fractions for major species ! index(1) : reference eta level (temperature dependent) ! index(2) : reference pressure level ! index(3) : reference temperature level real ( wp ), dimension (:,:,:,:), intent ( in ) :: k ! (temp,eta,press,gpt) integer , intent ( in ) :: gptS , gptE integer , dimension ( 2 ), intent ( in ) :: jeta ! interpolation index for binary species parameter (eta) integer , intent ( in ) :: jtemp ! interpolation index for temperature integer , intent ( in ) :: jpress ! interpolation index for pressure real ( wp ), dimension ( gptS : gptE ) :: res ! the result ! Local variable integer :: igpt ! each code block is for a different reference temperature do igpt = gptS , gptE res ( igpt ) = & scaling ( 1 ) * & ( fmajor ( 1 , 1 , 1 ) * k ( jtemp , jeta ( 1 ) , jpress - 1 , igpt ) + & fmajor ( 2 , 1 , 1 ) * k ( jtemp , jeta ( 1 ) + 1 , jpress - 1 , igpt ) + & fmajor ( 1 , 2 , 1 ) * k ( jtemp , jeta ( 1 ) , jpress , igpt ) + & fmajor ( 2 , 2 , 1 ) * k ( jtemp , jeta ( 1 ) + 1 , jpress , igpt ) ) + & scaling ( 2 ) * & ( fmajor ( 1 , 1 , 2 ) * k ( jtemp + 1 , jeta ( 2 ) , jpress - 1 , igpt ) + & fmajor ( 2 , 1 , 2 ) * k ( jtemp + 1 , jeta ( 2 ) + 1 , jpress - 1 , igpt ) + & fmajor ( 1 , 2 , 2 ) * k ( jtemp + 1 , jeta ( 2 ) , jpress , igpt ) + & fmajor ( 2 , 2 , 2 ) * k ( jtemp + 1 , jeta ( 2 ) + 1 , jpress , igpt ) ) end do end function interpolate3D_byflav end module mo_gas_optics_rrtmgp_kernels","tags":"","loc":"sourcefile/mo_gas_optics_rrtmgp_kernels.f90.html"}]} \ No newline at end of file +var tipuesearch = {"pages":[{"title":" RRTMGP kernels ","text":"RRTMGP kernels These pages document the low-level computational kernels used by RRTMGP. The listings below may not be exhaustive.\nTo see the full listings use the links at the top of the page.\nThere is a search bar in the top right. Return to the Documentation overview or the reference overview . Developer Info The RTE+RRTTMGP consortium","tags":"home","loc":"index.html"},{"title":"compute_Planck_source – RRTMGP kernels","text":"public subroutine compute_Planck_source(ncol, nlay, nbnd, ngpt, nflav, neta, npres, ntemp, nPlanckTemp, tlay, tlev, tsfc, sfc_lay, fmajor, jeta, tropo, jtemp, jpress, gpoint_bands, band_lims_gpt, pfracin, temp_ref_min, totplnk_delta, totplnk, gpoint_flavor, sfc_src, lay_src, lev_src, sfc_source_Jac) bind(C, name=\"0\") Arguments Type Intent Optional Attributes Name integer, intent(in) :: ncol input dimensions integer, intent(in) :: nlay input dimensions integer, intent(in) :: nbnd input dimensions integer, intent(in) :: ngpt input dimensions integer, intent(in) :: nflav table dimensions integer, intent(in) :: neta table dimensions integer, intent(in) :: npres table dimensions integer, intent(in) :: ntemp table dimensions integer, intent(in) :: nPlanckTemp table dimensions real(kind=wp), intent(in), dimension(ncol,nlay ) :: tlay temperature at layer centers (K) real(kind=wp), intent(in), dimension(ncol,nlay+1) :: tlev temperature at interfaces (K) real(kind=wp), intent(in), dimension(ncol ) :: tsfc surface temperture integer, intent(in) :: sfc_lay index into surface layer real(kind=wp), intent(in), dimension(2,2,2,ncol,nlay,nflav) :: fmajor interpolation weights for major gases - computed in interpolation() integer, intent(in), dimension(2, ncol,nlay,nflav) :: jeta interpolation indexes in eta - computed in interpolation() logical(kind=wl), intent(in), dimension( ncol,nlay) :: tropo use upper- or lower-atmospheric tables? integer, intent(in), dimension( ncol,nlay) :: jtemp interpolation indexes in temperature and pressure - computed in interpolation() integer, intent(in), dimension( ncol,nlay) :: jpress interpolation indexes in temperature and pressure - computed in interpolation() integer, intent(in), dimension(ngpt) :: gpoint_bands band to which each g-point belongs integer, intent(in), dimension(2, nbnd) :: band_lims_gpt start and end g-point for each band real(kind=wp), intent(in), dimension(ntemp,neta,npres+1,ngpt) :: pfracin Fraction of the Planck function in each g-point real(kind=wp), intent(in) :: temp_ref_min interpolation constants real(kind=wp), intent(in) :: totplnk_delta interpolation constants real(kind=wp), intent(in), dimension(nPlanckTemp,nbnd) :: totplnk Total Planck function by band at each temperature integer, intent(in), dimension(2,ngpt) :: gpoint_flavor major gas flavor (pair) by upper/lower, g-point real(kind=wp), intent(out), dimension(ncol, ngpt) :: sfc_src Planck emission from the surface real(kind=wp), intent(out), dimension(ncol,nlay, ngpt) :: lay_src Planck emission from layer centers real(kind=wp), intent(out), dimension(ncol,nlay+1,ngpt) :: lev_src Planck emission from layer boundaries real(kind=wp), intent(out), dimension(ncol, ngpt) :: sfc_source_Jac Jacobian (derivative) of the surface Planck source with respect to surface temperature Contents None","tags":"","loc":"proc/compute_planck_source.html"},{"title":"compute_tau_absorption – RRTMGP kernels","text":"public subroutine compute_tau_absorption(ncol, nlay, nbnd, ngpt, ngas, nflav, neta, npres, ntemp, nminorlower, nminorklower, nminorupper, nminorkupper, idx_h2o, gpoint_flavor, band_lims_gpt, kmajor, kminor_lower, kminor_upper, minor_limits_gpt_lower, minor_limits_gpt_upper, minor_scales_with_density_lower, minor_scales_with_density_upper, scale_by_complement_lower, scale_by_complement_upper, idx_minor_lower, idx_minor_upper, idx_minor_scaling_lower, idx_minor_scaling_upper, kminor_start_lower, kminor_start_upper, tropo, col_mix, fmajor, fminor, play, tlay, col_gas, jeta, jtemp, jpress, tau) bind(C, name=\"0\") Compute minor and major species optical depth using pre-computed interpolation coefficients\n (jeta,jtemp,jpress) and weights (fmajor, fminor) Arguments Type Intent Optional Attributes Name integer, intent(in) :: ncol array sizes integer, intent(in) :: nlay array sizes integer, intent(in) :: nbnd array sizes integer, intent(in) :: ngpt array sizes integer, intent(in) :: ngas tables sizes integer, intent(in) :: nflav tables sizes integer, intent(in) :: neta tables sizes integer, intent(in) :: npres tables sizes integer, intent(in) :: ntemp tables sizes integer, intent(in) :: nminorlower table sizes integer, intent(in) :: nminorklower table sizes integer, intent(in) :: nminorupper table sizes integer, intent(in) :: nminorkupper table sizes integer, intent(in) :: idx_h2o index of water vapor in col_gas integer, intent(in), dimension(2,ngpt) :: gpoint_flavor major gas flavor (pair) by upper/lower, g-point integer, intent(in), dimension(2,nbnd) :: band_lims_gpt beginning and ending g-point for each band real(kind=wp), intent(in), dimension(ntemp,neta,npres+1,ngpt) :: kmajor absorption coefficient table - major gases real(kind=wp), intent(in), dimension(ntemp,neta,nminorklower) :: kminor_lower absorption coefficient table - minor gases, lower atmosphere real(kind=wp), intent(in), dimension(ntemp,neta,nminorkupper) :: kminor_upper absorption coefficient table - minor gases, upper atmosphere integer, intent(in), dimension(2,nminorlower) :: minor_limits_gpt_lower beginning and ending g-point for each minor gas integer, intent(in), dimension(2,nminorupper) :: minor_limits_gpt_upper logical(kind=wl), intent(in), dimension( nminorlower) :: minor_scales_with_density_lower generic treatment of minor gases - scales with density (e.g. continuum, collision-induced absorption)? logical(kind=wl), intent(in), dimension( nminorupper) :: minor_scales_with_density_upper logical(kind=wl), intent(in), dimension( nminorlower) :: scale_by_complement_lower generic treatment of minor gases - scale by density (e.g. self-continuum) or complement? logical(kind=wl), intent(in), dimension( nminorupper) :: scale_by_complement_upper integer, intent(in), dimension( nminorlower) :: idx_minor_lower index of each minor gas in col_gas integer, intent(in), dimension( nminorupper) :: idx_minor_upper integer, intent(in), dimension( nminorlower) :: idx_minor_scaling_lower for this minor gas, index of the \"scaling gas\" in col_gas integer, intent(in), dimension( nminorupper) :: idx_minor_scaling_upper integer, intent(in), dimension( nminorlower) :: kminor_start_lower starting g-point index in minor gas absorption table integer, intent(in), dimension( nminorupper) :: kminor_start_upper logical(kind=wl), intent(in), dimension(ncol,nlay) :: tropo use upper- or lower-atmospheric tables? real(kind=wp), intent(in), dimension(2, ncol,nlay,nflav ) :: col_mix combination of major species's column amounts - computed in interpolation() real(kind=wp), intent(in), dimension(2,2,2,ncol,nlay,nflav ) :: fmajor interpolation weights for major gases - computed in interpolation() real(kind=wp), intent(in), dimension(2,2, ncol,nlay,nflav ) :: fminor interpolation weights for minor gases - computed in interpolation() real(kind=wp), intent(in), dimension( ncol,nlay ) :: play input temperature and pressure real(kind=wp), intent(in), dimension( ncol,nlay ) :: tlay input temperature and pressure real(kind=wp), intent(in), dimension( ncol,nlay,0:ngas) :: col_gas input column gas amount (molecules/cm^2) integer, intent(in), dimension(2, ncol,nlay,nflav ) :: jeta interpolation indexes in eta - computed in interpolation() integer, intent(in), dimension( ncol,nlay ) :: jtemp interpolation indexes in temperature - computed in interpolation() integer, intent(in), dimension( ncol,nlay ) :: jpress interpolation indexes in pressure - computed in interpolation() real(kind=wp), intent(inout), dimension(ncol,nlay,ngpt) :: tau aborption optional depth Contents None","tags":"","loc":"proc/compute_tau_absorption.html"},{"title":"compute_tau_rayleigh – RRTMGP kernels","text":"public subroutine compute_tau_rayleigh(ncol, nlay, nbnd, ngpt, ngas, nflav, neta, npres, ntemp, gpoint_flavor, band_lims_gpt, krayl, idx_h2o, col_dry, col_gas, fminor, jeta, tropo, jtemp, tau_rayleigh) bind(C, name=\"0\") Arguments Type Intent Optional Attributes Name integer, intent(in) :: ncol input dimensions integer, intent(in) :: nlay input dimensions integer, intent(in) :: nbnd input dimensions integer, intent(in) :: ngpt input dimensions integer, intent(in) :: ngas table dimensions integer, intent(in) :: nflav table dimensions integer, intent(in) :: neta table dimensions integer, intent(in) :: npres table dimensions integer, intent(in) :: ntemp table dimensions integer, intent(in), dimension(2,ngpt) :: gpoint_flavor major gas flavor (pair) by upper/lower, g-point integer, intent(in), dimension(2,nbnd) :: band_lims_gpt start and end g-point for each band real(kind=wp), intent(in), dimension(ntemp,neta,ngpt,2) :: krayl Rayleigh scattering coefficients integer, intent(in) :: idx_h2o index of water vapor in col_gas real(kind=wp), intent(in), dimension(ncol,nlay) :: col_dry column amount of dry air real(kind=wp), intent(in), dimension(ncol,nlay,0:ngas) :: col_gas input column gas amount (molecules/cm^2) real(kind=wp), intent(in), dimension(2,2,ncol,nlay,nflav) :: fminor interpolation weights for major gases - computed in interpolation() integer, intent(in), dimension(2, ncol,nlay,nflav) :: jeta interpolation indexes in eta - computed in interpolation() logical(kind=wl), intent(in), dimension(ncol,nlay) :: tropo use upper- or lower-atmospheric tables? integer, intent(in), dimension(ncol,nlay) :: jtemp interpolation indexes in temperature - computed in interpolation() real(kind=wp), intent(out), dimension(ncol,nlay,ngpt) :: tau_rayleigh Rayleigh optical depth Contents None","tags":"","loc":"proc/compute_tau_rayleigh.html"},{"title":"interpolation – RRTMGP kernels","text":"public subroutine interpolation(ncol, nlay, ngas, nflav, neta, npres, ntemp, flavor, press_ref_log, temp_ref, press_ref_log_delta, temp_ref_min, temp_ref_delta, press_ref_trop_log, vmr_ref, play, tlay, col_gas, jtemp, fmajor, fminor, col_mix, tropo, jeta, jpress) bind(C, name=\"0\") Compute interpolation coefficients\nfor calculations of major optical depths, minor optical depths, Rayleigh,\nand Planck fractions Arguments Type Intent Optional Attributes Name integer, intent(in) :: ncol physical domain size integer, intent(in) :: nlay physical domain size integer, intent(in) :: ngas k-distribution table dimensions integer, intent(in) :: nflav k-distribution table dimensions integer, intent(in) :: neta k-distribution table dimensions integer, intent(in) :: npres k-distribution table dimensions integer, intent(in) :: ntemp k-distribution table dimensions integer, intent(in), dimension(2,nflav) :: flavor index into vmr_ref of major gases for each flavor real(kind=wp), intent(in), dimension(npres) :: press_ref_log log of pressure dimension in RRTMGP tables real(kind=wp), intent(in), dimension(ntemp) :: temp_ref temperature dimension in RRTMGP tables real(kind=wp), intent(in) :: press_ref_log_delta constants related to RRTMGP tables real(kind=wp), intent(in) :: temp_ref_min constants related to RRTMGP tables real(kind=wp), intent(in) :: temp_ref_delta constants related to RRTMGP tables real(kind=wp), intent(in) :: press_ref_trop_log constants related to RRTMGP tables real(kind=wp), intent(in), dimension(2,0:ngas,ntemp) :: vmr_ref reference volume mixing ratios used in compute \"binary species parameter\" eta real(kind=wp), intent(in), dimension(ncol,nlay) :: play input pressure (Pa?) and temperature (K) real(kind=wp), intent(in), dimension(ncol,nlay) :: tlay input pressure (Pa?) and temperature (K) real(kind=wp), intent(in), dimension(ncol,nlay,0:ngas) :: col_gas input column gas amount - molecules/cm^2 integer, intent(out), dimension(ncol,nlay) :: jtemp temperature and pressure interpolation indexes real(kind=wp), intent(out), dimension(2,2,2,ncol,nlay,nflav) :: fmajor Interpolation weights in pressure, eta, strat/trop real(kind=wp), intent(out), dimension(2,2, ncol,nlay,nflav) :: fminor Interpolation fraction in eta, strat/trop real(kind=wp), intent(out), dimension(2, ncol,nlay,nflav) :: col_mix combination of major species's column amounts (first index is strat/trop) logical(kind=wl), intent(out), dimension(ncol,nlay) :: tropo use lower (or upper) atmosphere tables integer, intent(out), dimension(2, ncol,nlay,nflav) :: jeta Index for binary species interpolation integer, intent(out), dimension(ncol,nlay) :: jpress temperature and pressure interpolation indexes Calls proc~~interpolation~~CallsGraph proc~interpolation interpolation float float proc~interpolation->float Help × Graph Key Nodes of different colours represent the following: Graph Key Subroutine Subroutine Function Function Interface Interface Unknown Procedure Type Unknown Procedure Type Program Program This Page's Entity This Page's Entity Solid arrows point from a procedure to one which it calls. Dashed \n arrows point from an interface to procedures which implement that interface.\n This could include the module procedures in a generic interface or the\n implementation in a submodule of an interface in a parent module. Contents None","tags":"","loc":"proc/interpolation.html"},{"title":"compute_Planck_source – RRTMGP kernels","text":"interface public subroutine compute_Planck_source(ncol, nlay, nbnd, ngpt, nflav, neta, npres, ntemp, nPlanckTemp, tlay, tlev, tsfc, sfc_lay, fmajor, jeta, tropo, jtemp, jpress, gpoint_bands, band_lims_gpt, pfracin, temp_ref_min, totplnk_delta, totplnk, gpoint_flavor, sfc_src, lay_src, lev_src, sfc_source_Jac) bind(C, name=\"0\") Arguments Type Intent Optional Attributes Name integer, intent(in) :: ncol input dimensions integer, intent(in) :: nlay input dimensions integer, intent(in) :: nbnd input dimensions integer, intent(in) :: ngpt input dimensions integer, intent(in) :: nflav table dimensions integer, intent(in) :: neta table dimensions integer, intent(in) :: npres table dimensions integer, intent(in) :: ntemp table dimensions integer, intent(in) :: nPlanckTemp table dimensions real(kind=wp), intent(in), dimension(ncol,nlay ) :: tlay temperature at layer centers (K) real(kind=wp), intent(in), dimension(ncol,nlay+1) :: tlev temperature at interfaces (K) real(kind=wp), intent(in), dimension(ncol ) :: tsfc surface temperture integer, intent(in) :: sfc_lay index into surface layer real(kind=wp), intent(in), dimension(2,2,2,ncol,nlay,nflav) :: fmajor interpolation weights for major gases - computed in interpolation() integer, intent(in), dimension(2, ncol,nlay,nflav) :: jeta interpolation indexes in eta - computed in interpolation() logical(kind=wl), intent(in), dimension( ncol,nlay) :: tropo use upper- or lower-atmospheric tables? integer, intent(in), dimension( ncol,nlay) :: jtemp interpolation indexes in temperature and pressure - computed in interpolation() integer, intent(in), dimension( ncol,nlay) :: jpress interpolation indexes in temperature and pressure - computed in interpolation() integer, intent(in), dimension(ngpt) :: gpoint_bands band to which each g-point belongs integer, intent(in), dimension(2, nbnd) :: band_lims_gpt start and end g-point for each band real(kind=wp), intent(in), dimension(ntemp,neta,npres+1,ngpt) :: pfracin Fraction of the Planck function in each g-point real(kind=wp), intent(in) :: temp_ref_min interpolation constants real(kind=wp), intent(in) :: totplnk_delta interpolation constants real(kind=wp), intent(in), dimension(nPlanckTemp,nbnd) :: totplnk Total Planck function by band at each temperature integer, intent(in), dimension(2,ngpt) :: gpoint_flavor major gas flavor (pair) by upper/lower, g-point real(kind=wp), intent(out), dimension(ncol, ngpt) :: sfc_src Planck emssion from the surface real(kind=wp), intent(out), dimension(ncol,nlay, ngpt) :: lay_src Planck emssion from layer centers real(kind=wp), intent(out), dimension(ncol,nlay+1,ngpt) :: lev_src Planck emission at layer boundaries real(kind=wp), intent(out), dimension(ncol, ngpt) :: sfc_source_Jac Jacobian (derivative) of the surface Planck source with respect to surface temperature","tags":"","loc":"interface/compute_planck_source.html"},{"title":"compute_tau_absorption – RRTMGP kernels","text":"interface public subroutine compute_tau_absorption(ncol, nlay, nbnd, ngpt, ngas, nflav, neta, npres, ntemp, nminorlower, nminorklower, nminorupper, nminorkupper, idx_h2o, gpoint_flavor, band_lims_gpt, kmajor, kminor_lower, kminor_upper, minor_limits_gpt_lower, minor_limits_gpt_upper, minor_scales_with_density_lower, minor_scales_with_density_upper, scale_by_complement_lower, scale_by_complement_upper, idx_minor_lower, idx_minor_upper, idx_minor_scaling_lower, idx_minor_scaling_upper, kminor_start_lower, kminor_start_upper, tropo, col_mix, fmajor, fminor, play, tlay, col_gas, jeta, jtemp, jpress, tau) bind(C, name=\"0\") Arguments Type Intent Optional Attributes Name integer, intent(in) :: ncol array sizes integer, intent(in) :: nlay array sizes integer, intent(in) :: nbnd array sizes integer, intent(in) :: ngpt array sizes integer, intent(in) :: ngas tables sizes integer, intent(in) :: nflav tables sizes integer, intent(in) :: neta tables sizes integer, intent(in) :: npres tables sizes integer, intent(in) :: ntemp tables sizes integer, intent(in) :: nminorlower table sizes integer, intent(in) :: nminorklower table sizes integer, intent(in) :: nminorupper table sizes integer, intent(in) :: nminorkupper table sizes integer, intent(in) :: idx_h2o index of water vapor in col_gas integer, intent(in), dimension(2,ngpt) :: gpoint_flavor major gas flavor (pair) by upper/lower, g-point integer, intent(in), dimension(2,nbnd) :: band_lims_gpt beginning and ending g-point for each band real(kind=wp), intent(in), dimension(ntemp,neta,npres+1,ngpt) :: kmajor absorption coefficient table - major gases real(kind=wp), intent(in), dimension(ntemp,neta,nminorklower) :: kminor_lower absorption coefficient table - minor gases, lower atmosphere real(kind=wp), intent(in), dimension(ntemp,neta,nminorkupper) :: kminor_upper absorption coefficient table - minor gases, upper atmosphere integer, intent(in), dimension(2,nminorlower) :: minor_limits_gpt_lower beginning and ending g-point for each minor gas integer, intent(in), dimension(2,nminorupper) :: minor_limits_gpt_upper logical(kind=wl), intent(in), dimension( nminorlower) :: minor_scales_with_density_lower generic treatment of minor gases - scales with density (e.g. continuum, collision-induced absorption)? logical(kind=wl), intent(in), dimension( nminorupper) :: minor_scales_with_density_upper logical(kind=wl), intent(in), dimension( nminorlower) :: scale_by_complement_lower generic treatment of minor gases - scale by density (e.g. self-continuum) or complement? logical(kind=wl), intent(in), dimension( nminorupper) :: scale_by_complement_upper integer, intent(in), dimension( nminorlower) :: idx_minor_lower index of each minor gas in col_gas integer, intent(in), dimension( nminorupper) :: idx_minor_upper integer, intent(in), dimension( nminorlower) :: idx_minor_scaling_lower for this minor gas, index of the \"scaling gas\" in col_gas integer, intent(in), dimension( nminorupper) :: idx_minor_scaling_upper integer, intent(in), dimension( nminorlower) :: kminor_start_lower starting g-point index in minor gas absorption table integer, intent(in), dimension( nminorupper) :: kminor_start_upper logical(kind=wl), intent(in), dimension(ncol,nlay) :: tropo use upper- or lower-atmospheric tables? real(kind=wp), intent(in), dimension(2, ncol,nlay,nflav ) :: col_mix combination of major species's column amounts - computed in interpolation() real(kind=wp), intent(in), dimension(2,2,2,ncol,nlay,nflav ) :: fmajor interpolation weights for major gases - computed in interpolation() real(kind=wp), intent(in), dimension(2,2, ncol,nlay,nflav ) :: fminor interpolation weights for minor gases - computed in interpolation() real(kind=wp), intent(in), dimension( ncol,nlay ) :: play input temperature and pressure real(kind=wp), intent(in), dimension( ncol,nlay ) :: tlay input temperature and pressure real(kind=wp), intent(in), dimension( ncol,nlay,0:ngas) :: col_gas input column gas amount (molecules/cm^2) integer, intent(in), dimension(2, ncol,nlay,nflav ) :: jeta interpolation indexes in eta - computed in interpolation() integer, intent(in), dimension( ncol,nlay ) :: jtemp interpolation indexes in temperature - computed in interpolation() integer, intent(in), dimension( ncol,nlay ) :: jpress interpolation indexes in pressure - computed in interpolation() real(kind=wp), intent(inout), dimension(ncol,nlay,ngpt) :: tau aborption optional depth","tags":"","loc":"interface/compute_tau_absorption.html"},{"title":"compute_tau_rayleigh – RRTMGP kernels","text":"interface public subroutine compute_tau_rayleigh(ncol, nlay, nbnd, ngpt, ngas, nflav, neta, npres, ntemp, gpoint_flavor, band_lims_gpt, krayl, idx_h2o, col_dry, col_gas, fminor, jeta, tropo, jtemp, tau_rayleigh) bind(C, name=\"0\") Arguments Type Intent Optional Attributes Name integer, intent(in) :: ncol input dimensions integer, intent(in) :: nlay input dimensions integer, intent(in) :: nbnd input dimensions integer, intent(in) :: ngpt input dimensions integer, intent(in) :: ngas table dimensions integer, intent(in) :: nflav table dimensions integer, intent(in) :: neta table dimensions integer, intent(in) :: npres table dimensions integer, intent(in) :: ntemp table dimensions integer, intent(in), dimension(2,ngpt) :: gpoint_flavor major gas flavor (pair) by upper/lower, g-point integer, intent(in), dimension(2,nbnd) :: band_lims_gpt start and end g-point for each band real(kind=wp), intent(in), dimension(ntemp,neta,ngpt,2) :: krayl Rayleigh scattering coefficients integer, intent(in) :: idx_h2o index of water vapor in col_gas real(kind=wp), intent(in), dimension(ncol,nlay) :: col_dry column amount of dry air real(kind=wp), intent(in), dimension(ncol,nlay,0:ngas) :: col_gas input column gas amount (molecules/cm^2) real(kind=wp), intent(in), dimension(2,2,ncol,nlay,nflav) :: fminor interpolation weights for major gases - computed in interpolation() integer, intent(in), dimension(2, ncol,nlay,nflav) :: jeta interpolation indexes in eta - computed in interpolation() logical(kind=wl), intent(in), dimension(ncol,nlay) :: tropo use upper- or lower-atmospheric tables? integer, intent(in), dimension(ncol,nlay) :: jtemp interpolation indexes in temperature - computed in interpolation() real(kind=wp), intent(out), dimension(ncol,nlay,ngpt) :: tau_rayleigh Rayleigh optical depth","tags":"","loc":"interface/compute_tau_rayleigh.html"},{"title":"interpolation – RRTMGP kernels","text":"interface public subroutine interpolation(ncol, nlay, ngas, nflav, neta, npres, ntemp, flavor, press_ref_log, temp_ref, press_ref_log_delta, temp_ref_min, temp_ref_delta, press_ref_trop_log, vmr_ref, play, tlay, col_gas, jtemp, fmajor, fminor, col_mix, tropo, jeta, jpress) bind(C, name=\"0\") Arguments Type Intent Optional Attributes Name integer, intent(in) :: ncol physical domain size integer, intent(in) :: nlay physical domain size integer, intent(in) :: ngas k-distribution table dimensions integer, intent(in) :: nflav k-distribution table dimensions integer, intent(in) :: neta k-distribution table dimensions integer, intent(in) :: npres k-distribution table dimensions integer, intent(in) :: ntemp k-distribution table dimensions integer, intent(in), dimension(2,nflav) :: flavor index into vmr_ref of major gases for each flavor real(kind=wp), intent(in), dimension(npres) :: press_ref_log log of pressure dimension in RRTMGP tables real(kind=wp), intent(in), dimension(ntemp) :: temp_ref temperature dimension in RRTMGP tables real(kind=wp), intent(in) :: press_ref_log_delta constants related to RRTMGP tables real(kind=wp), intent(in) :: temp_ref_min constants related to RRTMGP tables real(kind=wp), intent(in) :: temp_ref_delta constants related to RRTMGP tables real(kind=wp), intent(in) :: press_ref_trop_log constants related to RRTMGP tables real(kind=wp), intent(in), dimension(2,0:ngas,ntemp) :: vmr_ref reference volume mixing ratios used in compute \"binary species parameter\" eta real(kind=wp), intent(in), dimension(ncol,nlay) :: play input pressure (Pa?) and temperature (K) real(kind=wp), intent(in), dimension(ncol,nlay) :: tlay input pressure (Pa?) and temperature (K) real(kind=wp), intent(in), dimension(ncol,nlay,0:ngas) :: col_gas input column gas amount - molecules/cm^2 integer, intent(out), dimension(ncol,nlay) :: jtemp temperature and pressure interpolation indexes real(kind=wp), intent(out), dimension(2,2,2,ncol,nlay,nflav) :: fmajor Interpolation weights in pressure, eta, strat/trop real(kind=wp), intent(out), dimension(2,2, ncol,nlay,nflav) :: fminor Interpolation fraction in eta, strat/trop real(kind=wp), intent(out), dimension(2, ncol,nlay,nflav) :: col_mix combination of major species's column amounts (first index is strat/trop) logical(kind=wl), intent(out), dimension(ncol,nlay) :: tropo use lower (or upper) atmosphere tables integer, intent(out), dimension(2, ncol,nlay,nflav) :: jeta Index for binary species interpolation integer, intent(out), dimension(ncol,nlay) :: jpress temperature and pressure interpolation indexes","tags":"","loc":"interface/interpolation.html"},{"title":"mo_gas_optics_rrtmgp_kernels – RRTMGP kernels","text":"Numeric calculations for gas optics. Absorption and Rayleigh optical depths, Planck source functions. Interpolation coefficients are computed, then used in subsequent routines. All applications will call compute_tau_absorption(); \n compute_tau_rayleigh() and/or compute_Planck_source() will be called depending on the \n configuration of the k-distribution. The details of the interpolation scheme are not particaulrly important as long as arrays including \n tables are passed consisently between kernels. Uses mo_rte_util_array mo_rte_kind module~~mo_gas_optics_rrtmgp_kernels~~UsesGraph module~mo_gas_optics_rrtmgp_kernels mo_gas_optics_rrtmgp_kernels mo_rte_util_array mo_rte_util_array module~mo_gas_optics_rrtmgp_kernels->mo_rte_util_array mo_rte_kind mo_rte_kind module~mo_gas_optics_rrtmgp_kernels->mo_rte_kind Help × Graph Key Nodes of different colours represent the following: Graph Key Module Module Submodule Submodule Subroutine Subroutine Function Function Program Program This Page's Entity This Page's Entity Solid arrows point from a submodule to the (sub)module which it is\n descended from. Dashed arrows point from a module or program unit to \n modules which it uses. Contents Subroutines compute_Planck_source compute_tau_absorption compute_tau_rayleigh interpolation Subroutines public subroutine compute_Planck_source (ncol, nlay, nbnd, ngpt, nflav, neta, npres, ntemp, nPlanckTemp, tlay, tlev, tsfc, sfc_lay, fmajor, jeta, tropo, jtemp, jpress, gpoint_bands, band_lims_gpt, pfracin, temp_ref_min, totplnk_delta, totplnk, gpoint_flavor, sfc_src, lay_src, lev_src, sfc_source_Jac) bind(C, name=\"0\") Arguments Type Intent Optional Attributes Name integer, intent(in) :: ncol input dimensions integer, intent(in) :: nlay input dimensions integer, intent(in) :: nbnd input dimensions integer, intent(in) :: ngpt input dimensions integer, intent(in) :: nflav table dimensions integer, intent(in) :: neta table dimensions integer, intent(in) :: npres table dimensions integer, intent(in) :: ntemp table dimensions integer, intent(in) :: nPlanckTemp table dimensions real(kind=wp), intent(in), dimension(ncol,nlay ) :: tlay temperature at layer centers (K) real(kind=wp), intent(in), dimension(ncol,nlay+1) :: tlev temperature at interfaces (K) real(kind=wp), intent(in), dimension(ncol ) :: tsfc surface temperture integer, intent(in) :: sfc_lay index into surface layer real(kind=wp), intent(in), dimension(2,2,2,ncol,nlay,nflav) :: fmajor interpolation weights for major gases - computed in interpolation() integer, intent(in), dimension(2, ncol,nlay,nflav) :: jeta interpolation indexes in eta - computed in interpolation() logical(kind=wl), intent(in), dimension( ncol,nlay) :: tropo use upper- or lower-atmospheric tables? integer, intent(in), dimension( ncol,nlay) :: jtemp interpolation indexes in temperature and pressure - computed in interpolation() integer, intent(in), dimension( ncol,nlay) :: jpress interpolation indexes in temperature and pressure - computed in interpolation() integer, intent(in), dimension(ngpt) :: gpoint_bands band to which each g-point belongs integer, intent(in), dimension(2, nbnd) :: band_lims_gpt start and end g-point for each band real(kind=wp), intent(in), dimension(ntemp,neta,npres+1,ngpt) :: pfracin Fraction of the Planck function in each g-point real(kind=wp), intent(in) :: temp_ref_min interpolation constants real(kind=wp), intent(in) :: totplnk_delta interpolation constants real(kind=wp), intent(in), dimension(nPlanckTemp,nbnd) :: totplnk Total Planck function by band at each temperature integer, intent(in), dimension(2,ngpt) :: gpoint_flavor major gas flavor (pair) by upper/lower, g-point real(kind=wp), intent(out), dimension(ncol, ngpt) :: sfc_src Planck emission from the surface real(kind=wp), intent(out), dimension(ncol,nlay, ngpt) :: lay_src Planck emission from layer centers real(kind=wp), intent(out), dimension(ncol,nlay+1,ngpt) :: lev_src Planck emission from layer boundaries real(kind=wp), intent(out), dimension(ncol, ngpt) :: sfc_source_Jac Jacobian (derivative) of the surface Planck source with respect to surface temperature public subroutine compute_tau_absorption (ncol, nlay, nbnd, ngpt, ngas, nflav, neta, npres, ntemp, nminorlower, nminorklower, nminorupper, nminorkupper, idx_h2o, gpoint_flavor, band_lims_gpt, kmajor, kminor_lower, kminor_upper, minor_limits_gpt_lower, minor_limits_gpt_upper, minor_scales_with_density_lower, minor_scales_with_density_upper, scale_by_complement_lower, scale_by_complement_upper, idx_minor_lower, idx_minor_upper, idx_minor_scaling_lower, idx_minor_scaling_upper, kminor_start_lower, kminor_start_upper, tropo, col_mix, fmajor, fminor, play, tlay, col_gas, jeta, jtemp, jpress, tau) bind(C, name=\"0\") Compute minor and major species optical depth using pre-computed interpolation coefficients\n (jeta,jtemp,jpress) and weights (fmajor, fminor) Arguments Type Intent Optional Attributes Name integer, intent(in) :: ncol array sizes integer, intent(in) :: nlay array sizes integer, intent(in) :: nbnd array sizes integer, intent(in) :: ngpt array sizes integer, intent(in) :: ngas tables sizes integer, intent(in) :: nflav tables sizes integer, intent(in) :: neta tables sizes integer, intent(in) :: npres tables sizes integer, intent(in) :: ntemp tables sizes integer, intent(in) :: nminorlower table sizes integer, intent(in) :: nminorklower table sizes integer, intent(in) :: nminorupper table sizes integer, intent(in) :: nminorkupper table sizes integer, intent(in) :: idx_h2o index of water vapor in col_gas integer, intent(in), dimension(2,ngpt) :: gpoint_flavor major gas flavor (pair) by upper/lower, g-point integer, intent(in), dimension(2,nbnd) :: band_lims_gpt beginning and ending g-point for each band real(kind=wp), intent(in), dimension(ntemp,neta,npres+1,ngpt) :: kmajor absorption coefficient table - major gases real(kind=wp), intent(in), dimension(ntemp,neta,nminorklower) :: kminor_lower absorption coefficient table - minor gases, lower atmosphere real(kind=wp), intent(in), dimension(ntemp,neta,nminorkupper) :: kminor_upper absorption coefficient table - minor gases, upper atmosphere integer, intent(in), dimension(2,nminorlower) :: minor_limits_gpt_lower beginning and ending g-point for each minor gas integer, intent(in), dimension(2,nminorupper) :: minor_limits_gpt_upper logical(kind=wl), intent(in), dimension( nminorlower) :: minor_scales_with_density_lower generic treatment of minor gases - scales with density (e.g. continuum, collision-induced absorption)? logical(kind=wl), intent(in), dimension( nminorupper) :: minor_scales_with_density_upper logical(kind=wl), intent(in), dimension( nminorlower) :: scale_by_complement_lower generic treatment of minor gases - scale by density (e.g. self-continuum) or complement? logical(kind=wl), intent(in), dimension( nminorupper) :: scale_by_complement_upper integer, intent(in), dimension( nminorlower) :: idx_minor_lower index of each minor gas in col_gas integer, intent(in), dimension( nminorupper) :: idx_minor_upper integer, intent(in), dimension( nminorlower) :: idx_minor_scaling_lower for this minor gas, index of the \"scaling gas\" in col_gas integer, intent(in), dimension( nminorupper) :: idx_minor_scaling_upper integer, intent(in), dimension( nminorlower) :: kminor_start_lower starting g-point index in minor gas absorption table integer, intent(in), dimension( nminorupper) :: kminor_start_upper logical(kind=wl), intent(in), dimension(ncol,nlay) :: tropo use upper- or lower-atmospheric tables? real(kind=wp), intent(in), dimension(2, ncol,nlay,nflav ) :: col_mix combination of major species's column amounts - computed in interpolation() real(kind=wp), intent(in), dimension(2,2,2,ncol,nlay,nflav ) :: fmajor interpolation weights for major gases - computed in interpolation() real(kind=wp), intent(in), dimension(2,2, ncol,nlay,nflav ) :: fminor interpolation weights for minor gases - computed in interpolation() real(kind=wp), intent(in), dimension( ncol,nlay ) :: play input temperature and pressure real(kind=wp), intent(in), dimension( ncol,nlay ) :: tlay input temperature and pressure real(kind=wp), intent(in), dimension( ncol,nlay,0:ngas) :: col_gas input column gas amount (molecules/cm^2) integer, intent(in), dimension(2, ncol,nlay,nflav ) :: jeta interpolation indexes in eta - computed in interpolation() integer, intent(in), dimension( ncol,nlay ) :: jtemp interpolation indexes in temperature - computed in interpolation() integer, intent(in), dimension( ncol,nlay ) :: jpress interpolation indexes in pressure - computed in interpolation() real(kind=wp), intent(inout), dimension(ncol,nlay,ngpt) :: tau aborption optional depth public subroutine compute_tau_rayleigh (ncol, nlay, nbnd, ngpt, ngas, nflav, neta, npres, ntemp, gpoint_flavor, band_lims_gpt, krayl, idx_h2o, col_dry, col_gas, fminor, jeta, tropo, jtemp, tau_rayleigh) bind(C, name=\"0\") Arguments Type Intent Optional Attributes Name integer, intent(in) :: ncol input dimensions integer, intent(in) :: nlay input dimensions integer, intent(in) :: nbnd input dimensions integer, intent(in) :: ngpt input dimensions integer, intent(in) :: ngas table dimensions integer, intent(in) :: nflav table dimensions integer, intent(in) :: neta table dimensions integer, intent(in) :: npres table dimensions integer, intent(in) :: ntemp table dimensions integer, intent(in), dimension(2,ngpt) :: gpoint_flavor major gas flavor (pair) by upper/lower, g-point integer, intent(in), dimension(2,nbnd) :: band_lims_gpt start and end g-point for each band real(kind=wp), intent(in), dimension(ntemp,neta,ngpt,2) :: krayl Rayleigh scattering coefficients integer, intent(in) :: idx_h2o index of water vapor in col_gas real(kind=wp), intent(in), dimension(ncol,nlay) :: col_dry column amount of dry air real(kind=wp), intent(in), dimension(ncol,nlay,0:ngas) :: col_gas input column gas amount (molecules/cm^2) real(kind=wp), intent(in), dimension(2,2,ncol,nlay,nflav) :: fminor interpolation weights for major gases - computed in interpolation() integer, intent(in), dimension(2, ncol,nlay,nflav) :: jeta interpolation indexes in eta - computed in interpolation() logical(kind=wl), intent(in), dimension(ncol,nlay) :: tropo use upper- or lower-atmospheric tables? integer, intent(in), dimension(ncol,nlay) :: jtemp interpolation indexes in temperature - computed in interpolation() real(kind=wp), intent(out), dimension(ncol,nlay,ngpt) :: tau_rayleigh Rayleigh optical depth public subroutine interpolation (ncol, nlay, ngas, nflav, neta, npres, ntemp, flavor, press_ref_log, temp_ref, press_ref_log_delta, temp_ref_min, temp_ref_delta, press_ref_trop_log, vmr_ref, play, tlay, col_gas, jtemp, fmajor, fminor, col_mix, tropo, jeta, jpress) bind(C, name=\"0\") Compute interpolation coefficients\nfor calculations of major optical depths, minor optical depths, Rayleigh,\nand Planck fractions Arguments Type Intent Optional Attributes Name integer, intent(in) :: ncol physical domain size integer, intent(in) :: nlay physical domain size integer, intent(in) :: ngas k-distribution table dimensions integer, intent(in) :: nflav k-distribution table dimensions integer, intent(in) :: neta k-distribution table dimensions integer, intent(in) :: npres k-distribution table dimensions integer, intent(in) :: ntemp k-distribution table dimensions integer, intent(in), dimension(2,nflav) :: flavor index into vmr_ref of major gases for each flavor real(kind=wp), intent(in), dimension(npres) :: press_ref_log log of pressure dimension in RRTMGP tables real(kind=wp), intent(in), dimension(ntemp) :: temp_ref temperature dimension in RRTMGP tables real(kind=wp), intent(in) :: press_ref_log_delta constants related to RRTMGP tables real(kind=wp), intent(in) :: temp_ref_min constants related to RRTMGP tables real(kind=wp), intent(in) :: temp_ref_delta constants related to RRTMGP tables real(kind=wp), intent(in) :: press_ref_trop_log constants related to RRTMGP tables real(kind=wp), intent(in), dimension(2,0:ngas,ntemp) :: vmr_ref reference volume mixing ratios used in compute \"binary species parameter\" eta real(kind=wp), intent(in), dimension(ncol,nlay) :: play input pressure (Pa?) and temperature (K) real(kind=wp), intent(in), dimension(ncol,nlay) :: tlay input pressure (Pa?) and temperature (K) real(kind=wp), intent(in), dimension(ncol,nlay,0:ngas) :: col_gas input column gas amount - molecules/cm^2 integer, intent(out), dimension(ncol,nlay) :: jtemp temperature and pressure interpolation indexes real(kind=wp), intent(out), dimension(2,2,2,ncol,nlay,nflav) :: fmajor Interpolation weights in pressure, eta, strat/trop real(kind=wp), intent(out), dimension(2,2, ncol,nlay,nflav) :: fminor Interpolation fraction in eta, strat/trop real(kind=wp), intent(out), dimension(2, ncol,nlay,nflav) :: col_mix combination of major species's column amounts (first index is strat/trop) logical(kind=wl), intent(out), dimension(ncol,nlay) :: tropo use lower (or upper) atmosphere tables integer, intent(out), dimension(2, ncol,nlay,nflav) :: jeta Index for binary species interpolation integer, intent(out), dimension(ncol,nlay) :: jpress temperature and pressure interpolation indexes","tags":"","loc":"module/mo_gas_optics_rrtmgp_kernels.html"},{"title":"mo_gas_optics_rrtmgp_kernels – RRTMGP kernels","text":"Uses mo_rte_util_array mo_rte_kind module~~mo_gas_optics_rrtmgp_kernels~2~~UsesGraph module~mo_gas_optics_rrtmgp_kernels~2 mo_gas_optics_rrtmgp_kernels mo_rte_util_array mo_rte_util_array module~mo_gas_optics_rrtmgp_kernels~2->mo_rte_util_array mo_rte_kind mo_rte_kind module~mo_gas_optics_rrtmgp_kernels~2->mo_rte_kind Help × Graph Key Nodes of different colours represent the following: Graph Key Module Module Submodule Submodule Subroutine Subroutine Function Function Program Program This Page's Entity This Page's Entity Solid arrows point from a submodule to the (sub)module which it is\n descended from. Dashed arrows point from a module or program unit to \n modules which it uses. Contents Interfaces compute_Planck_source compute_tau_absorption compute_tau_rayleigh interpolation Interfaces interface public subroutine compute_Planck_source(ncol, nlay, nbnd, ngpt, nflav, neta, npres, ntemp, nPlanckTemp, tlay, tlev, tsfc, sfc_lay, fmajor, jeta, tropo, jtemp, jpress, gpoint_bands, band_lims_gpt, pfracin, temp_ref_min, totplnk_delta, totplnk, gpoint_flavor, sfc_src, lay_src, lev_src, sfc_source_Jac) bind(C, name=\"0\") Arguments Type Intent Optional Attributes Name integer, intent(in) :: ncol input dimensions integer, intent(in) :: nlay input dimensions integer, intent(in) :: nbnd input dimensions integer, intent(in) :: ngpt input dimensions integer, intent(in) :: nflav table dimensions integer, intent(in) :: neta table dimensions integer, intent(in) :: npres table dimensions integer, intent(in) :: ntemp table dimensions integer, intent(in) :: nPlanckTemp table dimensions real(kind=wp), intent(in), dimension(ncol,nlay ) :: tlay temperature at layer centers (K) real(kind=wp), intent(in), dimension(ncol,nlay+1) :: tlev temperature at interfaces (K) real(kind=wp), intent(in), dimension(ncol ) :: tsfc surface temperture integer, intent(in) :: sfc_lay index into surface layer real(kind=wp), intent(in), dimension(2,2,2,ncol,nlay,nflav) :: fmajor interpolation weights for major gases - computed in interpolation() integer, intent(in), dimension(2, ncol,nlay,nflav) :: jeta interpolation indexes in eta - computed in interpolation() logical(kind=wl), intent(in), dimension( ncol,nlay) :: tropo use upper- or lower-atmospheric tables? integer, intent(in), dimension( ncol,nlay) :: jtemp interpolation indexes in temperature and pressure - computed in interpolation() integer, intent(in), dimension( ncol,nlay) :: jpress interpolation indexes in temperature and pressure - computed in interpolation() integer, intent(in), dimension(ngpt) :: gpoint_bands band to which each g-point belongs integer, intent(in), dimension(2, nbnd) :: band_lims_gpt start and end g-point for each band real(kind=wp), intent(in), dimension(ntemp,neta,npres+1,ngpt) :: pfracin Fraction of the Planck function in each g-point real(kind=wp), intent(in) :: temp_ref_min interpolation constants real(kind=wp), intent(in) :: totplnk_delta interpolation constants real(kind=wp), intent(in), dimension(nPlanckTemp,nbnd) :: totplnk Total Planck function by band at each temperature integer, intent(in), dimension(2,ngpt) :: gpoint_flavor major gas flavor (pair) by upper/lower, g-point real(kind=wp), intent(out), dimension(ncol, ngpt) :: sfc_src Planck emssion from the surface real(kind=wp), intent(out), dimension(ncol,nlay, ngpt) :: lay_src Planck emssion from layer centers real(kind=wp), intent(out), dimension(ncol,nlay+1,ngpt) :: lev_src Planck emission at layer boundaries real(kind=wp), intent(out), dimension(ncol, ngpt) :: sfc_source_Jac Jacobian (derivative) of the surface Planck source with respect to surface temperature interface public subroutine compute_tau_absorption(ncol, nlay, nbnd, ngpt, ngas, nflav, neta, npres, ntemp, nminorlower, nminorklower, nminorupper, nminorkupper, idx_h2o, gpoint_flavor, band_lims_gpt, kmajor, kminor_lower, kminor_upper, minor_limits_gpt_lower, minor_limits_gpt_upper, minor_scales_with_density_lower, minor_scales_with_density_upper, scale_by_complement_lower, scale_by_complement_upper, idx_minor_lower, idx_minor_upper, idx_minor_scaling_lower, idx_minor_scaling_upper, kminor_start_lower, kminor_start_upper, tropo, col_mix, fmajor, fminor, play, tlay, col_gas, jeta, jtemp, jpress, tau) bind(C, name=\"0\") Arguments Type Intent Optional Attributes Name integer, intent(in) :: ncol array sizes integer, intent(in) :: nlay array sizes integer, intent(in) :: nbnd array sizes integer, intent(in) :: ngpt array sizes integer, intent(in) :: ngas tables sizes integer, intent(in) :: nflav tables sizes integer, intent(in) :: neta tables sizes integer, intent(in) :: npres tables sizes integer, intent(in) :: ntemp tables sizes integer, intent(in) :: nminorlower table sizes integer, intent(in) :: nminorklower table sizes integer, intent(in) :: nminorupper table sizes integer, intent(in) :: nminorkupper table sizes integer, intent(in) :: idx_h2o index of water vapor in col_gas integer, intent(in), dimension(2,ngpt) :: gpoint_flavor major gas flavor (pair) by upper/lower, g-point integer, intent(in), dimension(2,nbnd) :: band_lims_gpt beginning and ending g-point for each band real(kind=wp), intent(in), dimension(ntemp,neta,npres+1,ngpt) :: kmajor absorption coefficient table - major gases real(kind=wp), intent(in), dimension(ntemp,neta,nminorklower) :: kminor_lower absorption coefficient table - minor gases, lower atmosphere real(kind=wp), intent(in), dimension(ntemp,neta,nminorkupper) :: kminor_upper absorption coefficient table - minor gases, upper atmosphere integer, intent(in), dimension(2,nminorlower) :: minor_limits_gpt_lower beginning and ending g-point for each minor gas integer, intent(in), dimension(2,nminorupper) :: minor_limits_gpt_upper logical(kind=wl), intent(in), dimension( nminorlower) :: minor_scales_with_density_lower generic treatment of minor gases - scales with density (e.g. continuum, collision-induced absorption)? logical(kind=wl), intent(in), dimension( nminorupper) :: minor_scales_with_density_upper logical(kind=wl), intent(in), dimension( nminorlower) :: scale_by_complement_lower generic treatment of minor gases - scale by density (e.g. self-continuum) or complement? logical(kind=wl), intent(in), dimension( nminorupper) :: scale_by_complement_upper integer, intent(in), dimension( nminorlower) :: idx_minor_lower index of each minor gas in col_gas integer, intent(in), dimension( nminorupper) :: idx_minor_upper integer, intent(in), dimension( nminorlower) :: idx_minor_scaling_lower for this minor gas, index of the \"scaling gas\" in col_gas integer, intent(in), dimension( nminorupper) :: idx_minor_scaling_upper integer, intent(in), dimension( nminorlower) :: kminor_start_lower starting g-point index in minor gas absorption table integer, intent(in), dimension( nminorupper) :: kminor_start_upper logical(kind=wl), intent(in), dimension(ncol,nlay) :: tropo use upper- or lower-atmospheric tables? real(kind=wp), intent(in), dimension(2, ncol,nlay,nflav ) :: col_mix combination of major species's column amounts - computed in interpolation() real(kind=wp), intent(in), dimension(2,2,2,ncol,nlay,nflav ) :: fmajor interpolation weights for major gases - computed in interpolation() real(kind=wp), intent(in), dimension(2,2, ncol,nlay,nflav ) :: fminor interpolation weights for minor gases - computed in interpolation() real(kind=wp), intent(in), dimension( ncol,nlay ) :: play input temperature and pressure real(kind=wp), intent(in), dimension( ncol,nlay ) :: tlay input temperature and pressure real(kind=wp), intent(in), dimension( ncol,nlay,0:ngas) :: col_gas input column gas amount (molecules/cm^2) integer, intent(in), dimension(2, ncol,nlay,nflav ) :: jeta interpolation indexes in eta - computed in interpolation() integer, intent(in), dimension( ncol,nlay ) :: jtemp interpolation indexes in temperature - computed in interpolation() integer, intent(in), dimension( ncol,nlay ) :: jpress interpolation indexes in pressure - computed in interpolation() real(kind=wp), intent(inout), dimension(ncol,nlay,ngpt) :: tau aborption optional depth interface public subroutine compute_tau_rayleigh(ncol, nlay, nbnd, ngpt, ngas, nflav, neta, npres, ntemp, gpoint_flavor, band_lims_gpt, krayl, idx_h2o, col_dry, col_gas, fminor, jeta, tropo, jtemp, tau_rayleigh) bind(C, name=\"0\") Arguments Type Intent Optional Attributes Name integer, intent(in) :: ncol input dimensions integer, intent(in) :: nlay input dimensions integer, intent(in) :: nbnd input dimensions integer, intent(in) :: ngpt input dimensions integer, intent(in) :: ngas table dimensions integer, intent(in) :: nflav table dimensions integer, intent(in) :: neta table dimensions integer, intent(in) :: npres table dimensions integer, intent(in) :: ntemp table dimensions integer, intent(in), dimension(2,ngpt) :: gpoint_flavor major gas flavor (pair) by upper/lower, g-point integer, intent(in), dimension(2,nbnd) :: band_lims_gpt start and end g-point for each band real(kind=wp), intent(in), dimension(ntemp,neta,ngpt,2) :: krayl Rayleigh scattering coefficients integer, intent(in) :: idx_h2o index of water vapor in col_gas real(kind=wp), intent(in), dimension(ncol,nlay) :: col_dry column amount of dry air real(kind=wp), intent(in), dimension(ncol,nlay,0:ngas) :: col_gas input column gas amount (molecules/cm^2) real(kind=wp), intent(in), dimension(2,2,ncol,nlay,nflav) :: fminor interpolation weights for major gases - computed in interpolation() integer, intent(in), dimension(2, ncol,nlay,nflav) :: jeta interpolation indexes in eta - computed in interpolation() logical(kind=wl), intent(in), dimension(ncol,nlay) :: tropo use upper- or lower-atmospheric tables? integer, intent(in), dimension(ncol,nlay) :: jtemp interpolation indexes in temperature - computed in interpolation() real(kind=wp), intent(out), dimension(ncol,nlay,ngpt) :: tau_rayleigh Rayleigh optical depth interface public subroutine interpolation(ncol, nlay, ngas, nflav, neta, npres, ntemp, flavor, press_ref_log, temp_ref, press_ref_log_delta, temp_ref_min, temp_ref_delta, press_ref_trop_log, vmr_ref, play, tlay, col_gas, jtemp, fmajor, fminor, col_mix, tropo, jeta, jpress) bind(C, name=\"0\") Arguments Type Intent Optional Attributes Name integer, intent(in) :: ncol physical domain size integer, intent(in) :: nlay physical domain size integer, intent(in) :: ngas k-distribution table dimensions integer, intent(in) :: nflav k-distribution table dimensions integer, intent(in) :: neta k-distribution table dimensions integer, intent(in) :: npres k-distribution table dimensions integer, intent(in) :: ntemp k-distribution table dimensions integer, intent(in), dimension(2,nflav) :: flavor index into vmr_ref of major gases for each flavor real(kind=wp), intent(in), dimension(npres) :: press_ref_log log of pressure dimension in RRTMGP tables real(kind=wp), intent(in), dimension(ntemp) :: temp_ref temperature dimension in RRTMGP tables real(kind=wp), intent(in) :: press_ref_log_delta constants related to RRTMGP tables real(kind=wp), intent(in) :: temp_ref_min constants related to RRTMGP tables real(kind=wp), intent(in) :: temp_ref_delta constants related to RRTMGP tables real(kind=wp), intent(in) :: press_ref_trop_log constants related to RRTMGP tables real(kind=wp), intent(in), dimension(2,0:ngas,ntemp) :: vmr_ref reference volume mixing ratios used in compute \"binary species parameter\" eta real(kind=wp), intent(in), dimension(ncol,nlay) :: play input pressure (Pa?) and temperature (K) real(kind=wp), intent(in), dimension(ncol,nlay) :: tlay input pressure (Pa?) and temperature (K) real(kind=wp), intent(in), dimension(ncol,nlay,0:ngas) :: col_gas input column gas amount - molecules/cm^2 integer, intent(out), dimension(ncol,nlay) :: jtemp temperature and pressure interpolation indexes real(kind=wp), intent(out), dimension(2,2,2,ncol,nlay,nflav) :: fmajor Interpolation weights in pressure, eta, strat/trop real(kind=wp), intent(out), dimension(2,2, ncol,nlay,nflav) :: fminor Interpolation fraction in eta, strat/trop real(kind=wp), intent(out), dimension(2, ncol,nlay,nflav) :: col_mix combination of major species's column amounts (first index is strat/trop) logical(kind=wl), intent(out), dimension(ncol,nlay) :: tropo use lower (or upper) atmosphere tables integer, intent(out), dimension(2, ncol,nlay,nflav) :: jeta Index for binary species interpolation integer, intent(out), dimension(ncol,nlay) :: jpress temperature and pressure interpolation indexes","tags":"","loc":"module/mo_gas_optics_rrtmgp_kernels~2.html"},{"title":"mo_gas_optics_rrtmgp_kernels.F90 – RRTMGP kernels","text":"Contents Modules mo_gas_optics_rrtmgp_kernels Source Code mo_gas_optics_rrtmgp_kernels.F90 Source Code ! This code is part of ! RRTM for GCM Applications - Parallel (RRTMGP) ! ! Eli Mlawer and Robert Pincus ! Andre Wehe and Jennifer Delamere ! email: rrtmgp@aer.com ! ! Copyright 2015-, Atmospheric and Environmental Research, ! Regents of the University of Colorado, Trustees of Columbia University. All right reserved. ! ! Use and duplication is permitted under the terms of the ! BSD 3-clause license, see http://opensource.org/licenses/BSD-3-Clause ! ------------------------------------------------------------------------------------------------- !> !> ## Numeric calculations for gas optics. Absorption and Rayleigh optical depths, Planck source functions. !> !> - Interpolation coefficients are computed, then used in subsequent routines. !> - All applications will call compute_tau_absorption(); !> compute_tau_rayleigh() and/or compute_Planck_source() will be called depending on the !> configuration of the k-distribution. !> - The details of the interpolation scheme are not particaulrly important as long as arrays including !> tables are passed consisently between kernels. !> ! ------------------------------------------------------------------------------------------------- module mo_gas_optics_rrtmgp_kernels use mo_rte_kind , only : wp , wl use mo_rte_util_array , only : zero_array implicit none private public :: interpolation , compute_tau_absorption , compute_tau_rayleigh , compute_Planck_source contains ! -------------------------------------------------------------------------------------- !> Compute interpolation coefficients !> for calculations of major optical depths, minor optical depths, Rayleigh, !> and Planck fractions subroutine interpolation ( & ncol , nlay , ngas , nflav , neta , npres , ntemp , & flavor , & press_ref_log , temp_ref , press_ref_log_delta , & temp_ref_min , temp_ref_delta , press_ref_trop_log , & vmr_ref , & play , tlay , col_gas , & jtemp , fmajor , fminor , col_mix , tropo , jeta , jpress ) bind ( C , name = \"rrtmgp_interpolation\" ) ! input dimensions integer , intent ( in ) :: ncol , nlay !! physical domain size integer , intent ( in ) :: ngas , nflav , neta , npres , ntemp !! k-distribution table dimensions integer , dimension ( 2 , nflav ), intent ( in ) :: flavor !! index into vmr_ref of major gases for each flavor real ( wp ), dimension ( npres ), intent ( in ) :: press_ref_log !! log of pressure dimension in RRTMGP tables real ( wp ), dimension ( ntemp ), intent ( in ) :: temp_ref !! temperature dimension in RRTMGP tables real ( wp ), intent ( in ) :: press_ref_log_delta , & temp_ref_min , temp_ref_delta , & press_ref_trop_log !! constants related to RRTMGP tables real ( wp ), dimension ( 2 , 0 : ngas , ntemp ), intent ( in ) :: vmr_ref !! reference volume mixing ratios used in compute \"binary species parameter\" eta ! inputs from profile or parent function real ( wp ), dimension ( ncol , nlay ), intent ( in ) :: play , tlay !! input pressure (Pa?) and temperature (K) real ( wp ), dimension ( ncol , nlay , 0 : ngas ), intent ( in ) :: col_gas !! input column gas amount - molecules/cm^2 ! outputs integer , dimension ( ncol , nlay ), intent ( out ) :: jtemp , jpress !! temperature and pressure interpolation indexes logical ( wl ), dimension ( ncol , nlay ), intent ( out ) :: tropo !! use lower (or upper) atmosphere tables integer , dimension ( 2 , ncol , nlay , nflav ), intent ( out ) :: jeta !! Index for binary species interpolation #if !defined(__INTEL_LLVM_COMPILER) && __INTEL_COMPILER >= 1910 ! A performance-hitting workaround for the vectorization problem reported in ! https://github.com/earth-system-radiation/rte-rrtmgp/issues/159 ! The known affected compilers are Intel Fortran Compiler Classic ! 2021.4, 2021.5 and 2022.1. We do not limit the workaround to these ! versions because it is not clear when the compiler bug will be fixed, see ! https://community.intel.com/t5/Intel-Fortran-Compiler/Compiler-vectorization-bug/m-p/1362591. ! We, however, limit the workaround to the Classic versions only since the ! problem is not confirmed for the Intel Fortran Compiler oneAPI (a.k.a ! 'ifx'), which does not mean there is none though. real ( wp ), dimension (:, :, :, :), intent ( out ) :: col_mix #else real ( wp ), dimension ( 2 , ncol , nlay , nflav ), intent ( out ) :: col_mix !! combination of major species's column amounts (first index is strat/trop) #endif real ( wp ), dimension ( 2 , 2 , 2 , ncol , nlay , nflav ), intent ( out ) :: fmajor !! Interpolation weights in pressure, eta, strat/trop real ( wp ), dimension ( 2 , 2 , ncol , nlay , nflav ), intent ( out ) :: fminor !! Interpolation fraction in eta, strat/trop ! ----------------- ! local real ( wp ), dimension ( ncol , nlay ) :: ftemp , fpress ! interpolation fraction for temperature, pressure real ( wp ) :: locpress ! needed to find location in pressure grid real ( wp ) :: ratio_eta_half ! ratio of vmrs of major species that defines eta=0.5 ! for given flavor and reference temperature level real ( wp ) :: eta , feta ! binary_species_parameter, interpolation variable for eta real ( wp ) :: loceta ! needed to find location in eta grid real ( wp ) :: ftemp_term ! ----------------- ! local indexes integer :: icol , ilay , iflav , igases ( 2 ), itropo , itemp do ilay = 1 , nlay do icol = 1 , ncol ! index and factor for temperature interpolation jtemp ( icol , ilay ) = int (( tlay ( icol , ilay ) - ( temp_ref_min - temp_ref_delta )) / temp_ref_delta ) jtemp ( icol , ilay ) = min ( ntemp - 1 , max ( 1 , jtemp ( icol , ilay ))) ! limit the index range ftemp ( icol , ilay ) = ( tlay ( icol , ilay ) - temp_ref ( jtemp ( icol , ilay ))) / temp_ref_delta ! index and factor for pressure interpolation locpress = 1._wp + ( log ( play ( icol , ilay )) - press_ref_log ( 1 )) / press_ref_log_delta jpress ( icol , ilay ) = min ( npres - 1 , max ( 1 , int ( locpress ))) fpress ( icol , ilay ) = locpress - float ( jpress ( icol , ilay )) ! determine if in lower or upper part of atmosphere tropo ( icol , ilay ) = log ( play ( icol , ilay )) > press_ref_trop_log end do end do do iflav = 1 , nflav igases (:) = flavor (:, iflav ) do ilay = 1 , nlay do icol = 1 , ncol ! itropo = 1 lower atmosphere; itropo = 2 upper atmosphere itropo = merge ( 1 , 2 , tropo ( icol , ilay )) ! loop over implemented combinations of major species do itemp = 1 , 2 ! compute interpolation fractions needed for lower, then upper reference temperature level ! compute binary species parameter (eta) for flavor and temperature and ! associated interpolation index and factors ratio_eta_half = vmr_ref ( itropo , igases ( 1 ),( jtemp ( icol , ilay ) + itemp - 1 )) / & vmr_ref ( itropo , igases ( 2 ),( jtemp ( icol , ilay ) + itemp - 1 )) col_mix ( itemp , icol , ilay , iflav ) = col_gas ( icol , ilay , igases ( 1 )) + ratio_eta_half * col_gas ( icol , ilay , igases ( 2 )) ! Keep this commented lines. Fortran does allow for ! substantial optimizations and in this merge cases may ! happen that all expressions are evaluated and so create ! a division by zero. In the if construct this should be ! save. Merge is the way to do it in general inside of ! loops, but sometimes it may not work. ! ! eta = merge(col_gas(icol,ilay,igases(1)) / col_mix(itemp,icol,ilay,iflav), 0.5_wp, & ! col_mix(itemp,icol,ilay,iflav) > 2._wp * tiny(col_mix)) ! ! In essence: do not turn it back to merge(...)! if ( col_mix ( itemp , icol , ilay , iflav ) > 2._wp * tiny ( col_mix )) then eta = col_gas ( icol , ilay , igases ( 1 )) / col_mix ( itemp , icol , ilay , iflav ) else eta = 0.5_wp endif loceta = eta * float ( neta - 1 ) jeta ( itemp , icol , ilay , iflav ) = min ( int ( loceta ) + 1 , neta - 1 ) feta = mod ( loceta , 1.0_wp ) ! compute interpolation fractions needed for minor species ! ftemp_term = (1._wp-ftemp(icol,ilay)) for itemp = 1, ftemp(icol,ilay) for itemp=2 ftemp_term = ( real ( 2 - itemp , wp ) + real ( 2 * itemp - 3 , wp ) * ftemp ( icol , ilay )) fminor ( 1 , itemp , icol , ilay , iflav ) = ( 1._wp - feta ) * ftemp_term fminor ( 2 , itemp , icol , ilay , iflav ) = feta * ftemp_term ! compute interpolation fractions needed for major species fmajor ( 1 , 1 , itemp , icol , ilay , iflav ) = ( 1._wp - fpress ( icol , ilay )) * fminor ( 1 , itemp , icol , ilay , iflav ) fmajor ( 2 , 1 , itemp , icol , ilay , iflav ) = ( 1._wp - fpress ( icol , ilay )) * fminor ( 2 , itemp , icol , ilay , iflav ) fmajor ( 1 , 2 , itemp , icol , ilay , iflav ) = fpress ( icol , ilay ) * fminor ( 1 , itemp , icol , ilay , iflav ) fmajor ( 2 , 2 , itemp , icol , ilay , iflav ) = fpress ( icol , ilay ) * fminor ( 2 , itemp , icol , ilay , iflav ) end do ! reference temperatures end do ! icol end do ! ilay end do ! iflav end subroutine interpolation ! -------------------------------------------------------------------------------------- ! !> Compute minor and major species optical depth using pre-computed interpolation coefficients !> (jeta,jtemp,jpress) and weights (fmajor, fminor) ! subroutine compute_tau_absorption ( & ncol , nlay , nbnd , ngpt , & ! dimensions ngas , nflav , neta , npres , ntemp , & nminorlower , nminorklower , & ! number of minor contributors, total num absorption coeffs nminorupper , nminorkupper , & idx_h2o , & gpoint_flavor , & band_lims_gpt , & kmajor , & kminor_lower , & kminor_upper , & minor_limits_gpt_lower , & minor_limits_gpt_upper , & minor_scales_with_density_lower , & minor_scales_with_density_upper , & scale_by_complement_lower , & scale_by_complement_upper , & idx_minor_lower , & idx_minor_upper , & idx_minor_scaling_lower , & idx_minor_scaling_upper , & kminor_start_lower , & kminor_start_upper , & tropo , & col_mix , fmajor , fminor , & play , tlay , col_gas , & jeta , jtemp , jpress , & tau ) bind ( C , name = \"rrtmgp_compute_tau_absorption\" ) ! --------------------- ! input dimensions integer , intent ( in ) :: ncol , nlay , nbnd , ngpt !! array sizes integer , intent ( in ) :: ngas , nflav , neta , npres , ntemp !! tables sizes integer , intent ( in ) :: nminorlower , nminorklower , nminorupper , nminorkupper !! table sizes integer , intent ( in ) :: idx_h2o !! index of water vapor in col_gas ! --------------------- ! inputs from object integer , dimension ( 2 , ngpt ), intent ( in ) :: gpoint_flavor !! major gas flavor (pair) by upper/lower, g-point integer , dimension ( 2 , nbnd ), intent ( in ) :: band_lims_gpt !! beginning and ending g-point for each band real ( wp ), dimension ( ntemp , neta , npres + 1 , ngpt ), intent ( in ) :: kmajor !! absorption coefficient table - major gases real ( wp ), dimension ( ntemp , neta , nminorklower ), intent ( in ) :: kminor_lower !! absorption coefficient table - minor gases, lower atmosphere real ( wp ), dimension ( ntemp , neta , nminorkupper ), intent ( in ) :: kminor_upper !! absorption coefficient table - minor gases, upper atmosphere integer , dimension ( 2 , nminorlower ), intent ( in ) :: minor_limits_gpt_lower !! beginning and ending g-point for each minor gas integer , dimension ( 2 , nminorupper ), intent ( in ) :: minor_limits_gpt_upper logical ( wl ), dimension ( nminorlower ), intent ( in ) :: minor_scales_with_density_lower !! generic treatment of minor gases - scales with density (e.g. continuum, collision-induced absorption)? logical ( wl ), dimension ( nminorupper ), intent ( in ) :: minor_scales_with_density_upper logical ( wl ), dimension ( nminorlower ), intent ( in ) :: scale_by_complement_lower !! generic treatment of minor gases - scale by density (e.g. self-continuum) or complement? logical ( wl ), dimension ( nminorupper ), intent ( in ) :: scale_by_complement_upper integer , dimension ( nminorlower ), intent ( in ) :: idx_minor_lower !! index of each minor gas in col_gas integer , dimension ( nminorupper ), intent ( in ) :: idx_minor_upper integer , dimension ( nminorlower ), intent ( in ) :: idx_minor_scaling_lower !! for this minor gas, index of the \"scaling gas\" in col_gas integer , dimension ( nminorupper ), intent ( in ) :: idx_minor_scaling_upper integer , dimension ( nminorlower ), intent ( in ) :: kminor_start_lower !! starting g-point index in minor gas absorption table integer , dimension ( nminorupper ), intent ( in ) :: kminor_start_upper logical ( wl ), dimension ( ncol , nlay ), intent ( in ) :: tropo !! use upper- or lower-atmospheric tables? ! --------------------- ! inputs from profile or parent function real ( wp ), dimension ( 2 , ncol , nlay , nflav ), intent ( in ) :: col_mix !! combination of major species's column amounts - computed in interpolation() real ( wp ), dimension ( 2 , 2 , 2 , ncol , nlay , nflav ), intent ( in ) :: fmajor !! interpolation weights for major gases - computed in interpolation() real ( wp ), dimension ( 2 , 2 , ncol , nlay , nflav ), intent ( in ) :: fminor !! interpolation weights for minor gases - computed in interpolation() real ( wp ), dimension ( ncol , nlay ), intent ( in ) :: play , tlay !! input temperature and pressure real ( wp ), dimension ( ncol , nlay , 0 : ngas ), intent ( in ) :: col_gas !! input column gas amount (molecules/cm^2) integer , dimension ( 2 , ncol , nlay , nflav ), intent ( in ) :: jeta !! interpolation indexes in eta - computed in interpolation() integer , dimension ( ncol , nlay ), intent ( in ) :: jtemp !! interpolation indexes in temperature - computed in interpolation() integer , dimension ( ncol , nlay ), intent ( in ) :: jpress !! interpolation indexes in pressure - computed in interpolation() ! --------------------- ! output - optical depth real ( wp ), dimension ( ncol , nlay , ngpt ), intent ( inout ) :: tau !! aborption optional depth ! --------------------- ! Local variables ! logical :: top_at_1 integer , dimension ( ncol , 2 ) :: itropo_lower , itropo_upper ! ---------------------------------------------------------------- ! --------------------- ! Layer limits of upper, lower atmospheres ! --------------------- top_at_1 = play ( 1 , 1 ) < play ( 1 , nlay ) if ( top_at_1 ) then itropo_lower (:, 1 ) = minloc ( play , dim = 2 , mask = tropo ) itropo_lower (:, 2 ) = nlay itropo_upper (:, 1 ) = 1 itropo_upper (:, 2 ) = maxloc ( play , dim = 2 , mask = (. not . tropo )) else itropo_lower (:, 1 ) = 1 itropo_lower (:, 2 ) = minloc ( play , dim = 2 , mask = tropo ) itropo_upper (:, 1 ) = maxloc ( play , dim = 2 , mask = (. not . tropo )) itropo_upper (:, 2 ) = nlay end if ! --------------------- ! Major Species ! --------------------- call gas_optical_depths_major ( & ncol , nlay , nbnd , ngpt , & ! dimensions nflav , neta , npres , ntemp , & gpoint_flavor , & band_lims_gpt , & kmajor , & col_mix , fmajor , & jeta , tropo , jtemp , jpress , & tau ) ! --------------------- ! Minor Species - lower ! --------------------- call gas_optical_depths_minor ( & ncol , nlay , ngpt , & ! dimensions ngas , nflav , ntemp , neta , & nminorlower , nminorklower , & idx_h2o , & gpoint_flavor ( 1 ,:), & kminor_lower , & minor_limits_gpt_lower , & minor_scales_with_density_lower , & scale_by_complement_lower , & idx_minor_lower , & idx_minor_scaling_lower , & kminor_start_lower , & play , tlay , & col_gas , fminor , jeta , & itropo_lower , jtemp , & tau ) ! --------------------- ! Minor Species - upper ! --------------------- call gas_optical_depths_minor ( & ncol , nlay , ngpt , & ! dimensions ngas , nflav , ntemp , neta , & nminorupper , nminorkupper , & idx_h2o , & gpoint_flavor ( 2 ,:), & kminor_upper , & minor_limits_gpt_upper , & minor_scales_with_density_upper , & scale_by_complement_upper , & idx_minor_upper , & idx_minor_scaling_upper , & kminor_start_upper , & play , tlay , & col_gas , fminor , jeta , & itropo_upper , jtemp , & tau ) end subroutine compute_tau_absorption ! -------------------------------------------------------------------------------------- ! -------------------------------------------------------------------------------------- ! ! compute minor species optical depths ! subroutine gas_optical_depths_major ( ncol , nlay , nbnd , ngpt ,& nflav , neta , npres , ntemp , & ! dimensions gpoint_flavor , band_lims_gpt , & ! inputs from object kmajor , & col_mix , fmajor , & jeta , tropo , jtemp , jpress , & ! local input tau ) ! input dimensions integer , intent ( in ) :: ncol , nlay , nbnd , ngpt , nflav , neta , npres , ntemp ! dimensions ! inputs from object integer , dimension ( 2 , ngpt ), intent ( in ) :: gpoint_flavor integer , dimension ( 2 , nbnd ), intent ( in ) :: band_lims_gpt ! start and end g-point for each band real ( wp ), dimension ( ntemp , neta , npres + 1 , ngpt ), intent ( in ) :: kmajor ! inputs from profile or parent function real ( wp ), dimension ( 2 , ncol , nlay , nflav ), intent ( in ) :: col_mix real ( wp ), dimension ( 2 , 2 , 2 , ncol , nlay , nflav ), intent ( in ) :: fmajor integer , dimension ( 2 , ncol , nlay , nflav ), intent ( in ) :: jeta logical ( wl ), dimension ( ncol , nlay ), intent ( in ) :: tropo integer , dimension ( ncol , nlay ), intent ( in ) :: jtemp , jpress ! outputs real ( wp ), dimension ( ncol , nlay , ngpt ), intent ( inout ) :: tau ! ----------------- ! local variables real ( wp ) :: tau_major ( ngpt ) ! major species optical depth ! local index integer :: icol , ilay , iflav , ibnd , itropo integer :: gptS , gptE ! optical depth calculation for major species do ibnd = 1 , nbnd gptS = band_lims_gpt ( 1 , ibnd ) gptE = band_lims_gpt ( 2 , ibnd ) do ilay = 1 , nlay do icol = 1 , ncol ! itropo = 1 lower atmosphere; itropo = 2 upper atmosphere itropo = merge ( 1 , 2 , tropo ( icol , ilay )) iflav = gpoint_flavor ( itropo , gptS ) !eta interpolation depends on band's flavor tau_major ( gptS : gptE ) = & ! interpolation in temperature, pressure, and eta interpolate3D_byflav ( col_mix (:, icol , ilay , iflav ), & fmajor (:,:,:, icol , ilay , iflav ), kmajor , & band_lims_gpt ( 1 , ibnd ), band_lims_gpt ( 2 , ibnd ), & jeta (:, icol , ilay , iflav ), jtemp ( icol , ilay ), jpress ( icol , ilay ) + itropo ) tau ( icol , ilay , gptS : gptE ) = tau ( icol , ilay , gptS : gptE ) + tau_major ( gptS : gptE ) end do end do end do end subroutine gas_optical_depths_major ! ---------------------------------------------------------- ! ! compute minor species optical depths ! subroutine gas_optical_depths_minor ( ncol , nlay , ngpt , & ngas , nflav , ntemp , neta , & nminor , nminork , & idx_h2o , & gpt_flv , & kminor , & minor_limits_gpt , & minor_scales_with_density , & scale_by_complement , & idx_minor , idx_minor_scaling , & kminor_start , & play , tlay , & col_gas , fminor , jeta , & layer_limits , jtemp , & tau ) integer , intent ( in ) :: ncol , nlay , ngpt integer , intent ( in ) :: ngas , nflav integer , intent ( in ) :: ntemp , neta , nminor , nminork integer , intent ( in ) :: idx_h2o integer , dimension ( ngpt ), intent ( in ) :: gpt_flv real ( wp ), dimension ( ntemp , neta , nminork ), intent ( in ) :: kminor integer , dimension ( 2 , nminor ), intent ( in ) :: minor_limits_gpt logical ( wl ), dimension ( nminor ), intent ( in ) :: minor_scales_with_density logical ( wl ), dimension ( nminor ), intent ( in ) :: scale_by_complement integer , dimension ( nminor ), intent ( in ) :: kminor_start integer , dimension ( nminor ), intent ( in ) :: idx_minor , idx_minor_scaling real ( wp ), dimension ( ncol , nlay ), intent ( in ) :: play , tlay real ( wp ), dimension ( ncol , nlay , 0 : ngas ), intent ( in ) :: col_gas real ( wp ), dimension ( 2 , 2 , ncol , nlay , nflav ), intent ( in ) :: fminor integer , dimension ( 2 , ncol , nlay , nflav ), intent ( in ) :: jeta integer , dimension ( ncol , 2 ), intent ( in ) :: layer_limits integer , dimension ( ncol , nlay ), intent ( in ) :: jtemp real ( wp ), dimension ( ncol , nlay , ngpt ), intent ( inout ) :: tau ! ----------------- ! local variables real ( wp ), parameter :: PaTohPa = 0.01_wp real ( wp ) :: vmr_fact , dry_fact ! conversion from column abundance to dry vol. mixing ratio; real ( wp ) :: scaling ! optical depth integer :: icol , ilay , iflav , imnr integer :: gptS , gptE real ( wp ), dimension ( ngpt ) :: tau_minor ! ----------------- ! ! Guard against layer limits being 0 -- that means don't do anything i.e. there are no ! layers with pressures in the upper or lower atmosphere respectively ! First check skips the routine entirely if all columns are out of bounds... ! if ( any ( layer_limits (:, 1 ) > 0 )) then do imnr = 1 , size ( scale_by_complement , dim = 1 ) ! loop over minor absorbers in each band do icol = 1 , ncol ! ! This check skips individual columns with no pressures in range ! if ( layer_limits ( icol , 1 ) > 0 ) then do ilay = layer_limits ( icol , 1 ), layer_limits ( icol , 2 ) ! ! Scaling of minor gas absortion coefficient begins with column amount of minor gas ! scaling = col_gas ( icol , ilay , idx_minor ( imnr )) ! ! Density scaling (e.g. for h2o continuum, collision-induced absorption) ! if ( minor_scales_with_density ( imnr )) then ! ! NOTE: P needed in hPa to properly handle density scaling. ! scaling = scaling * ( PaTohPa * play ( icol , ilay ) / tlay ( icol , ilay )) if ( idx_minor_scaling ( imnr ) > 0 ) then ! there is a second gas that affects this gas's absorption vmr_fact = 1._wp / col_gas ( icol , ilay , 0 ) dry_fact = 1._wp / ( 1._wp + col_gas ( icol , ilay , idx_h2o ) * vmr_fact ) ! scale by density of special gas if ( scale_by_complement ( imnr )) then ! scale by densities of all gases but the special one scaling = scaling * ( 1._wp - col_gas ( icol , ilay , idx_minor_scaling ( imnr )) * vmr_fact * dry_fact ) else scaling = scaling * ( col_gas ( icol , ilay , idx_minor_scaling ( imnr )) * vmr_fact * dry_fact ) endif endif endif ! ! Interpolation of absorption coefficient and calculation of optical depth ! ! Which gpoint range does this minor gas affect? gptS = minor_limits_gpt ( 1 , imnr ) gptE = minor_limits_gpt ( 2 , imnr ) iflav = gpt_flv ( gptS ) tau_minor ( gptS : gptE ) = scaling * & interpolate2D_byflav ( fminor (:,:, icol , ilay , iflav ), & kminor , & kminor_start ( imnr ), kminor_start ( imnr ) + ( gptE - gptS ), & jeta (:, icol , ilay , iflav ), jtemp ( icol , ilay )) tau ( icol , ilay , gptS : gptE ) = tau ( icol , ilay , gptS : gptE ) + tau_minor ( gptS : gptE ) enddo end if enddo enddo end if end subroutine gas_optical_depths_minor ! ---------------------------------------------------------- ! ! compute Rayleigh scattering optical depths ! subroutine compute_tau_rayleigh ( ncol , nlay , nbnd , ngpt , & ngas , nflav , neta , npres , ntemp , & gpoint_flavor , band_lims_gpt , & krayl , & idx_h2o , col_dry , col_gas , & fminor , jeta , tropo , jtemp , & tau_rayleigh ) bind ( C , name = \"rrtmgp_compute_tau_rayleigh\" ) integer , intent ( in ) :: ncol , nlay , nbnd , ngpt !! input dimensions integer , intent ( in ) :: ngas , nflav , neta , npres , ntemp !! table dimensions integer , dimension ( 2 , ngpt ), intent ( in ) :: gpoint_flavor !! major gas flavor (pair) by upper/lower, g-point integer , dimension ( 2 , nbnd ), intent ( in ) :: band_lims_gpt !! start and end g-point for each band real ( wp ), dimension ( ntemp , neta , ngpt , 2 ), intent ( in ) :: krayl !! Rayleigh scattering coefficients integer , intent ( in ) :: idx_h2o !! index of water vapor in col_gas real ( wp ), dimension ( ncol , nlay ), intent ( in ) :: col_dry !! column amount of dry air real ( wp ), dimension ( ncol , nlay , 0 : ngas ), intent ( in ) :: col_gas !! input column gas amount (molecules/cm^2) real ( wp ), dimension ( 2 , 2 , ncol , nlay , nflav ), intent ( in ) :: fminor !! interpolation weights for major gases - computed in interpolation() integer , dimension ( 2 , ncol , nlay , nflav ), intent ( in ) :: jeta !! interpolation indexes in eta - computed in interpolation() logical ( wl ), dimension ( ncol , nlay ), intent ( in ) :: tropo !! use upper- or lower-atmospheric tables? integer , dimension ( ncol , nlay ), intent ( in ) :: jtemp !! interpolation indexes in temperature - computed in interpolation() ! outputs real ( wp ), dimension ( ncol , nlay , ngpt ), intent ( out ) :: tau_rayleigh !! Rayleigh optical depth ! ----------------- ! local variables real ( wp ) :: k ( ngpt ) ! rayleigh scattering coefficient integer :: icol , ilay , iflav , ibnd , gptS , gptE integer :: itropo ! ----------------- do ibnd = 1 , nbnd gptS = band_lims_gpt ( 1 , ibnd ) gptE = band_lims_gpt ( 2 , ibnd ) do ilay = 1 , nlay do icol = 1 , ncol itropo = merge ( 1 , 2 , tropo ( icol , ilay )) ! itropo = 1 lower atmosphere;itropo = 2 upper atmosphere iflav = gpoint_flavor ( itropo , gptS ) !eta interpolation depends on band's flavor k ( gptS : gptE ) = interpolate2D_byflav ( fminor (:,:, icol , ilay , iflav ), & krayl (:,:,:, itropo ), & gptS , gptE , jeta (:, icol , ilay , iflav ), jtemp ( icol , ilay )) tau_rayleigh ( icol , ilay , gptS : gptE ) = k ( gptS : gptE ) * & ( col_gas ( icol , ilay , idx_h2o ) + col_dry ( icol , ilay )) end do end do end do end subroutine compute_tau_rayleigh ! ---------------------------------------------------------- subroutine compute_Planck_source ( & ncol , nlay , nbnd , ngpt , & nflav , neta , npres , ntemp , nPlanckTemp ,& tlay , tlev , tsfc , sfc_lay , & fmajor , jeta , tropo , jtemp , jpress , & gpoint_bands , band_lims_gpt , & pfracin , temp_ref_min , totplnk_delta , totplnk , gpoint_flavor , & sfc_src , lay_src , lev_src , sfc_source_Jac ) bind ( C , name = \"rrtmgp_compute_Planck_source\" ) integer , intent ( in ) :: ncol , nlay , nbnd , ngpt !! input dimensions integer , intent ( in ) :: nflav , neta , npres , ntemp , nPlanckTemp !! table dimensions real ( wp ), dimension ( ncol , nlay ), intent ( in ) :: tlay !! temperature at layer centers (K) real ( wp ), dimension ( ncol , nlay + 1 ), intent ( in ) :: tlev !! temperature at interfaces (K) real ( wp ), dimension ( ncol ), intent ( in ) :: tsfc !! surface temperture integer , intent ( in ) :: sfc_lay !! index into surface layer ! Interpolation variables real ( wp ), dimension ( 2 , 2 , 2 , ncol , nlay , nflav ), intent ( in ) :: fmajor !! interpolation weights for major gases - computed in interpolation() integer , dimension ( 2 , ncol , nlay , nflav ), intent ( in ) :: jeta !! interpolation indexes in eta - computed in interpolation() logical ( wl ), dimension ( ncol , nlay ), intent ( in ) :: tropo !! use upper- or lower-atmospheric tables? integer , dimension ( ncol , nlay ), intent ( in ) :: jtemp , jpress !! interpolation indexes in temperature and pressure - computed in interpolation() ! Table-specific integer , dimension ( ngpt ), intent ( in ) :: gpoint_bands !! band to which each g-point belongs integer , dimension ( 2 , nbnd ), intent ( in ) :: band_lims_gpt !! start and end g-point for each band real ( wp ), intent ( in ) :: temp_ref_min , totplnk_delta !! interpolation constants real ( wp ), dimension ( ntemp , neta , npres + 1 , ngpt ), intent ( in ) :: pfracin !! Fraction of the Planck function in each g-point real ( wp ), dimension ( nPlanckTemp , nbnd ), intent ( in ) :: totplnk !! Total Planck function by band at each temperature integer , dimension ( 2 , ngpt ), intent ( in ) :: gpoint_flavor !! major gas flavor (pair) by upper/lower, g-point real ( wp ), dimension ( ncol , ngpt ), intent ( out ) :: sfc_src !! Planck emission from the surface real ( wp ), dimension ( ncol , nlay , ngpt ), intent ( out ) :: lay_src !! Planck emission from layer centers real ( wp ), dimension ( ncol , nlay + 1 , ngpt ), intent ( out ) :: lev_src !! Planck emission from layer boundaries real ( wp ), dimension ( ncol , ngpt ), intent ( out ) :: sfc_source_Jac !! Jacobian (derivative) of the surface Planck source with respect to surface temperature ! ----------------- ! local real ( wp ), parameter :: delta_Tsurf = 1.0_wp integer :: ilay , icol , igpt , ibnd , itropo , iflav integer :: gptS , gptE real ( wp ), dimension ( 2 ), parameter :: one = [ 1._wp , 1._wp ] real ( wp ) :: pfrac ( ncol , nlay , ngpt ) real ( wp ) :: planck_function ( ncol , nlay + 1 , nbnd ) ! ----------------- ! Calculation of fraction of band's Planck irradiance associated with each g-point do ibnd = 1 , nbnd gptS = band_lims_gpt ( 1 , ibnd ) gptE = band_lims_gpt ( 2 , ibnd ) do ilay = 1 , nlay do icol = 1 , ncol ! itropo = 1 lower atmosphere; itropo = 2 upper atmosphere itropo = merge ( 1 , 2 , tropo ( icol , ilay )) iflav = gpoint_flavor ( itropo , gptS ) !eta interpolation depends on band's flavor pfrac ( icol , ilay , gptS : gptE ) = & ! interpolation in temperature, pressure, and eta interpolate3D_byflav ( one , fmajor (:,:,:, icol , ilay , iflav ), pfracin , & band_lims_gpt ( 1 , ibnd ), band_lims_gpt ( 2 , ibnd ), & jeta (:, icol , ilay , iflav ), jtemp ( icol , ilay ), jpress ( icol , ilay ) + itropo ) end do ! column end do ! layer end do ! band ! ! Planck function by band for the surface ! Compute surface source irradiance for g-point, equals band irradiance x fraction for g-point ! do icol = 1 , ncol planck_function ( icol , 1 , 1 : nbnd ) = interpolate1D ( tsfc ( icol ), temp_ref_min , totplnk_delta , totplnk ) planck_function ( icol , 2 , 1 : nbnd ) = interpolate1D ( tsfc ( icol ) + delta_Tsurf , temp_ref_min , totplnk_delta , totplnk ) ! ! Map to g-points ! do ibnd = 1 , nbnd gptS = band_lims_gpt ( 1 , ibnd ) gptE = band_lims_gpt ( 2 , ibnd ) do igpt = gptS , gptE sfc_src ( icol , igpt ) = pfrac ( icol , sfc_lay , igpt ) * planck_function ( icol , 1 , ibnd ) sfc_source_Jac ( icol , igpt ) = pfrac ( icol , sfc_lay , igpt ) * & ( planck_function ( icol , 2 , ibnd ) - planck_function ( icol , 1 , ibnd )) end do end do end do !icol do ilay = 1 , nlay do icol = 1 , ncol ! Compute layer source irradiance for g-point, equals band irradiance x fraction for g-point planck_function ( icol , ilay , 1 : nbnd ) = interpolate1D ( tlay ( icol , ilay ), temp_ref_min , totplnk_delta , totplnk ) end do end do ! ! Map to g-points ! do ibnd = 1 , nbnd gptS = band_lims_gpt ( 1 , ibnd ) gptE = band_lims_gpt ( 2 , ibnd ) do igpt = gptS , gptE do ilay = 1 , nlay do icol = 1 , ncol lay_src ( icol , ilay , igpt ) = pfrac ( icol , ilay , igpt ) * planck_function ( icol , ilay , ibnd ) end do end do end do end do ! compute level source irradiances for each g-point do icol = 1 , ncol planck_function ( icol , 1 , 1 : nbnd ) = interpolate1D ( tlev ( icol , 1 ), temp_ref_min , totplnk_delta , totplnk ) end do do ilay = 1 , nlay do icol = 1 , ncol planck_function ( icol , ilay + 1 , 1 : nbnd ) = interpolate1D ( tlev ( icol , ilay + 1 ), temp_ref_min , totplnk_delta , totplnk ) end do end do ! ! Map to g-points ! do ibnd = 1 , nbnd gptS = band_lims_gpt ( 1 , ibnd ) gptE = band_lims_gpt ( 2 , ibnd ) do igpt = gptS , gptE do icol = 1 , ncol lev_src ( icol , 1 , igpt ) = pfrac ( icol , 1 , igpt ) * planck_function ( icol , 1 , ibnd ) end do do ilay = 2 , nlay do icol = 1 , ncol lev_src ( icol , ilay , igpt ) = sqrt ( pfrac ( icol , ilay - 1 , igpt ) * & pfrac ( icol , ilay , igpt )) & * planck_function ( icol , ilay , ibnd ) end do end do do icol = 1 , ncol lev_src ( icol , nlay + 1 , igpt ) = pfrac ( icol , nlay , igpt ) * planck_function ( icol , nlay + 1 , ibnd ) end do end do end do end subroutine compute_Planck_source ! ---------------------------------------------------------- ! ! One dimensional interpolation -- return all values along second table dimension ! pure function interpolate1D ( val , offset , delta , table ) result ( res ) ! input real ( wp ), intent ( in ) :: val , & ! axis value at which to evaluate table offset , & ! minimum of table axis delta ! step size of table axis real ( wp ), dimension (:,:), & intent ( in ) :: table ! dimensions (axis, values) ! output real ( wp ), dimension ( size ( table , dim = 2 )) :: res ! local real ( wp ) :: val0 ! fraction index adjusted by offset and delta integer :: index ! index term real ( wp ) :: frac ! fractional term ! ------------------------------------- val0 = ( val - offset ) / delta frac = val0 - int ( val0 ) ! get fractional part index = min ( size ( table , dim = 1 ) - 1 , max ( 1 , int ( val0 ) + 1 )) ! limit the index range res (:) = table ( index ,:) + frac * ( table ( index + 1 ,:) - table ( index ,:)) end function interpolate1D ! ---------------------------------------------------------- ! This function returns a range of values from a subset (in gpoint) of the k table ! pure function interpolate2D_byflav ( fminor , k , gptS , gptE , jeta , jtemp ) result ( res ) real ( wp ), dimension ( 2 , 2 ), intent ( in ) :: fminor ! interpolation fractions for minor species ! index(1) : reference eta level (temperature dependent) ! index(2) : reference temperature level real ( wp ), dimension (:,:,:), intent ( in ) :: k ! (g-point, eta, temp) integer , intent ( in ) :: gptS , gptE , jtemp ! interpolation index for temperature integer , dimension ( 2 ), intent ( in ) :: jeta ! interpolation index for binary species parameter (eta) real ( wp ), dimension ( gptE - gptS + 1 ) :: res ! the result ! Local variable integer :: igpt ! each code block is for a different reference temperature do igpt = 1 , gptE - gptS + 1 res ( igpt ) = fminor ( 1 , 1 ) * k ( jtemp , jeta ( 1 ) , gptS + igpt - 1 ) + & fminor ( 2 , 1 ) * k ( jtemp , jeta ( 1 ) + 1 , gptS + igpt - 1 ) + & fminor ( 1 , 2 ) * k ( jtemp + 1 , jeta ( 2 ) , gptS + igpt - 1 ) + & fminor ( 2 , 2 ) * k ( jtemp + 1 , jeta ( 2 ) + 1 , gptS + igpt - 1 ) end do end function interpolate2D_byflav ! ---------------------------------------------------------- pure function interpolate3D_byflav ( scaling , fmajor , k , gptS , gptE , jeta , jtemp , jpress ) result ( res ) real ( wp ), dimension ( 2 ), intent ( in ) :: scaling real ( wp ), dimension ( 2 , 2 , 2 ), intent ( in ) :: fmajor ! interpolation fractions for major species ! index(1) : reference eta level (temperature dependent) ! index(2) : reference pressure level ! index(3) : reference temperature level real ( wp ), dimension (:,:,:,:), intent ( in ) :: k ! (temp,eta,press,gpt) integer , intent ( in ) :: gptS , gptE integer , dimension ( 2 ), intent ( in ) :: jeta ! interpolation index for binary species parameter (eta) integer , intent ( in ) :: jtemp ! interpolation index for temperature integer , intent ( in ) :: jpress ! interpolation index for pressure real ( wp ), dimension ( gptS : gptE ) :: res ! the result ! Local variable integer :: igpt ! each code block is for a different reference temperature do igpt = gptS , gptE res ( igpt ) = & scaling ( 1 ) * & ( fmajor ( 1 , 1 , 1 ) * k ( jtemp , jeta ( 1 ) , jpress - 1 , igpt ) + & fmajor ( 2 , 1 , 1 ) * k ( jtemp , jeta ( 1 ) + 1 , jpress - 1 , igpt ) + & fmajor ( 1 , 2 , 1 ) * k ( jtemp , jeta ( 1 ) , jpress , igpt ) + & fmajor ( 2 , 2 , 1 ) * k ( jtemp , jeta ( 1 ) + 1 , jpress , igpt ) ) + & scaling ( 2 ) * & ( fmajor ( 1 , 1 , 2 ) * k ( jtemp + 1 , jeta ( 2 ) , jpress - 1 , igpt ) + & fmajor ( 2 , 1 , 2 ) * k ( jtemp + 1 , jeta ( 2 ) + 1 , jpress - 1 , igpt ) + & fmajor ( 1 , 2 , 2 ) * k ( jtemp + 1 , jeta ( 2 ) , jpress , igpt ) + & fmajor ( 2 , 2 , 2 ) * k ( jtemp + 1 , jeta ( 2 ) + 1 , jpress , igpt ) ) end do end function interpolate3D_byflav end module mo_gas_optics_rrtmgp_kernels","tags":"","loc":"sourcefile/mo_gas_optics_rrtmgp_kernels.f90.html"},{"title":"mo_gas_optics_rrtmgp_kernels.F90 – RRTMGP kernels","text":"Contents Modules mo_gas_optics_rrtmgp_kernels Source Code mo_gas_optics_rrtmgp_kernels.F90 Source Code module mo_gas_optics_rrtmgp_kernels use mo_rte_kind , only : wp , wl use mo_rte_util_array , only : zero_array implicit none private public :: interpolation , compute_tau_absorption , compute_tau_rayleigh , compute_Planck_source ! ------------------------------------------------------------------------------------------------------------------ interface subroutine interpolation ( & ncol , nlay , ngas , nflav , neta , npres , ntemp , & flavor , & press_ref_log , temp_ref , press_ref_log_delta , & temp_ref_min , temp_ref_delta , press_ref_trop_log , & vmr_ref , & play , tlay , col_gas , & jtemp , fmajor , fminor , col_mix , tropo , jeta , jpress ) bind ( C , name = \"rrtmgp_interpolation\" ) use mo_rte_kind , only : wp , wl ! input dimensions integer , intent ( in ) :: ncol , nlay !! physical domain size integer , intent ( in ) :: ngas , nflav , neta , npres , ntemp !! k-distribution table dimensions integer , dimension ( 2 , nflav ), intent ( in ) :: flavor !! index into vmr_ref of major gases for each flavor real ( wp ), dimension ( npres ), intent ( in ) :: press_ref_log !! log of pressure dimension in RRTMGP tables real ( wp ), dimension ( ntemp ), intent ( in ) :: temp_ref !! temperature dimension in RRTMGP tables real ( wp ), intent ( in ) :: press_ref_log_delta , & temp_ref_min , temp_ref_delta , & press_ref_trop_log !! constants related to RRTMGP tables real ( wp ), dimension ( 2 , 0 : ngas , ntemp ), intent ( in ) :: vmr_ref !! reference volume mixing ratios used in compute \"binary species parameter\" eta ! inputs from profile or parent function real ( wp ), dimension ( ncol , nlay ), intent ( in ) :: play , tlay !! input pressure (Pa?) and temperature (K) real ( wp ), dimension ( ncol , nlay , 0 : ngas ), intent ( in ) :: col_gas !! input column gas amount - molecules/cm^2 ! outputs integer , dimension ( ncol , nlay ), intent ( out ) :: jtemp , jpress !! temperature and pressure interpolation indexes logical ( wl ), dimension ( ncol , nlay ), intent ( out ) :: tropo !! use lower (or upper) atmosphere tables integer , dimension ( 2 , ncol , nlay , nflav ), intent ( out ) :: jeta !! Index for binary species interpolation #if !defined(__INTEL_LLVM_COMPILER) && __INTEL_COMPILER >= 2021 ! A performance-hitting workaround for the vectorization problem reported in ! https://github.com/earth-system-radiation/rte-rrtmgp/issues/159 ! The known affected compilers are Intel Fortran Compiler Classic ! 2021.4, 2021.5 and 2022.1. We do not limit the workaround to these ! versions because it is not clear when the compiler bug will be fixed, see ! https://community.intel.com/t5/Intel-Fortran-Compiler/Compiler-vectorization-bug/m-p/1362591. ! We, however, limit the workaround to the Classic versions only since the ! problem is not confirmed for the Intel Fortran Compiler oneAPI (a.k.a ! 'ifx'), which does not mean there is none though. real ( wp ), dimension (:, :, :, :), intent ( out ) :: col_mix #else real ( wp ), dimension ( 2 , ncol , nlay , nflav ), intent ( out ) :: col_mix !! combination of major species's column amounts (first index is strat/trop) #endif real ( wp ), dimension ( 2 , 2 , 2 , ncol , nlay , nflav ), intent ( out ) :: fmajor !! Interpolation weights in pressure, eta, strat/trop real ( wp ), dimension ( 2 , 2 , ncol , nlay , nflav ), intent ( out ) :: fminor !! Interpolation fraction in eta, strat/trop end subroutine interpolation end interface ! ------------------------------------------------------------------------------------------------------------------ interface subroutine compute_tau_absorption ( & ncol , nlay , nbnd , ngpt , & ! dimensions ngas , nflav , neta , npres , ntemp , & nminorlower , nminorklower , & ! number of minor contributors, total num absorption coeffs nminorupper , nminorkupper , & idx_h2o , & gpoint_flavor , & band_lims_gpt , & kmajor , & kminor_lower , & kminor_upper , & minor_limits_gpt_lower , & minor_limits_gpt_upper , & minor_scales_with_density_lower , & minor_scales_with_density_upper , & scale_by_complement_lower , & scale_by_complement_upper , & idx_minor_lower , & idx_minor_upper , & idx_minor_scaling_lower , & idx_minor_scaling_upper , & kminor_start_lower , & kminor_start_upper , & tropo , & col_mix , fmajor , fminor , & play , tlay , col_gas , & jeta , jtemp , jpress , & tau ) bind ( C , name = \"rrtmgp_compute_tau_absorption\" ) ! --------------------- use mo_rte_kind , only : wp , wl ! input dimensions integer , intent ( in ) :: ncol , nlay , nbnd , ngpt !! array sizes integer , intent ( in ) :: ngas , nflav , neta , npres , ntemp !! tables sizes integer , intent ( in ) :: nminorlower , nminorklower , nminorupper , nminorkupper !! table sizes integer , intent ( in ) :: idx_h2o !! index of water vapor in col_gas ! --------------------- ! inputs from object integer , dimension ( 2 , ngpt ), intent ( in ) :: gpoint_flavor !! major gas flavor (pair) by upper/lower, g-point integer , dimension ( 2 , nbnd ), intent ( in ) :: band_lims_gpt !! beginning and ending g-point for each band real ( wp ), dimension ( ntemp , neta , npres + 1 , ngpt ), intent ( in ) :: kmajor !! absorption coefficient table - major gases real ( wp ), dimension ( ntemp , neta , nminorklower ), intent ( in ) :: kminor_lower !! absorption coefficient table - minor gases, lower atmosphere real ( wp ), dimension ( ntemp , neta , nminorkupper ), intent ( in ) :: kminor_upper !! absorption coefficient table - minor gases, upper atmosphere integer , dimension ( 2 , nminorlower ), intent ( in ) :: minor_limits_gpt_lower !! beginning and ending g-point for each minor gas integer , dimension ( 2 , nminorupper ), intent ( in ) :: minor_limits_gpt_upper logical ( wl ), dimension ( nminorlower ), intent ( in ) :: minor_scales_with_density_lower !! generic treatment of minor gases - scales with density (e.g. continuum, collision-induced absorption)? logical ( wl ), dimension ( nminorupper ), intent ( in ) :: minor_scales_with_density_upper logical ( wl ), dimension ( nminorlower ), intent ( in ) :: scale_by_complement_lower !! generic treatment of minor gases - scale by density (e.g. self-continuum) or complement? logical ( wl ), dimension ( nminorupper ), intent ( in ) :: scale_by_complement_upper integer , dimension ( nminorlower ), intent ( in ) :: idx_minor_lower !! index of each minor gas in col_gas integer , dimension ( nminorupper ), intent ( in ) :: idx_minor_upper integer , dimension ( nminorlower ), intent ( in ) :: idx_minor_scaling_lower !! for this minor gas, index of the \"scaling gas\" in col_gas integer , dimension ( nminorupper ), intent ( in ) :: idx_minor_scaling_upper integer , dimension ( nminorlower ), intent ( in ) :: kminor_start_lower !! starting g-point index in minor gas absorption table integer , dimension ( nminorupper ), intent ( in ) :: kminor_start_upper logical ( wl ), dimension ( ncol , nlay ), intent ( in ) :: tropo !! use upper- or lower-atmospheric tables? ! --------------------- ! inputs from profile or parent function real ( wp ), dimension ( 2 , ncol , nlay , nflav ), intent ( in ) :: col_mix !! combination of major species's column amounts - computed in interpolation() real ( wp ), dimension ( 2 , 2 , 2 , ncol , nlay , nflav ), intent ( in ) :: fmajor !! interpolation weights for major gases - computed in interpolation() real ( wp ), dimension ( 2 , 2 , ncol , nlay , nflav ), intent ( in ) :: fminor !! interpolation weights for minor gases - computed in interpolation() real ( wp ), dimension ( ncol , nlay ), intent ( in ) :: play , tlay !! input temperature and pressure real ( wp ), dimension ( ncol , nlay , 0 : ngas ), intent ( in ) :: col_gas !! input column gas amount (molecules/cm^2) integer , dimension ( 2 , ncol , nlay , nflav ), intent ( in ) :: jeta !! interpolation indexes in eta - computed in interpolation() integer , dimension ( ncol , nlay ), intent ( in ) :: jtemp !! interpolation indexes in temperature - computed in interpolation() integer , dimension ( ncol , nlay ), intent ( in ) :: jpress !! interpolation indexes in pressure - computed in interpolation() ! --------------------- ! output - optical depth real ( wp ), dimension ( ncol , nlay , ngpt ), intent ( inout ) :: tau !! aborption optional depth end subroutine compute_tau_absorption end interface ! ------------------------------------------------------------------------------------------------------------------ interface subroutine compute_tau_rayleigh ( ncol , nlay , nbnd , ngpt , & ngas , nflav , neta , npres , ntemp , & gpoint_flavor , band_lims_gpt , & krayl , & idx_h2o , col_dry , col_gas , & fminor , jeta , tropo , jtemp , & tau_rayleigh ) bind ( C , name = \"rrtmgp_compute_tau_rayleigh\" ) use mo_rte_kind , only : wp , wl integer , intent ( in ) :: ncol , nlay , nbnd , ngpt !! input dimensions integer , intent ( in ) :: ngas , nflav , neta , npres , ntemp !! table dimensions integer , dimension ( 2 , ngpt ), intent ( in ) :: gpoint_flavor !! major gas flavor (pair) by upper/lower, g-point integer , dimension ( 2 , nbnd ), intent ( in ) :: band_lims_gpt !! start and end g-point for each band real ( wp ), dimension ( ntemp , neta , ngpt , 2 ), intent ( in ) :: krayl !! Rayleigh scattering coefficients integer , intent ( in ) :: idx_h2o !! index of water vapor in col_gas real ( wp ), dimension ( ncol , nlay ), intent ( in ) :: col_dry !! column amount of dry air real ( wp ), dimension ( ncol , nlay , 0 : ngas ), intent ( in ) :: col_gas !! input column gas amount (molecules/cm^2) real ( wp ), dimension ( 2 , 2 , ncol , nlay , nflav ), intent ( in ) :: fminor !! interpolation weights for major gases - computed in interpolation() integer , dimension ( 2 , ncol , nlay , nflav ), intent ( in ) :: jeta !! interpolation indexes in eta - computed in interpolation() logical ( wl ), dimension ( ncol , nlay ), intent ( in ) :: tropo !! use upper- or lower-atmospheric tables? integer , dimension ( ncol , nlay ), intent ( in ) :: jtemp !! interpolation indexes in temperature - computed in interpolation() ! outputs real ( wp ), dimension ( ncol , nlay , ngpt ), intent ( out ) :: tau_rayleigh !! Rayleigh optical depth end subroutine compute_tau_rayleigh end interface ! ------------------------------------------------------------------------------------------------------------------ interface subroutine compute_Planck_source ( & ncol , nlay , nbnd , ngpt , & nflav , neta , npres , ntemp , nPlanckTemp ,& tlay , tlev , tsfc , sfc_lay , & fmajor , jeta , tropo , jtemp , jpress , & gpoint_bands , band_lims_gpt , & pfracin , temp_ref_min , totplnk_delta , totplnk , gpoint_flavor , & sfc_src , lay_src , lev_src , sfc_source_Jac ) bind ( C , name = \"rrtmgp_compute_Planck_source\" ) use mo_rte_kind , only : wp , wl integer , intent ( in ) :: ncol , nlay , nbnd , ngpt !! input dimensions integer , intent ( in ) :: nflav , neta , npres , ntemp , nPlanckTemp !! table dimensions real ( wp ), dimension ( ncol , nlay ), intent ( in ) :: tlay !! temperature at layer centers (K) real ( wp ), dimension ( ncol , nlay + 1 ), intent ( in ) :: tlev !! temperature at interfaces (K) real ( wp ), dimension ( ncol ), intent ( in ) :: tsfc !! surface temperture integer , intent ( in ) :: sfc_lay !! index into surface layer ! Interpolation variables real ( wp ), dimension ( 2 , 2 , 2 , ncol , nlay , nflav ), intent ( in ) :: fmajor !! interpolation weights for major gases - computed in interpolation() integer , dimension ( 2 , ncol , nlay , nflav ), intent ( in ) :: jeta !! interpolation indexes in eta - computed in interpolation() logical ( wl ), dimension ( ncol , nlay ), intent ( in ) :: tropo !! use upper- or lower-atmospheric tables? integer , dimension ( ncol , nlay ), intent ( in ) :: jtemp , jpress !! interpolation indexes in temperature and pressure - computed in interpolation() ! Table-specific integer , dimension ( ngpt ), intent ( in ) :: gpoint_bands !! band to which each g-point belongs integer , dimension ( 2 , nbnd ), intent ( in ) :: band_lims_gpt !! start and end g-point for each band real ( wp ), dimension ( ntemp , neta , npres + 1 , ngpt ), intent ( in ) :: pfracin !! Fraction of the Planck function in each g-point real ( wp ), intent ( in ) :: temp_ref_min , totplnk_delta !! interpolation constants real ( wp ), dimension ( nPlanckTemp , nbnd ), intent ( in ) :: totplnk !! Total Planck function by band at each temperature integer , dimension ( 2 , ngpt ), intent ( in ) :: gpoint_flavor !! major gas flavor (pair) by upper/lower, g-point real ( wp ), dimension ( ncol , ngpt ), intent ( out ) :: sfc_src !! Planck emssion from the surface real ( wp ), dimension ( ncol , nlay , ngpt ), intent ( out ) :: lay_src !! Planck emssion from layer centers real ( wp ), dimension ( ncol , nlay + 1 , ngpt ), intent ( out ) :: lev_src !! Planck emission at layer boundaries real ( wp ), dimension ( ncol , ngpt ), intent ( out ) :: sfc_source_Jac !! Jacobian (derivative) of the surface Planck source with respect to surface temperature end subroutine compute_Planck_source end interface ! ------------------------------------------------------------------------------------------------------------------ end module mo_gas_optics_rrtmgp_kernels","tags":"","loc":"sourcefile/mo_gas_optics_rrtmgp_kernels.f90~2.html"}]} \ No newline at end of file diff --git a/reference/rte-fortran-interface/lists/files.html b/reference/rte-fortran-interface/lists/files.html index 3cb1cbdb5..de0b4f4ae 100644 --- a/reference/rte-fortran-interface/lists/files.html +++ b/reference/rte-fortran-interface/lists/files.html @@ -102,38 +102,30 @@

    Source Files

    file~~graph~~FileGraph - + -sourcefile~mo_source_functions.f90 - - -mo_source_functions.F90 +sourcefile~mo_rte_util_array_validation.f90 + + +mo_rte_util_array_validation.F90 - + sourcefile~mo_rte_lw.f90 - + mo_rte_lw.F90 - - -sourcefile~mo_source_functions.f90->sourcefile~mo_rte_lw.f90 - - - - - -sourcefile~mo_rte_config.f90 - - -mo_rte_config.F90 - - + + +sourcefile~mo_rte_util_array_validation.f90->sourcefile~mo_rte_lw.f90 + + + @@ -144,19 +136,12 @@

    Source Files

         - - -sourcefile~mo_rte_config.f90->sourcefile~mo_rte_sw.f90 - + + +sourcefile~mo_rte_util_array_validation.f90->sourcefile~mo_rte_sw.f90 + - - -sourcefile~mo_rte_config.f90->sourcefile~mo_rte_lw.f90 - - - - sourcefile~mo_fluxes.f90 @@ -166,9 +151,9 @@

    Source Files

         - + -sourcefile~mo_rte_config.f90->sourcefile~mo_fluxes.f90 +sourcefile~mo_rte_util_array_validation.f90->sourcefile~mo_fluxes.f90 @@ -181,75 +166,118 @@

    Source Files

         - + -sourcefile~mo_rte_config.f90->sourcefile~mo_optical_props.f90 - - +sourcefile~mo_rte_util_array_validation.f90->sourcefile~mo_optical_props.f90 + + - + -sourcefile~mo_rte_util_array_validation.f90 - - -mo_rte_util_array_validation.F90 +sourcefile~mo_rte_kind.f90 + + +mo_rte_kind.F90 - - -sourcefile~mo_rte_util_array_validation.f90->sourcefile~mo_rte_sw.f90 - - + + +sourcefile~mo_rte_kind.f90->sourcefile~mo_rte_util_array_validation.f90 + + - - -sourcefile~mo_rte_util_array_validation.f90->sourcefile~mo_rte_lw.f90 - - + + +sourcefile~mo_rte_kind.f90->sourcefile~mo_rte_lw.f90 + - + + +sourcefile~mo_rte_kind.f90->sourcefile~mo_rte_sw.f90 + + + + + + +sourcefile~mo_source_functions.f90 + + +mo_source_functions.F90 + + + + + +sourcefile~mo_rte_kind.f90->sourcefile~mo_source_functions.f90 + + + + + +sourcefile~mo_rte_kind.f90->sourcefile~mo_fluxes.f90 + + + + -sourcefile~mo_rte_util_array_validation.f90->sourcefile~mo_fluxes.f90 - - +sourcefile~mo_rte_kind.f90->sourcefile~mo_optical_props.f90 + + + - + + +sourcefile~mo_rte_config.f90 + + +mo_rte_config.F90 + + + + -sourcefile~mo_rte_util_array_validation.f90->sourcefile~mo_optical_props.f90 - - +sourcefile~mo_rte_kind.f90->sourcefile~mo_rte_config.f90 + + - - -sourcefile~mo_fluxes.f90->sourcefile~mo_rte_sw.f90 - - + + +sourcefile~mo_source_functions.f90->sourcefile~mo_rte_lw.f90 + + - + sourcefile~mo_fluxes.f90->sourcefile~mo_rte_lw.f90 - - -sourcefile~mo_optical_props.f90->sourcefile~mo_source_functions.f90 - - + + +sourcefile~mo_fluxes.f90->sourcefile~mo_rte_sw.f90 + + + + + +sourcefile~mo_optical_props.f90->sourcefile~mo_rte_lw.f90 + + - + sourcefile~mo_optical_props.f90->sourcefile~mo_rte_sw.f90 - - -sourcefile~mo_optical_props.f90->sourcefile~mo_rte_lw.f90 - - + + +sourcefile~mo_optical_props.f90->sourcefile~mo_source_functions.f90 + + @@ -257,57 +285,29 @@

    Source Files

     - - -sourcefile~mo_rte_kind.f90 - - -mo_rte_kind.F90 - - - - - -sourcefile~mo_rte_kind.f90->sourcefile~mo_source_functions.f90 - - - - + -sourcefile~mo_rte_kind.f90->sourcefile~mo_rte_config.f90 - - - - - -sourcefile~mo_rte_kind.f90->sourcefile~mo_rte_sw.f90 - - - +sourcefile~mo_rte_config.f90->sourcefile~mo_rte_lw.f90 + + - + -sourcefile~mo_rte_kind.f90->sourcefile~mo_rte_util_array_validation.f90 - - - - - -sourcefile~mo_rte_kind.f90->sourcefile~mo_rte_lw.f90 - +sourcefile~mo_rte_config.f90->sourcefile~mo_rte_sw.f90 + + - + -sourcefile~mo_rte_kind.f90->sourcefile~mo_fluxes.f90 - - +sourcefile~mo_rte_config.f90->sourcefile~mo_fluxes.f90 + + - + -sourcefile~mo_rte_kind.f90->sourcefile~mo_optical_props.f90 - - - +sourcefile~mo_rte_config.f90->sourcefile~mo_optical_props.f90 + +     diff --git a/reference/rte-fortran-interface/lists/modules.html b/reference/rte-fortran-interface/lists/modules.html index cb8e495ee..620fcddc9 100644 --- a/reference/rte-fortran-interface/lists/modules.html +++ b/reference/rte-fortran-interface/lists/modules.html @@ -104,292 +104,294 @@

    Modules

    - - + + module~~graph~~ModuleGraph - - + + -module~mo_source_functions - - -mo_source_functions +module~mo_rte_config + + +mo_rte_config - + module~mo_rte_kind - - -mo_rte_kind + + +mo_rte_kind - + +module~mo_rte_config->module~mo_rte_kind + + + + + +iso_c_binding + + +iso_c_binding + + + + + +module~mo_rte_kind->iso_c_binding + + + + + +module~mo_source_functions + + +mo_source_functions + + + + + module~mo_source_functions->module~mo_rte_kind - + module~mo_optical_props - -mo_optical_props + +mo_optical_props - + module~mo_source_functions->module~mo_optical_props - - + + - + module~mo_rte_sw - - -mo_rte_sw + + +mo_rte_sw + + +module~mo_rte_sw->module~mo_rte_config + + + + + + +module~mo_rte_sw->module~mo_rte_kind + + - + module~mo_rte_util_array_validation - - -mo_rte_util_array_validation + + +mo_rte_util_array_validation - + module~mo_rte_sw->module~mo_rte_util_array_validation - - - + + + - + module~mo_fluxes - - -mo_fluxes + + +mo_fluxes - + module~mo_rte_sw->module~mo_fluxes - - - - - -module~mo_rte_config - - -mo_rte_config - - - - - -module~mo_rte_sw->module~mo_rte_config - - - - - - -module~mo_rte_sw->module~mo_rte_kind - + + - + module~mo_rte_sw->module~mo_optical_props - - - - - -mo_rte_util_array - -mo_rte_util_array - - - -module~mo_rte_sw->mo_rte_util_array - - + + - + mo_rte_solver_kernels - -mo_rte_solver_kernels + +mo_rte_solver_kernels module~mo_rte_sw->mo_rte_solver_kernels - - + + + + + +mo_rte_util_array + +mo_rte_util_array + + + +module~mo_rte_sw->mo_rte_util_array + + + + + +module~mo_rte_util_array_validation->module~mo_rte_kind + + - + module~mo_rte_lw - - -mo_rte_lw + + +mo_rte_lw + + +module~mo_rte_lw->module~mo_rte_config + + + + + +module~mo_rte_lw->module~mo_rte_kind + + + + + + - + module~mo_rte_lw->module~mo_source_functions - - + + - + module~mo_rte_lw->module~mo_rte_util_array_validation - - - + + - + module~mo_rte_lw->module~mo_fluxes - - - - - -module~mo_rte_lw->module~mo_rte_config - - - - - -module~mo_rte_lw->module~mo_rte_kind - - - - + + - + module~mo_rte_lw->module~mo_optical_props - - - - - - -module~mo_rte_lw->mo_rte_util_array - - + + + - + module~mo_rte_lw->mo_rte_solver_kernels - - + + - - -module~mo_rte_util_array_validation->module~mo_rte_kind - - - - - -module~mo_fluxes->module~mo_rte_util_array_validation - + + +module~mo_rte_lw->mo_rte_util_array + + - + module~mo_fluxes->module~mo_rte_config - - + + + - + module~mo_fluxes->module~mo_rte_kind - - - + + + + + + +module~mo_fluxes->module~mo_rte_util_array_validation + + - + module~mo_fluxes->module~mo_optical_props - - + + mo_fluxes_broadband_kernels - -mo_fluxes_broadband_kernels + +mo_fluxes_broadband_kernels - -module~mo_fluxes->mo_fluxes_broadband_kernels - - - - - -module~mo_rte_config->module~mo_rte_kind - - - - - -iso_c_binding - - -iso_c_binding - - - - -module~mo_rte_kind->iso_c_binding - - - - - -module~mo_optical_props->module~mo_rte_util_array_validation - - +module~mo_fluxes->mo_fluxes_broadband_kernels + + - + module~mo_optical_props->module~mo_rte_config - - + + - + module~mo_optical_props->module~mo_rte_kind - + + + + +module~mo_optical_props->module~mo_rte_util_array_validation + + - + mo_optical_props_kernels - -mo_optical_props_kernels + +mo_optical_props_kernels - + module~mo_optical_props->mo_optical_props_kernels - - + + diff --git a/reference/rte-fortran-interface/lists/procedures.html b/reference/rte-fortran-interface/lists/procedures.html index 71390cfbc..5096278e4 100644 --- a/reference/rte-fortran-interface/lists/procedures.html +++ b/reference/rte-fortran-interface/lists/procedures.html @@ -100,80 +100,80 @@

    Procedures

    call~~graph~~CallGraph - + -interface~any_vals_outside - - -any_vals_outside +interface~extents_are + + +extents_are - + -interface~rte_sw - - -rte_sw +interface~any_vals_less_than + + +any_vals_less_than - + -proc~rte_lw - - -rte_lw +interface~rte_config_checks + + +rte_config_checks - - -proc~rte_lw->interface~any_vals_outside - - - - + -interface~any_vals_less_than - - -any_vals_less_than +interface~any_vals_outside + + +any_vals_outside - - -proc~rte_lw->interface~any_vals_less_than - - - - + -interface~extents_are - - -extents_are +proc~rte_lw + + +rte_lw proc~rte_lw->interface~extents_are - - + + - + + +proc~rte_lw->interface~any_vals_less_than + + + + + +proc~rte_lw->interface~any_vals_outside + + + + -lw_solver_noscat - -lw_solver_noscat +zero_array + +zero_array - + -proc~rte_lw->lw_solver_noscat - - +proc~rte_lw->zero_array + + @@ -182,29 +182,29 @@

    Procedures

    lw_solver_2stream     - + proc~rte_lw->lw_solver_2stream - + -zero_array - -zero_array +lw_solver_noscat + +lw_solver_noscat - - -proc~rte_lw->zero_array - - + + +proc~rte_lw->lw_solver_noscat + + - + -interface~rte_config_checks - - -rte_config_checks +interface~rte_sw + + +rte_sw diff --git a/reference/rte-fortran-interface/lists/types.html b/reference/rte-fortran-interface/lists/types.html index 6e09abd11..71886af80 100644 --- a/reference/rte-fortran-interface/lists/types.html +++ b/reference/rte-fortran-interface/lists/types.html @@ -116,93 +116,93 @@

    Derived Types

    type~~graph~~TypeGraph - + -type~ty_source_func_lw - - -ty_source_func_lw +type~ty_optical_props_1scl + + +ty_optical_props_1scl - - -type~ty_optical_props - - -ty_optical_props + + +type~ty_optical_props_arry + + +ty_optical_props_arry - + -type~ty_source_func_lw->type~ty_optical_props - - +type~ty_optical_props_1scl->type~ty_optical_props_arry + + - + -type~ty_source_func_sw - - -ty_source_func_sw +type~ty_fluxes + + +ty_fluxes - - -type~ty_source_func_sw->type~ty_optical_props - - - - + -type~ty_optical_props_arry - - -ty_optical_props_arry +type~ty_source_func_lw + + +ty_source_func_lw + + + + + +type~ty_optical_props + + +ty_optical_props + + +type~ty_source_func_lw->type~ty_optical_props + + + type~ty_optical_props_arry->type~ty_optical_props - - + + - - -type~ty_optical_props_1scl - + + +type~ty_optical_props_2str + -ty_optical_props_1scl +ty_optical_props_2str - + -type~ty_optical_props_1scl->type~ty_optical_props_arry - - +type~ty_optical_props_2str->type~ty_optical_props_arry + + - + type~ty_fluxes_broadband - + ty_fluxes_broadband - - -type~ty_fluxes - - -ty_fluxes - - - type~ty_fluxes_broadband->type~ty_fluxes @@ -210,9 +210,9 @@

    Derived Types

     - + type~ty_optical_props_nstr - + ty_optical_props_nstr @@ -221,23 +221,23 @@

    Derived Types

    type~ty_optical_props_nstr->type~ty_optical_props_arry - - + + - + -type~ty_optical_props_2str - - -ty_optical_props_2str +type~ty_source_func_sw + + +ty_source_func_sw - + -type~ty_optical_props_2str->type~ty_optical_props_arry - - +type~ty_source_func_sw->type~ty_optical_props + +     diff --git a/reference/rte-fortran-interface/module/mo_fluxes.html b/reference/rte-fortran-interface/module/mo_fluxes.html index b88856385..1fd4cead8 100644 --- a/reference/rte-fortran-interface/module/mo_fluxes.html +++ b/reference/rte-fortran-interface/module/mo_fluxes.html @@ -87,7 +87,7 @@

    mo_fluxes
  • 93 statements + title=" 5.9% of total for modules and submodules.">93 statements
  • Source File
    • @@ -137,10 +137,10 @@

    Uses

      • @@ -151,146 +151,146 @@

      Uses

      - - + + module~~mo_fluxes~~UsesGraph - + module~mo_fluxes - -mo_fluxes + +mo_fluxes - + -module~mo_optical_props - - -mo_optical_props +module~mo_rte_util_array_validation + + +mo_rte_util_array_validation - + -module~mo_fluxes->module~mo_optical_props - - +module~mo_fluxes->module~mo_rte_util_array_validation + + - + -module~mo_rte_config - - -mo_rte_config +module~mo_optical_props + + +mo_optical_props - + -module~mo_fluxes->module~mo_rte_config - - +module~mo_fluxes->module~mo_optical_props + + - + -mo_fluxes_broadband_kernels - -mo_fluxes_broadband_kernels +module~mo_rte_kind + + +mo_rte_kind + - - -module~mo_fluxes->mo_fluxes_broadband_kernels - - - + + +module~mo_fluxes->module~mo_rte_kind + + + + + -module~mo_rte_kind - - -mo_rte_kind +module~mo_rte_config + + +mo_rte_config - + -module~mo_fluxes->module~mo_rte_kind - - - +module~mo_fluxes->module~mo_rte_config + + - + -module~mo_rte_util_array_validation - - -mo_rte_util_array_validation - +mo_fluxes_broadband_kernels + +mo_fluxes_broadband_kernels + + +module~mo_fluxes->mo_fluxes_broadband_kernels + + - - -module~mo_fluxes->module~mo_rte_util_array_validation - - + + +module~mo_rte_util_array_validation->module~mo_rte_kind + + - - -module~mo_optical_props->module~mo_rte_config - - + + +module~mo_optical_props->module~mo_rte_util_array_validation + + - + module~mo_optical_props->module~mo_rte_kind - - + + - - -module~mo_optical_props->module~mo_rte_util_array_validation - - + + +module~mo_optical_props->module~mo_rte_config + + mo_optical_props_kernels - -mo_optical_props_kernels + +mo_optical_props_kernels module~mo_optical_props->mo_optical_props_kernels - - - - - -module~mo_rte_config->module~mo_rte_kind - - + + iso_c_binding - -iso_c_binding + +iso_c_binding module~mo_rte_kind->iso_c_binding - - + + - + -module~mo_rte_util_array_validation->module~mo_rte_kind - - +module~mo_rte_config->module~mo_rte_kind + + diff --git a/reference/rte-fortran-interface/module/mo_optical_props.html b/reference/rte-fortran-interface/module/mo_optical_props.html index 6b3a52198..5d1ff6ec7 100644 --- a/reference/rte-fortran-interface/module/mo_optical_props.html +++ b/reference/rte-fortran-interface/module/mo_optical_props.html @@ -87,7 +87,7 @@

      mo_optical_props
    • 749 statements + title="47.1% of total for modules and submodules.">749 statements
    • Source File

    @@ -169,10 +169,10 @@

    Uses

    • @@ -182,100 +182,100 @@

      Uses

      - - + + module~~mo_optical_props~~UsesGraph - + module~mo_optical_props - -mo_optical_props + +mo_optical_props - + -module~mo_rte_util_array_validation - - -mo_rte_util_array_validation +module~mo_rte_config + + +mo_rte_config - + -module~mo_optical_props->module~mo_rte_util_array_validation - - +module~mo_optical_props->module~mo_rte_config + + - + -module~mo_rte_config - - -mo_rte_config +module~mo_rte_util_array_validation + + +mo_rte_util_array_validation - + -module~mo_optical_props->module~mo_rte_config - - +module~mo_optical_props->module~mo_rte_util_array_validation + + - + -module~mo_rte_kind - - -mo_rte_kind - - +mo_optical_props_kernels + +mo_optical_props_kernels - + -module~mo_optical_props->module~mo_rte_kind - - +module~mo_optical_props->mo_optical_props_kernels + + - + -mo_optical_props_kernels - -mo_optical_props_kernels +module~mo_rte_kind + + +mo_rte_kind + - + + -module~mo_optical_props->mo_optical_props_kernels - - +module~mo_optical_props->module~mo_rte_kind + + - + -module~mo_rte_util_array_validation->module~mo_rte_kind - - +module~mo_rte_config->module~mo_rte_kind + + - + -module~mo_rte_config->module~mo_rte_kind - - +module~mo_rte_util_array_validation->module~mo_rte_kind + + iso_c_binding - -iso_c_binding + +iso_c_binding module~mo_rte_kind->iso_c_binding - - + + diff --git a/reference/rte-fortran-interface/module/mo_rte_config.html b/reference/rte-fortran-interface/module/mo_rte_config.html index 4ce6aa418..71bdc4f0d 100644 --- a/reference/rte-fortran-interface/module/mo_rte_config.html +++ b/reference/rte-fortran-interface/module/mo_rte_config.html @@ -271,128 +271,129 @@

      Used by

      - - + + module~~mo_rte_config~~UsedByGraph - + module~mo_rte_config - -mo_rte_config + +mo_rte_config - + -module~mo_optical_props - - -mo_optical_props +module~mo_rte_lw + + +mo_rte_lw - + -module~mo_optical_props->module~mo_rte_config - - +module~mo_rte_lw->module~mo_rte_config + + - + -module~mo_rte_sw - - -mo_rte_sw +module~mo_optical_props + + +mo_optical_props - - -module~mo_rte_sw->module~mo_rte_config - - - - -module~mo_rte_sw->module~mo_optical_props - - - + + +module~mo_rte_lw->module~mo_optical_props + + + module~mo_fluxes - -mo_fluxes + +mo_fluxes - - -module~mo_rte_sw->module~mo_fluxes - - + + +module~mo_rte_lw->module~mo_fluxes + + + + + +module~mo_source_functions + + +mo_source_functions + + + + + +module~mo_rte_lw->module~mo_source_functions + + + + + +module~mo_optical_props->module~mo_rte_config + + module~mo_fluxes->module~mo_rte_config - - - + module~mo_fluxes->module~mo_optical_props - - + + - + -module~mo_rte_lw - - -mo_rte_lw +module~mo_rte_sw + + +mo_rte_sw - + -module~mo_rte_lw->module~mo_rte_config - - - - - -module~mo_rte_lw->module~mo_optical_props - - - - - -module~mo_rte_lw->module~mo_fluxes - - - - - -module~mo_source_functions - - -mo_source_functions - +module~mo_rte_sw->module~mo_rte_config + + + + + + +module~mo_rte_sw->module~mo_optical_props + + - - -module~mo_rte_lw->module~mo_source_functions - - + + +module~mo_rte_sw->module~mo_fluxes + + module~mo_source_functions->module~mo_optical_props - - + + diff --git a/reference/rte-fortran-interface/module/mo_rte_kind.html b/reference/rte-fortran-interface/module/mo_rte_kind.html index 64b94fc1a..7045d8d8a 100644 --- a/reference/rte-fortran-interface/module/mo_rte_kind.html +++ b/reference/rte-fortran-interface/module/mo_rte_kind.html @@ -251,215 +251,213 @@

      Used by

      - - + + module~~mo_rte_kind~~UsedByGraph - + module~mo_rte_kind - -mo_rte_kind + +mo_rte_kind - + -module~mo_source_functions - - -mo_source_functions +module~mo_rte_util_array_validation + + +mo_rte_util_array_validation - + -module~mo_source_functions->module~mo_rte_kind - +module~mo_rte_util_array_validation->module~mo_rte_kind + + - + module~mo_optical_props - - -mo_optical_props + + +mo_optical_props - - -module~mo_source_functions->module~mo_optical_props - - - - - -module~mo_rte_sw - - -mo_rte_sw - - + + +module~mo_optical_props->module~mo_rte_kind + + + - - -module~mo_rte_sw->module~mo_rte_kind - + + +module~mo_optical_props->module~mo_rte_util_array_validation + + - + module~mo_rte_config - - -mo_rte_config + + +mo_rte_config - - -module~mo_rte_sw->module~mo_rte_config - - - - - -module~mo_rte_sw->module~mo_optical_props - + + +module~mo_optical_props->module~mo_rte_config + + - + module~mo_fluxes - - -mo_fluxes + + +mo_fluxes - - -module~mo_rte_sw->module~mo_fluxes - - + + +module~mo_fluxes->module~mo_rte_kind + + - - -module~mo_rte_util_array_validation - - -mo_rte_util_array_validation - + + +module~mo_fluxes->module~mo_rte_util_array_validation + + + + + +module~mo_fluxes->module~mo_optical_props + + - + -module~mo_rte_sw->module~mo_rte_util_array_validation - - - +module~mo_fluxes->module~mo_rte_config + + - - -module~mo_rte_config->module~mo_rte_kind - - + + +module~mo_rte_sw + + +mo_rte_sw + - - -module~mo_optical_props->module~mo_rte_kind - - + + +module~mo_rte_sw->module~mo_rte_kind + + + + + -module~mo_optical_props->module~mo_rte_config - - +module~mo_rte_sw->module~mo_rte_util_array_validation + + - - -module~mo_optical_props->module~mo_rte_util_array_validation - - + + +module~mo_rte_sw->module~mo_optical_props + + + + + + +module~mo_rte_sw->module~mo_fluxes + + + + + +module~mo_rte_sw->module~mo_rte_config + + module~mo_rte_lw - -mo_rte_lw + +mo_rte_lw - + module~mo_rte_lw->module~mo_rte_kind - - - - - + - - -module~mo_rte_lw->module~mo_source_functions - - - - - -module~mo_rte_lw->module~mo_rte_config - - + + +module~mo_rte_lw->module~mo_rte_util_array_validation + + - + module~mo_rte_lw->module~mo_optical_props - - - + - + module~mo_rte_lw->module~mo_fluxes - - + + - - -module~mo_rte_lw->module~mo_rte_util_array_validation - - + + +module~mo_rte_lw->module~mo_rte_config + + + - - -module~mo_fluxes->module~mo_rte_kind - - - + + +module~mo_source_functions + + +mo_source_functions + - - -module~mo_fluxes->module~mo_rte_config - - - - - -module~mo_fluxes->module~mo_optical_props - - + + +module~mo_rte_lw->module~mo_source_functions + + - - -module~mo_fluxes->module~mo_rte_util_array_validation - - - + + +module~mo_rte_config->module~mo_rte_kind + + - + -module~mo_rte_util_array_validation->module~mo_rte_kind - - +module~mo_source_functions->module~mo_rte_kind + + + + +module~mo_source_functions->module~mo_optical_props + + diff --git a/reference/rte-fortran-interface/module/mo_rte_lw.html b/reference/rte-fortran-interface/module/mo_rte_lw.html index 97718367d..f97268753 100644 --- a/reference/rte-fortran-interface/module/mo_rte_lw.html +++ b/reference/rte-fortran-interface/module/mo_rte_lw.html @@ -156,13 +156,13 @@

      Uses

        • @@ -173,237 +173,237 @@

        Uses

        - - + + module~~mo_rte_lw~~UsesGraph - + module~mo_rte_lw - -mo_rte_lw + +mo_rte_lw - + -module~mo_source_functions - - -mo_source_functions - - +mo_rte_solver_kernels + +mo_rte_solver_kernels - + -module~mo_rte_lw->module~mo_source_functions - - +module~mo_rte_lw->mo_rte_solver_kernels + + - + -module~mo_optical_props - - -mo_optical_props +module~mo_rte_util_array_validation + + +mo_rte_util_array_validation - - -module~mo_rte_lw->module~mo_optical_props - - + + +module~mo_rte_lw->module~mo_rte_util_array_validation + + + - + -module~mo_rte_config - - -mo_rte_config +module~mo_fluxes + + +mo_fluxes - - -module~mo_rte_lw->module~mo_rte_config - - - + + +module~mo_rte_lw->module~mo_fluxes + + - + -mo_rte_util_array - -mo_rte_util_array +module~mo_optical_props + + +mo_optical_props + - - -module~mo_rte_lw->mo_rte_util_array - - - + + +module~mo_rte_lw->module~mo_optical_props + + + + -module~mo_fluxes - - -mo_fluxes +module~mo_rte_kind + + +mo_rte_kind - - -module~mo_rte_lw->module~mo_fluxes - - + + +module~mo_rte_lw->module~mo_rte_kind + - + -mo_rte_solver_kernels - -mo_rte_solver_kernels +module~mo_rte_config + + +mo_rte_config + - + + -module~mo_rte_lw->mo_rte_solver_kernels - - +module~mo_rte_lw->module~mo_rte_config + + + - + -module~mo_rte_util_array_validation - - -mo_rte_util_array_validation +module~mo_source_functions + + +mo_source_functions - + -module~mo_rte_lw->module~mo_rte_util_array_validation - - +module~mo_rte_lw->module~mo_source_functions + + - + -module~mo_rte_kind - - -mo_rte_kind - - +mo_rte_util_array + +mo_rte_util_array - + -module~mo_rte_lw->module~mo_rte_kind - - - - -module~mo_source_functions->module~mo_optical_props - - +module~mo_rte_lw->mo_rte_util_array + + - + -module~mo_source_functions->module~mo_rte_kind - - - +module~mo_rte_util_array_validation->module~mo_rte_kind + + - - -module~mo_optical_props->module~mo_rte_config - - + + +module~mo_fluxes->module~mo_rte_util_array_validation + + - + -module~mo_optical_props->module~mo_rte_util_array_validation - - +module~mo_fluxes->module~mo_optical_props + + - + + +module~mo_fluxes->module~mo_rte_kind + + + + + -module~mo_optical_props->module~mo_rte_kind - - +module~mo_fluxes->module~mo_rte_config + - + -mo_optical_props_kernels - -mo_optical_props_kernels +mo_fluxes_broadband_kernels + +mo_fluxes_broadband_kernels - + -module~mo_optical_props->mo_optical_props_kernels - - - - - -module~mo_rte_config->module~mo_rte_kind - - +module~mo_fluxes->mo_fluxes_broadband_kernels + + - + -module~mo_fluxes->module~mo_optical_props - - - - - -module~mo_fluxes->module~mo_rte_config - - +module~mo_optical_props->module~mo_rte_util_array_validation + + - + -module~mo_fluxes->module~mo_rte_util_array_validation - - - +module~mo_optical_props->module~mo_rte_kind + + - - -module~mo_fluxes->module~mo_rte_kind - - + + +module~mo_optical_props->module~mo_rte_config + + - + -mo_fluxes_broadband_kernels - -mo_fluxes_broadband_kernels - - - -module~mo_fluxes->mo_fluxes_broadband_kernels - - +mo_optical_props_kernels + +mo_optical_props_kernels - - -module~mo_rte_util_array_validation->module~mo_rte_kind - - + + +module~mo_optical_props->mo_optical_props_kernels + + iso_c_binding - -iso_c_binding + +iso_c_binding - + module~mo_rte_kind->iso_c_binding - - + + + + + +module~mo_rte_config->module~mo_rte_kind + + + + + +module~mo_source_functions->module~mo_optical_props + + + + + +module~mo_source_functions->module~mo_rte_kind + + + diff --git a/reference/rte-fortran-interface/module/mo_rte_sw.html b/reference/rte-fortran-interface/module/mo_rte_sw.html index 38a3ca9bf..56d7572c6 100644 --- a/reference/rte-fortran-interface/module/mo_rte_sw.html +++ b/reference/rte-fortran-interface/module/mo_rte_sw.html @@ -87,7 +87,7 @@

        mo_rte_sw
      • 182 statements + title="11.5% of total for modules and submodules.">182 statements
      • Source File

      @@ -148,12 +148,12 @@

      Uses

        • @@ -175,60 +175,63 @@

        Uses

        mo_rte_sw - + -module~mo_rte_config - - -mo_rte_config +module~mo_rte_util_array_validation + + +mo_rte_util_array_validation - + -module~mo_rte_sw->module~mo_rte_config - - +module~mo_rte_sw->module~mo_rte_util_array_validation + + - + +mo_rte_solver_kernels + +mo_rte_solver_kernels + + + +module~mo_rte_sw->mo_rte_solver_kernels + + + + + module~mo_optical_props - + mo_optical_props - + module~mo_rte_sw->module~mo_optical_props - - -mo_rte_util_array - -mo_rte_util_array - - - -module~mo_rte_sw->mo_rte_util_array - - - - + -mo_rte_solver_kernels - -mo_rte_solver_kernels +module~mo_rte_kind + + +mo_rte_kind + - - -module~mo_rte_sw->mo_rte_solver_kernels - - + + + +module~mo_rte_sw->module~mo_rte_kind + + @@ -240,66 +243,63 @@

        Uses

                 - + module~mo_rte_sw->module~mo_fluxes - + -module~mo_rte_util_array_validation - - -mo_rte_util_array_validation +module~mo_rte_config + + +mo_rte_config - + -module~mo_rte_sw->module~mo_rte_util_array_validation +module~mo_rte_sw->module~mo_rte_config - + -module~mo_rte_kind - - -mo_rte_kind - - +mo_rte_util_array + +mo_rte_util_array - + -module~mo_rte_sw->module~mo_rte_kind - - +module~mo_rte_sw->mo_rte_util_array + + - + -module~mo_rte_config->module~mo_rte_kind - +module~mo_rte_util_array_validation->module~mo_rte_kind + - - -module~mo_optical_props->module~mo_rte_config - - - - + module~mo_optical_props->module~mo_rte_util_array_validation - - + + - + module~mo_optical_props->module~mo_rte_kind + + +module~mo_optical_props->module~mo_rte_config + + + mo_optical_props_kernels @@ -307,29 +307,38 @@

        Uses

        mo_optical_props_kernels         - + module~mo_optical_props->mo_optical_props_kernels - + + +iso_c_binding + + +iso_c_binding + + + + + +module~mo_rte_kind->iso_c_binding + + + + -module~mo_fluxes->module~mo_rte_config - - +module~mo_fluxes->module~mo_rte_util_array_validation + + - + module~mo_fluxes->module~mo_optical_props - - -module~mo_fluxes->module~mo_rte_util_array_validation - - - module~mo_fluxes->module~mo_rte_kind @@ -337,6 +346,12 @@

        Uses

         + + +module~mo_fluxes->module~mo_rte_config + + + mo_fluxes_broadband_kernels @@ -344,31 +359,16 @@

        Uses

        mo_fluxes_broadband_kernels         - + module~mo_fluxes->mo_fluxes_broadband_kernels - - -module~mo_rte_util_array_validation->module~mo_rte_kind - - - - - -iso_c_binding - - -iso_c_binding - - - - + -module~mo_rte_kind->iso_c_binding - - +module~mo_rte_config->module~mo_rte_kind + + diff --git a/reference/rte-fortran-interface/module/mo_source_functions.html b/reference/rte-fortran-interface/module/mo_source_functions.html index f8848dbb3..f24e84a88 100644 --- a/reference/rte-fortran-interface/module/mo_source_functions.html +++ b/reference/rte-fortran-interface/module/mo_source_functions.html @@ -87,7 +87,7 @@

        mo_source_functions
      • 180 statements + title="11.0% of total for modules and submodules.">175 statements
      • Source File

      @@ -201,26 +201,26 @@

      Uses

      - + module~mo_optical_props->module~mo_rte_kind - + -module~mo_rte_config - - -mo_rte_config +module~mo_rte_util_array_validation + + +mo_rte_util_array_validation - + -module~mo_optical_props->module~mo_rte_config - - +module~mo_optical_props->module~mo_rte_util_array_validation + + @@ -229,36 +229,36 @@

      Uses

      mo_optical_props_kernels       - + module~mo_optical_props->mo_optical_props_kernels - + -module~mo_rte_util_array_validation - - -mo_rte_util_array_validation +module~mo_rte_config + + +mo_rte_config - + -module~mo_optical_props->module~mo_rte_util_array_validation - - +module~mo_optical_props->module~mo_rte_config + + - + -module~mo_rte_config->module~mo_rte_kind - - +module~mo_rte_util_array_validation->module~mo_rte_kind + + - + -module~mo_rte_util_array_validation->module~mo_rte_kind - +module~mo_rte_config->module~mo_rte_kind + @@ -468,14 +468,9 @@

      Components

      lay_source

      Planck source at layer average temperature (ncol, nlay, ngpt)

      - real(kind=wp), -public, allocatable, dimension(:,:,:):: - lev_source_dec

      Planck source at layer edge in decreasing ilay direction (ncol, nlay+1, ngpt)

      - - - real(kind=wp), + real(kind=wp), public, allocatable, dimension(:,:,:):: - lev_source_inc

      Planck source at layer edge in increasing ilay direction (ncol, nlay+1, ngpt)

      + lev_source

      Planck source at layer edge (ncol, nlay+1, ngpt)

      real(kind=wp), diff --git a/reference/rte-fortran-interface/proc/rte_lw.html b/reference/rte-fortran-interface/proc/rte_lw.html index 722c15888..42c9fa392 100644 --- a/reference/rte-fortran-interface/proc/rte_lw.html +++ b/reference/rte-fortran-interface/proc/rte_lw.html @@ -232,17 +232,17 @@

      Calls

       - + -lw_solver_noscat - -lw_solver_noscat +zero_array + +zero_array - + -proc~rte_lw->lw_solver_noscat - - +proc~rte_lw->zero_array + + @@ -251,37 +251,37 @@

      Calls

      lw_solver_2stream       - + proc~rte_lw->lw_solver_2stream - + +lw_solver_noscat + +lw_solver_noscat + + + +proc~rte_lw->lw_solver_noscat + + + + + interface~any_vals_less_than - - -any_vals_less_than + + +any_vals_less_than - -proc~rte_lw->interface~any_vals_less_than - - - - - -zero_array - -zero_array - - -proc~rte_lw->zero_array - - +proc~rte_lw->interface~any_vals_less_than + + diff --git a/reference/rte-fortran-interface/sourcefile/mo_fluxes.f90.html b/reference/rte-fortran-interface/sourcefile/mo_fluxes.f90.html index 1b8a6b665..b69658b97 100644 --- a/reference/rte-fortran-interface/sourcefile/mo_fluxes.f90.html +++ b/reference/rte-fortran-interface/sourcefile/mo_fluxes.f90.html @@ -87,7 +87,7 @@

      mo_fluxes.F90
    • 93 statements + title=" 5.9% of total for source files.">93 statements
    • Source File

    @@ -177,7 +177,7 @@

    This file depends on

         - + sourcefile~mo_fluxes.f90->sourcefile~mo_rte_config.f90 @@ -193,7 +193,7 @@

    This file depends on

         - + sourcefile~mo_fluxes.f90->sourcefile~mo_optical_props.f90 diff --git a/reference/rte-fortran-interface/sourcefile/mo_optical_props.f90.html b/reference/rte-fortran-interface/sourcefile/mo_optical_props.f90.html index f787eb83d..1006e0c3e 100644 --- a/reference/rte-fortran-interface/sourcefile/mo_optical_props.f90.html +++ b/reference/rte-fortran-interface/sourcefile/mo_optical_props.f90.html @@ -87,7 +87,7 @@

    mo_optical_props.F90
  • 749 statements + title="47.1% of total for source files.">749 statements
  • Source File
    • @@ -269,84 +269,84 @@

    Files dependent on this one

    mo_optical_props.F90     - + -sourcefile~mo_source_functions.f90 - - -mo_source_functions.F90 +sourcefile~mo_rte_lw.f90 + + +mo_rte_lw.F90 - + -sourcefile~mo_source_functions.f90->sourcefile~mo_optical_props.f90 - - - - - -sourcefile~mo_rte_sw.f90 - - -mo_rte_sw.F90 - - - - - -sourcefile~mo_rte_sw.f90->sourcefile~mo_optical_props.f90 - - +sourcefile~mo_rte_lw.f90->sourcefile~mo_optical_props.f90 + + - + sourcefile~mo_fluxes.f90 - + mo_fluxes.F90 - - -sourcefile~mo_rte_sw.f90->sourcefile~mo_fluxes.f90 - - + + +sourcefile~mo_rte_lw.f90->sourcefile~mo_fluxes.f90 + + - - -sourcefile~mo_rte_lw.f90 - - -mo_rte_lw.F90 + + +sourcefile~mo_source_functions.f90 + + +mo_source_functions.F90 - - -sourcefile~mo_rte_lw.f90->sourcefile~mo_optical_props.f90 - - - - + sourcefile~mo_rte_lw.f90->sourcefile~mo_source_functions.f90 - - -sourcefile~mo_rte_lw.f90->sourcefile~mo_fluxes.f90 - - - - + sourcefile~mo_fluxes.f90->sourcefile~mo_optical_props.f90 + + +sourcefile~mo_rte_sw.f90 + + +mo_rte_sw.F90 + + + + + +sourcefile~mo_rte_sw.f90->sourcefile~mo_optical_props.f90 + + + + + +sourcefile~mo_rte_sw.f90->sourcefile~mo_fluxes.f90 + + + + + +sourcefile~mo_source_functions.f90->sourcefile~mo_optical_props.f90 + + + +
    +
    +
    +

    RTE kernels was developed by The RTE+RRTTMGP consortium
    © 2024 Creative Commons License +

    +
    +
    +

    + Documentation generated by + FORD +

    +
    +
    +
    +
    +
    + + + + + + + + + + + + + + + + + + + \ No newline at end of file diff --git a/reference/rte-kernels/module/mo_rte_util_array.html b/reference/rte-kernels/module/mo_rte_util_array.html index c22e50fe2..c8fded242 100644 --- a/reference/rte-kernels/module/mo_rte_util_array.html +++ b/reference/rte-kernels/module/mo_rte_util_array.html @@ -85,12 +85,12 @@

    mo_rte_util_array
  • 53 statements + title=" 1.9% of total for modules and submodules.">27 statements
  • Source File
      • -
    1. mo_rte_util_array.F90
      2. +
    2. mo_rte_util_array.F90
    3. mo_rte_util_array
    @@ -113,18 +113,7 @@

    Contents

    Interfaces

    - zero_array -
    -
    - -
    -

    Subroutines

    -
    -
    @@ -239,108 +228,7 @@

    Uses

    -
    -
    -

    Used by

    -
    -
      -
    • -
      - - - - - -module~~mo_rte_util_array~~UsedByGraph - - - -module~mo_rte_util_array - -mo_rte_util_array - - - -module~mo_rte_solver_kernels - - -mo_rte_solver_kernels - - - - - -module~mo_rte_solver_kernels->module~mo_rte_util_array - - - - - -
      -
      • -
    -
    -
    @@ -350,18 +238,7 @@

    Contents

    Interfaces

    - zero_array -
    -
    - -
    -

    Subroutines

    -
    -
    @@ -375,13 +252,10 @@

    Contents

    Interfaces

    -

    public interface zero_array

    -
    -

    Efficiently set arrays to zero

    -
    +

    public interface zero_array

    • -

      public subroutine zero_array_1D(ni, array) bind(C, name="0")

      +

      public subroutine zero_array_1D(ni, array) bind(C, name="0")

      Arguments

      @@ -403,7 +277,7 @@

      Arguments

      TypeIntentOptionalAttributesName
    • -

      public subroutine zero_array_2D(ni, nj, array) bind(C, name="0")

      +

      public subroutine zero_array_2D(ni, nj, array) bind(C, name="0")

      Arguments

      • @@ -431,7 +305,7 @@

      Arguments

      TypeIntentOptionalAttributesName
    • -

      public subroutine zero_array_3D(ni, nj, nk, array) bind(C, name="0")

      +

      public subroutine zero_array_3D(ni, nj, nk, array) bind(C, name="0")

      Arguments

      • @@ -465,7 +339,7 @@

      Arguments

      TypeIntentOptionalAttributesName
    • -

      public subroutine zero_array_4D(ni, nj, nk, nl, array) bind(C, name="0")

      +

      public subroutine zero_array_4D(ni, nj, nk, nl, array) bind(C, name="0")

      Arguments

      • @@ -513,150 +387,6 @@

      Arguments

      TypeIntentOptionalAttributesName
      -
      -

      Subroutines

      -
      -

      public subroutine zero_array_1D(ni, array) bind(C, name="0")

      -
      - -

      Arguments

      - - - - - - - - - - - - - - - -
      TypeIntentOptionalAttributesName
      integer,intent(in) ::ni
      real(kind=wp),intent(out), dimension(ni)::array
      - - -
    - - -
    -

    public subroutine zero_array_2D(ni, nj, array) bind(C, name="0")

    -
    - -

    Arguments

    - - - - - - - - - - - - - - - - - - - - - -
    TypeIntentOptionalAttributesName
    integer,intent(in) ::ni
    integer,intent(in) ::nj
    real(kind=wp),intent(out), dimension(ni, nj)::array
    - - -
    -
    - -
    -

    public subroutine zero_array_3D(ni, nj, nk, array) bind(C, name="0")

    -
    - -

    Arguments

    - - - - - - - - - - - - - - - - - - - - - - - - - - - -
    TypeIntentOptionalAttributesName
    integer,intent(in) ::ni
    integer,intent(in) ::nj
    integer,intent(in) ::nk
    real(kind=wp),intent(out), dimension(ni, nj, nk)::array
    - - -
    -
    - -
    -

    public subroutine zero_array_4D(ni, nj, nk, nl, array) bind(C, name="0")

    -
    - -

    Arguments

    - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
    TypeIntentOptionalAttributesName
    integer,intent(in) ::ni
    integer,intent(in) ::nj
    integer,intent(in) ::nk
    integer,intent(in) ::nl
    real(kind=wp),intent(out), dimension(ni, nj, nk, nl)::array
    - - -
    -
    - -
    -
    diff --git a/reference/rte-kernels/module/mo_rte_util_array~2.html b/reference/rte-kernels/module/mo_rte_util_array~2.html new file mode 100644 index 000000000..ac8bb2fbb --- /dev/null +++ b/reference/rte-kernels/module/mo_rte_util_array~2.html @@ -0,0 +1,710 @@ + + + + + + + + + + + mo_rte_util_array – RTE kernels + + + + + + + + + + + + + + + + + + + + +
    +
    +

    mo_rte_util_array + Module +

    +
    +
    +
    + +
      +
    1. mo_rte_util_array.F90
      2. +
    2. mo_rte_util_array
      3. +
    +
    +
    +
    + + +
    + +
    + + +
    + +
    +
    +

    Uses

    +
    +
      +
    • +
        +
      • mo_rte_kind
        • +
      +
      • +
    • +
      + + + + + +module~~mo_rte_util_array~2~~UsesGraph + + + +module~mo_rte_util_array~2 + +mo_rte_util_array + + + +mo_rte_kind + +mo_rte_kind + + + +module~mo_rte_util_array~2->mo_rte_kind + + + + + +
      +
      • +
    +
    + +
    +
    +

    Used by

    +
    +
      +
    • +
      + + + + + +module~~mo_rte_util_array~2~~UsedByGraph + + + +module~mo_rte_util_array~2 + +mo_rte_util_array + + + +module~mo_rte_solver_kernels + + +mo_rte_solver_kernels + + + + + +module~mo_rte_solver_kernels->module~mo_rte_util_array~2 + + + + + +
      +
      • +
    +
    + +
    + +
    +

    Contents

    + +
    +

    Interfaces

    +
    +
    + zero_array +
    +
    +
    +
    +

    Subroutines

    +
    + +
    +
    + +
    +
    + + + + +
    +

    Interfaces

    +
    +

    public interface zero_array

    +
    +

    Efficiently set arrays to zero

    +
    +
      +
    • +

      public subroutine zero_array_1D(ni, array) bind(C, name="0")

      +

      Arguments

      + + + + + + + + + + + + + + + +
      TypeIntentOptionalAttributesName
      integer,intent(in) ::ni
      real(kind=wp),intent(out), dimension(ni)::array
      + + +
      • +
    • +

      public subroutine zero_array_2D(ni, nj, array) bind(C, name="0")

      +

      Arguments

      + + + + + + + + + + + + + + + + + + + + + +
      TypeIntentOptionalAttributesName
      integer,intent(in) ::ni
      integer,intent(in) ::nj
      real(kind=wp),intent(out), dimension(ni, nj)::array
      + + +
      • +
    • +

      public subroutine zero_array_3D(ni, nj, nk, array) bind(C, name="0")

      +

      Arguments

      + + + + + + + + + + + + + + + + + + + + + + + + + + + +
      TypeIntentOptionalAttributesName
      integer,intent(in) ::ni
      integer,intent(in) ::nj
      integer,intent(in) ::nk
      real(kind=wp),intent(out), dimension(ni, nj, nk)::array
      + + +
      • +
    • +

      public subroutine zero_array_4D(ni, nj, nk, nl, array) bind(C, name="0")

      +

      Arguments

      + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
      TypeIntentOptionalAttributesName
      integer,intent(in) ::ni
      integer,intent(in) ::nj
      integer,intent(in) ::nk
      integer,intent(in) ::nl
      real(kind=wp),intent(out), dimension(ni, nj, nk, nl)::array
      + + +
      • +
    +
    + +
    +
    + + + + +
    +

    Subroutines

    +
    +

    public subroutine zero_array_1D(ni, array) bind(C, name="0")

    +
    + +

    Arguments

    + + + + + + + + + + + + + + + +
    TypeIntentOptionalAttributesName
    integer,intent(in) ::ni
    real(kind=wp),intent(out), dimension(ni)::array
    + + +
    +
    + +
    +

    public subroutine zero_array_2D(ni, nj, array) bind(C, name="0")

    +
    + +

    Arguments

    + + + + + + + + + + + + + + + + + + + + + +
    TypeIntentOptionalAttributesName
    integer,intent(in) ::ni
    integer,intent(in) ::nj
    real(kind=wp),intent(out), dimension(ni, nj)::array
    + + +
    +
    + +
    +

    public subroutine zero_array_3D(ni, nj, nk, array) bind(C, name="0")

    +
    + +

    Arguments

    + + + + + + + + + + + + + + + + + + + + + + + + + + + +
    TypeIntentOptionalAttributesName
    integer,intent(in) ::ni
    integer,intent(in) ::nj
    integer,intent(in) ::nk
    real(kind=wp),intent(out), dimension(ni, nj, nk)::array
    + + +
    +
    + +
    +

    public subroutine zero_array_4D(ni, nj, nk, nl, array) bind(C, name="0")

    +
    + +

    Arguments

    + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
    TypeIntentOptionalAttributesName
    integer,intent(in) ::ni
    integer,intent(in) ::nj
    integer,intent(in) ::nk
    integer,intent(in) ::nl
    real(kind=wp),intent(out), dimension(ni, nj, nk, nl)::array
    + + +
    +
    + +
    +
    + +
    +
    + +
    +
    +
    +
    +
    +

    RTE kernels was developed by The RTE+RRTTMGP consortium
    © 2024 Creative Commons License +

    +
    +
    +

    + Documentation generated by + FORD +

    +
    +
    +
    +
    +
    + + + + + + + + + + + + + + + + + + + \ No newline at end of file diff --git a/reference/rte-kernels/proc/delta_scale_2str_f_k.html b/reference/rte-kernels/proc/delta_scale_2str_f_k.html index 24ddb8eee..39e24bc2c 100644 --- a/reference/rte-kernels/proc/delta_scale_2str_f_k.html +++ b/reference/rte-kernels/proc/delta_scale_2str_f_k.html @@ -85,7 +85,7 @@

    delta_scale_2str_f_k
  • 17 statements + title=" 1.8% of total for procedures.">17 statements
  • Source File
    • @@ -127,37 +127,37 @@

    Arguments

    TypeIntentOptionalAttributesName - integer, + integer, intent(in) :: ncol

    Array sizes

    - integer, + integer, intent(in) :: nlay

    Array sizes

    - integer, + integer, intent(in) :: ngpt

    Array sizes

    - real(kind=wp), + real(kind=wp), intent(inout), dimension(ncol, nlay, ngpt):: tau

    Optical depth, single-scattering albedo, asymmetry parameter

    - real(kind=wp), + real(kind=wp), intent(inout), dimension(ncol, nlay, ngpt):: ssa

    Optical depth, single-scattering albedo, asymmetry parameter

    - real(kind=wp), + real(kind=wp), intent(inout), dimension(ncol, nlay, ngpt):: g

    Optical depth, single-scattering albedo, asymmetry parameter

    diff --git a/reference/rte-kernels/proc/delta_scale_2str_k.html b/reference/rte-kernels/proc/delta_scale_2str_k.html index b49e7b321..6fccd303c 100644 --- a/reference/rte-kernels/proc/delta_scale_2str_k.html +++ b/reference/rte-kernels/proc/delta_scale_2str_k.html @@ -85,7 +85,7 @@

    delta_scale_2str_k
  • 17 statements + title=" 1.8% of total for procedures.">17 statements
  • Source File
    • @@ -129,37 +129,37 @@

    Arguments

    TypeIntentOptionalAttributesName - integer, + integer, intent(in) :: ncol

    Array sizes

    - integer, + integer, intent(in) :: nlay

    Array sizes

    - integer, + integer, intent(in) :: ngpt

    Array sizes

    - real(kind=wp), + real(kind=wp), intent(inout), dimension(ncol, nlay, ngpt):: tau

    Optical depth, single-scattering albedo, asymmetry parameter

    - real(kind=wp), + real(kind=wp), intent(inout), dimension(ncol, nlay, ngpt):: ssa

    Optical depth, single-scattering albedo, asymmetry parameter

    - real(kind=wp), + real(kind=wp), intent(inout), dimension(ncol, nlay, ngpt):: g

    Optical depth, single-scattering albedo, asymmetry parameter

    diff --git a/reference/rte-kernels/proc/extract_subset_absorption_tau.html b/reference/rte-kernels/proc/extract_subset_absorption_tau.html index d6f27c754..99972baf1 100644 --- a/reference/rte-kernels/proc/extract_subset_absorption_tau.html +++ b/reference/rte-kernels/proc/extract_subset_absorption_tau.html @@ -85,7 +85,7 @@

    extract_subset_absorption_tau
  • 14 statements + title=" 1.5% of total for procedures.">14 statements
  • Source File
    • @@ -128,19 +128,19 @@

    Arguments

    TypeIntentOptionalAttributesName - integer, + integer, intent(in) :: ncol

    Array sizes

    - integer, + integer, intent(in) :: nlay

    Array sizes

    - integer, + integer, intent(in) :: ngpt

    Array sizes

    diff --git a/reference/rte-kernels/proc/extract_subset_dim1_3d.html b/reference/rte-kernels/proc/extract_subset_dim1_3d.html index 9d77e4bae..5c4881161 100644 --- a/reference/rte-kernels/proc/extract_subset_dim1_3d.html +++ b/reference/rte-kernels/proc/extract_subset_dim1_3d.html @@ -85,7 +85,7 @@

    extract_subset_dim1_3d
  • 14 statements + title=" 1.5% of total for procedures.">14 statements
  • Source File
    • @@ -128,19 +128,19 @@

    Arguments

    TypeIntentOptionalAttributesName - integer, + integer, intent(in) :: ncol

    Array sizes

    - integer, + integer, intent(in) :: nlay

    Array sizes

    - integer, + integer, intent(in) :: ngpt

    Array sizes

    diff --git a/reference/rte-kernels/proc/extract_subset_dim2_4d.html b/reference/rte-kernels/proc/extract_subset_dim2_4d.html index 8fcca98cb..1b9d46852 100644 --- a/reference/rte-kernels/proc/extract_subset_dim2_4d.html +++ b/reference/rte-kernels/proc/extract_subset_dim2_4d.html @@ -85,7 +85,7 @@

    extract_subset_dim2_4d
  • 16 statements + title=" 1.7% of total for procedures.">16 statements
  • Source File
    • @@ -134,19 +134,19 @@

    Arguments

    nmom

    Array sizes

    - integer, + integer, intent(in) :: ncol

    Array sizes

    - integer, + integer, intent(in) :: nlay

    Array sizes

    - integer, + integer, intent(in) :: ngpt

    Array sizes

    diff --git a/reference/rte-kernels/proc/inc_1scalar_by_1scalar_bybnd.html b/reference/rte-kernels/proc/inc_1scalar_by_1scalar_bybnd.html index 5be50057d..4477e873c 100644 --- a/reference/rte-kernels/proc/inc_1scalar_by_1scalar_bybnd.html +++ b/reference/rte-kernels/proc/inc_1scalar_by_1scalar_bybnd.html @@ -85,7 +85,7 @@

    inc_1scalar_by_1scalar_bybnd
  • 12 statements + title=" 1.3% of total for procedures.">12 statements
  • Source File
    • @@ -127,19 +127,19 @@

    Arguments

    TypeIntentOptionalAttributesName - integer, + integer, intent(in) :: ncol

    array sizes

    - integer, + integer, intent(in) :: nlay

    array sizes

    - integer, + integer, intent(in) :: ngpt

    array sizes

    diff --git a/reference/rte-kernels/proc/inc_1scalar_by_2stream_bybnd.html b/reference/rte-kernels/proc/inc_1scalar_by_2stream_bybnd.html index 6d625fc7b..34dc18599 100644 --- a/reference/rte-kernels/proc/inc_1scalar_by_2stream_bybnd.html +++ b/reference/rte-kernels/proc/inc_1scalar_by_2stream_bybnd.html @@ -85,7 +85,7 @@

    inc_1scalar_by_2stream_bybnd
  • 12 statements + title=" 1.3% of total for procedures.">12 statements
  • Source File
    • @@ -127,19 +127,19 @@

    Arguments

    TypeIntentOptionalAttributesName - integer, + integer, intent(in) :: ncol

    array sizes

    - integer, + integer, intent(in) :: nlay

    array sizes

    - integer, + integer, intent(in) :: ngpt

    array sizes

    diff --git a/reference/rte-kernels/proc/inc_1scalar_by_nstream_bybnd.html b/reference/rte-kernels/proc/inc_1scalar_by_nstream_bybnd.html index 82c276bc2..bb4f6f34e 100644 --- a/reference/rte-kernels/proc/inc_1scalar_by_nstream_bybnd.html +++ b/reference/rte-kernels/proc/inc_1scalar_by_nstream_bybnd.html @@ -85,7 +85,7 @@

    inc_1scalar_by_nstream_bybnd
  • 12 statements + title=" 1.3% of total for procedures.">12 statements
  • Source File
    • @@ -127,19 +127,19 @@

    Arguments

    TypeIntentOptionalAttributesName - integer, + integer, intent(in) :: ncol

    array sizes

    - integer, + integer, intent(in) :: nlay

    array sizes

    - integer, + integer, intent(in) :: ngpt

    array sizes

    diff --git a/reference/rte-kernels/proc/inc_2stream_by_1scalar_bybnd.html b/reference/rte-kernels/proc/inc_2stream_by_1scalar_bybnd.html index 2732b4df8..aa43e039b 100644 --- a/reference/rte-kernels/proc/inc_2stream_by_1scalar_bybnd.html +++ b/reference/rte-kernels/proc/inc_2stream_by_1scalar_bybnd.html @@ -85,7 +85,7 @@

    inc_2stream_by_1scalar_bybnd
  • 19 statements + title=" 2.0% of total for procedures.">19 statements
  • Source File
    • @@ -127,19 +127,19 @@

    Arguments

    TypeIntentOptionalAttributesName - integer, + integer, intent(in) :: ncol

    array sizes

    - integer, + integer, intent(in) :: nlay

    array sizes

    - integer, + integer, intent(in) :: ngpt

    array sizes

    diff --git a/reference/rte-kernels/proc/inc_2stream_by_2stream_bybnd.html b/reference/rte-kernels/proc/inc_2stream_by_2stream_bybnd.html index cb2a1b7ab..d345a3e77 100644 --- a/reference/rte-kernels/proc/inc_2stream_by_2stream_bybnd.html +++ b/reference/rte-kernels/proc/inc_2stream_by_2stream_bybnd.html @@ -85,7 +85,7 @@

    inc_2stream_by_2stream_bybnd
  • 21 statements + title=" 2.2% of total for procedures.">21 statements
  • Source File
    • @@ -127,19 +127,19 @@

    Arguments

    TypeIntentOptionalAttributesName - integer, + integer, intent(in) :: ncol

    array sizes

    - integer, + integer, intent(in) :: nlay

    array sizes

    - integer, + integer, intent(in) :: ngpt

    array sizes

    diff --git a/reference/rte-kernels/proc/inc_2stream_by_nstream_bybnd.html b/reference/rte-kernels/proc/inc_2stream_by_nstream_bybnd.html index b4e06ff7d..6689abd0f 100644 --- a/reference/rte-kernels/proc/inc_2stream_by_nstream_bybnd.html +++ b/reference/rte-kernels/proc/inc_2stream_by_nstream_bybnd.html @@ -85,7 +85,7 @@

    inc_2stream_by_nstream_bybnd
  • 22 statements + title=" 2.3% of total for procedures.">22 statements
  • Source File
    • @@ -127,19 +127,19 @@

    Arguments

    TypeIntentOptionalAttributesName - integer, + integer, intent(in) :: ncol

    array sizes

    - integer, + integer, intent(in) :: nlay

    array sizes

    - integer, + integer, intent(in) :: ngpt

    array sizes

    diff --git a/reference/rte-kernels/proc/inc_nstream_by_1scalar_bybnd.html b/reference/rte-kernels/proc/inc_nstream_by_1scalar_bybnd.html index b93c4a734..8b8eea5cb 100644 --- a/reference/rte-kernels/proc/inc_nstream_by_1scalar_bybnd.html +++ b/reference/rte-kernels/proc/inc_nstream_by_1scalar_bybnd.html @@ -85,7 +85,7 @@

    inc_nstream_by_1scalar_bybnd
  • 19 statements + title=" 2.0% of total for procedures.">19 statements
  • Source File
    • @@ -127,19 +127,19 @@

    Arguments

    TypeIntentOptionalAttributesName - integer, + integer, intent(in) :: ncol

    array sizes

    - integer, + integer, intent(in) :: nlay

    array sizes

    - integer, + integer, intent(in) :: ngpt

    array sizes

    diff --git a/reference/rte-kernels/proc/inc_nstream_by_2stream_bybnd.html b/reference/rte-kernels/proc/inc_nstream_by_2stream_bybnd.html index 1afeec321..982bbdfa4 100644 --- a/reference/rte-kernels/proc/inc_nstream_by_2stream_bybnd.html +++ b/reference/rte-kernels/proc/inc_nstream_by_2stream_bybnd.html @@ -85,7 +85,7 @@

    inc_nstream_by_2stream_bybnd
  • 28 statements + title=" 3.0% of total for procedures.">28 statements
  • Source File
    • @@ -127,19 +127,19 @@

    Arguments

    TypeIntentOptionalAttributesName - integer, + integer, intent(in) :: ncol

    array sizes

    - integer, + integer, intent(in) :: nlay

    array sizes

    - integer, + integer, intent(in) :: ngpt

    array sizes

    diff --git a/reference/rte-kernels/proc/inc_nstream_by_nstream_bybnd.html b/reference/rte-kernels/proc/inc_nstream_by_nstream_bybnd.html index c239fd493..177a723e5 100644 --- a/reference/rte-kernels/proc/inc_nstream_by_nstream_bybnd.html +++ b/reference/rte-kernels/proc/inc_nstream_by_nstream_bybnd.html @@ -85,7 +85,7 @@

    inc_nstream_by_nstream_bybnd
  • 24 statements + title=" 2.5% of total for procedures.">24 statements
  • Source File
    • @@ -127,19 +127,19 @@

    Arguments

    TypeIntentOptionalAttributesName - integer, + integer, intent(in) :: ncol

    array sizes

    - integer, + integer, intent(in) :: nlay

    array sizes

    - integer, + integer, intent(in) :: ngpt

    array sizes

    diff --git a/reference/rte-kernels/proc/increment_1scalar_by_1scalar.html b/reference/rte-kernels/proc/increment_1scalar_by_1scalar.html index 578aff9b2..d80042232 100644 --- a/reference/rte-kernels/proc/increment_1scalar_by_1scalar.html +++ b/reference/rte-kernels/proc/increment_1scalar_by_1scalar.html @@ -85,7 +85,7 @@

    increment_1scalar_by_1scalar
  • 13 statements + title=" 1.4% of total for procedures.">13 statements
  • Source File
    • @@ -127,19 +127,19 @@

    Arguments

    TypeIntentOptionalAttributesName - integer, + integer, intent(in) :: ncol

    array sizes

    - integer, + integer, intent(in) :: nlay

    array sizes

    - integer, + integer, intent(in) :: ngpt

    array sizes

    diff --git a/reference/rte-kernels/proc/increment_1scalar_by_2stream.html b/reference/rte-kernels/proc/increment_1scalar_by_2stream.html index 053b34962..6fcf8f053 100644 --- a/reference/rte-kernels/proc/increment_1scalar_by_2stream.html +++ b/reference/rte-kernels/proc/increment_1scalar_by_2stream.html @@ -85,7 +85,7 @@

    increment_1scalar_by_2stream
  • 13 statements + title=" 1.4% of total for procedures.">13 statements
  • Source File
    • @@ -127,19 +127,19 @@

    Arguments

    TypeIntentOptionalAttributesName - integer, + integer, intent(in) :: ncol

    array sizes

    - integer, + integer, intent(in) :: nlay

    array sizes

    - integer, + integer, intent(in) :: ngpt

    array sizes

    diff --git a/reference/rte-kernels/proc/increment_1scalar_by_nstream.html b/reference/rte-kernels/proc/increment_1scalar_by_nstream.html index 3f87932db..e54e8e029 100644 --- a/reference/rte-kernels/proc/increment_1scalar_by_nstream.html +++ b/reference/rte-kernels/proc/increment_1scalar_by_nstream.html @@ -85,7 +85,7 @@

    increment_1scalar_by_nstream
  • 13 statements + title=" 1.4% of total for procedures.">13 statements
  • Source File
    • @@ -127,19 +127,19 @@

    Arguments

    TypeIntentOptionalAttributesName - integer, + integer, intent(in) :: ncol

    array sizes

    - integer, + integer, intent(in) :: nlay

    array sizes

    - integer, + integer, intent(in) :: ngpt

    array sizes

    diff --git a/reference/rte-kernels/proc/increment_2stream_by_1scalar.html b/reference/rte-kernels/proc/increment_2stream_by_1scalar.html index 93f2f2afa..7067ff7de 100644 --- a/reference/rte-kernels/proc/increment_2stream_by_1scalar.html +++ b/reference/rte-kernels/proc/increment_2stream_by_1scalar.html @@ -85,7 +85,7 @@

    increment_2stream_by_1scalar
  • 16 statements + title=" 1.7% of total for procedures.">16 statements
  • Source File
    • @@ -127,19 +127,19 @@

    Arguments

    TypeIntentOptionalAttributesName - integer, + integer, intent(in) :: ncol

    array sizes

    - integer, + integer, intent(in) :: nlay

    array sizes

    - integer, + integer, intent(in) :: ngpt

    array sizes

    diff --git a/reference/rte-kernels/proc/increment_2stream_by_2stream.html b/reference/rte-kernels/proc/increment_2stream_by_2stream.html index c2a16aca7..1ab8dedcd 100644 --- a/reference/rte-kernels/proc/increment_2stream_by_2stream.html +++ b/reference/rte-kernels/proc/increment_2stream_by_2stream.html @@ -85,7 +85,7 @@

    increment_2stream_by_2stream
  • 18 statements + title=" 1.9% of total for procedures.">18 statements
  • Source File
    • @@ -127,19 +127,19 @@

    Arguments

    TypeIntentOptionalAttributesName - integer, + integer, intent(in) :: ncol

    array sizes

    - integer, + integer, intent(in) :: nlay

    array sizes

    - integer, + integer, intent(in) :: ngpt

    array sizes

    diff --git a/reference/rte-kernels/proc/increment_2stream_by_nstream.html b/reference/rte-kernels/proc/increment_2stream_by_nstream.html index 8a277e85b..cd9c9875e 100644 --- a/reference/rte-kernels/proc/increment_2stream_by_nstream.html +++ b/reference/rte-kernels/proc/increment_2stream_by_nstream.html @@ -85,7 +85,7 @@

    increment_2stream_by_nstream
  • 19 statements + title=" 2.0% of total for procedures.">19 statements
  • Source File
    • @@ -127,19 +127,19 @@

    Arguments

    TypeIntentOptionalAttributesName - integer, + integer, intent(in) :: ncol

    array sizes

    - integer, + integer, intent(in) :: nlay

    array sizes

    - integer, + integer, intent(in) :: ngpt

    array sizes

    diff --git a/reference/rte-kernels/proc/increment_nstream_by_1scalar.html b/reference/rte-kernels/proc/increment_nstream_by_1scalar.html index a57fce254..591896387 100644 --- a/reference/rte-kernels/proc/increment_nstream_by_1scalar.html +++ b/reference/rte-kernels/proc/increment_nstream_by_1scalar.html @@ -85,7 +85,7 @@

    increment_nstream_by_1scalar
  • 16 statements + title=" 1.7% of total for procedures.">16 statements
  • Source File
    • @@ -127,19 +127,19 @@

    Arguments

    TypeIntentOptionalAttributesName - integer, + integer, intent(in) :: ncol

    array sizes

    - integer, + integer, intent(in) :: nlay

    array sizes

    - integer, + integer, intent(in) :: ngpt

    array sizes

    diff --git a/reference/rte-kernels/proc/increment_nstream_by_2stream.html b/reference/rte-kernels/proc/increment_nstream_by_2stream.html index 86dd42e68..fc0bf9ae1 100644 --- a/reference/rte-kernels/proc/increment_nstream_by_2stream.html +++ b/reference/rte-kernels/proc/increment_nstream_by_2stream.html @@ -85,7 +85,7 @@

    increment_nstream_by_2stream
  • 25 statements + title=" 2.7% of total for procedures.">25 statements
  • Source File
    • @@ -127,19 +127,19 @@

    Arguments

    TypeIntentOptionalAttributesName - integer, + integer, intent(in) :: ncol

    array sizes

    - integer, + integer, intent(in) :: nlay

    array sizes

    - integer, + integer, intent(in) :: ngpt

    array sizes

    diff --git a/reference/rte-kernels/proc/increment_nstream_by_nstream.html b/reference/rte-kernels/proc/increment_nstream_by_nstream.html index 26237d521..38cff3624 100644 --- a/reference/rte-kernels/proc/increment_nstream_by_nstream.html +++ b/reference/rte-kernels/proc/increment_nstream_by_nstream.html @@ -85,7 +85,7 @@

    increment_nstream_by_nstream
  • 21 statements + title=" 2.2% of total for procedures.">21 statements
  • Source File
    • @@ -127,19 +127,19 @@

    Arguments

    TypeIntentOptionalAttributesName - integer, + integer, intent(in) :: ncol

    array sizes

    - integer, + integer, intent(in) :: nlay

    array sizes

    - integer, + integer, intent(in) :: ngpt

    array sizes

    diff --git a/reference/rte-kernels/proc/lw_solver_2stream.html b/reference/rte-kernels/proc/lw_solver_2stream.html index bbac46345..23b5a2a63 100644 --- a/reference/rte-kernels/proc/lw_solver_2stream.html +++ b/reference/rte-kernels/proc/lw_solver_2stream.html @@ -85,7 +85,7 @@

    lw_solver_2stream
  • 28 statements + title=" 2.7% of total for procedures.">25 statements
  • Source File
    • @@ -117,7 +117,7 @@

    Contents

    -

    public subroutine lw_solver_2stream(ncol, nlay, ngpt, top_at_1, tau, ssa, g, lay_source, lev_source_inc, lev_source_dec, sfc_emis, sfc_src, inc_flux, flux_up, flux_dn) bind(C, name="0")

    +

    public subroutine lw_solver_2stream(ncol, nlay, ngpt, top_at_1, tau, ssa, g, lay_source, lev_source, sfc_emis, sfc_src, inc_flux, flux_up, flux_dn) bind(C, name="0")

    Longwave two-stream calculation: @@ -131,19 +131,19 @@

    Arguments

    TypeIntentOptionalAttributesName - integer, + integer, intent(in) :: ncol

    Number of columns, layers, g-points

    - integer, + integer, intent(in) :: nlay

    Number of columns, layers, g-points

    - integer, + integer, intent(in) :: ngpt

    Number of columns, layers, g-points

    @@ -155,19 +155,19 @@

    Arguments

    top_at_1

    ilay = 1 is the top of the atmosphere?

    - real(kind=wp), + real(kind=wp), intent(in), dimension(ncol,nlay, ngpt):: tau

    Optical thickness, single-scattering albedo, asymmetry parameter []

    - real(kind=wp), + real(kind=wp), intent(in), dimension(ncol,nlay, ngpt):: ssa

    Optical thickness, single-scattering albedo, asymmetry parameter []

    - real(kind=wp), + real(kind=wp), intent(in), dimension(ncol,nlay, ngpt):: g

    Optical thickness, single-scattering albedo, asymmetry parameter []

    @@ -179,16 +179,10 @@

    Arguments

    lay_source

    Planck source at layer average temperature [W/m2]

    - real(kind=wp), + real(kind=wp), intent(in), - dimension(ncol,nlay, ngpt):: - lev_source_inc

    Planck source at layer edge for radiation in increasing ilay direction [W/m2]

    - - - real(kind=wp), -intent(in), - dimension(ncol,nlay, ngpt):: - lev_source_dec

    Planck source at layer edge for radiation in decreasing ilay direction [W/m2]

    + dimension(ncol,nlay+1,ngpt):: + lev_source

    Planck source at layer edge temperature [W/m2]

    real(kind=wp), diff --git a/reference/rte-kernels/proc/lw_solver_noscat.html b/reference/rte-kernels/proc/lw_solver_noscat.html index 24a0140cf..3fa3cef9b 100644 --- a/reference/rte-kernels/proc/lw_solver_noscat.html +++ b/reference/rte-kernels/proc/lw_solver_noscat.html @@ -85,7 +85,7 @@

    lw_solver_noscat
  • 58 statements + title=" 6.0% of total for procedures.">57 statements
  • Source File
    • @@ -117,7 +117,7 @@

    Contents

    -

    public subroutine lw_solver_noscat(ncol, nlay, ngpt, top_at_1, nmus, Ds, weights, tau, lay_source, lev_source_inc, lev_source_dec, sfc_emis, sfc_src, inc_flux, flux_up, flux_dn, do_broadband, broadband_up, broadband_dn, do_Jacobians, sfc_srcJac, flux_upJac, do_rescaling, ssa, g) bind(C, name="0")

    +

    public subroutine lw_solver_noscat(ncol, nlay, ngpt, top_at_1, nmus, Ds, weights, tau, lay_source, lev_source, sfc_emis, sfc_src, inc_flux, flux_up, flux_dn, do_broadband, broadband_up, broadband_dn, do_Jacobians, sfc_srcJac, flux_upJac, do_rescaling, ssa, g) bind(C, name="0")

    LW transport, no scattering, multi-angle quadrature @@ -129,19 +129,19 @@

    Arguments

    TypeIntentOptionalAttributesName - integer, + integer, intent(in) :: ncol

    Number of columns, layers, g-points

    - integer, + integer, intent(in) :: nlay

    Number of columns, layers, g-points

    - integer, + integer, intent(in) :: ngpt

    Number of columns, layers, g-points

    @@ -171,7 +171,7 @@

    Arguments

    weights

    quadrature weights

    - real(kind=wp), + real(kind=wp), intent(in), dimension(ncol,nlay, ngpt):: tau

    Absorption optical thickness []

    @@ -183,16 +183,10 @@

    Arguments

    lay_source

    Planck source at layer average temperature [W/m2]

    - real(kind=wp), + real(kind=wp), intent(in), - dimension(ncol,nlay, ngpt):: - lev_source_inc

    Planck source at layer edge for radiation in increasing ilay direction [W/m2]

    - - - real(kind=wp), -intent(in), - dimension(ncol,nlay, ngpt):: - lev_source_dec

    Planck source at layer edge for radiation in decreasing ilay direction [W/m2]

    + dimension(ncol,nlay+1,ngpt):: + lev_source

    Planck source at layer edge for radiation[W/m2]

    real(kind=wp), @@ -267,13 +261,13 @@

    Arguments

    do_rescaling

    Approximate treatment of scattering (10.1175/JAS-D-18-0014.1)

    - real(kind=wp), + real(kind=wp), intent(in), dimension(ncol,nlay ,ngpt):: ssa

    single-scattering albedo, asymmetry parameter

    - real(kind=wp), + real(kind=wp), intent(in), dimension(ncol,nlay ,ngpt):: g

    single-scattering albedo, asymmetry parameter

    diff --git a/reference/rte-kernels/proc/sum_broadband.html b/reference/rte-kernels/proc/sum_broadband.html index 62237266c..ae889a878 100644 --- a/reference/rte-kernels/proc/sum_broadband.html +++ b/reference/rte-kernels/proc/sum_broadband.html @@ -85,7 +85,7 @@

    sum_broadband
  • 16 statements + title=" 1.7% of total for procedures.">16 statements
  • Source File
    • @@ -127,7 +127,7 @@

    Arguments

    TypeIntentOptionalAttributesName - integer, + integer, intent(in) :: ncol

    Array sizes

    @@ -139,7 +139,7 @@

    Arguments

    nlev

    Array sizes

    - integer, + integer, intent(in) :: ngpt

    Array sizes

    diff --git a/reference/rte-kernels/proc/sw_solver_2stream.html b/reference/rte-kernels/proc/sw_solver_2stream.html index dc5c9ecaa..715ca6afd 100644 --- a/reference/rte-kernels/proc/sw_solver_2stream.html +++ b/reference/rte-kernels/proc/sw_solver_2stream.html @@ -85,7 +85,7 @@

    sw_solver_2stream
  • 57 statements + title=" 6.0% of total for procedures.">57 statements
  • Source File
    • @@ -130,19 +130,19 @@

    Arguments

    TypeIntentOptionalAttributesName - integer, + integer, intent(in) :: ncol

    Number of columns, layers, g-points

    - integer, + integer, intent(in) :: nlay

    Number of columns, layers, g-points

    - integer, + integer, intent(in) :: ngpt

    Number of columns, layers, g-points

    @@ -154,19 +154,19 @@

    Arguments

    top_at_1

    ilay = 1 is the top of the atmosphere?

    - real(kind=wp), + real(kind=wp), intent(in), dimension(ncol,nlay, ngpt):: tau

    Optical thickness, single-scattering albedo, asymmetry parameter []

    - real(kind=wp), + real(kind=wp), intent(in), dimension(ncol,nlay, ngpt):: ssa

    Optical thickness, single-scattering albedo, asymmetry parameter []

    - real(kind=wp), + real(kind=wp), intent(in), dimension(ncol,nlay, ngpt):: g

    Optical thickness, single-scattering albedo, asymmetry parameter []

    @@ -305,33 +305,33 @@

    Calls

    - + -proc~zero_array_4d - +proc~zero_array_2d + -zero_array_4D +zero_array_2D - + -interface~zero_array->proc~zero_array_4d +interface~zero_array->proc~zero_array_2d - + -proc~zero_array_2d - +proc~zero_array_4d + -zero_array_2D +zero_array_4D - + -interface~zero_array->proc~zero_array_2d +interface~zero_array->proc~zero_array_4d diff --git a/reference/rte-kernels/proc/sw_solver_noscat.html b/reference/rte-kernels/proc/sw_solver_noscat.html index c46ed5f87..0d50921f5 100644 --- a/reference/rte-kernels/proc/sw_solver_noscat.html +++ b/reference/rte-kernels/proc/sw_solver_noscat.html @@ -85,7 +85,7 @@

    sw_solver_noscat
  • 24 statements + title=" 2.5% of total for procedures.">24 statements
  • Source File
    • @@ -126,19 +126,19 @@

    Arguments

    TypeIntentOptionalAttributesName - integer, + integer, intent(in) :: ncol

    Number of columns, layers, g-points

    - integer, + integer, intent(in) :: nlay

    Number of columns, layers, g-points

    - integer, + integer, intent(in) :: ngpt

    Number of columns, layers, g-points

    @@ -150,7 +150,7 @@

    Arguments

    top_at_1

    ilay = 1 is the top of the atmosphere?

    - real(kind=wp), + real(kind=wp), intent(in), dimension(ncol,nlay, ngpt):: tau

    Absorption optical thickness []

    diff --git a/reference/rte-kernels/proc/zero_array_1d.html b/reference/rte-kernels/proc/zero_array_1d.html index c5078926d..6096c0dac 100644 --- a/reference/rte-kernels/proc/zero_array_1d.html +++ b/reference/rte-kernels/proc/zero_array_1d.html @@ -85,13 +85,13 @@

    zero_array_1D
  • 8 statements + title=" 0.8% of total for procedures.">8 statements
  • Source File
    1. mo_rte_util_array.F90
      2. -
    2. mo_rte_util_array
      3. +
    3. mo_rte_util_array
    4. zero_array_1D

    diff --git a/reference/rte-kernels/proc/zero_array_2d.html b/reference/rte-kernels/proc/zero_array_2d.html index ed108ec89..afcbca667 100644 --- a/reference/rte-kernels/proc/zero_array_2d.html +++ b/reference/rte-kernels/proc/zero_array_2d.html @@ -85,13 +85,13 @@

    zero_array_2D
  • 10 statements + title=" 1.1% of total for procedures.">10 statements
  • Source File
    1. mo_rte_util_array.F90
      2. -
    2. mo_rte_util_array
      3. +
    3. mo_rte_util_array
    4. zero_array_2D
    diff --git a/reference/rte-kernels/proc/zero_array_3d.html b/reference/rte-kernels/proc/zero_array_3d.html index 0dc16e952..49e501fa3 100644 --- a/reference/rte-kernels/proc/zero_array_3d.html +++ b/reference/rte-kernels/proc/zero_array_3d.html @@ -85,13 +85,13 @@

    zero_array_3D
  • 12 statements + title=" 1.3% of total for procedures.">12 statements
  • Source File
    1. mo_rte_util_array.F90
      2. -
    2. mo_rte_util_array
      3. +
    3. mo_rte_util_array
    4. zero_array_3D
    diff --git a/reference/rte-kernels/proc/zero_array_4d.html b/reference/rte-kernels/proc/zero_array_4d.html index 31e74f504..e18253377 100644 --- a/reference/rte-kernels/proc/zero_array_4d.html +++ b/reference/rte-kernels/proc/zero_array_4d.html @@ -85,13 +85,13 @@

    zero_array_4D
  • 14 statements + title=" 1.5% of total for procedures.">14 statements
  • Source File
    1. mo_rte_util_array.F90
      2. -
    2. mo_rte_util_array
      3. +
    3. mo_rte_util_array
    4. zero_array_4D
    diff --git a/reference/rte-kernels/sourcefile/mo_fluxes_broadband_kernels.f90.html b/reference/rte-kernels/sourcefile/mo_fluxes_broadband_kernels.f90.html index 143c59bb9..d54ee8177 100644 --- a/reference/rte-kernels/sourcefile/mo_fluxes_broadband_kernels.f90.html +++ b/reference/rte-kernels/sourcefile/mo_fluxes_broadband_kernels.f90.html @@ -85,7 +85,7 @@

    mo_fluxes_broadband_kernels.F90
  • 59 statements + title=" 4.2% of total for source files.">59 statements
  • Source File
    • diff --git a/reference/rte-kernels/sourcefile/mo_fluxes_broadband_kernels.f90~2.html b/reference/rte-kernels/sourcefile/mo_fluxes_broadband_kernels.f90~2.html new file mode 100644 index 000000000..078a8364c --- /dev/null +++ b/reference/rte-kernels/sourcefile/mo_fluxes_broadband_kernels.f90~2.html @@ -0,0 +1,281 @@ + + + + + + + + + + + mo_fluxes_broadband_kernels.F90 – RTE kernels + + + + + + + + + + + + + + + + + + + + +
    +
    +

    mo_fluxes_broadband_kernels.F90 + Source File +

    +
    +
    +
    + +
      +
    1. mo_fluxes_broadband_kernels.F90
      2. +
    +
    +
    +
    + + +
    +
    + +
    + +
    + +
    +

    Contents

    + +
    +

    Modules

    + +
    +
    +

    Source Code

    +
    + mo_fluxes_broadband_kernels.F90 +
    +
    + +
    +
    + +
    +

    Source Code

    + 
    ! This code is part of Radiative Transfer for Energetics (RTE)
+!
+! Contacts: Robert Pincus and Eli Mlawer
+! email:  rrtmgp@aer.com
+!
+! Copyright 2015-,  Atmospheric and Environmental Research,
+! Regents of the University of Colorado, Trustees of Columbia University.  All right reserved.
+!
+! Use and duplication is permitted under the terms of the
+!    BSD 3-clause license, see http://opensource.org/licenses/BSD-3-Clause
+! -------------------------------------------------------------------------------------------------
+!>
+!> ## Kernels for computing broadband fluxes
+!>
+! -------------------------------------------------------------------------------------------------
+module mo_fluxes_broadband_kernels
+  use, intrinsic :: iso_c_binding
+  use mo_rte_kind, only: wp
+  implicit none
+  private
+  public :: sum_broadband, net_broadband
+
+  ! ----------------------------------------------------------------------------
+  !>
+  !> Spectral reduction over all points
+  !>
+  interface
+    subroutine sum_broadband(ncol, nlev, ngpt, spectral_flux, broadband_flux) bind(C, name="rte_sum_broadband")
+      use mo_rte_kind, only: wp
+      integer,                               intent(in ) :: ncol, nlev, ngpt
+        !! Array sizes
+      real(wp), dimension(ncol, nlev, ngpt), intent(in ) :: spectral_flux
+        !! Spectrally-resolved flux
+      real(wp), dimension(ncol, nlev),       intent(out) :: broadband_flux
+        !! Sum of spectrally-resolved flux over `ngpt`
+    end subroutine sum_broadband
+  end interface
+  ! ----------------------------------------------------------------------------
+  !>
+  !> Spectral reduction over all points for net flux
+  !>   Overloaded - which routine is called depends on arguments 
+  !> 
+  interface net_broadband
+    ! ----------------------------------------------------------------------------
+    !>
+    !> Net flux from g-point fluxes up and down
+    !>
+    subroutine net_broadband_full(ncol, nlev, ngpt, spectral_flux_dn, spectral_flux_up, broadband_flux_net) &
+      bind(C, name="rte_net_broadband_full")
+      use mo_rte_kind, only: wp
+      integer,                               intent(in ) :: ncol, nlev, ngpt
+        !! Array sizes
+      real(wp), dimension(ncol, nlev, ngpt), intent(in ) :: spectral_flux_dn, spectral_flux_up
+        !! Spectrally-resolved flux up and down
+      real(wp), dimension(ncol, nlev),       intent(out) :: broadband_flux_net
+        !! Net (down minus up) summed over `ngpt`
+     end subroutine net_broadband_full
+    ! ----------------------------------------------------------------------------
+    !>
+    !> Net flux when bradband flux up and down are already available
+    !>
+    subroutine net_broadband_precalc(ncol, nlev, flux_dn, flux_up, broadband_flux_net) &
+      bind(C, name="rte_net_broadband_precalc")
+      use mo_rte_kind, only: wp
+      integer,                         intent(in ) :: ncol, nlev
+        !! Array sizes
+      real(wp), dimension(ncol, nlev), intent(in ) :: flux_dn, flux_up
+        !! Broadband downward and upward fluxes
+      real(wp), dimension(ncol, nlev), intent(out) :: broadband_flux_net
+        !! Net (down minus up)
+     end subroutine net_broadband_precalc
+  end interface net_broadband
+  ! ----------------------------------------------------------------------------
+end module mo_fluxes_broadband_kernels
+
    + +
    +
    +
    + +
    +
    +
    +
    +
    +

    RTE kernels was developed by The RTE+RRTTMGP consortium
    © 2024 Creative Commons License +

    +
    +
    +

    + Documentation generated by + FORD +

    +
    +
    +
    +
    +
    + + + + + + + + + + + + + + + + + + + \ No newline at end of file diff --git a/reference/rte-kernels/sourcefile/mo_optical_props_kernels.f90.html b/reference/rte-kernels/sourcefile/mo_optical_props_kernels.f90.html index 8ad7f567d..e66c08b1b 100644 --- a/reference/rte-kernels/sourcefile/mo_optical_props_kernels.f90.html +++ b/reference/rte-kernels/sourcefile/mo_optical_props_kernels.f90.html @@ -85,7 +85,7 @@

    mo_optical_props_kernels.F90
  • 416 statements + title="29.5% of total for source files.">416 statements
  • Source File
    • diff --git a/reference/rte-kernels/sourcefile/mo_optical_props_kernels.f90~2.html b/reference/rte-kernels/sourcefile/mo_optical_props_kernels.f90~2.html new file mode 100644 index 000000000..1bf6dc548 --- /dev/null +++ b/reference/rte-kernels/sourcefile/mo_optical_props_kernels.f90~2.html @@ -0,0 +1,584 @@ + + + + + + + + + + + mo_optical_props_kernels.F90 – RTE kernels + + + + + + + + + + + + + + + + + + + + +
    +
    +

    mo_optical_props_kernels.F90 + Source File +

    +
    +
    +
    + +
      +
    1. mo_optical_props_kernels.F90
      2. +
    +
    +
    +
    + + +
    +
    + +
    + +
    + +
    +

    Contents

    + +
    +

    Modules

    + +
    +
    +

    Source Code

    +
    + mo_optical_props_kernels.F90 +
    +
    + +
    +
    + +
    +

    Source Code

    + 
    ! This code is part of Radiative Transfer for Energetics (RTE)
+!
+! Contacts: Robert Pincus and Eli Mlawer
+! email:  rrtmgp@aer.com
+!
+! Copyright 2015-,  Atmospheric and Environmental Research,
+! Regents of the University of Colorado, Trustees of Columbia University.  All right reserved.
+!
+! Use and duplication is permitted under the terms of the
+!    BSD 3-clause license, see http://opensource.org/licenses/BSD-3-Clause
+! -------------------------------------------------------------------------------------------------
+!
+!> ## Kernels for arrays of optical properties:
+!>     - delta-scaling
+!>     - adding two sets of properties
+!>     - extracting subsets along the column dimension
+!
+! -------------------------------------------------------------------------------------------------
+
+module mo_optical_props_kernels
+  use, intrinsic :: iso_c_binding
+  use mo_rte_kind, only: wp, wl
+  implicit none
+
+  public
+
+  ! -------------------------------------------------------------------------------------------------
+  !
+  ! Delta-scaling is provided only for two-stream properties at present
+  !
+  interface delta_scale_2str_kernel
+    ! -------------------------------------------------------------------------------------------------
+    !> Delta-scale two-stream optical properties given user-provided value of \(f\) (forward scattering)
+    !
+    pure subroutine delta_scale_2str_f_k(ncol, nlay, ngpt, tau, ssa, g, f) &
+        bind(C, name="rte_delta_scale_2str_f_k")
+      use mo_rte_kind, only: wp, wl
+      integer,                               intent(in   ) :: ncol, nlay, ngpt
+        !! Array sizes
+      real(wp), dimension(ncol, nlay, ngpt), intent(inout) ::  tau, ssa, g
+        !! Optical depth, single-scattering albedo, asymmetry parameter
+      real(wp), dimension(ncol, nlay, ngpt), intent(in   ) ::  f
+        !! User-provided forward-scattering fraction
+     end subroutine delta_scale_2str_f_k
+    ! ---------------------------------
+    !> Delta-scale assuming forward-scatternig fraction is the square of the asymmetry parameter
+    !>    i.e. \(f = g^2\)
+    !
+    pure subroutine delta_scale_2str_k(ncol, nlay, ngpt, tau, ssa, g) &
+        bind(C, name="rte_delta_scale_2str_k")
+      use mo_rte_kind, only: wp, wl
+      integer,                               intent(in   ) :: ncol, nlay, ngpt
+        !! Array sizes
+      real(wp), dimension(ncol, nlay, ngpt), intent(inout) ::  tau, ssa, g
+        !! Optical depth, single-scattering albedo, asymmetry parameter
+    end subroutine delta_scale_2str_k
+  end interface delta_scale_2str_kernel
+  ! -------------------------------------------------------------------------------------------------
+  !
+  ! Addition of optical properties: the first set are incremented by the second set.
+  !
+  !   There are three possible representations of optical properties (scalar = optical depth only;
+  !   two-stream = tau, single-scattering albedo, and asymmetry factor g, and
+  !   n-stream = tau, ssa, and phase function moments p.) Thus we need nine routines, three for
+  !   each choice of representation on the left hand side times three representations of the
+  !   optical properties to be added.
+  !
+  !   There are two sets of these nine routines. In the first the two sets of optical
+  !   properties are defined at the same spectral resolution. There is also a set of routines
+  !   to add properties defined at lower spectral resolution to a set defined at higher spectral
+  !   resolution (adding properties defined by band to those defined by g-point)
+  !
+  ! -------------------------------------------------------------------------------------------------
+  !> increase one absorption optical depth by a second value
+  interface
+    pure subroutine increment_1scalar_by_1scalar(ncol, nlay, ngpt, &
+                                                 tau1,             &
+                                                 tau2) bind(C, name="rte_increment_1scalar_by_1scalar")
+      use mo_rte_kind, only: wp, wl
+      integer,                             intent(in   ) :: ncol, nlay, ngpt !! array sizes
+      real(wp), dimension(ncol,nlay,ngpt), intent(inout) :: tau1             !! optical properties to be modified
+      real(wp), dimension(ncol,nlay,ngpt), intent(in   ) :: tau2             !! optical properties to be added to original
+    end subroutine increment_1scalar_by_1scalar
+  end interface 
+  ! ---------------------------------
+  !> increase absorption optical depth with extinction optical depth (2-stream form)
+  interface
+    pure subroutine increment_1scalar_by_2stream(ncol, nlay, ngpt, &
+                                                 tau1,             &
+                                                 tau2, ssa2) bind(C, name="rte_increment_1scalar_by_2stream")
+      use mo_rte_kind, only: wp, wl
+      integer,                             intent(in   ) :: ncol, nlay, ngpt !! array sizes
+      real(wp), dimension(ncol,nlay,ngpt), intent(inout) :: tau1             !! optical properties to be modified
+      real(wp), dimension(ncol,nlay,ngpt), intent(in   ) :: tau2, ssa2       !! optical properties to be added to original
+    end subroutine increment_1scalar_by_2stream
+  end interface 
+  ! ---------------------------------
+  !> increase absorption optical depth with extinction optical depth (n-stream form)
+  interface
+    pure subroutine increment_1scalar_by_nstream(ncol, nlay, ngpt, &
+                                                 tau1,             &
+                                                 tau2, ssa2) bind(C, name="rte_increment_1scalar_by_nstream")
+      use mo_rte_kind, only: wp, wl
+      integer,                             intent(in   ) :: ncol, nlay, ngpt !! array sizes
+      real(wp), dimension(ncol,nlay,ngpt), intent(inout) :: tau1             !! optical properties to be modified
+      real(wp), dimension(ncol,nlay,ngpt), intent(in   ) :: tau2, ssa2       !! optical properties to be added to original
+    end subroutine increment_1scalar_by_nstream
+  end interface 
+  ! ---------------------------------
+  ! ---------------------------------
+  !> increment two-stream optical properties \(\tau, \omega_0, g\) with absorption optical depth
+  interface
+    pure subroutine increment_2stream_by_1scalar(ncol, nlay, ngpt, &
+                                                 tau1, ssa1,       &
+                                                 tau2) bind(C, name="rte_increment_2stream_by_1scalar")
+      use mo_rte_kind, only: wp, wl
+      integer,                             intent(in   ) :: ncol, nlay, ngpt !! array sizes
+      real(wp), dimension(ncol,nlay,ngpt), intent(inout) :: tau1, ssa1       !! optical properties to be modified
+      real(wp), dimension(ncol,nlay,ngpt), intent(in   ) :: tau2             !! optical properties to be added to original
+    end subroutine increment_2stream_by_1scalar
+  end interface 
+  ! ---------------------------------
+  !> increment two-stream optical properties \(\tau, \omega_0, g\) with a second set
+  interface
+    pure subroutine increment_2stream_by_2stream(ncol, nlay, ngpt, &
+                                                 tau1, ssa1, g1,   &
+                                                 tau2, ssa2, g2) bind(C, name="rte_increment_2stream_by_2stream")
+      use mo_rte_kind, only: wp, wl
+      integer,                             intent(in   ) :: ncol, nlay, ngpt !! array sizes
+      real(wp), dimension(ncol,nlay,ngpt), intent(inout) :: tau1, ssa1, g1   !! optical properties to be modified
+      real(wp), dimension(ncol,nlay,ngpt), intent(in   ) :: tau2, ssa2, g2   !! optical properties to be added to original
+    end subroutine increment_2stream_by_2stream
+  end interface 
+  ! ---------------------------------
+  !> increment two-stream optical properties \(\tau, \omega_0, g\) with _n_-stream
+  interface
+    pure subroutine increment_2stream_by_nstream(ncol, nlay, ngpt, nmom2, &
+                                                 tau1, ssa1, g1,          &
+                                                 tau2, ssa2, p2) bind(C, name="rte_increment_2stream_by_nstream")
+      use mo_rte_kind, only: wp, wl
+      integer,                             intent(in   ) :: ncol, nlay, ngpt, nmom2  !! array sizes
+      real(wp), dimension(ncol,nlay,ngpt), intent(inout) :: tau1, ssa1, g1           !! optical properties to be modified
+      real(wp), dimension(ncol,nlay,ngpt), intent(in   ) :: tau2, ssa2               !! optical properties to be added to original
+      real(wp), dimension(nmom2, &
+                          ncol,nlay,ngpt), intent(in   ) :: p2                       !! moments of the phase function to be added
+    end subroutine increment_2stream_by_nstream
+  end interface 
+  ! ---------------------------------
+  ! ---------------------------------
+  !> increment _n_-stream optical properties \(\tau, \omega_0, p\) with absorption optical depth
+  interface
+    pure subroutine increment_nstream_by_1scalar(ncol, nlay, ngpt, &
+                                                 tau1, ssa1,       &
+                                                 tau2) bind(C, name="rte_increment_nstream_by_1scalar")
+      use mo_rte_kind, only: wp, wl
+      integer,                             intent(in   ) :: ncol, nlay, ngpt  !! array sizes
+      real(wp), dimension(ncol,nlay,ngpt), intent(inout) :: tau1, ssa1        !! optical properties to be modified
+      real(wp), dimension(ncol,nlay,ngpt), intent(in   ) :: tau2              !! optical properties to be added to original
+    end subroutine increment_nstream_by_1scalar
+  end interface 
+  ! ---------------------------------
+  !> increment _n_-stream optical properties \(\tau, \omega_0, p\) with two-stream values
+  interface
+    pure subroutine increment_nstream_by_2stream(ncol, nlay, ngpt, nmom1, &
+                                                 tau1, ssa1, p1,          &
+                                                 tau2, ssa2, g2) bind(C, name="rte_increment_nstream_by_2stream")
+      use mo_rte_kind, only: wp, wl
+      integer,                              intent(in   ) :: ncol, nlay, ngpt, nmom1  !! array sizes
+      real(wp), dimension(ncol,nlay,ngpt), intent(inout) :: tau1, ssa1                !! optical properties to be modified
+      real(wp), dimension(nmom1, &
+                          ncol,nlay,ngpt), intent(inout) :: p1                        !! moments of the phase function be modified
+      real(wp), dimension(ncol,nlay,ngpt), intent(in   ) :: tau2, ssa2, g2            !! optical properties to be added to original
+    end subroutine increment_nstream_by_2stream
+  end interface 
+  ! ---------------------------------
+  !> increment one set of _n_-stream optical properties with another set
+  interface
+    pure subroutine increment_nstream_by_nstream(ncol, nlay, ngpt, nmom1, nmom2, &
+                                                 tau1, ssa1, p1,                 &
+                                                 tau2, ssa2, p2) bind(C, name="rte_increment_nstream_by_nstream")
+      use mo_rte_kind, only: wp, wl
+      integer,                              intent(in   ) :: ncol, nlay, ngpt, nmom1, nmom2  !! array sizes
+      real(wp), dimension(ncol,nlay,ngpt), intent(inout) :: tau1, ssa1   !! optical properties to be modified
+      real(wp), dimension(nmom1, &
+                          ncol,nlay,ngpt), intent(inout) :: p1           !! moments of the phase function be modified
+      real(wp), dimension(ncol,nlay,ngpt), intent(in   ) :: tau2, ssa2   !! optical properties to be added to original
+      real(wp), dimension(nmom2, &
+                          ncol,nlay,ngpt), intent(in   ) :: p2           !! moments of the phase function to be added
+    end subroutine increment_nstream_by_nstream
+  end interface 
+  ! -------------------------------------------------------------------------------------------------
+  !
+  ! Incrementing when the second set of optical properties is defined at lower spectral resolution
+  !   (e.g. by band instead of by gpoint)
+  !
+  ! -------------------------------------------------------------------------------------------------
+  !> increase one absorption optical depth defined on g-points by a second value defined on bands
+  interface
+    pure subroutine inc_1scalar_by_1scalar_bybnd(ncol, nlay, ngpt, &
+                                                 tau1,             &
+                                                 tau2,             &
+                                                 nbnd, gpt_lims) bind(C, name="rte_inc_1scalar_by_1scalar_bybnd")
+      use mo_rte_kind, only: wp, wl
+      integer,                             intent(in   ) :: ncol, nlay, ngpt, nbnd  !! array sizes
+      real(wp), dimension(ncol,nlay,ngpt), intent(inout) :: tau1     !! optical properties to be modified (defined on g-points)
+      real(wp), dimension(ncol,nlay,nbnd), intent(in   ) :: tau2     !! optical properties to be added to original (defined on bands)
+      integer,  dimension(2,nbnd),         intent(in   ) :: gpt_lims !! Starting and ending gpoint for each band
+     end subroutine inc_1scalar_by_1scalar_bybnd
+  end interface 
+  ! ---------------------------------
+  !> increase absorption optical depth defined on g-points  with extinction optical depth (2-stream form) defined on bands
+  interface
+    pure subroutine inc_1scalar_by_2stream_bybnd(ncol, nlay, ngpt, &
+                                                 tau1,             &
+                                                 tau2, ssa2,       &
+                                                 nbnd, gpt_lims) bind(C, name="rte_inc_1scalar_by_2stream_bybnd")
+      use mo_rte_kind, only: wp, wl
+      integer,                             intent(in   ) :: ncol, nlay, ngpt, nbnd  !! array sizes
+      real(wp), dimension(ncol,nlay,ngpt), intent(inout) :: tau1        !! optical properties to be modified (defined on g-points)
+      real(wp), dimension(ncol,nlay,nbnd), intent(in   ) :: tau2, ssa2  !! optical properties to be added to original (defined on bands)
+      integer,  dimension(2,nbnd),         intent(in   ) :: gpt_lims    !! Starting and ending gpoint for each band
+    end subroutine inc_1scalar_by_2stream_bybnd
+  end interface 
+  ! ---------------------------------
+  !> increase absorption optical depth defined on g-points  with extinction optical depth (n-stream form) defined on bands
+  interface
+    pure subroutine inc_1scalar_by_nstream_bybnd(ncol, nlay, ngpt, &
+                                                 tau1,             &
+                                                 tau2, ssa2,       &
+                                                 nbnd, gpt_lims) bind(C, name="rte_inc_1scalar_by_nstream_bybnd")
+      use mo_rte_kind, only: wp, wl
+      integer,                             intent(in   ) :: ncol, nlay, ngpt, nbnd  !! array sizes
+      real(wp), dimension(ncol,nlay,ngpt), intent(inout) :: tau1       !! optical properties to be modified (defined on g-points)
+      real(wp), dimension(ncol,nlay,nbnd), intent(in   ) :: tau2, ssa2 !! optical properties to be added to original (defined on bands)
+      integer,  dimension(2,nbnd),         intent(in   ) :: gpt_lims   !! Starting and ending gpoint for each band
+    end subroutine inc_1scalar_by_nstream_bybnd
+  end interface 
+  ! ---------------------------------
+  !> increment two-stream optical properties \(\tau, \omega_0, g\) defined on g-points with absorption optical depth defined on bands
+  interface
+    pure subroutine inc_2stream_by_1scalar_bybnd(ncol, nlay, ngpt, &
+                                                 tau1, ssa1,       &
+                                                 tau2,             &
+                                                 nbnd, gpt_lims) bind(C, name="rte_inc_2stream_by_1scalar_bybnd")
+      use mo_rte_kind, only: wp, wl
+      integer,                             intent(in   ) :: ncol, nlay, ngpt, nbnd  !! array sizes
+      real(wp), dimension(ncol,nlay,ngpt), intent(inout) :: tau1, ssa1 !! optical properties to be modified (defined on g-points)
+      real(wp), dimension(ncol,nlay,nbnd), intent(in   ) :: tau2       !! optical properties to be added to original (defined on bands)
+      integer,  dimension(2,nbnd),         intent(in   ) :: gpt_lims   !! Starting and ending gpoint for each band
+    end subroutine inc_2stream_by_1scalar_bybnd
+  end interface 
+  ! ---------------------------------
+  !> increment 2-stream optical properties defined on g-points with another set defined on bands
+  interface
+    pure subroutine inc_2stream_by_2stream_bybnd(ncol, nlay, ngpt, &
+                                                 tau1, ssa1, g1,   &
+                                                 tau2, ssa2, g2,   &
+                                                 nbnd, gpt_lims) bind(C, name="rte_inc_2stream_by_2stream_bybnd")
+      use mo_rte_kind, only: wp, wl
+      integer,                             intent(in   ) :: ncol, nlay, ngpt, nbnd  !! array sizes
+      real(wp), dimension(ncol,nlay,ngpt), intent(inout) :: tau1, ssa1, g1 !! optical properties to be modified (defined on g-points)
+      real(wp), dimension(ncol,nlay,nbnd), intent(in   ) :: tau2, ssa2, g2 !! optical properties to be added to original (defined on bands)
+      integer,  dimension(2,nbnd),         intent(in   ) :: gpt_lims       !! Starting and ending gpoint for each band
+    end subroutine inc_2stream_by_2stream_bybnd
+  end interface 
+  ! ---------------------------------
+  !> increment 2-stream optical properties defined on g-points with _n_-stream properties set defined on bands
+  interface
+    pure subroutine inc_2stream_by_nstream_bybnd(ncol, nlay, ngpt, nmom2, &
+                                                 tau1, ssa1, g1,          &
+                                                 tau2, ssa2, p2,          &
+                                                 nbnd, gpt_lims) bind(C, name="rte_inc_2stream_by_nstream_bybnd")
+      use mo_rte_kind, only: wp, wl
+      integer,                             intent(in   ) :: ncol, nlay, ngpt, nmom2, nbnd  !! array sizes
+      real(wp), dimension(ncol,nlay,ngpt), intent(inout) :: tau1, ssa1, g1 !! optical properties to be modified (defined on g-points)
+      real(wp), dimension(ncol,nlay,nbnd), intent(in   ) :: tau2, ssa2     !! optical properties to be added to original (defined on bands)
+      real(wp), dimension(nmom2, &
+                          ncol,nlay,nbnd), intent(in   ) :: p2             !! moments of the phase function to be added
+      integer,  dimension(2,nbnd),         intent(in   ) :: gpt_lims       !! Starting and ending gpoint for each band
+    end subroutine inc_2stream_by_nstream_bybnd
+  end interface 
+  ! ---------------------------------
+  ! ---------------------------------
+  !> increment _n_-stream optical properties defined on g-points with absorption optical depth defined on bands
+  interface
+    pure subroutine inc_nstream_by_1scalar_bybnd(ncol, nlay, ngpt, &
+                                                 tau1, ssa1,       &
+                                                 tau2,             &
+                                                 nbnd, gpt_lims) bind(C, name="rte_inc_nstream_by_1scalar_bybnd")
+      use mo_rte_kind, only: wp, wl
+      integer,                             intent(in   ) :: ncol, nlay, ngpt, nbnd  !! array sizes
+      real(wp), dimension(ncol,nlay,ngpt), intent(inout) :: tau1, ssa1 !! optical properties to be modified (defined on g-points)
+      real(wp), dimension(ncol,nlay,nbnd), intent(in   ) :: tau2       !! optical properties to be added to original (defined on bands)
+      integer,  dimension(2,nbnd),         intent(in   ) :: gpt_lims   !! Starting and ending gpoint for each band
+    end subroutine inc_nstream_by_1scalar_bybnd
+  end interface 
+  ! ---------------------------------
+  !> increment n-stream optical properties defined on g-points with 2-stream properties set defined on bands
+  interface
+    pure subroutine inc_nstream_by_2stream_bybnd(ncol, nlay, ngpt, nmom1, &
+                                                 tau1, ssa1, p1,          &
+                                                 tau2, ssa2, g2,          &
+                                                 nbnd, gpt_lims) bind(C, name="rte_inc_nstream_by_2stream_bybnd")
+      use mo_rte_kind, only: wp, wl
+      integer,                             intent(in   ) :: ncol, nlay, ngpt, nmom1, nbnd  !! array sizes
+      real(wp), dimension(ncol,nlay,ngpt), intent(inout) :: tau1, ssa1     !! optical properties to be modified (defined on g-points)
+      real(wp), dimension(nmom1, &
+                          ncol,nlay,ngpt), intent(inout) :: p1             !! moments of the phase function be modified
+      real(wp), dimension(ncol,nlay,nbnd), intent(in   ) :: tau2, ssa2, g2 !! optical properties to be added to original (defined on bands)
+      integer,  dimension(2,nbnd),         intent(in   ) :: gpt_lims       !! Starting and ending gpoint for each band
+    end subroutine inc_nstream_by_2stream_bybnd
+  end interface 
+  ! ---------------------------------
+  !> increment _n_-stream optical properties defined on g-points with a second set defined on bands
+  interface
+    pure subroutine inc_nstream_by_nstream_bybnd(ncol, nlay, ngpt, nmom1, nmom2, &
+                                                 tau1, ssa1, p1,                 &
+                                                 tau2, ssa2, p2,                 &
+                                                 nbnd, gpt_lims) bind(C, name="rte_inc_nstream_by_nstream_bybnd")
+      use mo_rte_kind, only: wp, wl
+      integer,                             intent(in   ) :: ncol, nlay, ngpt, nmom1, nmom2, nbnd  !! array sizes
+      real(wp), dimension(ncol,nlay,ngpt), intent(inout) :: tau1, ssa1 !! optical properties to be modified (defined on g-points)
+      real(wp), dimension(nmom1, &
+                          ncol,nlay,ngpt), intent(inout) :: p1         !! moments of the phase function be modified
+      real(wp), dimension(ncol,nlay,nbnd), intent(in   ) :: tau2, ssa2 !! optical properties to be added to original (defined on bands)
+      real(wp), dimension(nmom2, &
+                          ncol,nlay,nbnd), intent(in   ) :: p2         !! moments of the phase function to be added
+      integer,  dimension(2,nbnd),         intent(in   ) :: gpt_lims   !! Starting and ending gpoint for each band
+    end subroutine inc_nstream_by_nstream_bybnd
+  end interface 
+  ! -------------------------------------------------------------------------------------------------
+  !
+  ! Subsetting, meaning extracting some portion of the 3D domain
+  !
+  ! -------------------------------------------------------------------------------------------------
+  !>
+  !> Extract a subset from the first dimension (normally columns) of a 3D field.
+  !>   Applicable to most variables e.g. tau, ssa, g
+  !>
+  interface extract_subset
+    pure subroutine extract_subset_dim1_3d(ncol, nlay, ngpt, array_in, colS, colE, array_out) &
+      bind (C, name="rte_extract_subset_dim1_3d")
+      use mo_rte_kind, only: wp, wl
+      integer,                             intent(in ) :: ncol, nlay, ngpt !! Array sizes
+      real(wp), dimension(ncol,nlay,ngpt), intent(in ) :: array_in         !! Array to subset
+      integer,                             intent(in ) :: colS, colE       !! Starting and ending index
+      real(wp), dimension(colE-colS+1,&
+                               nlay,ngpt), intent(out) :: array_out        !! subset of the input array
+    end subroutine extract_subset_dim1_3d
+    ! ---------------------------------
+    !> Extract a subset from the second dimension (normally columns) of a 4D field.
+    !>   Applicable to phase function moments, where the first dimension is the moment
+    pure subroutine extract_subset_dim2_4d(nmom, ncol, nlay, ngpt, array_in, colS, colE, array_out) &
+      bind (C, name="rte_extract_subset_dim2_4d")
+      use mo_rte_kind, only: wp, wl
+      integer,                                  intent(in ) :: nmom, ncol, nlay, ngpt !! Array sizes
+      real(wp), dimension(nmom,ncol,nlay,ngpt), intent(in ) :: array_in               !! Array to subset
+      integer,                                  intent(in ) :: colS, colE             !! Starting and ending index
+      real(wp), dimension(nmom,colE-colS+1,&
+                                    nlay,ngpt), intent(out) :: array_out              !! subset of the input array
+    end subroutine extract_subset_dim2_4d
+    ! ---------------------------------
+    !
+    !> Extract the absorption optical thickness \(\tau_{abs} = 1 - \omega_0 \tau_{ext}\)
+    !
+    pure subroutine extract_subset_absorption_tau(ncol, nlay, ngpt, tau_in, ssa_in, &
+                                                  colS, colE, tau_out)              &
+      bind (C, name="rte_extract_subset_absorption_tau")
+      use mo_rte_kind, only: wp, wl
+      integer,                             intent(in ) :: ncol, nlay, ngpt !! Array sizes
+      real(wp), dimension(ncol,nlay,ngpt), intent(in ) :: tau_in, ssa_in   !! Optical thickness, single scattering albedo
+      integer,                             intent(in ) :: colS, colE       !! Starting and ending index
+      real(wp), dimension(colE-colS+1,&
+                               nlay,ngpt), intent(out) :: tau_out          !! absorption optical thickness subset
+    end subroutine extract_subset_absorption_tau
+  end interface extract_subset
+end module mo_optical_props_kernels
+
    + +
    +
    +
    + +
    +
    +
    +
    +
    +

    RTE kernels was developed by The RTE+RRTTMGP consortium
    © 2024 Creative Commons License +

    +
    +
    +

    + Documentation generated by + FORD +

    +
    +
    +
    +
    +
    + + + + + + + + + + + + + + + + + + + \ No newline at end of file diff --git a/reference/rte-kernels/sourcefile/mo_rte_solver_kernels.f90.html b/reference/rte-kernels/sourcefile/mo_rte_solver_kernels.f90.html index 9928e2a31..c74a1cf91 100644 --- a/reference/rte-kernels/sourcefile/mo_rte_solver_kernels.f90.html +++ b/reference/rte-kernels/sourcefile/mo_rte_solver_kernels.f90.html @@ -85,7 +85,7 @@

    mo_rte_solver_kernels.F90
  • 568 statements + title="39.1% of total for source files.">552 statements
  • Source File
    • @@ -277,12 +277,12 @@

    Source Code

    !> using user-supplied weights ! ! --------------------------------------------------------------- - subroutine lw_solver_noscat_oneangle(ncol, nlay, ngpt, top_at_1, D, weight, & - tau, lay_source, lev_source_inc, lev_source_dec, sfc_emis, sfc_src, & + subroutine lw_solver_noscat_oneangle(ncol, nlay, ngpt, top_at_1, D, weight, & + tau, lay_source, lev_source, sfc_emis, sfc_src, & incident_flux, & flux_up, flux_dn, & do_broadband, broadband_up, broadband_dn, & - do_Jacobians, sfc_srcJac, flux_upJac, & + do_Jacobians, sfc_srcJac, flux_upJac, & do_rescaling, ssa, g) integer, intent(in ) :: ncol, nlay, ngpt ! Number of columns, layers, g-points logical(wl), intent(in ) :: top_at_1 @@ -290,1223 +290,1189 @@

    Source Code

    real(wp), intent(in ) :: weight ! quadrature weight real(wp), dimension(ncol,nlay, ngpt), intent(in ) :: tau ! Absorption optical thickness [] real(wp), dimension(ncol,nlay, ngpt), intent(in ) :: lay_source ! Planck source at layer average temperature [W/m2] - ! Planck source at layer edge for radiation in increasing/decreasing ilay direction - ! lev_source_dec applies the mapping in layer i to the Planck function at layer i - ! lev_source_inc applies the mapping in layer i to the Planck function at layer i+1 - real(wp), dimension(ncol,nlay, ngpt), target, & - intent(in ) :: lev_source_inc, lev_source_dec - real(wp), dimension(ncol, ngpt), intent(in ) :: sfc_emis ! Surface emissivity [] - real(wp), dimension(ncol, ngpt), intent(in ) :: sfc_src ! Surface source function [W/m2] - real(wp), dimension(ncol, ngpt), intent(in ) :: incident_flux! Boundary condition for flux [W/m2] - real(wp), dimension(ncol,nlay+1,ngpt), target, & ! Fluxes [W/m2] - intent( out) :: flux_up, flux_dn - ! - ! Optional variables - arrays aren't referenced if corresponding logical == False - ! - logical(wl), intent(in ) :: do_broadband - real(wp), dimension(ncol,nlay+1 ), intent( out) :: broadband_up, broadband_dn ! Spectrally-integrated fluxes [W/m2] - logical(wl), intent(in ) :: do_Jacobians - real(wp), dimension(ncol ,ngpt), intent(in ) :: sfc_srcJac ! surface temperature Jacobian of surface source function [W/m2/K] - real(wp), dimension(ncol,nlay+1 ), intent( out) :: flux_upJac ! surface temperature Jacobian of Radiances [W/m2-str / K] - logical(wl), intent(in ) :: do_rescaling - real(wp), dimension(ncol,nlay ,ngpt), intent(in ) :: ssa, g ! single-scattering albedo, asymmetry parameter - ! ------------------------------------ - ! Local variables, no g-point dependency - ! - integer :: icol, ilay, igpt - integer :: top_level, sfc_level - real(wp), dimension(ncol,nlay) :: tau_loc, & ! path length (tau/mu) - trans ! transmissivity = exp(-tau) - real(wp), dimension(ncol,nlay) :: source_dn, source_up - real(wp), dimension(ncol ) :: sfc_albedo - - real(wp), dimension(:,:,:), pointer :: lev_source_up, lev_source_dn ! Mapping increasing/decreasing indicies to up/down - - real(wp), parameter :: pi = acos(-1._wp) - ! loc_fluxes hold a single g-point flux if fluxes are being integrated instead of returned - ! with spectral detail - real(wp), dimension(ncol,nlay+1), & - target :: loc_flux_up, loc_flux_dn - ! gpt_fluxes point to calculations for the current g-point - real(wp), dimension(:,:), pointer :: gpt_flux_up, gpt_flux_dn - ! ------------------------------------------------------------------------------------------------- - ! Optionally, use an approximate treatment of scattering using rescaling - ! Implemented based on the paper - ! Tang G, et al, 2018: https://doi.org/10.1175/JAS-D-18-0014.1 - ! a) relies on rescaling of the optical parameters based on asymetry factor and single scattering albedo - ! scaling can be computed by scaling_1rescl - ! b) adds adustment term based on cloud properties (lw_transport_1rescl) - ! adustment terms is computed based on solution of the Tang equations - ! for "linear-in-tau" internal source (not in the paper) - ! - ! Used when approximating scattering - ! - real(wp) :: ssal, wb, scaleTau - real(wp), dimension(ncol,nlay ) :: An, Cn - real(wp), dimension(ncol,nlay+1) :: gpt_flux_Jac - ! ------------------------------------ - ! Which way is up? - ! Level Planck sources for upward and downward radiation - ! When top_at_1, lev_source_up => lev_source_dec - ! lev_source_dn => lev_source_inc, and vice-versa - if(top_at_1) then - top_level = 1 - sfc_level = nlay+1 - lev_source_up => lev_source_dec - lev_source_dn => lev_source_inc - else - top_level = nlay+1 - sfc_level = 1 - lev_source_up => lev_source_inc - lev_source_dn => lev_source_dec - end if - - ! - ! Integrated fluxes need zeroing - ! - if(do_broadband) then - call zero_array(ncol, nlay+1, broadband_up ) - call zero_array(ncol, nlay+1, broadband_dn ) - end if - if(do_Jacobians) & - call zero_array(ncol, nlay+1, flux_upJac ) - - do igpt = 1, ngpt - if(do_broadband) then - gpt_flux_up => loc_flux_up - gpt_flux_dn => loc_flux_dn - else - gpt_flux_up => flux_up (:,:,igpt) - gpt_flux_dn => flux_dn (:,:,igpt) - end if - ! - ! Transport is for intensity - ! convert flux at top of domain to intensity assuming azimuthal isotropy - ! - gpt_flux_dn(:,top_level) = incident_flux(:,igpt)/(2._wp * pi * weight) - ! - ! Optical path and transmission, used in source function and transport calculations - ! - if (do_rescaling) then - ! - ! The scaling and scaleTau terms are independent of propagation - ! angle D and could be pre-computed if several values of D are used - ! We re-compute them here to keep not have to localize memory use - ! - do ilay = 1, nlay - do icol = 1, ncol - ssal = ssa(icol, ilay, igpt) - - ! w is the layer single scattering albedo - ! b is phase function parameter (Eq.13 of the paper) - ! for the similarity principle scaling scheme - ! b = (1-g)/2 (where g is phase function avergae cosine) - wb = ssal*(1._wp - g(icol, ilay, igpt)) * 0.5_wp - - ! scaleTau=1-w(1-b) is a scaling factor of the optical thickness representing - ! the radiative transfer equation in a nonscattering form Eq(14) of the paper - scaleTau = (1._wp - ssal + wb) - - ! Cn = 0.5*wb/(1-w(1-b)) is parameter of Eq.21-22 of the Tang paper - ! Tang paper, p.2222 advises to replace 0.5 with 0.4 based on simulations - Cn(icol,ilay) = 0.4_wp*wb/scaleTau - - ! Eqs.15, 18ab and 19 of the paper, - ! rescaling of the optical depth multiplied by path length - tau_loc(icol,ilay) = tau(icol,ilay,igpt)*D(icol,igpt)*scaleTau - end do - trans (:,ilay) = exp(-tau_loc(:,ilay)) - An(:,ilay) = (1._wp-trans(:,ilay)**2) - end do - else - do ilay = 1, nlay - tau_loc(:,ilay) = tau(:,ilay,igpt)*D(:,igpt) - trans (:,ilay) = exp(-tau_loc(:,ilay)) - end do - end if - ! - ! Source function for diffuse radiation - ! - call lw_source_noscat(ncol, nlay, & - lay_source(:,:,igpt), lev_source_up(:,:,igpt), lev_source_dn(:,:,igpt), & - tau_loc, trans, source_dn, source_up) - ! - ! Transport down - ! - call lw_transport_noscat_dn(ncol, nlay, top_at_1, trans, source_dn, gpt_flux_dn) - ! - ! Surface albedo, surface source function, reflection and emission - ! - sfc_albedo(:) = 1._wp - sfc_emis(:,igpt) - gpt_flux_up (:,sfc_level) = gpt_flux_dn(:,sfc_level)*sfc_albedo(:) + & - sfc_emis(:,igpt) * sfc_src (:,igpt) - if(do_Jacobians) & - gpt_flux_Jac(:,sfc_level) = sfc_emis(:,igpt) * sfc_srcJac(:,igpt) - ! - ! Transport up, or up and down again if using rescaling - ! - if(do_rescaling) then - call lw_transport_1rescl(ncol, nlay, top_at_1, trans, & - source_dn, source_up, & - gpt_flux_up, gpt_flux_dn, An, Cn, & - do_Jacobians, gpt_flux_Jac) ! Standing in for Jacobian, i.e. rad_up_Jac(:,:,igpt), rad_dn_Jac(:,:,igpt)) - else - call lw_transport_noscat_up(ncol, nlay, top_at_1, trans, source_up, gpt_flux_up, & - do_Jacobians, gpt_flux_Jac) - end if - - if(do_broadband) then - broadband_up(:,:) = broadband_up(:,:) + gpt_flux_up(:,:) - broadband_dn(:,:) = broadband_dn(:,:) + gpt_flux_dn(:,:) - else - ! - ! Convert intensity to flux assuming azimuthal isotropy and quadrature weight - ! - gpt_flux_dn(:,:) = 2._wp * pi * weight * gpt_flux_dn(:,:) - gpt_flux_up(:,:) = 2._wp * pi * weight * gpt_flux_up(:,:) - end if - ! - ! Only broadband-integrated Jacobians are provided - ! - if(do_Jacobians) & - flux_upJac(:,:) = flux_upJac(:,:) + gpt_flux_Jac(:,:) - end do ! g point loop - - if(do_broadband) then - broadband_up(:,:) = 2._wp * pi * weight* broadband_up(:,:) - broadband_dn(:,:) = 2._wp * pi * weight* broadband_dn(:,:) - end if - if(do_Jacobians) & - flux_upJac(:,:) = 2._wp * pi * weight * flux_upJac(:,:) - - end subroutine lw_solver_noscat_oneangle - ! ------------------------------------------------------------------------------------------------- - ! - !> LW transport, no scattering, multi-angle quadrature - !> Users provide a set of weights and quadrature angles - !> Routine sums over single-angle solutions for each sets of angles/weights - ! - ! --------------------------------------------------------------- - subroutine lw_solver_noscat(ncol, nlay, ngpt, top_at_1, & - nmus, Ds, weights, & - tau, & - lay_source, lev_source_inc, lev_source_dec, & - sfc_emis, sfc_src, & - inc_flux, & - flux_up, flux_dn, & - do_broadband, broadband_up, broadband_dn, & - do_Jacobians, sfc_srcJac, flux_upJac, & - do_rescaling, ssa, g) bind(C, name="rte_lw_solver_noscat") - integer, intent(in ) :: ncol, nlay, ngpt - !! Number of columns, layers, g-points - logical(wl), intent(in ) :: top_at_1 - !! ilay = 1 is the top of the atmosphere? - integer, intent(in ) :: nmus - !! number of quadrature angles - real(wp), dimension (ncol, ngpt, & - nmus), intent(in ) :: Ds - !! quadrature secants - real(wp), dimension(nmus), intent(in ) :: weights - !! quadrature weights - real(wp), dimension(ncol,nlay, ngpt), intent(in ) :: tau - !! Absorption optical thickness [] - real(wp), dimension(ncol,nlay, ngpt), intent(in ) :: lay_source - !! Planck source at layer average temperature [W/m2] - real(wp), dimension(ncol,nlay, ngpt), intent(in ) :: lev_source_inc - !! Planck source at layer edge for radiation in increasing ilay direction [W/m2] - real(wp), dimension(ncol,nlay, ngpt), intent(in ) :: lev_source_dec - !! Planck source at layer edge for radiation in decreasing ilay direction [W/m2] - real(wp), dimension(ncol, ngpt), intent(in ) :: sfc_emis - !! Surface emissivity [] - real(wp), dimension(ncol, ngpt), intent(in ) :: sfc_src - !! Surface source function [W/m2] - real(wp), dimension(ncol, ngpt), intent(in ) :: inc_flux - !! Incident diffuse flux, probably 0 [W/m2] - real(wp), dimension(ncol,nlay+1,ngpt), target, & - intent( out) :: flux_up, flux_dn - !! Fluxes [W/m2] - ! - ! Optional variables - arrays aren't referenced if corresponding logical == False - ! - logical(wl), intent(in ) :: do_broadband - real(wp), dimension(ncol,nlay+1 ), target, & - intent( out) :: broadband_up, broadband_dn - !! Spectrally-integrated fluxes [W/m2] - logical(wl), intent(in ) :: do_Jacobians - !! compute Jacobian with respect to surface temeprature? - real(wp), dimension(ncol ,ngpt), intent(in ) :: sfc_srcJac - !! surface temperature Jacobian of surface source function [W/m2/K] - real(wp), dimension(ncol,nlay+1 ), target, & - intent( out) :: flux_upJac - !! surface temperature Jacobian of Radiances [W/m2-str / K] - logical(wl), intent(in ) :: do_rescaling - !! Approximate treatment of scattering (10.1175/JAS-D-18-0014.1) - real(wp), dimension(ncol,nlay ,ngpt), intent(in ) :: ssa, g - !! single-scattering albedo, asymmetry parameter - ! ------------------------------------ - ! - ! Local variables - used for a single quadrature angle - ! - real(wp), dimension(:,:,:), pointer :: this_flux_up, this_flux_dn - real(wp), dimension(:,:), pointer :: this_broadband_up, this_broadband_dn, this_flux_upJac - - integer :: imu - ! ------------------------------------ - ! - ! For the first angle output arrays store total flux - ! - call lw_solver_noscat_oneangle(ncol, nlay, ngpt, & - top_at_1, Ds(:,:,1), weights(1), tau, & - lay_source, lev_source_inc, lev_source_dec, sfc_emis, sfc_src, & - inc_flux, & - flux_up, flux_dn, & - do_broadband, broadband_up, broadband_dn, & - do_Jacobians, sfc_srcJac, flux_upJac, & - do_rescaling, ssa, g) - ! - ! For more than one angle use local arrays - ! - if(nmus > 1) then - if(do_broadband) then - allocate(this_broadband_up(ncol,nlay+1), this_broadband_dn(ncol,nlay+1)) - ! Spectrally-resolved fluxes won't be filled in so can point to caller-supplied memory - this_flux_up => flux_up - this_flux_dn => flux_dn - else - allocate(this_flux_up(ncol,nlay+1,ngpt), this_flux_dn(ncol,nlay+1,ngpt)) - ! Spectrally-integrated fluxes won't be filled in so can point to caller-supplied memory - this_broadband_up => broadband_up - this_broadband_dn => broadband_dn - end if - if(do_Jacobians) then - allocate(this_flux_upJac(ncol,nlay+1)) - else - this_flux_upJac => flux_upJac - end if - end if - do imu = 2, nmus - call lw_solver_noscat_oneangle(ncol, nlay, ngpt, & - top_at_1, Ds(:,:,imu), weights(imu), tau, & - lay_source, lev_source_inc, lev_source_dec, sfc_emis, sfc_src, & - inc_flux, & - this_flux_up, this_flux_dn, & - do_broadband, this_broadband_up, this_broadband_dn, & - do_Jacobians, sfc_srcJac, this_flux_upJac, & - do_rescaling, ssa, g) - if(do_broadband) then - broadband_up(:,:) = broadband_up(:,:) + this_broadband_up(:,:) - broadband_dn(:,:) = broadband_dn(:,:) + this_broadband_dn(:,:) - else - flux_up (:,:,:) = flux_up (:,:,:) + this_flux_up (:,:,:) - flux_dn (:,:,:) = flux_dn (:,:,:) + this_flux_dn (:,:,:) - end if - if (do_Jacobians) & - flux_upJac(:,:) = flux_upJac(:,: ) + this_flux_upJac(:,: ) - end do - if(nmus > 1) then - if( do_broadband) deallocate(this_broadband_up, this_broadband_dn) - if(.not. do_broadband) deallocate(this_flux_up, this_flux_dn) - if( do_Jacobians) deallocate(this_flux_upJac) - end if - end subroutine lw_solver_noscat - ! ------------------------------------------------------------------------------------------------- - ! - !> Longwave two-stream calculation: - !> - combine RRTMGP-specific sources at levels - !> - compute layer reflectance, transmittance - !> - compute total source function at levels using linear-in-tau - !> - transport - ! - ! ------------------------------------------------------------------------------------------------- - subroutine lw_solver_2stream (ncol, nlay, ngpt, top_at_1, & - tau, ssa, g, & - lay_source, lev_source_inc, lev_source_dec, sfc_emis, sfc_src, & - inc_flux, & - flux_up, flux_dn) bind(C, name="rte_lw_solver_2stream") - integer, intent(in ) :: ncol, nlay, ngpt - !! Number of columns, layers, g-points - logical(wl), intent(in ) :: top_at_1 - !! ilay = 1 is the top of the atmosphere? - real(wp), dimension(ncol,nlay, ngpt), intent(in ) :: tau, ssa, g - !! Optical thickness, single-scattering albedo, asymmetry parameter [] - real(wp), dimension(ncol,nlay, ngpt), intent(in ) :: lay_source - !! Planck source at layer average temperature [W/m2] - real(wp), dimension(ncol,nlay, ngpt), intent(in ) :: lev_source_inc - !! Planck source at layer edge for radiation in increasing ilay direction [W/m2] - real(wp), dimension(ncol,nlay, ngpt), intent(in ) :: lev_source_dec - !! Planck source at layer edge for radiation in decreasing ilay direction [W/m2] - real(wp), dimension(ncol, ngpt), intent(in ) :: sfc_emis - !! Surface emissivity [] - real(wp), dimension(ncol, ngpt), intent(in ) :: sfc_src - !! Surface source function [W/m2] - real(wp), dimension(ncol, ngpt), intent(in ) :: inc_flux - !! Incident diffuse flux, probably 0 [W/m2] - real(wp), dimension(ncol,nlay+1,ngpt), intent( out) :: flux_up, flux_dn - !! Fluxes [W/m2] - ! ---------------------------------------------------------------------- - integer :: igpt, top_level - real(wp), dimension(ncol,nlay ) :: Rdif, Tdif, gamma1, gamma2 - real(wp), dimension(ncol ) :: sfc_albedo - real(wp), dimension(ncol,nlay+1) :: lev_source - real(wp), dimension(ncol,nlay ) :: source_dn, source_up - real(wp), dimension(ncol ) :: source_sfc - ! ------------------------------------ - top_level = nlay+1 - if(top_at_1) top_level = 1 - do igpt = 1, ngpt - ! - ! RRTMGP provides source functions at each level using the spectral mapping - ! of each adjacent layer. Combine these for two-stream calculations + real(wp), dimension(ncol,nlay+1,ngpt), intent(in ) :: lev_source ! Planck source at layer edge [W/m2] + real(wp), dimension(ncol, ngpt), intent(in ) :: sfc_emis ! Surface emissivity [] + real(wp), dimension(ncol, ngpt), intent(in ) :: sfc_src ! Surface source function [W/m2] + real(wp), dimension(ncol, ngpt), intent(in ) :: incident_flux! Boundary condition for flux [W/m2] + real(wp), dimension(ncol,nlay+1,ngpt), target, & ! Fluxes [W/m2] + intent( out) :: flux_up, flux_dn + ! + ! Optional variables - arrays aren't referenced if corresponding logical == False + ! + logical(wl), intent(in ) :: do_broadband + real(wp), dimension(ncol,nlay+1 ), intent( out) :: broadband_up, broadband_dn ! Spectrally-integrated fluxes [W/m2] + logical(wl), intent(in ) :: do_Jacobians + real(wp), dimension(ncol ,ngpt), intent(in ) :: sfc_srcJac ! surface temperature Jacobian of surface source function [W/m2/K] + real(wp), dimension(ncol,nlay+1 ), intent( out) :: flux_upJac ! surface temperature Jacobian of Radiances [W/m2-str / K] + logical(wl), intent(in ) :: do_rescaling + real(wp), dimension(ncol,nlay ,ngpt), intent(in ) :: ssa, g ! single-scattering albedo, asymmetry parameter + ! ------------------------------------ + ! Local variables, no g-point dependency + ! + integer :: icol, ilay, igpt + integer :: top_level, sfc_level + real(wp), dimension(ncol,nlay) :: tau_loc, & ! path length (tau/mu) + trans ! transmissivity = exp(-tau) + real(wp), dimension(ncol,nlay) :: source_dn, source_up + real(wp), dimension(ncol ) :: sfc_albedo + + real(wp), parameter :: pi = acos(-1._wp) + ! loc_fluxes hold a single g-point flux if fluxes are being integrated instead of returned + ! with spectral detail + real(wp), dimension(ncol,nlay+1), & + target :: loc_flux_up, loc_flux_dn + ! gpt_fluxes point to calculations for the current g-point + real(wp), dimension(:,:), pointer :: gpt_flux_up, gpt_flux_dn + ! ------------------------------------------------------------------------------------------------- + ! Optionally, use an approximate treatment of scattering using rescaling + ! Implemented based on the paper + ! Tang G, et al, 2018: https://doi.org/10.1175/JAS-D-18-0014.1 + ! a) relies on rescaling of the optical parameters based on asymetry factor and single scattering albedo + ! scaling can be computed by scaling_1rescl + ! b) adds adustment term based on cloud properties (lw_transport_1rescl) + ! adustment terms is computed based on solution of the Tang equations + ! for "linear-in-tau" internal source (not in the paper) + ! + ! Used when approximating scattering + ! + real(wp) :: ssal, wb, scaleTau + real(wp), dimension(ncol,nlay ) :: An, Cn + real(wp), dimension(ncol,nlay+1) :: gpt_flux_Jac + ! ------------------------------------ + ! Which way is up? + if(top_at_1) then + top_level = 1 + sfc_level = nlay+1 + else + top_level = nlay+1 + sfc_level = 1 + end if + + ! + ! Integrated fluxes need zeroing + ! + if(do_broadband) then + call zero_array(ncol, nlay+1, broadband_up ) + call zero_array(ncol, nlay+1, broadband_dn ) + end if + if(do_Jacobians) & + call zero_array(ncol, nlay+1, flux_upJac ) + + do igpt = 1, ngpt + if(do_broadband) then + gpt_flux_up => loc_flux_up + gpt_flux_dn => loc_flux_dn + else + gpt_flux_up => flux_up (:,:,igpt) + gpt_flux_dn => flux_dn (:,:,igpt) + end if + ! + ! Transport is for intensity + ! convert flux at top of domain to intensity assuming azimuthal isotropy + ! + gpt_flux_dn(:,top_level) = incident_flux(:,igpt)/(pi * weight) + ! + ! Optical path and transmission, used in source function and transport calculations + ! + if (do_rescaling) then + ! + ! The scaling and scaleTau terms are independent of propagation + ! angle D and could be pre-computed if several values of D are used + ! We re-compute them here to keep not have to localize memory use + ! + do ilay = 1, nlay + do icol = 1, ncol + ssal = ssa(icol, ilay, igpt) + + ! w is the layer single scattering albedo + ! b is phase function parameter (Eq.13 of the paper) + ! for the similarity principle scaling scheme + ! b = (1-g)/2 (where g is phase function avergae cosine) + wb = ssal*(1._wp - g(icol, ilay, igpt)) * 0.5_wp + + ! scaleTau=1-w(1-b) is a scaling factor of the optical thickness representing + ! the radiative transfer equation in a nonscattering form Eq(14) of the paper + scaleTau = (1._wp - ssal + wb) + + ! Cn = 0.5*wb/(1-w(1-b)) is parameter of Eq.21-22 of the Tang paper + ! Tang paper, p.2222 advises to replace 0.5 with 0.4 based on simulations + Cn(icol,ilay) = 0.4_wp*wb/scaleTau + + ! Eqs.15, 18ab and 19 of the paper, + ! rescaling of the optical depth multiplied by path length + tau_loc(icol,ilay) = tau(icol,ilay,igpt)*D(icol,igpt)*scaleTau + end do + trans (:,ilay) = exp(-tau_loc(:,ilay)) + An(:,ilay) = (1._wp-trans(:,ilay)**2) + end do + else + do ilay = 1, nlay + tau_loc(:,ilay) = tau(:,ilay,igpt)*D(:,igpt) + trans (:,ilay) = exp(-tau_loc(:,ilay)) + end do + end if + ! + ! Source function for diffuse radiation + ! + call lw_source_noscat(ncol, nlay, top_at_1, & + lay_source(:,:,igpt), lev_source(:,:,igpt), & + tau_loc, trans, source_dn, source_up) + ! + ! Transport down + ! + call lw_transport_noscat_dn(ncol, nlay, top_at_1, trans, source_dn, gpt_flux_dn) + ! + ! Surface albedo, surface source function, reflection and emission + ! + sfc_albedo(:) = 1._wp - sfc_emis(:,igpt) + gpt_flux_up (:,sfc_level) = gpt_flux_dn(:,sfc_level)*sfc_albedo(:) + & + sfc_emis(:,igpt) * sfc_src (:,igpt) + if(do_Jacobians) & + gpt_flux_Jac(:,sfc_level) = sfc_emis(:,igpt) * sfc_srcJac(:,igpt) + ! + ! Transport up, or up and down again if using rescaling + ! + if(do_rescaling) then + call lw_transport_1rescl(ncol, nlay, top_at_1, trans, & + source_dn, source_up, & + gpt_flux_up, gpt_flux_dn, An, Cn, & + do_Jacobians, gpt_flux_Jac) ! Standing in for Jacobian, i.e. rad_up_Jac(:,:,igpt), rad_dn_Jac(:,:,igpt)) + else + call lw_transport_noscat_up(ncol, nlay, top_at_1, trans, source_up, gpt_flux_up, & + do_Jacobians, gpt_flux_Jac) + end if + + if(do_broadband) then + broadband_up(:,:) = broadband_up(:,:) + gpt_flux_up(:,:) + broadband_dn(:,:) = broadband_dn(:,:) + gpt_flux_dn(:,:) + else + ! + ! Convert intensity to flux assuming azimuthal isotropy and quadrature weight + ! + gpt_flux_dn(:,:) = pi * weight * gpt_flux_dn(:,:) + gpt_flux_up(:,:) = pi * weight * gpt_flux_up(:,:) + end if + ! + ! Only broadband-integrated Jacobians are provided + ! + if(do_Jacobians) & + flux_upJac(:,:) = flux_upJac(:,:) + gpt_flux_Jac(:,:) + end do ! g point loop + + if(do_broadband) then + broadband_up(:,:) = pi * weight* broadband_up(:,:) + broadband_dn(:,:) = pi * weight* broadband_dn(:,:) + end if + if(do_Jacobians) & + flux_upJac(:,:) = pi * weight * flux_upJac(:,:) + + end subroutine lw_solver_noscat_oneangle + ! ------------------------------------------------------------------------------------------------- + ! + !> LW transport, no scattering, multi-angle quadrature + !> Users provide a set of weights and quadrature angles + !> Routine sums over single-angle solutions for each sets of angles/weights + ! + ! --------------------------------------------------------------- + subroutine lw_solver_noscat(ncol, nlay, ngpt, top_at_1, & + nmus, Ds, weights, & + tau, & + lay_source, lev_source, & + sfc_emis, sfc_src, & + inc_flux, & + flux_up, flux_dn, & + do_broadband, broadband_up, broadband_dn, & + do_Jacobians, sfc_srcJac, flux_upJac, & + do_rescaling, ssa, g) bind(C, name="rte_lw_solver_noscat") + integer, intent(in ) :: ncol, nlay, ngpt + !! Number of columns, layers, g-points + logical(wl), intent(in ) :: top_at_1 + !! ilay = 1 is the top of the atmosphere? + integer, intent(in ) :: nmus + !! number of quadrature angles + real(wp), dimension (ncol, ngpt, & + nmus), intent(in ) :: Ds + !! quadrature secants + real(wp), dimension(nmus), intent(in ) :: weights + !! quadrature weights + real(wp), dimension(ncol,nlay, ngpt), intent(in ) :: tau + !! Absorption optical thickness [] + real(wp), dimension(ncol,nlay, ngpt), intent(in ) :: lay_source + !! Planck source at layer average temperature [W/m2] + real(wp), dimension(ncol,nlay+1,ngpt), intent(in ) :: lev_source + !! Planck source at layer edge for radiation[W/m2] + real(wp), dimension(ncol, ngpt), intent(in ) :: sfc_emis + !! Surface emissivity [] + real(wp), dimension(ncol, ngpt), intent(in ) :: sfc_src + !! Surface source function [W/m2] + real(wp), dimension(ncol, ngpt), intent(in ) :: inc_flux + !! Incident diffuse flux, probably 0 [W/m2] + real(wp), dimension(ncol,nlay+1,ngpt), target, & + intent( out) :: flux_up, flux_dn + !! Fluxes [W/m2] + ! + ! Optional variables - arrays aren't referenced if corresponding logical == False + ! + logical(wl), intent(in ) :: do_broadband + real(wp), dimension(ncol,nlay+1 ), target, & + intent( out) :: broadband_up, broadband_dn + !! Spectrally-integrated fluxes [W/m2] + logical(wl), intent(in ) :: do_Jacobians + !! compute Jacobian with respect to surface temeprature? + real(wp), dimension(ncol ,ngpt), intent(in ) :: sfc_srcJac + !! surface temperature Jacobian of surface source function [W/m2/K] + real(wp), dimension(ncol,nlay+1 ), target, & + intent( out) :: flux_upJac + !! surface temperature Jacobian of Radiances [W/m2-str / K] + logical(wl), intent(in ) :: do_rescaling + !! Approximate treatment of scattering (10.1175/JAS-D-18-0014.1) + real(wp), dimension(ncol,nlay ,ngpt), intent(in ) :: ssa, g + !! single-scattering albedo, asymmetry parameter + ! ------------------------------------ + ! + ! Local variables - used for a single quadrature angle + ! + real(wp), dimension(:,:,:), pointer :: this_flux_up, this_flux_dn + real(wp), dimension(:,:), pointer :: this_broadband_up, this_broadband_dn, this_flux_upJac + + integer :: imu + ! ------------------------------------ + ! + ! For the first angle output arrays store total flux + ! + call lw_solver_noscat_oneangle(ncol, nlay, ngpt, & + top_at_1, Ds(:,:,1), weights(1), tau, & + lay_source, lev_source, sfc_emis, sfc_src, & + inc_flux, & + flux_up, flux_dn, & + do_broadband, broadband_up, broadband_dn, & + do_Jacobians, sfc_srcJac, flux_upJac, & + do_rescaling, ssa, g) + ! + ! For more than one angle use local arrays + ! + if(nmus > 1) then + if(do_broadband) then + allocate(this_broadband_up(ncol,nlay+1), this_broadband_dn(ncol,nlay+1)) + ! Spectrally-resolved fluxes won't be filled in so can point to caller-supplied memory + this_flux_up => flux_up + this_flux_dn => flux_dn + else + allocate(this_flux_up(ncol,nlay+1,ngpt), this_flux_dn(ncol,nlay+1,ngpt)) + ! Spectrally-integrated fluxes won't be filled in so can point to caller-supplied memory + this_broadband_up => broadband_up + this_broadband_dn => broadband_dn + end if + if(do_Jacobians) then + allocate(this_flux_upJac(ncol,nlay+1)) + else + this_flux_upJac => flux_upJac + end if + end if + do imu = 2, nmus + call lw_solver_noscat_oneangle(ncol, nlay, ngpt, & + top_at_1, Ds(:,:,imu), weights(imu), tau, & + lay_source, lev_source, sfc_emis, sfc_src, & + inc_flux, & + this_flux_up, this_flux_dn, & + do_broadband, this_broadband_up, this_broadband_dn, & + do_Jacobians, sfc_srcJac, this_flux_upJac, & + do_rescaling, ssa, g) + if(do_broadband) then + broadband_up(:,:) = broadband_up(:,:) + this_broadband_up(:,:) + broadband_dn(:,:) = broadband_dn(:,:) + this_broadband_dn(:,:) + else + flux_up (:,:,:) = flux_up (:,:,:) + this_flux_up (:,:,:) + flux_dn (:,:,:) = flux_dn (:,:,:) + this_flux_dn (:,:,:) + end if + if (do_Jacobians) & + flux_upJac(:,:) = flux_upJac(:,: ) + this_flux_upJac(:,: ) + end do + if(nmus > 1) then + if( do_broadband) deallocate(this_broadband_up, this_broadband_dn) + if(.not. do_broadband) deallocate(this_flux_up, this_flux_dn) + if( do_Jacobians) deallocate(this_flux_upJac) + end if + end subroutine lw_solver_noscat + ! ------------------------------------------------------------------------------------------------- + ! + !> Longwave two-stream calculation: + !> - combine RRTMGP-specific sources at levels + !> - compute layer reflectance, transmittance + !> - compute total source function at levels using linear-in-tau + !> - transport + ! + ! ------------------------------------------------------------------------------------------------- + subroutine lw_solver_2stream (ncol, nlay, ngpt, top_at_1, & + tau, ssa, g, & + lay_source, lev_source, sfc_emis, sfc_src, & + inc_flux, & + flux_up, flux_dn) bind(C, name="rte_lw_solver_2stream") + integer, intent(in ) :: ncol, nlay, ngpt + !! Number of columns, layers, g-points + logical(wl), intent(in ) :: top_at_1 + !! ilay = 1 is the top of the atmosphere? + real(wp), dimension(ncol,nlay, ngpt), intent(in ) :: tau, ssa, g + !! Optical thickness, single-scattering albedo, asymmetry parameter [] + real(wp), dimension(ncol,nlay, ngpt), intent(in ) :: lay_source + !! Planck source at layer average temperature [W/m2] + real(wp), dimension(ncol,nlay+1,ngpt), intent(in ) :: lev_source + !! Planck source at layer edge temperature [W/m2] + real(wp), dimension(ncol, ngpt), intent(in ) :: sfc_emis + !! Surface emissivity [] + real(wp), dimension(ncol, ngpt), intent(in ) :: sfc_src + !! Surface source function [W/m2] + real(wp), dimension(ncol, ngpt), intent(in ) :: inc_flux + !! Incident diffuse flux, probably 0 [W/m2] + real(wp), dimension(ncol,nlay+1,ngpt), intent( out) :: flux_up, flux_dn + !! Fluxes [W/m2] + ! ---------------------------------------------------------------------- + integer :: igpt, top_level + real(wp), dimension(ncol,nlay ) :: Rdif, Tdif, gamma1, gamma2 + real(wp), dimension(ncol ) :: sfc_albedo + real(wp), dimension(ncol,nlay ) :: source_dn, source_up + real(wp), dimension(ncol ) :: source_sfc + ! ------------------------------------ + top_level = nlay+1 + if(top_at_1) top_level = 1 + do igpt = 1, ngpt + ! + ! Cell properties: reflection, transmission for diffuse radiation + ! Coupling coefficients needed for source function + ! + call lw_two_stream(ncol, nlay, & + tau (:,:,igpt), ssa(:,:,igpt), g(:,:,igpt), & + gamma1, gamma2, Rdif, Tdif) + ! + ! Source function for diffuse radiation + ! + call lw_source_2str(ncol, nlay, top_at_1, & + sfc_emis(:,igpt), sfc_src(:,igpt), & + lay_source(:,:,igpt), lev_source, & + gamma1, gamma2, Rdif, Tdif, tau(:,:,igpt), & + source_dn, source_up, source_sfc) + ! + ! Transport + ! + sfc_albedo(1:ncol) = 1._wp - sfc_emis(:,igpt) + ! + ! Boundary condition ! - call lw_combine_sources(ncol, nlay, top_at_1, & - lev_source_inc(:,:,igpt), lev_source_dec(:,:,igpt), & - lev_source) - ! - ! Cell properties: reflection, transmission for diffuse radiation - ! Coupling coefficients needed for source function - ! - call lw_two_stream(ncol, nlay, & - tau (:,:,igpt), ssa(:,:,igpt), g(:,:,igpt), & - gamma1, gamma2, Rdif, Tdif) - ! - ! Source function for diffuse radiation - ! - call lw_source_2str(ncol, nlay, top_at_1, & - sfc_emis(:,igpt), sfc_src(:,igpt), & - lay_source(:,:,igpt), lev_source, & - gamma1, gamma2, Rdif, Tdif, tau(:,:,igpt), & - source_dn, source_up, source_sfc) - ! - ! Transport - ! - sfc_albedo(1:ncol) = 1._wp - sfc_emis(:,igpt) - ! - ! Boundary condition - ! - flux_dn(:,top_level,igpt) = inc_flux(:,igpt) - call adding(ncol, nlay, top_at_1, & - sfc_albedo, & - Rdif, Tdif, & - source_dn, source_up, source_sfc, & - flux_up(:,:,igpt), flux_dn(:,:,igpt)) - end do + flux_dn(:,top_level,igpt) = inc_flux(:,igpt) + call adding(ncol, nlay, top_at_1, & + sfc_albedo, & + Rdif, Tdif, & + source_dn, source_up, source_sfc, & + flux_up(:,:,igpt), flux_dn(:,:,igpt)) + end do + + end subroutine lw_solver_2stream + ! ------------------------------------------------------------------------------------------------- + ! + ! Top-level shortwave kernels + ! + ! ------------------------------------------------------------------------------------------------- + ! + ! !> Extinction-only shortwave solver i.e. solar direct beam + ! + ! ------------------------------------------------------------------------------------------------- + pure subroutine sw_solver_noscat(ncol, nlay, ngpt, top_at_1, & + tau, mu0, inc_flux_dir, flux_dir) bind(C, name="rte_sw_solver_noscat") + integer, intent(in ) :: ncol, nlay, ngpt ! Number of columns, layers, g-points + !! Number of columns, layers, g-points + logical(wl), intent(in ) :: top_at_1 + !! ilay = 1 is the top of the atmosphere? + real(wp), dimension(ncol,nlay, ngpt), intent(in ) :: tau + !! Absorption optical thickness [] + real(wp), dimension(ncol,nlay ), intent(in ) :: mu0 + !! cosine of solar zenith angle + real(wp), dimension(ncol, ngpt), intent(in ) :: inc_flux_dir + !! Direct beam incident flux [W/m2] + real(wp), dimension(ncol,nlay+1,ngpt), intent(out) :: flux_dir + !! Direct-beam flux, spectral [W/m2] - end subroutine lw_solver_2stream - ! ------------------------------------------------------------------------------------------------- - ! - ! Top-level shortwave kernels - ! - ! ------------------------------------------------------------------------------------------------- - ! - ! !> Extinction-only shortwave solver i.e. solar direct beam - ! - ! ------------------------------------------------------------------------------------------------- - pure subroutine sw_solver_noscat(ncol, nlay, ngpt, top_at_1, & - tau, mu0, inc_flux_dir, flux_dir) bind(C, name="rte_sw_solver_noscat") - integer, intent(in ) :: ncol, nlay, ngpt ! Number of columns, layers, g-points - !! Number of columns, layers, g-points - logical(wl), intent(in ) :: top_at_1 - !! ilay = 1 is the top of the atmosphere? - real(wp), dimension(ncol,nlay, ngpt), intent(in ) :: tau - !! Absorption optical thickness [] - real(wp), dimension(ncol,nlay ), intent(in ) :: mu0 - !! cosine of solar zenith angle - real(wp), dimension(ncol, ngpt), intent(in ) :: inc_flux_dir - !! Direct beam incident flux [W/m2] - real(wp), dimension(ncol,nlay+1,ngpt), intent(out) :: flux_dir - !! Direct-beam flux, spectral [W/m2] - - integer :: ilev, igpt - - ! ------------------------------------ - ! Indexing into arrays for upward and downward propagation depends on the vertical - ! orientation of the arrays (whether the domain top is at the first or last index) - ! We write the loops out explicitly so compilers will have no trouble optimizing them. - - ! Downward propagation - if(top_at_1) then - ! For the flux at this level, what was the previous level, and which layer has the - ! radiation just passed through? - ! layer index = level index - 1 - ! previous level is up (-1) - do igpt = 1, ngpt - flux_dir(:, 1,igpt) = inc_flux_dir(:,igpt) * mu0(:,1) - do ilev = 2, nlay+1 - flux_dir(:,ilev,igpt) = flux_dir(:,ilev-1,igpt) * exp(-tau(:,ilev-1,igpt)/mu0(:,ilev-1)) - end do - end do - else - ! layer index = level index - ! previous level is up (+1) - do igpt = 1, ngpt - flux_dir(:,nlay+1,igpt) = inc_flux_dir(:,igpt) * mu0(:,nlay) - do ilev = nlay, 1, -1 - flux_dir(:,ilev,igpt) = flux_dir(:,ilev+1,igpt) * exp(-tau(:,ilev,igpt)/mu0(:,ilev)) - end do - end do - end if - end subroutine sw_solver_noscat - ! ------------------------------------------------------------------------------------------------- - ! - !> Shortwave two-stream calculation: - !> compute layer reflectance, transmittance - !> compute solar source function for diffuse radiation - !> transport - ! - ! ------------------------------------------------------------------------------------------------- - subroutine sw_solver_2stream (ncol, nlay, ngpt, top_at_1, & - tau, ssa, g, mu0, & - sfc_alb_dir, sfc_alb_dif, & - inc_flux_dir, & - flux_up, flux_dn, flux_dir, & - has_dif_bc, inc_flux_dif, & - do_broadband, broadband_up, & - broadband_dn, broadband_dir) bind(C, name="rte_sw_solver_2stream") - integer, intent(in ) :: ncol, nlay, ngpt - !! Number of columns, layers, g-points - logical(wl), intent(in ) :: top_at_1 - !! ilay = 1 is the top of the atmosphere? - real(wp), dimension(ncol,nlay, ngpt), intent(in ) :: tau, ssa, g - !! Optical thickness, single-scattering albedo, asymmetry parameter [] - real(wp), dimension(ncol,nlay ), intent(in ) :: mu0 - !! cosine of solar zenith angle - real(wp), dimension(ncol, ngpt), intent(in ) :: sfc_alb_dir, sfc_alb_dif - !! Spectral surface albedo for direct and diffuse radiation - real(wp), dimension(ncol, ngpt), intent(in ) :: inc_flux_dir - !! Direct beam incident flux - real(wp), dimension(ncol,nlay+1,ngpt), target, & - intent( out) :: flux_up, flux_dn, flux_dir - !! Fluxes [W/m2] - logical(wl), intent(in ) :: has_dif_bc - !! Is a boundary condition for diffuse flux supplied? - real(wp), dimension(ncol, ngpt), intent(in ) :: inc_flux_dif - !! Boundary condition for diffuse flux [W/m2] - logical(wl), intent(in ) :: do_broadband - !! Provide broadband-integrated, not spectrally-resolved, fluxes? - real(wp), dimension(ncol,nlay+1 ), intent( out) :: broadband_up, broadband_dn, broadband_dir - !! Broadband integrated fluxes - ! ------------------------------------------- - integer :: igpt, top_level, top_layer - real(wp), dimension(ncol,nlay ) :: Rdif, Tdif - real(wp), dimension(ncol,nlay ) :: source_up, source_dn - real(wp), dimension(ncol ) :: source_srf - ! loc_fluxes hold a single g-point flux if fluxes are being integrated instead of returned - ! with spectral detail - real(wp), dimension(ncol,nlay+1), & - target :: loc_flux_up, loc_flux_dn, loc_flux_dir - ! gpt_fluxes point to calculations for the current g-point - real(wp), dimension(:,:), pointer :: gpt_flux_up, gpt_flux_dn, gpt_flux_dir - ! ------------------------------------ - if(top_at_1) then - top_level = 1 - top_layer = 1 - else - top_level = nlay+1 - top_layer = nlay - end if - ! - ! Integrated fluxes need zeroing - ! - if(do_broadband) then - call zero_array(ncol, nlay+1, broadband_up ) - call zero_array(ncol, nlay+1, broadband_dn ) - call zero_array(ncol, nlay+1, broadband_dir) - end if - - do igpt = 1, ngpt - if(do_broadband) then - gpt_flux_up => loc_flux_up - gpt_flux_dn => loc_flux_dn - gpt_flux_dir => loc_flux_dir - else - gpt_flux_up => flux_up (:,:,igpt) - gpt_flux_dn => flux_dn (:,:,igpt) - gpt_flux_dir => flux_dir(:,:,igpt) - end if - ! - ! Boundary conditions direct beam... - ! - gpt_flux_dir(:,top_level) = inc_flux_dir(:,igpt) * mu0(:,top_layer) - ! - ! ... and diffuse field, using 0 if no BC is provided - ! - if(has_dif_bc) then - gpt_flux_dn(:,top_level) = inc_flux_dif(:,igpt) - else - gpt_flux_dn(:,top_level) = 0._wp - end if - ! - ! Cell properties: transmittance and reflectance for diffuse radiation - ! Direct-beam and source for diffuse radiation - ! - call sw_dif_and_source(ncol, nlay, top_at_1, mu0, sfc_alb_dir(:,igpt), & - tau(:,:,igpt), ssa(:,:,igpt), g(:,:,igpt), & - Rdif, Tdif, source_dn, source_up, source_srf, & - gpt_flux_dir) - ! - ! Transport - ! - call adding(ncol, nlay, top_at_1, & - sfc_alb_dif(:,igpt), Rdif, Tdif, & - source_dn, source_up, source_srf, gpt_flux_up, gpt_flux_dn) - ! - ! adding() computes only diffuse flux; flux_dn is total - ! - if(do_broadband) then - broadband_up (:,:) = broadband_up (:,:) + gpt_flux_up (:,:) - broadband_dn (:,:) = broadband_dn (:,:) + gpt_flux_dn (:,:) + gpt_flux_dir(:,:) - broadband_dir(:,:) = broadband_dir(:,:) + gpt_flux_dir(:,:) - else - gpt_flux_dn(:,:) = gpt_flux_dn (:,:) + gpt_flux_dir(:,:) - end if - end do - end subroutine sw_solver_2stream - ! ------------------------------------------------------------------------------------------------- - ! - ! Lower-level longwave kernels - ! - ! ------------------------------------------------------------------------------------------------- - ! - ! Compute LW source function for upward and downward emission at levels using linear-in-tau assumption - ! See Clough et al., 1992, doi: 10.1029/92JD01419, Eq 13 - ! - ! --------------------------------------------------------------- - subroutine lw_source_noscat(ncol, nlay, lay_source, lev_source_up, lev_source_dn, tau, trans, & - source_dn, source_up) - integer, intent(in) :: ncol, nlay - real(wp), dimension(ncol, nlay), intent(in) :: lay_source, & ! Planck source at layer center - lev_source_up, & ! Planck source at levels (layer edges), - lev_source_dn, & ! increasing/decreasing layer index - tau, & ! Optical path (tau/mu) - trans ! Transmissivity (exp(-tau)) - real(wp), dimension(ncol, nlay), intent(out):: source_dn, source_up - ! Source function at layer edges - ! Down at the bottom of the layer, up at the top - ! -------------------------------- - integer :: icol, ilay - real(wp) :: fact - real(wp), parameter :: tau_thresh = sqrt(sqrt(epsilon(tau))) - ! --------------------------------------------------------------- - do ilay = 1, nlay - do icol = 1, ncol - ! - ! Weighting factor. Use 2nd order series expansion when rounding error (~tau^2) - ! is of order epsilon (smallest difference from 1. in working precision) - ! Thanks to Peter Blossey - ! Updated to 3rd order series and lower threshold based on suggestion from Dmitry Alexeev (Nvidia) - ! - if(tau(icol, ilay) > tau_thresh) then - fact = (1._wp - trans(icol,ilay))/tau(icol,ilay) - trans(icol,ilay) - else - fact = tau(icol, ilay) * (0.5_wp + tau(icol, ilay) * (- 1._wp/3._wp + tau(icol, ilay) * 1._wp/8._wp ) ) - end if - ! - ! Equation below is developed in Clough et al., 1992, doi:10.1029/92JD01419, Eq 13 - ! - source_dn(icol,ilay) = (1._wp - trans(icol,ilay)) * lev_source_dn(icol,ilay) + & - 2._wp * fact * (lay_source(icol,ilay) - lev_source_dn(icol,ilay)) - source_up(icol,ilay) = (1._wp - trans(icol,ilay)) * lev_source_up(icol,ilay ) + & - 2._wp * fact * (lay_source(icol,ilay) - lev_source_up(icol,ilay)) - end do - end do - end subroutine lw_source_noscat - ! ------------------------------------------------------------------------------------------------- - ! - ! Longwave no-scattering transport - separate routines for up and down - ! - ! ------------------------------------------------------------------------------------------------- - subroutine lw_transport_noscat_dn(ncol, nlay, top_at_1, & - trans, source_dn, radn_dn) - integer, intent(in ) :: ncol, nlay ! Number of columns, layers, g-points - logical(wl), intent(in ) :: top_at_1 ! - real(wp), dimension(ncol,nlay ), intent(in ) :: trans ! transmissivity = exp(-tau) - real(wp), dimension(ncol,nlay ), intent(in ) :: source_dn ! Diffuse radiation emitted by the layer - real(wp), dimension(ncol,nlay+1), intent(inout) :: radn_dn ! Radiances [W/m2-str] Top level must contain incident flux boundary condition - - ! --------------------------------------------------- - ! Local variables - integer :: ilev - ! --------------------------------------------------- - if(top_at_1) then - ! - ! Top of domain is index 1 - ! - do ilev = 2, nlay+1 - radn_dn(:,ilev) = trans(:,ilev-1)*radn_dn(:,ilev-1) + source_dn(:,ilev-1) - end do - else - ! - ! Top of domain is index nlay+1 - ! - do ilev = nlay, 1, -1 - radn_dn(:,ilev) = trans(:,ilev )*radn_dn(:,ilev+1) + source_dn(:,ilev) - end do - end if - end subroutine lw_transport_noscat_dn - ! ------------------------------------------------------------------------------------------------- - subroutine lw_transport_noscat_up(ncol, nlay, top_at_1, & - trans, source_up, radn_up, do_Jacobians, radn_upJac) - integer, intent(in ) :: ncol, nlay ! Number of columns, layers, g-points - logical(wl), intent(in ) :: top_at_1 ! - real(wp), dimension(ncol,nlay ), intent(in ) :: trans ! transmissivity = exp(-tau) - real(wp), dimension(ncol,nlay ), intent(in ) :: source_up ! Diffuse radiation emitted by the layer - real(wp), dimension(ncol,nlay+1), intent(inout) :: radn_up ! Radiances [W/m2-str] Top level must contain incident flux boundary condition - logical(wl), intent(in ) :: do_Jacobians - real(wp), dimension(ncol,nlay+1), intent(inout) :: radn_upJac ! surface temperature Jacobian of Radiances [W/m2-str / K] - - ! --------------------------------------------------- - ! Local variables - integer :: ilev - ! --------------------------------------------------- - if(top_at_1) then - ! - ! Top of domain is index 1 + integer :: ilev, igpt + + ! ------------------------------------ + ! Indexing into arrays for upward and downward propagation depends on the vertical + ! orientation of the arrays (whether the domain top is at the first or last index) + ! We write the loops out explicitly so compilers will have no trouble optimizing them. + + ! Downward propagation + if(top_at_1) then + ! For the flux at this level, what was the previous level, and which layer has the + ! radiation just passed through? + ! layer index = level index - 1 + ! previous level is up (-1) + do igpt = 1, ngpt + flux_dir(:, 1,igpt) = inc_flux_dir(:,igpt) * mu0(:,1) + do ilev = 2, nlay+1 + flux_dir(:,ilev,igpt) = flux_dir(:,ilev-1,igpt) * exp(-tau(:,ilev-1,igpt)/mu0(:,ilev-1)) + end do + end do + else + ! layer index = level index + ! previous level is up (+1) + do igpt = 1, ngpt + flux_dir(:,nlay+1,igpt) = inc_flux_dir(:,igpt) * mu0(:,nlay) + do ilev = nlay, 1, -1 + flux_dir(:,ilev,igpt) = flux_dir(:,ilev+1,igpt) * exp(-tau(:,ilev,igpt)/mu0(:,ilev)) + end do + end do + end if + end subroutine sw_solver_noscat + ! ------------------------------------------------------------------------------------------------- + ! + !> Shortwave two-stream calculation: + !> compute layer reflectance, transmittance + !> compute solar source function for diffuse radiation + !> transport + ! + ! ------------------------------------------------------------------------------------------------- + subroutine sw_solver_2stream (ncol, nlay, ngpt, top_at_1, & + tau, ssa, g, mu0, & + sfc_alb_dir, sfc_alb_dif, & + inc_flux_dir, & + flux_up, flux_dn, flux_dir, & + has_dif_bc, inc_flux_dif, & + do_broadband, broadband_up, & + broadband_dn, broadband_dir) bind(C, name="rte_sw_solver_2stream") + integer, intent(in ) :: ncol, nlay, ngpt + !! Number of columns, layers, g-points + logical(wl), intent(in ) :: top_at_1 + !! ilay = 1 is the top of the atmosphere? + real(wp), dimension(ncol,nlay, ngpt), intent(in ) :: tau, ssa, g + !! Optical thickness, single-scattering albedo, asymmetry parameter [] + real(wp), dimension(ncol,nlay ), intent(in ) :: mu0 + !! cosine of solar zenith angle + real(wp), dimension(ncol, ngpt), intent(in ) :: sfc_alb_dir, sfc_alb_dif + !! Spectral surface albedo for direct and diffuse radiation + real(wp), dimension(ncol, ngpt), intent(in ) :: inc_flux_dir + !! Direct beam incident flux + real(wp), dimension(ncol,nlay+1,ngpt), target, & + intent( out) :: flux_up, flux_dn, flux_dir + !! Fluxes [W/m2] + logical(wl), intent(in ) :: has_dif_bc + !! Is a boundary condition for diffuse flux supplied? + real(wp), dimension(ncol, ngpt), intent(in ) :: inc_flux_dif + !! Boundary condition for diffuse flux [W/m2] + logical(wl), intent(in ) :: do_broadband + !! Provide broadband-integrated, not spectrally-resolved, fluxes? + real(wp), dimension(ncol,nlay+1 ), intent( out) :: broadband_up, broadband_dn, broadband_dir + !! Broadband integrated fluxes + ! ------------------------------------------- + integer :: igpt, top_level, top_layer + real(wp), dimension(ncol,nlay ) :: Rdif, Tdif + real(wp), dimension(ncol,nlay ) :: source_up, source_dn + real(wp), dimension(ncol ) :: source_srf + ! loc_fluxes hold a single g-point flux if fluxes are being integrated instead of returned + ! with spectral detail + real(wp), dimension(ncol,nlay+1), & + target :: loc_flux_up, loc_flux_dn, loc_flux_dir + ! gpt_fluxes point to calculations for the current g-point + real(wp), dimension(:,:), pointer :: gpt_flux_up, gpt_flux_dn, gpt_flux_dir + ! ------------------------------------ + if(top_at_1) then + top_level = 1 + top_layer = 1 + else + top_level = nlay+1 + top_layer = nlay + end if + ! + ! Integrated fluxes need zeroing + ! + if(do_broadband) then + call zero_array(ncol, nlay+1, broadband_up ) + call zero_array(ncol, nlay+1, broadband_dn ) + call zero_array(ncol, nlay+1, broadband_dir) + end if + + do igpt = 1, ngpt + if(do_broadband) then + gpt_flux_up => loc_flux_up + gpt_flux_dn => loc_flux_dn + gpt_flux_dir => loc_flux_dir + else + gpt_flux_up => flux_up (:,:,igpt) + gpt_flux_dn => flux_dn (:,:,igpt) + gpt_flux_dir => flux_dir(:,:,igpt) + end if + ! + ! Boundary conditions direct beam... + ! + gpt_flux_dir(:,top_level) = inc_flux_dir(:,igpt) * mu0(:,top_layer) + ! + ! ... and diffuse field, using 0 if no BC is provided + ! + if(has_dif_bc) then + gpt_flux_dn(:,top_level) = inc_flux_dif(:,igpt) + else + gpt_flux_dn(:,top_level) = 0._wp + end if + ! + ! Cell properties: transmittance and reflectance for diffuse radiation + ! Direct-beam and source for diffuse radiation + ! + call sw_dif_and_source(ncol, nlay, top_at_1, mu0, sfc_alb_dir(:,igpt), & + tau(:,:,igpt), ssa(:,:,igpt), g(:,:,igpt), & + Rdif, Tdif, source_dn, source_up, source_srf, & + gpt_flux_dir) + ! + ! Transport + ! + call adding(ncol, nlay, top_at_1, & + sfc_alb_dif(:,igpt), Rdif, Tdif, & + source_dn, source_up, source_srf, gpt_flux_up, gpt_flux_dn) + ! + ! adding() computes only diffuse flux; flux_dn is total + ! + if(do_broadband) then + broadband_up (:,:) = broadband_up (:,:) + gpt_flux_up (:,:) + broadband_dn (:,:) = broadband_dn (:,:) + gpt_flux_dn (:,:) + gpt_flux_dir(:,:) + broadband_dir(:,:) = broadband_dir(:,:) + gpt_flux_dir(:,:) + else + gpt_flux_dn(:,:) = gpt_flux_dn (:,:) + gpt_flux_dir(:,:) + end if + end do + end subroutine sw_solver_2stream + ! ------------------------------------------------------------------------------------------------- + ! + ! Lower-level longwave kernels + ! + ! ------------------------------------------------------------------------------------------------- + ! + ! Compute LW source function for upward and downward emission at levels using linear-in-tau assumption + ! See Clough et al., 1992, doi: 10.1029/92JD01419, Eq 13 + ! + ! --------------------------------------------------------------- + subroutine lw_source_noscat(ncol, nlay, top_at_1, lay_source, lev_source, tau, trans, & + source_dn, source_up) + integer, intent(in) :: ncol, nlay + logical(wl), intent(in) :: top_at_1 + real(wp), dimension(ncol, nlay ), intent(in) :: lay_source, & ! Planck source at layer center + tau, & ! Optical path (tau/mu) + trans ! Transmissivity (exp(-tau)) + real(wp), dimension(ncol, nlay+1), intent(in) :: lev_source ! Planck source at levels (layer edges) + real(wp), dimension(ncol, nlay ), target, & + intent(out):: source_dn, source_up + ! Source function at layer edges + ! Down at the bottom of the layer, up at the top + ! -------------------------------- + real(wp), dimension(:,:), pointer :: source_inc, source_dec + integer :: icol, ilay + real(wp) :: fact + real(wp), parameter :: tau_thresh = sqrt(sqrt(epsilon(tau))) + ! --------------------------------------------------------------- + if (top_at_1) then + source_inc => source_dn + source_dec => source_up + else + source_inc => source_up + source_dec => source_dn + end if + do ilay = 1, nlay + do icol = 1, ncol + ! + ! Weighting factor. Use 3rd order series expansion when rounding error (~tau^2) + ! is of order epsilon (smallest difference from 1. in working precision) + ! Thanks to Peter Blossey (UW) for the idea and Dmitry Alexeev (Nvidia) for suggesting 3rd order + ! + if(tau(icol, ilay) > tau_thresh) then + fact = (1._wp - trans(icol,ilay))/tau(icol,ilay) - trans(icol,ilay) + else + fact = tau(icol, ilay) * (0.5_wp + tau(icol, ilay) * (- 1._wp/3._wp + tau(icol, ilay) * 1._wp/8._wp ) ) + end if + ! + ! Equation below is developed in Clough et al., 1992, doi:10.1029/92JD01419, Eq 13 + ! + source_inc(icol,ilay) = (1._wp - trans(icol,ilay)) * lev_source(icol,ilay+1) + & + 2._wp * fact * (lay_source(icol,ilay) - lev_source(icol,ilay+1)) + source_dec(icol,ilay) = (1._wp - trans(icol,ilay)) * lev_source(icol,ilay ) + & + 2._wp * fact * (lay_source(icol,ilay) - lev_source(icol,ilay )) + ! + ! Even better - omit the layer Planck source (not working so well) + ! + if(.false.) then + source_inc(icol,ilay) = (1._wp - trans(icol,ilay)) * lev_source(icol,ilay+1) + & + fact * (lev_source(icol,ilay ) - lev_source(icol,ilay+1)) + source_dec(icol,ilay) = (1._wp - trans(icol,ilay)) * lev_source(icol,ilay ) + & + fact * (lev_source(icol,ilay+1) - lev_source(icol,ilay )) + end if + end do + end do + end subroutine lw_source_noscat + ! ------------------------------------------------------------------------------------------------- + ! + ! Longwave no-scattering transport - separate routines for up and down + ! + ! ------------------------------------------------------------------------------------------------- + subroutine lw_transport_noscat_dn(ncol, nlay, top_at_1, & + trans, source_dn, radn_dn) + integer, intent(in ) :: ncol, nlay ! Number of columns, layers, g-points + logical(wl), intent(in ) :: top_at_1 ! + real(wp), dimension(ncol,nlay ), intent(in ) :: trans ! transmissivity = exp(-tau) + real(wp), dimension(ncol,nlay ), intent(in ) :: source_dn ! Diffuse radiation emitted by the layer + real(wp), dimension(ncol,nlay+1), intent(inout) :: radn_dn ! Radiances [W/m2-str] Top level must contain incident flux boundary condition + + ! --------------------------------------------------- + ! Local variables + integer :: ilev + ! --------------------------------------------------- + if(top_at_1) then + ! + ! Top of domain is index 1 + ! + do ilev = 2, nlay+1 + radn_dn(:,ilev) = trans(:,ilev-1)*radn_dn(:,ilev-1) + source_dn(:,ilev-1) + end do + else + ! + ! Top of domain is index nlay+1 + ! + do ilev = nlay, 1, -1 + radn_dn(:,ilev) = trans(:,ilev )*radn_dn(:,ilev+1) + source_dn(:,ilev) + end do + end if + end subroutine lw_transport_noscat_dn + ! ------------------------------------------------------------------------------------------------- + subroutine lw_transport_noscat_up(ncol, nlay, top_at_1, & + trans, source_up, radn_up, do_Jacobians, radn_upJac) + integer, intent(in ) :: ncol, nlay ! Number of columns, layers, g-points + logical(wl), intent(in ) :: top_at_1 ! + real(wp), dimension(ncol,nlay ), intent(in ) :: trans ! transmissivity = exp(-tau) + real(wp), dimension(ncol,nlay ), intent(in ) :: source_up ! Diffuse radiation emitted by the layer + real(wp), dimension(ncol,nlay+1), intent(inout) :: radn_up ! Radiances [W/m2-str] Top level must contain incident flux boundary condition + logical(wl), intent(in ) :: do_Jacobians + real(wp), dimension(ncol,nlay+1), intent(inout) :: radn_upJac ! surface temperature Jacobian of Radiances [W/m2-str / K] + + ! --------------------------------------------------- + ! Local variables + integer :: ilev + ! --------------------------------------------------- + if(top_at_1) then + ! + ! Top of domain is index 1 + ! + ! Upward propagation + do ilev = nlay, 1, -1 + radn_up (:,ilev) = trans(:,ilev )*radn_up (:,ilev+1) + source_up(:,ilev) + if(do_Jacobians) & + radn_upJac(:,ilev) = trans(:,ilev )*radn_upJac(:,ilev+1) + end do + else ! - ! Upward propagation - do ilev = nlay, 1, -1 - radn_up (:,ilev) = trans(:,ilev )*radn_up (:,ilev+1) + source_up(:,ilev) - if(do_Jacobians) & - radn_upJac(:,ilev) = trans(:,ilev )*radn_upJac(:,ilev+1) - end do - else - ! - ! Top of domain is index nlay+1 - ! - ! Upward propagation - do ilev = 2, nlay+1 - radn_up (:,ilev) = trans(:,ilev-1) * radn_up (:,ilev-1) + source_up(:,ilev-1) - if(do_Jacobians) & - radn_upJac(:,ilev) = trans(:,ilev-1) * radn_upJac(:,ilev-1) - end do - end if - end subroutine lw_transport_noscat_up - ! ------------------------------------------------------------------------------------------------- - ! Upward and (second) downward transport for re-scaled longwave solution - ! adds adjustment factor based on cloud properties - ! - ! implementation notice: - ! the adjustmentFactor computation can be skipped where Cn <= epsilon - ! ------------------------------------------------------------------------------------------------- - subroutine lw_transport_1rescl(ncol, nlay, top_at_1, & - trans, source_dn, source_up, & - radn_up, radn_dn, An, Cn,& - do_Jacobians, radn_up_Jac) - integer, intent(in ) :: ncol, nlay ! Number of columns, layers, g-points - logical(wl), intent(in ) :: top_at_1 ! - real(wp), dimension(ncol,nlay ), intent(in ) :: trans ! transmissivity = exp(-tau) - real(wp), dimension(ncol,nlay ), intent(in ) :: source_dn, & - source_up ! Diffuse radiation emitted by the layer - real(wp), dimension(ncol,nlay+1), intent(inout) :: radn_up ! Radiances [W/m2-str] - real(wp), dimension(ncol,nlay+1), intent(inout) :: radn_dn !Top level must contain incident flux boundary condition - real(wp), dimension(ncol,nlay), intent(in ) :: An, Cn - logical(wl), intent(in ) :: do_Jacobians - real(wp), dimension(ncol,nlay+1), intent(inout) :: radn_up_Jac ! Surface temperature Jacobians [W/m2-str/K] - ! - ! We could in principle compute a downwelling Jacobian too, but it's small - ! (only a small proportion of LW is scattered) and it complicates code and the API, - ! so we will not - ! - - ! Local variables - integer :: ilev, icol - ! --------------------------------------------------- - real(wp) :: adjustmentFactor - if(top_at_1) then - ! - ! Top of domain is index 1 - ! - ! Upward propagation - ! adjustment factor is obtained as a solution of 18b of the Tang paper - ! eqvivalent to Eq.20 of the Tang paper but for linear-in-tau source - do ilev = nlay, 1, -1 - do icol=1,ncol - adjustmentFactor = Cn(icol,ilev)*( An(icol,ilev)*radn_dn(icol,ilev) - & - trans(icol,ilev)*source_dn(icol,ilev) - source_up(icol,ilev) ) - radn_up (icol,ilev) = trans(icol,ilev)*radn_up(icol,ilev+1) + source_up(icol,ilev) + & - adjustmentFactor - end do - if(do_Jacobians) & - radn_up_Jac(:,ilev) = trans(:,ilev)*radn_up_Jac(:,ilev+1) - end do - ! Downward propagation - ! radn_dn_Jac(:,1) = 0._wp - ! adjustment factor is obtained as a solution of 19 of the Tang paper - ! eqvivalent to Eq.21 of the Tang paper but for linear-in-tau source - do ilev = 1, nlay - ! radn_dn_Jac(:,ilev+1) = trans(:,ilev)*radn_dn_Jac(:,ilev) - do icol=1,ncol - adjustmentFactor = Cn(icol,ilev)*( An(icol,ilev)*radn_up(icol,ilev) - & - trans(icol,ilev)*source_up(icol,ilev) - source_dn(icol,ilev) ) - radn_dn(icol,ilev+1) = trans(icol,ilev)*radn_dn(icol,ilev) + source_dn(icol,ilev) + & - adjustmentFactor - ! adjustmentFactor = Cn(icol,ilev)*An(icol,ilev)*radn_up_Jac(icol,ilev) - ! radn_dn_Jac(icol,ilev+1) = radn_dn_Jac(icol,ilev+1) + adjustmentFactor - enddo - end do - else - ! - ! Top of domain is index nlay+1 - ! - ! Upward propagation - ! adjustment factor is obtained as a solution of 18b of the Tang paper - ! eqvivalent to Eq.20 of the Tang paper but for linear-in-tau source - do ilev = 1, nlay - radn_up (:,ilev+1) = trans(:,ilev) * radn_up (:,ilev) + source_up(:,ilev) - do icol=1,ncol - adjustmentFactor = Cn(icol,ilev)*( An(icol,ilev)*radn_dn(icol,ilev+1) - & - trans(icol,ilev)*source_dn(icol,ilev) - source_up(icol,ilev) ) - radn_up(icol,ilev+1) = trans(icol,ilev)*radn_up(icol,ilev) + source_up(icol,ilev) + & - adjustmentFactor - enddo - if(do_Jacobians) & - radn_up_Jac(:,ilev+1) = trans(:,ilev) * radn_up_Jac(:,ilev) - end do - - ! Downward propagation - ! adjustment factor is obtained as a solution of 19 of the Tang paper - ! eqvivalent to Eq.21 of the Tang paper but for linear-in-tau source - ! radn_dn_Jac(:,nlay+1) = 0._wp - do ilev = nlay, 1, -1 - ! radn_dn_Jac(:,ilev) = trans(:,ilev)*radn_dn_Jac(:,ilev+1) - do icol=1,ncol - adjustmentFactor = Cn(icol,ilev)*( An(icol,ilev)*radn_up(icol,ilev) - & - trans(icol,ilev)*source_up(icol,ilev) - source_dn(icol,ilev) ) - radn_dn(icol,ilev) = trans(icol,ilev)*radn_dn(icol,ilev+1) + source_dn(icol,ilev) + & - adjustmentFactor - ! adjustmentFactor = Cn(icol,ilev)*An(icol,ilev)*radn_up_Jac(icol,ilev) - ! radn_dn_Jac(icol,ilev) = radn_dn_Jac(icol,ilev) + adjustmentFactor - enddo - end do - end if - end subroutine lw_transport_1rescl -! ------------------------------------------------------------------------------------------------- - ! - ! Longwave two-stream solutions to diffuse reflectance and transmittance for a layer - ! with optical depth tau, single scattering albedo w0, and asymmetery parameter g. - ! - ! Equations are developed in Meador and Weaver, 1980, - ! doi:10.1175/1520-0469(1980)037<0630:TSATRT>2.0.CO;2 - ! - ! ------------------------------------------------------------------------------------------------- - pure subroutine lw_two_stream(ncol, nlay, tau, w0, g, & - gamma1, gamma2, Rdif, Tdif) - integer, intent(in) :: ncol, nlay - real(wp), dimension(ncol,nlay), intent(in) :: tau, w0, g - real(wp), dimension(ncol,nlay), intent(out) :: gamma1, gamma2, Rdif, Tdif - - ! ----------------------- - integer :: i, j - - ! Variables used in Meador and Weaver - real(wp) :: k(ncol) - - ! Ancillary variables - real(wp) :: RT_term(ncol) - real(wp) :: exp_minusktau(ncol), exp_minus2ktau(ncol) - - real(wp), parameter :: LW_diff_sec = 1.66 ! 1./cos(diffusivity angle) - ! --------------------------------- - do j = 1, nlay - do i = 1, ncol - ! - ! Coefficients differ from SW implementation because the phase function is more isotropic - ! Here we follow Fu et al. 1997, doi:10.1175/1520-0469(1997)054<2799:MSPITI>2.0.CO;2 - ! and use a diffusivity sec of 1.66 - ! - gamma1(i,j)= LW_diff_sec * (1._wp - 0.5_wp * w0(i,j) * (1._wp + g(i,j))) ! Fu et al. Eq 2.9 - gamma2(i,j)= LW_diff_sec * 0.5_wp * w0(i,j) * (1._wp - g(i,j)) ! Fu et al. Eq 2.10 - ! Eq 18; k = SQRT(gamma1**2 - gamma2**2), limited below to avoid div by 0. - ! k = 0 for isotropic, conservative scattering; this lower limit on k - ! gives relative error with respect to conservative solution - ! of < 0.1% in Rdif down to tau = 10^-9 - k(i) = sqrt(max((gamma1(i,j) - gamma2(i,j)) * (gamma1(i,j) + gamma2(i,j)), 1.e-12_wp)) - end do - - ! Written to encourage vectorization of exponential - exp_minusktau(1:ncol) = exp(-tau(1:ncol,j)*k(1:ncol)) - - ! - ! Diffuse reflection and transmission - ! - do i = 1, ncol - exp_minus2ktau(i) = exp_minusktau(i) * exp_minusktau(i) - - ! Refactored to avoid rounding errors when k, gamma1 are of very different magnitudes - RT_term(i) = 1._wp / (k (i ) * (1._wp + exp_minus2ktau(i)) + & - gamma1(i,j) * (1._wp - exp_minus2ktau(i)) ) - - ! Equation 25 - Rdif(i,j) = RT_term(i) * gamma2(i,j) * (1._wp - exp_minus2ktau(i)) - - ! Equation 26 - Tdif(i,j) = RT_term(i) * 2._wp * k(i) * exp_minusktau(i) - end do - - end do - end subroutine lw_two_stream - ! ------------------------------------------------------------------------------------------------- - ! - ! Source function combination - ! RRTMGP provides two source functions at each level - ! using the spectral mapping from each of the adjascent layers. - ! Need to combine these for use in two-stream calculation. - ! - ! ------------------------------------------------------------------------------------------------- - subroutine lw_combine_sources(ncol, nlay, top_at_1, & - lev_src_inc, lev_src_dec, lev_source) - integer, intent(in ) :: ncol, nlay - logical(wl), intent(in ) :: top_at_1 - real(wp), dimension(ncol, nlay ), intent(in ) :: lev_src_inc, lev_src_dec - real(wp), dimension(ncol, nlay+1), intent(out) :: lev_source - - integer :: icol, ilay - ! --------------------------------------------------------------- - ilay = 1 - do icol = 1,ncol - lev_source(icol, ilay) = lev_src_dec(icol, ilay) - end do - do ilay = 2, nlay - do icol = 1,ncol - lev_source(icol, ilay) = sqrt(lev_src_dec(icol, ilay) * & - lev_src_inc(icol, ilay-1)) - end do - end do - ilay = nlay+1 - do icol = 1,ncol - lev_source(icol, ilay) = lev_src_inc(icol, ilay-1) - end do - - end subroutine lw_combine_sources - ! --------------------------------------------------------------- - ! - ! Compute LW source function for upward and downward emission at levels using linear-in-tau assumption - ! This version straight from ECRAD - ! Source is provided as W/m2-str; factor of pi converts to flux units - ! - ! --------------------------------------------------------------- - subroutine lw_source_2str(ncol, nlay, top_at_1, & - sfc_emis, sfc_src, & - lay_source, lev_source, & - gamma1, gamma2, rdif, tdif, tau, source_dn, source_up, source_sfc) & - bind (C, name="rte_lw_source_2str") - integer, intent(in) :: ncol, nlay - logical(wl), intent(in) :: top_at_1 - real(wp), dimension(ncol ), intent(in) :: sfc_emis, sfc_src - real(wp), dimension(ncol, nlay), intent(in) :: lay_source, & ! Planck source at layer center - tau, & ! Optical depth (tau) - gamma1, gamma2,& ! Coupling coefficients - rdif, tdif ! Layer reflectance and transmittance - real(wp), dimension(ncol, nlay+1), target, & - intent(in) :: lev_source ! Planck source at layer edges - real(wp), dimension(ncol, nlay), intent(out) :: source_dn, source_up - real(wp), dimension(ncol ), intent(out) :: source_sfc ! Source function for upward radation at surface - - integer :: icol, ilay - real(wp) :: Z, Zup_top, Zup_bottom, Zdn_top, Zdn_bottom - real(wp), dimension(:), pointer :: lev_source_bot, lev_source_top - ! --------------------------------------------------------------- - do ilay = 1, nlay - if(top_at_1) then - lev_source_top => lev_source(:,ilay) - lev_source_bot => lev_source(:,ilay+1) - else - lev_source_top => lev_source(:,ilay+1) - lev_source_bot => lev_source(:,ilay) - end if - do icol = 1, ncol - if (tau(icol,ilay) > 1.0e-8_wp) then - ! - ! Toon et al. (JGR 1989) Eqs 26-27 - ! - Z = (lev_source_bot(icol)-lev_source_top(icol)) / (tau(icol,ilay)*(gamma1(icol,ilay)+gamma2(icol,ilay))) - Zup_top = Z + lev_source_top(icol) - Zup_bottom = Z + lev_source_bot(icol) - Zdn_top = -Z + lev_source_top(icol) - Zdn_bottom = -Z + lev_source_bot(icol) - source_up(icol,ilay) = pi * (Zup_top - rdif(icol,ilay) * Zdn_top - tdif(icol,ilay) * Zup_bottom) - source_dn(icol,ilay) = pi * (Zdn_bottom - rdif(icol,ilay) * Zup_bottom - tdif(icol,ilay) * Zdn_top) - else - source_up(icol,ilay) = 0._wp - source_dn(icol,ilay) = 0._wp - end if - end do - end do - do icol = 1, ncol - source_sfc(icol) = pi * sfc_emis(icol) * sfc_src(icol) - end do - end subroutine lw_source_2str - ! ------------------------------------------------------------------------------------------------- - ! - ! Lower-level shortwave kernels - ! - ! ------------------------------------------------------------------------------------------------- - ! - ! Two-stream solutions to diffuse reflectance and transmittance for a layer - ! with optical depth tau, single scattering albedo w0, and asymmetery parameter g. - ! Direct reflectance and transmittance used to compute direct beam source for diffuse radiation - ! in layers and at surface; report direct beam as a byproduct - ! Computing the direct-beam source for diffuse radiation at the same time as R and T for - ! direct radiation reduces memory traffic and use. - ! - ! Equations are developed in Meador and Weaver, 1980, - ! doi:10.1175/1520-0469(1980)037<0630:TSATRT>2.0.CO;2 - ! - ! ------------------------------------------------------------------------------------------------- - pure subroutine sw_dif_and_source(ncol, nlay, top_at_1, mu0, sfc_albedo, & - tau, w0, g, & - Rdif, Tdif, source_dn, source_up, source_sfc, flux_dn_dir) bind (C, name="rte_sw_source_dir") - integer, intent(in ) :: ncol, nlay - logical(wl), intent(in ) :: top_at_1 - real(wp), dimension(ncol ), intent(in ) :: sfc_albedo ! surface albedo for direct radiation - real(wp), dimension(ncol,nlay ), intent(in ) :: tau, w0, g, mu0 - real(wp), dimension(ncol,nlay ), intent( out) :: Rdif, Tdif, source_dn, source_up - real(wp), dimension(ncol ), intent( out) :: source_sfc ! Source function for upward radation at surface - real(wp), dimension(ncol,nlay+1), target, & - intent(inout) :: flux_dn_dir ! Direct beam flux - - ! ----------------------- - integer :: i, j - - ! Variables used in Meador and Weaver - real(wp) :: gamma1, gamma2, gamma3, gamma4, alpha1, alpha2 - - - ! Ancillary variables - real(wp), parameter :: min_k = 1.e4_wp * epsilon(1._wp) ! Suggestion from Chiel van Heerwaarden - real(wp) :: k, exp_minusktau, k_mu, k_gamma3, k_gamma4 - real(wp) :: RT_term, exp_minus2ktau - real(wp) :: Rdir, Tdir, Tnoscat - real(wp), pointer, dimension(:) :: dir_flux_inc, dir_flux_trans - integer :: lay_index - real(wp) :: tau_s, w0_s, g_s, mu0_s - ! --------------------------------- - - do j = 1, nlay - if(top_at_1) then - lay_index = j - dir_flux_inc => flux_dn_dir(:,lay_index ) - dir_flux_trans => flux_dn_dir(:,lay_index+1) - else - lay_index = nlay-j+1 - dir_flux_inc => flux_dn_dir(:,lay_index+1) - dir_flux_trans => flux_dn_dir(:,lay_index ) - end if - - do i = 1, ncol + ! Top of domain is index nlay+1 + ! + ! Upward propagation + do ilev = 2, nlay+1 + radn_up (:,ilev) = trans(:,ilev-1) * radn_up (:,ilev-1) + source_up(:,ilev-1) + if(do_Jacobians) & + radn_upJac(:,ilev) = trans(:,ilev-1) * radn_upJac(:,ilev-1) + end do + end if + end subroutine lw_transport_noscat_up + ! ------------------------------------------------------------------------------------------------- + ! Upward and (second) downward transport for re-scaled longwave solution + ! adds adjustment factor based on cloud properties + ! + ! implementation notice: + ! the adjustmentFactor computation can be skipped where Cn <= epsilon + ! ------------------------------------------------------------------------------------------------- + subroutine lw_transport_1rescl(ncol, nlay, top_at_1, & + trans, source_dn, source_up, & + radn_up, radn_dn, An, Cn,& + do_Jacobians, radn_up_Jac) + integer, intent(in ) :: ncol, nlay ! Number of columns, layers, g-points + logical(wl), intent(in ) :: top_at_1 ! + real(wp), dimension(ncol,nlay ), intent(in ) :: trans ! transmissivity = exp(-tau) + real(wp), dimension(ncol,nlay ), intent(in ) :: source_dn, & + source_up ! Diffuse radiation emitted by the layer + real(wp), dimension(ncol,nlay+1), intent(inout) :: radn_up ! Radiances [W/m2-str] + real(wp), dimension(ncol,nlay+1), intent(inout) :: radn_dn !Top level must contain incident flux boundary condition + real(wp), dimension(ncol,nlay), intent(in ) :: An, Cn + logical(wl), intent(in ) :: do_Jacobians + real(wp), dimension(ncol,nlay+1), intent(inout) :: radn_up_Jac ! Surface temperature Jacobians [W/m2-str/K] + ! + ! We could in principle compute a downwelling Jacobian too, but it's small + ! (only a small proportion of LW is scattered) and it complicates code and the API, + ! so we will not + ! + + ! Local variables + integer :: ilev, icol + ! --------------------------------------------------- + real(wp) :: adjustmentFactor + if(top_at_1) then + ! + ! Top of domain is index 1 + ! + ! Upward propagation + ! adjustment factor is obtained as a solution of 18b of the Tang paper + ! eqvivalent to Eq.20 of the Tang paper but for linear-in-tau source + do ilev = nlay, 1, -1 + do icol=1,ncol + adjustmentFactor = Cn(icol,ilev)*( An(icol,ilev)*radn_dn(icol,ilev) - & + trans(icol,ilev)*source_dn(icol,ilev) - source_up(icol,ilev) ) + radn_up (icol,ilev) = trans(icol,ilev)*radn_up(icol,ilev+1) + source_up(icol,ilev) + & + adjustmentFactor + end do + if(do_Jacobians) & + radn_up_Jac(:,ilev) = trans(:,ilev)*radn_up_Jac(:,ilev+1) + end do + ! Downward propagation + ! radn_dn_Jac(:,1) = 0._wp + ! adjustment factor is obtained as a solution of 19 of the Tang paper + ! eqvivalent to Eq.21 of the Tang paper but for linear-in-tau source + do ilev = 1, nlay + ! radn_dn_Jac(:,ilev+1) = trans(:,ilev)*radn_dn_Jac(:,ilev) + do icol=1,ncol + adjustmentFactor = Cn(icol,ilev)*( An(icol,ilev)*radn_up(icol,ilev) - & + trans(icol,ilev)*source_up(icol,ilev) - source_dn(icol,ilev) ) + radn_dn(icol,ilev+1) = trans(icol,ilev)*radn_dn(icol,ilev) + source_dn(icol,ilev) + & + adjustmentFactor + ! adjustmentFactor = Cn(icol,ilev)*An(icol,ilev)*radn_up_Jac(icol,ilev) + ! radn_dn_Jac(icol,ilev+1) = radn_dn_Jac(icol,ilev+1) + adjustmentFactor + enddo + end do + else + ! + ! Top of domain is index nlay+1 + ! + ! Upward propagation + ! adjustment factor is obtained as a solution of 18b of the Tang paper + ! eqvivalent to Eq.20 of the Tang paper but for linear-in-tau source + do ilev = 1, nlay + radn_up (:,ilev+1) = trans(:,ilev) * radn_up (:,ilev) + source_up(:,ilev) + do icol=1,ncol + adjustmentFactor = Cn(icol,ilev)*( An(icol,ilev)*radn_dn(icol,ilev+1) - & + trans(icol,ilev)*source_dn(icol,ilev) - source_up(icol,ilev) ) + radn_up(icol,ilev+1) = trans(icol,ilev)*radn_up(icol,ilev) + source_up(icol,ilev) + & + adjustmentFactor + enddo + if(do_Jacobians) & + radn_up_Jac(:,ilev+1) = trans(:,ilev) * radn_up_Jac(:,ilev) + end do + + ! Downward propagation + ! adjustment factor is obtained as a solution of 19 of the Tang paper + ! eqvivalent to Eq.21 of the Tang paper but for linear-in-tau source + ! radn_dn_Jac(:,nlay+1) = 0._wp + do ilev = nlay, 1, -1 + ! radn_dn_Jac(:,ilev) = trans(:,ilev)*radn_dn_Jac(:,ilev+1) + do icol=1,ncol + adjustmentFactor = Cn(icol,ilev)*( An(icol,ilev)*radn_up(icol,ilev) - & + trans(icol,ilev)*source_up(icol,ilev) - source_dn(icol,ilev) ) + radn_dn(icol,ilev) = trans(icol,ilev)*radn_dn(icol,ilev+1) + source_dn(icol,ilev) + & + adjustmentFactor + ! adjustmentFactor = Cn(icol,ilev)*An(icol,ilev)*radn_up_Jac(icol,ilev) + ! radn_dn_Jac(icol,ilev) = radn_dn_Jac(icol,ilev) + adjustmentFactor + enddo + end do + end if + end subroutine lw_transport_1rescl +! ------------------------------------------------------------------------------------------------- + ! + ! Longwave two-stream solutions to diffuse reflectance and transmittance for a layer + ! with optical depth tau, single scattering albedo w0, and asymmetery parameter g. + ! + ! Equations are developed in Meador and Weaver, 1980, + ! doi:10.1175/1520-0469(1980)037<0630:TSATRT>2.0.CO;2 + ! + ! ------------------------------------------------------------------------------------------------- + pure subroutine lw_two_stream(ncol, nlay, tau, w0, g, & + gamma1, gamma2, Rdif, Tdif) + integer, intent(in) :: ncol, nlay + real(wp), dimension(ncol,nlay), intent(in) :: tau, w0, g + real(wp), dimension(ncol,nlay), intent(out) :: gamma1, gamma2, Rdif, Tdif + + ! ----------------------- + integer :: i, j + + ! Variables used in Meador and Weaver + real(wp) :: k(ncol) + + ! Ancillary variables + real(wp) :: RT_term(ncol) + real(wp) :: exp_minusktau(ncol), exp_minus2ktau(ncol) + + real(wp), parameter :: LW_diff_sec = 1.66 ! 1./cos(diffusivity angle) + ! --------------------------------- + do j = 1, nlay + do i = 1, ncol + ! + ! Coefficients differ from SW implementation because the phase function is more isotropic + ! Here we follow Fu et al. 1997, doi:10.1175/1520-0469(1997)054<2799:MSPITI>2.0.CO;2 + ! and use a diffusivity sec of 1.66 + ! + gamma1(i,j)= LW_diff_sec * (1._wp - 0.5_wp * w0(i,j) * (1._wp + g(i,j))) ! Fu et al. Eq 2.9 + gamma2(i,j)= LW_diff_sec * 0.5_wp * w0(i,j) * (1._wp - g(i,j)) ! Fu et al. Eq 2.10 + ! Eq 18; k = SQRT(gamma1**2 - gamma2**2), limited below to avoid div by 0. + ! k = 0 for isotropic, conservative scattering; this lower limit on k + ! gives relative error with respect to conservative solution + ! of < 0.1% in Rdif down to tau = 10^-9 + k(i) = sqrt(max((gamma1(i,j) - gamma2(i,j)) * (gamma1(i,j) + gamma2(i,j)), 1.e-12_wp)) + end do + + ! Written to encourage vectorization of exponential + exp_minusktau(1:ncol) = exp(-tau(1:ncol,j)*k(1:ncol)) + + ! + ! Diffuse reflection and transmission + ! + do i = 1, ncol + exp_minus2ktau(i) = exp_minusktau(i) * exp_minusktau(i) + + ! Refactored to avoid rounding errors when k, gamma1 are of very different magnitudes + RT_term(i) = 1._wp / (k (i ) * (1._wp + exp_minus2ktau(i)) + & + gamma1(i,j) * (1._wp - exp_minus2ktau(i)) ) + + ! Equation 25 + Rdif(i,j) = RT_term(i) * gamma2(i,j) * (1._wp - exp_minus2ktau(i)) + + ! Equation 26 + Tdif(i,j) = RT_term(i) * 2._wp * k(i) * exp_minusktau(i) + end do + + end do + end subroutine lw_two_stream + ! --------------------------------------------------------------- + ! + ! Compute LW source function for upward and downward emission at levels using linear-in-tau assumption + ! This version straight from ECRAD + ! Source is provided as W/m2-str; factor of pi converts to flux units + ! + ! --------------------------------------------------------------- + subroutine lw_source_2str(ncol, nlay, top_at_1, & + sfc_emis, sfc_src, & + lay_source, lev_source, & + gamma1, gamma2, rdif, tdif, tau, source_dn, source_up, source_sfc) & + bind (C, name="rte_lw_source_2str") + integer, intent(in) :: ncol, nlay + logical(wl), intent(in) :: top_at_1 + real(wp), dimension(ncol ), intent(in) :: sfc_emis, sfc_src + real(wp), dimension(ncol, nlay), intent(in) :: lay_source, & ! Planck source at layer center + tau, & ! Optical depth (tau) + gamma1, gamma2,& ! Coupling coefficients + rdif, tdif ! Layer reflectance and transmittance + real(wp), dimension(ncol, nlay+1), target, & + intent(in) :: lev_source ! Planck source at layer edges + real(wp), dimension(ncol, nlay), intent(out) :: source_dn, source_up + real(wp), dimension(ncol ), intent(out) :: source_sfc ! Source function for upward radation at surface + + integer :: icol, ilay + real(wp) :: Z, Zup_top, Zup_bottom, Zdn_top, Zdn_bottom + real(wp), dimension(:), pointer :: lev_source_bot, lev_source_top + ! --------------------------------------------------------------- + do ilay = 1, nlay + if(top_at_1) then + lev_source_top => lev_source(:,ilay) + lev_source_bot => lev_source(:,ilay+1) + else + lev_source_top => lev_source(:,ilay+1) + lev_source_bot => lev_source(:,ilay) + end if + do icol = 1, ncol + if (tau(icol,ilay) > 1.0e-8_wp) then + ! + ! Toon et al. (JGR 1989) Eqs 26-27 + ! + Z = (lev_source_bot(icol)-lev_source_top(icol)) / (tau(icol,ilay)*(gamma1(icol,ilay)+gamma2(icol,ilay))) + Zup_top = Z + lev_source_top(icol) + Zup_bottom = Z + lev_source_bot(icol) + Zdn_top = -Z + lev_source_top(icol) + Zdn_bottom = -Z + lev_source_bot(icol) + source_up(icol,ilay) = pi * (Zup_top - rdif(icol,ilay) * Zdn_top - tdif(icol,ilay) * Zup_bottom) + source_dn(icol,ilay) = pi * (Zdn_bottom - rdif(icol,ilay) * Zup_bottom - tdif(icol,ilay) * Zdn_top) + else + source_up(icol,ilay) = 0._wp + source_dn(icol,ilay) = 0._wp + end if + end do + end do + do icol = 1, ncol + source_sfc(icol) = pi * sfc_emis(icol) * sfc_src(icol) + end do + end subroutine lw_source_2str + ! ------------------------------------------------------------------------------------------------- + ! + ! Lower-level shortwave kernels + ! + ! ------------------------------------------------------------------------------------------------- + ! + ! Two-stream solutions to diffuse reflectance and transmittance for a layer + ! with optical depth tau, single scattering albedo w0, and asymmetery parameter g. + ! Direct reflectance and transmittance used to compute direct beam source for diffuse radiation + ! in layers and at surface; report direct beam as a byproduct + ! Computing the direct-beam source for diffuse radiation at the same time as R and T for + ! direct radiation reduces memory traffic and use. + ! + ! Equations are developed in Meador and Weaver, 1980, + ! doi:10.1175/1520-0469(1980)037<0630:TSATRT>2.0.CO;2 + ! + ! ------------------------------------------------------------------------------------------------- + pure subroutine sw_dif_and_source(ncol, nlay, top_at_1, mu0, sfc_albedo, & + tau, w0, g, & + Rdif, Tdif, source_dn, source_up, source_sfc, flux_dn_dir) bind (C, name="rte_sw_source_dir") + integer, intent(in ) :: ncol, nlay + logical(wl), intent(in ) :: top_at_1 + real(wp), dimension(ncol ), intent(in ) :: sfc_albedo ! surface albedo for direct radiation + real(wp), dimension(ncol,nlay ), intent(in ) :: tau, w0, g, mu0 + real(wp), dimension(ncol,nlay ), intent( out) :: Rdif, Tdif, source_dn, source_up + real(wp), dimension(ncol ), intent( out) :: source_sfc ! Source function for upward radation at surface + real(wp), dimension(ncol,nlay+1), target, & + intent(inout) :: flux_dn_dir ! Direct beam flux + + ! ----------------------- + integer :: i, j + + ! Variables used in Meador and Weaver + real(wp) :: gamma1, gamma2, gamma3, gamma4, alpha1, alpha2 + + + ! Ancillary variables + real(wp), parameter :: min_k = 1.e4_wp * epsilon(1._wp) ! Suggestion from Chiel van Heerwaarden + real(wp), parameter :: min_mu0 = sqrt(epsilon(1._wp)) + real(wp) :: k, exp_minusktau, k_mu, k_gamma3, k_gamma4 + real(wp) :: RT_term, exp_minus2ktau + real(wp) :: Rdir, Tdir, Tnoscat + real(wp), pointer, dimension(:) :: dir_flux_inc, dir_flux_trans + integer :: lay_index + real(wp) :: tau_s, w0_s, g_s, mu0_s + ! --------------------------------- + + do j = 1, nlay + if(top_at_1) then + lay_index = j + dir_flux_inc => flux_dn_dir(:,lay_index ) + dir_flux_trans => flux_dn_dir(:,lay_index+1) + else + lay_index = nlay-j+1 + dir_flux_inc => flux_dn_dir(:,lay_index+1) + dir_flux_trans => flux_dn_dir(:,lay_index ) + end if + + !$OMP SIMD + do i = 1, ncol + ! + ! Scalars + ! + tau_s = tau(i, lay_index) + w0_s = w0 (i, lay_index) + g_s = g (i, lay_index) + ! + ! Zdunkowski Practical Improved Flux Method "PIFM" + ! (Zdunkowski et al., 1980; Contributions to Atmospheric Physics 53, 147-66) + ! + gamma1 = (8._wp - w0_s * (5._wp + 3._wp * g_s)) * .25_wp + gamma2 = 3._wp *(w0_s * (1._wp - g_s)) * .25_wp + ! + ! Direct reflect and transmission + ! + ! Eq 18; k = SQRT(gamma1**2 - gamma2**2), limited below to avoid div by 0. + ! k = 0 for isotropic, conservative scattering; this lower limit on k + ! gives relative error with respect to conservative solution + ! of < 0.1% in Rdif down to tau = 10^-9 + k = sqrt(max((gamma1 - gamma2) * (gamma1 + gamma2), min_k)) + exp_minusktau = exp(-tau_s*k) + exp_minus2ktau = exp_minusktau * exp_minusktau + + ! Refactored to avoid rounding errors when k, gamma1 are of very different magnitudes + RT_term = 1._wp / (k * (1._wp + exp_minus2ktau) + & + gamma1 * (1._wp - exp_minus2ktau) ) + ! Equation 25 + Rdif(i,lay_index) = RT_term * gamma2 * (1._wp - exp_minus2ktau) + + ! Equation 26 + Tdif(i,lay_index) = RT_term * 2._wp * k * exp_minusktau + + ! + ! On a round earth, where mu0 can increase with depth in the atmosphere, + ! levels with mu0 <= 0 have no direct beam and hence no source for diffuse light + ! Compute transmission and reflection using a nominal value but mask out later + ! + mu0_s = max(min_mu0, mu0(i, lay_index)) + k_mu = k * mu0_s ! - ! Scalars - ! - tau_s = tau(i, lay_index) - w0_s = w0 (i, lay_index) - g_s = g (i, lay_index) - mu0_s = mu0(i, lay_index) + ! Equation 14, multiplying top and bottom by exp(-k*tau) + ! and rearranging to avoid div by 0. + ! + RT_term = w0_s * RT_term/merge(1._wp - k_mu*k_mu, & + epsilon(1._wp), & + abs(1._wp - k_mu*k_mu) >= epsilon(1._wp)) ! ! Zdunkowski Practical Improved Flux Method "PIFM" ! (Zdunkowski et al., 1980; Contributions to Atmospheric Physics 53, 147-66) ! - gamma1 = (8._wp - w0_s * (5._wp + 3._wp * g_s)) * .25_wp - gamma2 = 3._wp *(w0_s * (1._wp - g_s)) * .25_wp - ! - ! Direct reflect and transmission - ! - ! Eq 18; k = SQRT(gamma1**2 - gamma2**2), limited below to avoid div by 0. - ! k = 0 for isotropic, conservative scattering; this lower limit on k - ! gives relative error with respect to conservative solution - ! of < 0.1% in Rdif down to tau = 10^-9 - k = sqrt(max((gamma1 - gamma2) * (gamma1 + gamma2), min_k)) - exp_minusktau = exp(-tau_s*k) - exp_minus2ktau = exp_minusktau * exp_minusktau - - ! Refactored to avoid rounding errors when k, gamma1 are of very different magnitudes - RT_term = 1._wp / (k * (1._wp + exp_minus2ktau) + & - gamma1 * (1._wp - exp_minus2ktau) ) - ! Equation 25 - Rdif(i,lay_index) = RT_term * gamma2 * (1._wp - exp_minus2ktau) - - ! Equation 26 - Tdif(i,lay_index) = RT_term * 2._wp * k * exp_minusktau - - ! - ! On a round earth, where mu0 can increase with depth in the atmosphere, - ! levels with mu0 <= 0 have no direct beam and hence no source for diffuse light - ! - if(mu0_s > 0._wp) then - k_mu = k * mu0_s - ! - ! Equation 14, multiplying top and bottom by exp(-k*tau) - ! and rearranging to avoid div by 0. - ! - RT_term = w0_s * RT_term/merge(1._wp - k_mu*k_mu, & - epsilon(1._wp), & - abs(1._wp - k_mu*k_mu) >= epsilon(1._wp)) - ! - ! Zdunkowski Practical Improved Flux Method "PIFM" - ! (Zdunkowski et al., 1980; Contributions to Atmospheric Physics 53, 147-66) - ! - gamma3 = (2._wp - 3._wp * mu0_s * g_s ) * .25_wp - gamma4 = 1._wp - gamma3 - alpha1 = gamma1 * gamma4 + gamma2 * gamma3 ! Eq. 16 - alpha2 = gamma1 * gamma3 + gamma2 * gamma4 ! Eq. 17 - - ! - ! Transmittance of direct, unscattered beam. - ! - k_gamma3 = k * gamma3 - k_gamma4 = k * gamma4 - Tnoscat = exp(-tau_s/mu0_s) - Rdir = RT_term * & - ((1._wp - k_mu) * (alpha2 + k_gamma3) - & - (1._wp + k_mu) * (alpha2 - k_gamma3) * exp_minus2ktau - & - 2.0_wp * (k_gamma3 - alpha2 * k_mu) * exp_minusktau * Tnoscat) - ! - ! Equation 15, multiplying top and bottom by exp(-k*tau), - ! multiplying through by exp(-tau/mu0) to - ! prefer underflow to overflow - ! Omitting direct transmittance - ! - Tdir = -RT_term * & - ((1._wp + k_mu) * (alpha1 + k_gamma4) * Tnoscat - & - (1._wp - k_mu) * (alpha1 - k_gamma4) * exp_minus2ktau * Tnoscat - & - 2.0_wp * (k_gamma4 + alpha1 * k_mu) * exp_minusktau) - ! Final check that energy is not spuriously created, by recognizing that - ! the beam can either be reflected, penetrate unscattered to the base of a layer, - ! or penetrate through but be scattered on the way - the rest is absorbed - ! Makes the equations safer in single precision. Credit: Robin Hogan, Peter Ukkonen - Rdir = max(0.0_wp, min(Rdir, (1.0_wp - Tnoscat ) )) - Tdir = max(0.0_wp, min(Tdir, (1.0_wp - Tnoscat - Rdir) )) - - source_up(i,lay_index) = Rdir * dir_flux_inc(i) - source_dn(i,lay_index) = Tdir * dir_flux_inc(i) - dir_flux_trans(i) = Tnoscat * dir_flux_inc(i) - else - source_up(i,lay_index) = 0._wp - source_dn(i,lay_index) = 0._wp - dir_flux_trans(i) = 0._wp - end if - end do - end do - source_sfc(:) = dir_flux_trans(:)*sfc_albedo(:) - - end subroutine sw_dif_and_source -! --------------------------------------------------------------- -! -! Transport of diffuse radiation through a vertically layered atmosphere. -! Equations are after Shonk and Hogan 2008, doi:10.1175/2007JCLI1940.1 (SH08) -! This routine is shared by longwave and shortwave -! -! ------------------------------------------------------------------------------------------------- -subroutine adding(ncol, nlay, top_at_1, & - albedo_sfc, & - rdif, tdif, & - src_dn, src_up, src_sfc, & - flux_up, flux_dn) - integer, intent(in ) :: ncol, nlay - logical(wl), intent(in ) :: top_at_1 - real(wp), dimension(ncol ), intent(in ) :: albedo_sfc - real(wp), dimension(ncol,nlay ), intent(in ) :: rdif, tdif - real(wp), dimension(ncol,nlay ), intent(in ) :: src_dn, src_up - real(wp), dimension(ncol ), intent(in ) :: src_sfc - real(wp), dimension(ncol,nlay+1), intent( out) :: flux_up - ! intent(inout) because top layer includes incident flux - real(wp), dimension(ncol,nlay+1), intent(inout) :: flux_dn - ! ------------------ - integer :: ilev - real(wp), dimension(ncol,nlay+1) :: albedo, & ! reflectivity to diffuse radiation below this level - ! alpha in SH08 - src ! source of diffuse upwelling radiation from emission or - ! scattering of direct beam - ! G in SH08 - real(wp), dimension(ncol,nlay ) :: denom ! beta in SH08 - ! ------------------ - ! - ! Indexing into arrays for upward and downward propagation depends on the vertical - ! orientation of the arrays (whether the domain top is at the first or last index) - ! We write the loops out explicitly so compilers will have no trouble optimizing them. - ! - if(top_at_1) then - ilev = nlay + 1 - ! Albedo of lowest level is the surface albedo... - albedo(:,ilev) = albedo_sfc(:) - ! ... and source of diffuse radiation is surface emission - src(:,ilev) = src_sfc(:) - - ! - ! From bottom to top of atmosphere -- - ! compute albedo and source of upward radiation - ! - do ilev = nlay, 1, -1 - denom(:, ilev) = 1._wp/(1._wp - rdif(:,ilev)*albedo(:,ilev+1)) ! Eq 10 - albedo(:,ilev) = rdif(:,ilev) + & - tdif(:,ilev)*tdif(:,ilev) * albedo(:,ilev+1) * denom(:,ilev) ! Equation 9 - ! - ! Equation 11 -- source is emitted upward radiation at top of layer plus - ! radiation emitted at bottom of layer, - ! transmitted through the layer and reflected from layers below (tdiff*src*albedo) - ! - src(:,ilev) = src_up(:, ilev) + & - tdif(:,ilev) * denom(:,ilev) * & - (src(:,ilev+1) + albedo(:,ilev+1)*src_dn(:,ilev)) - end do - - ! Eq 12, at the top of the domain upwelling diffuse is due to ... - ilev = 1 - flux_up(:,ilev) = flux_dn(:,ilev) * albedo(:,ilev) + & ! ... reflection of incident diffuse and - src(:,ilev) ! emission from below - - ! - ! From the top of the atmosphere downward -- compute fluxes - ! - do ilev = 2, nlay+1 - flux_dn(:,ilev) = (tdif(:,ilev-1)*flux_dn(:,ilev-1) + & ! Equation 13 - rdif(:,ilev-1)*src(:,ilev) + & - src_dn(:,ilev-1)) * denom(:,ilev-1) - flux_up(:,ilev) = flux_dn(:,ilev) * albedo(:,ilev) + & ! Equation 12 - src(:,ilev) - end do - else - ilev = 1 - ! Albedo of lowest level is the surface albedo... - albedo(:,ilev) = albedo_sfc(:) - ! ... and source of diffuse radiation is surface emission - src(:,ilev) = src_sfc(:) - - ! - ! From bottom to top of atmosphere -- - ! compute albedo and source of upward radiation - ! - do ilev = 1, nlay - denom(:, ilev ) = 1._wp/(1._wp - rdif(:,ilev)*albedo(:,ilev)) ! Eq 10 - albedo(:,ilev+1) = rdif(:,ilev) + & - tdif(:,ilev)*tdif(:,ilev) * albedo(:,ilev) * denom(:,ilev) ! Equation 9 - ! - ! Equation 11 -- source is emitted upward radiation at top of layer plus - ! radiation emitted at bottom of layer, - ! transmitted through the layer and reflected from layers below (tdiff*src*albedo) - ! - src(:,ilev+1) = src_up(:, ilev) + & - tdif(:,ilev) * denom(:,ilev) * & - (src(:,ilev) + albedo(:,ilev)*src_dn(:,ilev)) - end do - - ! Eq 12, at the top of the domain upwelling diffuse is due to ... - ilev = nlay+1 - flux_up(:,ilev) = flux_dn(:,ilev) * albedo(:,ilev) + & ! ... reflection of incident diffuse and - src(:,ilev) ! scattering by the direct beam below - - ! - ! From the top of the atmosphere downward -- compute fluxes - ! - do ilev = nlay, 1, -1 - flux_dn(:,ilev) = (tdif(:,ilev)*flux_dn(:,ilev+1) + & ! Equation 13 - rdif(:,ilev)*src(:,ilev) + & - src_dn(:, ilev)) * denom(:,ilev) - flux_up(:,ilev) = flux_dn(:,ilev) * albedo(:,ilev) + & ! Equation 12 - src(:,ilev) - - end do - end if -end subroutine adding -end module mo_rte_solver_kernels + gamma3 = (2._wp - 3._wp * mu0_s * g_s ) * .25_wp + gamma4 = 1._wp - gamma3 + alpha1 = gamma1 * gamma4 + gamma2 * gamma3 ! Eq. 16 + alpha2 = gamma1 * gamma3 + gamma2 * gamma4 ! Eq. 17 + + ! + ! Transmittance of direct, unscattered beam. + ! + k_gamma3 = k * gamma3 + k_gamma4 = k * gamma4 + Tnoscat = exp(-tau_s/mu0_s) + Rdir = RT_term * & + ((1._wp - k_mu) * (alpha2 + k_gamma3) - & + (1._wp + k_mu) * (alpha2 - k_gamma3) * exp_minus2ktau - & + 2.0_wp * (k_gamma3 - alpha2 * k_mu) * exp_minusktau * Tnoscat) + ! + ! Equation 15, multiplying top and bottom by exp(-k*tau), + ! multiplying through by exp(-tau/mu0) to + ! prefer underflow to overflow + ! Omitting direct transmittance + ! + Tdir = -RT_term * & + ((1._wp + k_mu) * (alpha1 + k_gamma4) * Tnoscat - & + (1._wp - k_mu) * (alpha1 - k_gamma4) * exp_minus2ktau * Tnoscat - & + 2.0_wp * (k_gamma4 + alpha1 * k_mu) * exp_minusktau) + ! Final check that energy is not spuriously created, by recognizing that + ! the beam can either be reflected, penetrate unscattered to the base of a layer, + ! or penetrate through but be scattered on the way - the rest is absorbed + ! Makes the equations safer in single precision. Credit: Robin Hogan, Peter Ukkonen + Rdir = max(0.0_wp, min(Rdir, (1.0_wp - Tnoscat ) )) + Tdir = max(0.0_wp, min(Tdir, (1.0_wp - Tnoscat - Rdir) )) + + source_up(i,lay_index) = Rdir * dir_flux_inc(i) + source_dn(i,lay_index) = Tdir * dir_flux_inc(i) + dir_flux_trans(i) = Tnoscat * dir_flux_inc(i) + end do + end do + ! + ! T and R for the direct beam are computed using nominal values even when the + ! sun is below the horizon (mu0 < 0); set those values back to zero + ! This won't be efficient if many nighttime columns are passed + ! + source_sfc(:) = merge(dir_flux_trans(:)*sfc_albedo(:), & + 0._wp, mu0(:,lay_index) > 0._wp) + where(mu0(:,:) <= 0._wp) + source_up(:,:) = 0._wp + source_dn(:,:) = 0._wp + end where + + end subroutine sw_dif_and_source +! --------------------------------------------------------------- +! +! Transport of diffuse radiation through a vertically layered atmosphere. +! Equations are after Shonk and Hogan 2008, doi:10.1175/2007JCLI1940.1 (SH08) +! This routine is shared by longwave and shortwave +! +! ------------------------------------------------------------------------------------------------- +subroutine adding(ncol, nlay, top_at_1, & + albedo_sfc, & + rdif, tdif, & + src_dn, src_up, src_sfc, & + flux_up, flux_dn) + integer, intent(in ) :: ncol, nlay + logical(wl), intent(in ) :: top_at_1 + real(wp), dimension(ncol ), intent(in ) :: albedo_sfc + real(wp), dimension(ncol,nlay ), intent(in ) :: rdif, tdif + real(wp), dimension(ncol,nlay ), intent(in ) :: src_dn, src_up + real(wp), dimension(ncol ), intent(in ) :: src_sfc + real(wp), dimension(ncol,nlay+1), intent( out) :: flux_up + ! intent(inout) because top layer includes incident flux + real(wp), dimension(ncol,nlay+1), intent(inout) :: flux_dn + ! ------------------ + integer :: ilev + real(wp), dimension(ncol,nlay+1) :: albedo, & ! reflectivity to diffuse radiation below this level + ! alpha in SH08 + src ! source of diffuse upwelling radiation from emission or + ! scattering of direct beam + ! G in SH08 + real(wp), dimension(ncol,nlay ) :: denom ! beta in SH08 + ! ------------------ + ! + ! Indexing into arrays for upward and downward propagation depends on the vertical + ! orientation of the arrays (whether the domain top is at the first or last index) + ! We write the loops out explicitly so compilers will have no trouble optimizing them. + ! + if(top_at_1) then + ilev = nlay + 1 + ! Albedo of lowest level is the surface albedo... + albedo(:,ilev) = albedo_sfc(:) + ! ... and source of diffuse radiation is surface emission + src(:,ilev) = src_sfc(:) + + ! + ! From bottom to top of atmosphere -- + ! compute albedo and source of upward radiation + ! + do ilev = nlay, 1, -1 + denom(:, ilev) = 1._wp/(1._wp - rdif(:,ilev)*albedo(:,ilev+1)) ! Eq 10 + albedo(:,ilev) = rdif(:,ilev) + & + tdif(:,ilev)*tdif(:,ilev) * albedo(:,ilev+1) * denom(:,ilev) ! Equation 9 + ! + ! Equation 11 -- source is emitted upward radiation at top of layer plus + ! radiation emitted at bottom of layer, + ! transmitted through the layer and reflected from layers below (tdiff*src*albedo) + ! + src(:,ilev) = src_up(:, ilev) + & + tdif(:,ilev) * denom(:,ilev) * & + (src(:,ilev+1) + albedo(:,ilev+1)*src_dn(:,ilev)) + end do + + ! Eq 12, at the top of the domain upwelling diffuse is due to ... + ilev = 1 + flux_up(:,ilev) = flux_dn(:,ilev) * albedo(:,ilev) + & ! ... reflection of incident diffuse and + src(:,ilev) ! emission from below + + ! + ! From the top of the atmosphere downward -- compute fluxes + ! + do ilev = 2, nlay+1 + flux_dn(:,ilev) = (tdif(:,ilev-1)*flux_dn(:,ilev-1) + & ! Equation 13 + rdif(:,ilev-1)*src(:,ilev) + & + src_dn(:,ilev-1)) * denom(:,ilev-1) + flux_up(:,ilev) = flux_dn(:,ilev) * albedo(:,ilev) + & ! Equation 12 + src(:,ilev) + end do + else + ilev = 1 + ! Albedo of lowest level is the surface albedo... + albedo(:,ilev) = albedo_sfc(:) + ! ... and source of diffuse radiation is surface emission + src(:,ilev) = src_sfc(:) + + ! + ! From bottom to top of atmosphere -- + ! compute albedo and source of upward radiation + ! + do ilev = 1, nlay + denom(:, ilev ) = 1._wp/(1._wp - rdif(:,ilev)*albedo(:,ilev)) ! Eq 10 + albedo(:,ilev+1) = rdif(:,ilev) + & + tdif(:,ilev)*tdif(:,ilev) * albedo(:,ilev) * denom(:,ilev) ! Equation 9 + ! + ! Equation 11 -- source is emitted upward radiation at top of layer plus + ! radiation emitted at bottom of layer, + ! transmitted through the layer and reflected from layers below (tdiff*src*albedo) + ! + src(:,ilev+1) = src_up(:, ilev) + & + tdif(:,ilev) * denom(:,ilev) * & + (src(:,ilev) + albedo(:,ilev)*src_dn(:,ilev)) + end do + + ! Eq 12, at the top of the domain upwelling diffuse is due to ... + ilev = nlay+1 + flux_up(:,ilev) = flux_dn(:,ilev) * albedo(:,ilev) + & ! ... reflection of incident diffuse and + src(:,ilev) ! scattering by the direct beam below + + ! + ! From the top of the atmosphere downward -- compute fluxes + ! + do ilev = nlay, 1, -1 + flux_dn(:,ilev) = (tdif(:,ilev)*flux_dn(:,ilev+1) + & ! Equation 13 + rdif(:,ilev)*src(:,ilev) + & + src_dn(:, ilev)) * denom(:,ilev) + flux_up(:,ilev) = flux_dn(:,ilev) * albedo(:,ilev) + & ! Equation 12 + src(:,ilev) + + end do + end if +end subroutine adding +end module mo_rte_solver_kernels
    diff --git a/reference/rte-kernels/sourcefile/mo_rte_solver_kernels.f90~2.html b/reference/rte-kernels/sourcefile/mo_rte_solver_kernels.f90~2.html new file mode 100644 index 000000000..a58c99d24 --- /dev/null +++ b/reference/rte-kernels/sourcefile/mo_rte_solver_kernels.f90~2.html @@ -0,0 +1,409 @@ + + + + + + + + + + + mo_rte_solver_kernels.F90 – RTE kernels + + + + + + + + + + + + + + + + + + + + +
    +
    +

    mo_rte_solver_kernels.F90 + Source File +

    +
    +
    +
    + +
      +
    1. mo_rte_solver_kernels.F90
      2. +
    +
    +
    +
    + + +
    +
    + +
    + +
    + +
    +

    Contents

    + +
    +

    Modules

    + +
    +
    +

    Source Code

    +
    + mo_rte_solver_kernels.F90 +
    +
    + +
    +
    + +
    +

    Source Code

    + 
    ! This code is part of Radiative Transfer for Energetics (RTE)
+!
+! Contacts: Robert Pincus and Eli Mlawer
+! email:  rrtmgp@aer.com
+!
+! Copyright 2015-,  Atmospheric and Environmental Research,
+! Regents of the University of Colorado, Trustees of Columbia University.  All right reserved.
+!
+! Use and duplication is permitted under the terms of the
+!    BSD 3-clause license, see http://opensource.org/licenses/BSD-3-Clause
+! -------------------------------------------------------------------------------------------------
+!
+!>## Numeric calculations for radiative transfer solvers
+!>  - Emission/absorption (no-scattering) calculations
+!>  - solver for multi-angle Gaussian quadrature
+!>  - Extinction-only calculation (direct solar beam)
+!>  - Two-stream calculations:
+!>    solvers for LW and SW with different boundary conditions and source functions
+!
+! -------------------------------------------------------------------------------------------------
+module mo_rte_solver_kernels
+  use,  intrinsic :: iso_c_binding
+  use mo_rte_kind,      only: wp, wl
+  implicit none
+  private
+
+  public :: lw_solver_noscat, lw_solver_2stream, &
+            sw_solver_noscat, sw_solver_2stream
+  ! -------------------------------------------------------------------------------------------------
+  !
+  ! Top-level longwave kernels
+  !
+  ! -------------------------------------------------------------------------------------------------
+  !
+  !> LW transport, no scattering, multi-angle quadrature
+  !>   Users provide a set of weights and quadrature angles
+  !>   Routine sums over single-angle solutions for each sets of angles/weights
+  !
+  ! ---------------------------------------------------------------
+  interface
+    subroutine lw_solver_noscat(ncol, nlay, ngpt, top_at_1, &
+                                nmus, Ds, weights,          &
+                                tau,                        &
+                                lay_source, lev_source,     &
+                                sfc_emis, sfc_src,          &
+                                inc_flux,                   &
+                                flux_up, flux_dn,           &
+                                do_broadband, broadband_up, broadband_dn,   &
+                                do_Jacobians, sfc_srcJac, flux_upJac,       &
+                                do_rescaling, ssa, g) bind(C, name="rte_lw_solver_noscat")
+      use mo_rte_kind,      only: wp, wl
+      integer,                               intent(in   ) :: ncol, nlay, ngpt
+                                                              !! Number of columns, layers, g-points
+      logical(wl),                           intent(in   ) :: top_at_1
+                                                              !! ilay = 1 is the top of the atmosphere?
+      integer,                               intent(in   ) :: nmus
+                                                              !! number of quadrature angles
+      real(wp), dimension (ncol,      ngpt, &
+                                      nmus), intent(in   ) :: Ds
+                                                              !! quadrature secants
+      real(wp), dimension(nmus),             intent(in   ) :: weights
+                                                              !! quadrature weights
+      real(wp), dimension(ncol,nlay,  ngpt), intent(in   ) :: tau
+                                                              !! Absorption optical thickness []
+      real(wp), dimension(ncol,nlay,  ngpt), intent(in   ) :: lay_source
+                                                              !! Planck source at layer average temperature [W/m2]
+      real(wp), dimension(ncol,nlay+1,ngpt), intent(in   ) :: lev_source
+                                                              !! Planck source at layer edge for radiation [W/m2]
+      real(wp), dimension(ncol,       ngpt), intent(in   ) :: sfc_emis
+                                                              !! Surface emissivity      []
+      real(wp), dimension(ncol,       ngpt), intent(in   ) :: sfc_src
+                                                              !! Surface source function [W/m2]
+      real(wp), dimension(ncol,       ngpt), intent(in   ) :: inc_flux
+                                                              !! Incident diffuse flux, probably 0 [W/m2]
+      real(wp), dimension(ncol,nlay+1,ngpt), target, &
+                                             intent(  out) :: flux_up, flux_dn
+                                                              !! Fluxes [W/m2]
+      !
+      ! Optional variables - arrays aren't referenced if corresponding logical  == False
+      !
+      logical(wl),                           intent(in   ) :: do_broadband
+      real(wp), dimension(ncol,nlay+1     ), target, &
+                                             intent(  out) :: broadband_up, broadband_dn
+                                                              !! Spectrally-integrated fluxes [W/m2]
+      logical(wl),                           intent(in   ) :: do_Jacobians
+                                                              !! compute Jacobian with respect to surface temeprature?
+      real(wp), dimension(ncol       ,ngpt), intent(in   ) :: sfc_srcJac
+                                                              !! surface temperature Jacobian of surface source function [W/m2/K]
+      real(wp), dimension(ncol,nlay+1     ), target, &
+                                             intent(  out) :: flux_upJac
+                                                              !! surface temperature Jacobian of Radiances [W/m2-str / K]
+      logical(wl),                           intent(in   ) :: do_rescaling
+                                                              !! Approximate treatment of scattering (10.1175/JAS-D-18-0014.1)
+      real(wp), dimension(ncol,nlay  ,ngpt), intent(in   ) :: ssa, g
+                                                              !! single-scattering albedo, asymmetry parameter
+    end subroutine lw_solver_noscat
+  end interface
+  ! -------------------------------------------------------------------------------------------------
+  !
+  !> Longwave two-stream calculation:
+  !>   - combine RRTMGP-specific sources at levels
+  !>   - compute layer reflectance, transmittance
+  !>   - compute total source function at levels using linear-in-tau
+  !>   - transport
+  !
+  ! -------------------------------------------------------------------------------------------------
+  interface
+    subroutine lw_solver_2stream (ncol, nlay, ngpt, top_at_1, &
+                                  tau, ssa, g,                &
+                                  lay_source, lev_source, sfc_emis, sfc_src, &
+                                  inc_flux,                   &
+                                  flux_up, flux_dn) bind(C, name="rte_lw_solver_2stream")
+      use mo_rte_kind,      only: wp, wl
+      integer,                               intent(in   ) :: ncol, nlay, ngpt
+                                                              !! Number of columns, layers, g-points
+      logical(wl),                           intent(in   ) :: top_at_1
+                                                              !! ilay = 1 is the top of the atmosphere?
+      real(wp), dimension(ncol,nlay,  ngpt), intent(in   ) :: tau, ssa, g
+                                                              !! Optical thickness, single-scattering albedo, asymmetry parameter []
+      real(wp), dimension(ncol,nlay,  ngpt),   intent(in   ) :: lay_source
+                                                              !! Planck source at layer average temperature [W/m2]
+      real(wp), dimension(ncol,nlay+1,ngpt), intent(in   ) :: lev_source
+                                                              !! Planck source at layer edge for radiation [W/m2]
+      real(wp), dimension(ncol,       ngpt), intent(in   ) :: sfc_emis
+                                                              !! Surface emissivity      []
+      real(wp), dimension(ncol,       ngpt), intent(in   ) :: sfc_src
+                                                              !! Surface source function [W/m2]
+      real(wp), dimension(ncol,       ngpt), intent(in   ) :: inc_flux
+                                                              !! Incident diffuse flux, probably 0 [W/m2]
+      real(wp), dimension(ncol,nlay+1,ngpt), intent(  out) :: flux_up, flux_dn
+                                                              !! Fluxes [W/m2]
+    end subroutine lw_solver_2stream
+  end interface
+  ! -------------------------------------------------------------------------------------------------
+  !
+  !   Top-level shortwave kernels
+  !
+  ! -------------------------------------------------------------------------------------------------
+  !
+  !  !> Extinction-only shortwave solver i.e. solar direct beam
+  !
+  ! -------------------------------------------------------------------------------------------------
+  interface
+    pure subroutine sw_solver_noscat(ncol, nlay, ngpt, top_at_1, &
+                                     tau, mu0, inc_flux_dir, flux_dir) bind(C, name="rte_sw_solver_noscat")
+      use mo_rte_kind,      only: wp, wl
+      integer,                               intent(in ) :: ncol, nlay, ngpt ! Number of columns, layers, g-points
+                                                            !! Number of columns, layers, g-points
+      logical(wl),                           intent(in ) :: top_at_1
+                                                            !! ilay = 1 is the top of the atmosphere?
+      real(wp), dimension(ncol,nlay,  ngpt), intent(in ) :: tau
+                                                            !! Absorption optical thickness []
+      real(wp), dimension(ncol,nlay       ), intent(in ) :: mu0
+                                                            !! cosine of solar zenith angle
+      real(wp), dimension(ncol,       ngpt), intent(in ) :: inc_flux_dir
+                                                            !! Direct beam incident flux [W/m2]
+      real(wp), dimension(ncol,nlay+1,ngpt), intent(out) :: flux_dir
+    end subroutine sw_solver_noscat
+  end interface
+  ! -------------------------------------------------------------------------------------------------
+  !
+  !> Shortwave two-stream calculation:
+  !>   compute layer reflectance, transmittance
+  !>   compute solar source function for diffuse radiation
+  !>   transport
+  !
+  ! -------------------------------------------------------------------------------------------------
+  interface
+    subroutine sw_solver_2stream (ncol, nlay, ngpt, top_at_1,  &
+                                  tau, ssa, g, mu0,           &
+                                  sfc_alb_dir, sfc_alb_dif,   &
+                                              inc_flux_dir,   &
+                                  flux_up, flux_dn, flux_dir, &
+                                  has_dif_bc, inc_flux_dif,   &
+                                  do_broadband, broadband_up, &
+                                  broadband_dn, broadband_dir) bind(C, name="rte_sw_solver_2stream")
+      use mo_rte_kind,      only: wp, wl
+      integer,                               intent(in   ) :: ncol, nlay, ngpt
+                                                              !! Number of columns, layers, g-points
+      logical(wl),                           intent(in   ) :: top_at_1
+                                                              !! ilay = 1 is the top of the atmosphere?
+      real(wp), dimension(ncol,nlay,  ngpt), intent(in   ) :: tau, ssa, g
+                                                              !! Optical thickness, single-scattering albedo, asymmetry parameter []
+      real(wp), dimension(ncol,nlay       ), intent(in   ) :: mu0
+                                                              !! cosine of solar zenith angle
+      real(wp), dimension(ncol,       ngpt), intent(in   ) :: sfc_alb_dir, sfc_alb_dif
+                                                              !! Spectral surface albedo for direct and diffuse radiation
+      real(wp), dimension(ncol,       ngpt), intent(in   ) :: inc_flux_dir
+                                                              !! Direct beam incident flux
+      real(wp), dimension(ncol,nlay+1,ngpt), target, &
+                                             intent(  out) :: flux_up, flux_dn, flux_dir
+                                                              !! Fluxes [W/m2]
+      logical(wl),                           intent(in   ) :: has_dif_bc
+                                                              !! Is a boundary condition for diffuse flux supplied?
+      real(wp), dimension(ncol,       ngpt), intent(in   ) :: inc_flux_dif
+                                                              !! Boundary condition for diffuse flux [W/m2]
+      logical(wl),                           intent(in   ) :: do_broadband
+                                                              !! Provide broadband-integrated, not spectrally-resolved, fluxes?
+      real(wp), dimension(ncol,nlay+1     ), intent(  out) :: broadband_up, broadband_dn, broadband_dir
+    end subroutine sw_solver_2stream
+  end interface
+end module mo_rte_solver_kernels
+
    + +
    +
    +
    + +
    +
    +
    +
    +
    +

    RTE kernels was developed by The RTE+RRTTMGP consortium
    © 2024 Creative Commons License +

    +
    +
    +

    + Documentation generated by + FORD +

    +
    +
    +
    +
    +
    + + + + + + + + + + + + + + + + + + + \ No newline at end of file diff --git a/reference/rte-kernels/sourcefile/mo_rte_util_array.f90.html b/reference/rte-kernels/sourcefile/mo_rte_util_array.f90.html index f2bfe37dd..b1712a673 100644 --- a/reference/rte-kernels/sourcefile/mo_rte_util_array.f90.html +++ b/reference/rte-kernels/sourcefile/mo_rte_util_array.f90.html @@ -85,7 +85,7 @@

    mo_rte_util_array.F90
  • 53 statements + title=" 3.8% of total for source files.">53 statements
  • Source File
    • @@ -111,7 +111,7 @@

    Contents

    Modules

    @@ -211,7 +211,7 @@

    Contents

    Modules

    diff --git a/reference/rte-kernels/sourcefile/mo_rte_util_array.f90~2.html b/reference/rte-kernels/sourcefile/mo_rte_util_array.f90~2.html new file mode 100644 index 000000000..c18efe9b3 --- /dev/null +++ b/reference/rte-kernels/sourcefile/mo_rte_util_array.f90~2.html @@ -0,0 +1,254 @@ + + + + + + + + + + + mo_rte_util_array.F90 – RTE kernels + + + + + + + + + + + + + + + + + + + + +
    +
    +

    mo_rte_util_array.F90 + Source File +

    +
    +
    +
    + +
      +
    1. mo_rte_util_array.F90
      2. +
    +
    +
    +
    + + +
    +
    + +
    + +
    + +
    +

    Contents

    + +
    +

    Modules

    + +
    +
    +

    Source Code

    +
    + mo_rte_util_array.F90 +
    +
    + +
    +
    + +
    +

    Source Code

    + 
    ! This code is part of Radiative Transfer for Energetics (RTE)
+!
+! Contacts: Robert Pincus and Eli Mlawer
+! email:  rrtmgp@aer.com
+!
+! Copyright 2015-  Atmospheric and Environmental Research,
+!    Regents of the University of Colorado,
+!    Trustees of Columbia University in the City of New York
+! All right reserved.
+!
+! Use and duplication is permitted under the terms of the
+!    BSD 3-clause license, see http://opensource.org/licenses/BSD-3-Clause
+! -------------------------------------------------------------------------------------------------
+module mo_rte_util_array
+  use mo_rte_kind,      only: wp, wl
+  implicit none
+  public :: zero_array
+
+  !-------------------------------------------------------------------------------------------------
+  ! Initializing arrays to 0
+  !-------------------------------------------------------------------------------------------------
+  interface zero_array
+    subroutine zero_array_1D(ni, array) bind(C, name="zero_array_1D")
+      use mo_rte_kind,      only: wp, wl
+      integer,                 intent(in ) :: ni
+      real(wp), dimension(ni), intent(out) :: array
+    end subroutine zero_array_1D
+    ! ----------------------------------------------------------
+    subroutine zero_array_2D(ni, nj, array) bind(C, name="zero_array_2D")
+      use mo_rte_kind,      only: wp, wl
+      integer,                     intent(in ) :: ni, nj
+      real(wp), dimension(ni, nj), intent(out) :: array
+    end subroutine zero_array_2D
+    ! ----------------------------------------------------------
+    subroutine zero_array_3D(ni, nj, nk, array) bind(C, name="zero_array_3D")
+      use mo_rte_kind,      only: wp, wl
+      integer,                         intent(in ) :: ni, nj, nk
+      real(wp), dimension(ni, nj, nk), intent(out) :: array
+    end subroutine zero_array_3D
+    ! ----------------------------------------------------------
+    subroutine zero_array_4D(ni, nj, nk, nl, array) bind(C, name="zero_array_4D")
+    use mo_rte_kind,      only: wp, wl
+    integer,                             intent(in ) :: ni, nj, nk, nl
+      real(wp), dimension(ni, nj, nk, nl), intent(out) :: array
+    end subroutine zero_array_4D
+  end interface zero_array
+end module mo_rte_util_array
+
    + +
    +
    +
    + +
    +
    +
    +
    +
    +

    RTE kernels was developed by The RTE+RRTTMGP consortium
    © 2024 Creative Commons License +

    +
    +
    +

    + Documentation generated by + FORD +

    +
    +
    +
    +
    +
    + + + + + + + + + + + + + + + + + + + \ No newline at end of file diff --git a/reference/rte-kernels/src/mo_fluxes_broadband_kernels.F90 b/reference/rte-kernels/src/mo_fluxes_broadband_kernels.F90 index 8437dfbbd..d64c1fa29 100644 --- a/reference/rte-kernels/src/mo_fluxes_broadband_kernels.F90 +++ b/reference/rte-kernels/src/mo_fluxes_broadband_kernels.F90 @@ -20,111 +20,55 @@ module mo_fluxes_broadband_kernels private public :: sum_broadband, net_broadband - interface net_broadband - !! Interface for computing net flux - module procedure net_broadband_full, net_broadband_precalc - end interface net_broadband -contains ! ---------------------------------------------------------------------------- !> !> Spectral reduction over all points !> - subroutine sum_broadband(ncol, nlev, ngpt, spectral_flux, broadband_flux) bind(C, name="rte_sum_broadband") - integer, intent(in ) :: ncol, nlev, ngpt - !! Array sizes - real(wp), dimension(ncol, nlev, ngpt), intent(in ) :: spectral_flux - !! Spectrally-resolved flux - real(wp), dimension(ncol, nlev), intent(out) :: broadband_flux - !! Sum of spectrally-resolved flux over `ngpt` - - integer :: icol, ilev, igpt - real(wp) :: bb_flux_s ! local scalar version - - !$acc enter data copyin(spectral_flux) create(broadband_flux) - !$omp target enter data map(to:spectral_flux) map(alloc:broadband_flux) - !$acc parallel loop gang vector collapse(2) - !$omp target teams distribute parallel do simd collapse(2) - do ilev = 1, nlev - do icol = 1, ncol - - bb_flux_s = 0.0_wp - - do igpt = 1, ngpt - bb_flux_s = bb_flux_s + spectral_flux(icol, ilev, igpt) - end do - - broadband_flux(icol, ilev) = bb_flux_s - end do - end do - !$acc exit data delete(spectral_flux) copyout(broadband_flux) - !$omp target exit data map(release:spectral_flux) map(from:broadband_flux) - end subroutine sum_broadband + interface + subroutine sum_broadband(ncol, nlev, ngpt, spectral_flux, broadband_flux) bind(C, name="rte_sum_broadband") + use mo_rte_kind, only: wp + integer, intent(in ) :: ncol, nlev, ngpt + !! Array sizes + real(wp), dimension(ncol, nlev, ngpt), intent(in ) :: spectral_flux + !! Spectrally-resolved flux + real(wp), dimension(ncol, nlev), intent(out) :: broadband_flux + !! Sum of spectrally-resolved flux over `ngpt` + end subroutine sum_broadband + end interface ! ---------------------------------------------------------------------------- !> !> Spectral reduction over all points for net flux - !> - subroutine net_broadband_full(ncol, nlev, ngpt, spectral_flux_dn, spectral_flux_up, broadband_flux_net) & - bind(C, name="rte_net_broadband_full") - integer, intent(in ) :: ncol, nlev, ngpt - !! Array sizes - real(wp), dimension(ncol, nlev, ngpt), intent(in ) :: spectral_flux_dn, spectral_flux_up - !! Spectrally-resolved flux up and down - real(wp), dimension(ncol, nlev), intent(out) :: broadband_flux_net - !! Net (down minus up) summed over `ngpt` - - integer :: icol, ilev, igpt - real(wp) :: diff - - !$acc enter data copyin(spectral_flux_dn, spectral_flux_up) create(broadband_flux_net) - !$omp target enter data map(to:spectral_flux_dn, spectral_flux_up) map(alloc:broadband_flux_net) - !$acc parallel loop collapse(2) - !$omp target teams distribute parallel do simd collapse(2) - do ilev = 1, nlev - do icol = 1, ncol - diff = spectral_flux_dn(icol, ilev, 1 ) - spectral_flux_up(icol, ilev, 1) - broadband_flux_net(icol, ilev) = diff - end do - end do - !$acc parallel loop collapse(3) - !$omp target teams distribute parallel do simd collapse(3) - do igpt = 2, ngpt - do ilev = 1, nlev - do icol = 1, ncol - diff = spectral_flux_dn(icol, ilev, igpt) - spectral_flux_up(icol, ilev, igpt) - !$acc atomic update - !$omp atomic update - broadband_flux_net(icol, ilev) = broadband_flux_net(icol, ilev) + diff - end do - end do - end do - !$acc exit data delete(spectral_flux_dn, spectral_flux_up) copyout(broadband_flux_net) - !$omp target exit data map(release:spectral_flux_dn, spectral_flux_up) map(from:broadband_flux_net) - end subroutine net_broadband_full - ! ---------------------------------------------------------------------------- - !> - !> Net flux when bradband flux up and down are already available - !> - subroutine net_broadband_precalc(ncol, nlev, flux_dn, flux_up, broadband_flux_net) & - bind(C, name="rte_net_broadband_precalc") - integer, intent(in ) :: ncol, nlev - !! Array sizes - real(wp), dimension(ncol, nlev), intent(in ) :: flux_dn, flux_up - !! Broadband downward and upward fluxes - real(wp), dimension(ncol, nlev), intent(out) :: broadband_flux_net - !! Net (down minus up) - - integer :: icol, ilev - !$acc enter data copyin(flux_dn, flux_up) create(broadband_flux_net) - !$omp target enter data map(to:flux_dn, flux_up) map(alloc:broadband_flux_net) - !$acc parallel loop collapse(2) - !$omp target teams distribute parallel do simd collapse(2) - do ilev = 1, nlev - do icol = 1, ncol - broadband_flux_net(icol,ilev) = flux_dn(icol,ilev) - flux_up(icol,ilev) - end do - end do - !$acc exit data delete(flux_dn, flux_up) copyout(broadband_flux_net) - !$omp target exit data map(release:flux_dn, flux_up) map(from:broadband_flux_net) - end subroutine net_broadband_precalc + !> Overloaded - which routine is called depends on arguments + !> + interface net_broadband + ! ---------------------------------------------------------------------------- + !> + !> Net flux from g-point fluxes up and down + !> + subroutine net_broadband_full(ncol, nlev, ngpt, spectral_flux_dn, spectral_flux_up, broadband_flux_net) & + bind(C, name="rte_net_broadband_full") + use mo_rte_kind, only: wp + integer, intent(in ) :: ncol, nlev, ngpt + !! Array sizes + real(wp), dimension(ncol, nlev, ngpt), intent(in ) :: spectral_flux_dn, spectral_flux_up + !! Spectrally-resolved flux up and down + real(wp), dimension(ncol, nlev), intent(out) :: broadband_flux_net + !! Net (down minus up) summed over `ngpt` + end subroutine net_broadband_full + ! ---------------------------------------------------------------------------- + !> + !> Net flux when bradband flux up and down are already available + !> + subroutine net_broadband_precalc(ncol, nlev, flux_dn, flux_up, broadband_flux_net) & + bind(C, name="rte_net_broadband_precalc") + use mo_rte_kind, only: wp + integer, intent(in ) :: ncol, nlev + !! Array sizes + real(wp), dimension(ncol, nlev), intent(in ) :: flux_dn, flux_up + !! Broadband downward and upward fluxes + real(wp), dimension(ncol, nlev), intent(out) :: broadband_flux_net + !! Net (down minus up) + end subroutine net_broadband_precalc + end interface net_broadband ! ---------------------------------------------------------------------------- end module mo_fluxes_broadband_kernels diff --git a/reference/rte-kernels/src/mo_optical_props_kernels.F90 b/reference/rte-kernels/src/mo_optical_props_kernels.F90 index 9c971bd98..bb7e5116f 100644 --- a/reference/rte-kernels/src/mo_optical_props_kernels.F90 +++ b/reference/rte-kernels/src/mo_optical_props_kernels.F90 @@ -24,78 +24,37 @@ module mo_optical_props_kernels public - !> Delta-scale two-stream optical properties - interface delta_scale_2str_kernel - module procedure delta_scale_2str_f_k, delta_scale_2str_k - end interface - - !> Subsetting, meaning extracting some portion of the 3D domain - interface extract_subset - module procedure extract_subset_dim1_3d, extract_subset_dim2_4d - module procedure extract_subset_absorption_tau - end interface extract_subset - - real(wp), parameter, private :: eps = 3.0_wp*tiny(1.0_wp) -contains ! ------------------------------------------------------------------------------------------------- ! ! Delta-scaling is provided only for two-stream properties at present ! - ! ------------------------------------------------------------------------------------------------- - !> Delta-scale two-stream optical properties given user-provided value of \(f\) (forward scattering) - ! - pure subroutine delta_scale_2str_f_k(ncol, nlay, ngpt, tau, ssa, g, f) & - bind(C, name="rte_delta_scale_2str_f_k") - integer, intent(in ) :: ncol, nlay, ngpt - !! Array sizes - real(wp), dimension(ncol, nlay, ngpt), intent(inout) :: tau, ssa, g - !! Optical depth, single-scattering albedo, asymmetry parameter - real(wp), dimension(ncol, nlay, ngpt), intent(in ) :: f - !! User-provided forward-scattering fraction - - real(wp) :: wf - integer :: icol, ilay, igpt - - do igpt = 1, ngpt - do ilay = 1, nlay - do icol = 1, ncol - wf = ssa(icol,ilay,igpt) * f(icol,ilay,igpt) - tau(icol,ilay,igpt) = (1._wp - wf) * tau(icol,ilay,igpt) - ssa(icol,ilay,igpt) = (ssa(icol,ilay,igpt) - wf) / max(eps,(1.0_wp - wf)) - g (icol,ilay,igpt) = (g (icol,ilay,igpt) - f(icol,ilay,igpt)) / & - max(eps,(1._wp - f(icol,ilay,igpt))) - end do - end do - end do - - end subroutine delta_scale_2str_f_k - ! --------------------------------- - !> Delta-scale assuming forward-scatternig fraction is the square of the asymmetry parameter - !> i.e. \(f = g^2\) - ! - pure subroutine delta_scale_2str_k(ncol, nlay, ngpt, tau, ssa, g) & - bind(C, name="rte_delta_scale_2str_k") - integer, intent(in ) :: ncol, nlay, ngpt - !! Array sizes - real(wp), dimension(ncol, nlay, ngpt), intent(inout) :: tau, ssa, g - !! Optical depth, single-scattering albedo, asymmetry parameter - - real(wp) :: f, wf - integer :: icol, ilay, igpt - - do igpt = 1, ngpt - do ilay = 1, nlay - do icol = 1, ncol - f = g (icol,ilay,igpt) * g (icol,ilay,igpt) - wf = ssa(icol,ilay,igpt) * f - tau(icol,ilay,igpt) = (1._wp - wf) * tau(icol,ilay,igpt) - ssa(icol,ilay,igpt) = (ssa(icol,ilay,igpt) - wf) / max(eps,(1.0_wp - wf)) - g (icol,ilay,igpt) = (g (icol,ilay,igpt) - f) / max(eps,(1.0_wp - f)) - end do - end do - end do - - end subroutine delta_scale_2str_k + interface delta_scale_2str_kernel + ! ------------------------------------------------------------------------------------------------- + !> Delta-scale two-stream optical properties given user-provided value of \(f\) (forward scattering) + ! + pure subroutine delta_scale_2str_f_k(ncol, nlay, ngpt, tau, ssa, g, f) & + bind(C, name="rte_delta_scale_2str_f_k") + use mo_rte_kind, only: wp, wl + integer, intent(in ) :: ncol, nlay, ngpt + !! Array sizes + real(wp), dimension(ncol, nlay, ngpt), intent(inout) :: tau, ssa, g + !! Optical depth, single-scattering albedo, asymmetry parameter + real(wp), dimension(ncol, nlay, ngpt), intent(in ) :: f + !! User-provided forward-scattering fraction + end subroutine delta_scale_2str_f_k + ! --------------------------------- + !> Delta-scale assuming forward-scatternig fraction is the square of the asymmetry parameter + !> i.e. \(f = g^2\) + ! + pure subroutine delta_scale_2str_k(ncol, nlay, ngpt, tau, ssa, g) & + bind(C, name="rte_delta_scale_2str_k") + use mo_rte_kind, only: wp, wl + integer, intent(in ) :: ncol, nlay, ngpt + !! Array sizes + real(wp), dimension(ncol, nlay, ngpt), intent(inout) :: tau, ssa, g + !! Optical depth, single-scattering albedo, asymmetry parameter + end subroutine delta_scale_2str_k + end interface delta_scale_2str_kernel ! ------------------------------------------------------------------------------------------------- ! ! Addition of optical properties: the first set are incremented by the second set. @@ -113,249 +72,122 @@ end subroutine delta_scale_2str_k ! ! ------------------------------------------------------------------------------------------------- !> increase one absorption optical depth by a second value - pure subroutine increment_1scalar_by_1scalar(ncol, nlay, ngpt, & - tau1, & - tau2) bind(C, name="rte_increment_1scalar_by_1scalar") - integer, intent(in ) :: ncol, nlay, ngpt !! array sizes - real(wp), dimension(ncol,nlay,ngpt), intent(inout) :: tau1 !! optical properties to be modified - real(wp), dimension(ncol,nlay,ngpt), intent(in ) :: tau2 !! optical properties to be added to original - - integer :: icol, ilay, igpt - - do igpt = 1, ngpt - do ilay = 1, nlay - do icol = 1, ncol - tau1(icol,ilay,igpt) = tau1(icol,ilay,igpt) + tau2(icol,ilay,igpt) - end do - end do - end do - end subroutine increment_1scalar_by_1scalar + interface + pure subroutine increment_1scalar_by_1scalar(ncol, nlay, ngpt, & + tau1, & + tau2) bind(C, name="rte_increment_1scalar_by_1scalar") + use mo_rte_kind, only: wp, wl + integer, intent(in ) :: ncol, nlay, ngpt !! array sizes + real(wp), dimension(ncol,nlay,ngpt), intent(inout) :: tau1 !! optical properties to be modified + real(wp), dimension(ncol,nlay,ngpt), intent(in ) :: tau2 !! optical properties to be added to original + end subroutine increment_1scalar_by_1scalar + end interface ! --------------------------------- !> increase absorption optical depth with extinction optical depth (2-stream form) - pure subroutine increment_1scalar_by_2stream(ncol, nlay, ngpt, & - tau1, & - tau2, ssa2) bind(C, name="rte_increment_1scalar_by_2stream") - integer, intent(in ) :: ncol, nlay, ngpt !! array sizes - real(wp), dimension(ncol,nlay,ngpt), intent(inout) :: tau1 !! optical properties to be modified - real(wp), dimension(ncol,nlay,ngpt), intent(in ) :: tau2, ssa2 !! optical properties to be added to original - - integer :: icol, ilay, igpt - - do igpt = 1, ngpt - do ilay = 1, nlay - do icol = 1, ncol - tau1(icol,ilay,igpt) = tau1(icol,ilay,igpt) + & - tau2(icol,ilay,igpt) * (1._wp - ssa2(icol,ilay,igpt)) - end do - end do - end do - end subroutine increment_1scalar_by_2stream + interface + pure subroutine increment_1scalar_by_2stream(ncol, nlay, ngpt, & + tau1, & + tau2, ssa2) bind(C, name="rte_increment_1scalar_by_2stream") + use mo_rte_kind, only: wp, wl + integer, intent(in ) :: ncol, nlay, ngpt !! array sizes + real(wp), dimension(ncol,nlay,ngpt), intent(inout) :: tau1 !! optical properties to be modified + real(wp), dimension(ncol,nlay,ngpt), intent(in ) :: tau2, ssa2 !! optical properties to be added to original + end subroutine increment_1scalar_by_2stream + end interface ! --------------------------------- !> increase absorption optical depth with extinction optical depth (n-stream form) - pure subroutine increment_1scalar_by_nstream(ncol, nlay, ngpt, & - tau1, & - tau2, ssa2) bind(C, name="rte_increment_1scalar_by_nstream") - integer, intent(in ) :: ncol, nlay, ngpt !! array sizes - real(wp), dimension(ncol,nlay,ngpt), intent(inout) :: tau1 !! optical properties to be modified - real(wp), dimension(ncol,nlay,ngpt), intent(in ) :: tau2, ssa2 !! optical properties to be added to original - - integer :: icol, ilay, igpt - - do igpt = 1, ngpt - do ilay = 1, nlay - do icol = 1, ncol - tau1(icol,ilay,igpt) = tau1(icol,ilay,igpt) + & - tau2(icol,ilay,igpt) * (1._wp - ssa2(icol,ilay,igpt)) - end do - end do - end do - end subroutine increment_1scalar_by_nstream + interface + pure subroutine increment_1scalar_by_nstream(ncol, nlay, ngpt, & + tau1, & + tau2, ssa2) bind(C, name="rte_increment_1scalar_by_nstream") + use mo_rte_kind, only: wp, wl + integer, intent(in ) :: ncol, nlay, ngpt !! array sizes + real(wp), dimension(ncol,nlay,ngpt), intent(inout) :: tau1 !! optical properties to be modified + real(wp), dimension(ncol,nlay,ngpt), intent(in ) :: tau2, ssa2 !! optical properties to be added to original + end subroutine increment_1scalar_by_nstream + end interface ! --------------------------------- ! --------------------------------- !> increment two-stream optical properties \(\tau, \omega_0, g\) with absorption optical depth - pure subroutine increment_2stream_by_1scalar(ncol, nlay, ngpt, & - tau1, ssa1, & - tau2) bind(C, name="rte_increment_2stream_by_1scalar") - integer, intent(in ) :: ncol, nlay, ngpt !! array sizes - real(wp), dimension(ncol,nlay,ngpt), intent(inout) :: tau1, ssa1 !! optical properties to be modified - real(wp), dimension(ncol,nlay,ngpt), intent(in ) :: tau2 !! optical properties to be added to original - - integer :: icol, ilay, igpt - real(wp) :: tau12 - - do igpt = 1, ngpt - do ilay = 1, nlay - do icol = 1, ncol - tau12 = tau1(icol,ilay,igpt) + tau2(icol,ilay,igpt) - ssa1(icol,ilay,igpt) = tau1(icol,ilay,igpt) * ssa1(icol,ilay,igpt) / max(eps,tau12) - tau1(icol,ilay,igpt) = tau12 - ! g is unchanged - end do - end do - end do - end subroutine increment_2stream_by_1scalar + interface + pure subroutine increment_2stream_by_1scalar(ncol, nlay, ngpt, & + tau1, ssa1, & + tau2) bind(C, name="rte_increment_2stream_by_1scalar") + use mo_rte_kind, only: wp, wl + integer, intent(in ) :: ncol, nlay, ngpt !! array sizes + real(wp), dimension(ncol,nlay,ngpt), intent(inout) :: tau1, ssa1 !! optical properties to be modified + real(wp), dimension(ncol,nlay,ngpt), intent(in ) :: tau2 !! optical properties to be added to original + end subroutine increment_2stream_by_1scalar + end interface ! --------------------------------- !> increment two-stream optical properties \(\tau, \omega_0, g\) with a second set - pure subroutine increment_2stream_by_2stream(ncol, nlay, ngpt, & - tau1, ssa1, g1, & - tau2, ssa2, g2) bind(C, name="rte_increment_2stream_by_2stream") - integer, intent(in ) :: ncol, nlay, ngpt !! array sizes - real(wp), dimension(ncol,nlay,ngpt), intent(inout) :: tau1, ssa1, g1 !! optical properties to be modified - real(wp), dimension(ncol,nlay,ngpt), intent(in ) :: tau2, ssa2, g2 !! optical properties to be added to original - - integer :: icol, ilay, igpt - real(wp) :: tau12, tauscat12 - - do igpt = 1, ngpt - do ilay = 1, nlay - do icol = 1, ncol - ! t=tau1 + tau2 - tau12 = tau1(icol,ilay,igpt) + tau2(icol,ilay,igpt) - ! w=(tau1*ssa1 + tau2*ssa2) / t - tauscat12 = tau1(icol,ilay,igpt) * ssa1(icol,ilay,igpt) + & - tau2(icol,ilay,igpt) * ssa2(icol,ilay,igpt) - g1(icol,ilay,igpt) = & - (tau1(icol,ilay,igpt) * ssa1(icol,ilay,igpt) * g1(icol,ilay,igpt) + & - tau2(icol,ilay,igpt) * ssa2(icol,ilay,igpt) * g2(icol,ilay,igpt)) & - / max(eps,tauscat12) - ssa1(icol,ilay,igpt) = tauscat12 / max(eps,tau12) - tau1(icol,ilay,igpt) = tau12 - end do - end do - end do - end subroutine increment_2stream_by_2stream + interface + pure subroutine increment_2stream_by_2stream(ncol, nlay, ngpt, & + tau1, ssa1, g1, & + tau2, ssa2, g2) bind(C, name="rte_increment_2stream_by_2stream") + use mo_rte_kind, only: wp, wl + integer, intent(in ) :: ncol, nlay, ngpt !! array sizes + real(wp), dimension(ncol,nlay,ngpt), intent(inout) :: tau1, ssa1, g1 !! optical properties to be modified + real(wp), dimension(ncol,nlay,ngpt), intent(in ) :: tau2, ssa2, g2 !! optical properties to be added to original + end subroutine increment_2stream_by_2stream + end interface ! --------------------------------- !> increment two-stream optical properties \(\tau, \omega_0, g\) with _n_-stream - pure subroutine increment_2stream_by_nstream(ncol, nlay, ngpt, nmom2, & - tau1, ssa1, g1, & - tau2, ssa2, p2) bind(C, name="rte_increment_2stream_by_nstream") - integer, intent(in ) :: ncol, nlay, ngpt, nmom2 !! array sizes - real(wp), dimension(ncol,nlay,ngpt), intent(inout) :: tau1, ssa1, g1 !! optical properties to be modified - real(wp), dimension(ncol,nlay,ngpt), intent(in ) :: tau2, ssa2 !! optical properties to be added to original - real(wp), dimension(nmom2, & - ncol,nlay,ngpt), intent(in ) :: p2 !! moments of the phase function to be added - - integer :: icol, ilay, igpt - real(wp) :: tau12, tauscat12 - - do igpt = 1, ngpt - do ilay = 1, nlay - do icol = 1, ncol - ! t=tau1 + tau2 - tau12 = tau1(icol,ilay,igpt) + tau2(icol,ilay,igpt) - ! w=(tau1*ssa1 + tau2*ssa2) / t - tauscat12 = & - tau1(icol,ilay,igpt) * ssa1(icol,ilay,igpt) + & - tau2(icol,ilay,igpt) * ssa2(icol,ilay,igpt) - g1(icol,ilay,igpt) = & - (tau1(icol,ilay,igpt) * ssa1(icol,ilay,igpt) * g1( icol,ilay,igpt)+ & - tau2(icol,ilay,igpt) * ssa2(icol,ilay,igpt) * p2(1, icol,ilay,igpt)) / max(eps,tauscat12) - ssa1(icol,ilay,igpt) = tauscat12 / max(eps,tau12) - tau1(icol,ilay,igpt) = tau12 - end do - end do - end do - end subroutine increment_2stream_by_nstream + interface + pure subroutine increment_2stream_by_nstream(ncol, nlay, ngpt, nmom2, & + tau1, ssa1, g1, & + tau2, ssa2, p2) bind(C, name="rte_increment_2stream_by_nstream") + use mo_rte_kind, only: wp, wl + integer, intent(in ) :: ncol, nlay, ngpt, nmom2 !! array sizes + real(wp), dimension(ncol,nlay,ngpt), intent(inout) :: tau1, ssa1, g1 !! optical properties to be modified + real(wp), dimension(ncol,nlay,ngpt), intent(in ) :: tau2, ssa2 !! optical properties to be added to original + real(wp), dimension(nmom2, & + ncol,nlay,ngpt), intent(in ) :: p2 !! moments of the phase function to be added + end subroutine increment_2stream_by_nstream + end interface ! --------------------------------- ! --------------------------------- !> increment _n_-stream optical properties \(\tau, \omega_0, p\) with absorption optical depth - pure subroutine increment_nstream_by_1scalar(ncol, nlay, ngpt, & - tau1, ssa1, & - tau2) bind(C, name="rte_increment_nstream_by_1scalar") - integer, intent(in ) :: ncol, nlay, ngpt !! array sizes - real(wp), dimension(ncol,nlay,ngpt), intent(inout) :: tau1, ssa1 !! optical properties to be modified - real(wp), dimension(ncol,nlay,ngpt), intent(in ) :: tau2 !! optical properties to be added to original - - integer :: icol, ilay, igpt - real(wp) :: tau12 - - do igpt = 1, ngpt - do ilay = 1, nlay - do icol = 1, ncol - tau12 = tau1(icol,ilay,igpt) + tau2(icol,ilay,igpt) - ssa1(icol,ilay,igpt) = tau1(icol,ilay,igpt) * ssa1(icol,ilay,igpt) / max(eps,tau12) - tau1(icol,ilay,igpt) = tau12 - ! p is unchanged - end do - end do - end do - end subroutine increment_nstream_by_1scalar + interface + pure subroutine increment_nstream_by_1scalar(ncol, nlay, ngpt, & + tau1, ssa1, & + tau2) bind(C, name="rte_increment_nstream_by_1scalar") + use mo_rte_kind, only: wp, wl + integer, intent(in ) :: ncol, nlay, ngpt !! array sizes + real(wp), dimension(ncol,nlay,ngpt), intent(inout) :: tau1, ssa1 !! optical properties to be modified + real(wp), dimension(ncol,nlay,ngpt), intent(in ) :: tau2 !! optical properties to be added to original + end subroutine increment_nstream_by_1scalar + end interface ! --------------------------------- !> increment _n_-stream optical properties \(\tau, \omega_0, p\) with two-stream values - pure subroutine increment_nstream_by_2stream(ncol, nlay, ngpt, nmom1, & - tau1, ssa1, p1, & - tau2, ssa2, g2) bind(C, name="rte_increment_nstream_by_2stream") - integer, intent(in ) :: ncol, nlay, ngpt, nmom1 !! array sizes - real(wp), dimension(ncol,nlay,ngpt), intent(inout) :: tau1, ssa1 !! optical properties to be modified - real(wp), dimension(nmom1, & - ncol,nlay,ngpt), intent(inout) :: p1 !! moments of the phase function be modified - real(wp), dimension(ncol,nlay,ngpt), intent(in ) :: tau2, ssa2, g2 !! optical properties to be added to original - - integer :: icol, ilay, igpt - real(wp) :: tau12, tauscat12 - real(wp), dimension(nmom1) :: temp_moms ! TK - integer :: imom !TK - - do igpt = 1, ngpt - do ilay = 1, nlay - do icol = 1, ncol - tau12 = tau1(icol,ilay,igpt) + tau2(icol,ilay,igpt) - tauscat12 = & - tau1(icol,ilay,igpt) * ssa1(icol,ilay,igpt) + & - tau2(icol,ilay,igpt) * ssa2(icol,ilay,igpt) - ! - ! Here assume Henyey-Greenstein - ! - temp_moms(1) = g2(icol,ilay,igpt) - do imom = 2, nmom1 - temp_moms(imom) = temp_moms(imom-1) * g2(icol,ilay,igpt) - end do - p1(1:nmom1, icol,ilay,igpt) = & - (tau1(icol,ilay,igpt) * ssa1(icol,ilay,igpt) * p1(1:nmom1, icol,ilay,igpt) + & - tau2(icol,ilay,igpt) * ssa2(icol,ilay,igpt) * temp_moms(1:nmom1) ) / max(eps,tauscat12) - ssa1(icol,ilay,igpt) = tauscat12 / max(eps,tau12) - tau1(icol,ilay,igpt) = tau12 - end do - end do - end do - end subroutine increment_nstream_by_2stream + interface + pure subroutine increment_nstream_by_2stream(ncol, nlay, ngpt, nmom1, & + tau1, ssa1, p1, & + tau2, ssa2, g2) bind(C, name="rte_increment_nstream_by_2stream") + use mo_rte_kind, only: wp, wl + integer, intent(in ) :: ncol, nlay, ngpt, nmom1 !! array sizes + real(wp), dimension(ncol,nlay,ngpt), intent(inout) :: tau1, ssa1 !! optical properties to be modified + real(wp), dimension(nmom1, & + ncol,nlay,ngpt), intent(inout) :: p1 !! moments of the phase function be modified + real(wp), dimension(ncol,nlay,ngpt), intent(in ) :: tau2, ssa2, g2 !! optical properties to be added to original + end subroutine increment_nstream_by_2stream + end interface ! --------------------------------- !> increment one set of _n_-stream optical properties with another set - pure subroutine increment_nstream_by_nstream(ncol, nlay, ngpt, nmom1, nmom2, & - tau1, ssa1, p1, & - tau2, ssa2, p2) bind(C, name="rte_increment_nstream_by_nstream") - integer, intent(in ) :: ncol, nlay, ngpt, nmom1, nmom2 !! array sizes - real(wp), dimension(ncol,nlay,ngpt), intent(inout) :: tau1, ssa1 !! optical properties to be modified - real(wp), dimension(nmom1, & - ncol,nlay,ngpt), intent(inout) :: p1 !! moments of the phase function be modified - real(wp), dimension(ncol,nlay,ngpt), intent(in ) :: tau2, ssa2 !! optical properties to be added to original - real(wp), dimension(nmom2, & - ncol,nlay,ngpt), intent(in ) :: p2 !! moments of the phase function to be added - - integer :: icol, ilay, igpt, mom_lim - real(wp) :: tau12, tauscat12 - - mom_lim = min(nmom1, nmom2) - do igpt = 1, ngpt - do ilay = 1, nlay - do icol = 1, ncol - tau12 = tau1(icol,ilay,igpt) + tau2(icol,ilay,igpt) - tauscat12 = & - tau1(icol,ilay,igpt) * ssa1(icol,ilay,igpt) + & - tau2(icol,ilay,igpt) * ssa2(icol,ilay,igpt) - ! - ! If op2 has more moments than op1 these are ignored; - ! if it has fewer moments the higher orders are assumed to be 0 - ! - p1(1:mom_lim, icol,ilay,igpt) = & - (tau1(icol,ilay,igpt) * ssa1(icol,ilay,igpt) * p1(1:mom_lim, icol,ilay,igpt) + & - tau2(icol,ilay,igpt) * ssa2(icol,ilay,igpt) * p2(1:mom_lim, icol,ilay,igpt)) / max(eps,tauscat12) - ssa1(icol,ilay,igpt) = tauscat12 / max(eps,tau12) - tau1(icol,ilay,igpt) = tau12 - end do - end do - end do - end subroutine increment_nstream_by_nstream + interface + pure subroutine increment_nstream_by_nstream(ncol, nlay, ngpt, nmom1, nmom2, & + tau1, ssa1, p1, & + tau2, ssa2, p2) bind(C, name="rte_increment_nstream_by_nstream") + use mo_rte_kind, only: wp, wl + integer, intent(in ) :: ncol, nlay, ngpt, nmom1, nmom2 !! array sizes + real(wp), dimension(ncol,nlay,ngpt), intent(inout) :: tau1, ssa1 !! optical properties to be modified + real(wp), dimension(nmom1, & + ncol,nlay,ngpt), intent(inout) :: p1 !! moments of the phase function be modified + real(wp), dimension(ncol,nlay,ngpt), intent(in ) :: tau2, ssa2 !! optical properties to be added to original + real(wp), dimension(nmom2, & + ncol,nlay,ngpt), intent(in ) :: p2 !! moments of the phase function to be added + end subroutine increment_nstream_by_nstream + end interface ! ------------------------------------------------------------------------------------------------- ! ! Incrementing when the second set of optical properties is defined at lower spectral resolution @@ -363,271 +195,139 @@ end subroutine increment_nstream_by_nstream ! ! ------------------------------------------------------------------------------------------------- !> increase one absorption optical depth defined on g-points by a second value defined on bands - pure subroutine inc_1scalar_by_1scalar_bybnd(ncol, nlay, ngpt, & - tau1, & - tau2, & - nbnd, gpt_lims) bind(C, name="rte_inc_1scalar_by_1scalar_bybnd") - integer, intent(in ) :: ncol, nlay, ngpt, nbnd !! array sizes - real(wp), dimension(ncol,nlay,ngpt), intent(inout) :: tau1 !! optical properties to be modified (defined on g-points) - real(wp), dimension(ncol,nlay,nbnd), intent(in ) :: tau2 !! optical properties to be added to original (defined on bands) - integer, dimension(2,nbnd), intent(in ) :: gpt_lims !! Starting and ending gpoint for each band - - integer :: ibnd, igpt - - do ibnd = 1, nbnd - do igpt = gpt_lims(1, ibnd), gpt_lims(2, ibnd) - tau1(:,:,igpt) = tau1(:,:,igpt) + tau2(:,:,ibnd) - end do - end do - end subroutine inc_1scalar_by_1scalar_bybnd + interface + pure subroutine inc_1scalar_by_1scalar_bybnd(ncol, nlay, ngpt, & + tau1, & + tau2, & + nbnd, gpt_lims) bind(C, name="rte_inc_1scalar_by_1scalar_bybnd") + use mo_rte_kind, only: wp, wl + integer, intent(in ) :: ncol, nlay, ngpt, nbnd !! array sizes + real(wp), dimension(ncol,nlay,ngpt), intent(inout) :: tau1 !! optical properties to be modified (defined on g-points) + real(wp), dimension(ncol,nlay,nbnd), intent(in ) :: tau2 !! optical properties to be added to original (defined on bands) + integer, dimension(2,nbnd), intent(in ) :: gpt_lims !! Starting and ending gpoint for each band + end subroutine inc_1scalar_by_1scalar_bybnd + end interface ! --------------------------------- !> increase absorption optical depth defined on g-points with extinction optical depth (2-stream form) defined on bands - pure subroutine inc_1scalar_by_2stream_bybnd(ncol, nlay, ngpt, & - tau1, & - tau2, ssa2, & - nbnd, gpt_lims) bind(C, name="rte_inc_1scalar_by_2stream_bybnd") - integer, intent(in ) :: ncol, nlay, ngpt, nbnd !! array sizes - real(wp), dimension(ncol,nlay,ngpt), intent(inout) :: tau1 !! optical properties to be modified (defined on g-points) - real(wp), dimension(ncol,nlay,nbnd), intent(in ) :: tau2, ssa2 !! optical properties to be added to original (defined on bands) - integer, dimension(2,nbnd), intent(in ) :: gpt_lims !! Starting and ending gpoint for each band - - integer :: ibnd, igpt - - do ibnd = 1, nbnd - do igpt = gpt_lims(1, ibnd), gpt_lims(2, ibnd) - tau1(:,:,igpt) = tau1(:,:,igpt) + tau2(:,:,ibnd) * (1._wp - ssa2(:,:,ibnd)) - end do - end do - end subroutine inc_1scalar_by_2stream_bybnd + interface + pure subroutine inc_1scalar_by_2stream_bybnd(ncol, nlay, ngpt, & + tau1, & + tau2, ssa2, & + nbnd, gpt_lims) bind(C, name="rte_inc_1scalar_by_2stream_bybnd") + use mo_rte_kind, only: wp, wl + integer, intent(in ) :: ncol, nlay, ngpt, nbnd !! array sizes + real(wp), dimension(ncol,nlay,ngpt), intent(inout) :: tau1 !! optical properties to be modified (defined on g-points) + real(wp), dimension(ncol,nlay,nbnd), intent(in ) :: tau2, ssa2 !! optical properties to be added to original (defined on bands) + integer, dimension(2,nbnd), intent(in ) :: gpt_lims !! Starting and ending gpoint for each band + end subroutine inc_1scalar_by_2stream_bybnd + end interface ! --------------------------------- !> increase absorption optical depth defined on g-points with extinction optical depth (n-stream form) defined on bands - pure subroutine inc_1scalar_by_nstream_bybnd(ncol, nlay, ngpt, & - tau1, & - tau2, ssa2, & - nbnd, gpt_lims) bind(C, name="rte_inc_1scalar_by_nstream_bybnd") - integer, intent(in ) :: ncol, nlay, ngpt, nbnd !! array sizes - real(wp), dimension(ncol,nlay,ngpt), intent(inout) :: tau1 !! optical properties to be modified (defined on g-points) - real(wp), dimension(ncol,nlay,nbnd), intent(in ) :: tau2, ssa2 !! optical properties to be added to original (defined on bands) - integer, dimension(2,nbnd), intent(in ) :: gpt_lims !! Starting and ending gpoint for each band - - integer :: ibnd, igpt - - do ibnd = 1, nbnd - do igpt = gpt_lims(1, ibnd), gpt_lims(2, ibnd) - tau1(:,:,igpt) = tau1(:,:,igpt) + tau2(:,:,ibnd) * (1._wp - ssa2(:,:,ibnd)) - end do - end do - end subroutine inc_1scalar_by_nstream_bybnd - - ! --------------------------------- + interface + pure subroutine inc_1scalar_by_nstream_bybnd(ncol, nlay, ngpt, & + tau1, & + tau2, ssa2, & + nbnd, gpt_lims) bind(C, name="rte_inc_1scalar_by_nstream_bybnd") + use mo_rte_kind, only: wp, wl + integer, intent(in ) :: ncol, nlay, ngpt, nbnd !! array sizes + real(wp), dimension(ncol,nlay,ngpt), intent(inout) :: tau1 !! optical properties to be modified (defined on g-points) + real(wp), dimension(ncol,nlay,nbnd), intent(in ) :: tau2, ssa2 !! optical properties to be added to original (defined on bands) + integer, dimension(2,nbnd), intent(in ) :: gpt_lims !! Starting and ending gpoint for each band + end subroutine inc_1scalar_by_nstream_bybnd + end interface + ! --------------------------------- !> increment two-stream optical properties \(\tau, \omega_0, g\) defined on g-points with absorption optical depth defined on bands - pure subroutine inc_2stream_by_1scalar_bybnd(ncol, nlay, ngpt, & - tau1, ssa1, & - tau2, & - nbnd, gpt_lims) bind(C, name="rte_inc_2stream_by_1scalar_bybnd") - integer, intent(in ) :: ncol, nlay, ngpt, nbnd !! array sizes - real(wp), dimension(ncol,nlay,ngpt), intent(inout) :: tau1, ssa1 !! optical properties to be modified (defined on g-points) - real(wp), dimension(ncol,nlay,nbnd), intent(in ) :: tau2 !! optical properties to be added to original (defined on bands) - integer, dimension(2,nbnd), intent(in ) :: gpt_lims !! Starting and ending gpoint for each band - - integer :: icol, ilay, igpt, ibnd - real(wp) :: tau12 - - do ibnd = 1, nbnd - do igpt = gpt_lims(1, ibnd), gpt_lims(2, ibnd) - do ilay = 1, nlay - do icol = 1, ncol - tau12 = tau1(icol,ilay,igpt) + tau2(icol,ilay,ibnd) - ssa1(icol,ilay,igpt) = tau1(icol,ilay,igpt) * ssa1(icol,ilay,igpt) / max(eps,tau12) - tau1(icol,ilay,igpt) = tau12 - ! g is unchanged - end do - end do - end do - end do - end subroutine inc_2stream_by_1scalar_bybnd + interface + pure subroutine inc_2stream_by_1scalar_bybnd(ncol, nlay, ngpt, & + tau1, ssa1, & + tau2, & + nbnd, gpt_lims) bind(C, name="rte_inc_2stream_by_1scalar_bybnd") + use mo_rte_kind, only: wp, wl + integer, intent(in ) :: ncol, nlay, ngpt, nbnd !! array sizes + real(wp), dimension(ncol,nlay,ngpt), intent(inout) :: tau1, ssa1 !! optical properties to be modified (defined on g-points) + real(wp), dimension(ncol,nlay,nbnd), intent(in ) :: tau2 !! optical properties to be added to original (defined on bands) + integer, dimension(2,nbnd), intent(in ) :: gpt_lims !! Starting and ending gpoint for each band + end subroutine inc_2stream_by_1scalar_bybnd + end interface ! --------------------------------- !> increment 2-stream optical properties defined on g-points with another set defined on bands - pure subroutine inc_2stream_by_2stream_bybnd(ncol, nlay, ngpt, & - tau1, ssa1, g1, & - tau2, ssa2, g2, & - nbnd, gpt_lims) bind(C, name="rte_inc_2stream_by_2stream_bybnd") - integer, intent(in ) :: ncol, nlay, ngpt, nbnd !! array sizes - real(wp), dimension(ncol,nlay,ngpt), intent(inout) :: tau1, ssa1, g1 !! optical properties to be modified (defined on g-points) - real(wp), dimension(ncol,nlay,nbnd), intent(in ) :: tau2, ssa2, g2 !! optical properties to be added to original (defined on bands) - integer, dimension(2,nbnd), intent(in ) :: gpt_lims !! Starting and ending gpoint for each band - - integer :: icol, ilay, igpt, ibnd - real(wp) :: tau12, tauscat12 - - do ibnd = 1, nbnd - do igpt = gpt_lims(1, ibnd), gpt_lims(2, ibnd) - do ilay = 1, nlay - do icol = 1, ncol - ! t=tau1 + tau2 - tau12 = tau1(icol,ilay,igpt) + tau2(icol,ilay,ibnd) - ! w=(tau1*ssa1 + tau2*ssa2) / t - tauscat12 = & - tau1(icol,ilay,igpt) * ssa1(icol,ilay,igpt) + & - tau2(icol,ilay,ibnd) * ssa2(icol,ilay,ibnd) - g1(icol,ilay,igpt) = & - (tau1(icol,ilay,igpt) * ssa1(icol,ilay,igpt) * g1(icol,ilay,igpt) + & - tau2(icol,ilay,ibnd) * ssa2(icol,ilay,ibnd) * g2(icol,ilay,ibnd)) / max(eps,tauscat12) - ssa1(icol,ilay,igpt) = tauscat12 / max(eps,tau12) - tau1(icol,ilay,igpt) = tau12 - end do - end do - end do - end do - end subroutine inc_2stream_by_2stream_bybnd + interface + pure subroutine inc_2stream_by_2stream_bybnd(ncol, nlay, ngpt, & + tau1, ssa1, g1, & + tau2, ssa2, g2, & + nbnd, gpt_lims) bind(C, name="rte_inc_2stream_by_2stream_bybnd") + use mo_rte_kind, only: wp, wl + integer, intent(in ) :: ncol, nlay, ngpt, nbnd !! array sizes + real(wp), dimension(ncol,nlay,ngpt), intent(inout) :: tau1, ssa1, g1 !! optical properties to be modified (defined on g-points) + real(wp), dimension(ncol,nlay,nbnd), intent(in ) :: tau2, ssa2, g2 !! optical properties to be added to original (defined on bands) + integer, dimension(2,nbnd), intent(in ) :: gpt_lims !! Starting and ending gpoint for each band + end subroutine inc_2stream_by_2stream_bybnd + end interface ! --------------------------------- !> increment 2-stream optical properties defined on g-points with _n_-stream properties set defined on bands - pure subroutine inc_2stream_by_nstream_bybnd(ncol, nlay, ngpt, nmom2, & - tau1, ssa1, g1, & - tau2, ssa2, p2, & - nbnd, gpt_lims) bind(C, name="rte_inc_2stream_by_nstream_bybnd") - integer, intent(in ) :: ncol, nlay, ngpt, nmom2, nbnd !! array sizes - real(wp), dimension(ncol,nlay,ngpt), intent(inout) :: tau1, ssa1, g1 !! optical properties to be modified (defined on g-points) - real(wp), dimension(ncol,nlay,nbnd), intent(in ) :: tau2, ssa2 !! optical properties to be added to original (defined on bands) - real(wp), dimension(nmom2, & - ncol,nlay,nbnd), intent(in ) :: p2 !! moments of the phase function to be added - integer, dimension(2,nbnd), intent(in ) :: gpt_lims !! Starting and ending gpoint for each band - - integer :: icol, ilay, igpt, ibnd - real(wp) :: tau12, tauscat12 - - do ibnd = 1, nbnd - do igpt = gpt_lims(1, ibnd), gpt_lims(2, ibnd) - do ilay = 1, nlay - do icol = 1, ncol - ! t=tau1 + tau2 - tau12 = tau1(icol,ilay,igpt) + tau2(icol,ilay,ibnd) - ! w=(tau1*ssa1 + tau2*ssa2) / t - tauscat12 = & - tau1(icol,ilay,igpt) * ssa1(icol,ilay,igpt) + & - tau2(icol,ilay,ibnd) * ssa2(icol,ilay,ibnd) - g1(icol,ilay,igpt) = & - (tau1(icol,ilay,igpt) * ssa1(icol,ilay,igpt) * g1( icol,ilay,igpt)+ & - tau2(icol,ilay,ibnd) * ssa2(icol,ilay,ibnd) * p2(1, icol,ilay,ibnd)) / max(eps,tauscat12) - ssa1(icol,ilay,igpt) = tauscat12 / max(eps,tau12) - tau1(icol,ilay,igpt) = tau12 - end do - end do - end do - end do - end subroutine inc_2stream_by_nstream_bybnd + interface + pure subroutine inc_2stream_by_nstream_bybnd(ncol, nlay, ngpt, nmom2, & + tau1, ssa1, g1, & + tau2, ssa2, p2, & + nbnd, gpt_lims) bind(C, name="rte_inc_2stream_by_nstream_bybnd") + use mo_rte_kind, only: wp, wl + integer, intent(in ) :: ncol, nlay, ngpt, nmom2, nbnd !! array sizes + real(wp), dimension(ncol,nlay,ngpt), intent(inout) :: tau1, ssa1, g1 !! optical properties to be modified (defined on g-points) + real(wp), dimension(ncol,nlay,nbnd), intent(in ) :: tau2, ssa2 !! optical properties to be added to original (defined on bands) + real(wp), dimension(nmom2, & + ncol,nlay,nbnd), intent(in ) :: p2 !! moments of the phase function to be added + integer, dimension(2,nbnd), intent(in ) :: gpt_lims !! Starting and ending gpoint for each band + end subroutine inc_2stream_by_nstream_bybnd + end interface ! --------------------------------- ! --------------------------------- !> increment _n_-stream optical properties defined on g-points with absorption optical depth defined on bands - pure subroutine inc_nstream_by_1scalar_bybnd(ncol, nlay, ngpt, & - tau1, ssa1, & - tau2, & - nbnd, gpt_lims) bind(C, name="rte_inc_nstream_by_1scalar_bybnd") - integer, intent(in ) :: ncol, nlay, ngpt, nbnd !! array sizes - real(wp), dimension(ncol,nlay,ngpt), intent(inout) :: tau1, ssa1 !! optical properties to be modified (defined on g-points) - real(wp), dimension(ncol,nlay,nbnd), intent(in ) :: tau2 !! optical properties to be added to original (defined on bands) - integer, dimension(2,nbnd), intent(in ) :: gpt_lims !! Starting and ending gpoint for each band - - integer :: icol, ilay, igpt, ibnd - real(wp) :: tau12 - - do ibnd = 1, nbnd - do igpt = gpt_lims(1, ibnd), gpt_lims(2, ibnd) - do ilay = 1, nlay - do icol = 1, ncol - tau12 = tau1(icol,ilay,igpt) + tau2(icol,ilay,ibnd) - ssa1(icol,ilay,igpt) = tau1(icol,ilay,igpt) * ssa1(icol,ilay,igpt) / max(eps,tau12) - tau1(icol,ilay,igpt) = tau12 - ! p is unchanged - end do - end do - end do - end do - end subroutine inc_nstream_by_1scalar_bybnd + interface + pure subroutine inc_nstream_by_1scalar_bybnd(ncol, nlay, ngpt, & + tau1, ssa1, & + tau2, & + nbnd, gpt_lims) bind(C, name="rte_inc_nstream_by_1scalar_bybnd") + use mo_rte_kind, only: wp, wl + integer, intent(in ) :: ncol, nlay, ngpt, nbnd !! array sizes + real(wp), dimension(ncol,nlay,ngpt), intent(inout) :: tau1, ssa1 !! optical properties to be modified (defined on g-points) + real(wp), dimension(ncol,nlay,nbnd), intent(in ) :: tau2 !! optical properties to be added to original (defined on bands) + integer, dimension(2,nbnd), intent(in ) :: gpt_lims !! Starting and ending gpoint for each band + end subroutine inc_nstream_by_1scalar_bybnd + end interface ! --------------------------------- !> increment n-stream optical properties defined on g-points with 2-stream properties set defined on bands - pure subroutine inc_nstream_by_2stream_bybnd(ncol, nlay, ngpt, nmom1, & - tau1, ssa1, p1, & - tau2, ssa2, g2, & - nbnd, gpt_lims) bind(C, name="rte_inc_nstream_by_2stream_bybnd") - integer, intent(in ) :: ncol, nlay, ngpt, nmom1, nbnd !! array sizes - real(wp), dimension(ncol,nlay,ngpt), intent(inout) :: tau1, ssa1 !! optical properties to be modified (defined on g-points) - real(wp), dimension(nmom1, & - ncol,nlay,ngpt), intent(inout) :: p1 !! moments of the phase function be modified - real(wp), dimension(ncol,nlay,nbnd), intent(in ) :: tau2, ssa2, g2 !! optical properties to be added to original (defined on bands) - integer, dimension(2,nbnd), intent(in ) :: gpt_lims !! Starting and ending gpoint for each band - - integer :: icol, ilay, igpt, ibnd - real(wp) :: tau12, tauscat12 - real(wp), dimension(nmom1) :: temp_moms ! TK - integer :: imom !TK - - do ibnd = 1, nbnd - do igpt = gpt_lims(1, ibnd), gpt_lims(2, ibnd) - do ilay = 1, nlay - do icol = 1, ncol - tau12 = tau1(icol,ilay,igpt) + tau2(icol,ilay,ibnd) - tauscat12 = & - tau1(icol,ilay,igpt) * ssa1(icol,ilay,igpt) + & - tau2(icol,ilay,ibnd) * ssa2(icol,ilay,ibnd) - ! - ! Here assume Henyey-Greenstein - ! - temp_moms(1) = g2(icol,ilay,ibnd) - do imom = 2, nmom1 - temp_moms(imom) = temp_moms(imom-1) * g2(icol,ilay,ibnd) - end do - p1(1:nmom1, icol,ilay,igpt) = & - (tau1(icol,ilay,igpt) * ssa1(icol,ilay,igpt) * p1(1:nmom1, icol,ilay,igpt) + & - tau2(icol,ilay,ibnd) * ssa2(icol,ilay,ibnd) * temp_moms(1:nmom1) ) / max(eps,tauscat12) - ssa1(icol,ilay,igpt) = tauscat12 / max(eps,tau12) - tau1(icol,ilay,igpt) = tau12 - end do - end do - end do - end do - end subroutine inc_nstream_by_2stream_bybnd + interface + pure subroutine inc_nstream_by_2stream_bybnd(ncol, nlay, ngpt, nmom1, & + tau1, ssa1, p1, & + tau2, ssa2, g2, & + nbnd, gpt_lims) bind(C, name="rte_inc_nstream_by_2stream_bybnd") + use mo_rte_kind, only: wp, wl + integer, intent(in ) :: ncol, nlay, ngpt, nmom1, nbnd !! array sizes + real(wp), dimension(ncol,nlay,ngpt), intent(inout) :: tau1, ssa1 !! optical properties to be modified (defined on g-points) + real(wp), dimension(nmom1, & + ncol,nlay,ngpt), intent(inout) :: p1 !! moments of the phase function be modified + real(wp), dimension(ncol,nlay,nbnd), intent(in ) :: tau2, ssa2, g2 !! optical properties to be added to original (defined on bands) + integer, dimension(2,nbnd), intent(in ) :: gpt_lims !! Starting and ending gpoint for each band + end subroutine inc_nstream_by_2stream_bybnd + end interface ! --------------------------------- !> increment _n_-stream optical properties defined on g-points with a second set defined on bands - pure subroutine inc_nstream_by_nstream_bybnd(ncol, nlay, ngpt, nmom1, nmom2, & - tau1, ssa1, p1, & - tau2, ssa2, p2, & - nbnd, gpt_lims) bind(C, name="rte_inc_nstream_by_nstream_bybnd") - integer, intent(in ) :: ncol, nlay, ngpt, nmom1, nmom2, nbnd !! array sizes - real(wp), dimension(ncol,nlay,ngpt), intent(inout) :: tau1, ssa1 !! optical properties to be modified (defined on g-points) - real(wp), dimension(nmom1, & - ncol,nlay,ngpt), intent(inout) :: p1 !! moments of the phase function be modified - real(wp), dimension(ncol,nlay,nbnd), intent(in ) :: tau2, ssa2 !! optical properties to be added to original (defined on bands) - real(wp), dimension(nmom2, & - ncol,nlay,nbnd), intent(in ) :: p2 !! moments of the phase function to be added - integer, dimension(2,nbnd), intent(in ) :: gpt_lims !! Starting and ending gpoint for each band - - integer :: icol, ilay, igpt, ibnd, mom_lim - real(wp) :: tau12, tauscat12 - - mom_lim = min(nmom1, nmom2) - do ibnd = 1, nbnd - do igpt = gpt_lims(1, ibnd), gpt_lims(2, ibnd) - do ilay = 1, nlay - do icol = 1, ncol - tau12 = tau1(icol,ilay,igpt) + tau2(icol,ilay,ibnd) - tauscat12 = & - tau1(icol,ilay,igpt) * ssa1(icol,ilay,igpt) + & - tau2(icol,ilay,ibnd) * ssa2(icol,ilay,ibnd) - ! - ! If op2 has more moments than op1 these are ignored; - ! if it has fewer moments the higher orders are assumed to be 0 - ! - p1(1:mom_lim, icol,ilay,igpt) = & - (tau1(icol,ilay,igpt) * ssa1(icol,ilay,igpt) * p1(1:mom_lim, icol,ilay,igpt) + & - tau2(icol,ilay,ibnd) * ssa2(icol,ilay,ibnd) * p2(1:mom_lim, icol,ilay,ibnd)) / max(eps,tauscat12) - ssa1(icol,ilay,igpt) = tauscat12 / max(eps,tau12) - tau1(icol,ilay,igpt) = tau12 - end do - end do - end do - end do - end subroutine inc_nstream_by_nstream_bybnd + interface + pure subroutine inc_nstream_by_nstream_bybnd(ncol, nlay, ngpt, nmom1, nmom2, & + tau1, ssa1, p1, & + tau2, ssa2, p2, & + nbnd, gpt_lims) bind(C, name="rte_inc_nstream_by_nstream_bybnd") + use mo_rte_kind, only: wp, wl + integer, intent(in ) :: ncol, nlay, ngpt, nmom1, nmom2, nbnd !! array sizes + real(wp), dimension(ncol,nlay,ngpt), intent(inout) :: tau1, ssa1 !! optical properties to be modified (defined on g-points) + real(wp), dimension(nmom1, & + ncol,nlay,ngpt), intent(inout) :: p1 !! moments of the phase function be modified + real(wp), dimension(ncol,nlay,nbnd), intent(in ) :: tau2, ssa2 !! optical properties to be added to original (defined on bands) + real(wp), dimension(nmom2, & + ncol,nlay,nbnd), intent(in ) :: p2 !! moments of the phase function to be added + integer, dimension(2,nbnd), intent(in ) :: gpt_lims !! Starting and ending gpoint for each band + end subroutine inc_nstream_by_nstream_bybnd + end interface ! ------------------------------------------------------------------------------------------------- ! ! Subsetting, meaning extracting some portion of the 3D domain @@ -637,71 +337,41 @@ end subroutine inc_nstream_by_nstream_bybnd !> Extract a subset from the first dimension (normally columns) of a 3D field. !> Applicable to most variables e.g. tau, ssa, g !> - pure subroutine extract_subset_dim1_3d(ncol, nlay, ngpt, array_in, colS, colE, array_out) & - bind (C, name="rte_extract_subset_dim1_3d") - integer, intent(in ) :: ncol, nlay, ngpt !! Array sizes - real(wp), dimension(ncol,nlay,ngpt), intent(in ) :: array_in !! Array to subset - integer, intent(in ) :: colS, colE !! Starting and ending index - real(wp), dimension(colE-colS+1,& - nlay,ngpt), intent(out) :: array_out !! subset of the input array - - integer :: icol, ilay, igpt - do igpt = 1, ngpt - do ilay = 1, nlay - do icol = colS, colE - array_out(icol-colS+1, ilay, igpt) = array_in(icol, ilay, igpt) - end do - end do - end do - - end subroutine extract_subset_dim1_3d - ! --------------------------------- - !> Extract a subset from the second dimension (normally columns) of a 4D field. - !> Applicable to phase function moments, where the first dimension is the moment - pure subroutine extract_subset_dim2_4d(nmom, ncol, nlay, ngpt, array_in, colS, colE, array_out) & - bind (C, name="rte_extract_subset_dim2_4d") - integer, intent(in ) :: nmom, ncol, nlay, ngpt !! Array sizes - real(wp), dimension(nmom,ncol,nlay,ngpt), intent(in ) :: array_in !! Array to subset - integer, intent(in ) :: colS, colE !! Starting and ending index - real(wp), dimension(nmom,colE-colS+1,& - nlay,ngpt), intent(out) :: array_out !! subset of the input array - - integer :: icol, ilay, igpt, imom - - do igpt = 1, ngpt - do ilay = 1, nlay - do icol = colS, colE - do imom = 1, nmom - array_out(imom, icol-colS+1, ilay, igpt) = array_in(imom, icol, ilay, igpt) - end do - end do - end do - end do - - end subroutine extract_subset_dim2_4d - ! --------------------------------- - ! - !> Extract the absorption optical thickness \(\tau_{abs} = 1 - \omega_0 \tau_{ext}\) - ! - pure subroutine extract_subset_absorption_tau(ncol, nlay, ngpt, tau_in, ssa_in, & - colS, colE, tau_out) & - bind (C, name="rte_extract_subset_absorption_tau") - integer, intent(in ) :: ncol, nlay, ngpt !! Array sizes - real(wp), dimension(ncol,nlay,ngpt), intent(in ) :: tau_in, ssa_in !! Optical thickness, single scattering albedo - integer, intent(in ) :: colS, colE !! Starting and ending index - real(wp), dimension(colE-colS+1,& - nlay,ngpt), intent(out) :: tau_out !! absorption optical thickness subset - - integer :: icol, ilay, igpt - - do igpt = 1, ngpt - do ilay = 1, nlay - do icol = colS, colE - tau_out(icol-colS+1, ilay, igpt) = & - tau_in(icol, ilay, igpt) * (1._wp - ssa_in(icol, ilay, igpt)) - end do - end do - end do - - end subroutine extract_subset_absorption_tau + interface extract_subset + pure subroutine extract_subset_dim1_3d(ncol, nlay, ngpt, array_in, colS, colE, array_out) & + bind (C, name="rte_extract_subset_dim1_3d") + use mo_rte_kind, only: wp, wl + integer, intent(in ) :: ncol, nlay, ngpt !! Array sizes + real(wp), dimension(ncol,nlay,ngpt), intent(in ) :: array_in !! Array to subset + integer, intent(in ) :: colS, colE !! Starting and ending index + real(wp), dimension(colE-colS+1,& + nlay,ngpt), intent(out) :: array_out !! subset of the input array + end subroutine extract_subset_dim1_3d + ! --------------------------------- + !> Extract a subset from the second dimension (normally columns) of a 4D field. + !> Applicable to phase function moments, where the first dimension is the moment + pure subroutine extract_subset_dim2_4d(nmom, ncol, nlay, ngpt, array_in, colS, colE, array_out) & + bind (C, name="rte_extract_subset_dim2_4d") + use mo_rte_kind, only: wp, wl + integer, intent(in ) :: nmom, ncol, nlay, ngpt !! Array sizes + real(wp), dimension(nmom,ncol,nlay,ngpt), intent(in ) :: array_in !! Array to subset + integer, intent(in ) :: colS, colE !! Starting and ending index + real(wp), dimension(nmom,colE-colS+1,& + nlay,ngpt), intent(out) :: array_out !! subset of the input array + end subroutine extract_subset_dim2_4d + ! --------------------------------- + ! + !> Extract the absorption optical thickness \(\tau_{abs} = 1 - \omega_0 \tau_{ext}\) + ! + pure subroutine extract_subset_absorption_tau(ncol, nlay, ngpt, tau_in, ssa_in, & + colS, colE, tau_out) & + bind (C, name="rte_extract_subset_absorption_tau") + use mo_rte_kind, only: wp, wl + integer, intent(in ) :: ncol, nlay, ngpt !! Array sizes + real(wp), dimension(ncol,nlay,ngpt), intent(in ) :: tau_in, ssa_in !! Optical thickness, single scattering albedo + integer, intent(in ) :: colS, colE !! Starting and ending index + real(wp), dimension(colE-colS+1,& + nlay,ngpt), intent(out) :: tau_out !! absorption optical thickness subset + end subroutine extract_subset_absorption_tau + end interface extract_subset end module mo_optical_props_kernels diff --git a/reference/rte-kernels/src/mo_rte_solver_kernels.F90 b/reference/rte-kernels/src/mo_rte_solver_kernels.F90 index 0dc8c98e2..da8d0f706 100644 --- a/reference/rte-kernels/src/mo_rte_solver_kernels.F90 +++ b/reference/rte-kernels/src/mo_rte_solver_kernels.F90 @@ -13,373 +13,88 @@ !>## Numeric calculations for radiative transfer solvers !> - Emission/absorption (no-scattering) calculations !> - solver for multi-angle Gaussian quadrature -!> - solver for a single angle, calling -!> - source function computation (linear-in-tau) -!> - transport !> - Extinction-only calculation (direct solar beam) !> - Two-stream calculations: !> solvers for LW and SW with different boundary conditions and source functions -!> - source function calculation for LW, SW -!> - two-stream calculations for LW, SW (using different assumtions about phase function) -!> - transport (adding) -!> - Application of boundary conditions ! ! ------------------------------------------------------------------------------------------------- module mo_rte_solver_kernels use, intrinsic :: iso_c_binding use mo_rte_kind, only: wp, wl - use mo_rte_util_array,only: zero_array implicit none private public :: lw_solver_noscat, lw_solver_2stream, & sw_solver_noscat, sw_solver_2stream - - real(wp), parameter :: pi = acos(-1._wp) -contains ! ------------------------------------------------------------------------------------------------- ! ! Top-level longwave kernels ! ! ------------------------------------------------------------------------------------------------- ! - !> LW fluxes, no scattering, mu (cosine of integration angle) specified by column - !> Does radiation calculation at user-supplied angles; converts radiances to flux - !> using user-supplied weights - ! - ! --------------------------------------------------------------- - subroutine lw_solver_noscat_oneangle(ncol, nlay, ngpt, top_at_1, D, weight, & - tau, lay_source, lev_source_inc, lev_source_dec, sfc_emis, sfc_src, & - incident_flux, & - flux_up, flux_dn, & - do_broadband, broadband_up, broadband_dn, & - do_Jacobians, sfc_srcJac, flux_upJac, & - do_rescaling, ssa, g) - integer, intent(in ) :: ncol, nlay, ngpt ! Number of columns, layers, g-points - logical(wl), intent(in ) :: top_at_1 - real(wp), dimension(ncol, ngpt), intent(in ) :: D ! secant of propagation angle [] - real(wp), intent(in ) :: weight ! quadrature weight - real(wp), dimension(ncol,nlay, ngpt), intent(in ) :: tau ! Absorption optical thickness [] - real(wp), dimension(ncol,nlay, ngpt), intent(in ) :: lay_source ! Planck source at layer average temperature [W/m2] - ! Planck source at layer edge for radiation in increasing/decreasing ilay direction - ! lev_source_dec applies the mapping in layer i to the Planck function at layer i - ! lev_source_inc applies the mapping in layer i to the Planck function at layer i+1 - real(wp), dimension(ncol,nlay, ngpt), target, & - intent(in ) :: lev_source_inc, lev_source_dec - real(wp), dimension(ncol, ngpt), intent(in ) :: sfc_emis ! Surface emissivity [] - real(wp), dimension(ncol, ngpt), intent(in ) :: sfc_src ! Surface source function [W/m2] - real(wp), dimension(ncol, ngpt), intent(in ) :: incident_flux! Boundary condition for flux [W/m2] - real(wp), dimension(ncol,nlay+1,ngpt), target, & ! Fluxes [W/m2] - intent( out) :: flux_up, flux_dn - ! - ! Optional variables - arrays aren't referenced if corresponding logical == False - ! - logical(wl), intent(in ) :: do_broadband - real(wp), dimension(ncol,nlay+1 ), intent( out) :: broadband_up, broadband_dn ! Spectrally-integrated fluxes [W/m2] - logical(wl), intent(in ) :: do_Jacobians - real(wp), dimension(ncol ,ngpt), intent(in ) :: sfc_srcJac ! surface temperature Jacobian of surface source function [W/m2/K] - real(wp), dimension(ncol,nlay+1 ), intent( out) :: flux_upJac ! surface temperature Jacobian of Radiances [W/m2-str / K] - logical(wl), intent(in ) :: do_rescaling - real(wp), dimension(ncol,nlay ,ngpt), intent(in ) :: ssa, g ! single-scattering albedo, asymmetry parameter - ! ------------------------------------ - ! Local variables, no g-point dependency - ! - integer :: icol, ilay, igpt - integer :: top_level, sfc_level - real(wp), dimension(ncol,nlay) :: tau_loc, & ! path length (tau/mu) - trans ! transmissivity = exp(-tau) - real(wp), dimension(ncol,nlay) :: source_dn, source_up - real(wp), dimension(ncol ) :: sfc_albedo - - real(wp), dimension(:,:,:), pointer :: lev_source_up, lev_source_dn ! Mapping increasing/decreasing indicies to up/down - - real(wp), parameter :: pi = acos(-1._wp) - ! loc_fluxes hold a single g-point flux if fluxes are being integrated instead of returned - ! with spectral detail - real(wp), dimension(ncol,nlay+1), & - target :: loc_flux_up, loc_flux_dn - ! gpt_fluxes point to calculations for the current g-point - real(wp), dimension(:,:), pointer :: gpt_flux_up, gpt_flux_dn - ! ------------------------------------------------------------------------------------------------- - ! Optionally, use an approximate treatment of scattering using rescaling - ! Implemented based on the paper - ! Tang G, et al, 2018: https://doi.org/10.1175/JAS-D-18-0014.1 - ! a) relies on rescaling of the optical parameters based on asymetry factor and single scattering albedo - ! scaling can be computed by scaling_1rescl - ! b) adds adustment term based on cloud properties (lw_transport_1rescl) - ! adustment terms is computed based on solution of the Tang equations - ! for "linear-in-tau" internal source (not in the paper) - ! - ! Used when approximating scattering - ! - real(wp) :: ssal, wb, scaleTau - real(wp), dimension(ncol,nlay ) :: An, Cn - real(wp), dimension(ncol,nlay+1) :: gpt_flux_Jac - ! ------------------------------------ - ! Which way is up? - ! Level Planck sources for upward and downward radiation - ! When top_at_1, lev_source_up => lev_source_dec - ! lev_source_dn => lev_source_inc, and vice-versa - if(top_at_1) then - top_level = 1 - sfc_level = nlay+1 - lev_source_up => lev_source_dec - lev_source_dn => lev_source_inc - else - top_level = nlay+1 - sfc_level = 1 - lev_source_up => lev_source_inc - lev_source_dn => lev_source_dec - end if - - ! - ! Integrated fluxes need zeroing - ! - if(do_broadband) then - call zero_array(ncol, nlay+1, broadband_up ) - call zero_array(ncol, nlay+1, broadband_dn ) - end if - if(do_Jacobians) & - call zero_array(ncol, nlay+1, flux_upJac ) - - do igpt = 1, ngpt - if(do_broadband) then - gpt_flux_up => loc_flux_up - gpt_flux_dn => loc_flux_dn - else - gpt_flux_up => flux_up (:,:,igpt) - gpt_flux_dn => flux_dn (:,:,igpt) - end if - ! - ! Transport is for intensity - ! convert flux at top of domain to intensity assuming azimuthal isotropy - ! - gpt_flux_dn(:,top_level) = incident_flux(:,igpt)/(2._wp * pi * weight) - ! - ! Optical path and transmission, used in source function and transport calculations - ! - if (do_rescaling) then - ! - ! The scaling and scaleTau terms are independent of propagation - ! angle D and could be pre-computed if several values of D are used - ! We re-compute them here to keep not have to localize memory use - ! - do ilay = 1, nlay - do icol = 1, ncol - ssal = ssa(icol, ilay, igpt) - - ! w is the layer single scattering albedo - ! b is phase function parameter (Eq.13 of the paper) - ! for the similarity principle scaling scheme - ! b = (1-g)/2 (where g is phase function avergae cosine) - wb = ssal*(1._wp - g(icol, ilay, igpt)) * 0.5_wp - - ! scaleTau=1-w(1-b) is a scaling factor of the optical thickness representing - ! the radiative transfer equation in a nonscattering form Eq(14) of the paper - scaleTau = (1._wp - ssal + wb) - - ! Cn = 0.5*wb/(1-w(1-b)) is parameter of Eq.21-22 of the Tang paper - ! Tang paper, p.2222 advises to replace 0.5 with 0.4 based on simulations - Cn(icol,ilay) = 0.4_wp*wb/scaleTau - - ! Eqs.15, 18ab and 19 of the paper, - ! rescaling of the optical depth multiplied by path length - tau_loc(icol,ilay) = tau(icol,ilay,igpt)*D(icol,igpt)*scaleTau - end do - trans (:,ilay) = exp(-tau_loc(:,ilay)) - An(:,ilay) = (1._wp-trans(:,ilay)**2) - end do - else - do ilay = 1, nlay - tau_loc(:,ilay) = tau(:,ilay,igpt)*D(:,igpt) - trans (:,ilay) = exp(-tau_loc(:,ilay)) - end do - end if - ! - ! Source function for diffuse radiation - ! - call lw_source_noscat(ncol, nlay, & - lay_source(:,:,igpt), lev_source_up(:,:,igpt), lev_source_dn(:,:,igpt), & - tau_loc, trans, source_dn, source_up) - ! - ! Transport down - ! - call lw_transport_noscat_dn(ncol, nlay, top_at_1, trans, source_dn, gpt_flux_dn) - ! - ! Surface albedo, surface source function, reflection and emission - ! - sfc_albedo(:) = 1._wp - sfc_emis(:,igpt) - gpt_flux_up (:,sfc_level) = gpt_flux_dn(:,sfc_level)*sfc_albedo(:) + & - sfc_emis(:,igpt) * sfc_src (:,igpt) - if(do_Jacobians) & - gpt_flux_Jac(:,sfc_level) = sfc_emis(:,igpt) * sfc_srcJac(:,igpt) - ! - ! Transport up, or up and down again if using rescaling - ! - if(do_rescaling) then - call lw_transport_1rescl(ncol, nlay, top_at_1, trans, & - source_dn, source_up, & - gpt_flux_up, gpt_flux_dn, An, Cn, & - do_Jacobians, gpt_flux_Jac) ! Standing in for Jacobian, i.e. rad_up_Jac(:,:,igpt), rad_dn_Jac(:,:,igpt)) - else - call lw_transport_noscat_up(ncol, nlay, top_at_1, trans, source_up, gpt_flux_up, & - do_Jacobians, gpt_flux_Jac) - end if - - if(do_broadband) then - broadband_up(:,:) = broadband_up(:,:) + gpt_flux_up(:,:) - broadband_dn(:,:) = broadband_dn(:,:) + gpt_flux_dn(:,:) - else - ! - ! Convert intensity to flux assuming azimuthal isotropy and quadrature weight - ! - gpt_flux_dn(:,:) = 2._wp * pi * weight * gpt_flux_dn(:,:) - gpt_flux_up(:,:) = 2._wp * pi * weight * gpt_flux_up(:,:) - end if - ! - ! Only broadband-integrated Jacobians are provided - ! - if(do_Jacobians) & - flux_upJac(:,:) = flux_upJac(:,:) + gpt_flux_Jac(:,:) - end do ! g point loop - - if(do_broadband) then - broadband_up(:,:) = 2._wp * pi * weight* broadband_up(:,:) - broadband_dn(:,:) = 2._wp * pi * weight* broadband_dn(:,:) - end if - if(do_Jacobians) & - flux_upJac(:,:) = 2._wp * pi * weight * flux_upJac(:,:) - - end subroutine lw_solver_noscat_oneangle - ! ------------------------------------------------------------------------------------------------- - ! !> LW transport, no scattering, multi-angle quadrature !> Users provide a set of weights and quadrature angles !> Routine sums over single-angle solutions for each sets of angles/weights ! ! --------------------------------------------------------------- - subroutine lw_solver_noscat(ncol, nlay, ngpt, top_at_1, & - nmus, Ds, weights, & - tau, & - lay_source, lev_source_inc, lev_source_dec, & - sfc_emis, sfc_src, & - inc_flux, & - flux_up, flux_dn, & - do_broadband, broadband_up, broadband_dn, & - do_Jacobians, sfc_srcJac, flux_upJac, & - do_rescaling, ssa, g) bind(C, name="rte_lw_solver_noscat") - integer, intent(in ) :: ncol, nlay, ngpt - !! Number of columns, layers, g-points - logical(wl), intent(in ) :: top_at_1 - !! ilay = 1 is the top of the atmosphere? - integer, intent(in ) :: nmus - !! number of quadrature angles - real(wp), dimension (ncol, ngpt, & - nmus), intent(in ) :: Ds - !! quadrature secants - real(wp), dimension(nmus), intent(in ) :: weights - !! quadrature weights - real(wp), dimension(ncol,nlay, ngpt), intent(in ) :: tau - !! Absorption optical thickness [] - real(wp), dimension(ncol,nlay, ngpt), intent(in ) :: lay_source - !! Planck source at layer average temperature [W/m2] - real(wp), dimension(ncol,nlay, ngpt), intent(in ) :: lev_source_inc - !! Planck source at layer edge for radiation in increasing ilay direction [W/m2] - real(wp), dimension(ncol,nlay, ngpt), intent(in ) :: lev_source_dec - !! Planck source at layer edge for radiation in decreasing ilay direction [W/m2] - real(wp), dimension(ncol, ngpt), intent(in ) :: sfc_emis - !! Surface emissivity [] - real(wp), dimension(ncol, ngpt), intent(in ) :: sfc_src - !! Surface source function [W/m2] - real(wp), dimension(ncol, ngpt), intent(in ) :: inc_flux - !! Incident diffuse flux, probably 0 [W/m2] - real(wp), dimension(ncol,nlay+1,ngpt), target, & - intent( out) :: flux_up, flux_dn - !! Fluxes [W/m2] - ! - ! Optional variables - arrays aren't referenced if corresponding logical == False - ! - logical(wl), intent(in ) :: do_broadband - real(wp), dimension(ncol,nlay+1 ), target, & - intent( out) :: broadband_up, broadband_dn - !! Spectrally-integrated fluxes [W/m2] - logical(wl), intent(in ) :: do_Jacobians - !! compute Jacobian with respect to surface temeprature? - real(wp), dimension(ncol ,ngpt), intent(in ) :: sfc_srcJac - !! surface temperature Jacobian of surface source function [W/m2/K] - real(wp), dimension(ncol,nlay+1 ), target, & - intent( out) :: flux_upJac - !! surface temperature Jacobian of Radiances [W/m2-str / K] - logical(wl), intent(in ) :: do_rescaling - !! Approximate treatment of scattering (10.1175/JAS-D-18-0014.1) - real(wp), dimension(ncol,nlay ,ngpt), intent(in ) :: ssa, g - !! single-scattering albedo, asymmetry parameter - ! ------------------------------------ - ! - ! Local variables - used for a single quadrature angle - ! - real(wp), dimension(:,:,:), pointer :: this_flux_up, this_flux_dn - real(wp), dimension(:,:), pointer :: this_broadband_up, this_broadband_dn, this_flux_upJac - - integer :: imu - ! ------------------------------------ - ! - ! For the first angle output arrays store total flux - ! - call lw_solver_noscat_oneangle(ncol, nlay, ngpt, & - top_at_1, Ds(:,:,1), weights(1), tau, & - lay_source, lev_source_inc, lev_source_dec, sfc_emis, sfc_src, & - inc_flux, & - flux_up, flux_dn, & - do_broadband, broadband_up, broadband_dn, & - do_Jacobians, sfc_srcJac, flux_upJac, & - do_rescaling, ssa, g) - ! - ! For more than one angle use local arrays - ! - if(nmus > 1) then - if(do_broadband) then - allocate(this_broadband_up(ncol,nlay+1), this_broadband_dn(ncol,nlay+1)) - ! Spectrally-resolved fluxes won't be filled in so can point to caller-supplied memory - this_flux_up => flux_up - this_flux_dn => flux_dn - else - allocate(this_flux_up(ncol,nlay+1,ngpt), this_flux_dn(ncol,nlay+1,ngpt)) - ! Spectrally-integrated fluxes won't be filled in so can point to caller-supplied memory - this_broadband_up => broadband_up - this_broadband_dn => broadband_dn - end if - if(do_Jacobians) then - allocate(this_flux_upJac(ncol,nlay+1)) - else - this_flux_upJac => flux_upJac - end if - end if - do imu = 2, nmus - call lw_solver_noscat_oneangle(ncol, nlay, ngpt, & - top_at_1, Ds(:,:,imu), weights(imu), tau, & - lay_source, lev_source_inc, lev_source_dec, sfc_emis, sfc_src, & - inc_flux, & - this_flux_up, this_flux_dn, & - do_broadband, this_broadband_up, this_broadband_dn, & - do_Jacobians, sfc_srcJac, this_flux_upJac, & - do_rescaling, ssa, g) - if(do_broadband) then - broadband_up(:,:) = broadband_up(:,:) + this_broadband_up(:,:) - broadband_dn(:,:) = broadband_dn(:,:) + this_broadband_dn(:,:) - else - flux_up (:,:,:) = flux_up (:,:,:) + this_flux_up (:,:,:) - flux_dn (:,:,:) = flux_dn (:,:,:) + this_flux_dn (:,:,:) - end if - if (do_Jacobians) & - flux_upJac(:,:) = flux_upJac(:,: ) + this_flux_upJac(:,: ) - end do - if(nmus > 1) then - if( do_broadband) deallocate(this_broadband_up, this_broadband_dn) - if(.not. do_broadband) deallocate(this_flux_up, this_flux_dn) - if( do_Jacobians) deallocate(this_flux_upJac) - end if - end subroutine lw_solver_noscat + interface + subroutine lw_solver_noscat(ncol, nlay, ngpt, top_at_1, & + nmus, Ds, weights, & + tau, & + lay_source, lev_source, & + sfc_emis, sfc_src, & + inc_flux, & + flux_up, flux_dn, & + do_broadband, broadband_up, broadband_dn, & + do_Jacobians, sfc_srcJac, flux_upJac, & + do_rescaling, ssa, g) bind(C, name="rte_lw_solver_noscat") + use mo_rte_kind, only: wp, wl + integer, intent(in ) :: ncol, nlay, ngpt + !! Number of columns, layers, g-points + logical(wl), intent(in ) :: top_at_1 + !! ilay = 1 is the top of the atmosphere? + integer, intent(in ) :: nmus + !! number of quadrature angles + real(wp), dimension (ncol, ngpt, & + nmus), intent(in ) :: Ds + !! quadrature secants + real(wp), dimension(nmus), intent(in ) :: weights + !! quadrature weights + real(wp), dimension(ncol,nlay, ngpt), intent(in ) :: tau + !! Absorption optical thickness [] + real(wp), dimension(ncol,nlay, ngpt), intent(in ) :: lay_source + !! Planck source at layer average temperature [W/m2] + real(wp), dimension(ncol,nlay+1,ngpt), intent(in ) :: lev_source + !! Planck source at layer edge for radiation [W/m2] + real(wp), dimension(ncol, ngpt), intent(in ) :: sfc_emis + !! Surface emissivity [] + real(wp), dimension(ncol, ngpt), intent(in ) :: sfc_src + !! Surface source function [W/m2] + real(wp), dimension(ncol, ngpt), intent(in ) :: inc_flux + !! Incident diffuse flux, probably 0 [W/m2] + real(wp), dimension(ncol,nlay+1,ngpt), target, & + intent( out) :: flux_up, flux_dn + !! Fluxes [W/m2] + ! + ! Optional variables - arrays aren't referenced if corresponding logical == False + ! + logical(wl), intent(in ) :: do_broadband + real(wp), dimension(ncol,nlay+1 ), target, & + intent( out) :: broadband_up, broadband_dn + !! Spectrally-integrated fluxes [W/m2] + logical(wl), intent(in ) :: do_Jacobians + !! compute Jacobian with respect to surface temeprature? + real(wp), dimension(ncol ,ngpt), intent(in ) :: sfc_srcJac + !! surface temperature Jacobian of surface source function [W/m2/K] + real(wp), dimension(ncol,nlay+1 ), target, & + intent( out) :: flux_upJac + !! surface temperature Jacobian of Radiances [W/m2-str / K] + logical(wl), intent(in ) :: do_rescaling + !! Approximate treatment of scattering (10.1175/JAS-D-18-0014.1) + real(wp), dimension(ncol,nlay ,ngpt), intent(in ) :: ssa, g + !! single-scattering albedo, asymmetry parameter + end subroutine lw_solver_noscat + end interface ! ------------------------------------------------------------------------------------------------- ! !> Longwave two-stream calculation: @@ -389,80 +104,33 @@ end subroutine lw_solver_noscat !> - transport ! ! ------------------------------------------------------------------------------------------------- - subroutine lw_solver_2stream (ncol, nlay, ngpt, top_at_1, & - tau, ssa, g, & - lay_source, lev_source_inc, lev_source_dec, sfc_emis, sfc_src, & - inc_flux, & - flux_up, flux_dn) bind(C, name="rte_lw_solver_2stream") - integer, intent(in ) :: ncol, nlay, ngpt - !! Number of columns, layers, g-points - logical(wl), intent(in ) :: top_at_1 - !! ilay = 1 is the top of the atmosphere? - real(wp), dimension(ncol,nlay, ngpt), intent(in ) :: tau, ssa, g - !! Optical thickness, single-scattering albedo, asymmetry parameter [] - real(wp), dimension(ncol,nlay, ngpt), intent(in ) :: lay_source - !! Planck source at layer average temperature [W/m2] - real(wp), dimension(ncol,nlay, ngpt), intent(in ) :: lev_source_inc - !! Planck source at layer edge for radiation in increasing ilay direction [W/m2] - real(wp), dimension(ncol,nlay, ngpt), intent(in ) :: lev_source_dec - !! Planck source at layer edge for radiation in decreasing ilay direction [W/m2] - real(wp), dimension(ncol, ngpt), intent(in ) :: sfc_emis - !! Surface emissivity [] - real(wp), dimension(ncol, ngpt), intent(in ) :: sfc_src - !! Surface source function [W/m2] - real(wp), dimension(ncol, ngpt), intent(in ) :: inc_flux - !! Incident diffuse flux, probably 0 [W/m2] - real(wp), dimension(ncol,nlay+1,ngpt), intent( out) :: flux_up, flux_dn - !! Fluxes [W/m2] - ! ---------------------------------------------------------------------- - integer :: igpt, top_level - real(wp), dimension(ncol,nlay ) :: Rdif, Tdif, gamma1, gamma2 - real(wp), dimension(ncol ) :: sfc_albedo - real(wp), dimension(ncol,nlay+1) :: lev_source - real(wp), dimension(ncol,nlay ) :: source_dn, source_up - real(wp), dimension(ncol ) :: source_sfc - ! ------------------------------------ - top_level = nlay+1 - if(top_at_1) top_level = 1 - do igpt = 1, ngpt - ! - ! RRTMGP provides source functions at each level using the spectral mapping - ! of each adjacent layer. Combine these for two-stream calculations - ! - call lw_combine_sources(ncol, nlay, top_at_1, & - lev_source_inc(:,:,igpt), lev_source_dec(:,:,igpt), & - lev_source) - ! - ! Cell properties: reflection, transmission for diffuse radiation - ! Coupling coefficients needed for source function - ! - call lw_two_stream(ncol, nlay, & - tau (:,:,igpt), ssa(:,:,igpt), g(:,:,igpt), & - gamma1, gamma2, Rdif, Tdif) - ! - ! Source function for diffuse radiation - ! - call lw_source_2str(ncol, nlay, top_at_1, & - sfc_emis(:,igpt), sfc_src(:,igpt), & - lay_source(:,:,igpt), lev_source, & - gamma1, gamma2, Rdif, Tdif, tau(:,:,igpt), & - source_dn, source_up, source_sfc) - ! - ! Transport - ! - sfc_albedo(1:ncol) = 1._wp - sfc_emis(:,igpt) - ! - ! Boundary condition - ! - flux_dn(:,top_level,igpt) = inc_flux(:,igpt) - call adding(ncol, nlay, top_at_1, & - sfc_albedo, & - Rdif, Tdif, & - source_dn, source_up, source_sfc, & - flux_up(:,:,igpt), flux_dn(:,:,igpt)) - end do - - end subroutine lw_solver_2stream + interface + subroutine lw_solver_2stream (ncol, nlay, ngpt, top_at_1, & + tau, ssa, g, & + lay_source, lev_source, sfc_emis, sfc_src, & + inc_flux, & + flux_up, flux_dn) bind(C, name="rte_lw_solver_2stream") + use mo_rte_kind, only: wp, wl + integer, intent(in ) :: ncol, nlay, ngpt + !! Number of columns, layers, g-points + logical(wl), intent(in ) :: top_at_1 + !! ilay = 1 is the top of the atmosphere? + real(wp), dimension(ncol,nlay, ngpt), intent(in ) :: tau, ssa, g + !! Optical thickness, single-scattering albedo, asymmetry parameter [] + real(wp), dimension(ncol,nlay, ngpt), intent(in ) :: lay_source + !! Planck source at layer average temperature [W/m2] + real(wp), dimension(ncol,nlay+1,ngpt), intent(in ) :: lev_source + !! Planck source at layer edge for radiation [W/m2] + real(wp), dimension(ncol, ngpt), intent(in ) :: sfc_emis + !! Surface emissivity [] + real(wp), dimension(ncol, ngpt), intent(in ) :: sfc_src + !! Surface source function [W/m2] + real(wp), dimension(ncol, ngpt), intent(in ) :: inc_flux + !! Incident diffuse flux, probably 0 [W/m2] + real(wp), dimension(ncol,nlay+1,ngpt), intent( out) :: flux_up, flux_dn + !! Fluxes [W/m2] + end subroutine lw_solver_2stream + end interface ! ------------------------------------------------------------------------------------------------- ! ! Top-level shortwave kernels @@ -472,51 +140,23 @@ end subroutine lw_solver_2stream ! !> Extinction-only shortwave solver i.e. solar direct beam ! ! ------------------------------------------------------------------------------------------------- - pure subroutine sw_solver_noscat(ncol, nlay, ngpt, top_at_1, & - tau, mu0, inc_flux_dir, flux_dir) bind(C, name="rte_sw_solver_noscat") - integer, intent(in ) :: ncol, nlay, ngpt ! Number of columns, layers, g-points - !! Number of columns, layers, g-points - logical(wl), intent(in ) :: top_at_1 - !! ilay = 1 is the top of the atmosphere? - real(wp), dimension(ncol,nlay, ngpt), intent(in ) :: tau - !! Absorption optical thickness [] - real(wp), dimension(ncol,nlay ), intent(in ) :: mu0 - !! cosine of solar zenith angle - real(wp), dimension(ncol, ngpt), intent(in ) :: inc_flux_dir - !! Direct beam incident flux [W/m2] - real(wp), dimension(ncol,nlay+1,ngpt), intent(out) :: flux_dir - !! Direct-beam flux, spectral [W/m2] - - integer :: ilev, igpt - - ! ------------------------------------ - ! Indexing into arrays for upward and downward propagation depends on the vertical - ! orientation of the arrays (whether the domain top is at the first or last index) - ! We write the loops out explicitly so compilers will have no trouble optimizing them. - - ! Downward propagation - if(top_at_1) then - ! For the flux at this level, what was the previous level, and which layer has the - ! radiation just passed through? - ! layer index = level index - 1 - ! previous level is up (-1) - do igpt = 1, ngpt - flux_dir(:, 1,igpt) = inc_flux_dir(:,igpt) * mu0(:,1) - do ilev = 2, nlay+1 - flux_dir(:,ilev,igpt) = flux_dir(:,ilev-1,igpt) * exp(-tau(:,ilev-1,igpt)/mu0(:,ilev-1)) - end do - end do - else - ! layer index = level index - ! previous level is up (+1) - do igpt = 1, ngpt - flux_dir(:,nlay+1,igpt) = inc_flux_dir(:,igpt) * mu0(:,nlay) - do ilev = nlay, 1, -1 - flux_dir(:,ilev,igpt) = flux_dir(:,ilev+1,igpt) * exp(-tau(:,ilev,igpt)/mu0(:,ilev)) - end do - end do - end if - end subroutine sw_solver_noscat + interface + pure subroutine sw_solver_noscat(ncol, nlay, ngpt, top_at_1, & + tau, mu0, inc_flux_dir, flux_dir) bind(C, name="rte_sw_solver_noscat") + use mo_rte_kind, only: wp, wl + integer, intent(in ) :: ncol, nlay, ngpt ! Number of columns, layers, g-points + !! Number of columns, layers, g-points + logical(wl), intent(in ) :: top_at_1 + !! ilay = 1 is the top of the atmosphere? + real(wp), dimension(ncol,nlay, ngpt), intent(in ) :: tau + !! Absorption optical thickness [] + real(wp), dimension(ncol,nlay ), intent(in ) :: mu0 + !! cosine of solar zenith angle + real(wp), dimension(ncol, ngpt), intent(in ) :: inc_flux_dir + !! Direct beam incident flux [W/m2] + real(wp), dimension(ncol,nlay+1,ngpt), intent(out) :: flux_dir + end subroutine sw_solver_noscat + end interface ! ------------------------------------------------------------------------------------------------- ! !> Shortwave two-stream calculation: @@ -525,756 +165,38 @@ end subroutine sw_solver_noscat !> transport ! ! ------------------------------------------------------------------------------------------------- - subroutine sw_solver_2stream (ncol, nlay, ngpt, top_at_1, & - tau, ssa, g, mu0, & - sfc_alb_dir, sfc_alb_dif, & - inc_flux_dir, & - flux_up, flux_dn, flux_dir, & - has_dif_bc, inc_flux_dif, & - do_broadband, broadband_up, & - broadband_dn, broadband_dir) bind(C, name="rte_sw_solver_2stream") - integer, intent(in ) :: ncol, nlay, ngpt - !! Number of columns, layers, g-points - logical(wl), intent(in ) :: top_at_1 - !! ilay = 1 is the top of the atmosphere? - real(wp), dimension(ncol,nlay, ngpt), intent(in ) :: tau, ssa, g - !! Optical thickness, single-scattering albedo, asymmetry parameter [] - real(wp), dimension(ncol,nlay ), intent(in ) :: mu0 - !! cosine of solar zenith angle - real(wp), dimension(ncol, ngpt), intent(in ) :: sfc_alb_dir, sfc_alb_dif - !! Spectral surface albedo for direct and diffuse radiation - real(wp), dimension(ncol, ngpt), intent(in ) :: inc_flux_dir - !! Direct beam incident flux - real(wp), dimension(ncol,nlay+1,ngpt), target, & - intent( out) :: flux_up, flux_dn, flux_dir - !! Fluxes [W/m2] - logical(wl), intent(in ) :: has_dif_bc - !! Is a boundary condition for diffuse flux supplied? - real(wp), dimension(ncol, ngpt), intent(in ) :: inc_flux_dif - !! Boundary condition for diffuse flux [W/m2] - logical(wl), intent(in ) :: do_broadband - !! Provide broadband-integrated, not spectrally-resolved, fluxes? - real(wp), dimension(ncol,nlay+1 ), intent( out) :: broadband_up, broadband_dn, broadband_dir - !! Broadband integrated fluxes - ! ------------------------------------------- - integer :: igpt, top_level, top_layer - real(wp), dimension(ncol,nlay ) :: Rdif, Tdif - real(wp), dimension(ncol,nlay ) :: source_up, source_dn - real(wp), dimension(ncol ) :: source_srf - ! loc_fluxes hold a single g-point flux if fluxes are being integrated instead of returned - ! with spectral detail - real(wp), dimension(ncol,nlay+1), & - target :: loc_flux_up, loc_flux_dn, loc_flux_dir - ! gpt_fluxes point to calculations for the current g-point - real(wp), dimension(:,:), pointer :: gpt_flux_up, gpt_flux_dn, gpt_flux_dir - ! ------------------------------------ - if(top_at_1) then - top_level = 1 - top_layer = 1 - else - top_level = nlay+1 - top_layer = nlay - end if - ! - ! Integrated fluxes need zeroing - ! - if(do_broadband) then - call zero_array(ncol, nlay+1, broadband_up ) - call zero_array(ncol, nlay+1, broadband_dn ) - call zero_array(ncol, nlay+1, broadband_dir) - end if - - do igpt = 1, ngpt - if(do_broadband) then - gpt_flux_up => loc_flux_up - gpt_flux_dn => loc_flux_dn - gpt_flux_dir => loc_flux_dir - else - gpt_flux_up => flux_up (:,:,igpt) - gpt_flux_dn => flux_dn (:,:,igpt) - gpt_flux_dir => flux_dir(:,:,igpt) - end if - ! - ! Boundary conditions direct beam... - ! - gpt_flux_dir(:,top_level) = inc_flux_dir(:,igpt) * mu0(:,top_layer) - ! - ! ... and diffuse field, using 0 if no BC is provided - ! - if(has_dif_bc) then - gpt_flux_dn(:,top_level) = inc_flux_dif(:,igpt) - else - gpt_flux_dn(:,top_level) = 0._wp - end if - ! - ! Cell properties: transmittance and reflectance for diffuse radiation - ! Direct-beam and source for diffuse radiation - ! - call sw_dif_and_source(ncol, nlay, top_at_1, mu0, sfc_alb_dir(:,igpt), & - tau(:,:,igpt), ssa(:,:,igpt), g(:,:,igpt), & - Rdif, Tdif, source_dn, source_up, source_srf, & - gpt_flux_dir) - ! - ! Transport - ! - call adding(ncol, nlay, top_at_1, & - sfc_alb_dif(:,igpt), Rdif, Tdif, & - source_dn, source_up, source_srf, gpt_flux_up, gpt_flux_dn) - ! - ! adding() computes only diffuse flux; flux_dn is total - ! - if(do_broadband) then - broadband_up (:,:) = broadband_up (:,:) + gpt_flux_up (:,:) - broadband_dn (:,:) = broadband_dn (:,:) + gpt_flux_dn (:,:) + gpt_flux_dir(:,:) - broadband_dir(:,:) = broadband_dir(:,:) + gpt_flux_dir(:,:) - else - gpt_flux_dn(:,:) = gpt_flux_dn (:,:) + gpt_flux_dir(:,:) - end if - end do - end subroutine sw_solver_2stream - ! ------------------------------------------------------------------------------------------------- - ! - ! Lower-level longwave kernels - ! - ! ------------------------------------------------------------------------------------------------- - ! - ! Compute LW source function for upward and downward emission at levels using linear-in-tau assumption - ! See Clough et al., 1992, doi: 10.1029/92JD01419, Eq 13 - ! - ! --------------------------------------------------------------- - subroutine lw_source_noscat(ncol, nlay, lay_source, lev_source_up, lev_source_dn, tau, trans, & - source_dn, source_up) - integer, intent(in) :: ncol, nlay - real(wp), dimension(ncol, nlay), intent(in) :: lay_source, & ! Planck source at layer center - lev_source_up, & ! Planck source at levels (layer edges), - lev_source_dn, & ! increasing/decreasing layer index - tau, & ! Optical path (tau/mu) - trans ! Transmissivity (exp(-tau)) - real(wp), dimension(ncol, nlay), intent(out):: source_dn, source_up - ! Source function at layer edges - ! Down at the bottom of the layer, up at the top - ! -------------------------------- - integer :: icol, ilay - real(wp) :: fact - real(wp), parameter :: tau_thresh = sqrt(sqrt(epsilon(tau))) - ! --------------------------------------------------------------- - do ilay = 1, nlay - do icol = 1, ncol - ! - ! Weighting factor. Use 2nd order series expansion when rounding error (~tau^2) - ! is of order epsilon (smallest difference from 1. in working precision) - ! Thanks to Peter Blossey - ! Updated to 3rd order series and lower threshold based on suggestion from Dmitry Alexeev (Nvidia) - ! - if(tau(icol, ilay) > tau_thresh) then - fact = (1._wp - trans(icol,ilay))/tau(icol,ilay) - trans(icol,ilay) - else - fact = tau(icol, ilay) * (0.5_wp + tau(icol, ilay) * (- 1._wp/3._wp + tau(icol, ilay) * 1._wp/8._wp ) ) - end if - ! - ! Equation below is developed in Clough et al., 1992, doi:10.1029/92JD01419, Eq 13 - ! - source_dn(icol,ilay) = (1._wp - trans(icol,ilay)) * lev_source_dn(icol,ilay) + & - 2._wp * fact * (lay_source(icol,ilay) - lev_source_dn(icol,ilay)) - source_up(icol,ilay) = (1._wp - trans(icol,ilay)) * lev_source_up(icol,ilay ) + & - 2._wp * fact * (lay_source(icol,ilay) - lev_source_up(icol,ilay)) - end do - end do - end subroutine lw_source_noscat - ! ------------------------------------------------------------------------------------------------- - ! - ! Longwave no-scattering transport - separate routines for up and down - ! - ! ------------------------------------------------------------------------------------------------- - subroutine lw_transport_noscat_dn(ncol, nlay, top_at_1, & - trans, source_dn, radn_dn) - integer, intent(in ) :: ncol, nlay ! Number of columns, layers, g-points - logical(wl), intent(in ) :: top_at_1 ! - real(wp), dimension(ncol,nlay ), intent(in ) :: trans ! transmissivity = exp(-tau) - real(wp), dimension(ncol,nlay ), intent(in ) :: source_dn ! Diffuse radiation emitted by the layer - real(wp), dimension(ncol,nlay+1), intent(inout) :: radn_dn ! Radiances [W/m2-str] Top level must contain incident flux boundary condition - - ! --------------------------------------------------- - ! Local variables - integer :: ilev - ! --------------------------------------------------- - if(top_at_1) then - ! - ! Top of domain is index 1 - ! - do ilev = 2, nlay+1 - radn_dn(:,ilev) = trans(:,ilev-1)*radn_dn(:,ilev-1) + source_dn(:,ilev-1) - end do - else - ! - ! Top of domain is index nlay+1 - ! - do ilev = nlay, 1, -1 - radn_dn(:,ilev) = trans(:,ilev )*radn_dn(:,ilev+1) + source_dn(:,ilev) - end do - end if - end subroutine lw_transport_noscat_dn - ! ------------------------------------------------------------------------------------------------- - subroutine lw_transport_noscat_up(ncol, nlay, top_at_1, & - trans, source_up, radn_up, do_Jacobians, radn_upJac) - integer, intent(in ) :: ncol, nlay ! Number of columns, layers, g-points - logical(wl), intent(in ) :: top_at_1 ! - real(wp), dimension(ncol,nlay ), intent(in ) :: trans ! transmissivity = exp(-tau) - real(wp), dimension(ncol,nlay ), intent(in ) :: source_up ! Diffuse radiation emitted by the layer - real(wp), dimension(ncol,nlay+1), intent(inout) :: radn_up ! Radiances [W/m2-str] Top level must contain incident flux boundary condition - logical(wl), intent(in ) :: do_Jacobians - real(wp), dimension(ncol,nlay+1), intent(inout) :: radn_upJac ! surface temperature Jacobian of Radiances [W/m2-str / K] - - ! --------------------------------------------------- - ! Local variables - integer :: ilev - ! --------------------------------------------------- - if(top_at_1) then - ! - ! Top of domain is index 1 - ! - ! Upward propagation - do ilev = nlay, 1, -1 - radn_up (:,ilev) = trans(:,ilev )*radn_up (:,ilev+1) + source_up(:,ilev) - if(do_Jacobians) & - radn_upJac(:,ilev) = trans(:,ilev )*radn_upJac(:,ilev+1) - end do - else - ! - ! Top of domain is index nlay+1 - ! - ! Upward propagation - do ilev = 2, nlay+1 - radn_up (:,ilev) = trans(:,ilev-1) * radn_up (:,ilev-1) + source_up(:,ilev-1) - if(do_Jacobians) & - radn_upJac(:,ilev) = trans(:,ilev-1) * radn_upJac(:,ilev-1) - end do - end if - end subroutine lw_transport_noscat_up - ! ------------------------------------------------------------------------------------------------- - ! Upward and (second) downward transport for re-scaled longwave solution - ! adds adjustment factor based on cloud properties - ! - ! implementation notice: - ! the adjustmentFactor computation can be skipped where Cn <= epsilon - ! ------------------------------------------------------------------------------------------------- - subroutine lw_transport_1rescl(ncol, nlay, top_at_1, & - trans, source_dn, source_up, & - radn_up, radn_dn, An, Cn,& - do_Jacobians, radn_up_Jac) - integer, intent(in ) :: ncol, nlay ! Number of columns, layers, g-points - logical(wl), intent(in ) :: top_at_1 ! - real(wp), dimension(ncol,nlay ), intent(in ) :: trans ! transmissivity = exp(-tau) - real(wp), dimension(ncol,nlay ), intent(in ) :: source_dn, & - source_up ! Diffuse radiation emitted by the layer - real(wp), dimension(ncol,nlay+1), intent(inout) :: radn_up ! Radiances [W/m2-str] - real(wp), dimension(ncol,nlay+1), intent(inout) :: radn_dn !Top level must contain incident flux boundary condition - real(wp), dimension(ncol,nlay), intent(in ) :: An, Cn - logical(wl), intent(in ) :: do_Jacobians - real(wp), dimension(ncol,nlay+1), intent(inout) :: radn_up_Jac ! Surface temperature Jacobians [W/m2-str/K] - ! - ! We could in principle compute a downwelling Jacobian too, but it's small - ! (only a small proportion of LW is scattered) and it complicates code and the API, - ! so we will not - ! - - ! Local variables - integer :: ilev, icol - ! --------------------------------------------------- - real(wp) :: adjustmentFactor - if(top_at_1) then - ! - ! Top of domain is index 1 - ! - ! Upward propagation - ! adjustment factor is obtained as a solution of 18b of the Tang paper - ! eqvivalent to Eq.20 of the Tang paper but for linear-in-tau source - do ilev = nlay, 1, -1 - do icol=1,ncol - adjustmentFactor = Cn(icol,ilev)*( An(icol,ilev)*radn_dn(icol,ilev) - & - trans(icol,ilev)*source_dn(icol,ilev) - source_up(icol,ilev) ) - radn_up (icol,ilev) = trans(icol,ilev)*radn_up(icol,ilev+1) + source_up(icol,ilev) + & - adjustmentFactor - end do - if(do_Jacobians) & - radn_up_Jac(:,ilev) = trans(:,ilev)*radn_up_Jac(:,ilev+1) - end do - ! Downward propagation - ! radn_dn_Jac(:,1) = 0._wp - ! adjustment factor is obtained as a solution of 19 of the Tang paper - ! eqvivalent to Eq.21 of the Tang paper but for linear-in-tau source - do ilev = 1, nlay - ! radn_dn_Jac(:,ilev+1) = trans(:,ilev)*radn_dn_Jac(:,ilev) - do icol=1,ncol - adjustmentFactor = Cn(icol,ilev)*( An(icol,ilev)*radn_up(icol,ilev) - & - trans(icol,ilev)*source_up(icol,ilev) - source_dn(icol,ilev) ) - radn_dn(icol,ilev+1) = trans(icol,ilev)*radn_dn(icol,ilev) + source_dn(icol,ilev) + & - adjustmentFactor - ! adjustmentFactor = Cn(icol,ilev)*An(icol,ilev)*radn_up_Jac(icol,ilev) - ! radn_dn_Jac(icol,ilev+1) = radn_dn_Jac(icol,ilev+1) + adjustmentFactor - enddo - end do - else - ! - ! Top of domain is index nlay+1 - ! - ! Upward propagation - ! adjustment factor is obtained as a solution of 18b of the Tang paper - ! eqvivalent to Eq.20 of the Tang paper but for linear-in-tau source - do ilev = 1, nlay - radn_up (:,ilev+1) = trans(:,ilev) * radn_up (:,ilev) + source_up(:,ilev) - do icol=1,ncol - adjustmentFactor = Cn(icol,ilev)*( An(icol,ilev)*radn_dn(icol,ilev+1) - & - trans(icol,ilev)*source_dn(icol,ilev) - source_up(icol,ilev) ) - radn_up(icol,ilev+1) = trans(icol,ilev)*radn_up(icol,ilev) + source_up(icol,ilev) + & - adjustmentFactor - enddo - if(do_Jacobians) & - radn_up_Jac(:,ilev+1) = trans(:,ilev) * radn_up_Jac(:,ilev) - end do - - ! Downward propagation - ! adjustment factor is obtained as a solution of 19 of the Tang paper - ! eqvivalent to Eq.21 of the Tang paper but for linear-in-tau source - ! radn_dn_Jac(:,nlay+1) = 0._wp - do ilev = nlay, 1, -1 - ! radn_dn_Jac(:,ilev) = trans(:,ilev)*radn_dn_Jac(:,ilev+1) - do icol=1,ncol - adjustmentFactor = Cn(icol,ilev)*( An(icol,ilev)*radn_up(icol,ilev) - & - trans(icol,ilev)*source_up(icol,ilev) - source_dn(icol,ilev) ) - radn_dn(icol,ilev) = trans(icol,ilev)*radn_dn(icol,ilev+1) + source_dn(icol,ilev) + & - adjustmentFactor - ! adjustmentFactor = Cn(icol,ilev)*An(icol,ilev)*radn_up_Jac(icol,ilev) - ! radn_dn_Jac(icol,ilev) = radn_dn_Jac(icol,ilev) + adjustmentFactor - enddo - end do - end if - end subroutine lw_transport_1rescl -! ------------------------------------------------------------------------------------------------- - ! - ! Longwave two-stream solutions to diffuse reflectance and transmittance for a layer - ! with optical depth tau, single scattering albedo w0, and asymmetery parameter g. - ! - ! Equations are developed in Meador and Weaver, 1980, - ! doi:10.1175/1520-0469(1980)037<0630:TSATRT>2.0.CO;2 - ! - ! ------------------------------------------------------------------------------------------------- - pure subroutine lw_two_stream(ncol, nlay, tau, w0, g, & - gamma1, gamma2, Rdif, Tdif) - integer, intent(in) :: ncol, nlay - real(wp), dimension(ncol,nlay), intent(in) :: tau, w0, g - real(wp), dimension(ncol,nlay), intent(out) :: gamma1, gamma2, Rdif, Tdif - - ! ----------------------- - integer :: i, j - - ! Variables used in Meador and Weaver - real(wp) :: k(ncol) - - ! Ancillary variables - real(wp) :: RT_term(ncol) - real(wp) :: exp_minusktau(ncol), exp_minus2ktau(ncol) - - real(wp), parameter :: LW_diff_sec = 1.66 ! 1./cos(diffusivity angle) - ! --------------------------------- - do j = 1, nlay - do i = 1, ncol - ! - ! Coefficients differ from SW implementation because the phase function is more isotropic - ! Here we follow Fu et al. 1997, doi:10.1175/1520-0469(1997)054<2799:MSPITI>2.0.CO;2 - ! and use a diffusivity sec of 1.66 - ! - gamma1(i,j)= LW_diff_sec * (1._wp - 0.5_wp * w0(i,j) * (1._wp + g(i,j))) ! Fu et al. Eq 2.9 - gamma2(i,j)= LW_diff_sec * 0.5_wp * w0(i,j) * (1._wp - g(i,j)) ! Fu et al. Eq 2.10 - ! Eq 18; k = SQRT(gamma1**2 - gamma2**2), limited below to avoid div by 0. - ! k = 0 for isotropic, conservative scattering; this lower limit on k - ! gives relative error with respect to conservative solution - ! of < 0.1% in Rdif down to tau = 10^-9 - k(i) = sqrt(max((gamma1(i,j) - gamma2(i,j)) * (gamma1(i,j) + gamma2(i,j)), 1.e-12_wp)) - end do - - ! Written to encourage vectorization of exponential - exp_minusktau(1:ncol) = exp(-tau(1:ncol,j)*k(1:ncol)) - - ! - ! Diffuse reflection and transmission - ! - do i = 1, ncol - exp_minus2ktau(i) = exp_minusktau(i) * exp_minusktau(i) - - ! Refactored to avoid rounding errors when k, gamma1 are of very different magnitudes - RT_term(i) = 1._wp / (k (i ) * (1._wp + exp_minus2ktau(i)) + & - gamma1(i,j) * (1._wp - exp_minus2ktau(i)) ) - - ! Equation 25 - Rdif(i,j) = RT_term(i) * gamma2(i,j) * (1._wp - exp_minus2ktau(i)) - - ! Equation 26 - Tdif(i,j) = RT_term(i) * 2._wp * k(i) * exp_minusktau(i) - end do - - end do - end subroutine lw_two_stream - ! ------------------------------------------------------------------------------------------------- - ! - ! Source function combination - ! RRTMGP provides two source functions at each level - ! using the spectral mapping from each of the adjascent layers. - ! Need to combine these for use in two-stream calculation. - ! - ! ------------------------------------------------------------------------------------------------- - subroutine lw_combine_sources(ncol, nlay, top_at_1, & - lev_src_inc, lev_src_dec, lev_source) - integer, intent(in ) :: ncol, nlay - logical(wl), intent(in ) :: top_at_1 - real(wp), dimension(ncol, nlay ), intent(in ) :: lev_src_inc, lev_src_dec - real(wp), dimension(ncol, nlay+1), intent(out) :: lev_source - - integer :: icol, ilay - ! --------------------------------------------------------------- - ilay = 1 - do icol = 1,ncol - lev_source(icol, ilay) = lev_src_dec(icol, ilay) - end do - do ilay = 2, nlay - do icol = 1,ncol - lev_source(icol, ilay) = sqrt(lev_src_dec(icol, ilay) * & - lev_src_inc(icol, ilay-1)) - end do - end do - ilay = nlay+1 - do icol = 1,ncol - lev_source(icol, ilay) = lev_src_inc(icol, ilay-1) - end do - - end subroutine lw_combine_sources - ! --------------------------------------------------------------- - ! - ! Compute LW source function for upward and downward emission at levels using linear-in-tau assumption - ! This version straight from ECRAD - ! Source is provided as W/m2-str; factor of pi converts to flux units - ! - ! --------------------------------------------------------------- - subroutine lw_source_2str(ncol, nlay, top_at_1, & - sfc_emis, sfc_src, & - lay_source, lev_source, & - gamma1, gamma2, rdif, tdif, tau, source_dn, source_up, source_sfc) & - bind (C, name="rte_lw_source_2str") - integer, intent(in) :: ncol, nlay - logical(wl), intent(in) :: top_at_1 - real(wp), dimension(ncol ), intent(in) :: sfc_emis, sfc_src - real(wp), dimension(ncol, nlay), intent(in) :: lay_source, & ! Planck source at layer center - tau, & ! Optical depth (tau) - gamma1, gamma2,& ! Coupling coefficients - rdif, tdif ! Layer reflectance and transmittance - real(wp), dimension(ncol, nlay+1), target, & - intent(in) :: lev_source ! Planck source at layer edges - real(wp), dimension(ncol, nlay), intent(out) :: source_dn, source_up - real(wp), dimension(ncol ), intent(out) :: source_sfc ! Source function for upward radation at surface - - integer :: icol, ilay - real(wp) :: Z, Zup_top, Zup_bottom, Zdn_top, Zdn_bottom - real(wp), dimension(:), pointer :: lev_source_bot, lev_source_top - ! --------------------------------------------------------------- - do ilay = 1, nlay - if(top_at_1) then - lev_source_top => lev_source(:,ilay) - lev_source_bot => lev_source(:,ilay+1) - else - lev_source_top => lev_source(:,ilay+1) - lev_source_bot => lev_source(:,ilay) - end if - do icol = 1, ncol - if (tau(icol,ilay) > 1.0e-8_wp) then - ! - ! Toon et al. (JGR 1989) Eqs 26-27 - ! - Z = (lev_source_bot(icol)-lev_source_top(icol)) / (tau(icol,ilay)*(gamma1(icol,ilay)+gamma2(icol,ilay))) - Zup_top = Z + lev_source_top(icol) - Zup_bottom = Z + lev_source_bot(icol) - Zdn_top = -Z + lev_source_top(icol) - Zdn_bottom = -Z + lev_source_bot(icol) - source_up(icol,ilay) = pi * (Zup_top - rdif(icol,ilay) * Zdn_top - tdif(icol,ilay) * Zup_bottom) - source_dn(icol,ilay) = pi * (Zdn_bottom - rdif(icol,ilay) * Zup_bottom - tdif(icol,ilay) * Zdn_top) - else - source_up(icol,ilay) = 0._wp - source_dn(icol,ilay) = 0._wp - end if - end do - end do - do icol = 1, ncol - source_sfc(icol) = pi * sfc_emis(icol) * sfc_src(icol) - end do - end subroutine lw_source_2str - ! ------------------------------------------------------------------------------------------------- - ! - ! Lower-level shortwave kernels - ! - ! ------------------------------------------------------------------------------------------------- - ! - ! Two-stream solutions to diffuse reflectance and transmittance for a layer - ! with optical depth tau, single scattering albedo w0, and asymmetery parameter g. - ! Direct reflectance and transmittance used to compute direct beam source for diffuse radiation - ! in layers and at surface; report direct beam as a byproduct - ! Computing the direct-beam source for diffuse radiation at the same time as R and T for - ! direct radiation reduces memory traffic and use. - ! - ! Equations are developed in Meador and Weaver, 1980, - ! doi:10.1175/1520-0469(1980)037<0630:TSATRT>2.0.CO;2 - ! - ! ------------------------------------------------------------------------------------------------- - pure subroutine sw_dif_and_source(ncol, nlay, top_at_1, mu0, sfc_albedo, & - tau, w0, g, & - Rdif, Tdif, source_dn, source_up, source_sfc, flux_dn_dir) bind (C, name="rte_sw_source_dir") - integer, intent(in ) :: ncol, nlay - logical(wl), intent(in ) :: top_at_1 - real(wp), dimension(ncol ), intent(in ) :: sfc_albedo ! surface albedo for direct radiation - real(wp), dimension(ncol,nlay ), intent(in ) :: tau, w0, g, mu0 - real(wp), dimension(ncol,nlay ), intent( out) :: Rdif, Tdif, source_dn, source_up - real(wp), dimension(ncol ), intent( out) :: source_sfc ! Source function for upward radation at surface - real(wp), dimension(ncol,nlay+1), target, & - intent(inout) :: flux_dn_dir ! Direct beam flux - - ! ----------------------- - integer :: i, j - - ! Variables used in Meador and Weaver - real(wp) :: gamma1, gamma2, gamma3, gamma4, alpha1, alpha2 - - - ! Ancillary variables - real(wp), parameter :: min_k = 1.e4_wp * epsilon(1._wp) ! Suggestion from Chiel van Heerwaarden - real(wp) :: k, exp_minusktau, k_mu, k_gamma3, k_gamma4 - real(wp) :: RT_term, exp_minus2ktau - real(wp) :: Rdir, Tdir, Tnoscat - real(wp), pointer, dimension(:) :: dir_flux_inc, dir_flux_trans - integer :: lay_index - real(wp) :: tau_s, w0_s, g_s, mu0_s - ! --------------------------------- - - do j = 1, nlay - if(top_at_1) then - lay_index = j - dir_flux_inc => flux_dn_dir(:,lay_index ) - dir_flux_trans => flux_dn_dir(:,lay_index+1) - else - lay_index = nlay-j+1 - dir_flux_inc => flux_dn_dir(:,lay_index+1) - dir_flux_trans => flux_dn_dir(:,lay_index ) - end if - - do i = 1, ncol - ! - ! Scalars - ! - tau_s = tau(i, lay_index) - w0_s = w0 (i, lay_index) - g_s = g (i, lay_index) - mu0_s = mu0(i, lay_index) - ! - ! Zdunkowski Practical Improved Flux Method "PIFM" - ! (Zdunkowski et al., 1980; Contributions to Atmospheric Physics 53, 147-66) - ! - gamma1 = (8._wp - w0_s * (5._wp + 3._wp * g_s)) * .25_wp - gamma2 = 3._wp *(w0_s * (1._wp - g_s)) * .25_wp - ! - ! Direct reflect and transmission - ! - ! Eq 18; k = SQRT(gamma1**2 - gamma2**2), limited below to avoid div by 0. - ! k = 0 for isotropic, conservative scattering; this lower limit on k - ! gives relative error with respect to conservative solution - ! of < 0.1% in Rdif down to tau = 10^-9 - k = sqrt(max((gamma1 - gamma2) * (gamma1 + gamma2), min_k)) - exp_minusktau = exp(-tau_s*k) - exp_minus2ktau = exp_minusktau * exp_minusktau - - ! Refactored to avoid rounding errors when k, gamma1 are of very different magnitudes - RT_term = 1._wp / (k * (1._wp + exp_minus2ktau) + & - gamma1 * (1._wp - exp_minus2ktau) ) - ! Equation 25 - Rdif(i,lay_index) = RT_term * gamma2 * (1._wp - exp_minus2ktau) - - ! Equation 26 - Tdif(i,lay_index) = RT_term * 2._wp * k * exp_minusktau - - ! - ! On a round earth, where mu0 can increase with depth in the atmosphere, - ! levels with mu0 <= 0 have no direct beam and hence no source for diffuse light - ! - if(mu0_s > 0._wp) then - k_mu = k * mu0_s - ! - ! Equation 14, multiplying top and bottom by exp(-k*tau) - ! and rearranging to avoid div by 0. - ! - RT_term = w0_s * RT_term/merge(1._wp - k_mu*k_mu, & - epsilon(1._wp), & - abs(1._wp - k_mu*k_mu) >= epsilon(1._wp)) - ! - ! Zdunkowski Practical Improved Flux Method "PIFM" - ! (Zdunkowski et al., 1980; Contributions to Atmospheric Physics 53, 147-66) - ! - gamma3 = (2._wp - 3._wp * mu0_s * g_s ) * .25_wp - gamma4 = 1._wp - gamma3 - alpha1 = gamma1 * gamma4 + gamma2 * gamma3 ! Eq. 16 - alpha2 = gamma1 * gamma3 + gamma2 * gamma4 ! Eq. 17 - - ! - ! Transmittance of direct, unscattered beam. - ! - k_gamma3 = k * gamma3 - k_gamma4 = k * gamma4 - Tnoscat = exp(-tau_s/mu0_s) - Rdir = RT_term * & - ((1._wp - k_mu) * (alpha2 + k_gamma3) - & - (1._wp + k_mu) * (alpha2 - k_gamma3) * exp_minus2ktau - & - 2.0_wp * (k_gamma3 - alpha2 * k_mu) * exp_minusktau * Tnoscat) - ! - ! Equation 15, multiplying top and bottom by exp(-k*tau), - ! multiplying through by exp(-tau/mu0) to - ! prefer underflow to overflow - ! Omitting direct transmittance - ! - Tdir = -RT_term * & - ((1._wp + k_mu) * (alpha1 + k_gamma4) * Tnoscat - & - (1._wp - k_mu) * (alpha1 - k_gamma4) * exp_minus2ktau * Tnoscat - & - 2.0_wp * (k_gamma4 + alpha1 * k_mu) * exp_minusktau) - ! Final check that energy is not spuriously created, by recognizing that - ! the beam can either be reflected, penetrate unscattered to the base of a layer, - ! or penetrate through but be scattered on the way - the rest is absorbed - ! Makes the equations safer in single precision. Credit: Robin Hogan, Peter Ukkonen - Rdir = max(0.0_wp, min(Rdir, (1.0_wp - Tnoscat ) )) - Tdir = max(0.0_wp, min(Tdir, (1.0_wp - Tnoscat - Rdir) )) - - source_up(i,lay_index) = Rdir * dir_flux_inc(i) - source_dn(i,lay_index) = Tdir * dir_flux_inc(i) - dir_flux_trans(i) = Tnoscat * dir_flux_inc(i) - else - source_up(i,lay_index) = 0._wp - source_dn(i,lay_index) = 0._wp - dir_flux_trans(i) = 0._wp - end if - end do - end do - source_sfc(:) = dir_flux_trans(:)*sfc_albedo(:) - - end subroutine sw_dif_and_source -! --------------------------------------------------------------- -! -! Transport of diffuse radiation through a vertically layered atmosphere. -! Equations are after Shonk and Hogan 2008, doi:10.1175/2007JCLI1940.1 (SH08) -! This routine is shared by longwave and shortwave -! -! ------------------------------------------------------------------------------------------------- -subroutine adding(ncol, nlay, top_at_1, & - albedo_sfc, & - rdif, tdif, & - src_dn, src_up, src_sfc, & - flux_up, flux_dn) - integer, intent(in ) :: ncol, nlay - logical(wl), intent(in ) :: top_at_1 - real(wp), dimension(ncol ), intent(in ) :: albedo_sfc - real(wp), dimension(ncol,nlay ), intent(in ) :: rdif, tdif - real(wp), dimension(ncol,nlay ), intent(in ) :: src_dn, src_up - real(wp), dimension(ncol ), intent(in ) :: src_sfc - real(wp), dimension(ncol,nlay+1), intent( out) :: flux_up - ! intent(inout) because top layer includes incident flux - real(wp), dimension(ncol,nlay+1), intent(inout) :: flux_dn - ! ------------------ - integer :: ilev - real(wp), dimension(ncol,nlay+1) :: albedo, & ! reflectivity to diffuse radiation below this level - ! alpha in SH08 - src ! source of diffuse upwelling radiation from emission or - ! scattering of direct beam - ! G in SH08 - real(wp), dimension(ncol,nlay ) :: denom ! beta in SH08 - ! ------------------ - ! - ! Indexing into arrays for upward and downward propagation depends on the vertical - ! orientation of the arrays (whether the domain top is at the first or last index) - ! We write the loops out explicitly so compilers will have no trouble optimizing them. - ! - if(top_at_1) then - ilev = nlay + 1 - ! Albedo of lowest level is the surface albedo... - albedo(:,ilev) = albedo_sfc(:) - ! ... and source of diffuse radiation is surface emission - src(:,ilev) = src_sfc(:) - - ! - ! From bottom to top of atmosphere -- - ! compute albedo and source of upward radiation - ! - do ilev = nlay, 1, -1 - denom(:, ilev) = 1._wp/(1._wp - rdif(:,ilev)*albedo(:,ilev+1)) ! Eq 10 - albedo(:,ilev) = rdif(:,ilev) + & - tdif(:,ilev)*tdif(:,ilev) * albedo(:,ilev+1) * denom(:,ilev) ! Equation 9 - ! - ! Equation 11 -- source is emitted upward radiation at top of layer plus - ! radiation emitted at bottom of layer, - ! transmitted through the layer and reflected from layers below (tdiff*src*albedo) - ! - src(:,ilev) = src_up(:, ilev) + & - tdif(:,ilev) * denom(:,ilev) * & - (src(:,ilev+1) + albedo(:,ilev+1)*src_dn(:,ilev)) - end do - - ! Eq 12, at the top of the domain upwelling diffuse is due to ... - ilev = 1 - flux_up(:,ilev) = flux_dn(:,ilev) * albedo(:,ilev) + & ! ... reflection of incident diffuse and - src(:,ilev) ! emission from below - - ! - ! From the top of the atmosphere downward -- compute fluxes - ! - do ilev = 2, nlay+1 - flux_dn(:,ilev) = (tdif(:,ilev-1)*flux_dn(:,ilev-1) + & ! Equation 13 - rdif(:,ilev-1)*src(:,ilev) + & - src_dn(:,ilev-1)) * denom(:,ilev-1) - flux_up(:,ilev) = flux_dn(:,ilev) * albedo(:,ilev) + & ! Equation 12 - src(:,ilev) - end do - else - ilev = 1 - ! Albedo of lowest level is the surface albedo... - albedo(:,ilev) = albedo_sfc(:) - ! ... and source of diffuse radiation is surface emission - src(:,ilev) = src_sfc(:) - - ! - ! From bottom to top of atmosphere -- - ! compute albedo and source of upward radiation - ! - do ilev = 1, nlay - denom(:, ilev ) = 1._wp/(1._wp - rdif(:,ilev)*albedo(:,ilev)) ! Eq 10 - albedo(:,ilev+1) = rdif(:,ilev) + & - tdif(:,ilev)*tdif(:,ilev) * albedo(:,ilev) * denom(:,ilev) ! Equation 9 - ! - ! Equation 11 -- source is emitted upward radiation at top of layer plus - ! radiation emitted at bottom of layer, - ! transmitted through the layer and reflected from layers below (tdiff*src*albedo) - ! - src(:,ilev+1) = src_up(:, ilev) + & - tdif(:,ilev) * denom(:,ilev) * & - (src(:,ilev) + albedo(:,ilev)*src_dn(:,ilev)) - end do - - ! Eq 12, at the top of the domain upwelling diffuse is due to ... - ilev = nlay+1 - flux_up(:,ilev) = flux_dn(:,ilev) * albedo(:,ilev) + & ! ... reflection of incident diffuse and - src(:,ilev) ! scattering by the direct beam below - - ! - ! From the top of the atmosphere downward -- compute fluxes - ! - do ilev = nlay, 1, -1 - flux_dn(:,ilev) = (tdif(:,ilev)*flux_dn(:,ilev+1) + & ! Equation 13 - rdif(:,ilev)*src(:,ilev) + & - src_dn(:, ilev)) * denom(:,ilev) - flux_up(:,ilev) = flux_dn(:,ilev) * albedo(:,ilev) + & ! Equation 12 - src(:,ilev) - - end do - end if -end subroutine adding + interface + subroutine sw_solver_2stream (ncol, nlay, ngpt, top_at_1, & + tau, ssa, g, mu0, & + sfc_alb_dir, sfc_alb_dif, & + inc_flux_dir, & + flux_up, flux_dn, flux_dir, & + has_dif_bc, inc_flux_dif, & + do_broadband, broadband_up, & + broadband_dn, broadband_dir) bind(C, name="rte_sw_solver_2stream") + use mo_rte_kind, only: wp, wl + integer, intent(in ) :: ncol, nlay, ngpt + !! Number of columns, layers, g-points + logical(wl), intent(in ) :: top_at_1 + !! ilay = 1 is the top of the atmosphere? + real(wp), dimension(ncol,nlay, ngpt), intent(in ) :: tau, ssa, g + !! Optical thickness, single-scattering albedo, asymmetry parameter [] + real(wp), dimension(ncol,nlay ), intent(in ) :: mu0 + !! cosine of solar zenith angle + real(wp), dimension(ncol, ngpt), intent(in ) :: sfc_alb_dir, sfc_alb_dif + !! Spectral surface albedo for direct and diffuse radiation + real(wp), dimension(ncol, ngpt), intent(in ) :: inc_flux_dir + !! Direct beam incident flux + real(wp), dimension(ncol,nlay+1,ngpt), target, & + intent( out) :: flux_up, flux_dn, flux_dir + !! Fluxes [W/m2] + logical(wl), intent(in ) :: has_dif_bc + !! Is a boundary condition for diffuse flux supplied? + real(wp), dimension(ncol, ngpt), intent(in ) :: inc_flux_dif + !! Boundary condition for diffuse flux [W/m2] + logical(wl), intent(in ) :: do_broadband + !! Provide broadband-integrated, not spectrally-resolved, fluxes? + real(wp), dimension(ncol,nlay+1 ), intent( out) :: broadband_up, broadband_dn, broadband_dir + end subroutine sw_solver_2stream + end interface end module mo_rte_solver_kernels diff --git a/reference/rte-kernels/src/mo_rte_util_array.F90 b/reference/rte-kernels/src/mo_rte_util_array.F90 index a6c449fbb..cdae473c4 100644 --- a/reference/rte-kernels/src/mo_rte_util_array.F90 +++ b/reference/rte-kernels/src/mo_rte_util_array.F90 @@ -14,78 +14,34 @@ module mo_rte_util_array use mo_rte_kind, only: wp, wl implicit none - !> - !> Efficiently set arrays to zero - !> - interface zero_array - module procedure zero_array_1D, zero_array_2D, zero_array_3D, zero_array_4D - end interface public :: zero_array -contains - !------------------------------------------------------------------------------------------------- + + !------------------------------------------------------------------------------------------------- ! Initializing arrays to 0 !------------------------------------------------------------------------------------------------- - subroutine zero_array_1D(ni, array) bind(C, name="zero_array_1D") - integer, intent(in ) :: ni - real(wp), dimension(ni), intent(out) :: array - ! ----------------------- - integer :: i - ! ----------------------- - !$acc parallel loop copyout(array) - !$omp target teams distribute parallel do simd map(from:array) - do i = 1, ni - array(i) = 0.0_wp - end do - end subroutine zero_array_1D - ! ---------------------------------------------------------- - subroutine zero_array_2D(ni, nj, array) bind(C, name="zero_array_2D") - integer, intent(in ) :: ni, nj - real(wp), dimension(ni, nj), intent(out) :: array - ! ----------------------- - integer :: i,j - ! ----------------------- - !$acc parallel loop collapse(2) copyout(array) - !$omp target teams distribute parallel do simd collapse(2) map(from:array) - do j = 1, nj - do i = 1, ni - array(i,j) = 0.0_wp - end do - end do - end subroutine zero_array_2D - ! ---------------------------------------------------------- - subroutine zero_array_3D(ni, nj, nk, array) bind(C, name="zero_array_3D") - integer, intent(in ) :: ni, nj, nk - real(wp), dimension(ni, nj, nk), intent(out) :: array - ! ----------------------- - integer :: i,j,k - ! ----------------------- - !$acc parallel loop collapse(3) copyout(array) - !$omp target teams distribute parallel do simd collapse(3) map(from:array) - do k = 1, nk - do j = 1, nj - do i = 1, ni - array(i,j,k) = 0.0_wp - end do - end do - end do - end subroutine zero_array_3D - ! ---------------------------------------------------------- - subroutine zero_array_4D(ni, nj, nk, nl, array) bind(C, name="zero_array_4D") + interface zero_array + subroutine zero_array_1D(ni, array) bind(C, name="zero_array_1D") + use mo_rte_kind, only: wp, wl + integer, intent(in ) :: ni + real(wp), dimension(ni), intent(out) :: array + end subroutine zero_array_1D + ! ---------------------------------------------------------- + subroutine zero_array_2D(ni, nj, array) bind(C, name="zero_array_2D") + use mo_rte_kind, only: wp, wl + integer, intent(in ) :: ni, nj + real(wp), dimension(ni, nj), intent(out) :: array + end subroutine zero_array_2D + ! ---------------------------------------------------------- + subroutine zero_array_3D(ni, nj, nk, array) bind(C, name="zero_array_3D") + use mo_rte_kind, only: wp, wl + integer, intent(in ) :: ni, nj, nk + real(wp), dimension(ni, nj, nk), intent(out) :: array + end subroutine zero_array_3D + ! ---------------------------------------------------------- + subroutine zero_array_4D(ni, nj, nk, nl, array) bind(C, name="zero_array_4D") + use mo_rte_kind, only: wp, wl integer, intent(in ) :: ni, nj, nk, nl - real(wp), dimension(ni, nj, nk, nl), intent(out) :: array - ! ----------------------- - integer :: i,j,k,l - ! ----------------------- - !$acc parallel loop collapse(4) copyout(array) - !$omp target teams distribute parallel do simd collapse(4) map(from:array) - do l = 1, nl - do k = 1, nk - do j = 1, nj - do i = 1, ni - array(i,j,k,l) = 0.0_wp - end do - end do - end do - end do - end subroutine zero_array_4D + real(wp), dimension(ni, nj, nk, nl), intent(out) :: array + end subroutine zero_array_4D + end interface zero_array end module mo_rte_util_array diff --git a/reference/rte-kernels/tipuesearch/tipuesearch_content.js b/reference/rte-kernels/tipuesearch/tipuesearch_content.js index 39212f4ce..fb4f9526b 100644 --- a/reference/rte-kernels/tipuesearch/tipuesearch_content.js +++ b/reference/rte-kernels/tipuesearch/tipuesearch_content.js @@ -1 +1 @@ -var tipuesearch = {"pages":[{"title":" RTE kernels ","text":"RTE kernels These pages document the low-level computational kernels used by RRTMGP. The listings below are not exhaustive.\nTo see the full listings use the links at the top of the page.\nThere is a search bar in the top right. Return to the Documentation overview or the reference overview . Developer Info The RTE+RRTTMGP consortium","tags":"home","loc":"index.html"},{"title":"lw_solver_2stream – RTE kernels","text":"public subroutine lw_solver_2stream(ncol, nlay, ngpt, top_at_1, tau, ssa, g, lay_source, lev_source_inc, lev_source_dec, sfc_emis, sfc_src, inc_flux, flux_up, flux_dn) bind(C, name=\"0\") Longwave two-stream calculation:\n - combine RRTMGP-specific sources at levels\n - compute layer reflectance, transmittance\n - compute total source function at levels using linear-in-tau\n - transport Arguments Type Intent Optional Attributes Name integer, intent(in) :: ncol Number of columns, layers, g-points integer, intent(in) :: nlay Number of columns, layers, g-points integer, intent(in) :: ngpt Number of columns, layers, g-points logical(kind=wl), intent(in) :: top_at_1 ilay = 1 is the top of the atmosphere? real(kind=wp), intent(in), dimension(ncol,nlay, ngpt) :: tau Optical thickness, single-scattering albedo, asymmetry parameter [] real(kind=wp), intent(in), dimension(ncol,nlay, ngpt) :: ssa Optical thickness, single-scattering albedo, asymmetry parameter [] real(kind=wp), intent(in), dimension(ncol,nlay, ngpt) :: g Optical thickness, single-scattering albedo, asymmetry parameter [] real(kind=wp), intent(in), dimension(ncol,nlay, ngpt) :: lay_source Planck source at layer average temperature [W/m2] real(kind=wp), intent(in), dimension(ncol,nlay, ngpt) :: lev_source_inc Planck source at layer edge for radiation in increasing ilay direction [W/m2] real(kind=wp), intent(in), dimension(ncol,nlay, ngpt) :: lev_source_dec Planck source at layer edge for radiation in decreasing ilay direction [W/m2] real(kind=wp), intent(in), dimension(ncol, ngpt) :: sfc_emis Surface emissivity [] real(kind=wp), intent(in), dimension(ncol, ngpt) :: sfc_src Surface source function [W/m2] real(kind=wp), intent(in), dimension(ncol, ngpt) :: inc_flux Incident diffuse flux, probably 0 [W/m2] real(kind=wp), intent(out), dimension(ncol,nlay+1,ngpt) :: flux_up Fluxes [W/m2] real(kind=wp), intent(out), dimension(ncol,nlay+1,ngpt) :: flux_dn Fluxes [W/m2] Contents None","tags":"","loc":"proc/lw_solver_2stream.html"},{"title":"lw_solver_noscat – RTE kernels","text":"public subroutine lw_solver_noscat(ncol, nlay, ngpt, top_at_1, nmus, Ds, weights, tau, lay_source, lev_source_inc, lev_source_dec, sfc_emis, sfc_src, inc_flux, flux_up, flux_dn, do_broadband, broadband_up, broadband_dn, do_Jacobians, sfc_srcJac, flux_upJac, do_rescaling, ssa, g) bind(C, name=\"0\") LW transport, no scattering, multi-angle quadrature\n Users provide a set of weights and quadrature angles\n Routine sums over single-angle solutions for each sets of angles/weights Arguments Type Intent Optional Attributes Name integer, intent(in) :: ncol Number of columns, layers, g-points integer, intent(in) :: nlay Number of columns, layers, g-points integer, intent(in) :: ngpt Number of columns, layers, g-points logical(kind=wl), intent(in) :: top_at_1 ilay = 1 is the top of the atmosphere? integer, intent(in) :: nmus number of quadrature angles real(kind=wp), intent(in), dimension (ncol, ngpt, nmus) :: Ds quadrature secants real(kind=wp), intent(in), dimension(nmus) :: weights quadrature weights real(kind=wp), intent(in), dimension(ncol,nlay, ngpt) :: tau Absorption optical thickness [] real(kind=wp), intent(in), dimension(ncol,nlay, ngpt) :: lay_source Planck source at layer average temperature [W/m2] real(kind=wp), intent(in), dimension(ncol,nlay, ngpt) :: lev_source_inc Planck source at layer edge for radiation in increasing ilay direction [W/m2] real(kind=wp), intent(in), dimension(ncol,nlay, ngpt) :: lev_source_dec Planck source at layer edge for radiation in decreasing ilay direction [W/m2] real(kind=wp), intent(in), dimension(ncol, ngpt) :: sfc_emis Surface emissivity [] real(kind=wp), intent(in), dimension(ncol, ngpt) :: sfc_src Surface source function [W/m2] real(kind=wp), intent(in), dimension(ncol, ngpt) :: inc_flux Incident diffuse flux, probably 0 [W/m2] real(kind=wp), intent(out), dimension(ncol,nlay+1,ngpt), target :: flux_up Fluxes [W/m2] real(kind=wp), intent(out), dimension(ncol,nlay+1,ngpt), target :: flux_dn Fluxes [W/m2] logical(kind=wl), intent(in) :: do_broadband real(kind=wp), intent(out), dimension(ncol,nlay+1 ), target :: broadband_up Spectrally-integrated fluxes [W/m2] real(kind=wp), intent(out), dimension(ncol,nlay+1 ), target :: broadband_dn Spectrally-integrated fluxes [W/m2] logical(kind=wl), intent(in) :: do_Jacobians compute Jacobian with respect to surface temeprature? real(kind=wp), intent(in), dimension(ncol ,ngpt) :: sfc_srcJac surface temperature Jacobian of surface source function [W/m2/K] real(kind=wp), intent(out), dimension(ncol,nlay+1 ), target :: flux_upJac surface temperature Jacobian of Radiances [W/m2-str / K] logical(kind=wl), intent(in) :: do_rescaling Approximate treatment of scattering (10.1175/JAS-D-18-0014.1) real(kind=wp), intent(in), dimension(ncol,nlay ,ngpt) :: ssa single-scattering albedo, asymmetry parameter real(kind=wp), intent(in), dimension(ncol,nlay ,ngpt) :: g single-scattering albedo, asymmetry parameter Contents None","tags":"","loc":"proc/lw_solver_noscat.html"},{"title":"sw_solver_2stream – RTE kernels","text":"public subroutine sw_solver_2stream(ncol, nlay, ngpt, top_at_1, tau, ssa, g, mu0, sfc_alb_dir, sfc_alb_dif, inc_flux_dir, flux_up, flux_dn, flux_dir, has_dif_bc, inc_flux_dif, do_broadband, broadband_up, broadband_dn, broadband_dir) bind(C, name=\"0\") Shortwave two-stream calculation:\n compute layer reflectance, transmittance\n compute solar source function for diffuse radiation\n transport Arguments Type Intent Optional Attributes Name integer, intent(in) :: ncol Number of columns, layers, g-points integer, intent(in) :: nlay Number of columns, layers, g-points integer, intent(in) :: ngpt Number of columns, layers, g-points logical(kind=wl), intent(in) :: top_at_1 ilay = 1 is the top of the atmosphere? real(kind=wp), intent(in), dimension(ncol,nlay, ngpt) :: tau Optical thickness, single-scattering albedo, asymmetry parameter [] real(kind=wp), intent(in), dimension(ncol,nlay, ngpt) :: ssa Optical thickness, single-scattering albedo, asymmetry parameter [] real(kind=wp), intent(in), dimension(ncol,nlay, ngpt) :: g Optical thickness, single-scattering albedo, asymmetry parameter [] real(kind=wp), intent(in), dimension(ncol,nlay ) :: mu0 cosine of solar zenith angle real(kind=wp), intent(in), dimension(ncol, ngpt) :: sfc_alb_dir Spectral surface albedo for direct and diffuse radiation real(kind=wp), intent(in), dimension(ncol, ngpt) :: sfc_alb_dif Spectral surface albedo for direct and diffuse radiation real(kind=wp), intent(in), dimension(ncol, ngpt) :: inc_flux_dir Direct beam incident flux real(kind=wp), intent(out), dimension(ncol,nlay+1,ngpt), target :: flux_up Fluxes [W/m2] real(kind=wp), intent(out), dimension(ncol,nlay+1,ngpt), target :: flux_dn Fluxes [W/m2] real(kind=wp), intent(out), dimension(ncol,nlay+1,ngpt), target :: flux_dir Fluxes [W/m2] logical(kind=wl), intent(in) :: has_dif_bc Is a boundary condition for diffuse flux supplied? real(kind=wp), intent(in), dimension(ncol, ngpt) :: inc_flux_dif Boundary condition for diffuse flux [W/m2] logical(kind=wl), intent(in) :: do_broadband Provide broadband-integrated, not spectrally-resolved, fluxes? real(kind=wp), intent(out), dimension(ncol,nlay+1 ) :: broadband_up Broadband integrated fluxes real(kind=wp), intent(out), dimension(ncol,nlay+1 ) :: broadband_dn Broadband integrated fluxes real(kind=wp), intent(out), dimension(ncol,nlay+1 ) :: broadband_dir Broadband integrated fluxes Calls proc~~sw_solver_2stream~~CallsGraph proc~sw_solver_2stream sw_solver_2stream interface~zero_array zero_array proc~sw_solver_2stream->interface~zero_array proc~zero_array_1d zero_array_1D interface~zero_array->proc~zero_array_1d proc~zero_array_4d zero_array_4D interface~zero_array->proc~zero_array_4d proc~zero_array_2d zero_array_2D interface~zero_array->proc~zero_array_2d proc~zero_array_3d zero_array_3D interface~zero_array->proc~zero_array_3d Help × Graph Key Nodes of different colours represent the following: Graph Key Subroutine Subroutine Function Function Interface Interface Unknown Procedure Type Unknown Procedure Type Program Program This Page's Entity This Page's Entity Solid arrows point from a procedure to one which it calls. Dashed \n arrows point from an interface to procedures which implement that interface.\n This could include the module procedures in a generic interface or the\n implementation in a submodule of an interface in a parent module. Contents None","tags":"","loc":"proc/sw_solver_2stream.html"},{"title":"sw_solver_noscat – RTE kernels","text":"public pure subroutine sw_solver_noscat(ncol, nlay, ngpt, top_at_1, tau, mu0, inc_flux_dir, flux_dir) bind(C, name=\"0\") Arguments Type Intent Optional Attributes Name integer, intent(in) :: ncol Number of columns, layers, g-points integer, intent(in) :: nlay Number of columns, layers, g-points integer, intent(in) :: ngpt Number of columns, layers, g-points logical(kind=wl), intent(in) :: top_at_1 ilay = 1 is the top of the atmosphere? real(kind=wp), intent(in), dimension(ncol,nlay, ngpt) :: tau Absorption optical thickness [] real(kind=wp), intent(in), dimension(ncol,nlay ) :: mu0 cosine of solar zenith angle real(kind=wp), intent(in), dimension(ncol, ngpt) :: inc_flux_dir Direct beam incident flux [W/m2] real(kind=wp), intent(out), dimension(ncol,nlay+1,ngpt) :: flux_dir Direct-beam flux, spectral [W/m2] Contents None","tags":"","loc":"proc/sw_solver_noscat.html"},{"title":"zero_array_1D – RTE kernels","text":"public subroutine zero_array_1D(ni, array) bind(C, name=\"0\") Arguments Type Intent Optional Attributes Name integer, intent(in) :: ni real(kind=wp), intent(out), dimension(ni) :: array Called by proc~~zero_array_1d~~CalledByGraph proc~zero_array_1d zero_array_1D interface~zero_array zero_array interface~zero_array->proc~zero_array_1d proc~sw_solver_2stream sw_solver_2stream proc~sw_solver_2stream->interface~zero_array Help × Graph Key Nodes of different colours represent the following: Graph Key Subroutine Subroutine Function Function Interface Interface Unknown Procedure Type Unknown Procedure Type Program Program This Page's Entity This Page's Entity Solid arrows point from a procedure to one which it calls. Dashed \n arrows point from an interface to procedures which implement that interface.\n This could include the module procedures in a generic interface or the\n implementation in a submodule of an interface in a parent module. Contents None","tags":"","loc":"proc/zero_array_1d.html"},{"title":"zero_array_2D – RTE kernels","text":"public subroutine zero_array_2D(ni, nj, array) bind(C, name=\"0\") Arguments Type Intent Optional Attributes Name integer, intent(in) :: ni integer, intent(in) :: nj real(kind=wp), intent(out), dimension(ni, nj) :: array Called by proc~~zero_array_2d~~CalledByGraph proc~zero_array_2d zero_array_2D interface~zero_array zero_array interface~zero_array->proc~zero_array_2d proc~sw_solver_2stream sw_solver_2stream proc~sw_solver_2stream->interface~zero_array Help × Graph Key Nodes of different colours represent the following: Graph Key Subroutine Subroutine Function Function Interface Interface Unknown Procedure Type Unknown Procedure Type Program Program This Page's Entity This Page's Entity Solid arrows point from a procedure to one which it calls. Dashed \n arrows point from an interface to procedures which implement that interface.\n This could include the module procedures in a generic interface or the\n implementation in a submodule of an interface in a parent module. Contents None","tags":"","loc":"proc/zero_array_2d.html"},{"title":"zero_array_3D – RTE kernels","text":"public subroutine zero_array_3D(ni, nj, nk, array) bind(C, name=\"0\") Arguments Type Intent Optional Attributes Name integer, intent(in) :: ni integer, intent(in) :: nj integer, intent(in) :: nk real(kind=wp), intent(out), dimension(ni, nj, nk) :: array Called by proc~~zero_array_3d~~CalledByGraph proc~zero_array_3d zero_array_3D interface~zero_array zero_array interface~zero_array->proc~zero_array_3d proc~sw_solver_2stream sw_solver_2stream proc~sw_solver_2stream->interface~zero_array Help × Graph Key Nodes of different colours represent the following: Graph Key Subroutine Subroutine Function Function Interface Interface Unknown Procedure Type Unknown Procedure Type Program Program This Page's Entity This Page's Entity Solid arrows point from a procedure to one which it calls. Dashed \n arrows point from an interface to procedures which implement that interface.\n This could include the module procedures in a generic interface or the\n implementation in a submodule of an interface in a parent module. Contents None","tags":"","loc":"proc/zero_array_3d.html"},{"title":"zero_array_4D – RTE kernels","text":"public subroutine zero_array_4D(ni, nj, nk, nl, array) bind(C, name=\"0\") Arguments Type Intent Optional Attributes Name integer, intent(in) :: ni integer, intent(in) :: nj integer, intent(in) :: nk integer, intent(in) :: nl real(kind=wp), intent(out), dimension(ni, nj, nk, nl) :: array Called by proc~~zero_array_4d~~CalledByGraph proc~zero_array_4d zero_array_4D interface~zero_array zero_array interface~zero_array->proc~zero_array_4d proc~sw_solver_2stream sw_solver_2stream proc~sw_solver_2stream->interface~zero_array Help × Graph Key Nodes of different colours represent the following: Graph Key Subroutine Subroutine Function Function Interface Interface Unknown Procedure Type Unknown Procedure Type Program Program This Page's Entity This Page's Entity Solid arrows point from a procedure to one which it calls. Dashed \n arrows point from an interface to procedures which implement that interface.\n This could include the module procedures in a generic interface or the\n implementation in a submodule of an interface in a parent module. Contents None","tags":"","loc":"proc/zero_array_4d.html"},{"title":"zero_array – RTE kernels","text":"public interface zero_array Efficiently set arrays to zero Calls interface~~zero_array~~CallsGraph interface~zero_array zero_array proc~zero_array_1d zero_array_1D interface~zero_array->proc~zero_array_1d proc~zero_array_4d zero_array_4D interface~zero_array->proc~zero_array_4d proc~zero_array_2d zero_array_2D interface~zero_array->proc~zero_array_2d proc~zero_array_3d zero_array_3D interface~zero_array->proc~zero_array_3d Help × Graph Key Nodes of different colours represent the following: Graph Key Subroutine Subroutine Function Function Interface Interface Unknown Procedure Type Unknown Procedure Type Program Program This Page's Entity This Page's Entity Solid arrows point from a procedure to one which it calls. Dashed \n arrows point from an interface to procedures which implement that interface.\n This could include the module procedures in a generic interface or the\n implementation in a submodule of an interface in a parent module. Called by interface~~zero_array~~CalledByGraph interface~zero_array zero_array proc~sw_solver_2stream sw_solver_2stream proc~sw_solver_2stream->interface~zero_array Help × Graph Key Nodes of different colours represent the following: Graph Key Subroutine Subroutine Function Function Interface Interface Unknown Procedure Type Unknown Procedure Type Program Program This Page's Entity This Page's Entity Solid arrows point from a procedure to one which it calls. Dashed \n arrows point from an interface to procedures which implement that interface.\n This could include the module procedures in a generic interface or the\n implementation in a submodule of an interface in a parent module. Contents Module Procedures zero_array_1D zero_array_2D zero_array_3D zero_array_4D Module Procedures public subroutine zero_array_1D (ni, array) bind(C, name=\"0\") Arguments Type Intent Optional Attributes Name integer, intent(in) :: ni real(kind=wp), intent(out), dimension(ni) :: array public subroutine zero_array_2D (ni, nj, array) bind(C, name=\"0\") Arguments Type Intent Optional Attributes Name integer, intent(in) :: ni integer, intent(in) :: nj real(kind=wp), intent(out), dimension(ni, nj) :: array public subroutine zero_array_3D (ni, nj, nk, array) bind(C, name=\"0\") Arguments Type Intent Optional Attributes Name integer, intent(in) :: ni integer, intent(in) :: nj integer, intent(in) :: nk real(kind=wp), intent(out), dimension(ni, nj, nk) :: array public subroutine zero_array_4D (ni, nj, nk, nl, array) bind(C, name=\"0\") Arguments Type Intent Optional Attributes Name integer, intent(in) :: ni integer, intent(in) :: nj integer, intent(in) :: nk integer, intent(in) :: nl real(kind=wp), intent(out), dimension(ni, nj, nk, nl) :: array","tags":"","loc":"interface/zero_array.html"},{"title":"delta_scale_2str_f_k – RTE kernels","text":"public pure subroutine delta_scale_2str_f_k(ncol, nlay, ngpt, tau, ssa, g, f) bind(C, name=\"0\") Delta-scale two-stream optical properties given user-provided value of (forward scattering) Arguments Type Intent Optional Attributes Name integer, intent(in) :: ncol Array sizes integer, intent(in) :: nlay Array sizes integer, intent(in) :: ngpt Array sizes real(kind=wp), intent(inout), dimension(ncol, nlay, ngpt) :: tau Optical depth, single-scattering albedo, asymmetry parameter real(kind=wp), intent(inout), dimension(ncol, nlay, ngpt) :: ssa Optical depth, single-scattering albedo, asymmetry parameter real(kind=wp), intent(inout), dimension(ncol, nlay, ngpt) :: g Optical depth, single-scattering albedo, asymmetry parameter real(kind=wp), intent(in), dimension(ncol, nlay, ngpt) :: f User-provided forward-scattering fraction Called by proc~~delta_scale_2str_f_k~~CalledByGraph proc~delta_scale_2str_f_k delta_scale_2str_f_k interface~delta_scale_2str_kernel delta_scale_2str_kernel interface~delta_scale_2str_kernel->proc~delta_scale_2str_f_k Help × Graph Key Nodes of different colours represent the following: Graph Key Subroutine Subroutine Function Function Interface Interface Unknown Procedure Type Unknown Procedure Type Program Program This Page's Entity This Page's Entity Solid arrows point from a procedure to one which it calls. Dashed \n arrows point from an interface to procedures which implement that interface.\n This could include the module procedures in a generic interface or the\n implementation in a submodule of an interface in a parent module. Contents None","tags":"","loc":"proc/delta_scale_2str_f_k.html"},{"title":"delta_scale_2str_k – RTE kernels","text":"public pure subroutine delta_scale_2str_k(ncol, nlay, ngpt, tau, ssa, g) bind(C, name=\"0\") Delta-scale assuming forward-scatternig fraction is the square of the asymmetry parameter\n i.e. Arguments Type Intent Optional Attributes Name integer, intent(in) :: ncol Array sizes integer, intent(in) :: nlay Array sizes integer, intent(in) :: ngpt Array sizes real(kind=wp), intent(inout), dimension(ncol, nlay, ngpt) :: tau Optical depth, single-scattering albedo, asymmetry parameter real(kind=wp), intent(inout), dimension(ncol, nlay, ngpt) :: ssa Optical depth, single-scattering albedo, asymmetry parameter real(kind=wp), intent(inout), dimension(ncol, nlay, ngpt) :: g Optical depth, single-scattering albedo, asymmetry parameter Called by proc~~delta_scale_2str_k~~CalledByGraph proc~delta_scale_2str_k delta_scale_2str_k interface~delta_scale_2str_kernel delta_scale_2str_kernel interface~delta_scale_2str_kernel->proc~delta_scale_2str_k Help × Graph Key Nodes of different colours represent the following: Graph Key Subroutine Subroutine Function Function Interface Interface Unknown Procedure Type Unknown Procedure Type Program Program This Page's Entity This Page's Entity Solid arrows point from a procedure to one which it calls. Dashed \n arrows point from an interface to procedures which implement that interface.\n This could include the module procedures in a generic interface or the\n implementation in a submodule of an interface in a parent module. Contents None","tags":"","loc":"proc/delta_scale_2str_k.html"},{"title":"extract_subset_absorption_tau – RTE kernels","text":"public pure subroutine extract_subset_absorption_tau(ncol, nlay, ngpt, tau_in, ssa_in, colS, colE, tau_out) bind(C, name=\"0\") Extract the absorption optical thickness Arguments Type Intent Optional Attributes Name integer, intent(in) :: ncol Array sizes integer, intent(in) :: nlay Array sizes integer, intent(in) :: ngpt Array sizes real(kind=wp), intent(in), dimension(ncol,nlay,ngpt) :: tau_in Optical thickness, single scattering albedo real(kind=wp), intent(in), dimension(ncol,nlay,ngpt) :: ssa_in Optical thickness, single scattering albedo integer, intent(in) :: colS Starting and ending index integer, intent(in) :: colE Starting and ending index real(kind=wp), intent(out), dimension(colE-colS+1, nlay,ngpt) :: tau_out absorption optical thickness subset Called by proc~~extract_subset_absorption_tau~~CalledByGraph proc~extract_subset_absorption_tau extract_subset_absorption_tau interface~extract_subset extract_subset interface~extract_subset->proc~extract_subset_absorption_tau Help × Graph Key Nodes of different colours represent the following: Graph Key Subroutine Subroutine Function Function Interface Interface Unknown Procedure Type Unknown Procedure Type Program Program This Page's Entity This Page's Entity Solid arrows point from a procedure to one which it calls. Dashed \n arrows point from an interface to procedures which implement that interface.\n This could include the module procedures in a generic interface or the\n implementation in a submodule of an interface in a parent module. Contents None","tags":"","loc":"proc/extract_subset_absorption_tau.html"},{"title":"extract_subset_dim1_3d – RTE kernels","text":"public pure subroutine extract_subset_dim1_3d(ncol, nlay, ngpt, array_in, colS, colE, array_out) bind(C, name=\"0\") Extract a subset from the first dimension (normally columns) of a 3D field.\n Applicable to most variables e.g. tau, ssa, g Arguments Type Intent Optional Attributes Name integer, intent(in) :: ncol Array sizes integer, intent(in) :: nlay Array sizes integer, intent(in) :: ngpt Array sizes real(kind=wp), intent(in), dimension(ncol,nlay,ngpt) :: array_in Array to subset integer, intent(in) :: colS Starting and ending index integer, intent(in) :: colE Starting and ending index real(kind=wp), intent(out), dimension(colE-colS+1, nlay,ngpt) :: array_out subset of the input array Called by proc~~extract_subset_dim1_3d~~CalledByGraph proc~extract_subset_dim1_3d extract_subset_dim1_3d interface~extract_subset extract_subset interface~extract_subset->proc~extract_subset_dim1_3d Help × Graph Key Nodes of different colours represent the following: Graph Key Subroutine Subroutine Function Function Interface Interface Unknown Procedure Type Unknown Procedure Type Program Program This Page's Entity This Page's Entity Solid arrows point from a procedure to one which it calls. Dashed \n arrows point from an interface to procedures which implement that interface.\n This could include the module procedures in a generic interface or the\n implementation in a submodule of an interface in a parent module. Contents None","tags":"","loc":"proc/extract_subset_dim1_3d.html"},{"title":"extract_subset_dim2_4d – RTE kernels","text":"public pure subroutine extract_subset_dim2_4d(nmom, ncol, nlay, ngpt, array_in, colS, colE, array_out) bind(C, name=\"0\") Extract a subset from the second dimension (normally columns) of a 4D field.\n Applicable to phase function moments, where the first dimension is the moment Arguments Type Intent Optional Attributes Name integer, intent(in) :: nmom Array sizes integer, intent(in) :: ncol Array sizes integer, intent(in) :: nlay Array sizes integer, intent(in) :: ngpt Array sizes real(kind=wp), intent(in), dimension(nmom,ncol,nlay,ngpt) :: array_in Array to subset integer, intent(in) :: colS Starting and ending index integer, intent(in) :: colE Starting and ending index real(kind=wp), intent(out), dimension(nmom,colE-colS+1, nlay,ngpt) :: array_out subset of the input array Called by proc~~extract_subset_dim2_4d~~CalledByGraph proc~extract_subset_dim2_4d extract_subset_dim2_4d interface~extract_subset extract_subset interface~extract_subset->proc~extract_subset_dim2_4d Help × Graph Key Nodes of different colours represent the following: Graph Key Subroutine Subroutine Function Function Interface Interface Unknown Procedure Type Unknown Procedure Type Program Program This Page's Entity This Page's Entity Solid arrows point from a procedure to one which it calls. Dashed \n arrows point from an interface to procedures which implement that interface.\n This could include the module procedures in a generic interface or the\n implementation in a submodule of an interface in a parent module. Contents None","tags":"","loc":"proc/extract_subset_dim2_4d.html"},{"title":"inc_1scalar_by_1scalar_bybnd – RTE kernels","text":"public pure subroutine inc_1scalar_by_1scalar_bybnd(ncol, nlay, ngpt, tau1, tau2, nbnd, gpt_lims) bind(C, name=\"0\") increase one absorption optical depth defined on g-points by a second value defined on bands Arguments Type Intent Optional Attributes Name integer, intent(in) :: ncol array sizes integer, intent(in) :: nlay array sizes integer, intent(in) :: ngpt array sizes real(kind=wp), intent(inout), dimension(ncol,nlay,ngpt) :: tau1 optical properties to be modified (defined on g-points) real(kind=wp), intent(in), dimension(ncol,nlay,nbnd) :: tau2 optical properties to be added to original (defined on bands) integer, intent(in) :: nbnd array sizes integer, intent(in), dimension(2,nbnd) :: gpt_lims Starting and ending gpoint for each band Contents None","tags":"","loc":"proc/inc_1scalar_by_1scalar_bybnd.html"},{"title":"inc_1scalar_by_2stream_bybnd – RTE kernels","text":"public pure subroutine inc_1scalar_by_2stream_bybnd(ncol, nlay, ngpt, tau1, tau2, ssa2, nbnd, gpt_lims) bind(C, name=\"0\") increase absorption optical depth defined on g-points with extinction optical depth (2-stream form) defined on bands Arguments Type Intent Optional Attributes Name integer, intent(in) :: ncol array sizes integer, intent(in) :: nlay array sizes integer, intent(in) :: ngpt array sizes real(kind=wp), intent(inout), dimension(ncol,nlay,ngpt) :: tau1 optical properties to be modified (defined on g-points) real(kind=wp), intent(in), dimension(ncol,nlay,nbnd) :: tau2 optical properties to be added to original (defined on bands) real(kind=wp), intent(in), dimension(ncol,nlay,nbnd) :: ssa2 optical properties to be added to original (defined on bands) integer, intent(in) :: nbnd array sizes integer, intent(in), dimension(2,nbnd) :: gpt_lims Starting and ending gpoint for each band Contents None","tags":"","loc":"proc/inc_1scalar_by_2stream_bybnd.html"},{"title":"inc_1scalar_by_nstream_bybnd – RTE kernels","text":"public pure subroutine inc_1scalar_by_nstream_bybnd(ncol, nlay, ngpt, tau1, tau2, ssa2, nbnd, gpt_lims) bind(C, name=\"0\") increase absorption optical depth defined on g-points with extinction optical depth (n-stream form) defined on bands Arguments Type Intent Optional Attributes Name integer, intent(in) :: ncol array sizes integer, intent(in) :: nlay array sizes integer, intent(in) :: ngpt array sizes real(kind=wp), intent(inout), dimension(ncol,nlay,ngpt) :: tau1 optical properties to be modified (defined on g-points) real(kind=wp), intent(in), dimension(ncol,nlay,nbnd) :: tau2 optical properties to be added to original (defined on bands) real(kind=wp), intent(in), dimension(ncol,nlay,nbnd) :: ssa2 optical properties to be added to original (defined on bands) integer, intent(in) :: nbnd array sizes integer, intent(in), dimension(2,nbnd) :: gpt_lims Starting and ending gpoint for each band Contents None","tags":"","loc":"proc/inc_1scalar_by_nstream_bybnd.html"},{"title":"inc_2stream_by_1scalar_bybnd – RTE kernels","text":"public pure subroutine inc_2stream_by_1scalar_bybnd(ncol, nlay, ngpt, tau1, ssa1, tau2, nbnd, gpt_lims) bind(C, name=\"0\") increment two-stream optical properties defined on g-points with absorption optical depth defined on bands Arguments Type Intent Optional Attributes Name integer, intent(in) :: ncol array sizes integer, intent(in) :: nlay array sizes integer, intent(in) :: ngpt array sizes real(kind=wp), intent(inout), dimension(ncol,nlay,ngpt) :: tau1 optical properties to be modified (defined on g-points) real(kind=wp), intent(inout), dimension(ncol,nlay,ngpt) :: ssa1 optical properties to be modified (defined on g-points) real(kind=wp), intent(in), dimension(ncol,nlay,nbnd) :: tau2 optical properties to be added to original (defined on bands) integer, intent(in) :: nbnd array sizes integer, intent(in), dimension(2,nbnd) :: gpt_lims Starting and ending gpoint for each band Contents None","tags":"","loc":"proc/inc_2stream_by_1scalar_bybnd.html"},{"title":"inc_2stream_by_2stream_bybnd – RTE kernels","text":"public pure subroutine inc_2stream_by_2stream_bybnd(ncol, nlay, ngpt, tau1, ssa1, g1, tau2, ssa2, g2, nbnd, gpt_lims) bind(C, name=\"0\") increment 2-stream optical properties defined on g-points with another set defined on bands Arguments Type Intent Optional Attributes Name integer, intent(in) :: ncol array sizes integer, intent(in) :: nlay array sizes integer, intent(in) :: ngpt array sizes real(kind=wp), intent(inout), dimension(ncol,nlay,ngpt) :: tau1 optical properties to be modified (defined on g-points) real(kind=wp), intent(inout), dimension(ncol,nlay,ngpt) :: ssa1 optical properties to be modified (defined on g-points) real(kind=wp), intent(inout), dimension(ncol,nlay,ngpt) :: g1 optical properties to be modified (defined on g-points) real(kind=wp), intent(in), dimension(ncol,nlay,nbnd) :: tau2 optical properties to be added to original (defined on bands) real(kind=wp), intent(in), dimension(ncol,nlay,nbnd) :: ssa2 optical properties to be added to original (defined on bands) real(kind=wp), intent(in), dimension(ncol,nlay,nbnd) :: g2 optical properties to be added to original (defined on bands) integer, intent(in) :: nbnd array sizes integer, intent(in), dimension(2,nbnd) :: gpt_lims Starting and ending gpoint for each band Contents None","tags":"","loc":"proc/inc_2stream_by_2stream_bybnd.html"},{"title":"inc_2stream_by_nstream_bybnd – RTE kernels","text":"public pure subroutine inc_2stream_by_nstream_bybnd(ncol, nlay, ngpt, nmom2, tau1, ssa1, g1, tau2, ssa2, p2, nbnd, gpt_lims) bind(C, name=\"0\") increment 2-stream optical properties defined on g-points with n -stream properties set defined on bands Arguments Type Intent Optional Attributes Name integer, intent(in) :: ncol array sizes integer, intent(in) :: nlay array sizes integer, intent(in) :: ngpt array sizes integer, intent(in) :: nmom2 array sizes real(kind=wp), intent(inout), dimension(ncol,nlay,ngpt) :: tau1 optical properties to be modified (defined on g-points) real(kind=wp), intent(inout), dimension(ncol,nlay,ngpt) :: ssa1 optical properties to be modified (defined on g-points) real(kind=wp), intent(inout), dimension(ncol,nlay,ngpt) :: g1 optical properties to be modified (defined on g-points) real(kind=wp), intent(in), dimension(ncol,nlay,nbnd) :: tau2 optical properties to be added to original (defined on bands) real(kind=wp), intent(in), dimension(ncol,nlay,nbnd) :: ssa2 optical properties to be added to original (defined on bands) real(kind=wp), intent(in), dimension(nmom2, ncol,nlay,nbnd) :: p2 moments of the phase function to be added integer, intent(in) :: nbnd array sizes integer, intent(in), dimension(2,nbnd) :: gpt_lims Starting and ending gpoint for each band Contents None","tags":"","loc":"proc/inc_2stream_by_nstream_bybnd.html"},{"title":"inc_nstream_by_1scalar_bybnd – RTE kernels","text":"public pure subroutine inc_nstream_by_1scalar_bybnd(ncol, nlay, ngpt, tau1, ssa1, tau2, nbnd, gpt_lims) bind(C, name=\"0\") increment n -stream optical properties defined on g-points with absorption optical depth defined on bands Arguments Type Intent Optional Attributes Name integer, intent(in) :: ncol array sizes integer, intent(in) :: nlay array sizes integer, intent(in) :: ngpt array sizes real(kind=wp), intent(inout), dimension(ncol,nlay,ngpt) :: tau1 optical properties to be modified (defined on g-points) real(kind=wp), intent(inout), dimension(ncol,nlay,ngpt) :: ssa1 optical properties to be modified (defined on g-points) real(kind=wp), intent(in), dimension(ncol,nlay,nbnd) :: tau2 optical properties to be added to original (defined on bands) integer, intent(in) :: nbnd array sizes integer, intent(in), dimension(2,nbnd) :: gpt_lims Starting and ending gpoint for each band Contents None","tags":"","loc":"proc/inc_nstream_by_1scalar_bybnd.html"},{"title":"inc_nstream_by_2stream_bybnd – RTE kernels","text":"public pure subroutine inc_nstream_by_2stream_bybnd(ncol, nlay, ngpt, nmom1, tau1, ssa1, p1, tau2, ssa2, g2, nbnd, gpt_lims) bind(C, name=\"0\") increment n-stream optical properties defined on g-points with 2-stream properties set defined on bands Arguments Type Intent Optional Attributes Name integer, intent(in) :: ncol array sizes integer, intent(in) :: nlay array sizes integer, intent(in) :: ngpt array sizes integer, intent(in) :: nmom1 array sizes real(kind=wp), intent(inout), dimension(ncol,nlay,ngpt) :: tau1 optical properties to be modified (defined on g-points) real(kind=wp), intent(inout), dimension(ncol,nlay,ngpt) :: ssa1 optical properties to be modified (defined on g-points) real(kind=wp), intent(inout), dimension(nmom1, ncol,nlay,ngpt) :: p1 moments of the phase function be modified real(kind=wp), intent(in), dimension(ncol,nlay,nbnd) :: tau2 optical properties to be added to original (defined on bands) real(kind=wp), intent(in), dimension(ncol,nlay,nbnd) :: ssa2 optical properties to be added to original (defined on bands) real(kind=wp), intent(in), dimension(ncol,nlay,nbnd) :: g2 optical properties to be added to original (defined on bands) integer, intent(in) :: nbnd array sizes integer, intent(in), dimension(2,nbnd) :: gpt_lims Starting and ending gpoint for each band Contents None","tags":"","loc":"proc/inc_nstream_by_2stream_bybnd.html"},{"title":"inc_nstream_by_nstream_bybnd – RTE kernels","text":"public pure subroutine inc_nstream_by_nstream_bybnd(ncol, nlay, ngpt, nmom1, nmom2, tau1, ssa1, p1, tau2, ssa2, p2, nbnd, gpt_lims) bind(C, name=\"0\") increment n -stream optical properties defined on g-points with a second set defined on bands Arguments Type Intent Optional Attributes Name integer, intent(in) :: ncol array sizes integer, intent(in) :: nlay array sizes integer, intent(in) :: ngpt array sizes integer, intent(in) :: nmom1 array sizes integer, intent(in) :: nmom2 array sizes real(kind=wp), intent(inout), dimension(ncol,nlay,ngpt) :: tau1 optical properties to be modified (defined on g-points) real(kind=wp), intent(inout), dimension(ncol,nlay,ngpt) :: ssa1 optical properties to be modified (defined on g-points) real(kind=wp), intent(inout), dimension(nmom1, ncol,nlay,ngpt) :: p1 moments of the phase function be modified real(kind=wp), intent(in), dimension(ncol,nlay,nbnd) :: tau2 optical properties to be added to original (defined on bands) real(kind=wp), intent(in), dimension(ncol,nlay,nbnd) :: ssa2 optical properties to be added to original (defined on bands) real(kind=wp), intent(in), dimension(nmom2, ncol,nlay,nbnd) :: p2 moments of the phase function to be added integer, intent(in) :: nbnd array sizes integer, intent(in), dimension(2,nbnd) :: gpt_lims Starting and ending gpoint for each band Contents None","tags":"","loc":"proc/inc_nstream_by_nstream_bybnd.html"},{"title":"increment_1scalar_by_1scalar – RTE kernels","text":"public pure subroutine increment_1scalar_by_1scalar(ncol, nlay, ngpt, tau1, tau2) bind(C, name=\"0\") increase one absorption optical depth by a second value Arguments Type Intent Optional Attributes Name integer, intent(in) :: ncol array sizes integer, intent(in) :: nlay array sizes integer, intent(in) :: ngpt array sizes real(kind=wp), intent(inout), dimension(ncol,nlay,ngpt) :: tau1 optical properties to be modified real(kind=wp), intent(in), dimension(ncol,nlay,ngpt) :: tau2 optical properties to be added to original Contents None","tags":"","loc":"proc/increment_1scalar_by_1scalar.html"},{"title":"increment_1scalar_by_2stream – RTE kernels","text":"public pure subroutine increment_1scalar_by_2stream(ncol, nlay, ngpt, tau1, tau2, ssa2) bind(C, name=\"0\") increase absorption optical depth with extinction optical depth (2-stream form) Arguments Type Intent Optional Attributes Name integer, intent(in) :: ncol array sizes integer, intent(in) :: nlay array sizes integer, intent(in) :: ngpt array sizes real(kind=wp), intent(inout), dimension(ncol,nlay,ngpt) :: tau1 optical properties to be modified real(kind=wp), intent(in), dimension(ncol,nlay,ngpt) :: tau2 optical properties to be added to original real(kind=wp), intent(in), dimension(ncol,nlay,ngpt) :: ssa2 optical properties to be added to original Contents None","tags":"","loc":"proc/increment_1scalar_by_2stream.html"},{"title":"increment_1scalar_by_nstream – RTE kernels","text":"public pure subroutine increment_1scalar_by_nstream(ncol, nlay, ngpt, tau1, tau2, ssa2) bind(C, name=\"0\") increase absorption optical depth with extinction optical depth (n-stream form) Arguments Type Intent Optional Attributes Name integer, intent(in) :: ncol array sizes integer, intent(in) :: nlay array sizes integer, intent(in) :: ngpt array sizes real(kind=wp), intent(inout), dimension(ncol,nlay,ngpt) :: tau1 optical properties to be modified real(kind=wp), intent(in), dimension(ncol,nlay,ngpt) :: tau2 optical properties to be added to original real(kind=wp), intent(in), dimension(ncol,nlay,ngpt) :: ssa2 optical properties to be added to original Contents None","tags":"","loc":"proc/increment_1scalar_by_nstream.html"},{"title":"increment_2stream_by_1scalar – RTE kernels","text":"public pure subroutine increment_2stream_by_1scalar(ncol, nlay, ngpt, tau1, ssa1, tau2) bind(C, name=\"0\") increment two-stream optical properties with absorption optical depth Arguments Type Intent Optional Attributes Name integer, intent(in) :: ncol array sizes integer, intent(in) :: nlay array sizes integer, intent(in) :: ngpt array sizes real(kind=wp), intent(inout), dimension(ncol,nlay,ngpt) :: tau1 optical properties to be modified real(kind=wp), intent(inout), dimension(ncol,nlay,ngpt) :: ssa1 optical properties to be modified real(kind=wp), intent(in), dimension(ncol,nlay,ngpt) :: tau2 optical properties to be added to original Contents None","tags":"","loc":"proc/increment_2stream_by_1scalar.html"},{"title":"increment_2stream_by_2stream – RTE kernels","text":"public pure subroutine increment_2stream_by_2stream(ncol, nlay, ngpt, tau1, ssa1, g1, tau2, ssa2, g2) bind(C, name=\"0\") increment two-stream optical properties with a second set Arguments Type Intent Optional Attributes Name integer, intent(in) :: ncol array sizes integer, intent(in) :: nlay array sizes integer, intent(in) :: ngpt array sizes real(kind=wp), intent(inout), dimension(ncol,nlay,ngpt) :: tau1 optical properties to be modified real(kind=wp), intent(inout), dimension(ncol,nlay,ngpt) :: ssa1 optical properties to be modified real(kind=wp), intent(inout), dimension(ncol,nlay,ngpt) :: g1 optical properties to be modified real(kind=wp), intent(in), dimension(ncol,nlay,ngpt) :: tau2 optical properties to be added to original real(kind=wp), intent(in), dimension(ncol,nlay,ngpt) :: ssa2 optical properties to be added to original real(kind=wp), intent(in), dimension(ncol,nlay,ngpt) :: g2 optical properties to be added to original Contents None","tags":"","loc":"proc/increment_2stream_by_2stream.html"},{"title":"increment_2stream_by_nstream – RTE kernels","text":"public pure subroutine increment_2stream_by_nstream(ncol, nlay, ngpt, nmom2, tau1, ssa1, g1, tau2, ssa2, p2) bind(C, name=\"0\") increment two-stream optical properties with n -stream Arguments Type Intent Optional Attributes Name integer, intent(in) :: ncol array sizes integer, intent(in) :: nlay array sizes integer, intent(in) :: ngpt array sizes integer, intent(in) :: nmom2 array sizes real(kind=wp), intent(inout), dimension(ncol,nlay,ngpt) :: tau1 optical properties to be modified real(kind=wp), intent(inout), dimension(ncol,nlay,ngpt) :: ssa1 optical properties to be modified real(kind=wp), intent(inout), dimension(ncol,nlay,ngpt) :: g1 optical properties to be modified real(kind=wp), intent(in), dimension(ncol,nlay,ngpt) :: tau2 optical properties to be added to original real(kind=wp), intent(in), dimension(ncol,nlay,ngpt) :: ssa2 optical properties to be added to original real(kind=wp), intent(in), dimension(nmom2, ncol,nlay,ngpt) :: p2 moments of the phase function to be added Contents None","tags":"","loc":"proc/increment_2stream_by_nstream.html"},{"title":"increment_nstream_by_1scalar – RTE kernels","text":"public pure subroutine increment_nstream_by_1scalar(ncol, nlay, ngpt, tau1, ssa1, tau2) bind(C, name=\"0\") increment n -stream optical properties with absorption optical depth Arguments Type Intent Optional Attributes Name integer, intent(in) :: ncol array sizes integer, intent(in) :: nlay array sizes integer, intent(in) :: ngpt array sizes real(kind=wp), intent(inout), dimension(ncol,nlay,ngpt) :: tau1 optical properties to be modified real(kind=wp), intent(inout), dimension(ncol,nlay,ngpt) :: ssa1 optical properties to be modified real(kind=wp), intent(in), dimension(ncol,nlay,ngpt) :: tau2 optical properties to be added to original Contents None","tags":"","loc":"proc/increment_nstream_by_1scalar.html"},{"title":"increment_nstream_by_2stream – RTE kernels","text":"public pure subroutine increment_nstream_by_2stream(ncol, nlay, ngpt, nmom1, tau1, ssa1, p1, tau2, ssa2, g2) bind(C, name=\"0\") increment n -stream optical properties with two-stream values Arguments Type Intent Optional Attributes Name integer, intent(in) :: ncol array sizes integer, intent(in) :: nlay array sizes integer, intent(in) :: ngpt array sizes integer, intent(in) :: nmom1 array sizes real(kind=wp), intent(inout), dimension(ncol,nlay,ngpt) :: tau1 optical properties to be modified real(kind=wp), intent(inout), dimension(ncol,nlay,ngpt) :: ssa1 optical properties to be modified real(kind=wp), intent(inout), dimension(nmom1, ncol,nlay,ngpt) :: p1 moments of the phase function be modified real(kind=wp), intent(in), dimension(ncol,nlay,ngpt) :: tau2 optical properties to be added to original real(kind=wp), intent(in), dimension(ncol,nlay,ngpt) :: ssa2 optical properties to be added to original real(kind=wp), intent(in), dimension(ncol,nlay,ngpt) :: g2 optical properties to be added to original Contents None","tags":"","loc":"proc/increment_nstream_by_2stream.html"},{"title":"increment_nstream_by_nstream – RTE kernels","text":"public pure subroutine increment_nstream_by_nstream(ncol, nlay, ngpt, nmom1, nmom2, tau1, ssa1, p1, tau2, ssa2, p2) bind(C, name=\"0\") increment one set of n -stream optical properties with another set Arguments Type Intent Optional Attributes Name integer, intent(in) :: ncol array sizes integer, intent(in) :: nlay array sizes integer, intent(in) :: ngpt array sizes integer, intent(in) :: nmom1 array sizes integer, intent(in) :: nmom2 array sizes real(kind=wp), intent(inout), dimension(ncol,nlay,ngpt) :: tau1 optical properties to be modified real(kind=wp), intent(inout), dimension(ncol,nlay,ngpt) :: ssa1 optical properties to be modified real(kind=wp), intent(inout), dimension(nmom1, ncol,nlay,ngpt) :: p1 moments of the phase function be modified real(kind=wp), intent(in), dimension(ncol,nlay,ngpt) :: tau2 optical properties to be added to original real(kind=wp), intent(in), dimension(ncol,nlay,ngpt) :: ssa2 optical properties to be added to original real(kind=wp), intent(in), dimension(nmom2, ncol,nlay,ngpt) :: p2 moments of the phase function to be added Contents None","tags":"","loc":"proc/increment_nstream_by_nstream.html"},{"title":"delta_scale_2str_kernel – RTE kernels","text":"public interface delta_scale_2str_kernel Delta-scale two-stream optical properties Calls interface~~delta_scale_2str_kernel~~CallsGraph interface~delta_scale_2str_kernel delta_scale_2str_kernel proc~delta_scale_2str_f_k delta_scale_2str_f_k interface~delta_scale_2str_kernel->proc~delta_scale_2str_f_k proc~delta_scale_2str_k delta_scale_2str_k interface~delta_scale_2str_kernel->proc~delta_scale_2str_k Help × Graph Key Nodes of different colours represent the following: Graph Key Subroutine Subroutine Function Function Interface Interface Unknown Procedure Type Unknown Procedure Type Program Program This Page's Entity This Page's Entity Solid arrows point from a procedure to one which it calls. Dashed \n arrows point from an interface to procedures which implement that interface.\n This could include the module procedures in a generic interface or the\n implementation in a submodule of an interface in a parent module. Contents Module Procedures delta_scale_2str_f_k delta_scale_2str_k Module Procedures public pure subroutine delta_scale_2str_f_k (ncol, nlay, ngpt, tau, ssa, g, f) bind(C, name=\"0\") Delta-scale two-stream optical properties given user-provided value of (forward scattering) Arguments Type Intent Optional Attributes Name integer, intent(in) :: ncol Array sizes integer, intent(in) :: nlay Array sizes integer, intent(in) :: ngpt Array sizes real(kind=wp), intent(inout), dimension(ncol, nlay, ngpt) :: tau Optical depth, single-scattering albedo, asymmetry parameter real(kind=wp), intent(inout), dimension(ncol, nlay, ngpt) :: ssa Optical depth, single-scattering albedo, asymmetry parameter real(kind=wp), intent(inout), dimension(ncol, nlay, ngpt) :: g Optical depth, single-scattering albedo, asymmetry parameter real(kind=wp), intent(in), dimension(ncol, nlay, ngpt) :: f User-provided forward-scattering fraction public pure subroutine delta_scale_2str_k (ncol, nlay, ngpt, tau, ssa, g) bind(C, name=\"0\") Delta-scale assuming forward-scatternig fraction is the square of the asymmetry parameter\n i.e. Arguments Type Intent Optional Attributes Name integer, intent(in) :: ncol Array sizes integer, intent(in) :: nlay Array sizes integer, intent(in) :: ngpt Array sizes real(kind=wp), intent(inout), dimension(ncol, nlay, ngpt) :: tau Optical depth, single-scattering albedo, asymmetry parameter real(kind=wp), intent(inout), dimension(ncol, nlay, ngpt) :: ssa Optical depth, single-scattering albedo, asymmetry parameter real(kind=wp), intent(inout), dimension(ncol, nlay, ngpt) :: g Optical depth, single-scattering albedo, asymmetry parameter","tags":"","loc":"interface/delta_scale_2str_kernel.html"},{"title":"extract_subset – RTE kernels","text":"public interface extract_subset Subsetting, meaning extracting some portion of the 3D domain Calls interface~~extract_subset~~CallsGraph interface~extract_subset extract_subset proc~extract_subset_dim1_3d extract_subset_dim1_3d interface~extract_subset->proc~extract_subset_dim1_3d proc~extract_subset_dim2_4d extract_subset_dim2_4d interface~extract_subset->proc~extract_subset_dim2_4d proc~extract_subset_absorption_tau extract_subset_absorption_tau interface~extract_subset->proc~extract_subset_absorption_tau Help × Graph Key Nodes of different colours represent the following: Graph Key Subroutine Subroutine Function Function Interface Interface Unknown Procedure Type Unknown Procedure Type Program Program This Page's Entity This Page's Entity Solid arrows point from a procedure to one which it calls. Dashed \n arrows point from an interface to procedures which implement that interface.\n This could include the module procedures in a generic interface or the\n implementation in a submodule of an interface in a parent module. Contents Module Procedures extract_subset_dim1_3d extract_subset_dim2_4d extract_subset_absorption_tau Module Procedures public pure subroutine extract_subset_dim1_3d (ncol, nlay, ngpt, array_in, colS, colE, array_out) bind(C, name=\"0\") Extract a subset from the first dimension (normally columns) of a 3D field.\n Applicable to most variables e.g. tau, ssa, g Arguments Type Intent Optional Attributes Name integer, intent(in) :: ncol Array sizes integer, intent(in) :: nlay Array sizes integer, intent(in) :: ngpt Array sizes real(kind=wp), intent(in), dimension(ncol,nlay,ngpt) :: array_in Array to subset integer, intent(in) :: colS Starting and ending index integer, intent(in) :: colE Starting and ending index real(kind=wp), intent(out), dimension(colE-colS+1, nlay,ngpt) :: array_out subset of the input array public pure subroutine extract_subset_dim2_4d (nmom, ncol, nlay, ngpt, array_in, colS, colE, array_out) bind(C, name=\"0\") Extract a subset from the second dimension (normally columns) of a 4D field.\n Applicable to phase function moments, where the first dimension is the moment Arguments Type Intent Optional Attributes Name integer, intent(in) :: nmom Array sizes integer, intent(in) :: ncol Array sizes integer, intent(in) :: nlay Array sizes integer, intent(in) :: ngpt Array sizes real(kind=wp), intent(in), dimension(nmom,ncol,nlay,ngpt) :: array_in Array to subset integer, intent(in) :: colS Starting and ending index integer, intent(in) :: colE Starting and ending index real(kind=wp), intent(out), dimension(nmom,colE-colS+1, nlay,ngpt) :: array_out subset of the input array public pure subroutine extract_subset_absorption_tau (ncol, nlay, ngpt, tau_in, ssa_in, colS, colE, tau_out) bind(C, name=\"0\") Extract the absorption optical thickness Arguments Type Intent Optional Attributes Name integer, intent(in) :: ncol Array sizes integer, intent(in) :: nlay Array sizes integer, intent(in) :: ngpt Array sizes real(kind=wp), intent(in), dimension(ncol,nlay,ngpt) :: tau_in Optical thickness, single scattering albedo real(kind=wp), intent(in), dimension(ncol,nlay,ngpt) :: ssa_in Optical thickness, single scattering albedo integer, intent(in) :: colS Starting and ending index integer, intent(in) :: colE Starting and ending index real(kind=wp), intent(out), dimension(colE-colS+1, nlay,ngpt) :: tau_out absorption optical thickness subset","tags":"","loc":"interface/extract_subset.html"},{"title":"sum_broadband – RTE kernels","text":"public subroutine sum_broadband(ncol, nlev, ngpt, spectral_flux, broadband_flux) bind(C, name=\"0\") Spectral reduction over all points Arguments Type Intent Optional Attributes Name integer, intent(in) :: ncol Array sizes integer, intent(in) :: nlev Array sizes integer, intent(in) :: ngpt Array sizes real(kind=wp), intent(in), dimension(ncol, nlev, ngpt) :: spectral_flux Spectrally-resolved flux real(kind=wp), intent(out), dimension(ncol, nlev) :: broadband_flux Sum of spectrally-resolved flux over ngpt Contents None","tags":"","loc":"proc/sum_broadband.html"},{"title":"net_broadband – RTE kernels","text":"public interface net_broadband Interface for computing net flux Contents Module Procedures net_broadband_full net_broadband_precalc Module Procedures private subroutine net_broadband_full(ncol, nlev, ngpt, spectral_flux_dn, spectral_flux_up, broadband_flux_net) bind(C, name=\"0\") Spectral reduction over all points for net flux Arguments Type Intent Optional Attributes Name integer, intent(in) :: ncol Array sizes integer, intent(in) :: nlev Array sizes integer, intent(in) :: ngpt Array sizes real(kind=wp), intent(in), dimension(ncol, nlev, ngpt) :: spectral_flux_dn Spectrally-resolved flux up and down real(kind=wp), intent(in), dimension(ncol, nlev, ngpt) :: spectral_flux_up Spectrally-resolved flux up and down real(kind=wp), intent(out), dimension(ncol, nlev) :: broadband_flux_net Net (down minus up) summed over ngpt private subroutine net_broadband_precalc(ncol, nlev, flux_dn, flux_up, broadband_flux_net) bind(C, name=\"0\") Net flux when bradband flux up and down are already available Arguments Type Intent Optional Attributes Name integer, intent(in) :: ncol Array sizes integer, intent(in) :: nlev Array sizes real(kind=wp), intent(in), dimension(ncol, nlev) :: flux_dn Broadband downward and upward fluxes real(kind=wp), intent(in), dimension(ncol, nlev) :: flux_up Broadband downward and upward fluxes real(kind=wp), intent(out), dimension(ncol, nlev) :: broadband_flux_net Net (down minus up)","tags":"","loc":"interface/net_broadband.html"},{"title":"mo_rte_solver_kernels – RTE kernels","text":"Numeric calculations for radiative transfer solvers Emission/absorption (no-scattering) calculations solver for multi-angle Gaussian quadrature solver for a single angle, calling source function computation (linear-in-tau) transport Extinction-only calculation (direct solar beam) Two-stream calculations:\n solvers for LW and SW with different boundary conditions and source functions source function calculation for LW, SW two-stream calculations for LW, SW (using different assumtions about phase function) transport (adding) Application of boundary conditions Uses mo_rte_kind iso_c_binding mo_rte_util_array module~~mo_rte_solver_kernels~~UsesGraph module~mo_rte_solver_kernels mo_rte_solver_kernels mo_rte_kind mo_rte_kind module~mo_rte_solver_kernels->mo_rte_kind module~mo_rte_util_array mo_rte_util_array module~mo_rte_solver_kernels->module~mo_rte_util_array iso_c_binding iso_c_binding module~mo_rte_solver_kernels->iso_c_binding module~mo_rte_util_array->mo_rte_kind Help × Graph Key Nodes of different colours represent the following: Graph Key Module Module Submodule Submodule Subroutine Subroutine Function Function Program Program This Page's Entity This Page's Entity Solid arrows point from a submodule to the (sub)module which it is\n descended from. Dashed arrows point from a module or program unit to \n modules which it uses. Contents Subroutines lw_solver_2stream lw_solver_noscat sw_solver_2stream sw_solver_noscat Subroutines public subroutine lw_solver_2stream (ncol, nlay, ngpt, top_at_1, tau, ssa, g, lay_source, lev_source_inc, lev_source_dec, sfc_emis, sfc_src, inc_flux, flux_up, flux_dn) bind(C, name=\"0\") Longwave two-stream calculation:\n - combine RRTMGP-specific sources at levels\n - compute layer reflectance, transmittance\n - compute total source function at levels using linear-in-tau\n - transport Arguments Type Intent Optional Attributes Name integer, intent(in) :: ncol Number of columns, layers, g-points integer, intent(in) :: nlay Number of columns, layers, g-points integer, intent(in) :: ngpt Number of columns, layers, g-points logical(kind=wl), intent(in) :: top_at_1 ilay = 1 is the top of the atmosphere? real(kind=wp), intent(in), dimension(ncol,nlay, ngpt) :: tau Optical thickness, single-scattering albedo, asymmetry parameter [] real(kind=wp), intent(in), dimension(ncol,nlay, ngpt) :: ssa Optical thickness, single-scattering albedo, asymmetry parameter [] real(kind=wp), intent(in), dimension(ncol,nlay, ngpt) :: g Optical thickness, single-scattering albedo, asymmetry parameter [] real(kind=wp), intent(in), dimension(ncol,nlay, ngpt) :: lay_source Planck source at layer average temperature [W/m2] real(kind=wp), intent(in), dimension(ncol,nlay, ngpt) :: lev_source_inc Planck source at layer edge for radiation in increasing ilay direction [W/m2] real(kind=wp), intent(in), dimension(ncol,nlay, ngpt) :: lev_source_dec Planck source at layer edge for radiation in decreasing ilay direction [W/m2] real(kind=wp), intent(in), dimension(ncol, ngpt) :: sfc_emis Surface emissivity [] real(kind=wp), intent(in), dimension(ncol, ngpt) :: sfc_src Surface source function [W/m2] real(kind=wp), intent(in), dimension(ncol, ngpt) :: inc_flux Incident diffuse flux, probably 0 [W/m2] real(kind=wp), intent(out), dimension(ncol,nlay+1,ngpt) :: flux_up Fluxes [W/m2] real(kind=wp), intent(out), dimension(ncol,nlay+1,ngpt) :: flux_dn Fluxes [W/m2] public subroutine lw_solver_noscat (ncol, nlay, ngpt, top_at_1, nmus, Ds, weights, tau, lay_source, lev_source_inc, lev_source_dec, sfc_emis, sfc_src, inc_flux, flux_up, flux_dn, do_broadband, broadband_up, broadband_dn, do_Jacobians, sfc_srcJac, flux_upJac, do_rescaling, ssa, g) bind(C, name=\"0\") LW transport, no scattering, multi-angle quadrature\n Users provide a set of weights and quadrature angles\n Routine sums over single-angle solutions for each sets of angles/weights Arguments Type Intent Optional Attributes Name integer, intent(in) :: ncol Number of columns, layers, g-points integer, intent(in) :: nlay Number of columns, layers, g-points integer, intent(in) :: ngpt Number of columns, layers, g-points logical(kind=wl), intent(in) :: top_at_1 ilay = 1 is the top of the atmosphere? integer, intent(in) :: nmus number of quadrature angles real(kind=wp), intent(in), dimension (ncol, ngpt, nmus) :: Ds quadrature secants real(kind=wp), intent(in), dimension(nmus) :: weights quadrature weights real(kind=wp), intent(in), dimension(ncol,nlay, ngpt) :: tau Absorption optical thickness [] real(kind=wp), intent(in), dimension(ncol,nlay, ngpt) :: lay_source Planck source at layer average temperature [W/m2] real(kind=wp), intent(in), dimension(ncol,nlay, ngpt) :: lev_source_inc Planck source at layer edge for radiation in increasing ilay direction [W/m2] real(kind=wp), intent(in), dimension(ncol,nlay, ngpt) :: lev_source_dec Planck source at layer edge for radiation in decreasing ilay direction [W/m2] real(kind=wp), intent(in), dimension(ncol, ngpt) :: sfc_emis Surface emissivity [] real(kind=wp), intent(in), dimension(ncol, ngpt) :: sfc_src Surface source function [W/m2] real(kind=wp), intent(in), dimension(ncol, ngpt) :: inc_flux Incident diffuse flux, probably 0 [W/m2] real(kind=wp), intent(out), dimension(ncol,nlay+1,ngpt), target :: flux_up Fluxes [W/m2] real(kind=wp), intent(out), dimension(ncol,nlay+1,ngpt), target :: flux_dn Fluxes [W/m2] logical(kind=wl), intent(in) :: do_broadband real(kind=wp), intent(out), dimension(ncol,nlay+1 ), target :: broadband_up Spectrally-integrated fluxes [W/m2] real(kind=wp), intent(out), dimension(ncol,nlay+1 ), target :: broadband_dn Spectrally-integrated fluxes [W/m2] logical(kind=wl), intent(in) :: do_Jacobians compute Jacobian with respect to surface temeprature? real(kind=wp), intent(in), dimension(ncol ,ngpt) :: sfc_srcJac surface temperature Jacobian of surface source function [W/m2/K] real(kind=wp), intent(out), dimension(ncol,nlay+1 ), target :: flux_upJac surface temperature Jacobian of Radiances [W/m2-str / K] logical(kind=wl), intent(in) :: do_rescaling Approximate treatment of scattering (10.1175/JAS-D-18-0014.1) real(kind=wp), intent(in), dimension(ncol,nlay ,ngpt) :: ssa single-scattering albedo, asymmetry parameter real(kind=wp), intent(in), dimension(ncol,nlay ,ngpt) :: g single-scattering albedo, asymmetry parameter public subroutine sw_solver_2stream (ncol, nlay, ngpt, top_at_1, tau, ssa, g, mu0, sfc_alb_dir, sfc_alb_dif, inc_flux_dir, flux_up, flux_dn, flux_dir, has_dif_bc, inc_flux_dif, do_broadband, broadband_up, broadband_dn, broadband_dir) bind(C, name=\"0\") Shortwave two-stream calculation:\n compute layer reflectance, transmittance\n compute solar source function for diffuse radiation\n transport Arguments Type Intent Optional Attributes Name integer, intent(in) :: ncol Number of columns, layers, g-points integer, intent(in) :: nlay Number of columns, layers, g-points integer, intent(in) :: ngpt Number of columns, layers, g-points logical(kind=wl), intent(in) :: top_at_1 ilay = 1 is the top of the atmosphere? real(kind=wp), intent(in), dimension(ncol,nlay, ngpt) :: tau Optical thickness, single-scattering albedo, asymmetry parameter [] real(kind=wp), intent(in), dimension(ncol,nlay, ngpt) :: ssa Optical thickness, single-scattering albedo, asymmetry parameter [] real(kind=wp), intent(in), dimension(ncol,nlay, ngpt) :: g Optical thickness, single-scattering albedo, asymmetry parameter [] real(kind=wp), intent(in), dimension(ncol,nlay ) :: mu0 cosine of solar zenith angle real(kind=wp), intent(in), dimension(ncol, ngpt) :: sfc_alb_dir Spectral surface albedo for direct and diffuse radiation real(kind=wp), intent(in), dimension(ncol, ngpt) :: sfc_alb_dif Spectral surface albedo for direct and diffuse radiation real(kind=wp), intent(in), dimension(ncol, ngpt) :: inc_flux_dir Direct beam incident flux real(kind=wp), intent(out), dimension(ncol,nlay+1,ngpt), target :: flux_up Fluxes [W/m2] real(kind=wp), intent(out), dimension(ncol,nlay+1,ngpt), target :: flux_dn Fluxes [W/m2] real(kind=wp), intent(out), dimension(ncol,nlay+1,ngpt), target :: flux_dir Fluxes [W/m2] logical(kind=wl), intent(in) :: has_dif_bc Is a boundary condition for diffuse flux supplied? real(kind=wp), intent(in), dimension(ncol, ngpt) :: inc_flux_dif Boundary condition for diffuse flux [W/m2] logical(kind=wl), intent(in) :: do_broadband Provide broadband-integrated, not spectrally-resolved, fluxes? real(kind=wp), intent(out), dimension(ncol,nlay+1 ) :: broadband_up Broadband integrated fluxes real(kind=wp), intent(out), dimension(ncol,nlay+1 ) :: broadband_dn Broadband integrated fluxes real(kind=wp), intent(out), dimension(ncol,nlay+1 ) :: broadband_dir Broadband integrated fluxes public pure subroutine sw_solver_noscat (ncol, nlay, ngpt, top_at_1, tau, mu0, inc_flux_dir, flux_dir) bind(C, name=\"0\") Arguments Type Intent Optional Attributes Name integer, intent(in) :: ncol Number of columns, layers, g-points integer, intent(in) :: nlay Number of columns, layers, g-points integer, intent(in) :: ngpt Number of columns, layers, g-points logical(kind=wl), intent(in) :: top_at_1 ilay = 1 is the top of the atmosphere? real(kind=wp), intent(in), dimension(ncol,nlay, ngpt) :: tau Absorption optical thickness [] real(kind=wp), intent(in), dimension(ncol,nlay ) :: mu0 cosine of solar zenith angle real(kind=wp), intent(in), dimension(ncol, ngpt) :: inc_flux_dir Direct beam incident flux [W/m2] real(kind=wp), intent(out), dimension(ncol,nlay+1,ngpt) :: flux_dir Direct-beam flux, spectral [W/m2]","tags":"","loc":"module/mo_rte_solver_kernels.html"},{"title":"mo_rte_util_array – RTE kernels","text":"Uses mo_rte_kind module~~mo_rte_util_array~~UsesGraph module~mo_rte_util_array mo_rte_util_array mo_rte_kind mo_rte_kind module~mo_rte_util_array->mo_rte_kind Help × Graph Key Nodes of different colours represent the following: Graph Key Module Module Submodule Submodule Subroutine Subroutine Function Function Program Program This Page's Entity This Page's Entity Solid arrows point from a submodule to the (sub)module which it is\n descended from. Dashed arrows point from a module or program unit to \n modules which it uses. Used by module~~mo_rte_util_array~~UsedByGraph module~mo_rte_util_array mo_rte_util_array module~mo_rte_solver_kernels mo_rte_solver_kernels module~mo_rte_solver_kernels->module~mo_rte_util_array Help × Graph Key Nodes of different colours represent the following: Graph Key Module Module Submodule Submodule Subroutine Subroutine Function Function Program Program This Page's Entity This Page's Entity Solid arrows point from a submodule to the (sub)module which it is\n descended from. Dashed arrows point from a module or program unit to \n modules which it uses. Contents Interfaces zero_array Subroutines zero_array_1D zero_array_2D zero_array_3D zero_array_4D Interfaces public interface zero_array Efficiently set arrays to zero public subroutine zero_array_1D (ni, array) bind(C, name=\"0\") Arguments Type Intent Optional Attributes Name integer, intent(in) :: ni real(kind=wp), intent(out), dimension(ni) :: array public subroutine zero_array_2D (ni, nj, array) bind(C, name=\"0\") Arguments Type Intent Optional Attributes Name integer, intent(in) :: ni integer, intent(in) :: nj real(kind=wp), intent(out), dimension(ni, nj) :: array public subroutine zero_array_3D (ni, nj, nk, array) bind(C, name=\"0\") Arguments Type Intent Optional Attributes Name integer, intent(in) :: ni integer, intent(in) :: nj integer, intent(in) :: nk real(kind=wp), intent(out), dimension(ni, nj, nk) :: array public subroutine zero_array_4D (ni, nj, nk, nl, array) bind(C, name=\"0\") Arguments Type Intent Optional Attributes Name integer, intent(in) :: ni integer, intent(in) :: nj integer, intent(in) :: nk integer, intent(in) :: nl real(kind=wp), intent(out), dimension(ni, nj, nk, nl) :: array Subroutines public subroutine zero_array_1D (ni, array) bind(C, name=\"0\") Arguments Type Intent Optional Attributes Name integer, intent(in) :: ni real(kind=wp), intent(out), dimension(ni) :: array public subroutine zero_array_2D (ni, nj, array) bind(C, name=\"0\") Arguments Type Intent Optional Attributes Name integer, intent(in) :: ni integer, intent(in) :: nj real(kind=wp), intent(out), dimension(ni, nj) :: array public subroutine zero_array_3D (ni, nj, nk, array) bind(C, name=\"0\") Arguments Type Intent Optional Attributes Name integer, intent(in) :: ni integer, intent(in) :: nj integer, intent(in) :: nk real(kind=wp), intent(out), dimension(ni, nj, nk) :: array public subroutine zero_array_4D (ni, nj, nk, nl, array) bind(C, name=\"0\") Arguments Type Intent Optional Attributes Name integer, intent(in) :: ni integer, intent(in) :: nj integer, intent(in) :: nk integer, intent(in) :: nl real(kind=wp), intent(out), dimension(ni, nj, nk, nl) :: array","tags":"","loc":"module/mo_rte_util_array.html"},{"title":"mo_optical_props_kernels – RTE kernels","text":"Kernels for arrays of optical properties: - delta-scaling\n- adding two sets of properties\n- extracting subsets along the column dimension Uses mo_rte_kind iso_c_binding module~~mo_optical_props_kernels~~UsesGraph module~mo_optical_props_kernels mo_optical_props_kernels mo_rte_kind mo_rte_kind module~mo_optical_props_kernels->mo_rte_kind iso_c_binding iso_c_binding module~mo_optical_props_kernels->iso_c_binding Help × Graph Key Nodes of different colours represent the following: Graph Key Module Module Submodule Submodule Subroutine Subroutine Function Function Program Program This Page's Entity This Page's Entity Solid arrows point from a submodule to the (sub)module which it is\n descended from. Dashed arrows point from a module or program unit to \n modules which it uses. Contents Interfaces delta_scale_2str_kernel extract_subset Subroutines delta_scale_2str_f_k delta_scale_2str_k extract_subset_absorption_tau extract_subset_dim1_3d extract_subset_dim2_4d inc_1scalar_by_1scalar_bybnd inc_1scalar_by_2stream_bybnd inc_1scalar_by_nstream_bybnd inc_2stream_by_1scalar_bybnd inc_2stream_by_2stream_bybnd inc_2stream_by_nstream_bybnd inc_nstream_by_1scalar_bybnd inc_nstream_by_2stream_bybnd inc_nstream_by_nstream_bybnd increment_1scalar_by_1scalar increment_1scalar_by_2stream increment_1scalar_by_nstream increment_2stream_by_1scalar increment_2stream_by_2stream increment_2stream_by_nstream increment_nstream_by_1scalar increment_nstream_by_2stream increment_nstream_by_nstream Interfaces public interface delta_scale_2str_kernel Delta-scale two-stream optical properties public pure subroutine delta_scale_2str_f_k (ncol, nlay, ngpt, tau, ssa, g, f) bind(C, name=\"0\") Delta-scale two-stream optical properties given user-provided value of (forward scattering) Arguments Type Intent Optional Attributes Name integer, intent(in) :: ncol Array sizes integer, intent(in) :: nlay Array sizes integer, intent(in) :: ngpt Array sizes real(kind=wp), intent(inout), dimension(ncol, nlay, ngpt) :: tau Optical depth, single-scattering albedo, asymmetry parameter real(kind=wp), intent(inout), dimension(ncol, nlay, ngpt) :: ssa Optical depth, single-scattering albedo, asymmetry parameter real(kind=wp), intent(inout), dimension(ncol, nlay, ngpt) :: g Optical depth, single-scattering albedo, asymmetry parameter real(kind=wp), intent(in), dimension(ncol, nlay, ngpt) :: f User-provided forward-scattering fraction public pure subroutine delta_scale_2str_k (ncol, nlay, ngpt, tau, ssa, g) bind(C, name=\"0\") Delta-scale assuming forward-scatternig fraction is the square of the asymmetry parameter\n i.e. Arguments Type Intent Optional Attributes Name integer, intent(in) :: ncol Array sizes integer, intent(in) :: nlay Array sizes integer, intent(in) :: ngpt Array sizes real(kind=wp), intent(inout), dimension(ncol, nlay, ngpt) :: tau Optical depth, single-scattering albedo, asymmetry parameter real(kind=wp), intent(inout), dimension(ncol, nlay, ngpt) :: ssa Optical depth, single-scattering albedo, asymmetry parameter real(kind=wp), intent(inout), dimension(ncol, nlay, ngpt) :: g Optical depth, single-scattering albedo, asymmetry parameter public interface extract_subset Subsetting, meaning extracting some portion of the 3D domain public pure subroutine extract_subset_dim1_3d (ncol, nlay, ngpt, array_in, colS, colE, array_out) bind(C, name=\"0\") Extract a subset from the first dimension (normally columns) of a 3D field.\n Applicable to most variables e.g. tau, ssa, g Arguments Type Intent Optional Attributes Name integer, intent(in) :: ncol Array sizes integer, intent(in) :: nlay Array sizes integer, intent(in) :: ngpt Array sizes real(kind=wp), intent(in), dimension(ncol,nlay,ngpt) :: array_in Array to subset integer, intent(in) :: colS Starting and ending index integer, intent(in) :: colE Starting and ending index real(kind=wp), intent(out), dimension(colE-colS+1, nlay,ngpt) :: array_out subset of the input array public pure subroutine extract_subset_dim2_4d (nmom, ncol, nlay, ngpt, array_in, colS, colE, array_out) bind(C, name=\"0\") Extract a subset from the second dimension (normally columns) of a 4D field.\n Applicable to phase function moments, where the first dimension is the moment Arguments Type Intent Optional Attributes Name integer, intent(in) :: nmom Array sizes integer, intent(in) :: ncol Array sizes integer, intent(in) :: nlay Array sizes integer, intent(in) :: ngpt Array sizes real(kind=wp), intent(in), dimension(nmom,ncol,nlay,ngpt) :: array_in Array to subset integer, intent(in) :: colS Starting and ending index integer, intent(in) :: colE Starting and ending index real(kind=wp), intent(out), dimension(nmom,colE-colS+1, nlay,ngpt) :: array_out subset of the input array public pure subroutine extract_subset_absorption_tau (ncol, nlay, ngpt, tau_in, ssa_in, colS, colE, tau_out) bind(C, name=\"0\") Extract the absorption optical thickness Arguments Type Intent Optional Attributes Name integer, intent(in) :: ncol Array sizes integer, intent(in) :: nlay Array sizes integer, intent(in) :: ngpt Array sizes real(kind=wp), intent(in), dimension(ncol,nlay,ngpt) :: tau_in Optical thickness, single scattering albedo real(kind=wp), intent(in), dimension(ncol,nlay,ngpt) :: ssa_in Optical thickness, single scattering albedo integer, intent(in) :: colS Starting and ending index integer, intent(in) :: colE Starting and ending index real(kind=wp), intent(out), dimension(colE-colS+1, nlay,ngpt) :: tau_out absorption optical thickness subset Subroutines public pure subroutine delta_scale_2str_f_k (ncol, nlay, ngpt, tau, ssa, g, f) bind(C, name=\"0\") Delta-scale two-stream optical properties given user-provided value of (forward scattering) Arguments Type Intent Optional Attributes Name integer, intent(in) :: ncol Array sizes integer, intent(in) :: nlay Array sizes integer, intent(in) :: ngpt Array sizes real(kind=wp), intent(inout), dimension(ncol, nlay, ngpt) :: tau Optical depth, single-scattering albedo, asymmetry parameter real(kind=wp), intent(inout), dimension(ncol, nlay, ngpt) :: ssa Optical depth, single-scattering albedo, asymmetry parameter real(kind=wp), intent(inout), dimension(ncol, nlay, ngpt) :: g Optical depth, single-scattering albedo, asymmetry parameter real(kind=wp), intent(in), dimension(ncol, nlay, ngpt) :: f User-provided forward-scattering fraction public pure subroutine delta_scale_2str_k (ncol, nlay, ngpt, tau, ssa, g) bind(C, name=\"0\") Delta-scale assuming forward-scatternig fraction is the square of the asymmetry parameter\n i.e. Arguments Type Intent Optional Attributes Name integer, intent(in) :: ncol Array sizes integer, intent(in) :: nlay Array sizes integer, intent(in) :: ngpt Array sizes real(kind=wp), intent(inout), dimension(ncol, nlay, ngpt) :: tau Optical depth, single-scattering albedo, asymmetry parameter real(kind=wp), intent(inout), dimension(ncol, nlay, ngpt) :: ssa Optical depth, single-scattering albedo, asymmetry parameter real(kind=wp), intent(inout), dimension(ncol, nlay, ngpt) :: g Optical depth, single-scattering albedo, asymmetry parameter public pure subroutine extract_subset_absorption_tau (ncol, nlay, ngpt, tau_in, ssa_in, colS, colE, tau_out) bind(C, name=\"0\") Extract the absorption optical thickness Arguments Type Intent Optional Attributes Name integer, intent(in) :: ncol Array sizes integer, intent(in) :: nlay Array sizes integer, intent(in) :: ngpt Array sizes real(kind=wp), intent(in), dimension(ncol,nlay,ngpt) :: tau_in Optical thickness, single scattering albedo real(kind=wp), intent(in), dimension(ncol,nlay,ngpt) :: ssa_in Optical thickness, single scattering albedo integer, intent(in) :: colS Starting and ending index integer, intent(in) :: colE Starting and ending index real(kind=wp), intent(out), dimension(colE-colS+1, nlay,ngpt) :: tau_out absorption optical thickness subset public pure subroutine extract_subset_dim1_3d (ncol, nlay, ngpt, array_in, colS, colE, array_out) bind(C, name=\"0\") Extract a subset from the first dimension (normally columns) of a 3D field.\n Applicable to most variables e.g. tau, ssa, g Arguments Type Intent Optional Attributes Name integer, intent(in) :: ncol Array sizes integer, intent(in) :: nlay Array sizes integer, intent(in) :: ngpt Array sizes real(kind=wp), intent(in), dimension(ncol,nlay,ngpt) :: array_in Array to subset integer, intent(in) :: colS Starting and ending index integer, intent(in) :: colE Starting and ending index real(kind=wp), intent(out), dimension(colE-colS+1, nlay,ngpt) :: array_out subset of the input array public pure subroutine extract_subset_dim2_4d (nmom, ncol, nlay, ngpt, array_in, colS, colE, array_out) bind(C, name=\"0\") Extract a subset from the second dimension (normally columns) of a 4D field.\n Applicable to phase function moments, where the first dimension is the moment Arguments Type Intent Optional Attributes Name integer, intent(in) :: nmom Array sizes integer, intent(in) :: ncol Array sizes integer, intent(in) :: nlay Array sizes integer, intent(in) :: ngpt Array sizes real(kind=wp), intent(in), dimension(nmom,ncol,nlay,ngpt) :: array_in Array to subset integer, intent(in) :: colS Starting and ending index integer, intent(in) :: colE Starting and ending index real(kind=wp), intent(out), dimension(nmom,colE-colS+1, nlay,ngpt) :: array_out subset of the input array public pure subroutine inc_1scalar_by_1scalar_bybnd (ncol, nlay, ngpt, tau1, tau2, nbnd, gpt_lims) bind(C, name=\"0\") increase one absorption optical depth defined on g-points by a second value defined on bands Arguments Type Intent Optional Attributes Name integer, intent(in) :: ncol array sizes integer, intent(in) :: nlay array sizes integer, intent(in) :: ngpt array sizes real(kind=wp), intent(inout), dimension(ncol,nlay,ngpt) :: tau1 optical properties to be modified (defined on g-points) real(kind=wp), intent(in), dimension(ncol,nlay,nbnd) :: tau2 optical properties to be added to original (defined on bands) integer, intent(in) :: nbnd array sizes integer, intent(in), dimension(2,nbnd) :: gpt_lims Starting and ending gpoint for each band public pure subroutine inc_1scalar_by_2stream_bybnd (ncol, nlay, ngpt, tau1, tau2, ssa2, nbnd, gpt_lims) bind(C, name=\"0\") increase absorption optical depth defined on g-points with extinction optical depth (2-stream form) defined on bands Arguments Type Intent Optional Attributes Name integer, intent(in) :: ncol array sizes integer, intent(in) :: nlay array sizes integer, intent(in) :: ngpt array sizes real(kind=wp), intent(inout), dimension(ncol,nlay,ngpt) :: tau1 optical properties to be modified (defined on g-points) real(kind=wp), intent(in), dimension(ncol,nlay,nbnd) :: tau2 optical properties to be added to original (defined on bands) real(kind=wp), intent(in), dimension(ncol,nlay,nbnd) :: ssa2 optical properties to be added to original (defined on bands) integer, intent(in) :: nbnd array sizes integer, intent(in), dimension(2,nbnd) :: gpt_lims Starting and ending gpoint for each band public pure subroutine inc_1scalar_by_nstream_bybnd (ncol, nlay, ngpt, tau1, tau2, ssa2, nbnd, gpt_lims) bind(C, name=\"0\") increase absorption optical depth defined on g-points with extinction optical depth (n-stream form) defined on bands Arguments Type Intent Optional Attributes Name integer, intent(in) :: ncol array sizes integer, intent(in) :: nlay array sizes integer, intent(in) :: ngpt array sizes real(kind=wp), intent(inout), dimension(ncol,nlay,ngpt) :: tau1 optical properties to be modified (defined on g-points) real(kind=wp), intent(in), dimension(ncol,nlay,nbnd) :: tau2 optical properties to be added to original (defined on bands) real(kind=wp), intent(in), dimension(ncol,nlay,nbnd) :: ssa2 optical properties to be added to original (defined on bands) integer, intent(in) :: nbnd array sizes integer, intent(in), dimension(2,nbnd) :: gpt_lims Starting and ending gpoint for each band public pure subroutine inc_2stream_by_1scalar_bybnd (ncol, nlay, ngpt, tau1, ssa1, tau2, nbnd, gpt_lims) bind(C, name=\"0\") increment two-stream optical properties defined on g-points with absorption optical depth defined on bands Arguments Type Intent Optional Attributes Name integer, intent(in) :: ncol array sizes integer, intent(in) :: nlay array sizes integer, intent(in) :: ngpt array sizes real(kind=wp), intent(inout), dimension(ncol,nlay,ngpt) :: tau1 optical properties to be modified (defined on g-points) real(kind=wp), intent(inout), dimension(ncol,nlay,ngpt) :: ssa1 optical properties to be modified (defined on g-points) real(kind=wp), intent(in), dimension(ncol,nlay,nbnd) :: tau2 optical properties to be added to original (defined on bands) integer, intent(in) :: nbnd array sizes integer, intent(in), dimension(2,nbnd) :: gpt_lims Starting and ending gpoint for each band public pure subroutine inc_2stream_by_2stream_bybnd (ncol, nlay, ngpt, tau1, ssa1, g1, tau2, ssa2, g2, nbnd, gpt_lims) bind(C, name=\"0\") increment 2-stream optical properties defined on g-points with another set defined on bands Arguments Type Intent Optional Attributes Name integer, intent(in) :: ncol array sizes integer, intent(in) :: nlay array sizes integer, intent(in) :: ngpt array sizes real(kind=wp), intent(inout), dimension(ncol,nlay,ngpt) :: tau1 optical properties to be modified (defined on g-points) real(kind=wp), intent(inout), dimension(ncol,nlay,ngpt) :: ssa1 optical properties to be modified (defined on g-points) real(kind=wp), intent(inout), dimension(ncol,nlay,ngpt) :: g1 optical properties to be modified (defined on g-points) real(kind=wp), intent(in), dimension(ncol,nlay,nbnd) :: tau2 optical properties to be added to original (defined on bands) real(kind=wp), intent(in), dimension(ncol,nlay,nbnd) :: ssa2 optical properties to be added to original (defined on bands) real(kind=wp), intent(in), dimension(ncol,nlay,nbnd) :: g2 optical properties to be added to original (defined on bands) integer, intent(in) :: nbnd array sizes integer, intent(in), dimension(2,nbnd) :: gpt_lims Starting and ending gpoint for each band public pure subroutine inc_2stream_by_nstream_bybnd (ncol, nlay, ngpt, nmom2, tau1, ssa1, g1, tau2, ssa2, p2, nbnd, gpt_lims) bind(C, name=\"0\") increment 2-stream optical properties defined on g-points with n -stream properties set defined on bands Arguments Type Intent Optional Attributes Name integer, intent(in) :: ncol array sizes integer, intent(in) :: nlay array sizes integer, intent(in) :: ngpt array sizes integer, intent(in) :: nmom2 array sizes real(kind=wp), intent(inout), dimension(ncol,nlay,ngpt) :: tau1 optical properties to be modified (defined on g-points) real(kind=wp), intent(inout), dimension(ncol,nlay,ngpt) :: ssa1 optical properties to be modified (defined on g-points) real(kind=wp), intent(inout), dimension(ncol,nlay,ngpt) :: g1 optical properties to be modified (defined on g-points) real(kind=wp), intent(in), dimension(ncol,nlay,nbnd) :: tau2 optical properties to be added to original (defined on bands) real(kind=wp), intent(in), dimension(ncol,nlay,nbnd) :: ssa2 optical properties to be added to original (defined on bands) real(kind=wp), intent(in), dimension(nmom2, ncol,nlay,nbnd) :: p2 moments of the phase function to be added integer, intent(in) :: nbnd array sizes integer, intent(in), dimension(2,nbnd) :: gpt_lims Starting and ending gpoint for each band public pure subroutine inc_nstream_by_1scalar_bybnd (ncol, nlay, ngpt, tau1, ssa1, tau2, nbnd, gpt_lims) bind(C, name=\"0\") increment n -stream optical properties defined on g-points with absorption optical depth defined on bands Arguments Type Intent Optional Attributes Name integer, intent(in) :: ncol array sizes integer, intent(in) :: nlay array sizes integer, intent(in) :: ngpt array sizes real(kind=wp), intent(inout), dimension(ncol,nlay,ngpt) :: tau1 optical properties to be modified (defined on g-points) real(kind=wp), intent(inout), dimension(ncol,nlay,ngpt) :: ssa1 optical properties to be modified (defined on g-points) real(kind=wp), intent(in), dimension(ncol,nlay,nbnd) :: tau2 optical properties to be added to original (defined on bands) integer, intent(in) :: nbnd array sizes integer, intent(in), dimension(2,nbnd) :: gpt_lims Starting and ending gpoint for each band public pure subroutine inc_nstream_by_2stream_bybnd (ncol, nlay, ngpt, nmom1, tau1, ssa1, p1, tau2, ssa2, g2, nbnd, gpt_lims) bind(C, name=\"0\") increment n-stream optical properties defined on g-points with 2-stream properties set defined on bands Arguments Type Intent Optional Attributes Name integer, intent(in) :: ncol array sizes integer, intent(in) :: nlay array sizes integer, intent(in) :: ngpt array sizes integer, intent(in) :: nmom1 array sizes real(kind=wp), intent(inout), dimension(ncol,nlay,ngpt) :: tau1 optical properties to be modified (defined on g-points) real(kind=wp), intent(inout), dimension(ncol,nlay,ngpt) :: ssa1 optical properties to be modified (defined on g-points) real(kind=wp), intent(inout), dimension(nmom1, ncol,nlay,ngpt) :: p1 moments of the phase function be modified real(kind=wp), intent(in), dimension(ncol,nlay,nbnd) :: tau2 optical properties to be added to original (defined on bands) real(kind=wp), intent(in), dimension(ncol,nlay,nbnd) :: ssa2 optical properties to be added to original (defined on bands) real(kind=wp), intent(in), dimension(ncol,nlay,nbnd) :: g2 optical properties to be added to original (defined on bands) integer, intent(in) :: nbnd array sizes integer, intent(in), dimension(2,nbnd) :: gpt_lims Starting and ending gpoint for each band public pure subroutine inc_nstream_by_nstream_bybnd (ncol, nlay, ngpt, nmom1, nmom2, tau1, ssa1, p1, tau2, ssa2, p2, nbnd, gpt_lims) bind(C, name=\"0\") increment n -stream optical properties defined on g-points with a second set defined on bands Arguments Type Intent Optional Attributes Name integer, intent(in) :: ncol array sizes integer, intent(in) :: nlay array sizes integer, intent(in) :: ngpt array sizes integer, intent(in) :: nmom1 array sizes integer, intent(in) :: nmom2 array sizes real(kind=wp), intent(inout), dimension(ncol,nlay,ngpt) :: tau1 optical properties to be modified (defined on g-points) real(kind=wp), intent(inout), dimension(ncol,nlay,ngpt) :: ssa1 optical properties to be modified (defined on g-points) real(kind=wp), intent(inout), dimension(nmom1, ncol,nlay,ngpt) :: p1 moments of the phase function be modified real(kind=wp), intent(in), dimension(ncol,nlay,nbnd) :: tau2 optical properties to be added to original (defined on bands) real(kind=wp), intent(in), dimension(ncol,nlay,nbnd) :: ssa2 optical properties to be added to original (defined on bands) real(kind=wp), intent(in), dimension(nmom2, ncol,nlay,nbnd) :: p2 moments of the phase function to be added integer, intent(in) :: nbnd array sizes integer, intent(in), dimension(2,nbnd) :: gpt_lims Starting and ending gpoint for each band public pure subroutine increment_1scalar_by_1scalar (ncol, nlay, ngpt, tau1, tau2) bind(C, name=\"0\") increase one absorption optical depth by a second value Arguments Type Intent Optional Attributes Name integer, intent(in) :: ncol array sizes integer, intent(in) :: nlay array sizes integer, intent(in) :: ngpt array sizes real(kind=wp), intent(inout), dimension(ncol,nlay,ngpt) :: tau1 optical properties to be modified real(kind=wp), intent(in), dimension(ncol,nlay,ngpt) :: tau2 optical properties to be added to original public pure subroutine increment_1scalar_by_2stream (ncol, nlay, ngpt, tau1, tau2, ssa2) bind(C, name=\"0\") increase absorption optical depth with extinction optical depth (2-stream form) Arguments Type Intent Optional Attributes Name integer, intent(in) :: ncol array sizes integer, intent(in) :: nlay array sizes integer, intent(in) :: ngpt array sizes real(kind=wp), intent(inout), dimension(ncol,nlay,ngpt) :: tau1 optical properties to be modified real(kind=wp), intent(in), dimension(ncol,nlay,ngpt) :: tau2 optical properties to be added to original real(kind=wp), intent(in), dimension(ncol,nlay,ngpt) :: ssa2 optical properties to be added to original public pure subroutine increment_1scalar_by_nstream (ncol, nlay, ngpt, tau1, tau2, ssa2) bind(C, name=\"0\") increase absorption optical depth with extinction optical depth (n-stream form) Arguments Type Intent Optional Attributes Name integer, intent(in) :: ncol array sizes integer, intent(in) :: nlay array sizes integer, intent(in) :: ngpt array sizes real(kind=wp), intent(inout), dimension(ncol,nlay,ngpt) :: tau1 optical properties to be modified real(kind=wp), intent(in), dimension(ncol,nlay,ngpt) :: tau2 optical properties to be added to original real(kind=wp), intent(in), dimension(ncol,nlay,ngpt) :: ssa2 optical properties to be added to original public pure subroutine increment_2stream_by_1scalar (ncol, nlay, ngpt, tau1, ssa1, tau2) bind(C, name=\"0\") increment two-stream optical properties with absorption optical depth Arguments Type Intent Optional Attributes Name integer, intent(in) :: ncol array sizes integer, intent(in) :: nlay array sizes integer, intent(in) :: ngpt array sizes real(kind=wp), intent(inout), dimension(ncol,nlay,ngpt) :: tau1 optical properties to be modified real(kind=wp), intent(inout), dimension(ncol,nlay,ngpt) :: ssa1 optical properties to be modified real(kind=wp), intent(in), dimension(ncol,nlay,ngpt) :: tau2 optical properties to be added to original public pure subroutine increment_2stream_by_2stream (ncol, nlay, ngpt, tau1, ssa1, g1, tau2, ssa2, g2) bind(C, name=\"0\") increment two-stream optical properties with a second set Arguments Type Intent Optional Attributes Name integer, intent(in) :: ncol array sizes integer, intent(in) :: nlay array sizes integer, intent(in) :: ngpt array sizes real(kind=wp), intent(inout), dimension(ncol,nlay,ngpt) :: tau1 optical properties to be modified real(kind=wp), intent(inout), dimension(ncol,nlay,ngpt) :: ssa1 optical properties to be modified real(kind=wp), intent(inout), dimension(ncol,nlay,ngpt) :: g1 optical properties to be modified real(kind=wp), intent(in), dimension(ncol,nlay,ngpt) :: tau2 optical properties to be added to original real(kind=wp), intent(in), dimension(ncol,nlay,ngpt) :: ssa2 optical properties to be added to original real(kind=wp), intent(in), dimension(ncol,nlay,ngpt) :: g2 optical properties to be added to original public pure subroutine increment_2stream_by_nstream (ncol, nlay, ngpt, nmom2, tau1, ssa1, g1, tau2, ssa2, p2) bind(C, name=\"0\") increment two-stream optical properties with n -stream Arguments Type Intent Optional Attributes Name integer, intent(in) :: ncol array sizes integer, intent(in) :: nlay array sizes integer, intent(in) :: ngpt array sizes integer, intent(in) :: nmom2 array sizes real(kind=wp), intent(inout), dimension(ncol,nlay,ngpt) :: tau1 optical properties to be modified real(kind=wp), intent(inout), dimension(ncol,nlay,ngpt) :: ssa1 optical properties to be modified real(kind=wp), intent(inout), dimension(ncol,nlay,ngpt) :: g1 optical properties to be modified real(kind=wp), intent(in), dimension(ncol,nlay,ngpt) :: tau2 optical properties to be added to original real(kind=wp), intent(in), dimension(ncol,nlay,ngpt) :: ssa2 optical properties to be added to original real(kind=wp), intent(in), dimension(nmom2, ncol,nlay,ngpt) :: p2 moments of the phase function to be added public pure subroutine increment_nstream_by_1scalar (ncol, nlay, ngpt, tau1, ssa1, tau2) bind(C, name=\"0\") increment n -stream optical properties with absorption optical depth Arguments Type Intent Optional Attributes Name integer, intent(in) :: ncol array sizes integer, intent(in) :: nlay array sizes integer, intent(in) :: ngpt array sizes real(kind=wp), intent(inout), dimension(ncol,nlay,ngpt) :: tau1 optical properties to be modified real(kind=wp), intent(inout), dimension(ncol,nlay,ngpt) :: ssa1 optical properties to be modified real(kind=wp), intent(in), dimension(ncol,nlay,ngpt) :: tau2 optical properties to be added to original public pure subroutine increment_nstream_by_2stream (ncol, nlay, ngpt, nmom1, tau1, ssa1, p1, tau2, ssa2, g2) bind(C, name=\"0\") increment n -stream optical properties with two-stream values Arguments Type Intent Optional Attributes Name integer, intent(in) :: ncol array sizes integer, intent(in) :: nlay array sizes integer, intent(in) :: ngpt array sizes integer, intent(in) :: nmom1 array sizes real(kind=wp), intent(inout), dimension(ncol,nlay,ngpt) :: tau1 optical properties to be modified real(kind=wp), intent(inout), dimension(ncol,nlay,ngpt) :: ssa1 optical properties to be modified real(kind=wp), intent(inout), dimension(nmom1, ncol,nlay,ngpt) :: p1 moments of the phase function be modified real(kind=wp), intent(in), dimension(ncol,nlay,ngpt) :: tau2 optical properties to be added to original real(kind=wp), intent(in), dimension(ncol,nlay,ngpt) :: ssa2 optical properties to be added to original real(kind=wp), intent(in), dimension(ncol,nlay,ngpt) :: g2 optical properties to be added to original public pure subroutine increment_nstream_by_nstream (ncol, nlay, ngpt, nmom1, nmom2, tau1, ssa1, p1, tau2, ssa2, p2) bind(C, name=\"0\") increment one set of n -stream optical properties with another set Arguments Type Intent Optional Attributes Name integer, intent(in) :: ncol array sizes integer, intent(in) :: nlay array sizes integer, intent(in) :: ngpt array sizes integer, intent(in) :: nmom1 array sizes integer, intent(in) :: nmom2 array sizes real(kind=wp), intent(inout), dimension(ncol,nlay,ngpt) :: tau1 optical properties to be modified real(kind=wp), intent(inout), dimension(ncol,nlay,ngpt) :: ssa1 optical properties to be modified real(kind=wp), intent(inout), dimension(nmom1, ncol,nlay,ngpt) :: p1 moments of the phase function be modified real(kind=wp), intent(in), dimension(ncol,nlay,ngpt) :: tau2 optical properties to be added to original real(kind=wp), intent(in), dimension(ncol,nlay,ngpt) :: ssa2 optical properties to be added to original real(kind=wp), intent(in), dimension(nmom2, ncol,nlay,ngpt) :: p2 moments of the phase function to be added","tags":"","loc":"module/mo_optical_props_kernels.html"},{"title":"mo_fluxes_broadband_kernels – RTE kernels","text":"Kernels for computing broadband fluxes Uses mo_rte_kind iso_c_binding module~~mo_fluxes_broadband_kernels~~UsesGraph module~mo_fluxes_broadband_kernels mo_fluxes_broadband_kernels mo_rte_kind mo_rte_kind module~mo_fluxes_broadband_kernels->mo_rte_kind iso_c_binding iso_c_binding module~mo_fluxes_broadband_kernels->iso_c_binding Help × Graph Key Nodes of different colours represent the following: Graph Key Module Module Submodule Submodule Subroutine Subroutine Function Function Program Program This Page's Entity This Page's Entity Solid arrows point from a submodule to the (sub)module which it is\n descended from. Dashed arrows point from a module or program unit to \n modules which it uses. Contents Interfaces net_broadband Subroutines sum_broadband Interfaces public interface net_broadband Interface for computing net flux private subroutine net_broadband_full(ncol, nlev, ngpt, spectral_flux_dn, spectral_flux_up, broadband_flux_net) bind(C, name=\"0\") Spectral reduction over all points for net flux Arguments Type Intent Optional Attributes Name integer, intent(in) :: ncol Array sizes integer, intent(in) :: nlev Array sizes integer, intent(in) :: ngpt Array sizes real(kind=wp), intent(in), dimension(ncol, nlev, ngpt) :: spectral_flux_dn Spectrally-resolved flux up and down real(kind=wp), intent(in), dimension(ncol, nlev, ngpt) :: spectral_flux_up Spectrally-resolved flux up and down real(kind=wp), intent(out), dimension(ncol, nlev) :: broadband_flux_net Net (down minus up) summed over ngpt private subroutine net_broadband_precalc(ncol, nlev, flux_dn, flux_up, broadband_flux_net) bind(C, name=\"0\") Net flux when bradband flux up and down are already available Arguments Type Intent Optional Attributes Name integer, intent(in) :: ncol Array sizes integer, intent(in) :: nlev Array sizes real(kind=wp), intent(in), dimension(ncol, nlev) :: flux_dn Broadband downward and upward fluxes real(kind=wp), intent(in), dimension(ncol, nlev) :: flux_up Broadband downward and upward fluxes real(kind=wp), intent(out), dimension(ncol, nlev) :: broadband_flux_net Net (down minus up) Subroutines public subroutine sum_broadband (ncol, nlev, ngpt, spectral_flux, broadband_flux) bind(C, name=\"0\") Spectral reduction over all points Arguments Type Intent Optional Attributes Name integer, intent(in) :: ncol Array sizes integer, intent(in) :: nlev Array sizes integer, intent(in) :: ngpt Array sizes real(kind=wp), intent(in), dimension(ncol, nlev, ngpt) :: spectral_flux Spectrally-resolved flux real(kind=wp), intent(out), dimension(ncol, nlev) :: broadband_flux Sum of spectrally-resolved flux over ngpt","tags":"","loc":"module/mo_fluxes_broadband_kernels.html"},{"title":"mo_rte_solver_kernels.F90 – RTE kernels","text":"This file depends on sourcefile~~mo_rte_solver_kernels.f90~~EfferentGraph sourcefile~mo_rte_solver_kernels.f90 mo_rte_solver_kernels.F90 sourcefile~mo_rte_util_array.f90 mo_rte_util_array.F90 sourcefile~mo_rte_solver_kernels.f90->sourcefile~mo_rte_util_array.f90 Help × Graph Key Nodes of different colours represent the following: Graph Key Source File Source File This Page's Entity This Page's Entity Solid arrows point from a file to a file which it depends on. A file\n is dependent upon another if the latter must be compiled before the former\n can be. Contents Modules mo_rte_solver_kernels Source Code mo_rte_solver_kernels.F90 Source Code ! This code is part of Radiative Transfer for Energetics (RTE) ! ! Contacts: Robert Pincus and Eli Mlawer ! email: rrtmgp@aer.com ! ! Copyright 2015-, Atmospheric and Environmental Research, ! Regents of the University of Colorado, Trustees of Columbia University. All right reserved. ! ! Use and duplication is permitted under the terms of the ! BSD 3-clause license, see http://opensource.org/licenses/BSD-3-Clause ! ------------------------------------------------------------------------------------------------- ! !>## Numeric calculations for radiative transfer solvers !> - Emission/absorption (no-scattering) calculations !> - solver for multi-angle Gaussian quadrature !> - solver for a single angle, calling !> - source function computation (linear-in-tau) !> - transport !> - Extinction-only calculation (direct solar beam) !> - Two-stream calculations: !> solvers for LW and SW with different boundary conditions and source functions !> - source function calculation for LW, SW !> - two-stream calculations for LW, SW (using different assumtions about phase function) !> - transport (adding) !> - Application of boundary conditions ! ! ------------------------------------------------------------------------------------------------- module mo_rte_solver_kernels use , intrinsic :: iso_c_binding use mo_rte_kind , only : wp , wl use mo_rte_util_array , only : zero_array implicit none private public :: lw_solver_noscat , lw_solver_2stream , & sw_solver_noscat , sw_solver_2stream real ( wp ), parameter :: pi = acos ( - 1._wp ) contains ! ------------------------------------------------------------------------------------------------- ! ! Top-level longwave kernels ! ! ------------------------------------------------------------------------------------------------- ! !> LW fluxes, no scattering, mu (cosine of integration angle) specified by column !> Does radiation calculation at user-supplied angles; converts radiances to flux !> using user-supplied weights ! ! --------------------------------------------------------------- subroutine lw_solver_noscat_oneangle ( ncol , nlay , ngpt , top_at_1 , D , weight , & tau , lay_source , lev_source_inc , lev_source_dec , sfc_emis , sfc_src , & incident_flux , & flux_up , flux_dn , & do_broadband , broadband_up , broadband_dn , & do_Jacobians , sfc_srcJac , flux_upJac , & do_rescaling , ssa , g ) integer , intent ( in ) :: ncol , nlay , ngpt ! Number of columns, layers, g-points logical ( wl ), intent ( in ) :: top_at_1 real ( wp ), dimension ( ncol , ngpt ), intent ( in ) :: D ! secant of propagation angle [] real ( wp ), intent ( in ) :: weight ! quadrature weight real ( wp ), dimension ( ncol , nlay , ngpt ), intent ( in ) :: tau ! Absorption optical thickness [] real ( wp ), dimension ( ncol , nlay , ngpt ), intent ( in ) :: lay_source ! Planck source at layer average temperature [W/m2] ! Planck source at layer edge for radiation in increasing/decreasing ilay direction ! lev_source_dec applies the mapping in layer i to the Planck function at layer i ! lev_source_inc applies the mapping in layer i to the Planck function at layer i+1 real ( wp ), dimension ( ncol , nlay , ngpt ), target , & intent ( in ) :: lev_source_inc , lev_source_dec real ( wp ), dimension ( ncol , ngpt ), intent ( in ) :: sfc_emis ! Surface emissivity [] real ( wp ), dimension ( ncol , ngpt ), intent ( in ) :: sfc_src ! Surface source function [W/m2] real ( wp ), dimension ( ncol , ngpt ), intent ( in ) :: incident_flux ! Boundary condition for flux [W/m2] real ( wp ), dimension ( ncol , nlay + 1 , ngpt ), target , & ! Fluxes [W/m2] intent ( out ) :: flux_up , flux_dn ! ! Optional variables - arrays aren't referenced if corresponding logical == False ! logical ( wl ), intent ( in ) :: do_broadband real ( wp ), dimension ( ncol , nlay + 1 ), intent ( out ) :: broadband_up , broadband_dn ! Spectrally-integrated fluxes [W/m2] logical ( wl ), intent ( in ) :: do_Jacobians real ( wp ), dimension ( ncol , ngpt ), intent ( in ) :: sfc_srcJac ! surface temperature Jacobian of surface source function [W/m2/K] real ( wp ), dimension ( ncol , nlay + 1 ), intent ( out ) :: flux_upJac ! surface temperature Jacobian of Radiances [W/m2-str / K] logical ( wl ), intent ( in ) :: do_rescaling real ( wp ), dimension ( ncol , nlay , ngpt ), intent ( in ) :: ssa , g ! single-scattering albedo, asymmetry parameter ! ------------------------------------ ! Local variables, no g-point dependency ! integer :: icol , ilay , igpt integer :: top_level , sfc_level real ( wp ), dimension ( ncol , nlay ) :: tau_loc , & ! path length (tau/mu) trans ! transmissivity = exp(-tau) real ( wp ), dimension ( ncol , nlay ) :: source_dn , source_up real ( wp ), dimension ( ncol ) :: sfc_albedo real ( wp ), dimension (:,:,:), pointer :: lev_source_up , lev_source_dn ! Mapping increasing/decreasing indicies to up/down real ( wp ), parameter :: pi = acos ( - 1._wp ) ! loc_fluxes hold a single g-point flux if fluxes are being integrated instead of returned ! with spectral detail real ( wp ), dimension ( ncol , nlay + 1 ), & target :: loc_flux_up , loc_flux_dn ! gpt_fluxes point to calculations for the current g-point real ( wp ), dimension (:,:), pointer :: gpt_flux_up , gpt_flux_dn ! ------------------------------------------------------------------------------------------------- ! Optionally, use an approximate treatment of scattering using rescaling ! Implemented based on the paper ! Tang G, et al, 2018: https://doi.org/10.1175/JAS-D-18-0014.1 ! a) relies on rescaling of the optical parameters based on asymetry factor and single scattering albedo ! scaling can be computed by scaling_1rescl ! b) adds adustment term based on cloud properties (lw_transport_1rescl) ! adustment terms is computed based on solution of the Tang equations ! for \"linear-in-tau\" internal source (not in the paper) ! ! Used when approximating scattering ! real ( wp ) :: ssal , wb , scaleTau real ( wp ), dimension ( ncol , nlay ) :: An , Cn real ( wp ), dimension ( ncol , nlay + 1 ) :: gpt_flux_Jac ! ------------------------------------ ! Which way is up? ! Level Planck sources for upward and downward radiation ! When top_at_1, lev_source_up => lev_source_dec ! lev_source_dn => lev_source_inc, and vice-versa if ( top_at_1 ) then top_level = 1 sfc_level = nlay + 1 lev_source_up => lev_source_dec lev_source_dn => lev_source_inc else top_level = nlay + 1 sfc_level = 1 lev_source_up => lev_source_inc lev_source_dn => lev_source_dec end if ! ! Integrated fluxes need zeroing ! if ( do_broadband ) then call zero_array ( ncol , nlay + 1 , broadband_up ) call zero_array ( ncol , nlay + 1 , broadband_dn ) end if if ( do_Jacobians ) & call zero_array ( ncol , nlay + 1 , flux_upJac ) do igpt = 1 , ngpt if ( do_broadband ) then gpt_flux_up => loc_flux_up gpt_flux_dn => loc_flux_dn else gpt_flux_up => flux_up (:,:, igpt ) gpt_flux_dn => flux_dn (:,:, igpt ) end if ! ! Transport is for intensity ! convert flux at top of domain to intensity assuming azimuthal isotropy ! gpt_flux_dn (:, top_level ) = incident_flux (:, igpt ) / ( 2._wp * pi * weight ) ! ! Optical path and transmission, used in source function and transport calculations ! if ( do_rescaling ) then ! ! The scaling and scaleTau terms are independent of propagation ! angle D and could be pre-computed if several values of D are used ! We re-compute them here to keep not have to localize memory use ! do ilay = 1 , nlay do icol = 1 , ncol ssal = ssa ( icol , ilay , igpt ) ! w is the layer single scattering albedo ! b is phase function parameter (Eq.13 of the paper) ! for the similarity principle scaling scheme ! b = (1-g)/2 (where g is phase function avergae cosine) wb = ssal * ( 1._wp - g ( icol , ilay , igpt )) * 0.5_wp ! scaleTau=1-w(1-b) is a scaling factor of the optical thickness representing ! the radiative transfer equation in a nonscattering form Eq(14) of the paper scaleTau = ( 1._wp - ssal + wb ) ! Cn = 0.5*wb/(1-w(1-b)) is parameter of Eq.21-22 of the Tang paper ! Tang paper, p.2222 advises to replace 0.5 with 0.4 based on simulations Cn ( icol , ilay ) = 0.4_wp * wb / scaleTau ! Eqs.15, 18ab and 19 of the paper, ! rescaling of the optical depth multiplied by path length tau_loc ( icol , ilay ) = tau ( icol , ilay , igpt ) * D ( icol , igpt ) * scaleTau end do trans (:, ilay ) = exp ( - tau_loc (:, ilay )) An (:, ilay ) = ( 1._wp - trans (:, ilay ) ** 2 ) end do else do ilay = 1 , nlay tau_loc (:, ilay ) = tau (:, ilay , igpt ) * D (:, igpt ) trans (:, ilay ) = exp ( - tau_loc (:, ilay )) end do end if ! ! Source function for diffuse radiation ! call lw_source_noscat ( ncol , nlay , & lay_source (:,:, igpt ), lev_source_up (:,:, igpt ), lev_source_dn (:,:, igpt ), & tau_loc , trans , source_dn , source_up ) ! ! Transport down ! call lw_transport_noscat_dn ( ncol , nlay , top_at_1 , trans , source_dn , gpt_flux_dn ) ! ! Surface albedo, surface source function, reflection and emission ! sfc_albedo (:) = 1._wp - sfc_emis (:, igpt ) gpt_flux_up (:, sfc_level ) = gpt_flux_dn (:, sfc_level ) * sfc_albedo (:) + & sfc_emis (:, igpt ) * sfc_src (:, igpt ) if ( do_Jacobians ) & gpt_flux_Jac (:, sfc_level ) = sfc_emis (:, igpt ) * sfc_srcJac (:, igpt ) ! ! Transport up, or up and down again if using rescaling ! if ( do_rescaling ) then call lw_transport_1rescl ( ncol , nlay , top_at_1 , trans , & source_dn , source_up , & gpt_flux_up , gpt_flux_dn , An , Cn , & do_Jacobians , gpt_flux_Jac ) ! Standing in for Jacobian, i.e. rad_up_Jac(:,:,igpt), rad_dn_Jac(:,:,igpt)) else call lw_transport_noscat_up ( ncol , nlay , top_at_1 , trans , source_up , gpt_flux_up , & do_Jacobians , gpt_flux_Jac ) end if if ( do_broadband ) then broadband_up (:,:) = broadband_up (:,:) + gpt_flux_up (:,:) broadband_dn (:,:) = broadband_dn (:,:) + gpt_flux_dn (:,:) else ! ! Convert intensity to flux assuming azimuthal isotropy and quadrature weight ! gpt_flux_dn (:,:) = 2._wp * pi * weight * gpt_flux_dn (:,:) gpt_flux_up (:,:) = 2._wp * pi * weight * gpt_flux_up (:,:) end if ! ! Only broadband-integrated Jacobians are provided ! if ( do_Jacobians ) & flux_upJac (:,:) = flux_upJac (:,:) + gpt_flux_Jac (:,:) end do ! g point loop if ( do_broadband ) then broadband_up (:,:) = 2._wp * pi * weight * broadband_up (:,:) broadband_dn (:,:) = 2._wp * pi * weight * broadband_dn (:,:) end if if ( do_Jacobians ) & flux_upJac (:,:) = 2._wp * pi * weight * flux_upJac (:,:) end subroutine lw_solver_noscat_oneangle ! ------------------------------------------------------------------------------------------------- ! !> LW transport, no scattering, multi-angle quadrature !> Users provide a set of weights and quadrature angles !> Routine sums over single-angle solutions for each sets of angles/weights ! ! --------------------------------------------------------------- subroutine lw_solver_noscat ( ncol , nlay , ngpt , top_at_1 , & nmus , Ds , weights , & tau , & lay_source , lev_source_inc , lev_source_dec , & sfc_emis , sfc_src , & inc_flux , & flux_up , flux_dn , & do_broadband , broadband_up , broadband_dn , & do_Jacobians , sfc_srcJac , flux_upJac , & do_rescaling , ssa , g ) bind ( C , name = \"rte_lw_solver_noscat\" ) integer , intent ( in ) :: ncol , nlay , ngpt !! Number of columns, layers, g-points logical ( wl ), intent ( in ) :: top_at_1 !! ilay = 1 is the top of the atmosphere? integer , intent ( in ) :: nmus !! number of quadrature angles real ( wp ), dimension ( ncol , ngpt , & nmus ), intent ( in ) :: Ds !! quadrature secants real ( wp ), dimension ( nmus ), intent ( in ) :: weights !! quadrature weights real ( wp ), dimension ( ncol , nlay , ngpt ), intent ( in ) :: tau !! Absorption optical thickness [] real ( wp ), dimension ( ncol , nlay , ngpt ), intent ( in ) :: lay_source !! Planck source at layer average temperature [W/m2] real ( wp ), dimension ( ncol , nlay , ngpt ), intent ( in ) :: lev_source_inc !! Planck source at layer edge for radiation in increasing ilay direction [W/m2] real ( wp ), dimension ( ncol , nlay , ngpt ), intent ( in ) :: lev_source_dec !! Planck source at layer edge for radiation in decreasing ilay direction [W/m2] real ( wp ), dimension ( ncol , ngpt ), intent ( in ) :: sfc_emis !! Surface emissivity [] real ( wp ), dimension ( ncol , ngpt ), intent ( in ) :: sfc_src !! Surface source function [W/m2] real ( wp ), dimension ( ncol , ngpt ), intent ( in ) :: inc_flux !! Incident diffuse flux, probably 0 [W/m2] real ( wp ), dimension ( ncol , nlay + 1 , ngpt ), target , & intent ( out ) :: flux_up , flux_dn !! Fluxes [W/m2] ! ! Optional variables - arrays aren't referenced if corresponding logical == False ! logical ( wl ), intent ( in ) :: do_broadband real ( wp ), dimension ( ncol , nlay + 1 ), target , & intent ( out ) :: broadband_up , broadband_dn !! Spectrally-integrated fluxes [W/m2] logical ( wl ), intent ( in ) :: do_Jacobians !! compute Jacobian with respect to surface temeprature? real ( wp ), dimension ( ncol , ngpt ), intent ( in ) :: sfc_srcJac !! surface temperature Jacobian of surface source function [W/m2/K] real ( wp ), dimension ( ncol , nlay + 1 ), target , & intent ( out ) :: flux_upJac !! surface temperature Jacobian of Radiances [W/m2-str / K] logical ( wl ), intent ( in ) :: do_rescaling !! Approximate treatment of scattering (10.1175/JAS-D-18-0014.1) real ( wp ), dimension ( ncol , nlay , ngpt ), intent ( in ) :: ssa , g !! single-scattering albedo, asymmetry parameter ! ------------------------------------ ! ! Local variables - used for a single quadrature angle ! real ( wp ), dimension (:,:,:), pointer :: this_flux_up , this_flux_dn real ( wp ), dimension (:,:), pointer :: this_broadband_up , this_broadband_dn , this_flux_upJac integer :: imu ! ------------------------------------ ! ! For the first angle output arrays store total flux ! call lw_solver_noscat_oneangle ( ncol , nlay , ngpt , & top_at_1 , Ds (:,:, 1 ), weights ( 1 ), tau , & lay_source , lev_source_inc , lev_source_dec , sfc_emis , sfc_src , & inc_flux , & flux_up , flux_dn , & do_broadband , broadband_up , broadband_dn , & do_Jacobians , sfc_srcJac , flux_upJac , & do_rescaling , ssa , g ) ! ! For more than one angle use local arrays ! if ( nmus > 1 ) then if ( do_broadband ) then allocate ( this_broadband_up ( ncol , nlay + 1 ), this_broadband_dn ( ncol , nlay + 1 )) ! Spectrally-resolved fluxes won't be filled in so can point to caller-supplied memory this_flux_up => flux_up this_flux_dn => flux_dn else allocate ( this_flux_up ( ncol , nlay + 1 , ngpt ), this_flux_dn ( ncol , nlay + 1 , ngpt )) ! Spectrally-integrated fluxes won't be filled in so can point to caller-supplied memory this_broadband_up => broadband_up this_broadband_dn => broadband_dn end if if ( do_Jacobians ) then allocate ( this_flux_upJac ( ncol , nlay + 1 )) else this_flux_upJac => flux_upJac end if end if do imu = 2 , nmus call lw_solver_noscat_oneangle ( ncol , nlay , ngpt , & top_at_1 , Ds (:,:, imu ), weights ( imu ), tau , & lay_source , lev_source_inc , lev_source_dec , sfc_emis , sfc_src , & inc_flux , & this_flux_up , this_flux_dn , & do_broadband , this_broadband_up , this_broadband_dn , & do_Jacobians , sfc_srcJac , this_flux_upJac , & do_rescaling , ssa , g ) if ( do_broadband ) then broadband_up (:,:) = broadband_up (:,:) + this_broadband_up (:,:) broadband_dn (:,:) = broadband_dn (:,:) + this_broadband_dn (:,:) else flux_up (:,:,:) = flux_up (:,:,:) + this_flux_up (:,:,:) flux_dn (:,:,:) = flux_dn (:,:,:) + this_flux_dn (:,:,:) end if if ( do_Jacobians ) & flux_upJac (:,:) = flux_upJac (:,: ) + this_flux_upJac (:,: ) end do if ( nmus > 1 ) then if ( do_broadband ) deallocate ( this_broadband_up , this_broadband_dn ) if (. not . do_broadband ) deallocate ( this_flux_up , this_flux_dn ) if ( do_Jacobians ) deallocate ( this_flux_upJac ) end if end subroutine lw_solver_noscat ! ------------------------------------------------------------------------------------------------- ! !> Longwave two-stream calculation: !> - combine RRTMGP-specific sources at levels !> - compute layer reflectance, transmittance !> - compute total source function at levels using linear-in-tau !> - transport ! ! ------------------------------------------------------------------------------------------------- subroutine lw_solver_2stream ( ncol , nlay , ngpt , top_at_1 , & tau , ssa , g , & lay_source , lev_source_inc , lev_source_dec , sfc_emis , sfc_src , & inc_flux , & flux_up , flux_dn ) bind ( C , name = \"rte_lw_solver_2stream\" ) integer , intent ( in ) :: ncol , nlay , ngpt !! Number of columns, layers, g-points logical ( wl ), intent ( in ) :: top_at_1 !! ilay = 1 is the top of the atmosphere? real ( wp ), dimension ( ncol , nlay , ngpt ), intent ( in ) :: tau , ssa , g !! Optical thickness, single-scattering albedo, asymmetry parameter [] real ( wp ), dimension ( ncol , nlay , ngpt ), intent ( in ) :: lay_source !! Planck source at layer average temperature [W/m2] real ( wp ), dimension ( ncol , nlay , ngpt ), intent ( in ) :: lev_source_inc !! Planck source at layer edge for radiation in increasing ilay direction [W/m2] real ( wp ), dimension ( ncol , nlay , ngpt ), intent ( in ) :: lev_source_dec !! Planck source at layer edge for radiation in decreasing ilay direction [W/m2] real ( wp ), dimension ( ncol , ngpt ), intent ( in ) :: sfc_emis !! Surface emissivity [] real ( wp ), dimension ( ncol , ngpt ), intent ( in ) :: sfc_src !! Surface source function [W/m2] real ( wp ), dimension ( ncol , ngpt ), intent ( in ) :: inc_flux !! Incident diffuse flux, probably 0 [W/m2] real ( wp ), dimension ( ncol , nlay + 1 , ngpt ), intent ( out ) :: flux_up , flux_dn !! Fluxes [W/m2] ! ---------------------------------------------------------------------- integer :: igpt , top_level real ( wp ), dimension ( ncol , nlay ) :: Rdif , Tdif , gamma1 , gamma2 real ( wp ), dimension ( ncol ) :: sfc_albedo real ( wp ), dimension ( ncol , nlay + 1 ) :: lev_source real ( wp ), dimension ( ncol , nlay ) :: source_dn , source_up real ( wp ), dimension ( ncol ) :: source_sfc ! ------------------------------------ top_level = nlay + 1 if ( top_at_1 ) top_level = 1 do igpt = 1 , ngpt ! ! RRTMGP provides source functions at each level using the spectral mapping ! of each adjacent layer. Combine these for two-stream calculations ! call lw_combine_sources ( ncol , nlay , top_at_1 , & lev_source_inc (:,:, igpt ), lev_source_dec (:,:, igpt ), & lev_source ) ! ! Cell properties: reflection, transmission for diffuse radiation ! Coupling coefficients needed for source function ! call lw_two_stream ( ncol , nlay , & tau (:,:, igpt ), ssa (:,:, igpt ), g (:,:, igpt ), & gamma1 , gamma2 , Rdif , Tdif ) ! ! Source function for diffuse radiation ! call lw_source_2str ( ncol , nlay , top_at_1 , & sfc_emis (:, igpt ), sfc_src (:, igpt ), & lay_source (:,:, igpt ), lev_source , & gamma1 , gamma2 , Rdif , Tdif , tau (:,:, igpt ), & source_dn , source_up , source_sfc ) ! ! Transport ! sfc_albedo ( 1 : ncol ) = 1._wp - sfc_emis (:, igpt ) ! ! Boundary condition ! flux_dn (:, top_level , igpt ) = inc_flux (:, igpt ) call adding ( ncol , nlay , top_at_1 , & sfc_albedo , & Rdif , Tdif , & source_dn , source_up , source_sfc , & flux_up (:,:, igpt ), flux_dn (:,:, igpt )) end do end subroutine lw_solver_2stream ! ------------------------------------------------------------------------------------------------- ! ! Top-level shortwave kernels ! ! ------------------------------------------------------------------------------------------------- ! ! !> Extinction-only shortwave solver i.e. solar direct beam ! ! ------------------------------------------------------------------------------------------------- pure subroutine sw_solver_noscat ( ncol , nlay , ngpt , top_at_1 , & tau , mu0 , inc_flux_dir , flux_dir ) bind ( C , name = \"rte_sw_solver_noscat\" ) integer , intent ( in ) :: ncol , nlay , ngpt ! Number of columns, layers, g-points !! Number of columns, layers, g-points logical ( wl ), intent ( in ) :: top_at_1 !! ilay = 1 is the top of the atmosphere? real ( wp ), dimension ( ncol , nlay , ngpt ), intent ( in ) :: tau !! Absorption optical thickness [] real ( wp ), dimension ( ncol , nlay ), intent ( in ) :: mu0 !! cosine of solar zenith angle real ( wp ), dimension ( ncol , ngpt ), intent ( in ) :: inc_flux_dir !! Direct beam incident flux [W/m2] real ( wp ), dimension ( ncol , nlay + 1 , ngpt ), intent ( out ) :: flux_dir !! Direct-beam flux, spectral [W/m2] integer :: ilev , igpt ! ------------------------------------ ! Indexing into arrays for upward and downward propagation depends on the vertical ! orientation of the arrays (whether the domain top is at the first or last index) ! We write the loops out explicitly so compilers will have no trouble optimizing them. ! Downward propagation if ( top_at_1 ) then ! For the flux at this level, what was the previous level, and which layer has the ! radiation just passed through? ! layer index = level index - 1 ! previous level is up (-1) do igpt = 1 , ngpt flux_dir (:, 1 , igpt ) = inc_flux_dir (:, igpt ) * mu0 (:, 1 ) do ilev = 2 , nlay + 1 flux_dir (:, ilev , igpt ) = flux_dir (:, ilev - 1 , igpt ) * exp ( - tau (:, ilev - 1 , igpt ) / mu0 (:, ilev - 1 )) end do end do else ! layer index = level index ! previous level is up (+1) do igpt = 1 , ngpt flux_dir (:, nlay + 1 , igpt ) = inc_flux_dir (:, igpt ) * mu0 (:, nlay ) do ilev = nlay , 1 , - 1 flux_dir (:, ilev , igpt ) = flux_dir (:, ilev + 1 , igpt ) * exp ( - tau (:, ilev , igpt ) / mu0 (:, ilev )) end do end do end if end subroutine sw_solver_noscat ! ------------------------------------------------------------------------------------------------- ! !> Shortwave two-stream calculation: !> compute layer reflectance, transmittance !> compute solar source function for diffuse radiation !> transport ! ! ------------------------------------------------------------------------------------------------- subroutine sw_solver_2stream ( ncol , nlay , ngpt , top_at_1 , & tau , ssa , g , mu0 , & sfc_alb_dir , sfc_alb_dif , & inc_flux_dir , & flux_up , flux_dn , flux_dir , & has_dif_bc , inc_flux_dif , & do_broadband , broadband_up , & broadband_dn , broadband_dir ) bind ( C , name = \"rte_sw_solver_2stream\" ) integer , intent ( in ) :: ncol , nlay , ngpt !! Number of columns, layers, g-points logical ( wl ), intent ( in ) :: top_at_1 !! ilay = 1 is the top of the atmosphere? real ( wp ), dimension ( ncol , nlay , ngpt ), intent ( in ) :: tau , ssa , g !! Optical thickness, single-scattering albedo, asymmetry parameter [] real ( wp ), dimension ( ncol , nlay ), intent ( in ) :: mu0 !! cosine of solar zenith angle real ( wp ), dimension ( ncol , ngpt ), intent ( in ) :: sfc_alb_dir , sfc_alb_dif !! Spectral surface albedo for direct and diffuse radiation real ( wp ), dimension ( ncol , ngpt ), intent ( in ) :: inc_flux_dir !! Direct beam incident flux real ( wp ), dimension ( ncol , nlay + 1 , ngpt ), target , & intent ( out ) :: flux_up , flux_dn , flux_dir !! Fluxes [W/m2] logical ( wl ), intent ( in ) :: has_dif_bc !! Is a boundary condition for diffuse flux supplied? real ( wp ), dimension ( ncol , ngpt ), intent ( in ) :: inc_flux_dif !! Boundary condition for diffuse flux [W/m2] logical ( wl ), intent ( in ) :: do_broadband !! Provide broadband-integrated, not spectrally-resolved, fluxes? real ( wp ), dimension ( ncol , nlay + 1 ), intent ( out ) :: broadband_up , broadband_dn , broadband_dir !! Broadband integrated fluxes ! ------------------------------------------- integer :: igpt , top_level , top_layer real ( wp ), dimension ( ncol , nlay ) :: Rdif , Tdif real ( wp ), dimension ( ncol , nlay ) :: source_up , source_dn real ( wp ), dimension ( ncol ) :: source_srf ! loc_fluxes hold a single g-point flux if fluxes are being integrated instead of returned ! with spectral detail real ( wp ), dimension ( ncol , nlay + 1 ), & target :: loc_flux_up , loc_flux_dn , loc_flux_dir ! gpt_fluxes point to calculations for the current g-point real ( wp ), dimension (:,:), pointer :: gpt_flux_up , gpt_flux_dn , gpt_flux_dir ! ------------------------------------ if ( top_at_1 ) then top_level = 1 top_layer = 1 else top_level = nlay + 1 top_layer = nlay end if ! ! Integrated fluxes need zeroing ! if ( do_broadband ) then call zero_array ( ncol , nlay + 1 , broadband_up ) call zero_array ( ncol , nlay + 1 , broadband_dn ) call zero_array ( ncol , nlay + 1 , broadband_dir ) end if do igpt = 1 , ngpt if ( do_broadband ) then gpt_flux_up => loc_flux_up gpt_flux_dn => loc_flux_dn gpt_flux_dir => loc_flux_dir else gpt_flux_up => flux_up (:,:, igpt ) gpt_flux_dn => flux_dn (:,:, igpt ) gpt_flux_dir => flux_dir (:,:, igpt ) end if ! ! Boundary conditions direct beam... ! gpt_flux_dir (:, top_level ) = inc_flux_dir (:, igpt ) * mu0 (:, top_layer ) ! ! ... and diffuse field, using 0 if no BC is provided ! if ( has_dif_bc ) then gpt_flux_dn (:, top_level ) = inc_flux_dif (:, igpt ) else gpt_flux_dn (:, top_level ) = 0._wp end if ! ! Cell properties: transmittance and reflectance for diffuse radiation ! Direct-beam and source for diffuse radiation ! call sw_dif_and_source ( ncol , nlay , top_at_1 , mu0 , sfc_alb_dir (:, igpt ), & tau (:,:, igpt ), ssa (:,:, igpt ), g (:,:, igpt ), & Rdif , Tdif , source_dn , source_up , source_srf , & gpt_flux_dir ) ! ! Transport ! call adding ( ncol , nlay , top_at_1 , & sfc_alb_dif (:, igpt ), Rdif , Tdif , & source_dn , source_up , source_srf , gpt_flux_up , gpt_flux_dn ) ! ! adding() computes only diffuse flux; flux_dn is total ! if ( do_broadband ) then broadband_up (:,:) = broadband_up (:,:) + gpt_flux_up (:,:) broadband_dn (:,:) = broadband_dn (:,:) + gpt_flux_dn (:,:) + gpt_flux_dir (:,:) broadband_dir (:,:) = broadband_dir (:,:) + gpt_flux_dir (:,:) else gpt_flux_dn (:,:) = gpt_flux_dn (:,:) + gpt_flux_dir (:,:) end if end do end subroutine sw_solver_2stream ! ------------------------------------------------------------------------------------------------- ! ! Lower-level longwave kernels ! ! ------------------------------------------------------------------------------------------------- ! ! Compute LW source function for upward and downward emission at levels using linear-in-tau assumption ! See Clough et al., 1992, doi: 10.1029/92JD01419, Eq 13 ! ! --------------------------------------------------------------- subroutine lw_source_noscat ( ncol , nlay , lay_source , lev_source_up , lev_source_dn , tau , trans , & source_dn , source_up ) integer , intent ( in ) :: ncol , nlay real ( wp ), dimension ( ncol , nlay ), intent ( in ) :: lay_source , & ! Planck source at layer center lev_source_up , & ! Planck source at levels (layer edges), lev_source_dn , & ! increasing/decreasing layer index tau , & ! Optical path (tau/mu) trans ! Transmissivity (exp(-tau)) real ( wp ), dimension ( ncol , nlay ), intent ( out ) :: source_dn , source_up ! Source function at layer edges ! Down at the bottom of the layer, up at the top ! -------------------------------- integer :: icol , ilay real ( wp ) :: fact real ( wp ), parameter :: tau_thresh = sqrt ( sqrt ( epsilon ( tau ))) ! --------------------------------------------------------------- do ilay = 1 , nlay do icol = 1 , ncol ! ! Weighting factor. Use 2nd order series expansion when rounding error (~tau^2) ! is of order epsilon (smallest difference from 1. in working precision) ! Thanks to Peter Blossey ! Updated to 3rd order series and lower threshold based on suggestion from Dmitry Alexeev (Nvidia) ! if ( tau ( icol , ilay ) > tau_thresh ) then fact = ( 1._wp - trans ( icol , ilay )) / tau ( icol , ilay ) - trans ( icol , ilay ) else fact = tau ( icol , ilay ) * ( 0.5_wp + tau ( icol , ilay ) * ( - 1._wp / 3._wp + tau ( icol , ilay ) * 1._wp / 8._wp ) ) end if ! ! Equation below is developed in Clough et al., 1992, doi:10.1029/92JD01419, Eq 13 ! source_dn ( icol , ilay ) = ( 1._wp - trans ( icol , ilay )) * lev_source_dn ( icol , ilay ) + & 2._wp * fact * ( lay_source ( icol , ilay ) - lev_source_dn ( icol , ilay )) source_up ( icol , ilay ) = ( 1._wp - trans ( icol , ilay )) * lev_source_up ( icol , ilay ) + & 2._wp * fact * ( lay_source ( icol , ilay ) - lev_source_up ( icol , ilay )) end do end do end subroutine lw_source_noscat ! ------------------------------------------------------------------------------------------------- ! ! Longwave no-scattering transport - separate routines for up and down ! ! ------------------------------------------------------------------------------------------------- subroutine lw_transport_noscat_dn ( ncol , nlay , top_at_1 , & trans , source_dn , radn_dn ) integer , intent ( in ) :: ncol , nlay ! Number of columns, layers, g-points logical ( wl ), intent ( in ) :: top_at_1 ! real ( wp ), dimension ( ncol , nlay ), intent ( in ) :: trans ! transmissivity = exp(-tau) real ( wp ), dimension ( ncol , nlay ), intent ( in ) :: source_dn ! Diffuse radiation emitted by the layer real ( wp ), dimension ( ncol , nlay + 1 ), intent ( inout ) :: radn_dn ! Radiances [W/m2-str] Top level must contain incident flux boundary condition ! --------------------------------------------------- ! Local variables integer :: ilev ! --------------------------------------------------- if ( top_at_1 ) then ! ! Top of domain is index 1 ! do ilev = 2 , nlay + 1 radn_dn (:, ilev ) = trans (:, ilev - 1 ) * radn_dn (:, ilev - 1 ) + source_dn (:, ilev - 1 ) end do else ! ! Top of domain is index nlay+1 ! do ilev = nlay , 1 , - 1 radn_dn (:, ilev ) = trans (:, ilev ) * radn_dn (:, ilev + 1 ) + source_dn (:, ilev ) end do end if end subroutine lw_transport_noscat_dn ! ------------------------------------------------------------------------------------------------- subroutine lw_transport_noscat_up ( ncol , nlay , top_at_1 , & trans , source_up , radn_up , do_Jacobians , radn_upJac ) integer , intent ( in ) :: ncol , nlay ! Number of columns, layers, g-points logical ( wl ), intent ( in ) :: top_at_1 ! real ( wp ), dimension ( ncol , nlay ), intent ( in ) :: trans ! transmissivity = exp(-tau) real ( wp ), dimension ( ncol , nlay ), intent ( in ) :: source_up ! Diffuse radiation emitted by the layer real ( wp ), dimension ( ncol , nlay + 1 ), intent ( inout ) :: radn_up ! Radiances [W/m2-str] Top level must contain incident flux boundary condition logical ( wl ), intent ( in ) :: do_Jacobians real ( wp ), dimension ( ncol , nlay + 1 ), intent ( inout ) :: radn_upJac ! surface temperature Jacobian of Radiances [W/m2-str / K] ! --------------------------------------------------- ! Local variables integer :: ilev ! --------------------------------------------------- if ( top_at_1 ) then ! ! Top of domain is index 1 ! ! Upward propagation do ilev = nlay , 1 , - 1 radn_up (:, ilev ) = trans (:, ilev ) * radn_up (:, ilev + 1 ) + source_up (:, ilev ) if ( do_Jacobians ) & radn_upJac (:, ilev ) = trans (:, ilev ) * radn_upJac (:, ilev + 1 ) end do else ! ! Top of domain is index nlay+1 ! ! Upward propagation do ilev = 2 , nlay + 1 radn_up (:, ilev ) = trans (:, ilev - 1 ) * radn_up (:, ilev - 1 ) + source_up (:, ilev - 1 ) if ( do_Jacobians ) & radn_upJac (:, ilev ) = trans (:, ilev - 1 ) * radn_upJac (:, ilev - 1 ) end do end if end subroutine lw_transport_noscat_up ! ------------------------------------------------------------------------------------------------- ! Upward and (second) downward transport for re-scaled longwave solution ! adds adjustment factor based on cloud properties ! ! implementation notice: ! the adjustmentFactor computation can be skipped where Cn <= epsilon ! ------------------------------------------------------------------------------------------------- subroutine lw_transport_1rescl ( ncol , nlay , top_at_1 , & trans , source_dn , source_up , & radn_up , radn_dn , An , Cn ,& do_Jacobians , radn_up_Jac ) integer , intent ( in ) :: ncol , nlay ! Number of columns, layers, g-points logical ( wl ), intent ( in ) :: top_at_1 ! real ( wp ), dimension ( ncol , nlay ), intent ( in ) :: trans ! transmissivity = exp(-tau) real ( wp ), dimension ( ncol , nlay ), intent ( in ) :: source_dn , & source_up ! Diffuse radiation emitted by the layer real ( wp ), dimension ( ncol , nlay + 1 ), intent ( inout ) :: radn_up ! Radiances [W/m2-str] real ( wp ), dimension ( ncol , nlay + 1 ), intent ( inout ) :: radn_dn !Top level must contain incident flux boundary condition real ( wp ), dimension ( ncol , nlay ), intent ( in ) :: An , Cn logical ( wl ), intent ( in ) :: do_Jacobians real ( wp ), dimension ( ncol , nlay + 1 ), intent ( inout ) :: radn_up_Jac ! Surface temperature Jacobians [W/m2-str/K] ! ! We could in principle compute a downwelling Jacobian too, but it's small ! (only a small proportion of LW is scattered) and it complicates code and the API, ! so we will not ! ! Local variables integer :: ilev , icol ! --------------------------------------------------- real ( wp ) :: adjustmentFactor if ( top_at_1 ) then ! ! Top of domain is index 1 ! ! Upward propagation ! adjustment factor is obtained as a solution of 18b of the Tang paper ! eqvivalent to Eq.20 of the Tang paper but for linear-in-tau source do ilev = nlay , 1 , - 1 do icol = 1 , ncol adjustmentFactor = Cn ( icol , ilev ) * ( An ( icol , ilev ) * radn_dn ( icol , ilev ) - & trans ( icol , ilev ) * source_dn ( icol , ilev ) - source_up ( icol , ilev ) ) radn_up ( icol , ilev ) = trans ( icol , ilev ) * radn_up ( icol , ilev + 1 ) + source_up ( icol , ilev ) + & adjustmentFactor end do if ( do_Jacobians ) & radn_up_Jac (:, ilev ) = trans (:, ilev ) * radn_up_Jac (:, ilev + 1 ) end do ! Downward propagation ! radn_dn_Jac(:,1) = 0._wp ! adjustment factor is obtained as a solution of 19 of the Tang paper ! eqvivalent to Eq.21 of the Tang paper but for linear-in-tau source do ilev = 1 , nlay ! radn_dn_Jac(:,ilev+1) = trans(:,ilev)*radn_dn_Jac(:,ilev) do icol = 1 , ncol adjustmentFactor = Cn ( icol , ilev ) * ( An ( icol , ilev ) * radn_up ( icol , ilev ) - & trans ( icol , ilev ) * source_up ( icol , ilev ) - source_dn ( icol , ilev ) ) radn_dn ( icol , ilev + 1 ) = trans ( icol , ilev ) * radn_dn ( icol , ilev ) + source_dn ( icol , ilev ) + & adjustmentFactor ! adjustmentFactor = Cn(icol,ilev)*An(icol,ilev)*radn_up_Jac(icol,ilev) ! radn_dn_Jac(icol,ilev+1) = radn_dn_Jac(icol,ilev+1) + adjustmentFactor enddo end do else ! ! Top of domain is index nlay+1 ! ! Upward propagation ! adjustment factor is obtained as a solution of 18b of the Tang paper ! eqvivalent to Eq.20 of the Tang paper but for linear-in-tau source do ilev = 1 , nlay radn_up (:, ilev + 1 ) = trans (:, ilev ) * radn_up (:, ilev ) + source_up (:, ilev ) do icol = 1 , ncol adjustmentFactor = Cn ( icol , ilev ) * ( An ( icol , ilev ) * radn_dn ( icol , ilev + 1 ) - & trans ( icol , ilev ) * source_dn ( icol , ilev ) - source_up ( icol , ilev ) ) radn_up ( icol , ilev + 1 ) = trans ( icol , ilev ) * radn_up ( icol , ilev ) + source_up ( icol , ilev ) + & adjustmentFactor enddo if ( do_Jacobians ) & radn_up_Jac (:, ilev + 1 ) = trans (:, ilev ) * radn_up_Jac (:, ilev ) end do ! Downward propagation ! adjustment factor is obtained as a solution of 19 of the Tang paper ! eqvivalent to Eq.21 of the Tang paper but for linear-in-tau source ! radn_dn_Jac(:,nlay+1) = 0._wp do ilev = nlay , 1 , - 1 ! radn_dn_Jac(:,ilev) = trans(:,ilev)*radn_dn_Jac(:,ilev+1) do icol = 1 , ncol adjustmentFactor = Cn ( icol , ilev ) * ( An ( icol , ilev ) * radn_up ( icol , ilev ) - & trans ( icol , ilev ) * source_up ( icol , ilev ) - source_dn ( icol , ilev ) ) radn_dn ( icol , ilev ) = trans ( icol , ilev ) * radn_dn ( icol , ilev + 1 ) + source_dn ( icol , ilev ) + & adjustmentFactor ! adjustmentFactor = Cn(icol,ilev)*An(icol,ilev)*radn_up_Jac(icol,ilev) ! radn_dn_Jac(icol,ilev) = radn_dn_Jac(icol,ilev) + adjustmentFactor enddo end do end if end subroutine lw_transport_1rescl ! ------------------------------------------------------------------------------------------------- ! ! Longwave two-stream solutions to diffuse reflectance and transmittance for a layer ! with optical depth tau, single scattering albedo w0, and asymmetery parameter g. ! ! Equations are developed in Meador and Weaver, 1980, ! doi:10.1175/1520-0469(1980)037<0630:TSATRT>2.0.CO;2 ! ! ------------------------------------------------------------------------------------------------- pure subroutine lw_two_stream ( ncol , nlay , tau , w0 , g , & gamma1 , gamma2 , Rdif , Tdif ) integer , intent ( in ) :: ncol , nlay real ( wp ), dimension ( ncol , nlay ), intent ( in ) :: tau , w0 , g real ( wp ), dimension ( ncol , nlay ), intent ( out ) :: gamma1 , gamma2 , Rdif , Tdif ! ----------------------- integer :: i , j ! Variables used in Meador and Weaver real ( wp ) :: k ( ncol ) ! Ancillary variables real ( wp ) :: RT_term ( ncol ) real ( wp ) :: exp_minusktau ( ncol ), exp_minus2ktau ( ncol ) real ( wp ), parameter :: LW_diff_sec = 1.66 ! 1./cos(diffusivity angle) ! --------------------------------- do j = 1 , nlay do i = 1 , ncol ! ! Coefficients differ from SW implementation because the phase function is more isotropic ! Here we follow Fu et al. 1997, doi:10.1175/1520-0469(1997)054<2799:MSPITI>2.0.CO;2 ! and use a diffusivity sec of 1.66 ! gamma1 ( i , j ) = LW_diff_sec * ( 1._wp - 0.5_wp * w0 ( i , j ) * ( 1._wp + g ( i , j ))) ! Fu et al. Eq 2.9 gamma2 ( i , j ) = LW_diff_sec * 0.5_wp * w0 ( i , j ) * ( 1._wp - g ( i , j )) ! Fu et al. Eq 2.10 ! Eq 18; k = SQRT(gamma1**2 - gamma2**2), limited below to avoid div by 0. ! k = 0 for isotropic, conservative scattering; this lower limit on k ! gives relative error with respect to conservative solution ! of < 0.1% in Rdif down to tau = 10^-9 k ( i ) = sqrt ( max (( gamma1 ( i , j ) - gamma2 ( i , j )) * ( gamma1 ( i , j ) + gamma2 ( i , j )), 1.e-12_wp )) end do ! Written to encourage vectorization of exponential exp_minusktau ( 1 : ncol ) = exp ( - tau ( 1 : ncol , j ) * k ( 1 : ncol )) ! ! Diffuse reflection and transmission ! do i = 1 , ncol exp_minus2ktau ( i ) = exp_minusktau ( i ) * exp_minusktau ( i ) ! Refactored to avoid rounding errors when k, gamma1 are of very different magnitudes RT_term ( i ) = 1._wp / ( k ( i ) * ( 1._wp + exp_minus2ktau ( i )) + & gamma1 ( i , j ) * ( 1._wp - exp_minus2ktau ( i )) ) ! Equation 25 Rdif ( i , j ) = RT_term ( i ) * gamma2 ( i , j ) * ( 1._wp - exp_minus2ktau ( i )) ! Equation 26 Tdif ( i , j ) = RT_term ( i ) * 2._wp * k ( i ) * exp_minusktau ( i ) end do end do end subroutine lw_two_stream ! ------------------------------------------------------------------------------------------------- ! ! Source function combination ! RRTMGP provides two source functions at each level ! using the spectral mapping from each of the adjascent layers. ! Need to combine these for use in two-stream calculation. ! ! ------------------------------------------------------------------------------------------------- subroutine lw_combine_sources ( ncol , nlay , top_at_1 , & lev_src_inc , lev_src_dec , lev_source ) integer , intent ( in ) :: ncol , nlay logical ( wl ), intent ( in ) :: top_at_1 real ( wp ), dimension ( ncol , nlay ), intent ( in ) :: lev_src_inc , lev_src_dec real ( wp ), dimension ( ncol , nlay + 1 ), intent ( out ) :: lev_source integer :: icol , ilay ! --------------------------------------------------------------- ilay = 1 do icol = 1 , ncol lev_source ( icol , ilay ) = lev_src_dec ( icol , ilay ) end do do ilay = 2 , nlay do icol = 1 , ncol lev_source ( icol , ilay ) = sqrt ( lev_src_dec ( icol , ilay ) * & lev_src_inc ( icol , ilay - 1 )) end do end do ilay = nlay + 1 do icol = 1 , ncol lev_source ( icol , ilay ) = lev_src_inc ( icol , ilay - 1 ) end do end subroutine lw_combine_sources ! --------------------------------------------------------------- ! ! Compute LW source function for upward and downward emission at levels using linear-in-tau assumption ! This version straight from ECRAD ! Source is provided as W/m2-str; factor of pi converts to flux units ! ! --------------------------------------------------------------- subroutine lw_source_2str ( ncol , nlay , top_at_1 , & sfc_emis , sfc_src , & lay_source , lev_source , & gamma1 , gamma2 , rdif , tdif , tau , source_dn , source_up , source_sfc ) & bind ( C , name = \"rte_lw_source_2str\" ) integer , intent ( in ) :: ncol , nlay logical ( wl ), intent ( in ) :: top_at_1 real ( wp ), dimension ( ncol ), intent ( in ) :: sfc_emis , sfc_src real ( wp ), dimension ( ncol , nlay ), intent ( in ) :: lay_source , & ! Planck source at layer center tau , & ! Optical depth (tau) gamma1 , gamma2 ,& ! Coupling coefficients rdif , tdif ! Layer reflectance and transmittance real ( wp ), dimension ( ncol , nlay + 1 ), target , & intent ( in ) :: lev_source ! Planck source at layer edges real ( wp ), dimension ( ncol , nlay ), intent ( out ) :: source_dn , source_up real ( wp ), dimension ( ncol ), intent ( out ) :: source_sfc ! Source function for upward radation at surface integer :: icol , ilay real ( wp ) :: Z , Zup_top , Zup_bottom , Zdn_top , Zdn_bottom real ( wp ), dimension (:), pointer :: lev_source_bot , lev_source_top ! --------------------------------------------------------------- do ilay = 1 , nlay if ( top_at_1 ) then lev_source_top => lev_source (:, ilay ) lev_source_bot => lev_source (:, ilay + 1 ) else lev_source_top => lev_source (:, ilay + 1 ) lev_source_bot => lev_source (:, ilay ) end if do icol = 1 , ncol if ( tau ( icol , ilay ) > 1.0e-8_wp ) then ! ! Toon et al. (JGR 1989) Eqs 26-27 ! Z = ( lev_source_bot ( icol ) - lev_source_top ( icol )) / ( tau ( icol , ilay ) * ( gamma1 ( icol , ilay ) + gamma2 ( icol , ilay ))) Zup_top = Z + lev_source_top ( icol ) Zup_bottom = Z + lev_source_bot ( icol ) Zdn_top = - Z + lev_source_top ( icol ) Zdn_bottom = - Z + lev_source_bot ( icol ) source_up ( icol , ilay ) = pi * ( Zup_top - rdif ( icol , ilay ) * Zdn_top - tdif ( icol , ilay ) * Zup_bottom ) source_dn ( icol , ilay ) = pi * ( Zdn_bottom - rdif ( icol , ilay ) * Zup_bottom - tdif ( icol , ilay ) * Zdn_top ) else source_up ( icol , ilay ) = 0._wp source_dn ( icol , ilay ) = 0._wp end if end do end do do icol = 1 , ncol source_sfc ( icol ) = pi * sfc_emis ( icol ) * sfc_src ( icol ) end do end subroutine lw_source_2str ! ------------------------------------------------------------------------------------------------- ! ! Lower-level shortwave kernels ! ! ------------------------------------------------------------------------------------------------- ! ! Two-stream solutions to diffuse reflectance and transmittance for a layer ! with optical depth tau, single scattering albedo w0, and asymmetery parameter g. ! Direct reflectance and transmittance used to compute direct beam source for diffuse radiation ! in layers and at surface; report direct beam as a byproduct ! Computing the direct-beam source for diffuse radiation at the same time as R and T for ! direct radiation reduces memory traffic and use. ! ! Equations are developed in Meador and Weaver, 1980, ! doi:10.1175/1520-0469(1980)037<0630:TSATRT>2.0.CO;2 ! ! ------------------------------------------------------------------------------------------------- pure subroutine sw_dif_and_source ( ncol , nlay , top_at_1 , mu0 , sfc_albedo , & tau , w0 , g , & Rdif , Tdif , source_dn , source_up , source_sfc , flux_dn_dir ) bind ( C , name = \"rte_sw_source_dir\" ) integer , intent ( in ) :: ncol , nlay logical ( wl ), intent ( in ) :: top_at_1 real ( wp ), dimension ( ncol ), intent ( in ) :: sfc_albedo ! surface albedo for direct radiation real ( wp ), dimension ( ncol , nlay ), intent ( in ) :: tau , w0 , g , mu0 real ( wp ), dimension ( ncol , nlay ), intent ( out ) :: Rdif , Tdif , source_dn , source_up real ( wp ), dimension ( ncol ), intent ( out ) :: source_sfc ! Source function for upward radation at surface real ( wp ), dimension ( ncol , nlay + 1 ), target , & intent ( inout ) :: flux_dn_dir ! Direct beam flux ! ----------------------- integer :: i , j ! Variables used in Meador and Weaver real ( wp ) :: gamma1 , gamma2 , gamma3 , gamma4 , alpha1 , alpha2 ! Ancillary variables real ( wp ), parameter :: min_k = 1.e4_wp * epsilon ( 1._wp ) ! Suggestion from Chiel van Heerwaarden real ( wp ) :: k , exp_minusktau , k_mu , k_gamma3 , k_gamma4 real ( wp ) :: RT_term , exp_minus2ktau real ( wp ) :: Rdir , Tdir , Tnoscat real ( wp ), pointer , dimension (:) :: dir_flux_inc , dir_flux_trans integer :: lay_index real ( wp ) :: tau_s , w0_s , g_s , mu0_s ! --------------------------------- do j = 1 , nlay if ( top_at_1 ) then lay_index = j dir_flux_inc => flux_dn_dir (:, lay_index ) dir_flux_trans => flux_dn_dir (:, lay_index + 1 ) else lay_index = nlay - j + 1 dir_flux_inc => flux_dn_dir (:, lay_index + 1 ) dir_flux_trans => flux_dn_dir (:, lay_index ) end if do i = 1 , ncol ! ! Scalars ! tau_s = tau ( i , lay_index ) w0_s = w0 ( i , lay_index ) g_s = g ( i , lay_index ) mu0_s = mu0 ( i , lay_index ) ! ! Zdunkowski Practical Improved Flux Method \"PIFM\" ! (Zdunkowski et al., 1980; Contributions to Atmospheric Physics 53, 147-66) ! gamma1 = ( 8._wp - w0_s * ( 5._wp + 3._wp * g_s )) * . 25_wp gamma2 = 3._wp * ( w0_s * ( 1._wp - g_s )) * . 25_wp ! ! Direct reflect and transmission ! ! Eq 18; k = SQRT(gamma1**2 - gamma2**2), limited below to avoid div by 0. ! k = 0 for isotropic, conservative scattering; this lower limit on k ! gives relative error with respect to conservative solution ! of < 0.1% in Rdif down to tau = 10^-9 k = sqrt ( max (( gamma1 - gamma2 ) * ( gamma1 + gamma2 ), min_k )) exp_minusktau = exp ( - tau_s * k ) exp_minus2ktau = exp_minusktau * exp_minusktau ! Refactored to avoid rounding errors when k, gamma1 are of very different magnitudes RT_term = 1._wp / ( k * ( 1._wp + exp_minus2ktau ) + & gamma1 * ( 1._wp - exp_minus2ktau ) ) ! Equation 25 Rdif ( i , lay_index ) = RT_term * gamma2 * ( 1._wp - exp_minus2ktau ) ! Equation 26 Tdif ( i , lay_index ) = RT_term * 2._wp * k * exp_minusktau ! ! On a round earth, where mu0 can increase with depth in the atmosphere, ! levels with mu0 <= 0 have no direct beam and hence no source for diffuse light ! if ( mu0_s > 0._wp ) then k_mu = k * mu0_s ! ! Equation 14, multiplying top and bottom by exp(-k*tau) ! and rearranging to avoid div by 0. ! RT_term = w0_s * RT_term / merge ( 1._wp - k_mu * k_mu , & epsilon ( 1._wp ), & abs ( 1._wp - k_mu * k_mu ) >= epsilon ( 1._wp )) ! ! Zdunkowski Practical Improved Flux Method \"PIFM\" ! (Zdunkowski et al., 1980; Contributions to Atmospheric Physics 53, 147-66) ! gamma3 = ( 2._wp - 3._wp * mu0_s * g_s ) * . 25_wp gamma4 = 1._wp - gamma3 alpha1 = gamma1 * gamma4 + gamma2 * gamma3 ! Eq. 16 alpha2 = gamma1 * gamma3 + gamma2 * gamma4 ! Eq. 17 ! ! Transmittance of direct, unscattered beam. ! k_gamma3 = k * gamma3 k_gamma4 = k * gamma4 Tnoscat = exp ( - tau_s / mu0_s ) Rdir = RT_term * & (( 1._wp - k_mu ) * ( alpha2 + k_gamma3 ) - & ( 1._wp + k_mu ) * ( alpha2 - k_gamma3 ) * exp_minus2ktau - & 2.0_wp * ( k_gamma3 - alpha2 * k_mu ) * exp_minusktau * Tnoscat ) ! ! Equation 15, multiplying top and bottom by exp(-k*tau), ! multiplying through by exp(-tau/mu0) to ! prefer underflow to overflow ! Omitting direct transmittance ! Tdir = - RT_term * & (( 1._wp + k_mu ) * ( alpha1 + k_gamma4 ) * Tnoscat - & ( 1._wp - k_mu ) * ( alpha1 - k_gamma4 ) * exp_minus2ktau * Tnoscat - & 2.0_wp * ( k_gamma4 + alpha1 * k_mu ) * exp_minusktau ) ! Final check that energy is not spuriously created, by recognizing that ! the beam can either be reflected, penetrate unscattered to the base of a layer, ! or penetrate through but be scattered on the way - the rest is absorbed ! Makes the equations safer in single precision. Credit: Robin Hogan, Peter Ukkonen Rdir = max ( 0.0_wp , min ( Rdir , ( 1.0_wp - Tnoscat ) )) Tdir = max ( 0.0_wp , min ( Tdir , ( 1.0_wp - Tnoscat - Rdir ) )) source_up ( i , lay_index ) = Rdir * dir_flux_inc ( i ) source_dn ( i , lay_index ) = Tdir * dir_flux_inc ( i ) dir_flux_trans ( i ) = Tnoscat * dir_flux_inc ( i ) else source_up ( i , lay_index ) = 0._wp source_dn ( i , lay_index ) = 0._wp dir_flux_trans ( i ) = 0._wp end if end do end do source_sfc (:) = dir_flux_trans (:) * sfc_albedo (:) end subroutine sw_dif_and_source ! --------------------------------------------------------------- ! ! Transport of diffuse radiation through a vertically layered atmosphere. ! Equations are after Shonk and Hogan 2008, doi:10.1175/2007JCLI1940.1 (SH08) ! This routine is shared by longwave and shortwave ! ! ------------------------------------------------------------------------------------------------- subroutine adding ( ncol , nlay , top_at_1 , & albedo_sfc , & rdif , tdif , & src_dn , src_up , src_sfc , & flux_up , flux_dn ) integer , intent ( in ) :: ncol , nlay logical ( wl ), intent ( in ) :: top_at_1 real ( wp ), dimension ( ncol ), intent ( in ) :: albedo_sfc real ( wp ), dimension ( ncol , nlay ), intent ( in ) :: rdif , tdif real ( wp ), dimension ( ncol , nlay ), intent ( in ) :: src_dn , src_up real ( wp ), dimension ( ncol ), intent ( in ) :: src_sfc real ( wp ), dimension ( ncol , nlay + 1 ), intent ( out ) :: flux_up ! intent(inout) because top layer includes incident flux real ( wp ), dimension ( ncol , nlay + 1 ), intent ( inout ) :: flux_dn ! ------------------ integer :: ilev real ( wp ), dimension ( ncol , nlay + 1 ) :: albedo , & ! reflectivity to diffuse radiation below this level ! alpha in SH08 src ! source of diffuse upwelling radiation from emission or ! scattering of direct beam ! G in SH08 real ( wp ), dimension ( ncol , nlay ) :: denom ! beta in SH08 ! ------------------ ! ! Indexing into arrays for upward and downward propagation depends on the vertical ! orientation of the arrays (whether the domain top is at the first or last index) ! We write the loops out explicitly so compilers will have no trouble optimizing them. ! if ( top_at_1 ) then ilev = nlay + 1 ! Albedo of lowest level is the surface albedo... albedo (:, ilev ) = albedo_sfc (:) ! ... and source of diffuse radiation is surface emission src (:, ilev ) = src_sfc (:) ! ! From bottom to top of atmosphere -- ! compute albedo and source of upward radiation ! do ilev = nlay , 1 , - 1 denom (:, ilev ) = 1._wp / ( 1._wp - rdif (:, ilev ) * albedo (:, ilev + 1 )) ! Eq 10 albedo (:, ilev ) = rdif (:, ilev ) + & tdif (:, ilev ) * tdif (:, ilev ) * albedo (:, ilev + 1 ) * denom (:, ilev ) ! Equation 9 ! ! Equation 11 -- source is emitted upward radiation at top of layer plus ! radiation emitted at bottom of layer, ! transmitted through the layer and reflected from layers below (tdiff*src*albedo) ! src (:, ilev ) = src_up (:, ilev ) + & tdif (:, ilev ) * denom (:, ilev ) * & ( src (:, ilev + 1 ) + albedo (:, ilev + 1 ) * src_dn (:, ilev )) end do ! Eq 12, at the top of the domain upwelling diffuse is due to ... ilev = 1 flux_up (:, ilev ) = flux_dn (:, ilev ) * albedo (:, ilev ) + & ! ... reflection of incident diffuse and src (:, ilev ) ! emission from below ! ! From the top of the atmosphere downward -- compute fluxes ! do ilev = 2 , nlay + 1 flux_dn (:, ilev ) = ( tdif (:, ilev - 1 ) * flux_dn (:, ilev - 1 ) + & ! Equation 13 rdif (:, ilev - 1 ) * src (:, ilev ) + & src_dn (:, ilev - 1 )) * denom (:, ilev - 1 ) flux_up (:, ilev ) = flux_dn (:, ilev ) * albedo (:, ilev ) + & ! Equation 12 src (:, ilev ) end do else ilev = 1 ! Albedo of lowest level is the surface albedo... albedo (:, ilev ) = albedo_sfc (:) ! ... and source of diffuse radiation is surface emission src (:, ilev ) = src_sfc (:) ! ! From bottom to top of atmosphere -- ! compute albedo and source of upward radiation ! do ilev = 1 , nlay denom (:, ilev ) = 1._wp / ( 1._wp - rdif (:, ilev ) * albedo (:, ilev )) ! Eq 10 albedo (:, ilev + 1 ) = rdif (:, ilev ) + & tdif (:, ilev ) * tdif (:, ilev ) * albedo (:, ilev ) * denom (:, ilev ) ! Equation 9 ! ! Equation 11 -- source is emitted upward radiation at top of layer plus ! radiation emitted at bottom of layer, ! transmitted through the layer and reflected from layers below (tdiff*src*albedo) ! src (:, ilev + 1 ) = src_up (:, ilev ) + & tdif (:, ilev ) * denom (:, ilev ) * & ( src (:, ilev ) + albedo (:, ilev ) * src_dn (:, ilev )) end do ! Eq 12, at the top of the domain upwelling diffuse is due to ... ilev = nlay + 1 flux_up (:, ilev ) = flux_dn (:, ilev ) * albedo (:, ilev ) + & ! ... reflection of incident diffuse and src (:, ilev ) ! scattering by the direct beam below ! ! From the top of the atmosphere downward -- compute fluxes ! do ilev = nlay , 1 , - 1 flux_dn (:, ilev ) = ( tdif (:, ilev ) * flux_dn (:, ilev + 1 ) + & ! Equation 13 rdif (:, ilev ) * src (:, ilev ) + & src_dn (:, ilev )) * denom (:, ilev ) flux_up (:, ilev ) = flux_dn (:, ilev ) * albedo (:, ilev ) + & ! Equation 12 src (:, ilev ) end do end if end subroutine adding end module mo_rte_solver_kernels","tags":"","loc":"sourcefile/mo_rte_solver_kernels.f90.html"},{"title":"mo_rte_util_array.F90 – RTE kernels","text":"Files dependent on this one sourcefile~~mo_rte_util_array.f90~~AfferentGraph sourcefile~mo_rte_util_array.f90 mo_rte_util_array.F90 sourcefile~mo_rte_solver_kernels.f90 mo_rte_solver_kernels.F90 sourcefile~mo_rte_solver_kernels.f90->sourcefile~mo_rte_util_array.f90 Help × Graph Key Nodes of different colours represent the following: Graph Key Source File Source File This Page's Entity This Page's Entity Solid arrows point from a file to a file which it depends on. A file\n is dependent upon another if the latter must be compiled before the former\n can be. Contents Modules mo_rte_util_array Source Code mo_rte_util_array.F90 Source Code ! This code is part of Radiative Transfer for Energetics (RTE) ! ! Contacts: Robert Pincus and Eli Mlawer ! email: rrtmgp@aer.com ! ! Copyright 2015- Atmospheric and Environmental Research, ! Regents of the University of Colorado, ! Trustees of Columbia University in the City of New York ! All right reserved. ! ! Use and duplication is permitted under the terms of the ! BSD 3-clause license, see http://opensource.org/licenses/BSD-3-Clause ! ------------------------------------------------------------------------------------------------- module mo_rte_util_array use mo_rte_kind , only : wp , wl implicit none !> !> Efficiently set arrays to zero !> interface zero_array module procedure zero_array_1D , zero_array_2D , zero_array_3D , zero_array_4D end interface public :: zero_array contains !------------------------------------------------------------------------------------------------- ! Initializing arrays to 0 !------------------------------------------------------------------------------------------------- subroutine zero_array_1D ( ni , array ) bind ( C , name = \"zero_array_1D\" ) integer , intent ( in ) :: ni real ( wp ), dimension ( ni ), intent ( out ) :: array ! ----------------------- integer :: i ! ----------------------- !$acc parallel loop copyout(array) !$omp target teams distribute parallel do simd map(from:array) do i = 1 , ni array ( i ) = 0.0_wp end do end subroutine zero_array_1D ! ---------------------------------------------------------- subroutine zero_array_2D ( ni , nj , array ) bind ( C , name = \"zero_array_2D\" ) integer , intent ( in ) :: ni , nj real ( wp ), dimension ( ni , nj ), intent ( out ) :: array ! ----------------------- integer :: i , j ! ----------------------- !$acc parallel loop collapse(2) copyout(array) !$omp target teams distribute parallel do simd collapse(2) map(from:array) do j = 1 , nj do i = 1 , ni array ( i , j ) = 0.0_wp end do end do end subroutine zero_array_2D ! ---------------------------------------------------------- subroutine zero_array_3D ( ni , nj , nk , array ) bind ( C , name = \"zero_array_3D\" ) integer , intent ( in ) :: ni , nj , nk real ( wp ), dimension ( ni , nj , nk ), intent ( out ) :: array ! ----------------------- integer :: i , j , k ! ----------------------- !$acc parallel loop collapse(3) copyout(array) !$omp target teams distribute parallel do simd collapse(3) map(from:array) do k = 1 , nk do j = 1 , nj do i = 1 , ni array ( i , j , k ) = 0.0_wp end do end do end do end subroutine zero_array_3D ! ---------------------------------------------------------- subroutine zero_array_4D ( ni , nj , nk , nl , array ) bind ( C , name = \"zero_array_4D\" ) integer , intent ( in ) :: ni , nj , nk , nl real ( wp ), dimension ( ni , nj , nk , nl ), intent ( out ) :: array ! ----------------------- integer :: i , j , k , l ! ----------------------- !$acc parallel loop collapse(4) copyout(array) !$omp target teams distribute parallel do simd collapse(4) map(from:array) do l = 1 , nl do k = 1 , nk do j = 1 , nj do i = 1 , ni array ( i , j , k , l ) = 0.0_wp end do end do end do end do end subroutine zero_array_4D end module mo_rte_util_array","tags":"","loc":"sourcefile/mo_rte_util_array.f90.html"},{"title":"mo_optical_props_kernels.F90 – RTE kernels","text":"Contents Modules mo_optical_props_kernels Source Code mo_optical_props_kernels.F90 Source Code ! This code is part of Radiative Transfer for Energetics (RTE) ! ! Contacts: Robert Pincus and Eli Mlawer ! email: rrtmgp@aer.com ! ! Copyright 2015-, Atmospheric and Environmental Research, ! Regents of the University of Colorado, Trustees of Columbia University. All right reserved. ! ! Use and duplication is permitted under the terms of the ! BSD 3-clause license, see http://opensource.org/licenses/BSD-3-Clause ! ------------------------------------------------------------------------------------------------- ! !> ## Kernels for arrays of optical properties: !> - delta-scaling !> - adding two sets of properties !> - extracting subsets along the column dimension ! ! ------------------------------------------------------------------------------------------------- module mo_optical_props_kernels use , intrinsic :: iso_c_binding use mo_rte_kind , only : wp , wl implicit none public !> Delta-scale two-stream optical properties interface delta_scale_2str_kernel module procedure delta_scale_2str_f_k , delta_scale_2str_k end interface !> Subsetting, meaning extracting some portion of the 3D domain interface extract_subset module procedure extract_subset_dim1_3d , extract_subset_dim2_4d module procedure extract_subset_absorption_tau end interface extract_subset real ( wp ), parameter , private :: eps = 3.0_wp * tiny ( 1.0_wp ) contains ! ------------------------------------------------------------------------------------------------- ! ! Delta-scaling is provided only for two-stream properties at present ! ! ------------------------------------------------------------------------------------------------- !> Delta-scale two-stream optical properties given user-provided value of f (forward scattering) ! pure subroutine delta_scale_2str_f_k ( ncol , nlay , ngpt , tau , ssa , g , f ) & bind ( C , name = \"rte_delta_scale_2str_f_k\" ) integer , intent ( in ) :: ncol , nlay , ngpt !! Array sizes real ( wp ), dimension ( ncol , nlay , ngpt ), intent ( inout ) :: tau , ssa , g !! Optical depth, single-scattering albedo, asymmetry parameter real ( wp ), dimension ( ncol , nlay , ngpt ), intent ( in ) :: f !! User-provided forward-scattering fraction real ( wp ) :: wf integer :: icol , ilay , igpt do igpt = 1 , ngpt do ilay = 1 , nlay do icol = 1 , ncol wf = ssa ( icol , ilay , igpt ) * f ( icol , ilay , igpt ) tau ( icol , ilay , igpt ) = ( 1._wp - wf ) * tau ( icol , ilay , igpt ) ssa ( icol , ilay , igpt ) = ( ssa ( icol , ilay , igpt ) - wf ) / max ( eps ,( 1.0_wp - wf )) g ( icol , ilay , igpt ) = ( g ( icol , ilay , igpt ) - f ( icol , ilay , igpt )) / & max ( eps ,( 1._wp - f ( icol , ilay , igpt ))) end do end do end do end subroutine delta_scale_2str_f_k ! --------------------------------- !> Delta-scale assuming forward-scatternig fraction is the square of the asymmetry parameter !> i.e. f = g^2 ! pure subroutine delta_scale_2str_k ( ncol , nlay , ngpt , tau , ssa , g ) & bind ( C , name = \"rte_delta_scale_2str_k\" ) integer , intent ( in ) :: ncol , nlay , ngpt !! Array sizes real ( wp ), dimension ( ncol , nlay , ngpt ), intent ( inout ) :: tau , ssa , g !! Optical depth, single-scattering albedo, asymmetry parameter real ( wp ) :: f , wf integer :: icol , ilay , igpt do igpt = 1 , ngpt do ilay = 1 , nlay do icol = 1 , ncol f = g ( icol , ilay , igpt ) * g ( icol , ilay , igpt ) wf = ssa ( icol , ilay , igpt ) * f tau ( icol , ilay , igpt ) = ( 1._wp - wf ) * tau ( icol , ilay , igpt ) ssa ( icol , ilay , igpt ) = ( ssa ( icol , ilay , igpt ) - wf ) / max ( eps ,( 1.0_wp - wf )) g ( icol , ilay , igpt ) = ( g ( icol , ilay , igpt ) - f ) / max ( eps ,( 1.0_wp - f )) end do end do end do end subroutine delta_scale_2str_k ! ------------------------------------------------------------------------------------------------- ! ! Addition of optical properties: the first set are incremented by the second set. ! ! There are three possible representations of optical properties (scalar = optical depth only; ! two-stream = tau, single-scattering albedo, and asymmetry factor g, and ! n-stream = tau, ssa, and phase function moments p.) Thus we need nine routines, three for ! each choice of representation on the left hand side times three representations of the ! optical properties to be added. ! ! There are two sets of these nine routines. In the first the two sets of optical ! properties are defined at the same spectral resolution. There is also a set of routines ! to add properties defined at lower spectral resolution to a set defined at higher spectral ! resolution (adding properties defined by band to those defined by g-point) ! ! ------------------------------------------------------------------------------------------------- !> increase one absorption optical depth by a second value pure subroutine increment_1scalar_by_1scalar ( ncol , nlay , ngpt , & tau1 , & tau2 ) bind ( C , name = \"rte_increment_1scalar_by_1scalar\" ) integer , intent ( in ) :: ncol , nlay , ngpt !! array sizes real ( wp ), dimension ( ncol , nlay , ngpt ), intent ( inout ) :: tau1 !! optical properties to be modified real ( wp ), dimension ( ncol , nlay , ngpt ), intent ( in ) :: tau2 !! optical properties to be added to original integer :: icol , ilay , igpt do igpt = 1 , ngpt do ilay = 1 , nlay do icol = 1 , ncol tau1 ( icol , ilay , igpt ) = tau1 ( icol , ilay , igpt ) + tau2 ( icol , ilay , igpt ) end do end do end do end subroutine increment_1scalar_by_1scalar ! --------------------------------- !> increase absorption optical depth with extinction optical depth (2-stream form) pure subroutine increment_1scalar_by_2stream ( ncol , nlay , ngpt , & tau1 , & tau2 , ssa2 ) bind ( C , name = \"rte_increment_1scalar_by_2stream\" ) integer , intent ( in ) :: ncol , nlay , ngpt !! array sizes real ( wp ), dimension ( ncol , nlay , ngpt ), intent ( inout ) :: tau1 !! optical properties to be modified real ( wp ), dimension ( ncol , nlay , ngpt ), intent ( in ) :: tau2 , ssa2 !! optical properties to be added to original integer :: icol , ilay , igpt do igpt = 1 , ngpt do ilay = 1 , nlay do icol = 1 , ncol tau1 ( icol , ilay , igpt ) = tau1 ( icol , ilay , igpt ) + & tau2 ( icol , ilay , igpt ) * ( 1._wp - ssa2 ( icol , ilay , igpt )) end do end do end do end subroutine increment_1scalar_by_2stream ! --------------------------------- !> increase absorption optical depth with extinction optical depth (n-stream form) pure subroutine increment_1scalar_by_nstream ( ncol , nlay , ngpt , & tau1 , & tau2 , ssa2 ) bind ( C , name = \"rte_increment_1scalar_by_nstream\" ) integer , intent ( in ) :: ncol , nlay , ngpt !! array sizes real ( wp ), dimension ( ncol , nlay , ngpt ), intent ( inout ) :: tau1 !! optical properties to be modified real ( wp ), dimension ( ncol , nlay , ngpt ), intent ( in ) :: tau2 , ssa2 !! optical properties to be added to original integer :: icol , ilay , igpt do igpt = 1 , ngpt do ilay = 1 , nlay do icol = 1 , ncol tau1 ( icol , ilay , igpt ) = tau1 ( icol , ilay , igpt ) + & tau2 ( icol , ilay , igpt ) * ( 1._wp - ssa2 ( icol , ilay , igpt )) end do end do end do end subroutine increment_1scalar_by_nstream ! --------------------------------- ! --------------------------------- !> increment two-stream optical properties \\tau, \\omega_0, g with absorption optical depth pure subroutine increment_2stream_by_1scalar ( ncol , nlay , ngpt , & tau1 , ssa1 , & tau2 ) bind ( C , name = \"rte_increment_2stream_by_1scalar\" ) integer , intent ( in ) :: ncol , nlay , ngpt !! array sizes real ( wp ), dimension ( ncol , nlay , ngpt ), intent ( inout ) :: tau1 , ssa1 !! optical properties to be modified real ( wp ), dimension ( ncol , nlay , ngpt ), intent ( in ) :: tau2 !! optical properties to be added to original integer :: icol , ilay , igpt real ( wp ) :: tau12 do igpt = 1 , ngpt do ilay = 1 , nlay do icol = 1 , ncol tau12 = tau1 ( icol , ilay , igpt ) + tau2 ( icol , ilay , igpt ) ssa1 ( icol , ilay , igpt ) = tau1 ( icol , ilay , igpt ) * ssa1 ( icol , ilay , igpt ) / max ( eps , tau12 ) tau1 ( icol , ilay , igpt ) = tau12 ! g is unchanged end do end do end do end subroutine increment_2stream_by_1scalar ! --------------------------------- !> increment two-stream optical properties \\tau, \\omega_0, g with a second set pure subroutine increment_2stream_by_2stream ( ncol , nlay , ngpt , & tau1 , ssa1 , g1 , & tau2 , ssa2 , g2 ) bind ( C , name = \"rte_increment_2stream_by_2stream\" ) integer , intent ( in ) :: ncol , nlay , ngpt !! array sizes real ( wp ), dimension ( ncol , nlay , ngpt ), intent ( inout ) :: tau1 , ssa1 , g1 !! optical properties to be modified real ( wp ), dimension ( ncol , nlay , ngpt ), intent ( in ) :: tau2 , ssa2 , g2 !! optical properties to be added to original integer :: icol , ilay , igpt real ( wp ) :: tau12 , tauscat12 do igpt = 1 , ngpt do ilay = 1 , nlay do icol = 1 , ncol ! t=tau1 + tau2 tau12 = tau1 ( icol , ilay , igpt ) + tau2 ( icol , ilay , igpt ) ! w=(tau1*ssa1 + tau2*ssa2) / t tauscat12 = tau1 ( icol , ilay , igpt ) * ssa1 ( icol , ilay , igpt ) + & tau2 ( icol , ilay , igpt ) * ssa2 ( icol , ilay , igpt ) g1 ( icol , ilay , igpt ) = & ( tau1 ( icol , ilay , igpt ) * ssa1 ( icol , ilay , igpt ) * g1 ( icol , ilay , igpt ) + & tau2 ( icol , ilay , igpt ) * ssa2 ( icol , ilay , igpt ) * g2 ( icol , ilay , igpt )) & / max ( eps , tauscat12 ) ssa1 ( icol , ilay , igpt ) = tauscat12 / max ( eps , tau12 ) tau1 ( icol , ilay , igpt ) = tau12 end do end do end do end subroutine increment_2stream_by_2stream ! --------------------------------- !> increment two-stream optical properties \\tau, \\omega_0, g with _n_-stream pure subroutine increment_2stream_by_nstream ( ncol , nlay , ngpt , nmom2 , & tau1 , ssa1 , g1 , & tau2 , ssa2 , p2 ) bind ( C , name = \"rte_increment_2stream_by_nstream\" ) integer , intent ( in ) :: ncol , nlay , ngpt , nmom2 !! array sizes real ( wp ), dimension ( ncol , nlay , ngpt ), intent ( inout ) :: tau1 , ssa1 , g1 !! optical properties to be modified real ( wp ), dimension ( ncol , nlay , ngpt ), intent ( in ) :: tau2 , ssa2 !! optical properties to be added to original real ( wp ), dimension ( nmom2 , & ncol , nlay , ngpt ), intent ( in ) :: p2 !! moments of the phase function to be added integer :: icol , ilay , igpt real ( wp ) :: tau12 , tauscat12 do igpt = 1 , ngpt do ilay = 1 , nlay do icol = 1 , ncol ! t=tau1 + tau2 tau12 = tau1 ( icol , ilay , igpt ) + tau2 ( icol , ilay , igpt ) ! w=(tau1*ssa1 + tau2*ssa2) / t tauscat12 = & tau1 ( icol , ilay , igpt ) * ssa1 ( icol , ilay , igpt ) + & tau2 ( icol , ilay , igpt ) * ssa2 ( icol , ilay , igpt ) g1 ( icol , ilay , igpt ) = & ( tau1 ( icol , ilay , igpt ) * ssa1 ( icol , ilay , igpt ) * g1 ( icol , ilay , igpt ) + & tau2 ( icol , ilay , igpt ) * ssa2 ( icol , ilay , igpt ) * p2 ( 1 , icol , ilay , igpt )) / max ( eps , tauscat12 ) ssa1 ( icol , ilay , igpt ) = tauscat12 / max ( eps , tau12 ) tau1 ( icol , ilay , igpt ) = tau12 end do end do end do end subroutine increment_2stream_by_nstream ! --------------------------------- ! --------------------------------- !> increment _n_-stream optical properties \\tau, \\omega_0, p with absorption optical depth pure subroutine increment_nstream_by_1scalar ( ncol , nlay , ngpt , & tau1 , ssa1 , & tau2 ) bind ( C , name = \"rte_increment_nstream_by_1scalar\" ) integer , intent ( in ) :: ncol , nlay , ngpt !! array sizes real ( wp ), dimension ( ncol , nlay , ngpt ), intent ( inout ) :: tau1 , ssa1 !! optical properties to be modified real ( wp ), dimension ( ncol , nlay , ngpt ), intent ( in ) :: tau2 !! optical properties to be added to original integer :: icol , ilay , igpt real ( wp ) :: tau12 do igpt = 1 , ngpt do ilay = 1 , nlay do icol = 1 , ncol tau12 = tau1 ( icol , ilay , igpt ) + tau2 ( icol , ilay , igpt ) ssa1 ( icol , ilay , igpt ) = tau1 ( icol , ilay , igpt ) * ssa1 ( icol , ilay , igpt ) / max ( eps , tau12 ) tau1 ( icol , ilay , igpt ) = tau12 ! p is unchanged end do end do end do end subroutine increment_nstream_by_1scalar ! --------------------------------- !> increment _n_-stream optical properties \\tau, \\omega_0, p with two-stream values pure subroutine increment_nstream_by_2stream ( ncol , nlay , ngpt , nmom1 , & tau1 , ssa1 , p1 , & tau2 , ssa2 , g2 ) bind ( C , name = \"rte_increment_nstream_by_2stream\" ) integer , intent ( in ) :: ncol , nlay , ngpt , nmom1 !! array sizes real ( wp ), dimension ( ncol , nlay , ngpt ), intent ( inout ) :: tau1 , ssa1 !! optical properties to be modified real ( wp ), dimension ( nmom1 , & ncol , nlay , ngpt ), intent ( inout ) :: p1 !! moments of the phase function be modified real ( wp ), dimension ( ncol , nlay , ngpt ), intent ( in ) :: tau2 , ssa2 , g2 !! optical properties to be added to original integer :: icol , ilay , igpt real ( wp ) :: tau12 , tauscat12 real ( wp ), dimension ( nmom1 ) :: temp_moms ! TK integer :: imom !TK do igpt = 1 , ngpt do ilay = 1 , nlay do icol = 1 , ncol tau12 = tau1 ( icol , ilay , igpt ) + tau2 ( icol , ilay , igpt ) tauscat12 = & tau1 ( icol , ilay , igpt ) * ssa1 ( icol , ilay , igpt ) + & tau2 ( icol , ilay , igpt ) * ssa2 ( icol , ilay , igpt ) ! ! Here assume Henyey-Greenstein ! temp_moms ( 1 ) = g2 ( icol , ilay , igpt ) do imom = 2 , nmom1 temp_moms ( imom ) = temp_moms ( imom - 1 ) * g2 ( icol , ilay , igpt ) end do p1 ( 1 : nmom1 , icol , ilay , igpt ) = & ( tau1 ( icol , ilay , igpt ) * ssa1 ( icol , ilay , igpt ) * p1 ( 1 : nmom1 , icol , ilay , igpt ) + & tau2 ( icol , ilay , igpt ) * ssa2 ( icol , ilay , igpt ) * temp_moms ( 1 : nmom1 ) ) / max ( eps , tauscat12 ) ssa1 ( icol , ilay , igpt ) = tauscat12 / max ( eps , tau12 ) tau1 ( icol , ilay , igpt ) = tau12 end do end do end do end subroutine increment_nstream_by_2stream ! --------------------------------- !> increment one set of _n_-stream optical properties with another set pure subroutine increment_nstream_by_nstream ( ncol , nlay , ngpt , nmom1 , nmom2 , & tau1 , ssa1 , p1 , & tau2 , ssa2 , p2 ) bind ( C , name = \"rte_increment_nstream_by_nstream\" ) integer , intent ( in ) :: ncol , nlay , ngpt , nmom1 , nmom2 !! array sizes real ( wp ), dimension ( ncol , nlay , ngpt ), intent ( inout ) :: tau1 , ssa1 !! optical properties to be modified real ( wp ), dimension ( nmom1 , & ncol , nlay , ngpt ), intent ( inout ) :: p1 !! moments of the phase function be modified real ( wp ), dimension ( ncol , nlay , ngpt ), intent ( in ) :: tau2 , ssa2 !! optical properties to be added to original real ( wp ), dimension ( nmom2 , & ncol , nlay , ngpt ), intent ( in ) :: p2 !! moments of the phase function to be added integer :: icol , ilay , igpt , mom_lim real ( wp ) :: tau12 , tauscat12 mom_lim = min ( nmom1 , nmom2 ) do igpt = 1 , ngpt do ilay = 1 , nlay do icol = 1 , ncol tau12 = tau1 ( icol , ilay , igpt ) + tau2 ( icol , ilay , igpt ) tauscat12 = & tau1 ( icol , ilay , igpt ) * ssa1 ( icol , ilay , igpt ) + & tau2 ( icol , ilay , igpt ) * ssa2 ( icol , ilay , igpt ) ! ! If op2 has more moments than op1 these are ignored; ! if it has fewer moments the higher orders are assumed to be 0 ! p1 ( 1 : mom_lim , icol , ilay , igpt ) = & ( tau1 ( icol , ilay , igpt ) * ssa1 ( icol , ilay , igpt ) * p1 ( 1 : mom_lim , icol , ilay , igpt ) + & tau2 ( icol , ilay , igpt ) * ssa2 ( icol , ilay , igpt ) * p2 ( 1 : mom_lim , icol , ilay , igpt )) / max ( eps , tauscat12 ) ssa1 ( icol , ilay , igpt ) = tauscat12 / max ( eps , tau12 ) tau1 ( icol , ilay , igpt ) = tau12 end do end do end do end subroutine increment_nstream_by_nstream ! ------------------------------------------------------------------------------------------------- ! ! Incrementing when the second set of optical properties is defined at lower spectral resolution ! (e.g. by band instead of by gpoint) ! ! ------------------------------------------------------------------------------------------------- !> increase one absorption optical depth defined on g-points by a second value defined on bands pure subroutine inc_1scalar_by_1scalar_bybnd ( ncol , nlay , ngpt , & tau1 , & tau2 , & nbnd , gpt_lims ) bind ( C , name = \"rte_inc_1scalar_by_1scalar_bybnd\" ) integer , intent ( in ) :: ncol , nlay , ngpt , nbnd !! array sizes real ( wp ), dimension ( ncol , nlay , ngpt ), intent ( inout ) :: tau1 !! optical properties to be modified (defined on g-points) real ( wp ), dimension ( ncol , nlay , nbnd ), intent ( in ) :: tau2 !! optical properties to be added to original (defined on bands) integer , dimension ( 2 , nbnd ), intent ( in ) :: gpt_lims !! Starting and ending gpoint for each band integer :: ibnd , igpt do ibnd = 1 , nbnd do igpt = gpt_lims ( 1 , ibnd ), gpt_lims ( 2 , ibnd ) tau1 (:,:, igpt ) = tau1 (:,:, igpt ) + tau2 (:,:, ibnd ) end do end do end subroutine inc_1scalar_by_1scalar_bybnd ! --------------------------------- !> increase absorption optical depth defined on g-points with extinction optical depth (2-stream form) defined on bands pure subroutine inc_1scalar_by_2stream_bybnd ( ncol , nlay , ngpt , & tau1 , & tau2 , ssa2 , & nbnd , gpt_lims ) bind ( C , name = \"rte_inc_1scalar_by_2stream_bybnd\" ) integer , intent ( in ) :: ncol , nlay , ngpt , nbnd !! array sizes real ( wp ), dimension ( ncol , nlay , ngpt ), intent ( inout ) :: tau1 !! optical properties to be modified (defined on g-points) real ( wp ), dimension ( ncol , nlay , nbnd ), intent ( in ) :: tau2 , ssa2 !! optical properties to be added to original (defined on bands) integer , dimension ( 2 , nbnd ), intent ( in ) :: gpt_lims !! Starting and ending gpoint for each band integer :: ibnd , igpt do ibnd = 1 , nbnd do igpt = gpt_lims ( 1 , ibnd ), gpt_lims ( 2 , ibnd ) tau1 (:,:, igpt ) = tau1 (:,:, igpt ) + tau2 (:,:, ibnd ) * ( 1._wp - ssa2 (:,:, ibnd )) end do end do end subroutine inc_1scalar_by_2stream_bybnd ! --------------------------------- !> increase absorption optical depth defined on g-points with extinction optical depth (n-stream form) defined on bands pure subroutine inc_1scalar_by_nstream_bybnd ( ncol , nlay , ngpt , & tau1 , & tau2 , ssa2 , & nbnd , gpt_lims ) bind ( C , name = \"rte_inc_1scalar_by_nstream_bybnd\" ) integer , intent ( in ) :: ncol , nlay , ngpt , nbnd !! array sizes real ( wp ), dimension ( ncol , nlay , ngpt ), intent ( inout ) :: tau1 !! optical properties to be modified (defined on g-points) real ( wp ), dimension ( ncol , nlay , nbnd ), intent ( in ) :: tau2 , ssa2 !! optical properties to be added to original (defined on bands) integer , dimension ( 2 , nbnd ), intent ( in ) :: gpt_lims !! Starting and ending gpoint for each band integer :: ibnd , igpt do ibnd = 1 , nbnd do igpt = gpt_lims ( 1 , ibnd ), gpt_lims ( 2 , ibnd ) tau1 (:,:, igpt ) = tau1 (:,:, igpt ) + tau2 (:,:, ibnd ) * ( 1._wp - ssa2 (:,:, ibnd )) end do end do end subroutine inc_1scalar_by_nstream_bybnd ! --------------------------------- !> increment two-stream optical properties \\tau, \\omega_0, g defined on g-points with absorption optical depth defined on bands pure subroutine inc_2stream_by_1scalar_bybnd ( ncol , nlay , ngpt , & tau1 , ssa1 , & tau2 , & nbnd , gpt_lims ) bind ( C , name = \"rte_inc_2stream_by_1scalar_bybnd\" ) integer , intent ( in ) :: ncol , nlay , ngpt , nbnd !! array sizes real ( wp ), dimension ( ncol , nlay , ngpt ), intent ( inout ) :: tau1 , ssa1 !! optical properties to be modified (defined on g-points) real ( wp ), dimension ( ncol , nlay , nbnd ), intent ( in ) :: tau2 !! optical properties to be added to original (defined on bands) integer , dimension ( 2 , nbnd ), intent ( in ) :: gpt_lims !! Starting and ending gpoint for each band integer :: icol , ilay , igpt , ibnd real ( wp ) :: tau12 do ibnd = 1 , nbnd do igpt = gpt_lims ( 1 , ibnd ), gpt_lims ( 2 , ibnd ) do ilay = 1 , nlay do icol = 1 , ncol tau12 = tau1 ( icol , ilay , igpt ) + tau2 ( icol , ilay , ibnd ) ssa1 ( icol , ilay , igpt ) = tau1 ( icol , ilay , igpt ) * ssa1 ( icol , ilay , igpt ) / max ( eps , tau12 ) tau1 ( icol , ilay , igpt ) = tau12 ! g is unchanged end do end do end do end do end subroutine inc_2stream_by_1scalar_bybnd ! --------------------------------- !> increment 2-stream optical properties defined on g-points with another set defined on bands pure subroutine inc_2stream_by_2stream_bybnd ( ncol , nlay , ngpt , & tau1 , ssa1 , g1 , & tau2 , ssa2 , g2 , & nbnd , gpt_lims ) bind ( C , name = \"rte_inc_2stream_by_2stream_bybnd\" ) integer , intent ( in ) :: ncol , nlay , ngpt , nbnd !! array sizes real ( wp ), dimension ( ncol , nlay , ngpt ), intent ( inout ) :: tau1 , ssa1 , g1 !! optical properties to be modified (defined on g-points) real ( wp ), dimension ( ncol , nlay , nbnd ), intent ( in ) :: tau2 , ssa2 , g2 !! optical properties to be added to original (defined on bands) integer , dimension ( 2 , nbnd ), intent ( in ) :: gpt_lims !! Starting and ending gpoint for each band integer :: icol , ilay , igpt , ibnd real ( wp ) :: tau12 , tauscat12 do ibnd = 1 , nbnd do igpt = gpt_lims ( 1 , ibnd ), gpt_lims ( 2 , ibnd ) do ilay = 1 , nlay do icol = 1 , ncol ! t=tau1 + tau2 tau12 = tau1 ( icol , ilay , igpt ) + tau2 ( icol , ilay , ibnd ) ! w=(tau1*ssa1 + tau2*ssa2) / t tauscat12 = & tau1 ( icol , ilay , igpt ) * ssa1 ( icol , ilay , igpt ) + & tau2 ( icol , ilay , ibnd ) * ssa2 ( icol , ilay , ibnd ) g1 ( icol , ilay , igpt ) = & ( tau1 ( icol , ilay , igpt ) * ssa1 ( icol , ilay , igpt ) * g1 ( icol , ilay , igpt ) + & tau2 ( icol , ilay , ibnd ) * ssa2 ( icol , ilay , ibnd ) * g2 ( icol , ilay , ibnd )) / max ( eps , tauscat12 ) ssa1 ( icol , ilay , igpt ) = tauscat12 / max ( eps , tau12 ) tau1 ( icol , ilay , igpt ) = tau12 end do end do end do end do end subroutine inc_2stream_by_2stream_bybnd ! --------------------------------- !> increment 2-stream optical properties defined on g-points with _n_-stream properties set defined on bands pure subroutine inc_2stream_by_nstream_bybnd ( ncol , nlay , ngpt , nmom2 , & tau1 , ssa1 , g1 , & tau2 , ssa2 , p2 , & nbnd , gpt_lims ) bind ( C , name = \"rte_inc_2stream_by_nstream_bybnd\" ) integer , intent ( in ) :: ncol , nlay , ngpt , nmom2 , nbnd !! array sizes real ( wp ), dimension ( ncol , nlay , ngpt ), intent ( inout ) :: tau1 , ssa1 , g1 !! optical properties to be modified (defined on g-points) real ( wp ), dimension ( ncol , nlay , nbnd ), intent ( in ) :: tau2 , ssa2 !! optical properties to be added to original (defined on bands) real ( wp ), dimension ( nmom2 , & ncol , nlay , nbnd ), intent ( in ) :: p2 !! moments of the phase function to be added integer , dimension ( 2 , nbnd ), intent ( in ) :: gpt_lims !! Starting and ending gpoint for each band integer :: icol , ilay , igpt , ibnd real ( wp ) :: tau12 , tauscat12 do ibnd = 1 , nbnd do igpt = gpt_lims ( 1 , ibnd ), gpt_lims ( 2 , ibnd ) do ilay = 1 , nlay do icol = 1 , ncol ! t=tau1 + tau2 tau12 = tau1 ( icol , ilay , igpt ) + tau2 ( icol , ilay , ibnd ) ! w=(tau1*ssa1 + tau2*ssa2) / t tauscat12 = & tau1 ( icol , ilay , igpt ) * ssa1 ( icol , ilay , igpt ) + & tau2 ( icol , ilay , ibnd ) * ssa2 ( icol , ilay , ibnd ) g1 ( icol , ilay , igpt ) = & ( tau1 ( icol , ilay , igpt ) * ssa1 ( icol , ilay , igpt ) * g1 ( icol , ilay , igpt ) + & tau2 ( icol , ilay , ibnd ) * ssa2 ( icol , ilay , ibnd ) * p2 ( 1 , icol , ilay , ibnd )) / max ( eps , tauscat12 ) ssa1 ( icol , ilay , igpt ) = tauscat12 / max ( eps , tau12 ) tau1 ( icol , ilay , igpt ) = tau12 end do end do end do end do end subroutine inc_2stream_by_nstream_bybnd ! --------------------------------- ! --------------------------------- !> increment _n_-stream optical properties defined on g-points with absorption optical depth defined on bands pure subroutine inc_nstream_by_1scalar_bybnd ( ncol , nlay , ngpt , & tau1 , ssa1 , & tau2 , & nbnd , gpt_lims ) bind ( C , name = \"rte_inc_nstream_by_1scalar_bybnd\" ) integer , intent ( in ) :: ncol , nlay , ngpt , nbnd !! array sizes real ( wp ), dimension ( ncol , nlay , ngpt ), intent ( inout ) :: tau1 , ssa1 !! optical properties to be modified (defined on g-points) real ( wp ), dimension ( ncol , nlay , nbnd ), intent ( in ) :: tau2 !! optical properties to be added to original (defined on bands) integer , dimension ( 2 , nbnd ), intent ( in ) :: gpt_lims !! Starting and ending gpoint for each band integer :: icol , ilay , igpt , ibnd real ( wp ) :: tau12 do ibnd = 1 , nbnd do igpt = gpt_lims ( 1 , ibnd ), gpt_lims ( 2 , ibnd ) do ilay = 1 , nlay do icol = 1 , ncol tau12 = tau1 ( icol , ilay , igpt ) + tau2 ( icol , ilay , ibnd ) ssa1 ( icol , ilay , igpt ) = tau1 ( icol , ilay , igpt ) * ssa1 ( icol , ilay , igpt ) / max ( eps , tau12 ) tau1 ( icol , ilay , igpt ) = tau12 ! p is unchanged end do end do end do end do end subroutine inc_nstream_by_1scalar_bybnd ! --------------------------------- !> increment n-stream optical properties defined on g-points with 2-stream properties set defined on bands pure subroutine inc_nstream_by_2stream_bybnd ( ncol , nlay , ngpt , nmom1 , & tau1 , ssa1 , p1 , & tau2 , ssa2 , g2 , & nbnd , gpt_lims ) bind ( C , name = \"rte_inc_nstream_by_2stream_bybnd\" ) integer , intent ( in ) :: ncol , nlay , ngpt , nmom1 , nbnd !! array sizes real ( wp ), dimension ( ncol , nlay , ngpt ), intent ( inout ) :: tau1 , ssa1 !! optical properties to be modified (defined on g-points) real ( wp ), dimension ( nmom1 , & ncol , nlay , ngpt ), intent ( inout ) :: p1 !! moments of the phase function be modified real ( wp ), dimension ( ncol , nlay , nbnd ), intent ( in ) :: tau2 , ssa2 , g2 !! optical properties to be added to original (defined on bands) integer , dimension ( 2 , nbnd ), intent ( in ) :: gpt_lims !! Starting and ending gpoint for each band integer :: icol , ilay , igpt , ibnd real ( wp ) :: tau12 , tauscat12 real ( wp ), dimension ( nmom1 ) :: temp_moms ! TK integer :: imom !TK do ibnd = 1 , nbnd do igpt = gpt_lims ( 1 , ibnd ), gpt_lims ( 2 , ibnd ) do ilay = 1 , nlay do icol = 1 , ncol tau12 = tau1 ( icol , ilay , igpt ) + tau2 ( icol , ilay , ibnd ) tauscat12 = & tau1 ( icol , ilay , igpt ) * ssa1 ( icol , ilay , igpt ) + & tau2 ( icol , ilay , ibnd ) * ssa2 ( icol , ilay , ibnd ) ! ! Here assume Henyey-Greenstein ! temp_moms ( 1 ) = g2 ( icol , ilay , ibnd ) do imom = 2 , nmom1 temp_moms ( imom ) = temp_moms ( imom - 1 ) * g2 ( icol , ilay , ibnd ) end do p1 ( 1 : nmom1 , icol , ilay , igpt ) = & ( tau1 ( icol , ilay , igpt ) * ssa1 ( icol , ilay , igpt ) * p1 ( 1 : nmom1 , icol , ilay , igpt ) + & tau2 ( icol , ilay , ibnd ) * ssa2 ( icol , ilay , ibnd ) * temp_moms ( 1 : nmom1 ) ) / max ( eps , tauscat12 ) ssa1 ( icol , ilay , igpt ) = tauscat12 / max ( eps , tau12 ) tau1 ( icol , ilay , igpt ) = tau12 end do end do end do end do end subroutine inc_nstream_by_2stream_bybnd ! --------------------------------- !> increment _n_-stream optical properties defined on g-points with a second set defined on bands pure subroutine inc_nstream_by_nstream_bybnd ( ncol , nlay , ngpt , nmom1 , nmom2 , & tau1 , ssa1 , p1 , & tau2 , ssa2 , p2 , & nbnd , gpt_lims ) bind ( C , name = \"rte_inc_nstream_by_nstream_bybnd\" ) integer , intent ( in ) :: ncol , nlay , ngpt , nmom1 , nmom2 , nbnd !! array sizes real ( wp ), dimension ( ncol , nlay , ngpt ), intent ( inout ) :: tau1 , ssa1 !! optical properties to be modified (defined on g-points) real ( wp ), dimension ( nmom1 , & ncol , nlay , ngpt ), intent ( inout ) :: p1 !! moments of the phase function be modified real ( wp ), dimension ( ncol , nlay , nbnd ), intent ( in ) :: tau2 , ssa2 !! optical properties to be added to original (defined on bands) real ( wp ), dimension ( nmom2 , & ncol , nlay , nbnd ), intent ( in ) :: p2 !! moments of the phase function to be added integer , dimension ( 2 , nbnd ), intent ( in ) :: gpt_lims !! Starting and ending gpoint for each band integer :: icol , ilay , igpt , ibnd , mom_lim real ( wp ) :: tau12 , tauscat12 mom_lim = min ( nmom1 , nmom2 ) do ibnd = 1 , nbnd do igpt = gpt_lims ( 1 , ibnd ), gpt_lims ( 2 , ibnd ) do ilay = 1 , nlay do icol = 1 , ncol tau12 = tau1 ( icol , ilay , igpt ) + tau2 ( icol , ilay , ibnd ) tauscat12 = & tau1 ( icol , ilay , igpt ) * ssa1 ( icol , ilay , igpt ) + & tau2 ( icol , ilay , ibnd ) * ssa2 ( icol , ilay , ibnd ) ! ! If op2 has more moments than op1 these are ignored; ! if it has fewer moments the higher orders are assumed to be 0 ! p1 ( 1 : mom_lim , icol , ilay , igpt ) = & ( tau1 ( icol , ilay , igpt ) * ssa1 ( icol , ilay , igpt ) * p1 ( 1 : mom_lim , icol , ilay , igpt ) + & tau2 ( icol , ilay , ibnd ) * ssa2 ( icol , ilay , ibnd ) * p2 ( 1 : mom_lim , icol , ilay , ibnd )) / max ( eps , tauscat12 ) ssa1 ( icol , ilay , igpt ) = tauscat12 / max ( eps , tau12 ) tau1 ( icol , ilay , igpt ) = tau12 end do end do end do end do end subroutine inc_nstream_by_nstream_bybnd ! ------------------------------------------------------------------------------------------------- ! ! Subsetting, meaning extracting some portion of the 3D domain ! ! ------------------------------------------------------------------------------------------------- !> !> Extract a subset from the first dimension (normally columns) of a 3D field. !> Applicable to most variables e.g. tau, ssa, g !> pure subroutine extract_subset_dim1_3d ( ncol , nlay , ngpt , array_in , colS , colE , array_out ) & bind ( C , name = \"rte_extract_subset_dim1_3d\" ) integer , intent ( in ) :: ncol , nlay , ngpt !! Array sizes real ( wp ), dimension ( ncol , nlay , ngpt ), intent ( in ) :: array_in !! Array to subset integer , intent ( in ) :: colS , colE !! Starting and ending index real ( wp ), dimension ( colE - colS + 1 ,& nlay , ngpt ), intent ( out ) :: array_out !! subset of the input array integer :: icol , ilay , igpt do igpt = 1 , ngpt do ilay = 1 , nlay do icol = colS , colE array_out ( icol - colS + 1 , ilay , igpt ) = array_in ( icol , ilay , igpt ) end do end do end do end subroutine extract_subset_dim1_3d ! --------------------------------- !> Extract a subset from the second dimension (normally columns) of a 4D field. !> Applicable to phase function moments, where the first dimension is the moment pure subroutine extract_subset_dim2_4d ( nmom , ncol , nlay , ngpt , array_in , colS , colE , array_out ) & bind ( C , name = \"rte_extract_subset_dim2_4d\" ) integer , intent ( in ) :: nmom , ncol , nlay , ngpt !! Array sizes real ( wp ), dimension ( nmom , ncol , nlay , ngpt ), intent ( in ) :: array_in !! Array to subset integer , intent ( in ) :: colS , colE !! Starting and ending index real ( wp ), dimension ( nmom , colE - colS + 1 ,& nlay , ngpt ), intent ( out ) :: array_out !! subset of the input array integer :: icol , ilay , igpt , imom do igpt = 1 , ngpt do ilay = 1 , nlay do icol = colS , colE do imom = 1 , nmom array_out ( imom , icol - colS + 1 , ilay , igpt ) = array_in ( imom , icol , ilay , igpt ) end do end do end do end do end subroutine extract_subset_dim2_4d ! --------------------------------- ! !> Extract the absorption optical thickness \\tau_{abs} = 1 - \\omega_0 \\tau_{ext} ! pure subroutine extract_subset_absorption_tau ( ncol , nlay , ngpt , tau_in , ssa_in , & colS , colE , tau_out ) & bind ( C , name = \"rte_extract_subset_absorption_tau\" ) integer , intent ( in ) :: ncol , nlay , ngpt !! Array sizes real ( wp ), dimension ( ncol , nlay , ngpt ), intent ( in ) :: tau_in , ssa_in !! Optical thickness, single scattering albedo integer , intent ( in ) :: colS , colE !! Starting and ending index real ( wp ), dimension ( colE - colS + 1 ,& nlay , ngpt ), intent ( out ) :: tau_out !! absorption optical thickness subset integer :: icol , ilay , igpt do igpt = 1 , ngpt do ilay = 1 , nlay do icol = colS , colE tau_out ( icol - colS + 1 , ilay , igpt ) = & tau_in ( icol , ilay , igpt ) * ( 1._wp - ssa_in ( icol , ilay , igpt )) end do end do end do end subroutine extract_subset_absorption_tau end module mo_optical_props_kernels","tags":"","loc":"sourcefile/mo_optical_props_kernels.f90.html"},{"title":"mo_fluxes_broadband_kernels.F90 – RTE kernels","text":"Contents Modules mo_fluxes_broadband_kernels Source Code mo_fluxes_broadband_kernels.F90 Source Code ! This code is part of Radiative Transfer for Energetics (RTE) ! ! Contacts: Robert Pincus and Eli Mlawer ! email: rrtmgp@aer.com ! ! Copyright 2015-, Atmospheric and Environmental Research, ! Regents of the University of Colorado, Trustees of Columbia University. All right reserved. ! ! Use and duplication is permitted under the terms of the ! BSD 3-clause license, see http://opensource.org/licenses/BSD-3-Clause ! ------------------------------------------------------------------------------------------------- !> !> ## Kernels for computing broadband fluxes !> ! ------------------------------------------------------------------------------------------------- module mo_fluxes_broadband_kernels use , intrinsic :: iso_c_binding use mo_rte_kind , only : wp implicit none private public :: sum_broadband , net_broadband interface net_broadband !! Interface for computing net flux module procedure net_broadband_full , net_broadband_precalc end interface net_broadband contains ! ---------------------------------------------------------------------------- !> !> Spectral reduction over all points !> subroutine sum_broadband ( ncol , nlev , ngpt , spectral_flux , broadband_flux ) bind ( C , name = \"rte_sum_broadband\" ) integer , intent ( in ) :: ncol , nlev , ngpt !! Array sizes real ( wp ), dimension ( ncol , nlev , ngpt ), intent ( in ) :: spectral_flux !! Spectrally-resolved flux real ( wp ), dimension ( ncol , nlev ), intent ( out ) :: broadband_flux !! Sum of spectrally-resolved flux over `ngpt` integer :: icol , ilev , igpt real ( wp ) :: bb_flux_s ! local scalar version !$acc enter data copyin(spectral_flux) create(broadband_flux) !$omp target enter data map(to:spectral_flux) map(alloc:broadband_flux) !$acc parallel loop gang vector collapse(2) !$omp target teams distribute parallel do simd collapse(2) do ilev = 1 , nlev do icol = 1 , ncol bb_flux_s = 0.0_wp do igpt = 1 , ngpt bb_flux_s = bb_flux_s + spectral_flux ( icol , ilev , igpt ) end do broadband_flux ( icol , ilev ) = bb_flux_s end do end do !$acc exit data delete(spectral_flux) copyout(broadband_flux) !$omp target exit data map(release:spectral_flux) map(from:broadband_flux) end subroutine sum_broadband ! ---------------------------------------------------------------------------- !> !> Spectral reduction over all points for net flux !> subroutine net_broadband_full ( ncol , nlev , ngpt , spectral_flux_dn , spectral_flux_up , broadband_flux_net ) & bind ( C , name = \"rte_net_broadband_full\" ) integer , intent ( in ) :: ncol , nlev , ngpt !! Array sizes real ( wp ), dimension ( ncol , nlev , ngpt ), intent ( in ) :: spectral_flux_dn , spectral_flux_up !! Spectrally-resolved flux up and down real ( wp ), dimension ( ncol , nlev ), intent ( out ) :: broadband_flux_net !! Net (down minus up) summed over `ngpt` integer :: icol , ilev , igpt real ( wp ) :: diff !$acc enter data copyin(spectral_flux_dn, spectral_flux_up) create(broadband_flux_net) !$omp target enter data map(to:spectral_flux_dn, spectral_flux_up) map(alloc:broadband_flux_net) !$acc parallel loop collapse(2) !$omp target teams distribute parallel do simd collapse(2) do ilev = 1 , nlev do icol = 1 , ncol diff = spectral_flux_dn ( icol , ilev , 1 ) - spectral_flux_up ( icol , ilev , 1 ) broadband_flux_net ( icol , ilev ) = diff end do end do !$acc parallel loop collapse(3) !$omp target teams distribute parallel do simd collapse(3) do igpt = 2 , ngpt do ilev = 1 , nlev do icol = 1 , ncol diff = spectral_flux_dn ( icol , ilev , igpt ) - spectral_flux_up ( icol , ilev , igpt ) !$acc atomic update !$omp atomic update broadband_flux_net ( icol , ilev ) = broadband_flux_net ( icol , ilev ) + diff end do end do end do !$acc exit data delete(spectral_flux_dn, spectral_flux_up) copyout(broadband_flux_net) !$omp target exit data map(release:spectral_flux_dn, spectral_flux_up) map(from:broadband_flux_net) end subroutine net_broadband_full ! ---------------------------------------------------------------------------- !> !> Net flux when bradband flux up and down are already available !> subroutine net_broadband_precalc ( ncol , nlev , flux_dn , flux_up , broadband_flux_net ) & bind ( C , name = \"rte_net_broadband_precalc\" ) integer , intent ( in ) :: ncol , nlev !! Array sizes real ( wp ), dimension ( ncol , nlev ), intent ( in ) :: flux_dn , flux_up !! Broadband downward and upward fluxes real ( wp ), dimension ( ncol , nlev ), intent ( out ) :: broadband_flux_net !! Net (down minus up) integer :: icol , ilev !$acc enter data copyin(flux_dn, flux_up) create(broadband_flux_net) !$omp target enter data map(to:flux_dn, flux_up) map(alloc:broadband_flux_net) !$acc parallel loop collapse(2) !$omp target teams distribute parallel do simd collapse(2) do ilev = 1 , nlev do icol = 1 , ncol broadband_flux_net ( icol , ilev ) = flux_dn ( icol , ilev ) - flux_up ( icol , ilev ) end do end do !$acc exit data delete(flux_dn, flux_up) copyout(broadband_flux_net) !$omp target exit data map(release:flux_dn, flux_up) map(from:broadband_flux_net) end subroutine net_broadband_precalc ! ---------------------------------------------------------------------------- end module mo_fluxes_broadband_kernels","tags":"","loc":"sourcefile/mo_fluxes_broadband_kernels.f90.html"}]} \ No newline at end of file +var tipuesearch = {"pages":[{"title":" RTE kernels ","text":"RTE kernels These pages document the low-level computational kernels used by RRTMGP. The listings below are not exhaustive.\nTo see the full listings use the links at the top of the page.\nThere is a search bar in the top right. Return to the Documentation overview or the reference overview . Developer Info The RTE+RRTTMGP consortium","tags":"home","loc":"index.html"},{"title":"delta_scale_2str_f_k – RTE kernels","text":"public pure subroutine delta_scale_2str_f_k(ncol, nlay, ngpt, tau, ssa, g, f) bind(C, name=\"0\") Delta-scale two-stream optical properties given user-provided value of (forward scattering) Arguments Type Intent Optional Attributes Name integer, intent(in) :: ncol Array sizes integer, intent(in) :: nlay Array sizes integer, intent(in) :: ngpt Array sizes real(kind=wp), intent(inout), dimension(ncol, nlay, ngpt) :: tau Optical depth, single-scattering albedo, asymmetry parameter real(kind=wp), intent(inout), dimension(ncol, nlay, ngpt) :: ssa Optical depth, single-scattering albedo, asymmetry parameter real(kind=wp), intent(inout), dimension(ncol, nlay, ngpt) :: g Optical depth, single-scattering albedo, asymmetry parameter real(kind=wp), intent(in), dimension(ncol, nlay, ngpt) :: f User-provided forward-scattering fraction Called by proc~~delta_scale_2str_f_k~~CalledByGraph proc~delta_scale_2str_f_k delta_scale_2str_f_k interface~delta_scale_2str_kernel delta_scale_2str_kernel interface~delta_scale_2str_kernel->proc~delta_scale_2str_f_k Help × Graph Key Nodes of different colours represent the following: Graph Key Subroutine Subroutine Function Function Interface Interface Unknown Procedure Type Unknown Procedure Type Program Program This Page's Entity This Page's Entity Solid arrows point from a procedure to one which it calls. Dashed \n arrows point from an interface to procedures which implement that interface.\n This could include the module procedures in a generic interface or the\n implementation in a submodule of an interface in a parent module. Contents None","tags":"","loc":"proc/delta_scale_2str_f_k.html"},{"title":"delta_scale_2str_k – RTE kernels","text":"public pure subroutine delta_scale_2str_k(ncol, nlay, ngpt, tau, ssa, g) bind(C, name=\"0\") Delta-scale assuming forward-scatternig fraction is the square of the asymmetry parameter\n i.e. Arguments Type Intent Optional Attributes Name integer, intent(in) :: ncol Array sizes integer, intent(in) :: nlay Array sizes integer, intent(in) :: ngpt Array sizes real(kind=wp), intent(inout), dimension(ncol, nlay, ngpt) :: tau Optical depth, single-scattering albedo, asymmetry parameter real(kind=wp), intent(inout), dimension(ncol, nlay, ngpt) :: ssa Optical depth, single-scattering albedo, asymmetry parameter real(kind=wp), intent(inout), dimension(ncol, nlay, ngpt) :: g Optical depth, single-scattering albedo, asymmetry parameter Called by proc~~delta_scale_2str_k~~CalledByGraph proc~delta_scale_2str_k delta_scale_2str_k interface~delta_scale_2str_kernel delta_scale_2str_kernel interface~delta_scale_2str_kernel->proc~delta_scale_2str_k Help × Graph Key Nodes of different colours represent the following: Graph Key Subroutine Subroutine Function Function Interface Interface Unknown Procedure Type Unknown Procedure Type Program Program This Page's Entity This Page's Entity Solid arrows point from a procedure to one which it calls. Dashed \n arrows point from an interface to procedures which implement that interface.\n This could include the module procedures in a generic interface or the\n implementation in a submodule of an interface in a parent module. Contents None","tags":"","loc":"proc/delta_scale_2str_k.html"},{"title":"extract_subset_absorption_tau – RTE kernels","text":"public pure subroutine extract_subset_absorption_tau(ncol, nlay, ngpt, tau_in, ssa_in, colS, colE, tau_out) bind(C, name=\"0\") Extract the absorption optical thickness Arguments Type Intent Optional Attributes Name integer, intent(in) :: ncol Array sizes integer, intent(in) :: nlay Array sizes integer, intent(in) :: ngpt Array sizes real(kind=wp), intent(in), dimension(ncol,nlay,ngpt) :: tau_in Optical thickness, single scattering albedo real(kind=wp), intent(in), dimension(ncol,nlay,ngpt) :: ssa_in Optical thickness, single scattering albedo integer, intent(in) :: colS Starting and ending index integer, intent(in) :: colE Starting and ending index real(kind=wp), intent(out), dimension(colE-colS+1, nlay,ngpt) :: tau_out absorption optical thickness subset Called by proc~~extract_subset_absorption_tau~~CalledByGraph proc~extract_subset_absorption_tau extract_subset_absorption_tau interface~extract_subset extract_subset interface~extract_subset->proc~extract_subset_absorption_tau Help × Graph Key Nodes of different colours represent the following: Graph Key Subroutine Subroutine Function Function Interface Interface Unknown Procedure Type Unknown Procedure Type Program Program This Page's Entity This Page's Entity Solid arrows point from a procedure to one which it calls. Dashed \n arrows point from an interface to procedures which implement that interface.\n This could include the module procedures in a generic interface or the\n implementation in a submodule of an interface in a parent module. Contents None","tags":"","loc":"proc/extract_subset_absorption_tau.html"},{"title":"extract_subset_dim1_3d – RTE kernels","text":"public pure subroutine extract_subset_dim1_3d(ncol, nlay, ngpt, array_in, colS, colE, array_out) bind(C, name=\"0\") Extract a subset from the first dimension (normally columns) of a 3D field.\n Applicable to most variables e.g. tau, ssa, g Arguments Type Intent Optional Attributes Name integer, intent(in) :: ncol Array sizes integer, intent(in) :: nlay Array sizes integer, intent(in) :: ngpt Array sizes real(kind=wp), intent(in), dimension(ncol,nlay,ngpt) :: array_in Array to subset integer, intent(in) :: colS Starting and ending index integer, intent(in) :: colE Starting and ending index real(kind=wp), intent(out), dimension(colE-colS+1, nlay,ngpt) :: array_out subset of the input array Called by proc~~extract_subset_dim1_3d~~CalledByGraph proc~extract_subset_dim1_3d extract_subset_dim1_3d interface~extract_subset extract_subset interface~extract_subset->proc~extract_subset_dim1_3d Help × Graph Key Nodes of different colours represent the following: Graph Key Subroutine Subroutine Function Function Interface Interface Unknown Procedure Type Unknown Procedure Type Program Program This Page's Entity This Page's Entity Solid arrows point from a procedure to one which it calls. Dashed \n arrows point from an interface to procedures which implement that interface.\n This could include the module procedures in a generic interface or the\n implementation in a submodule of an interface in a parent module. Contents None","tags":"","loc":"proc/extract_subset_dim1_3d.html"},{"title":"extract_subset_dim2_4d – RTE kernels","text":"public pure subroutine extract_subset_dim2_4d(nmom, ncol, nlay, ngpt, array_in, colS, colE, array_out) bind(C, name=\"0\") Extract a subset from the second dimension (normally columns) of a 4D field.\n Applicable to phase function moments, where the first dimension is the moment Arguments Type Intent Optional Attributes Name integer, intent(in) :: nmom Array sizes integer, intent(in) :: ncol Array sizes integer, intent(in) :: nlay Array sizes integer, intent(in) :: ngpt Array sizes real(kind=wp), intent(in), dimension(nmom,ncol,nlay,ngpt) :: array_in Array to subset integer, intent(in) :: colS Starting and ending index integer, intent(in) :: colE Starting and ending index real(kind=wp), intent(out), dimension(nmom,colE-colS+1, nlay,ngpt) :: array_out subset of the input array Called by proc~~extract_subset_dim2_4d~~CalledByGraph proc~extract_subset_dim2_4d extract_subset_dim2_4d interface~extract_subset extract_subset interface~extract_subset->proc~extract_subset_dim2_4d Help × Graph Key Nodes of different colours represent the following: Graph Key Subroutine Subroutine Function Function Interface Interface Unknown Procedure Type Unknown Procedure Type Program Program This Page's Entity This Page's Entity Solid arrows point from a procedure to one which it calls. Dashed \n arrows point from an interface to procedures which implement that interface.\n This could include the module procedures in a generic interface or the\n implementation in a submodule of an interface in a parent module. Contents None","tags":"","loc":"proc/extract_subset_dim2_4d.html"},{"title":"inc_1scalar_by_1scalar_bybnd – RTE kernels","text":"public pure subroutine inc_1scalar_by_1scalar_bybnd(ncol, nlay, ngpt, tau1, tau2, nbnd, gpt_lims) bind(C, name=\"0\") increase one absorption optical depth defined on g-points by a second value defined on bands Arguments Type Intent Optional Attributes Name integer, intent(in) :: ncol array sizes integer, intent(in) :: nlay array sizes integer, intent(in) :: ngpt array sizes real(kind=wp), intent(inout), dimension(ncol,nlay,ngpt) :: tau1 optical properties to be modified (defined on g-points) real(kind=wp), intent(in), dimension(ncol,nlay,nbnd) :: tau2 optical properties to be added to original (defined on bands) integer, intent(in) :: nbnd array sizes integer, intent(in), dimension(2,nbnd) :: gpt_lims Starting and ending gpoint for each band Contents None","tags":"","loc":"proc/inc_1scalar_by_1scalar_bybnd.html"},{"title":"inc_1scalar_by_2stream_bybnd – RTE kernels","text":"public pure subroutine inc_1scalar_by_2stream_bybnd(ncol, nlay, ngpt, tau1, tau2, ssa2, nbnd, gpt_lims) bind(C, name=\"0\") increase absorption optical depth defined on g-points with extinction optical depth (2-stream form) defined on bands Arguments Type Intent Optional Attributes Name integer, intent(in) :: ncol array sizes integer, intent(in) :: nlay array sizes integer, intent(in) :: ngpt array sizes real(kind=wp), intent(inout), dimension(ncol,nlay,ngpt) :: tau1 optical properties to be modified (defined on g-points) real(kind=wp), intent(in), dimension(ncol,nlay,nbnd) :: tau2 optical properties to be added to original (defined on bands) real(kind=wp), intent(in), dimension(ncol,nlay,nbnd) :: ssa2 optical properties to be added to original (defined on bands) integer, intent(in) :: nbnd array sizes integer, intent(in), dimension(2,nbnd) :: gpt_lims Starting and ending gpoint for each band Contents None","tags":"","loc":"proc/inc_1scalar_by_2stream_bybnd.html"},{"title":"inc_1scalar_by_nstream_bybnd – RTE kernels","text":"public pure subroutine inc_1scalar_by_nstream_bybnd(ncol, nlay, ngpt, tau1, tau2, ssa2, nbnd, gpt_lims) bind(C, name=\"0\") increase absorption optical depth defined on g-points with extinction optical depth (n-stream form) defined on bands Arguments Type Intent Optional Attributes Name integer, intent(in) :: ncol array sizes integer, intent(in) :: nlay array sizes integer, intent(in) :: ngpt array sizes real(kind=wp), intent(inout), dimension(ncol,nlay,ngpt) :: tau1 optical properties to be modified (defined on g-points) real(kind=wp), intent(in), dimension(ncol,nlay,nbnd) :: tau2 optical properties to be added to original (defined on bands) real(kind=wp), intent(in), dimension(ncol,nlay,nbnd) :: ssa2 optical properties to be added to original (defined on bands) integer, intent(in) :: nbnd array sizes integer, intent(in), dimension(2,nbnd) :: gpt_lims Starting and ending gpoint for each band Contents None","tags":"","loc":"proc/inc_1scalar_by_nstream_bybnd.html"},{"title":"inc_2stream_by_1scalar_bybnd – RTE kernels","text":"public pure subroutine inc_2stream_by_1scalar_bybnd(ncol, nlay, ngpt, tau1, ssa1, tau2, nbnd, gpt_lims) bind(C, name=\"0\") increment two-stream optical properties defined on g-points with absorption optical depth defined on bands Arguments Type Intent Optional Attributes Name integer, intent(in) :: ncol array sizes integer, intent(in) :: nlay array sizes integer, intent(in) :: ngpt array sizes real(kind=wp), intent(inout), dimension(ncol,nlay,ngpt) :: tau1 optical properties to be modified (defined on g-points) real(kind=wp), intent(inout), dimension(ncol,nlay,ngpt) :: ssa1 optical properties to be modified (defined on g-points) real(kind=wp), intent(in), dimension(ncol,nlay,nbnd) :: tau2 optical properties to be added to original (defined on bands) integer, intent(in) :: nbnd array sizes integer, intent(in), dimension(2,nbnd) :: gpt_lims Starting and ending gpoint for each band Contents None","tags":"","loc":"proc/inc_2stream_by_1scalar_bybnd.html"},{"title":"inc_2stream_by_2stream_bybnd – RTE kernels","text":"public pure subroutine inc_2stream_by_2stream_bybnd(ncol, nlay, ngpt, tau1, ssa1, g1, tau2, ssa2, g2, nbnd, gpt_lims) bind(C, name=\"0\") increment 2-stream optical properties defined on g-points with another set defined on bands Arguments Type Intent Optional Attributes Name integer, intent(in) :: ncol array sizes integer, intent(in) :: nlay array sizes integer, intent(in) :: ngpt array sizes real(kind=wp), intent(inout), dimension(ncol,nlay,ngpt) :: tau1 optical properties to be modified (defined on g-points) real(kind=wp), intent(inout), dimension(ncol,nlay,ngpt) :: ssa1 optical properties to be modified (defined on g-points) real(kind=wp), intent(inout), dimension(ncol,nlay,ngpt) :: g1 optical properties to be modified (defined on g-points) real(kind=wp), intent(in), dimension(ncol,nlay,nbnd) :: tau2 optical properties to be added to original (defined on bands) real(kind=wp), intent(in), dimension(ncol,nlay,nbnd) :: ssa2 optical properties to be added to original (defined on bands) real(kind=wp), intent(in), dimension(ncol,nlay,nbnd) :: g2 optical properties to be added to original (defined on bands) integer, intent(in) :: nbnd array sizes integer, intent(in), dimension(2,nbnd) :: gpt_lims Starting and ending gpoint for each band Contents None","tags":"","loc":"proc/inc_2stream_by_2stream_bybnd.html"},{"title":"inc_2stream_by_nstream_bybnd – RTE kernels","text":"public pure subroutine inc_2stream_by_nstream_bybnd(ncol, nlay, ngpt, nmom2, tau1, ssa1, g1, tau2, ssa2, p2, nbnd, gpt_lims) bind(C, name=\"0\") increment 2-stream optical properties defined on g-points with n -stream properties set defined on bands Arguments Type Intent Optional Attributes Name integer, intent(in) :: ncol array sizes integer, intent(in) :: nlay array sizes integer, intent(in) :: ngpt array sizes integer, intent(in) :: nmom2 array sizes real(kind=wp), intent(inout), dimension(ncol,nlay,ngpt) :: tau1 optical properties to be modified (defined on g-points) real(kind=wp), intent(inout), dimension(ncol,nlay,ngpt) :: ssa1 optical properties to be modified (defined on g-points) real(kind=wp), intent(inout), dimension(ncol,nlay,ngpt) :: g1 optical properties to be modified (defined on g-points) real(kind=wp), intent(in), dimension(ncol,nlay,nbnd) :: tau2 optical properties to be added to original (defined on bands) real(kind=wp), intent(in), dimension(ncol,nlay,nbnd) :: ssa2 optical properties to be added to original (defined on bands) real(kind=wp), intent(in), dimension(nmom2, ncol,nlay,nbnd) :: p2 moments of the phase function to be added integer, intent(in) :: nbnd array sizes integer, intent(in), dimension(2,nbnd) :: gpt_lims Starting and ending gpoint for each band Contents None","tags":"","loc":"proc/inc_2stream_by_nstream_bybnd.html"},{"title":"inc_nstream_by_1scalar_bybnd – RTE kernels","text":"public pure subroutine inc_nstream_by_1scalar_bybnd(ncol, nlay, ngpt, tau1, ssa1, tau2, nbnd, gpt_lims) bind(C, name=\"0\") increment n -stream optical properties defined on g-points with absorption optical depth defined on bands Arguments Type Intent Optional Attributes Name integer, intent(in) :: ncol array sizes integer, intent(in) :: nlay array sizes integer, intent(in) :: ngpt array sizes real(kind=wp), intent(inout), dimension(ncol,nlay,ngpt) :: tau1 optical properties to be modified (defined on g-points) real(kind=wp), intent(inout), dimension(ncol,nlay,ngpt) :: ssa1 optical properties to be modified (defined on g-points) real(kind=wp), intent(in), dimension(ncol,nlay,nbnd) :: tau2 optical properties to be added to original (defined on bands) integer, intent(in) :: nbnd array sizes integer, intent(in), dimension(2,nbnd) :: gpt_lims Starting and ending gpoint for each band Contents None","tags":"","loc":"proc/inc_nstream_by_1scalar_bybnd.html"},{"title":"inc_nstream_by_2stream_bybnd – RTE kernels","text":"public pure subroutine inc_nstream_by_2stream_bybnd(ncol, nlay, ngpt, nmom1, tau1, ssa1, p1, tau2, ssa2, g2, nbnd, gpt_lims) bind(C, name=\"0\") increment n-stream optical properties defined on g-points with 2-stream properties set defined on bands Arguments Type Intent Optional Attributes Name integer, intent(in) :: ncol array sizes integer, intent(in) :: nlay array sizes integer, intent(in) :: ngpt array sizes integer, intent(in) :: nmom1 array sizes real(kind=wp), intent(inout), dimension(ncol,nlay,ngpt) :: tau1 optical properties to be modified (defined on g-points) real(kind=wp), intent(inout), dimension(ncol,nlay,ngpt) :: ssa1 optical properties to be modified (defined on g-points) real(kind=wp), intent(inout), dimension(nmom1, ncol,nlay,ngpt) :: p1 moments of the phase function be modified real(kind=wp), intent(in), dimension(ncol,nlay,nbnd) :: tau2 optical properties to be added to original (defined on bands) real(kind=wp), intent(in), dimension(ncol,nlay,nbnd) :: ssa2 optical properties to be added to original (defined on bands) real(kind=wp), intent(in), dimension(ncol,nlay,nbnd) :: g2 optical properties to be added to original (defined on bands) integer, intent(in) :: nbnd array sizes integer, intent(in), dimension(2,nbnd) :: gpt_lims Starting and ending gpoint for each band Contents None","tags":"","loc":"proc/inc_nstream_by_2stream_bybnd.html"},{"title":"inc_nstream_by_nstream_bybnd – RTE kernels","text":"public pure subroutine inc_nstream_by_nstream_bybnd(ncol, nlay, ngpt, nmom1, nmom2, tau1, ssa1, p1, tau2, ssa2, p2, nbnd, gpt_lims) bind(C, name=\"0\") increment n -stream optical properties defined on g-points with a second set defined on bands Arguments Type Intent Optional Attributes Name integer, intent(in) :: ncol array sizes integer, intent(in) :: nlay array sizes integer, intent(in) :: ngpt array sizes integer, intent(in) :: nmom1 array sizes integer, intent(in) :: nmom2 array sizes real(kind=wp), intent(inout), dimension(ncol,nlay,ngpt) :: tau1 optical properties to be modified (defined on g-points) real(kind=wp), intent(inout), dimension(ncol,nlay,ngpt) :: ssa1 optical properties to be modified (defined on g-points) real(kind=wp), intent(inout), dimension(nmom1, ncol,nlay,ngpt) :: p1 moments of the phase function be modified real(kind=wp), intent(in), dimension(ncol,nlay,nbnd) :: tau2 optical properties to be added to original (defined on bands) real(kind=wp), intent(in), dimension(ncol,nlay,nbnd) :: ssa2 optical properties to be added to original (defined on bands) real(kind=wp), intent(in), dimension(nmom2, ncol,nlay,nbnd) :: p2 moments of the phase function to be added integer, intent(in) :: nbnd array sizes integer, intent(in), dimension(2,nbnd) :: gpt_lims Starting and ending gpoint for each band Contents None","tags":"","loc":"proc/inc_nstream_by_nstream_bybnd.html"},{"title":"increment_1scalar_by_1scalar – RTE kernels","text":"public pure subroutine increment_1scalar_by_1scalar(ncol, nlay, ngpt, tau1, tau2) bind(C, name=\"0\") increase one absorption optical depth by a second value Arguments Type Intent Optional Attributes Name integer, intent(in) :: ncol array sizes integer, intent(in) :: nlay array sizes integer, intent(in) :: ngpt array sizes real(kind=wp), intent(inout), dimension(ncol,nlay,ngpt) :: tau1 optical properties to be modified real(kind=wp), intent(in), dimension(ncol,nlay,ngpt) :: tau2 optical properties to be added to original Contents None","tags":"","loc":"proc/increment_1scalar_by_1scalar.html"},{"title":"increment_1scalar_by_2stream – RTE kernels","text":"public pure subroutine increment_1scalar_by_2stream(ncol, nlay, ngpt, tau1, tau2, ssa2) bind(C, name=\"0\") increase absorption optical depth with extinction optical depth (2-stream form) Arguments Type Intent Optional Attributes Name integer, intent(in) :: ncol array sizes integer, intent(in) :: nlay array sizes integer, intent(in) :: ngpt array sizes real(kind=wp), intent(inout), dimension(ncol,nlay,ngpt) :: tau1 optical properties to be modified real(kind=wp), intent(in), dimension(ncol,nlay,ngpt) :: tau2 optical properties to be added to original real(kind=wp), intent(in), dimension(ncol,nlay,ngpt) :: ssa2 optical properties to be added to original Contents None","tags":"","loc":"proc/increment_1scalar_by_2stream.html"},{"title":"increment_1scalar_by_nstream – RTE kernels","text":"public pure subroutine increment_1scalar_by_nstream(ncol, nlay, ngpt, tau1, tau2, ssa2) bind(C, name=\"0\") increase absorption optical depth with extinction optical depth (n-stream form) Arguments Type Intent Optional Attributes Name integer, intent(in) :: ncol array sizes integer, intent(in) :: nlay array sizes integer, intent(in) :: ngpt array sizes real(kind=wp), intent(inout), dimension(ncol,nlay,ngpt) :: tau1 optical properties to be modified real(kind=wp), intent(in), dimension(ncol,nlay,ngpt) :: tau2 optical properties to be added to original real(kind=wp), intent(in), dimension(ncol,nlay,ngpt) :: ssa2 optical properties to be added to original Contents None","tags":"","loc":"proc/increment_1scalar_by_nstream.html"},{"title":"increment_2stream_by_1scalar – RTE kernels","text":"public pure subroutine increment_2stream_by_1scalar(ncol, nlay, ngpt, tau1, ssa1, tau2) bind(C, name=\"0\") increment two-stream optical properties with absorption optical depth Arguments Type Intent Optional Attributes Name integer, intent(in) :: ncol array sizes integer, intent(in) :: nlay array sizes integer, intent(in) :: ngpt array sizes real(kind=wp), intent(inout), dimension(ncol,nlay,ngpt) :: tau1 optical properties to be modified real(kind=wp), intent(inout), dimension(ncol,nlay,ngpt) :: ssa1 optical properties to be modified real(kind=wp), intent(in), dimension(ncol,nlay,ngpt) :: tau2 optical properties to be added to original Contents None","tags":"","loc":"proc/increment_2stream_by_1scalar.html"},{"title":"increment_2stream_by_2stream – RTE kernels","text":"public pure subroutine increment_2stream_by_2stream(ncol, nlay, ngpt, tau1, ssa1, g1, tau2, ssa2, g2) bind(C, name=\"0\") increment two-stream optical properties with a second set Arguments Type Intent Optional Attributes Name integer, intent(in) :: ncol array sizes integer, intent(in) :: nlay array sizes integer, intent(in) :: ngpt array sizes real(kind=wp), intent(inout), dimension(ncol,nlay,ngpt) :: tau1 optical properties to be modified real(kind=wp), intent(inout), dimension(ncol,nlay,ngpt) :: ssa1 optical properties to be modified real(kind=wp), intent(inout), dimension(ncol,nlay,ngpt) :: g1 optical properties to be modified real(kind=wp), intent(in), dimension(ncol,nlay,ngpt) :: tau2 optical properties to be added to original real(kind=wp), intent(in), dimension(ncol,nlay,ngpt) :: ssa2 optical properties to be added to original real(kind=wp), intent(in), dimension(ncol,nlay,ngpt) :: g2 optical properties to be added to original Contents None","tags":"","loc":"proc/increment_2stream_by_2stream.html"},{"title":"increment_2stream_by_nstream – RTE kernels","text":"public pure subroutine increment_2stream_by_nstream(ncol, nlay, ngpt, nmom2, tau1, ssa1, g1, tau2, ssa2, p2) bind(C, name=\"0\") increment two-stream optical properties with n -stream Arguments Type Intent Optional Attributes Name integer, intent(in) :: ncol array sizes integer, intent(in) :: nlay array sizes integer, intent(in) :: ngpt array sizes integer, intent(in) :: nmom2 array sizes real(kind=wp), intent(inout), dimension(ncol,nlay,ngpt) :: tau1 optical properties to be modified real(kind=wp), intent(inout), dimension(ncol,nlay,ngpt) :: ssa1 optical properties to be modified real(kind=wp), intent(inout), dimension(ncol,nlay,ngpt) :: g1 optical properties to be modified real(kind=wp), intent(in), dimension(ncol,nlay,ngpt) :: tau2 optical properties to be added to original real(kind=wp), intent(in), dimension(ncol,nlay,ngpt) :: ssa2 optical properties to be added to original real(kind=wp), intent(in), dimension(nmom2, ncol,nlay,ngpt) :: p2 moments of the phase function to be added Contents None","tags":"","loc":"proc/increment_2stream_by_nstream.html"},{"title":"increment_nstream_by_1scalar – RTE kernels","text":"public pure subroutine increment_nstream_by_1scalar(ncol, nlay, ngpt, tau1, ssa1, tau2) bind(C, name=\"0\") increment n -stream optical properties with absorption optical depth Arguments Type Intent Optional Attributes Name integer, intent(in) :: ncol array sizes integer, intent(in) :: nlay array sizes integer, intent(in) :: ngpt array sizes real(kind=wp), intent(inout), dimension(ncol,nlay,ngpt) :: tau1 optical properties to be modified real(kind=wp), intent(inout), dimension(ncol,nlay,ngpt) :: ssa1 optical properties to be modified real(kind=wp), intent(in), dimension(ncol,nlay,ngpt) :: tau2 optical properties to be added to original Contents None","tags":"","loc":"proc/increment_nstream_by_1scalar.html"},{"title":"increment_nstream_by_2stream – RTE kernels","text":"public pure subroutine increment_nstream_by_2stream(ncol, nlay, ngpt, nmom1, tau1, ssa1, p1, tau2, ssa2, g2) bind(C, name=\"0\") increment n -stream optical properties with two-stream values Arguments Type Intent Optional Attributes Name integer, intent(in) :: ncol array sizes integer, intent(in) :: nlay array sizes integer, intent(in) :: ngpt array sizes integer, intent(in) :: nmom1 array sizes real(kind=wp), intent(inout), dimension(ncol,nlay,ngpt) :: tau1 optical properties to be modified real(kind=wp), intent(inout), dimension(ncol,nlay,ngpt) :: ssa1 optical properties to be modified real(kind=wp), intent(inout), dimension(nmom1, ncol,nlay,ngpt) :: p1 moments of the phase function be modified real(kind=wp), intent(in), dimension(ncol,nlay,ngpt) :: tau2 optical properties to be added to original real(kind=wp), intent(in), dimension(ncol,nlay,ngpt) :: ssa2 optical properties to be added to original real(kind=wp), intent(in), dimension(ncol,nlay,ngpt) :: g2 optical properties to be added to original Contents None","tags":"","loc":"proc/increment_nstream_by_2stream.html"},{"title":"increment_nstream_by_nstream – RTE kernels","text":"public pure subroutine increment_nstream_by_nstream(ncol, nlay, ngpt, nmom1, nmom2, tau1, ssa1, p1, tau2, ssa2, p2) bind(C, name=\"0\") increment one set of n -stream optical properties with another set Arguments Type Intent Optional Attributes Name integer, intent(in) :: ncol array sizes integer, intent(in) :: nlay array sizes integer, intent(in) :: ngpt array sizes integer, intent(in) :: nmom1 array sizes integer, intent(in) :: nmom2 array sizes real(kind=wp), intent(inout), dimension(ncol,nlay,ngpt) :: tau1 optical properties to be modified real(kind=wp), intent(inout), dimension(ncol,nlay,ngpt) :: ssa1 optical properties to be modified real(kind=wp), intent(inout), dimension(nmom1, ncol,nlay,ngpt) :: p1 moments of the phase function be modified real(kind=wp), intent(in), dimension(ncol,nlay,ngpt) :: tau2 optical properties to be added to original real(kind=wp), intent(in), dimension(ncol,nlay,ngpt) :: ssa2 optical properties to be added to original real(kind=wp), intent(in), dimension(nmom2, ncol,nlay,ngpt) :: p2 moments of the phase function to be added Contents None","tags":"","loc":"proc/increment_nstream_by_nstream.html"},{"title":"delta_scale_2str_kernel – RTE kernels","text":"public interface delta_scale_2str_kernel Delta-scale two-stream optical properties Calls interface~~delta_scale_2str_kernel~~CallsGraph interface~delta_scale_2str_kernel delta_scale_2str_kernel proc~delta_scale_2str_f_k delta_scale_2str_f_k interface~delta_scale_2str_kernel->proc~delta_scale_2str_f_k proc~delta_scale_2str_k delta_scale_2str_k interface~delta_scale_2str_kernel->proc~delta_scale_2str_k Help × Graph Key Nodes of different colours represent the following: Graph Key Subroutine Subroutine Function Function Interface Interface Unknown Procedure Type Unknown Procedure Type Program Program This Page's Entity This Page's Entity Solid arrows point from a procedure to one which it calls. Dashed \n arrows point from an interface to procedures which implement that interface.\n This could include the module procedures in a generic interface or the\n implementation in a submodule of an interface in a parent module. Contents Module Procedures delta_scale_2str_f_k delta_scale_2str_k Module Procedures public pure subroutine delta_scale_2str_f_k (ncol, nlay, ngpt, tau, ssa, g, f) bind(C, name=\"0\") Delta-scale two-stream optical properties given user-provided value of (forward scattering) Arguments Type Intent Optional Attributes Name integer, intent(in) :: ncol Array sizes integer, intent(in) :: nlay Array sizes integer, intent(in) :: ngpt Array sizes real(kind=wp), intent(inout), dimension(ncol, nlay, ngpt) :: tau Optical depth, single-scattering albedo, asymmetry parameter real(kind=wp), intent(inout), dimension(ncol, nlay, ngpt) :: ssa Optical depth, single-scattering albedo, asymmetry parameter real(kind=wp), intent(inout), dimension(ncol, nlay, ngpt) :: g Optical depth, single-scattering albedo, asymmetry parameter real(kind=wp), intent(in), dimension(ncol, nlay, ngpt) :: f User-provided forward-scattering fraction public pure subroutine delta_scale_2str_k (ncol, nlay, ngpt, tau, ssa, g) bind(C, name=\"0\") Delta-scale assuming forward-scatternig fraction is the square of the asymmetry parameter\n i.e. Arguments Type Intent Optional Attributes Name integer, intent(in) :: ncol Array sizes integer, intent(in) :: nlay Array sizes integer, intent(in) :: ngpt Array sizes real(kind=wp), intent(inout), dimension(ncol, nlay, ngpt) :: tau Optical depth, single-scattering albedo, asymmetry parameter real(kind=wp), intent(inout), dimension(ncol, nlay, ngpt) :: ssa Optical depth, single-scattering albedo, asymmetry parameter real(kind=wp), intent(inout), dimension(ncol, nlay, ngpt) :: g Optical depth, single-scattering albedo, asymmetry parameter","tags":"","loc":"interface/delta_scale_2str_kernel.html"},{"title":"extract_subset – RTE kernels","text":"public interface extract_subset Subsetting, meaning extracting some portion of the 3D domain Calls interface~~extract_subset~~CallsGraph interface~extract_subset extract_subset proc~extract_subset_dim1_3d extract_subset_dim1_3d interface~extract_subset->proc~extract_subset_dim1_3d proc~extract_subset_dim2_4d extract_subset_dim2_4d interface~extract_subset->proc~extract_subset_dim2_4d proc~extract_subset_absorption_tau extract_subset_absorption_tau interface~extract_subset->proc~extract_subset_absorption_tau Help × Graph Key Nodes of different colours represent the following: Graph Key Subroutine Subroutine Function Function Interface Interface Unknown Procedure Type Unknown Procedure Type Program Program This Page's Entity This Page's Entity Solid arrows point from a procedure to one which it calls. Dashed \n arrows point from an interface to procedures which implement that interface.\n This could include the module procedures in a generic interface or the\n implementation in a submodule of an interface in a parent module. Contents Module Procedures extract_subset_dim1_3d extract_subset_dim2_4d extract_subset_absorption_tau Module Procedures public pure subroutine extract_subset_dim1_3d (ncol, nlay, ngpt, array_in, colS, colE, array_out) bind(C, name=\"0\") Extract a subset from the first dimension (normally columns) of a 3D field.\n Applicable to most variables e.g. tau, ssa, g Arguments Type Intent Optional Attributes Name integer, intent(in) :: ncol Array sizes integer, intent(in) :: nlay Array sizes integer, intent(in) :: ngpt Array sizes real(kind=wp), intent(in), dimension(ncol,nlay,ngpt) :: array_in Array to subset integer, intent(in) :: colS Starting and ending index integer, intent(in) :: colE Starting and ending index real(kind=wp), intent(out), dimension(colE-colS+1, nlay,ngpt) :: array_out subset of the input array public pure subroutine extract_subset_dim2_4d (nmom, ncol, nlay, ngpt, array_in, colS, colE, array_out) bind(C, name=\"0\") Extract a subset from the second dimension (normally columns) of a 4D field.\n Applicable to phase function moments, where the first dimension is the moment Arguments Type Intent Optional Attributes Name integer, intent(in) :: nmom Array sizes integer, intent(in) :: ncol Array sizes integer, intent(in) :: nlay Array sizes integer, intent(in) :: ngpt Array sizes real(kind=wp), intent(in), dimension(nmom,ncol,nlay,ngpt) :: array_in Array to subset integer, intent(in) :: colS Starting and ending index integer, intent(in) :: colE Starting and ending index real(kind=wp), intent(out), dimension(nmom,colE-colS+1, nlay,ngpt) :: array_out subset of the input array public pure subroutine extract_subset_absorption_tau (ncol, nlay, ngpt, tau_in, ssa_in, colS, colE, tau_out) bind(C, name=\"0\") Extract the absorption optical thickness Arguments Type Intent Optional Attributes Name integer, intent(in) :: ncol Array sizes integer, intent(in) :: nlay Array sizes integer, intent(in) :: ngpt Array sizes real(kind=wp), intent(in), dimension(ncol,nlay,ngpt) :: tau_in Optical thickness, single scattering albedo real(kind=wp), intent(in), dimension(ncol,nlay,ngpt) :: ssa_in Optical thickness, single scattering albedo integer, intent(in) :: colS Starting and ending index integer, intent(in) :: colE Starting and ending index real(kind=wp), intent(out), dimension(colE-colS+1, nlay,ngpt) :: tau_out absorption optical thickness subset","tags":"","loc":"interface/extract_subset.html"},{"title":"sum_broadband – RTE kernels","text":"public subroutine sum_broadband(ncol, nlev, ngpt, spectral_flux, broadband_flux) bind(C, name=\"0\") Spectral reduction over all points Arguments Type Intent Optional Attributes Name integer, intent(in) :: ncol Array sizes integer, intent(in) :: nlev Array sizes integer, intent(in) :: ngpt Array sizes real(kind=wp), intent(in), dimension(ncol, nlev, ngpt) :: spectral_flux Spectrally-resolved flux real(kind=wp), intent(out), dimension(ncol, nlev) :: broadband_flux Sum of spectrally-resolved flux over ngpt Contents None","tags":"","loc":"proc/sum_broadband.html"},{"title":"net_broadband – RTE kernels","text":"public interface net_broadband Interface for computing net flux Contents Module Procedures net_broadband_full net_broadband_precalc Module Procedures private subroutine net_broadband_full(ncol, nlev, ngpt, spectral_flux_dn, spectral_flux_up, broadband_flux_net) bind(C, name=\"0\") Spectral reduction over all points for net flux Arguments Type Intent Optional Attributes Name integer, intent(in) :: ncol Array sizes integer, intent(in) :: nlev Array sizes integer, intent(in) :: ngpt Array sizes real(kind=wp), intent(in), dimension(ncol, nlev, ngpt) :: spectral_flux_dn Spectrally-resolved flux up and down real(kind=wp), intent(in), dimension(ncol, nlev, ngpt) :: spectral_flux_up Spectrally-resolved flux up and down real(kind=wp), intent(out), dimension(ncol, nlev) :: broadband_flux_net Net (down minus up) summed over ngpt private subroutine net_broadband_precalc(ncol, nlev, flux_dn, flux_up, broadband_flux_net) bind(C, name=\"0\") Net flux when bradband flux up and down are already available Arguments Type Intent Optional Attributes Name integer, intent(in) :: ncol Array sizes integer, intent(in) :: nlev Array sizes real(kind=wp), intent(in), dimension(ncol, nlev) :: flux_dn Broadband downward and upward fluxes real(kind=wp), intent(in), dimension(ncol, nlev) :: flux_up Broadband downward and upward fluxes real(kind=wp), intent(out), dimension(ncol, nlev) :: broadband_flux_net Net (down minus up)","tags":"","loc":"interface/net_broadband.html"},{"title":"lw_solver_2stream – RTE kernels","text":"public subroutine lw_solver_2stream(ncol, nlay, ngpt, top_at_1, tau, ssa, g, lay_source, lev_source, sfc_emis, sfc_src, inc_flux, flux_up, flux_dn) bind(C, name=\"0\") Longwave two-stream calculation:\n - combine RRTMGP-specific sources at levels\n - compute layer reflectance, transmittance\n - compute total source function at levels using linear-in-tau\n - transport Arguments Type Intent Optional Attributes Name integer, intent(in) :: ncol Number of columns, layers, g-points integer, intent(in) :: nlay Number of columns, layers, g-points integer, intent(in) :: ngpt Number of columns, layers, g-points logical(kind=wl), intent(in) :: top_at_1 ilay = 1 is the top of the atmosphere? real(kind=wp), intent(in), dimension(ncol,nlay, ngpt) :: tau Optical thickness, single-scattering albedo, asymmetry parameter [] real(kind=wp), intent(in), dimension(ncol,nlay, ngpt) :: ssa Optical thickness, single-scattering albedo, asymmetry parameter [] real(kind=wp), intent(in), dimension(ncol,nlay, ngpt) :: g Optical thickness, single-scattering albedo, asymmetry parameter [] real(kind=wp), intent(in), dimension(ncol,nlay, ngpt) :: lay_source Planck source at layer average temperature [W/m2] real(kind=wp), intent(in), dimension(ncol,nlay+1,ngpt) :: lev_source Planck source at layer edge temperature [W/m2] real(kind=wp), intent(in), dimension(ncol, ngpt) :: sfc_emis Surface emissivity [] real(kind=wp), intent(in), dimension(ncol, ngpt) :: sfc_src Surface source function [W/m2] real(kind=wp), intent(in), dimension(ncol, ngpt) :: inc_flux Incident diffuse flux, probably 0 [W/m2] real(kind=wp), intent(out), dimension(ncol,nlay+1,ngpt) :: flux_up Fluxes [W/m2] real(kind=wp), intent(out), dimension(ncol,nlay+1,ngpt) :: flux_dn Fluxes [W/m2] Contents None","tags":"","loc":"proc/lw_solver_2stream.html"},{"title":"lw_solver_noscat – RTE kernels","text":"public subroutine lw_solver_noscat(ncol, nlay, ngpt, top_at_1, nmus, Ds, weights, tau, lay_source, lev_source, sfc_emis, sfc_src, inc_flux, flux_up, flux_dn, do_broadband, broadband_up, broadband_dn, do_Jacobians, sfc_srcJac, flux_upJac, do_rescaling, ssa, g) bind(C, name=\"0\") LW transport, no scattering, multi-angle quadrature\n Users provide a set of weights and quadrature angles\n Routine sums over single-angle solutions for each sets of angles/weights Arguments Type Intent Optional Attributes Name integer, intent(in) :: ncol Number of columns, layers, g-points integer, intent(in) :: nlay Number of columns, layers, g-points integer, intent(in) :: ngpt Number of columns, layers, g-points logical(kind=wl), intent(in) :: top_at_1 ilay = 1 is the top of the atmosphere? integer, intent(in) :: nmus number of quadrature angles real(kind=wp), intent(in), dimension (ncol, ngpt, nmus) :: Ds quadrature secants real(kind=wp), intent(in), dimension(nmus) :: weights quadrature weights real(kind=wp), intent(in), dimension(ncol,nlay, ngpt) :: tau Absorption optical thickness [] real(kind=wp), intent(in), dimension(ncol,nlay, ngpt) :: lay_source Planck source at layer average temperature [W/m2] real(kind=wp), intent(in), dimension(ncol,nlay+1,ngpt) :: lev_source Planck source at layer edge for radiation[W/m2] real(kind=wp), intent(in), dimension(ncol, ngpt) :: sfc_emis Surface emissivity [] real(kind=wp), intent(in), dimension(ncol, ngpt) :: sfc_src Surface source function [W/m2] real(kind=wp), intent(in), dimension(ncol, ngpt) :: inc_flux Incident diffuse flux, probably 0 [W/m2] real(kind=wp), intent(out), dimension(ncol,nlay+1,ngpt), target :: flux_up Fluxes [W/m2] real(kind=wp), intent(out), dimension(ncol,nlay+1,ngpt), target :: flux_dn Fluxes [W/m2] logical(kind=wl), intent(in) :: do_broadband real(kind=wp), intent(out), dimension(ncol,nlay+1 ), target :: broadband_up Spectrally-integrated fluxes [W/m2] real(kind=wp), intent(out), dimension(ncol,nlay+1 ), target :: broadband_dn Spectrally-integrated fluxes [W/m2] logical(kind=wl), intent(in) :: do_Jacobians compute Jacobian with respect to surface temeprature? real(kind=wp), intent(in), dimension(ncol ,ngpt) :: sfc_srcJac surface temperature Jacobian of surface source function [W/m2/K] real(kind=wp), intent(out), dimension(ncol,nlay+1 ), target :: flux_upJac surface temperature Jacobian of Radiances [W/m2-str / K] logical(kind=wl), intent(in) :: do_rescaling Approximate treatment of scattering (10.1175/JAS-D-18-0014.1) real(kind=wp), intent(in), dimension(ncol,nlay ,ngpt) :: ssa single-scattering albedo, asymmetry parameter real(kind=wp), intent(in), dimension(ncol,nlay ,ngpt) :: g single-scattering albedo, asymmetry parameter Contents None","tags":"","loc":"proc/lw_solver_noscat.html"},{"title":"sw_solver_2stream – RTE kernels","text":"public subroutine sw_solver_2stream(ncol, nlay, ngpt, top_at_1, tau, ssa, g, mu0, sfc_alb_dir, sfc_alb_dif, inc_flux_dir, flux_up, flux_dn, flux_dir, has_dif_bc, inc_flux_dif, do_broadband, broadband_up, broadband_dn, broadband_dir) bind(C, name=\"0\") Shortwave two-stream calculation:\n compute layer reflectance, transmittance\n compute solar source function for diffuse radiation\n transport Arguments Type Intent Optional Attributes Name integer, intent(in) :: ncol Number of columns, layers, g-points integer, intent(in) :: nlay Number of columns, layers, g-points integer, intent(in) :: ngpt Number of columns, layers, g-points logical(kind=wl), intent(in) :: top_at_1 ilay = 1 is the top of the atmosphere? real(kind=wp), intent(in), dimension(ncol,nlay, ngpt) :: tau Optical thickness, single-scattering albedo, asymmetry parameter [] real(kind=wp), intent(in), dimension(ncol,nlay, ngpt) :: ssa Optical thickness, single-scattering albedo, asymmetry parameter [] real(kind=wp), intent(in), dimension(ncol,nlay, ngpt) :: g Optical thickness, single-scattering albedo, asymmetry parameter [] real(kind=wp), intent(in), dimension(ncol,nlay ) :: mu0 cosine of solar zenith angle real(kind=wp), intent(in), dimension(ncol, ngpt) :: sfc_alb_dir Spectral surface albedo for direct and diffuse radiation real(kind=wp), intent(in), dimension(ncol, ngpt) :: sfc_alb_dif Spectral surface albedo for direct and diffuse radiation real(kind=wp), intent(in), dimension(ncol, ngpt) :: inc_flux_dir Direct beam incident flux real(kind=wp), intent(out), dimension(ncol,nlay+1,ngpt), target :: flux_up Fluxes [W/m2] real(kind=wp), intent(out), dimension(ncol,nlay+1,ngpt), target :: flux_dn Fluxes [W/m2] real(kind=wp), intent(out), dimension(ncol,nlay+1,ngpt), target :: flux_dir Fluxes [W/m2] logical(kind=wl), intent(in) :: has_dif_bc Is a boundary condition for diffuse flux supplied? real(kind=wp), intent(in), dimension(ncol, ngpt) :: inc_flux_dif Boundary condition for diffuse flux [W/m2] logical(kind=wl), intent(in) :: do_broadband Provide broadband-integrated, not spectrally-resolved, fluxes? real(kind=wp), intent(out), dimension(ncol,nlay+1 ) :: broadband_up Broadband integrated fluxes real(kind=wp), intent(out), dimension(ncol,nlay+1 ) :: broadband_dn Broadband integrated fluxes real(kind=wp), intent(out), dimension(ncol,nlay+1 ) :: broadband_dir Broadband integrated fluxes Calls proc~~sw_solver_2stream~~CallsGraph proc~sw_solver_2stream sw_solver_2stream interface~zero_array zero_array proc~sw_solver_2stream->interface~zero_array proc~zero_array_1d zero_array_1D interface~zero_array->proc~zero_array_1d proc~zero_array_2d zero_array_2D interface~zero_array->proc~zero_array_2d proc~zero_array_4d zero_array_4D interface~zero_array->proc~zero_array_4d proc~zero_array_3d zero_array_3D interface~zero_array->proc~zero_array_3d Help × Graph Key Nodes of different colours represent the following: Graph Key Subroutine Subroutine Function Function Interface Interface Unknown Procedure Type Unknown Procedure Type Program Program This Page's Entity This Page's Entity Solid arrows point from a procedure to one which it calls. Dashed \n arrows point from an interface to procedures which implement that interface.\n This could include the module procedures in a generic interface or the\n implementation in a submodule of an interface in a parent module. Contents None","tags":"","loc":"proc/sw_solver_2stream.html"},{"title":"sw_solver_noscat – RTE kernels","text":"public pure subroutine sw_solver_noscat(ncol, nlay, ngpt, top_at_1, tau, mu0, inc_flux_dir, flux_dir) bind(C, name=\"0\") Arguments Type Intent Optional Attributes Name integer, intent(in) :: ncol Number of columns, layers, g-points integer, intent(in) :: nlay Number of columns, layers, g-points integer, intent(in) :: ngpt Number of columns, layers, g-points logical(kind=wl), intent(in) :: top_at_1 ilay = 1 is the top of the atmosphere? real(kind=wp), intent(in), dimension(ncol,nlay, ngpt) :: tau Absorption optical thickness [] real(kind=wp), intent(in), dimension(ncol,nlay ) :: mu0 cosine of solar zenith angle real(kind=wp), intent(in), dimension(ncol, ngpt) :: inc_flux_dir Direct beam incident flux [W/m2] real(kind=wp), intent(out), dimension(ncol,nlay+1,ngpt) :: flux_dir Direct-beam flux, spectral [W/m2] Contents None","tags":"","loc":"proc/sw_solver_noscat.html"},{"title":"zero_array_1D – RTE kernels","text":"public subroutine zero_array_1D(ni, array) bind(C, name=\"0\") Arguments Type Intent Optional Attributes Name integer, intent(in) :: ni real(kind=wp), intent(out), dimension(ni) :: array Called by proc~~zero_array_1d~~CalledByGraph proc~zero_array_1d zero_array_1D interface~zero_array zero_array interface~zero_array->proc~zero_array_1d proc~sw_solver_2stream sw_solver_2stream proc~sw_solver_2stream->interface~zero_array Help × Graph Key Nodes of different colours represent the following: Graph Key Subroutine Subroutine Function Function Interface Interface Unknown Procedure Type Unknown Procedure Type Program Program This Page's Entity This Page's Entity Solid arrows point from a procedure to one which it calls. Dashed \n arrows point from an interface to procedures which implement that interface.\n This could include the module procedures in a generic interface or the\n implementation in a submodule of an interface in a parent module. Contents None","tags":"","loc":"proc/zero_array_1d.html"},{"title":"zero_array_2D – RTE kernels","text":"public subroutine zero_array_2D(ni, nj, array) bind(C, name=\"0\") Arguments Type Intent Optional Attributes Name integer, intent(in) :: ni integer, intent(in) :: nj real(kind=wp), intent(out), dimension(ni, nj) :: array Called by proc~~zero_array_2d~~CalledByGraph proc~zero_array_2d zero_array_2D interface~zero_array zero_array interface~zero_array->proc~zero_array_2d proc~sw_solver_2stream sw_solver_2stream proc~sw_solver_2stream->interface~zero_array Help × Graph Key Nodes of different colours represent the following: Graph Key Subroutine Subroutine Function Function Interface Interface Unknown Procedure Type Unknown Procedure Type Program Program This Page's Entity This Page's Entity Solid arrows point from a procedure to one which it calls. Dashed \n arrows point from an interface to procedures which implement that interface.\n This could include the module procedures in a generic interface or the\n implementation in a submodule of an interface in a parent module. Contents None","tags":"","loc":"proc/zero_array_2d.html"},{"title":"zero_array_3D – RTE kernels","text":"public subroutine zero_array_3D(ni, nj, nk, array) bind(C, name=\"0\") Arguments Type Intent Optional Attributes Name integer, intent(in) :: ni integer, intent(in) :: nj integer, intent(in) :: nk real(kind=wp), intent(out), dimension(ni, nj, nk) :: array Called by proc~~zero_array_3d~~CalledByGraph proc~zero_array_3d zero_array_3D interface~zero_array zero_array interface~zero_array->proc~zero_array_3d proc~sw_solver_2stream sw_solver_2stream proc~sw_solver_2stream->interface~zero_array Help × Graph Key Nodes of different colours represent the following: Graph Key Subroutine Subroutine Function Function Interface Interface Unknown Procedure Type Unknown Procedure Type Program Program This Page's Entity This Page's Entity Solid arrows point from a procedure to one which it calls. Dashed \n arrows point from an interface to procedures which implement that interface.\n This could include the module procedures in a generic interface or the\n implementation in a submodule of an interface in a parent module. Contents None","tags":"","loc":"proc/zero_array_3d.html"},{"title":"zero_array_4D – RTE kernels","text":"public subroutine zero_array_4D(ni, nj, nk, nl, array) bind(C, name=\"0\") Arguments Type Intent Optional Attributes Name integer, intent(in) :: ni integer, intent(in) :: nj integer, intent(in) :: nk integer, intent(in) :: nl real(kind=wp), intent(out), dimension(ni, nj, nk, nl) :: array Called by proc~~zero_array_4d~~CalledByGraph proc~zero_array_4d zero_array_4D interface~zero_array zero_array interface~zero_array->proc~zero_array_4d proc~sw_solver_2stream sw_solver_2stream proc~sw_solver_2stream->interface~zero_array Help × Graph Key Nodes of different colours represent the following: Graph Key Subroutine Subroutine Function Function Interface Interface Unknown Procedure Type Unknown Procedure Type Program Program This Page's Entity This Page's Entity Solid arrows point from a procedure to one which it calls. Dashed \n arrows point from an interface to procedures which implement that interface.\n This could include the module procedures in a generic interface or the\n implementation in a submodule of an interface in a parent module. Contents None","tags":"","loc":"proc/zero_array_4d.html"},{"title":"zero_array – RTE kernels","text":"public interface zero_array Efficiently set arrays to zero Calls interface~~zero_array~~CallsGraph interface~zero_array zero_array proc~zero_array_1d zero_array_1D interface~zero_array->proc~zero_array_1d proc~zero_array_2d zero_array_2D interface~zero_array->proc~zero_array_2d proc~zero_array_4d zero_array_4D interface~zero_array->proc~zero_array_4d proc~zero_array_3d zero_array_3D interface~zero_array->proc~zero_array_3d Help × Graph Key Nodes of different colours represent the following: Graph Key Subroutine Subroutine Function Function Interface Interface Unknown Procedure Type Unknown Procedure Type Program Program This Page's Entity This Page's Entity Solid arrows point from a procedure to one which it calls. Dashed \n arrows point from an interface to procedures which implement that interface.\n This could include the module procedures in a generic interface or the\n implementation in a submodule of an interface in a parent module. Called by interface~~zero_array~~CalledByGraph interface~zero_array zero_array proc~sw_solver_2stream sw_solver_2stream proc~sw_solver_2stream->interface~zero_array Help × Graph Key Nodes of different colours represent the following: Graph Key Subroutine Subroutine Function Function Interface Interface Unknown Procedure Type Unknown Procedure Type Program Program This Page's Entity This Page's Entity Solid arrows point from a procedure to one which it calls. Dashed \n arrows point from an interface to procedures which implement that interface.\n This could include the module procedures in a generic interface or the\n implementation in a submodule of an interface in a parent module. Contents Module Procedures zero_array_1D zero_array_2D zero_array_3D zero_array_4D Module Procedures public subroutine zero_array_1D (ni, array) bind(C, name=\"0\") Arguments Type Intent Optional Attributes Name integer, intent(in) :: ni real(kind=wp), intent(out), dimension(ni) :: array public subroutine zero_array_2D (ni, nj, array) bind(C, name=\"0\") Arguments Type Intent Optional Attributes Name integer, intent(in) :: ni integer, intent(in) :: nj real(kind=wp), intent(out), dimension(ni, nj) :: array public subroutine zero_array_3D (ni, nj, nk, array) bind(C, name=\"0\") Arguments Type Intent Optional Attributes Name integer, intent(in) :: ni integer, intent(in) :: nj integer, intent(in) :: nk real(kind=wp), intent(out), dimension(ni, nj, nk) :: array public subroutine zero_array_4D (ni, nj, nk, nl, array) bind(C, name=\"0\") Arguments Type Intent Optional Attributes Name integer, intent(in) :: ni integer, intent(in) :: nj integer, intent(in) :: nk integer, intent(in) :: nl real(kind=wp), intent(out), dimension(ni, nj, nk, nl) :: array","tags":"","loc":"interface/zero_array.html"},{"title":"delta_scale_2str_kernel – RTE kernels","text":"public interface delta_scale_2str_kernel Contents Subroutines delta_scale_2str_f_k delta_scale_2str_k Subroutines public pure subroutine delta_scale_2str_f_k(ncol, nlay, ngpt, tau, ssa, g, f) bind(C, name=\"0\") Delta-scale two-stream optical properties given user-provided value of (forward scattering) Arguments Type Intent Optional Attributes Name integer, intent(in) :: ncol Array sizes integer, intent(in) :: nlay Array sizes integer, intent(in) :: ngpt Array sizes real(kind=wp), intent(inout), dimension(ncol, nlay, ngpt) :: tau Optical depth, single-scattering albedo, asymmetry parameter real(kind=wp), intent(inout), dimension(ncol, nlay, ngpt) :: ssa Optical depth, single-scattering albedo, asymmetry parameter real(kind=wp), intent(inout), dimension(ncol, nlay, ngpt) :: g Optical depth, single-scattering albedo, asymmetry parameter real(kind=wp), intent(in), dimension(ncol, nlay, ngpt) :: f User-provided forward-scattering fraction public pure subroutine delta_scale_2str_k(ncol, nlay, ngpt, tau, ssa, g) bind(C, name=\"0\") Delta-scale assuming forward-scatternig fraction is the square of the asymmetry parameter\n i.e. Arguments Type Intent Optional Attributes Name integer, intent(in) :: ncol Array sizes integer, intent(in) :: nlay Array sizes integer, intent(in) :: ngpt Array sizes real(kind=wp), intent(inout), dimension(ncol, nlay, ngpt) :: tau Optical depth, single-scattering albedo, asymmetry parameter real(kind=wp), intent(inout), dimension(ncol, nlay, ngpt) :: ssa Optical depth, single-scattering albedo, asymmetry parameter real(kind=wp), intent(inout), dimension(ncol, nlay, ngpt) :: g Optical depth, single-scattering albedo, asymmetry parameter","tags":"","loc":"interface/delta_scale_2str_kernel~2.html"},{"title":"extract_subset – RTE kernels","text":"public interface extract_subset Extract a subset from the first dimension (normally columns) of a 3D field.\n Applicable to most variables e.g. tau, ssa, g Contents Subroutines extract_subset_absorption_tau extract_subset_dim1_3d extract_subset_dim2_4d Subroutines public pure subroutine extract_subset_absorption_tau(ncol, nlay, ngpt, tau_in, ssa_in, colS, colE, tau_out) bind(C, name=\"0\") Extract the absorption optical thickness Arguments Type Intent Optional Attributes Name integer, intent(in) :: ncol Array sizes integer, intent(in) :: nlay Array sizes integer, intent(in) :: ngpt Array sizes real(kind=wp), intent(in), dimension(ncol,nlay,ngpt) :: tau_in Optical thickness, single scattering albedo real(kind=wp), intent(in), dimension(ncol,nlay,ngpt) :: ssa_in Optical thickness, single scattering albedo integer, intent(in) :: colS Starting and ending index integer, intent(in) :: colE Starting and ending index real(kind=wp), intent(out), dimension(colE-colS+1, nlay,ngpt) :: tau_out absorption optical thickness subset public pure subroutine extract_subset_dim1_3d(ncol, nlay, ngpt, array_in, colS, colE, array_out) bind(C, name=\"0\") Arguments Type Intent Optional Attributes Name integer, intent(in) :: ncol Array sizes integer, intent(in) :: nlay Array sizes integer, intent(in) :: ngpt Array sizes real(kind=wp), intent(in), dimension(ncol,nlay,ngpt) :: array_in Array to subset integer, intent(in) :: colS Starting and ending index integer, intent(in) :: colE Starting and ending index real(kind=wp), intent(out), dimension(colE-colS+1, nlay,ngpt) :: array_out subset of the input array public pure subroutine extract_subset_dim2_4d(nmom, ncol, nlay, ngpt, array_in, colS, colE, array_out) bind(C, name=\"0\") Extract a subset from the second dimension (normally columns) of a 4D field.\n Applicable to phase function moments, where the first dimension is the moment Arguments Type Intent Optional Attributes Name integer, intent(in) :: nmom Array sizes integer, intent(in) :: ncol Array sizes integer, intent(in) :: nlay Array sizes integer, intent(in) :: ngpt Array sizes real(kind=wp), intent(in), dimension(nmom,ncol,nlay,ngpt) :: array_in Array to subset integer, intent(in) :: colS Starting and ending index integer, intent(in) :: colE Starting and ending index real(kind=wp), intent(out), dimension(nmom,colE-colS+1, nlay,ngpt) :: array_out subset of the input array","tags":"","loc":"interface/extract_subset~2.html"},{"title":"inc_1scalar_by_1scalar_bybnd – RTE kernels","text":"interface increase one absorption optical depth defined on g-points by a second value defined on bands public pure subroutine inc_1scalar_by_1scalar_bybnd(ncol, nlay, ngpt, tau1, tau2, nbnd, gpt_lims) bind(C, name=\"0\") Arguments Type Intent Optional Attributes Name integer, intent(in) :: ncol array sizes integer, intent(in) :: nlay array sizes integer, intent(in) :: ngpt array sizes real(kind=wp), intent(inout), dimension(ncol,nlay,ngpt) :: tau1 optical properties to be modified (defined on g-points) real(kind=wp), intent(in), dimension(ncol,nlay,nbnd) :: tau2 optical properties to be added to original (defined on bands) integer, intent(in) :: nbnd array sizes integer, intent(in), dimension(2,nbnd) :: gpt_lims Starting and ending gpoint for each band","tags":"","loc":"interface/inc_1scalar_by_1scalar_bybnd.html"},{"title":"inc_1scalar_by_2stream_bybnd – RTE kernels","text":"interface increase absorption optical depth defined on g-points with extinction optical depth (2-stream form) defined on bands public pure subroutine inc_1scalar_by_2stream_bybnd(ncol, nlay, ngpt, tau1, tau2, ssa2, nbnd, gpt_lims) bind(C, name=\"0\") Arguments Type Intent Optional Attributes Name integer, intent(in) :: ncol array sizes integer, intent(in) :: nlay array sizes integer, intent(in) :: ngpt array sizes real(kind=wp), intent(inout), dimension(ncol,nlay,ngpt) :: tau1 optical properties to be modified (defined on g-points) real(kind=wp), intent(in), dimension(ncol,nlay,nbnd) :: tau2 optical properties to be added to original (defined on bands) real(kind=wp), intent(in), dimension(ncol,nlay,nbnd) :: ssa2 optical properties to be added to original (defined on bands) integer, intent(in) :: nbnd array sizes integer, intent(in), dimension(2,nbnd) :: gpt_lims Starting and ending gpoint for each band","tags":"","loc":"interface/inc_1scalar_by_2stream_bybnd.html"},{"title":"inc_1scalar_by_nstream_bybnd – RTE kernels","text":"interface increase absorption optical depth defined on g-points with extinction optical depth (n-stream form) defined on bands public pure subroutine inc_1scalar_by_nstream_bybnd(ncol, nlay, ngpt, tau1, tau2, ssa2, nbnd, gpt_lims) bind(C, name=\"0\") Arguments Type Intent Optional Attributes Name integer, intent(in) :: ncol array sizes integer, intent(in) :: nlay array sizes integer, intent(in) :: ngpt array sizes real(kind=wp), intent(inout), dimension(ncol,nlay,ngpt) :: tau1 optical properties to be modified (defined on g-points) real(kind=wp), intent(in), dimension(ncol,nlay,nbnd) :: tau2 optical properties to be added to original (defined on bands) real(kind=wp), intent(in), dimension(ncol,nlay,nbnd) :: ssa2 optical properties to be added to original (defined on bands) integer, intent(in) :: nbnd array sizes integer, intent(in), dimension(2,nbnd) :: gpt_lims Starting and ending gpoint for each band","tags":"","loc":"interface/inc_1scalar_by_nstream_bybnd.html"},{"title":"inc_2stream_by_1scalar_bybnd – RTE kernels","text":"interface increment two-stream optical properties defined on g-points with absorption optical depth defined on bands public pure subroutine inc_2stream_by_1scalar_bybnd(ncol, nlay, ngpt, tau1, ssa1, tau2, nbnd, gpt_lims) bind(C, name=\"0\") Arguments Type Intent Optional Attributes Name integer, intent(in) :: ncol array sizes integer, intent(in) :: nlay array sizes integer, intent(in) :: ngpt array sizes real(kind=wp), intent(inout), dimension(ncol,nlay,ngpt) :: tau1 optical properties to be modified (defined on g-points) real(kind=wp), intent(inout), dimension(ncol,nlay,ngpt) :: ssa1 optical properties to be modified (defined on g-points) real(kind=wp), intent(in), dimension(ncol,nlay,nbnd) :: tau2 optical properties to be added to original (defined on bands) integer, intent(in) :: nbnd array sizes integer, intent(in), dimension(2,nbnd) :: gpt_lims Starting and ending gpoint for each band","tags":"","loc":"interface/inc_2stream_by_1scalar_bybnd.html"},{"title":"inc_2stream_by_2stream_bybnd – RTE kernels","text":"interface increment 2-stream optical properties defined on g-points with another set defined on bands public pure subroutine inc_2stream_by_2stream_bybnd(ncol, nlay, ngpt, tau1, ssa1, g1, tau2, ssa2, g2, nbnd, gpt_lims) bind(C, name=\"0\") Arguments Type Intent Optional Attributes Name integer, intent(in) :: ncol array sizes integer, intent(in) :: nlay array sizes integer, intent(in) :: ngpt array sizes real(kind=wp), intent(inout), dimension(ncol,nlay,ngpt) :: tau1 optical properties to be modified (defined on g-points) real(kind=wp), intent(inout), dimension(ncol,nlay,ngpt) :: ssa1 optical properties to be modified (defined on g-points) real(kind=wp), intent(inout), dimension(ncol,nlay,ngpt) :: g1 optical properties to be modified (defined on g-points) real(kind=wp), intent(in), dimension(ncol,nlay,nbnd) :: tau2 optical properties to be added to original (defined on bands) real(kind=wp), intent(in), dimension(ncol,nlay,nbnd) :: ssa2 optical properties to be added to original (defined on bands) real(kind=wp), intent(in), dimension(ncol,nlay,nbnd) :: g2 optical properties to be added to original (defined on bands) integer, intent(in) :: nbnd array sizes integer, intent(in), dimension(2,nbnd) :: gpt_lims Starting and ending gpoint for each band","tags":"","loc":"interface/inc_2stream_by_2stream_bybnd.html"},{"title":"inc_2stream_by_nstream_bybnd – RTE kernels","text":"interface increment 2-stream optical properties defined on g-points with n -stream properties set defined on bands public pure subroutine inc_2stream_by_nstream_bybnd(ncol, nlay, ngpt, nmom2, tau1, ssa1, g1, tau2, ssa2, p2, nbnd, gpt_lims) bind(C, name=\"0\") Arguments Type Intent Optional Attributes Name integer, intent(in) :: ncol array sizes integer, intent(in) :: nlay array sizes integer, intent(in) :: ngpt array sizes integer, intent(in) :: nmom2 array sizes real(kind=wp), intent(inout), dimension(ncol,nlay,ngpt) :: tau1 optical properties to be modified (defined on g-points) real(kind=wp), intent(inout), dimension(ncol,nlay,ngpt) :: ssa1 optical properties to be modified (defined on g-points) real(kind=wp), intent(inout), dimension(ncol,nlay,ngpt) :: g1 optical properties to be modified (defined on g-points) real(kind=wp), intent(in), dimension(ncol,nlay,nbnd) :: tau2 optical properties to be added to original (defined on bands) real(kind=wp), intent(in), dimension(ncol,nlay,nbnd) :: ssa2 optical properties to be added to original (defined on bands) real(kind=wp), intent(in), dimension(nmom2, ncol,nlay,nbnd) :: p2 moments of the phase function to be added integer, intent(in) :: nbnd array sizes integer, intent(in), dimension(2,nbnd) :: gpt_lims Starting and ending gpoint for each band","tags":"","loc":"interface/inc_2stream_by_nstream_bybnd.html"},{"title":"inc_nstream_by_1scalar_bybnd – RTE kernels","text":"interface increment n -stream optical properties defined on g-points with absorption optical depth defined on bands public pure subroutine inc_nstream_by_1scalar_bybnd(ncol, nlay, ngpt, tau1, ssa1, tau2, nbnd, gpt_lims) bind(C, name=\"0\") Arguments Type Intent Optional Attributes Name integer, intent(in) :: ncol array sizes integer, intent(in) :: nlay array sizes integer, intent(in) :: ngpt array sizes real(kind=wp), intent(inout), dimension(ncol,nlay,ngpt) :: tau1 optical properties to be modified (defined on g-points) real(kind=wp), intent(inout), dimension(ncol,nlay,ngpt) :: ssa1 optical properties to be modified (defined on g-points) real(kind=wp), intent(in), dimension(ncol,nlay,nbnd) :: tau2 optical properties to be added to original (defined on bands) integer, intent(in) :: nbnd array sizes integer, intent(in), dimension(2,nbnd) :: gpt_lims Starting and ending gpoint for each band","tags":"","loc":"interface/inc_nstream_by_1scalar_bybnd.html"},{"title":"inc_nstream_by_2stream_bybnd – RTE kernels","text":"interface increment n-stream optical properties defined on g-points with 2-stream properties set defined on bands public pure subroutine inc_nstream_by_2stream_bybnd(ncol, nlay, ngpt, nmom1, tau1, ssa1, p1, tau2, ssa2, g2, nbnd, gpt_lims) bind(C, name=\"0\") Arguments Type Intent Optional Attributes Name integer, intent(in) :: ncol array sizes integer, intent(in) :: nlay array sizes integer, intent(in) :: ngpt array sizes integer, intent(in) :: nmom1 array sizes real(kind=wp), intent(inout), dimension(ncol,nlay,ngpt) :: tau1 optical properties to be modified (defined on g-points) real(kind=wp), intent(inout), dimension(ncol,nlay,ngpt) :: ssa1 optical properties to be modified (defined on g-points) real(kind=wp), intent(inout), dimension(nmom1, ncol,nlay,ngpt) :: p1 moments of the phase function be modified real(kind=wp), intent(in), dimension(ncol,nlay,nbnd) :: tau2 optical properties to be added to original (defined on bands) real(kind=wp), intent(in), dimension(ncol,nlay,nbnd) :: ssa2 optical properties to be added to original (defined on bands) real(kind=wp), intent(in), dimension(ncol,nlay,nbnd) :: g2 optical properties to be added to original (defined on bands) integer, intent(in) :: nbnd array sizes integer, intent(in), dimension(2,nbnd) :: gpt_lims Starting and ending gpoint for each band","tags":"","loc":"interface/inc_nstream_by_2stream_bybnd.html"},{"title":"inc_nstream_by_nstream_bybnd – RTE kernels","text":"interface increment n -stream optical properties defined on g-points with a second set defined on bands public pure subroutine inc_nstream_by_nstream_bybnd(ncol, nlay, ngpt, nmom1, nmom2, tau1, ssa1, p1, tau2, ssa2, p2, nbnd, gpt_lims) bind(C, name=\"0\") Arguments Type Intent Optional Attributes Name integer, intent(in) :: ncol array sizes integer, intent(in) :: nlay array sizes integer, intent(in) :: ngpt array sizes integer, intent(in) :: nmom1 array sizes integer, intent(in) :: nmom2 array sizes real(kind=wp), intent(inout), dimension(ncol,nlay,ngpt) :: tau1 optical properties to be modified (defined on g-points) real(kind=wp), intent(inout), dimension(ncol,nlay,ngpt) :: ssa1 optical properties to be modified (defined on g-points) real(kind=wp), intent(inout), dimension(nmom1, ncol,nlay,ngpt) :: p1 moments of the phase function be modified real(kind=wp), intent(in), dimension(ncol,nlay,nbnd) :: tau2 optical properties to be added to original (defined on bands) real(kind=wp), intent(in), dimension(ncol,nlay,nbnd) :: ssa2 optical properties to be added to original (defined on bands) real(kind=wp), intent(in), dimension(nmom2, ncol,nlay,nbnd) :: p2 moments of the phase function to be added integer, intent(in) :: nbnd array sizes integer, intent(in), dimension(2,nbnd) :: gpt_lims Starting and ending gpoint for each band","tags":"","loc":"interface/inc_nstream_by_nstream_bybnd.html"},{"title":"increment_1scalar_by_1scalar – RTE kernels","text":"interface increase one absorption optical depth by a second value public pure subroutine increment_1scalar_by_1scalar(ncol, nlay, ngpt, tau1, tau2) bind(C, name=\"0\") Arguments Type Intent Optional Attributes Name integer, intent(in) :: ncol array sizes integer, intent(in) :: nlay array sizes integer, intent(in) :: ngpt array sizes real(kind=wp), intent(inout), dimension(ncol,nlay,ngpt) :: tau1 optical properties to be modified real(kind=wp), intent(in), dimension(ncol,nlay,ngpt) :: tau2 optical properties to be added to original","tags":"","loc":"interface/increment_1scalar_by_1scalar.html"},{"title":"increment_1scalar_by_2stream – RTE kernels","text":"interface increase absorption optical depth with extinction optical depth (2-stream form) public pure subroutine increment_1scalar_by_2stream(ncol, nlay, ngpt, tau1, tau2, ssa2) bind(C, name=\"0\") Arguments Type Intent Optional Attributes Name integer, intent(in) :: ncol array sizes integer, intent(in) :: nlay array sizes integer, intent(in) :: ngpt array sizes real(kind=wp), intent(inout), dimension(ncol,nlay,ngpt) :: tau1 optical properties to be modified real(kind=wp), intent(in), dimension(ncol,nlay,ngpt) :: tau2 optical properties to be added to original real(kind=wp), intent(in), dimension(ncol,nlay,ngpt) :: ssa2 optical properties to be added to original","tags":"","loc":"interface/increment_1scalar_by_2stream.html"},{"title":"increment_1scalar_by_nstream – RTE kernels","text":"interface increase absorption optical depth with extinction optical depth (n-stream form) public pure subroutine increment_1scalar_by_nstream(ncol, nlay, ngpt, tau1, tau2, ssa2) bind(C, name=\"0\") Arguments Type Intent Optional Attributes Name integer, intent(in) :: ncol array sizes integer, intent(in) :: nlay array sizes integer, intent(in) :: ngpt array sizes real(kind=wp), intent(inout), dimension(ncol,nlay,ngpt) :: tau1 optical properties to be modified real(kind=wp), intent(in), dimension(ncol,nlay,ngpt) :: tau2 optical properties to be added to original real(kind=wp), intent(in), dimension(ncol,nlay,ngpt) :: ssa2 optical properties to be added to original","tags":"","loc":"interface/increment_1scalar_by_nstream.html"},{"title":"increment_2stream_by_1scalar – RTE kernels","text":"interface increment two-stream optical properties with absorption optical depth public pure subroutine increment_2stream_by_1scalar(ncol, nlay, ngpt, tau1, ssa1, tau2) bind(C, name=\"0\") Arguments Type Intent Optional Attributes Name integer, intent(in) :: ncol array sizes integer, intent(in) :: nlay array sizes integer, intent(in) :: ngpt array sizes real(kind=wp), intent(inout), dimension(ncol,nlay,ngpt) :: tau1 optical properties to be modified real(kind=wp), intent(inout), dimension(ncol,nlay,ngpt) :: ssa1 optical properties to be modified real(kind=wp), intent(in), dimension(ncol,nlay,ngpt) :: tau2 optical properties to be added to original","tags":"","loc":"interface/increment_2stream_by_1scalar.html"},{"title":"increment_2stream_by_2stream – RTE kernels","text":"interface increment two-stream optical properties with a second set public pure subroutine increment_2stream_by_2stream(ncol, nlay, ngpt, tau1, ssa1, g1, tau2, ssa2, g2) bind(C, name=\"0\") Arguments Type Intent Optional Attributes Name integer, intent(in) :: ncol array sizes integer, intent(in) :: nlay array sizes integer, intent(in) :: ngpt array sizes real(kind=wp), intent(inout), dimension(ncol,nlay,ngpt) :: tau1 optical properties to be modified real(kind=wp), intent(inout), dimension(ncol,nlay,ngpt) :: ssa1 optical properties to be modified real(kind=wp), intent(inout), dimension(ncol,nlay,ngpt) :: g1 optical properties to be modified real(kind=wp), intent(in), dimension(ncol,nlay,ngpt) :: tau2 optical properties to be added to original real(kind=wp), intent(in), dimension(ncol,nlay,ngpt) :: ssa2 optical properties to be added to original real(kind=wp), intent(in), dimension(ncol,nlay,ngpt) :: g2 optical properties to be added to original","tags":"","loc":"interface/increment_2stream_by_2stream.html"},{"title":"increment_2stream_by_nstream – RTE kernels","text":"interface increment two-stream optical properties with n -stream public pure subroutine increment_2stream_by_nstream(ncol, nlay, ngpt, nmom2, tau1, ssa1, g1, tau2, ssa2, p2) bind(C, name=\"0\") Arguments Type Intent Optional Attributes Name integer, intent(in) :: ncol array sizes integer, intent(in) :: nlay array sizes integer, intent(in) :: ngpt array sizes integer, intent(in) :: nmom2 array sizes real(kind=wp), intent(inout), dimension(ncol,nlay,ngpt) :: tau1 optical properties to be modified real(kind=wp), intent(inout), dimension(ncol,nlay,ngpt) :: ssa1 optical properties to be modified real(kind=wp), intent(inout), dimension(ncol,nlay,ngpt) :: g1 optical properties to be modified real(kind=wp), intent(in), dimension(ncol,nlay,ngpt) :: tau2 optical properties to be added to original real(kind=wp), intent(in), dimension(ncol,nlay,ngpt) :: ssa2 optical properties to be added to original real(kind=wp), intent(in), dimension(nmom2, ncol,nlay,ngpt) :: p2 moments of the phase function to be added","tags":"","loc":"interface/increment_2stream_by_nstream.html"},{"title":"increment_nstream_by_1scalar – RTE kernels","text":"interface increment n -stream optical properties with absorption optical depth public pure subroutine increment_nstream_by_1scalar(ncol, nlay, ngpt, tau1, ssa1, tau2) bind(C, name=\"0\") Arguments Type Intent Optional Attributes Name integer, intent(in) :: ncol array sizes integer, intent(in) :: nlay array sizes integer, intent(in) :: ngpt array sizes real(kind=wp), intent(inout), dimension(ncol,nlay,ngpt) :: tau1 optical properties to be modified real(kind=wp), intent(inout), dimension(ncol,nlay,ngpt) :: ssa1 optical properties to be modified real(kind=wp), intent(in), dimension(ncol,nlay,ngpt) :: tau2 optical properties to be added to original","tags":"","loc":"interface/increment_nstream_by_1scalar.html"},{"title":"increment_nstream_by_2stream – RTE kernels","text":"interface increment n -stream optical properties with two-stream values public pure subroutine increment_nstream_by_2stream(ncol, nlay, ngpt, nmom1, tau1, ssa1, p1, tau2, ssa2, g2) bind(C, name=\"0\") Arguments Type Intent Optional Attributes Name integer, intent(in) :: ncol array sizes integer, intent(in) :: nlay array sizes integer, intent(in) :: ngpt array sizes integer, intent(in) :: nmom1 array sizes real(kind=wp), intent(inout), dimension(ncol,nlay,ngpt) :: tau1 optical properties to be modified real(kind=wp), intent(inout), dimension(ncol,nlay,ngpt) :: ssa1 optical properties to be modified real(kind=wp), intent(inout), dimension(nmom1, ncol,nlay,ngpt) :: p1 moments of the phase function be modified real(kind=wp), intent(in), dimension(ncol,nlay,ngpt) :: tau2 optical properties to be added to original real(kind=wp), intent(in), dimension(ncol,nlay,ngpt) :: ssa2 optical properties to be added to original real(kind=wp), intent(in), dimension(ncol,nlay,ngpt) :: g2 optical properties to be added to original","tags":"","loc":"interface/increment_nstream_by_2stream.html"},{"title":"increment_nstream_by_nstream – RTE kernels","text":"interface increment one set of n -stream optical properties with another set public pure subroutine increment_nstream_by_nstream(ncol, nlay, ngpt, nmom1, nmom2, tau1, ssa1, p1, tau2, ssa2, p2) bind(C, name=\"0\") Arguments Type Intent Optional Attributes Name integer, intent(in) :: ncol array sizes integer, intent(in) :: nlay array sizes integer, intent(in) :: ngpt array sizes integer, intent(in) :: nmom1 array sizes integer, intent(in) :: nmom2 array sizes real(kind=wp), intent(inout), dimension(ncol,nlay,ngpt) :: tau1 optical properties to be modified real(kind=wp), intent(inout), dimension(ncol,nlay,ngpt) :: ssa1 optical properties to be modified real(kind=wp), intent(inout), dimension(nmom1, ncol,nlay,ngpt) :: p1 moments of the phase function be modified real(kind=wp), intent(in), dimension(ncol,nlay,ngpt) :: tau2 optical properties to be added to original real(kind=wp), intent(in), dimension(ncol,nlay,ngpt) :: ssa2 optical properties to be added to original real(kind=wp), intent(in), dimension(nmom2, ncol,nlay,ngpt) :: p2 moments of the phase function to be added","tags":"","loc":"interface/increment_nstream_by_nstream.html"},{"title":"net_broadband – RTE kernels","text":"public interface net_broadband Spectral reduction over all points for net flux\n Overloaded - which routine is called depends on arguments Contents Subroutines net_broadband_full net_broadband_precalc Subroutines private subroutine net_broadband_full(ncol, nlev, ngpt, spectral_flux_dn, spectral_flux_up, broadband_flux_net) bind(C, name=\"0\") Net flux from g-point fluxes up and down Arguments Type Intent Optional Attributes Name integer, intent(in) :: ncol Array sizes integer, intent(in) :: nlev Array sizes integer, intent(in) :: ngpt Array sizes real(kind=wp), intent(in), dimension(ncol, nlev, ngpt) :: spectral_flux_dn Spectrally-resolved flux up and down real(kind=wp), intent(in), dimension(ncol, nlev, ngpt) :: spectral_flux_up Spectrally-resolved flux up and down real(kind=wp), intent(out), dimension(ncol, nlev) :: broadband_flux_net Net (down minus up) summed over ngpt private subroutine net_broadband_precalc(ncol, nlev, flux_dn, flux_up, broadband_flux_net) bind(C, name=\"0\") Net flux when bradband flux up and down are already available Arguments Type Intent Optional Attributes Name integer, intent(in) :: ncol Array sizes integer, intent(in) :: nlev Array sizes real(kind=wp), intent(in), dimension(ncol, nlev) :: flux_dn Broadband downward and upward fluxes real(kind=wp), intent(in), dimension(ncol, nlev) :: flux_up Broadband downward and upward fluxes real(kind=wp), intent(out), dimension(ncol, nlev) :: broadband_flux_net Net (down minus up)","tags":"","loc":"interface/net_broadband~2.html"},{"title":"sum_broadband – RTE kernels","text":"interface Spectral reduction over all points public subroutine sum_broadband(ncol, nlev, ngpt, spectral_flux, broadband_flux) bind(C, name=\"0\") Arguments Type Intent Optional Attributes Name integer, intent(in) :: ncol Array sizes integer, intent(in) :: nlev Array sizes integer, intent(in) :: ngpt Array sizes real(kind=wp), intent(in), dimension(ncol, nlev, ngpt) :: spectral_flux Spectrally-resolved flux real(kind=wp), intent(out), dimension(ncol, nlev) :: broadband_flux Sum of spectrally-resolved flux over ngpt","tags":"","loc":"interface/sum_broadband.html"},{"title":"lw_solver_2stream – RTE kernels","text":"interface Longwave two-stream calculation:\n - combine RRTMGP-specific sources at levels\n - compute layer reflectance, transmittance\n - compute total source function at levels using linear-in-tau\n - transport public subroutine lw_solver_2stream(ncol, nlay, ngpt, top_at_1, tau, ssa, g, lay_source, lev_source, sfc_emis, sfc_src, inc_flux, flux_up, flux_dn) bind(C, name=\"0\") Arguments Type Intent Optional Attributes Name integer, intent(in) :: ncol Number of columns, layers, g-points integer, intent(in) :: nlay Number of columns, layers, g-points integer, intent(in) :: ngpt Number of columns, layers, g-points logical(kind=wl), intent(in) :: top_at_1 ilay = 1 is the top of the atmosphere? real(kind=wp), intent(in), dimension(ncol,nlay, ngpt) :: tau Optical thickness, single-scattering albedo, asymmetry parameter [] real(kind=wp), intent(in), dimension(ncol,nlay, ngpt) :: ssa Optical thickness, single-scattering albedo, asymmetry parameter [] real(kind=wp), intent(in), dimension(ncol,nlay, ngpt) :: g Optical thickness, single-scattering albedo, asymmetry parameter [] real(kind=wp), intent(in), dimension(ncol,nlay, ngpt) :: lay_source Planck source at layer average temperature [W/m2] real(kind=wp), intent(in), dimension(ncol,nlay+1,ngpt) :: lev_source Planck source at layer edge for radiation [W/m2] real(kind=wp), intent(in), dimension(ncol, ngpt) :: sfc_emis Surface emissivity [] real(kind=wp), intent(in), dimension(ncol, ngpt) :: sfc_src Surface source function [W/m2] real(kind=wp), intent(in), dimension(ncol, ngpt) :: inc_flux Incident diffuse flux, probably 0 [W/m2] real(kind=wp), intent(out), dimension(ncol,nlay+1,ngpt) :: flux_up Fluxes [W/m2] real(kind=wp), intent(out), dimension(ncol,nlay+1,ngpt) :: flux_dn Fluxes [W/m2]","tags":"","loc":"interface/lw_solver_2stream.html"},{"title":"lw_solver_noscat – RTE kernels","text":"interface LW transport, no scattering, multi-angle quadrature\n Users provide a set of weights and quadrature angles\n Routine sums over single-angle solutions for each sets of angles/weights public subroutine lw_solver_noscat(ncol, nlay, ngpt, top_at_1, nmus, Ds, weights, tau, lay_source, lev_source, sfc_emis, sfc_src, inc_flux, flux_up, flux_dn, do_broadband, broadband_up, broadband_dn, do_Jacobians, sfc_srcJac, flux_upJac, do_rescaling, ssa, g) bind(C, name=\"0\") Arguments Type Intent Optional Attributes Name integer, intent(in) :: ncol Number of columns, layers, g-points integer, intent(in) :: nlay Number of columns, layers, g-points integer, intent(in) :: ngpt Number of columns, layers, g-points logical(kind=wl), intent(in) :: top_at_1 ilay = 1 is the top of the atmosphere? integer, intent(in) :: nmus number of quadrature angles real(kind=wp), intent(in), dimension (ncol, ngpt, nmus) :: Ds quadrature secants real(kind=wp), intent(in), dimension(nmus) :: weights quadrature weights real(kind=wp), intent(in), dimension(ncol,nlay, ngpt) :: tau Absorption optical thickness [] real(kind=wp), intent(in), dimension(ncol,nlay, ngpt) :: lay_source Planck source at layer average temperature [W/m2] real(kind=wp), intent(in), dimension(ncol,nlay+1,ngpt) :: lev_source Planck source at layer edge for radiation [W/m2] real(kind=wp), intent(in), dimension(ncol, ngpt) :: sfc_emis Surface emissivity [] real(kind=wp), intent(in), dimension(ncol, ngpt) :: sfc_src Surface source function [W/m2] real(kind=wp), intent(in), dimension(ncol, ngpt) :: inc_flux Incident diffuse flux, probably 0 [W/m2] real(kind=wp), intent(out), dimension(ncol,nlay+1,ngpt), target :: flux_up Fluxes [W/m2] real(kind=wp), intent(out), dimension(ncol,nlay+1,ngpt), target :: flux_dn Fluxes [W/m2] logical(kind=wl), intent(in) :: do_broadband real(kind=wp), intent(out), dimension(ncol,nlay+1 ), target :: broadband_up Spectrally-integrated fluxes [W/m2] real(kind=wp), intent(out), dimension(ncol,nlay+1 ), target :: broadband_dn Spectrally-integrated fluxes [W/m2] logical(kind=wl), intent(in) :: do_Jacobians compute Jacobian with respect to surface temeprature? real(kind=wp), intent(in), dimension(ncol ,ngpt) :: sfc_srcJac surface temperature Jacobian of surface source function [W/m2/K] real(kind=wp), intent(out), dimension(ncol,nlay+1 ), target :: flux_upJac surface temperature Jacobian of Radiances [W/m2-str / K] logical(kind=wl), intent(in) :: do_rescaling Approximate treatment of scattering (10.1175/JAS-D-18-0014.1) real(kind=wp), intent(in), dimension(ncol,nlay ,ngpt) :: ssa single-scattering albedo, asymmetry parameter real(kind=wp), intent(in), dimension(ncol,nlay ,ngpt) :: g single-scattering albedo, asymmetry parameter","tags":"","loc":"interface/lw_solver_noscat.html"},{"title":"sw_solver_2stream – RTE kernels","text":"interface Shortwave two-stream calculation:\n compute layer reflectance, transmittance\n compute solar source function for diffuse radiation\n transport public subroutine sw_solver_2stream(ncol, nlay, ngpt, top_at_1, tau, ssa, g, mu0, sfc_alb_dir, sfc_alb_dif, inc_flux_dir, flux_up, flux_dn, flux_dir, has_dif_bc, inc_flux_dif, do_broadband, broadband_up, broadband_dn, broadband_dir) bind(C, name=\"0\") Arguments Type Intent Optional Attributes Name integer, intent(in) :: ncol Number of columns, layers, g-points integer, intent(in) :: nlay Number of columns, layers, g-points integer, intent(in) :: ngpt Number of columns, layers, g-points logical(kind=wl), intent(in) :: top_at_1 ilay = 1 is the top of the atmosphere? real(kind=wp), intent(in), dimension(ncol,nlay, ngpt) :: tau Optical thickness, single-scattering albedo, asymmetry parameter [] real(kind=wp), intent(in), dimension(ncol,nlay, ngpt) :: ssa Optical thickness, single-scattering albedo, asymmetry parameter [] real(kind=wp), intent(in), dimension(ncol,nlay, ngpt) :: g Optical thickness, single-scattering albedo, asymmetry parameter [] real(kind=wp), intent(in), dimension(ncol,nlay ) :: mu0 cosine of solar zenith angle real(kind=wp), intent(in), dimension(ncol, ngpt) :: sfc_alb_dir Spectral surface albedo for direct and diffuse radiation real(kind=wp), intent(in), dimension(ncol, ngpt) :: sfc_alb_dif Spectral surface albedo for direct and diffuse radiation real(kind=wp), intent(in), dimension(ncol, ngpt) :: inc_flux_dir Direct beam incident flux real(kind=wp), intent(out), dimension(ncol,nlay+1,ngpt), target :: flux_up Fluxes [W/m2] real(kind=wp), intent(out), dimension(ncol,nlay+1,ngpt), target :: flux_dn Fluxes [W/m2] real(kind=wp), intent(out), dimension(ncol,nlay+1,ngpt), target :: flux_dir Fluxes [W/m2] logical(kind=wl), intent(in) :: has_dif_bc Is a boundary condition for diffuse flux supplied? real(kind=wp), intent(in), dimension(ncol, ngpt) :: inc_flux_dif Boundary condition for diffuse flux [W/m2] logical(kind=wl), intent(in) :: do_broadband Provide broadband-integrated, not spectrally-resolved, fluxes? real(kind=wp), intent(out), dimension(ncol,nlay+1 ) :: broadband_up real(kind=wp), intent(out), dimension(ncol,nlay+1 ) :: broadband_dn real(kind=wp), intent(out), dimension(ncol,nlay+1 ) :: broadband_dir","tags":"","loc":"interface/sw_solver_2stream.html"},{"title":"sw_solver_noscat – RTE kernels","text":"interface public pure subroutine sw_solver_noscat(ncol, nlay, ngpt, top_at_1, tau, mu0, inc_flux_dir, flux_dir) bind(C, name=\"0\") Arguments Type Intent Optional Attributes Name integer, intent(in) :: ncol Number of columns, layers, g-points integer, intent(in) :: nlay Number of columns, layers, g-points integer, intent(in) :: ngpt Number of columns, layers, g-points logical(kind=wl), intent(in) :: top_at_1 ilay = 1 is the top of the atmosphere? real(kind=wp), intent(in), dimension(ncol,nlay, ngpt) :: tau Absorption optical thickness [] real(kind=wp), intent(in), dimension(ncol,nlay ) :: mu0 cosine of solar zenith angle real(kind=wp), intent(in), dimension(ncol, ngpt) :: inc_flux_dir Direct beam incident flux [W/m2] real(kind=wp), intent(out), dimension(ncol,nlay+1,ngpt) :: flux_dir","tags":"","loc":"interface/sw_solver_noscat.html"},{"title":"zero_array – RTE kernels","text":"public interface zero_array Contents Subroutines zero_array_1D zero_array_2D zero_array_3D zero_array_4D Subroutines public subroutine zero_array_1D(ni, array) bind(C, name=\"0\") Arguments Type Intent Optional Attributes Name integer, intent(in) :: ni real(kind=wp), intent(out), dimension(ni) :: array public subroutine zero_array_2D(ni, nj, array) bind(C, name=\"0\") Arguments Type Intent Optional Attributes Name integer, intent(in) :: ni integer, intent(in) :: nj real(kind=wp), intent(out), dimension(ni, nj) :: array public subroutine zero_array_3D(ni, nj, nk, array) bind(C, name=\"0\") Arguments Type Intent Optional Attributes Name integer, intent(in) :: ni integer, intent(in) :: nj integer, intent(in) :: nk real(kind=wp), intent(out), dimension(ni, nj, nk) :: array public subroutine zero_array_4D(ni, nj, nk, nl, array) bind(C, name=\"0\") Arguments Type Intent Optional Attributes Name integer, intent(in) :: ni integer, intent(in) :: nj integer, intent(in) :: nk integer, intent(in) :: nl real(kind=wp), intent(out), dimension(ni, nj, nk, nl) :: array","tags":"","loc":"interface/zero_array~2.html"},{"title":"mo_optical_props_kernels – RTE kernels","text":"Kernels for arrays of optical properties: - delta-scaling\n- adding two sets of properties\n- extracting subsets along the column dimension Uses iso_c_binding mo_rte_kind module~~mo_optical_props_kernels~~UsesGraph module~mo_optical_props_kernels mo_optical_props_kernels iso_c_binding iso_c_binding module~mo_optical_props_kernels->iso_c_binding mo_rte_kind mo_rte_kind module~mo_optical_props_kernels->mo_rte_kind Help × Graph Key Nodes of different colours represent the following: Graph Key Module Module Submodule Submodule Subroutine Subroutine Function Function Program Program This Page's Entity This Page's Entity Solid arrows point from a submodule to the (sub)module which it is\n descended from. Dashed arrows point from a module or program unit to \n modules which it uses. Contents Interfaces delta_scale_2str_kernel extract_subset Subroutines delta_scale_2str_f_k delta_scale_2str_k extract_subset_absorption_tau extract_subset_dim1_3d extract_subset_dim2_4d inc_1scalar_by_1scalar_bybnd inc_1scalar_by_2stream_bybnd inc_1scalar_by_nstream_bybnd inc_2stream_by_1scalar_bybnd inc_2stream_by_2stream_bybnd inc_2stream_by_nstream_bybnd inc_nstream_by_1scalar_bybnd inc_nstream_by_2stream_bybnd inc_nstream_by_nstream_bybnd increment_1scalar_by_1scalar increment_1scalar_by_2stream increment_1scalar_by_nstream increment_2stream_by_1scalar increment_2stream_by_2stream increment_2stream_by_nstream increment_nstream_by_1scalar increment_nstream_by_2stream increment_nstream_by_nstream Interfaces public interface delta_scale_2str_kernel Delta-scale two-stream optical properties public pure subroutine delta_scale_2str_f_k (ncol, nlay, ngpt, tau, ssa, g, f) bind(C, name=\"0\") Delta-scale two-stream optical properties given user-provided value of (forward scattering) Arguments Type Intent Optional Attributes Name integer, intent(in) :: ncol Array sizes integer, intent(in) :: nlay Array sizes integer, intent(in) :: ngpt Array sizes real(kind=wp), intent(inout), dimension(ncol, nlay, ngpt) :: tau Optical depth, single-scattering albedo, asymmetry parameter real(kind=wp), intent(inout), dimension(ncol, nlay, ngpt) :: ssa Optical depth, single-scattering albedo, asymmetry parameter real(kind=wp), intent(inout), dimension(ncol, nlay, ngpt) :: g Optical depth, single-scattering albedo, asymmetry parameter real(kind=wp), intent(in), dimension(ncol, nlay, ngpt) :: f User-provided forward-scattering fraction public pure subroutine delta_scale_2str_k (ncol, nlay, ngpt, tau, ssa, g) bind(C, name=\"0\") Delta-scale assuming forward-scatternig fraction is the square of the asymmetry parameter\n i.e. Arguments Type Intent Optional Attributes Name integer, intent(in) :: ncol Array sizes integer, intent(in) :: nlay Array sizes integer, intent(in) :: ngpt Array sizes real(kind=wp), intent(inout), dimension(ncol, nlay, ngpt) :: tau Optical depth, single-scattering albedo, asymmetry parameter real(kind=wp), intent(inout), dimension(ncol, nlay, ngpt) :: ssa Optical depth, single-scattering albedo, asymmetry parameter real(kind=wp), intent(inout), dimension(ncol, nlay, ngpt) :: g Optical depth, single-scattering albedo, asymmetry parameter public interface extract_subset Subsetting, meaning extracting some portion of the 3D domain public pure subroutine extract_subset_dim1_3d (ncol, nlay, ngpt, array_in, colS, colE, array_out) bind(C, name=\"0\") Extract a subset from the first dimension (normally columns) of a 3D field.\n Applicable to most variables e.g. tau, ssa, g Arguments Type Intent Optional Attributes Name integer, intent(in) :: ncol Array sizes integer, intent(in) :: nlay Array sizes integer, intent(in) :: ngpt Array sizes real(kind=wp), intent(in), dimension(ncol,nlay,ngpt) :: array_in Array to subset integer, intent(in) :: colS Starting and ending index integer, intent(in) :: colE Starting and ending index real(kind=wp), intent(out), dimension(colE-colS+1, nlay,ngpt) :: array_out subset of the input array public pure subroutine extract_subset_dim2_4d (nmom, ncol, nlay, ngpt, array_in, colS, colE, array_out) bind(C, name=\"0\") Extract a subset from the second dimension (normally columns) of a 4D field.\n Applicable to phase function moments, where the first dimension is the moment Arguments Type Intent Optional Attributes Name integer, intent(in) :: nmom Array sizes integer, intent(in) :: ncol Array sizes integer, intent(in) :: nlay Array sizes integer, intent(in) :: ngpt Array sizes real(kind=wp), intent(in), dimension(nmom,ncol,nlay,ngpt) :: array_in Array to subset integer, intent(in) :: colS Starting and ending index integer, intent(in) :: colE Starting and ending index real(kind=wp), intent(out), dimension(nmom,colE-colS+1, nlay,ngpt) :: array_out subset of the input array public pure subroutine extract_subset_absorption_tau (ncol, nlay, ngpt, tau_in, ssa_in, colS, colE, tau_out) bind(C, name=\"0\") Extract the absorption optical thickness Arguments Type Intent Optional Attributes Name integer, intent(in) :: ncol Array sizes integer, intent(in) :: nlay Array sizes integer, intent(in) :: ngpt Array sizes real(kind=wp), intent(in), dimension(ncol,nlay,ngpt) :: tau_in Optical thickness, single scattering albedo real(kind=wp), intent(in), dimension(ncol,nlay,ngpt) :: ssa_in Optical thickness, single scattering albedo integer, intent(in) :: colS Starting and ending index integer, intent(in) :: colE Starting and ending index real(kind=wp), intent(out), dimension(colE-colS+1, nlay,ngpt) :: tau_out absorption optical thickness subset Subroutines public pure subroutine delta_scale_2str_f_k (ncol, nlay, ngpt, tau, ssa, g, f) bind(C, name=\"0\") Delta-scale two-stream optical properties given user-provided value of (forward scattering) Arguments Type Intent Optional Attributes Name integer, intent(in) :: ncol Array sizes integer, intent(in) :: nlay Array sizes integer, intent(in) :: ngpt Array sizes real(kind=wp), intent(inout), dimension(ncol, nlay, ngpt) :: tau Optical depth, single-scattering albedo, asymmetry parameter real(kind=wp), intent(inout), dimension(ncol, nlay, ngpt) :: ssa Optical depth, single-scattering albedo, asymmetry parameter real(kind=wp), intent(inout), dimension(ncol, nlay, ngpt) :: g Optical depth, single-scattering albedo, asymmetry parameter real(kind=wp), intent(in), dimension(ncol, nlay, ngpt) :: f User-provided forward-scattering fraction public pure subroutine delta_scale_2str_k (ncol, nlay, ngpt, tau, ssa, g) bind(C, name=\"0\") Delta-scale assuming forward-scatternig fraction is the square of the asymmetry parameter\n i.e. Arguments Type Intent Optional Attributes Name integer, intent(in) :: ncol Array sizes integer, intent(in) :: nlay Array sizes integer, intent(in) :: ngpt Array sizes real(kind=wp), intent(inout), dimension(ncol, nlay, ngpt) :: tau Optical depth, single-scattering albedo, asymmetry parameter real(kind=wp), intent(inout), dimension(ncol, nlay, ngpt) :: ssa Optical depth, single-scattering albedo, asymmetry parameter real(kind=wp), intent(inout), dimension(ncol, nlay, ngpt) :: g Optical depth, single-scattering albedo, asymmetry parameter public pure subroutine extract_subset_absorption_tau (ncol, nlay, ngpt, tau_in, ssa_in, colS, colE, tau_out) bind(C, name=\"0\") Extract the absorption optical thickness Arguments Type Intent Optional Attributes Name integer, intent(in) :: ncol Array sizes integer, intent(in) :: nlay Array sizes integer, intent(in) :: ngpt Array sizes real(kind=wp), intent(in), dimension(ncol,nlay,ngpt) :: tau_in Optical thickness, single scattering albedo real(kind=wp), intent(in), dimension(ncol,nlay,ngpt) :: ssa_in Optical thickness, single scattering albedo integer, intent(in) :: colS Starting and ending index integer, intent(in) :: colE Starting and ending index real(kind=wp), intent(out), dimension(colE-colS+1, nlay,ngpt) :: tau_out absorption optical thickness subset public pure subroutine extract_subset_dim1_3d (ncol, nlay, ngpt, array_in, colS, colE, array_out) bind(C, name=\"0\") Extract a subset from the first dimension (normally columns) of a 3D field.\n Applicable to most variables e.g. tau, ssa, g Arguments Type Intent Optional Attributes Name integer, intent(in) :: ncol Array sizes integer, intent(in) :: nlay Array sizes integer, intent(in) :: ngpt Array sizes real(kind=wp), intent(in), dimension(ncol,nlay,ngpt) :: array_in Array to subset integer, intent(in) :: colS Starting and ending index integer, intent(in) :: colE Starting and ending index real(kind=wp), intent(out), dimension(colE-colS+1, nlay,ngpt) :: array_out subset of the input array public pure subroutine extract_subset_dim2_4d (nmom, ncol, nlay, ngpt, array_in, colS, colE, array_out) bind(C, name=\"0\") Extract a subset from the second dimension (normally columns) of a 4D field.\n Applicable to phase function moments, where the first dimension is the moment Arguments Type Intent Optional Attributes Name integer, intent(in) :: nmom Array sizes integer, intent(in) :: ncol Array sizes integer, intent(in) :: nlay Array sizes integer, intent(in) :: ngpt Array sizes real(kind=wp), intent(in), dimension(nmom,ncol,nlay,ngpt) :: array_in Array to subset integer, intent(in) :: colS Starting and ending index integer, intent(in) :: colE Starting and ending index real(kind=wp), intent(out), dimension(nmom,colE-colS+1, nlay,ngpt) :: array_out subset of the input array public pure subroutine inc_1scalar_by_1scalar_bybnd (ncol, nlay, ngpt, tau1, tau2, nbnd, gpt_lims) bind(C, name=\"0\") increase one absorption optical depth defined on g-points by a second value defined on bands Arguments Type Intent Optional Attributes Name integer, intent(in) :: ncol array sizes integer, intent(in) :: nlay array sizes integer, intent(in) :: ngpt array sizes real(kind=wp), intent(inout), dimension(ncol,nlay,ngpt) :: tau1 optical properties to be modified (defined on g-points) real(kind=wp), intent(in), dimension(ncol,nlay,nbnd) :: tau2 optical properties to be added to original (defined on bands) integer, intent(in) :: nbnd array sizes integer, intent(in), dimension(2,nbnd) :: gpt_lims Starting and ending gpoint for each band public pure subroutine inc_1scalar_by_2stream_bybnd (ncol, nlay, ngpt, tau1, tau2, ssa2, nbnd, gpt_lims) bind(C, name=\"0\") increase absorption optical depth defined on g-points with extinction optical depth (2-stream form) defined on bands Arguments Type Intent Optional Attributes Name integer, intent(in) :: ncol array sizes integer, intent(in) :: nlay array sizes integer, intent(in) :: ngpt array sizes real(kind=wp), intent(inout), dimension(ncol,nlay,ngpt) :: tau1 optical properties to be modified (defined on g-points) real(kind=wp), intent(in), dimension(ncol,nlay,nbnd) :: tau2 optical properties to be added to original (defined on bands) real(kind=wp), intent(in), dimension(ncol,nlay,nbnd) :: ssa2 optical properties to be added to original (defined on bands) integer, intent(in) :: nbnd array sizes integer, intent(in), dimension(2,nbnd) :: gpt_lims Starting and ending gpoint for each band public pure subroutine inc_1scalar_by_nstream_bybnd (ncol, nlay, ngpt, tau1, tau2, ssa2, nbnd, gpt_lims) bind(C, name=\"0\") increase absorption optical depth defined on g-points with extinction optical depth (n-stream form) defined on bands Arguments Type Intent Optional Attributes Name integer, intent(in) :: ncol array sizes integer, intent(in) :: nlay array sizes integer, intent(in) :: ngpt array sizes real(kind=wp), intent(inout), dimension(ncol,nlay,ngpt) :: tau1 optical properties to be modified (defined on g-points) real(kind=wp), intent(in), dimension(ncol,nlay,nbnd) :: tau2 optical properties to be added to original (defined on bands) real(kind=wp), intent(in), dimension(ncol,nlay,nbnd) :: ssa2 optical properties to be added to original (defined on bands) integer, intent(in) :: nbnd array sizes integer, intent(in), dimension(2,nbnd) :: gpt_lims Starting and ending gpoint for each band public pure subroutine inc_2stream_by_1scalar_bybnd (ncol, nlay, ngpt, tau1, ssa1, tau2, nbnd, gpt_lims) bind(C, name=\"0\") increment two-stream optical properties defined on g-points with absorption optical depth defined on bands Arguments Type Intent Optional Attributes Name integer, intent(in) :: ncol array sizes integer, intent(in) :: nlay array sizes integer, intent(in) :: ngpt array sizes real(kind=wp), intent(inout), dimension(ncol,nlay,ngpt) :: tau1 optical properties to be modified (defined on g-points) real(kind=wp), intent(inout), dimension(ncol,nlay,ngpt) :: ssa1 optical properties to be modified (defined on g-points) real(kind=wp), intent(in), dimension(ncol,nlay,nbnd) :: tau2 optical properties to be added to original (defined on bands) integer, intent(in) :: nbnd array sizes integer, intent(in), dimension(2,nbnd) :: gpt_lims Starting and ending gpoint for each band public pure subroutine inc_2stream_by_2stream_bybnd (ncol, nlay, ngpt, tau1, ssa1, g1, tau2, ssa2, g2, nbnd, gpt_lims) bind(C, name=\"0\") increment 2-stream optical properties defined on g-points with another set defined on bands Arguments Type Intent Optional Attributes Name integer, intent(in) :: ncol array sizes integer, intent(in) :: nlay array sizes integer, intent(in) :: ngpt array sizes real(kind=wp), intent(inout), dimension(ncol,nlay,ngpt) :: tau1 optical properties to be modified (defined on g-points) real(kind=wp), intent(inout), dimension(ncol,nlay,ngpt) :: ssa1 optical properties to be modified (defined on g-points) real(kind=wp), intent(inout), dimension(ncol,nlay,ngpt) :: g1 optical properties to be modified (defined on g-points) real(kind=wp), intent(in), dimension(ncol,nlay,nbnd) :: tau2 optical properties to be added to original (defined on bands) real(kind=wp), intent(in), dimension(ncol,nlay,nbnd) :: ssa2 optical properties to be added to original (defined on bands) real(kind=wp), intent(in), dimension(ncol,nlay,nbnd) :: g2 optical properties to be added to original (defined on bands) integer, intent(in) :: nbnd array sizes integer, intent(in), dimension(2,nbnd) :: gpt_lims Starting and ending gpoint for each band public pure subroutine inc_2stream_by_nstream_bybnd (ncol, nlay, ngpt, nmom2, tau1, ssa1, g1, tau2, ssa2, p2, nbnd, gpt_lims) bind(C, name=\"0\") increment 2-stream optical properties defined on g-points with n -stream properties set defined on bands Arguments Type Intent Optional Attributes Name integer, intent(in) :: ncol array sizes integer, intent(in) :: nlay array sizes integer, intent(in) :: ngpt array sizes integer, intent(in) :: nmom2 array sizes real(kind=wp), intent(inout), dimension(ncol,nlay,ngpt) :: tau1 optical properties to be modified (defined on g-points) real(kind=wp), intent(inout), dimension(ncol,nlay,ngpt) :: ssa1 optical properties to be modified (defined on g-points) real(kind=wp), intent(inout), dimension(ncol,nlay,ngpt) :: g1 optical properties to be modified (defined on g-points) real(kind=wp), intent(in), dimension(ncol,nlay,nbnd) :: tau2 optical properties to be added to original (defined on bands) real(kind=wp), intent(in), dimension(ncol,nlay,nbnd) :: ssa2 optical properties to be added to original (defined on bands) real(kind=wp), intent(in), dimension(nmom2, ncol,nlay,nbnd) :: p2 moments of the phase function to be added integer, intent(in) :: nbnd array sizes integer, intent(in), dimension(2,nbnd) :: gpt_lims Starting and ending gpoint for each band public pure subroutine inc_nstream_by_1scalar_bybnd (ncol, nlay, ngpt, tau1, ssa1, tau2, nbnd, gpt_lims) bind(C, name=\"0\") increment n -stream optical properties defined on g-points with absorption optical depth defined on bands Arguments Type Intent Optional Attributes Name integer, intent(in) :: ncol array sizes integer, intent(in) :: nlay array sizes integer, intent(in) :: ngpt array sizes real(kind=wp), intent(inout), dimension(ncol,nlay,ngpt) :: tau1 optical properties to be modified (defined on g-points) real(kind=wp), intent(inout), dimension(ncol,nlay,ngpt) :: ssa1 optical properties to be modified (defined on g-points) real(kind=wp), intent(in), dimension(ncol,nlay,nbnd) :: tau2 optical properties to be added to original (defined on bands) integer, intent(in) :: nbnd array sizes integer, intent(in), dimension(2,nbnd) :: gpt_lims Starting and ending gpoint for each band public pure subroutine inc_nstream_by_2stream_bybnd (ncol, nlay, ngpt, nmom1, tau1, ssa1, p1, tau2, ssa2, g2, nbnd, gpt_lims) bind(C, name=\"0\") increment n-stream optical properties defined on g-points with 2-stream properties set defined on bands Arguments Type Intent Optional Attributes Name integer, intent(in) :: ncol array sizes integer, intent(in) :: nlay array sizes integer, intent(in) :: ngpt array sizes integer, intent(in) :: nmom1 array sizes real(kind=wp), intent(inout), dimension(ncol,nlay,ngpt) :: tau1 optical properties to be modified (defined on g-points) real(kind=wp), intent(inout), dimension(ncol,nlay,ngpt) :: ssa1 optical properties to be modified (defined on g-points) real(kind=wp), intent(inout), dimension(nmom1, ncol,nlay,ngpt) :: p1 moments of the phase function be modified real(kind=wp), intent(in), dimension(ncol,nlay,nbnd) :: tau2 optical properties to be added to original (defined on bands) real(kind=wp), intent(in), dimension(ncol,nlay,nbnd) :: ssa2 optical properties to be added to original (defined on bands) real(kind=wp), intent(in), dimension(ncol,nlay,nbnd) :: g2 optical properties to be added to original (defined on bands) integer, intent(in) :: nbnd array sizes integer, intent(in), dimension(2,nbnd) :: gpt_lims Starting and ending gpoint for each band public pure subroutine inc_nstream_by_nstream_bybnd (ncol, nlay, ngpt, nmom1, nmom2, tau1, ssa1, p1, tau2, ssa2, p2, nbnd, gpt_lims) bind(C, name=\"0\") increment n -stream optical properties defined on g-points with a second set defined on bands Arguments Type Intent Optional Attributes Name integer, intent(in) :: ncol array sizes integer, intent(in) :: nlay array sizes integer, intent(in) :: ngpt array sizes integer, intent(in) :: nmom1 array sizes integer, intent(in) :: nmom2 array sizes real(kind=wp), intent(inout), dimension(ncol,nlay,ngpt) :: tau1 optical properties to be modified (defined on g-points) real(kind=wp), intent(inout), dimension(ncol,nlay,ngpt) :: ssa1 optical properties to be modified (defined on g-points) real(kind=wp), intent(inout), dimension(nmom1, ncol,nlay,ngpt) :: p1 moments of the phase function be modified real(kind=wp), intent(in), dimension(ncol,nlay,nbnd) :: tau2 optical properties to be added to original (defined on bands) real(kind=wp), intent(in), dimension(ncol,nlay,nbnd) :: ssa2 optical properties to be added to original (defined on bands) real(kind=wp), intent(in), dimension(nmom2, ncol,nlay,nbnd) :: p2 moments of the phase function to be added integer, intent(in) :: nbnd array sizes integer, intent(in), dimension(2,nbnd) :: gpt_lims Starting and ending gpoint for each band public pure subroutine increment_1scalar_by_1scalar (ncol, nlay, ngpt, tau1, tau2) bind(C, name=\"0\") increase one absorption optical depth by a second value Arguments Type Intent Optional Attributes Name integer, intent(in) :: ncol array sizes integer, intent(in) :: nlay array sizes integer, intent(in) :: ngpt array sizes real(kind=wp), intent(inout), dimension(ncol,nlay,ngpt) :: tau1 optical properties to be modified real(kind=wp), intent(in), dimension(ncol,nlay,ngpt) :: tau2 optical properties to be added to original public pure subroutine increment_1scalar_by_2stream (ncol, nlay, ngpt, tau1, tau2, ssa2) bind(C, name=\"0\") increase absorption optical depth with extinction optical depth (2-stream form) Arguments Type Intent Optional Attributes Name integer, intent(in) :: ncol array sizes integer, intent(in) :: nlay array sizes integer, intent(in) :: ngpt array sizes real(kind=wp), intent(inout), dimension(ncol,nlay,ngpt) :: tau1 optical properties to be modified real(kind=wp), intent(in), dimension(ncol,nlay,ngpt) :: tau2 optical properties to be added to original real(kind=wp), intent(in), dimension(ncol,nlay,ngpt) :: ssa2 optical properties to be added to original public pure subroutine increment_1scalar_by_nstream (ncol, nlay, ngpt, tau1, tau2, ssa2) bind(C, name=\"0\") increase absorption optical depth with extinction optical depth (n-stream form) Arguments Type Intent Optional Attributes Name integer, intent(in) :: ncol array sizes integer, intent(in) :: nlay array sizes integer, intent(in) :: ngpt array sizes real(kind=wp), intent(inout), dimension(ncol,nlay,ngpt) :: tau1 optical properties to be modified real(kind=wp), intent(in), dimension(ncol,nlay,ngpt) :: tau2 optical properties to be added to original real(kind=wp), intent(in), dimension(ncol,nlay,ngpt) :: ssa2 optical properties to be added to original public pure subroutine increment_2stream_by_1scalar (ncol, nlay, ngpt, tau1, ssa1, tau2) bind(C, name=\"0\") increment two-stream optical properties with absorption optical depth Arguments Type Intent Optional Attributes Name integer, intent(in) :: ncol array sizes integer, intent(in) :: nlay array sizes integer, intent(in) :: ngpt array sizes real(kind=wp), intent(inout), dimension(ncol,nlay,ngpt) :: tau1 optical properties to be modified real(kind=wp), intent(inout), dimension(ncol,nlay,ngpt) :: ssa1 optical properties to be modified real(kind=wp), intent(in), dimension(ncol,nlay,ngpt) :: tau2 optical properties to be added to original public pure subroutine increment_2stream_by_2stream (ncol, nlay, ngpt, tau1, ssa1, g1, tau2, ssa2, g2) bind(C, name=\"0\") increment two-stream optical properties with a second set Arguments Type Intent Optional Attributes Name integer, intent(in) :: ncol array sizes integer, intent(in) :: nlay array sizes integer, intent(in) :: ngpt array sizes real(kind=wp), intent(inout), dimension(ncol,nlay,ngpt) :: tau1 optical properties to be modified real(kind=wp), intent(inout), dimension(ncol,nlay,ngpt) :: ssa1 optical properties to be modified real(kind=wp), intent(inout), dimension(ncol,nlay,ngpt) :: g1 optical properties to be modified real(kind=wp), intent(in), dimension(ncol,nlay,ngpt) :: tau2 optical properties to be added to original real(kind=wp), intent(in), dimension(ncol,nlay,ngpt) :: ssa2 optical properties to be added to original real(kind=wp), intent(in), dimension(ncol,nlay,ngpt) :: g2 optical properties to be added to original public pure subroutine increment_2stream_by_nstream (ncol, nlay, ngpt, nmom2, tau1, ssa1, g1, tau2, ssa2, p2) bind(C, name=\"0\") increment two-stream optical properties with n -stream Arguments Type Intent Optional Attributes Name integer, intent(in) :: ncol array sizes integer, intent(in) :: nlay array sizes integer, intent(in) :: ngpt array sizes integer, intent(in) :: nmom2 array sizes real(kind=wp), intent(inout), dimension(ncol,nlay,ngpt) :: tau1 optical properties to be modified real(kind=wp), intent(inout), dimension(ncol,nlay,ngpt) :: ssa1 optical properties to be modified real(kind=wp), intent(inout), dimension(ncol,nlay,ngpt) :: g1 optical properties to be modified real(kind=wp), intent(in), dimension(ncol,nlay,ngpt) :: tau2 optical properties to be added to original real(kind=wp), intent(in), dimension(ncol,nlay,ngpt) :: ssa2 optical properties to be added to original real(kind=wp), intent(in), dimension(nmom2, ncol,nlay,ngpt) :: p2 moments of the phase function to be added public pure subroutine increment_nstream_by_1scalar (ncol, nlay, ngpt, tau1, ssa1, tau2) bind(C, name=\"0\") increment n -stream optical properties with absorption optical depth Arguments Type Intent Optional Attributes Name integer, intent(in) :: ncol array sizes integer, intent(in) :: nlay array sizes integer, intent(in) :: ngpt array sizes real(kind=wp), intent(inout), dimension(ncol,nlay,ngpt) :: tau1 optical properties to be modified real(kind=wp), intent(inout), dimension(ncol,nlay,ngpt) :: ssa1 optical properties to be modified real(kind=wp), intent(in), dimension(ncol,nlay,ngpt) :: tau2 optical properties to be added to original public pure subroutine increment_nstream_by_2stream (ncol, nlay, ngpt, nmom1, tau1, ssa1, p1, tau2, ssa2, g2) bind(C, name=\"0\") increment n -stream optical properties with two-stream values Arguments Type Intent Optional Attributes Name integer, intent(in) :: ncol array sizes integer, intent(in) :: nlay array sizes integer, intent(in) :: ngpt array sizes integer, intent(in) :: nmom1 array sizes real(kind=wp), intent(inout), dimension(ncol,nlay,ngpt) :: tau1 optical properties to be modified real(kind=wp), intent(inout), dimension(ncol,nlay,ngpt) :: ssa1 optical properties to be modified real(kind=wp), intent(inout), dimension(nmom1, ncol,nlay,ngpt) :: p1 moments of the phase function be modified real(kind=wp), intent(in), dimension(ncol,nlay,ngpt) :: tau2 optical properties to be added to original real(kind=wp), intent(in), dimension(ncol,nlay,ngpt) :: ssa2 optical properties to be added to original real(kind=wp), intent(in), dimension(ncol,nlay,ngpt) :: g2 optical properties to be added to original public pure subroutine increment_nstream_by_nstream (ncol, nlay, ngpt, nmom1, nmom2, tau1, ssa1, p1, tau2, ssa2, p2) bind(C, name=\"0\") increment one set of n -stream optical properties with another set Arguments Type Intent Optional Attributes Name integer, intent(in) :: ncol array sizes integer, intent(in) :: nlay array sizes integer, intent(in) :: ngpt array sizes integer, intent(in) :: nmom1 array sizes integer, intent(in) :: nmom2 array sizes real(kind=wp), intent(inout), dimension(ncol,nlay,ngpt) :: tau1 optical properties to be modified real(kind=wp), intent(inout), dimension(ncol,nlay,ngpt) :: ssa1 optical properties to be modified real(kind=wp), intent(inout), dimension(nmom1, ncol,nlay,ngpt) :: p1 moments of the phase function be modified real(kind=wp), intent(in), dimension(ncol,nlay,ngpt) :: tau2 optical properties to be added to original real(kind=wp), intent(in), dimension(ncol,nlay,ngpt) :: ssa2 optical properties to be added to original real(kind=wp), intent(in), dimension(nmom2, ncol,nlay,ngpt) :: p2 moments of the phase function to be added","tags":"","loc":"module/mo_optical_props_kernels.html"},{"title":"mo_fluxes_broadband_kernels – RTE kernels","text":"Kernels for computing broadband fluxes Uses iso_c_binding mo_rte_kind module~~mo_fluxes_broadband_kernels~~UsesGraph module~mo_fluxes_broadband_kernels mo_fluxes_broadband_kernels iso_c_binding iso_c_binding module~mo_fluxes_broadband_kernels->iso_c_binding mo_rte_kind mo_rte_kind module~mo_fluxes_broadband_kernels->mo_rte_kind Help × Graph Key Nodes of different colours represent the following: Graph Key Module Module Submodule Submodule Subroutine Subroutine Function Function Program Program This Page's Entity This Page's Entity Solid arrows point from a submodule to the (sub)module which it is\n descended from. Dashed arrows point from a module or program unit to \n modules which it uses. Contents Interfaces net_broadband Subroutines sum_broadband Interfaces public interface net_broadband Interface for computing net flux private subroutine net_broadband_full(ncol, nlev, ngpt, spectral_flux_dn, spectral_flux_up, broadband_flux_net) bind(C, name=\"0\") Spectral reduction over all points for net flux Arguments Type Intent Optional Attributes Name integer, intent(in) :: ncol Array sizes integer, intent(in) :: nlev Array sizes integer, intent(in) :: ngpt Array sizes real(kind=wp), intent(in), dimension(ncol, nlev, ngpt) :: spectral_flux_dn Spectrally-resolved flux up and down real(kind=wp), intent(in), dimension(ncol, nlev, ngpt) :: spectral_flux_up Spectrally-resolved flux up and down real(kind=wp), intent(out), dimension(ncol, nlev) :: broadband_flux_net Net (down minus up) summed over ngpt private subroutine net_broadband_precalc(ncol, nlev, flux_dn, flux_up, broadband_flux_net) bind(C, name=\"0\") Net flux when bradband flux up and down are already available Arguments Type Intent Optional Attributes Name integer, intent(in) :: ncol Array sizes integer, intent(in) :: nlev Array sizes real(kind=wp), intent(in), dimension(ncol, nlev) :: flux_dn Broadband downward and upward fluxes real(kind=wp), intent(in), dimension(ncol, nlev) :: flux_up Broadband downward and upward fluxes real(kind=wp), intent(out), dimension(ncol, nlev) :: broadband_flux_net Net (down minus up) Subroutines public subroutine sum_broadband (ncol, nlev, ngpt, spectral_flux, broadband_flux) bind(C, name=\"0\") Spectral reduction over all points Arguments Type Intent Optional Attributes Name integer, intent(in) :: ncol Array sizes integer, intent(in) :: nlev Array sizes integer, intent(in) :: ngpt Array sizes real(kind=wp), intent(in), dimension(ncol, nlev, ngpt) :: spectral_flux Spectrally-resolved flux real(kind=wp), intent(out), dimension(ncol, nlev) :: broadband_flux Sum of spectrally-resolved flux over ngpt","tags":"","loc":"module/mo_fluxes_broadband_kernels.html"},{"title":"mo_rte_solver_kernels – RTE kernels","text":"Numeric calculations for radiative transfer solvers Emission/absorption (no-scattering) calculations solver for multi-angle Gaussian quadrature solver for a single angle, calling source function computation (linear-in-tau) transport Extinction-only calculation (direct solar beam) Two-stream calculations:\n solvers for LW and SW with different boundary conditions and source functions source function calculation for LW, SW two-stream calculations for LW, SW (using different assumtions about phase function) transport (adding) Application of boundary conditions Uses iso_c_binding mo_rte_util_array mo_rte_kind module~~mo_rte_solver_kernels~~UsesGraph module~mo_rte_solver_kernels mo_rte_solver_kernels iso_c_binding iso_c_binding module~mo_rte_solver_kernels->iso_c_binding module~mo_rte_util_array~2 mo_rte_util_array module~mo_rte_solver_kernels->module~mo_rte_util_array~2 mo_rte_kind mo_rte_kind module~mo_rte_solver_kernels->mo_rte_kind module~mo_rte_util_array~2->mo_rte_kind Help × Graph Key Nodes of different colours represent the following: Graph Key Module Module Submodule Submodule Subroutine Subroutine Function Function Program Program This Page's Entity This Page's Entity Solid arrows point from a submodule to the (sub)module which it is\n descended from. Dashed arrows point from a module or program unit to \n modules which it uses. Contents Subroutines lw_solver_2stream lw_solver_noscat sw_solver_2stream sw_solver_noscat Subroutines public subroutine lw_solver_2stream (ncol, nlay, ngpt, top_at_1, tau, ssa, g, lay_source, lev_source, sfc_emis, sfc_src, inc_flux, flux_up, flux_dn) bind(C, name=\"0\") Longwave two-stream calculation:\n - combine RRTMGP-specific sources at levels\n - compute layer reflectance, transmittance\n - compute total source function at levels using linear-in-tau\n - transport Arguments Type Intent Optional Attributes Name integer, intent(in) :: ncol Number of columns, layers, g-points integer, intent(in) :: nlay Number of columns, layers, g-points integer, intent(in) :: ngpt Number of columns, layers, g-points logical(kind=wl), intent(in) :: top_at_1 ilay = 1 is the top of the atmosphere? real(kind=wp), intent(in), dimension(ncol,nlay, ngpt) :: tau Optical thickness, single-scattering albedo, asymmetry parameter [] real(kind=wp), intent(in), dimension(ncol,nlay, ngpt) :: ssa Optical thickness, single-scattering albedo, asymmetry parameter [] real(kind=wp), intent(in), dimension(ncol,nlay, ngpt) :: g Optical thickness, single-scattering albedo, asymmetry parameter [] real(kind=wp), intent(in), dimension(ncol,nlay, ngpt) :: lay_source Planck source at layer average temperature [W/m2] real(kind=wp), intent(in), dimension(ncol,nlay+1,ngpt) :: lev_source Planck source at layer edge temperature [W/m2] real(kind=wp), intent(in), dimension(ncol, ngpt) :: sfc_emis Surface emissivity [] real(kind=wp), intent(in), dimension(ncol, ngpt) :: sfc_src Surface source function [W/m2] real(kind=wp), intent(in), dimension(ncol, ngpt) :: inc_flux Incident diffuse flux, probably 0 [W/m2] real(kind=wp), intent(out), dimension(ncol,nlay+1,ngpt) :: flux_up Fluxes [W/m2] real(kind=wp), intent(out), dimension(ncol,nlay+1,ngpt) :: flux_dn Fluxes [W/m2] public subroutine lw_solver_noscat (ncol, nlay, ngpt, top_at_1, nmus, Ds, weights, tau, lay_source, lev_source, sfc_emis, sfc_src, inc_flux, flux_up, flux_dn, do_broadband, broadband_up, broadband_dn, do_Jacobians, sfc_srcJac, flux_upJac, do_rescaling, ssa, g) bind(C, name=\"0\") LW transport, no scattering, multi-angle quadrature\n Users provide a set of weights and quadrature angles\n Routine sums over single-angle solutions for each sets of angles/weights Arguments Type Intent Optional Attributes Name integer, intent(in) :: ncol Number of columns, layers, g-points integer, intent(in) :: nlay Number of columns, layers, g-points integer, intent(in) :: ngpt Number of columns, layers, g-points logical(kind=wl), intent(in) :: top_at_1 ilay = 1 is the top of the atmosphere? integer, intent(in) :: nmus number of quadrature angles real(kind=wp), intent(in), dimension (ncol, ngpt, nmus) :: Ds quadrature secants real(kind=wp), intent(in), dimension(nmus) :: weights quadrature weights real(kind=wp), intent(in), dimension(ncol,nlay, ngpt) :: tau Absorption optical thickness [] real(kind=wp), intent(in), dimension(ncol,nlay, ngpt) :: lay_source Planck source at layer average temperature [W/m2] real(kind=wp), intent(in), dimension(ncol,nlay+1,ngpt) :: lev_source Planck source at layer edge for radiation[W/m2] real(kind=wp), intent(in), dimension(ncol, ngpt) :: sfc_emis Surface emissivity [] real(kind=wp), intent(in), dimension(ncol, ngpt) :: sfc_src Surface source function [W/m2] real(kind=wp), intent(in), dimension(ncol, ngpt) :: inc_flux Incident diffuse flux, probably 0 [W/m2] real(kind=wp), intent(out), dimension(ncol,nlay+1,ngpt), target :: flux_up Fluxes [W/m2] real(kind=wp), intent(out), dimension(ncol,nlay+1,ngpt), target :: flux_dn Fluxes [W/m2] logical(kind=wl), intent(in) :: do_broadband real(kind=wp), intent(out), dimension(ncol,nlay+1 ), target :: broadband_up Spectrally-integrated fluxes [W/m2] real(kind=wp), intent(out), dimension(ncol,nlay+1 ), target :: broadband_dn Spectrally-integrated fluxes [W/m2] logical(kind=wl), intent(in) :: do_Jacobians compute Jacobian with respect to surface temeprature? real(kind=wp), intent(in), dimension(ncol ,ngpt) :: sfc_srcJac surface temperature Jacobian of surface source function [W/m2/K] real(kind=wp), intent(out), dimension(ncol,nlay+1 ), target :: flux_upJac surface temperature Jacobian of Radiances [W/m2-str / K] logical(kind=wl), intent(in) :: do_rescaling Approximate treatment of scattering (10.1175/JAS-D-18-0014.1) real(kind=wp), intent(in), dimension(ncol,nlay ,ngpt) :: ssa single-scattering albedo, asymmetry parameter real(kind=wp), intent(in), dimension(ncol,nlay ,ngpt) :: g single-scattering albedo, asymmetry parameter public subroutine sw_solver_2stream (ncol, nlay, ngpt, top_at_1, tau, ssa, g, mu0, sfc_alb_dir, sfc_alb_dif, inc_flux_dir, flux_up, flux_dn, flux_dir, has_dif_bc, inc_flux_dif, do_broadband, broadband_up, broadband_dn, broadband_dir) bind(C, name=\"0\") Shortwave two-stream calculation:\n compute layer reflectance, transmittance\n compute solar source function for diffuse radiation\n transport Arguments Type Intent Optional Attributes Name integer, intent(in) :: ncol Number of columns, layers, g-points integer, intent(in) :: nlay Number of columns, layers, g-points integer, intent(in) :: ngpt Number of columns, layers, g-points logical(kind=wl), intent(in) :: top_at_1 ilay = 1 is the top of the atmosphere? real(kind=wp), intent(in), dimension(ncol,nlay, ngpt) :: tau Optical thickness, single-scattering albedo, asymmetry parameter [] real(kind=wp), intent(in), dimension(ncol,nlay, ngpt) :: ssa Optical thickness, single-scattering albedo, asymmetry parameter [] real(kind=wp), intent(in), dimension(ncol,nlay, ngpt) :: g Optical thickness, single-scattering albedo, asymmetry parameter [] real(kind=wp), intent(in), dimension(ncol,nlay ) :: mu0 cosine of solar zenith angle real(kind=wp), intent(in), dimension(ncol, ngpt) :: sfc_alb_dir Spectral surface albedo for direct and diffuse radiation real(kind=wp), intent(in), dimension(ncol, ngpt) :: sfc_alb_dif Spectral surface albedo for direct and diffuse radiation real(kind=wp), intent(in), dimension(ncol, ngpt) :: inc_flux_dir Direct beam incident flux real(kind=wp), intent(out), dimension(ncol,nlay+1,ngpt), target :: flux_up Fluxes [W/m2] real(kind=wp), intent(out), dimension(ncol,nlay+1,ngpt), target :: flux_dn Fluxes [W/m2] real(kind=wp), intent(out), dimension(ncol,nlay+1,ngpt), target :: flux_dir Fluxes [W/m2] logical(kind=wl), intent(in) :: has_dif_bc Is a boundary condition for diffuse flux supplied? real(kind=wp), intent(in), dimension(ncol, ngpt) :: inc_flux_dif Boundary condition for diffuse flux [W/m2] logical(kind=wl), intent(in) :: do_broadband Provide broadband-integrated, not spectrally-resolved, fluxes? real(kind=wp), intent(out), dimension(ncol,nlay+1 ) :: broadband_up Broadband integrated fluxes real(kind=wp), intent(out), dimension(ncol,nlay+1 ) :: broadband_dn Broadband integrated fluxes real(kind=wp), intent(out), dimension(ncol,nlay+1 ) :: broadband_dir Broadband integrated fluxes public pure subroutine sw_solver_noscat (ncol, nlay, ngpt, top_at_1, tau, mu0, inc_flux_dir, flux_dir) bind(C, name=\"0\") Arguments Type Intent Optional Attributes Name integer, intent(in) :: ncol Number of columns, layers, g-points integer, intent(in) :: nlay Number of columns, layers, g-points integer, intent(in) :: ngpt Number of columns, layers, g-points logical(kind=wl), intent(in) :: top_at_1 ilay = 1 is the top of the atmosphere? real(kind=wp), intent(in), dimension(ncol,nlay, ngpt) :: tau Absorption optical thickness [] real(kind=wp), intent(in), dimension(ncol,nlay ) :: mu0 cosine of solar zenith angle real(kind=wp), intent(in), dimension(ncol, ngpt) :: inc_flux_dir Direct beam incident flux [W/m2] real(kind=wp), intent(out), dimension(ncol,nlay+1,ngpt) :: flux_dir Direct-beam flux, spectral [W/m2]","tags":"","loc":"module/mo_rte_solver_kernels.html"},{"title":"mo_rte_util_array – RTE kernels","text":"Uses mo_rte_kind module~~mo_rte_util_array~2~~UsesGraph module~mo_rte_util_array~2 mo_rte_util_array mo_rte_kind mo_rte_kind module~mo_rte_util_array~2->mo_rte_kind Help × Graph Key Nodes of different colours represent the following: Graph Key Module Module Submodule Submodule Subroutine Subroutine Function Function Program Program This Page's Entity This Page's Entity Solid arrows point from a submodule to the (sub)module which it is\n descended from. Dashed arrows point from a module or program unit to \n modules which it uses. Used by module~~mo_rte_util_array~2~~UsedByGraph module~mo_rte_util_array~2 mo_rte_util_array module~mo_rte_solver_kernels mo_rte_solver_kernels module~mo_rte_solver_kernels->module~mo_rte_util_array~2 Help × Graph Key Nodes of different colours represent the following: Graph Key Module Module Submodule Submodule Subroutine Subroutine Function Function Program Program This Page's Entity This Page's Entity Solid arrows point from a submodule to the (sub)module which it is\n descended from. Dashed arrows point from a module or program unit to \n modules which it uses. Contents Interfaces zero_array Subroutines zero_array_1D zero_array_2D zero_array_3D zero_array_4D Interfaces public interface zero_array Efficiently set arrays to zero public subroutine zero_array_1D (ni, array) bind(C, name=\"0\") Arguments Type Intent Optional Attributes Name integer, intent(in) :: ni real(kind=wp), intent(out), dimension(ni) :: array public subroutine zero_array_2D (ni, nj, array) bind(C, name=\"0\") Arguments Type Intent Optional Attributes Name integer, intent(in) :: ni integer, intent(in) :: nj real(kind=wp), intent(out), dimension(ni, nj) :: array public subroutine zero_array_3D (ni, nj, nk, array) bind(C, name=\"0\") Arguments Type Intent Optional Attributes Name integer, intent(in) :: ni integer, intent(in) :: nj integer, intent(in) :: nk real(kind=wp), intent(out), dimension(ni, nj, nk) :: array public subroutine zero_array_4D (ni, nj, nk, nl, array) bind(C, name=\"0\") Arguments Type Intent Optional Attributes Name integer, intent(in) :: ni integer, intent(in) :: nj integer, intent(in) :: nk integer, intent(in) :: nl real(kind=wp), intent(out), dimension(ni, nj, nk, nl) :: array Subroutines public subroutine zero_array_1D (ni, array) bind(C, name=\"0\") Arguments Type Intent Optional Attributes Name integer, intent(in) :: ni real(kind=wp), intent(out), dimension(ni) :: array public subroutine zero_array_2D (ni, nj, array) bind(C, name=\"0\") Arguments Type Intent Optional Attributes Name integer, intent(in) :: ni integer, intent(in) :: nj real(kind=wp), intent(out), dimension(ni, nj) :: array public subroutine zero_array_3D (ni, nj, nk, array) bind(C, name=\"0\") Arguments Type Intent Optional Attributes Name integer, intent(in) :: ni integer, intent(in) :: nj integer, intent(in) :: nk real(kind=wp), intent(out), dimension(ni, nj, nk) :: array public subroutine zero_array_4D (ni, nj, nk, nl, array) bind(C, name=\"0\") Arguments Type Intent Optional Attributes Name integer, intent(in) :: ni integer, intent(in) :: nj integer, intent(in) :: nk integer, intent(in) :: nl real(kind=wp), intent(out), dimension(ni, nj, nk, nl) :: array","tags":"","loc":"module/mo_rte_util_array~2.html"},{"title":"mo_optical_props_kernels – RTE kernels","text":"Kernels for arrays of optical properties: - delta-scaling\n- adding two sets of properties\n- extracting subsets along the column dimension Uses iso_c_binding mo_rte_kind module~~mo_optical_props_kernels~2~~UsesGraph module~mo_optical_props_kernels~2 mo_optical_props_kernels iso_c_binding iso_c_binding module~mo_optical_props_kernels~2->iso_c_binding mo_rte_kind mo_rte_kind module~mo_optical_props_kernels~2->mo_rte_kind Help × Graph Key Nodes of different colours represent the following: Graph Key Module Module Submodule Submodule Subroutine Subroutine Function Function Program Program This Page's Entity This Page's Entity Solid arrows point from a submodule to the (sub)module which it is\n descended from. Dashed arrows point from a module or program unit to \n modules which it uses. Contents Interfaces delta_scale_2str_kernel extract_subset inc_1scalar_by_1scalar_bybnd inc_1scalar_by_2stream_bybnd inc_1scalar_by_nstream_bybnd inc_2stream_by_1scalar_bybnd inc_2stream_by_2stream_bybnd inc_2stream_by_nstream_bybnd inc_nstream_by_1scalar_bybnd inc_nstream_by_2stream_bybnd inc_nstream_by_nstream_bybnd increment_1scalar_by_1scalar increment_1scalar_by_2stream increment_1scalar_by_nstream increment_2stream_by_1scalar increment_2stream_by_2stream increment_2stream_by_nstream increment_nstream_by_1scalar increment_nstream_by_2stream increment_nstream_by_nstream Interfaces public interface delta_scale_2str_kernel public pure subroutine delta_scale_2str_f_k(ncol, nlay, ngpt, tau, ssa, g, f) bind(C, name=\"0\") Delta-scale two-stream optical properties given user-provided value of (forward scattering) Arguments Type Intent Optional Attributes Name integer, intent(in) :: ncol Array sizes integer, intent(in) :: nlay Array sizes integer, intent(in) :: ngpt Array sizes real(kind=wp), intent(inout), dimension(ncol, nlay, ngpt) :: tau Optical depth, single-scattering albedo, asymmetry parameter real(kind=wp), intent(inout), dimension(ncol, nlay, ngpt) :: ssa Optical depth, single-scattering albedo, asymmetry parameter real(kind=wp), intent(inout), dimension(ncol, nlay, ngpt) :: g Optical depth, single-scattering albedo, asymmetry parameter real(kind=wp), intent(in), dimension(ncol, nlay, ngpt) :: f User-provided forward-scattering fraction public pure subroutine delta_scale_2str_k(ncol, nlay, ngpt, tau, ssa, g) bind(C, name=\"0\") Delta-scale assuming forward-scatternig fraction is the square of the asymmetry parameter\n i.e. Arguments Type Intent Optional Attributes Name integer, intent(in) :: ncol Array sizes integer, intent(in) :: nlay Array sizes integer, intent(in) :: ngpt Array sizes real(kind=wp), intent(inout), dimension(ncol, nlay, ngpt) :: tau Optical depth, single-scattering albedo, asymmetry parameter real(kind=wp), intent(inout), dimension(ncol, nlay, ngpt) :: ssa Optical depth, single-scattering albedo, asymmetry parameter real(kind=wp), intent(inout), dimension(ncol, nlay, ngpt) :: g Optical depth, single-scattering albedo, asymmetry parameter public interface extract_subset Extract a subset from the first dimension (normally columns) of a 3D field.\n Applicable to most variables e.g. tau, ssa, g public pure subroutine extract_subset_absorption_tau(ncol, nlay, ngpt, tau_in, ssa_in, colS, colE, tau_out) bind(C, name=\"0\") Extract the absorption optical thickness Arguments Type Intent Optional Attributes Name integer, intent(in) :: ncol Array sizes integer, intent(in) :: nlay Array sizes integer, intent(in) :: ngpt Array sizes real(kind=wp), intent(in), dimension(ncol,nlay,ngpt) :: tau_in Optical thickness, single scattering albedo real(kind=wp), intent(in), dimension(ncol,nlay,ngpt) :: ssa_in Optical thickness, single scattering albedo integer, intent(in) :: colS Starting and ending index integer, intent(in) :: colE Starting and ending index real(kind=wp), intent(out), dimension(colE-colS+1, nlay,ngpt) :: tau_out absorption optical thickness subset public pure subroutine extract_subset_dim1_3d(ncol, nlay, ngpt, array_in, colS, colE, array_out) bind(C, name=\"0\") Arguments Type Intent Optional Attributes Name integer, intent(in) :: ncol Array sizes integer, intent(in) :: nlay Array sizes integer, intent(in) :: ngpt Array sizes real(kind=wp), intent(in), dimension(ncol,nlay,ngpt) :: array_in Array to subset integer, intent(in) :: colS Starting and ending index integer, intent(in) :: colE Starting and ending index real(kind=wp), intent(out), dimension(colE-colS+1, nlay,ngpt) :: array_out subset of the input array public pure subroutine extract_subset_dim2_4d(nmom, ncol, nlay, ngpt, array_in, colS, colE, array_out) bind(C, name=\"0\") Extract a subset from the second dimension (normally columns) of a 4D field.\n Applicable to phase function moments, where the first dimension is the moment Arguments Type Intent Optional Attributes Name integer, intent(in) :: nmom Array sizes integer, intent(in) :: ncol Array sizes integer, intent(in) :: nlay Array sizes integer, intent(in) :: ngpt Array sizes real(kind=wp), intent(in), dimension(nmom,ncol,nlay,ngpt) :: array_in Array to subset integer, intent(in) :: colS Starting and ending index integer, intent(in) :: colE Starting and ending index real(kind=wp), intent(out), dimension(nmom,colE-colS+1, nlay,ngpt) :: array_out subset of the input array interface increase one absorption optical depth defined on g-points by a second value defined on bands public pure subroutine inc_1scalar_by_1scalar_bybnd(ncol, nlay, ngpt, tau1, tau2, nbnd, gpt_lims) bind(C, name=\"0\") Arguments Type Intent Optional Attributes Name integer, intent(in) :: ncol array sizes integer, intent(in) :: nlay array sizes integer, intent(in) :: ngpt array sizes real(kind=wp), intent(inout), dimension(ncol,nlay,ngpt) :: tau1 optical properties to be modified (defined on g-points) real(kind=wp), intent(in), dimension(ncol,nlay,nbnd) :: tau2 optical properties to be added to original (defined on bands) integer, intent(in) :: nbnd array sizes integer, intent(in), dimension(2,nbnd) :: gpt_lims Starting and ending gpoint for each band interface increase absorption optical depth defined on g-points with extinction optical depth (2-stream form) defined on bands public pure subroutine inc_1scalar_by_2stream_bybnd(ncol, nlay, ngpt, tau1, tau2, ssa2, nbnd, gpt_lims) bind(C, name=\"0\") Arguments Type Intent Optional Attributes Name integer, intent(in) :: ncol array sizes integer, intent(in) :: nlay array sizes integer, intent(in) :: ngpt array sizes real(kind=wp), intent(inout), dimension(ncol,nlay,ngpt) :: tau1 optical properties to be modified (defined on g-points) real(kind=wp), intent(in), dimension(ncol,nlay,nbnd) :: tau2 optical properties to be added to original (defined on bands) real(kind=wp), intent(in), dimension(ncol,nlay,nbnd) :: ssa2 optical properties to be added to original (defined on bands) integer, intent(in) :: nbnd array sizes integer, intent(in), dimension(2,nbnd) :: gpt_lims Starting and ending gpoint for each band interface increase absorption optical depth defined on g-points with extinction optical depth (n-stream form) defined on bands public pure subroutine inc_1scalar_by_nstream_bybnd(ncol, nlay, ngpt, tau1, tau2, ssa2, nbnd, gpt_lims) bind(C, name=\"0\") Arguments Type Intent Optional Attributes Name integer, intent(in) :: ncol array sizes integer, intent(in) :: nlay array sizes integer, intent(in) :: ngpt array sizes real(kind=wp), intent(inout), dimension(ncol,nlay,ngpt) :: tau1 optical properties to be modified (defined on g-points) real(kind=wp), intent(in), dimension(ncol,nlay,nbnd) :: tau2 optical properties to be added to original (defined on bands) real(kind=wp), intent(in), dimension(ncol,nlay,nbnd) :: ssa2 optical properties to be added to original (defined on bands) integer, intent(in) :: nbnd array sizes integer, intent(in), dimension(2,nbnd) :: gpt_lims Starting and ending gpoint for each band interface increment two-stream optical properties defined on g-points with absorption optical depth defined on bands public pure subroutine inc_2stream_by_1scalar_bybnd(ncol, nlay, ngpt, tau1, ssa1, tau2, nbnd, gpt_lims) bind(C, name=\"0\") Arguments Type Intent Optional Attributes Name integer, intent(in) :: ncol array sizes integer, intent(in) :: nlay array sizes integer, intent(in) :: ngpt array sizes real(kind=wp), intent(inout), dimension(ncol,nlay,ngpt) :: tau1 optical properties to be modified (defined on g-points) real(kind=wp), intent(inout), dimension(ncol,nlay,ngpt) :: ssa1 optical properties to be modified (defined on g-points) real(kind=wp), intent(in), dimension(ncol,nlay,nbnd) :: tau2 optical properties to be added to original (defined on bands) integer, intent(in) :: nbnd array sizes integer, intent(in), dimension(2,nbnd) :: gpt_lims Starting and ending gpoint for each band interface increment 2-stream optical properties defined on g-points with another set defined on bands public pure subroutine inc_2stream_by_2stream_bybnd(ncol, nlay, ngpt, tau1, ssa1, g1, tau2, ssa2, g2, nbnd, gpt_lims) bind(C, name=\"0\") Arguments Type Intent Optional Attributes Name integer, intent(in) :: ncol array sizes integer, intent(in) :: nlay array sizes integer, intent(in) :: ngpt array sizes real(kind=wp), intent(inout), dimension(ncol,nlay,ngpt) :: tau1 optical properties to be modified (defined on g-points) real(kind=wp), intent(inout), dimension(ncol,nlay,ngpt) :: ssa1 optical properties to be modified (defined on g-points) real(kind=wp), intent(inout), dimension(ncol,nlay,ngpt) :: g1 optical properties to be modified (defined on g-points) real(kind=wp), intent(in), dimension(ncol,nlay,nbnd) :: tau2 optical properties to be added to original (defined on bands) real(kind=wp), intent(in), dimension(ncol,nlay,nbnd) :: ssa2 optical properties to be added to original (defined on bands) real(kind=wp), intent(in), dimension(ncol,nlay,nbnd) :: g2 optical properties to be added to original (defined on bands) integer, intent(in) :: nbnd array sizes integer, intent(in), dimension(2,nbnd) :: gpt_lims Starting and ending gpoint for each band interface increment 2-stream optical properties defined on g-points with n -stream properties set defined on bands public pure subroutine inc_2stream_by_nstream_bybnd(ncol, nlay, ngpt, nmom2, tau1, ssa1, g1, tau2, ssa2, p2, nbnd, gpt_lims) bind(C, name=\"0\") Arguments Type Intent Optional Attributes Name integer, intent(in) :: ncol array sizes integer, intent(in) :: nlay array sizes integer, intent(in) :: ngpt array sizes integer, intent(in) :: nmom2 array sizes real(kind=wp), intent(inout), dimension(ncol,nlay,ngpt) :: tau1 optical properties to be modified (defined on g-points) real(kind=wp), intent(inout), dimension(ncol,nlay,ngpt) :: ssa1 optical properties to be modified (defined on g-points) real(kind=wp), intent(inout), dimension(ncol,nlay,ngpt) :: g1 optical properties to be modified (defined on g-points) real(kind=wp), intent(in), dimension(ncol,nlay,nbnd) :: tau2 optical properties to be added to original (defined on bands) real(kind=wp), intent(in), dimension(ncol,nlay,nbnd) :: ssa2 optical properties to be added to original (defined on bands) real(kind=wp), intent(in), dimension(nmom2, ncol,nlay,nbnd) :: p2 moments of the phase function to be added integer, intent(in) :: nbnd array sizes integer, intent(in), dimension(2,nbnd) :: gpt_lims Starting and ending gpoint for each band interface increment n -stream optical properties defined on g-points with absorption optical depth defined on bands public pure subroutine inc_nstream_by_1scalar_bybnd(ncol, nlay, ngpt, tau1, ssa1, tau2, nbnd, gpt_lims) bind(C, name=\"0\") Arguments Type Intent Optional Attributes Name integer, intent(in) :: ncol array sizes integer, intent(in) :: nlay array sizes integer, intent(in) :: ngpt array sizes real(kind=wp), intent(inout), dimension(ncol,nlay,ngpt) :: tau1 optical properties to be modified (defined on g-points) real(kind=wp), intent(inout), dimension(ncol,nlay,ngpt) :: ssa1 optical properties to be modified (defined on g-points) real(kind=wp), intent(in), dimension(ncol,nlay,nbnd) :: tau2 optical properties to be added to original (defined on bands) integer, intent(in) :: nbnd array sizes integer, intent(in), dimension(2,nbnd) :: gpt_lims Starting and ending gpoint for each band interface increment n-stream optical properties defined on g-points with 2-stream properties set defined on bands public pure subroutine inc_nstream_by_2stream_bybnd(ncol, nlay, ngpt, nmom1, tau1, ssa1, p1, tau2, ssa2, g2, nbnd, gpt_lims) bind(C, name=\"0\") Arguments Type Intent Optional Attributes Name integer, intent(in) :: ncol array sizes integer, intent(in) :: nlay array sizes integer, intent(in) :: ngpt array sizes integer, intent(in) :: nmom1 array sizes real(kind=wp), intent(inout), dimension(ncol,nlay,ngpt) :: tau1 optical properties to be modified (defined on g-points) real(kind=wp), intent(inout), dimension(ncol,nlay,ngpt) :: ssa1 optical properties to be modified (defined on g-points) real(kind=wp), intent(inout), dimension(nmom1, ncol,nlay,ngpt) :: p1 moments of the phase function be modified real(kind=wp), intent(in), dimension(ncol,nlay,nbnd) :: tau2 optical properties to be added to original (defined on bands) real(kind=wp), intent(in), dimension(ncol,nlay,nbnd) :: ssa2 optical properties to be added to original (defined on bands) real(kind=wp), intent(in), dimension(ncol,nlay,nbnd) :: g2 optical properties to be added to original (defined on bands) integer, intent(in) :: nbnd array sizes integer, intent(in), dimension(2,nbnd) :: gpt_lims Starting and ending gpoint for each band interface increment n -stream optical properties defined on g-points with a second set defined on bands public pure subroutine inc_nstream_by_nstream_bybnd(ncol, nlay, ngpt, nmom1, nmom2, tau1, ssa1, p1, tau2, ssa2, p2, nbnd, gpt_lims) bind(C, name=\"0\") Arguments Type Intent Optional Attributes Name integer, intent(in) :: ncol array sizes integer, intent(in) :: nlay array sizes integer, intent(in) :: ngpt array sizes integer, intent(in) :: nmom1 array sizes integer, intent(in) :: nmom2 array sizes real(kind=wp), intent(inout), dimension(ncol,nlay,ngpt) :: tau1 optical properties to be modified (defined on g-points) real(kind=wp), intent(inout), dimension(ncol,nlay,ngpt) :: ssa1 optical properties to be modified (defined on g-points) real(kind=wp), intent(inout), dimension(nmom1, ncol,nlay,ngpt) :: p1 moments of the phase function be modified real(kind=wp), intent(in), dimension(ncol,nlay,nbnd) :: tau2 optical properties to be added to original (defined on bands) real(kind=wp), intent(in), dimension(ncol,nlay,nbnd) :: ssa2 optical properties to be added to original (defined on bands) real(kind=wp), intent(in), dimension(nmom2, ncol,nlay,nbnd) :: p2 moments of the phase function to be added integer, intent(in) :: nbnd array sizes integer, intent(in), dimension(2,nbnd) :: gpt_lims Starting and ending gpoint for each band interface increase one absorption optical depth by a second value public pure subroutine increment_1scalar_by_1scalar(ncol, nlay, ngpt, tau1, tau2) bind(C, name=\"0\") Arguments Type Intent Optional Attributes Name integer, intent(in) :: ncol array sizes integer, intent(in) :: nlay array sizes integer, intent(in) :: ngpt array sizes real(kind=wp), intent(inout), dimension(ncol,nlay,ngpt) :: tau1 optical properties to be modified real(kind=wp), intent(in), dimension(ncol,nlay,ngpt) :: tau2 optical properties to be added to original interface increase absorption optical depth with extinction optical depth (2-stream form) public pure subroutine increment_1scalar_by_2stream(ncol, nlay, ngpt, tau1, tau2, ssa2) bind(C, name=\"0\") Arguments Type Intent Optional Attributes Name integer, intent(in) :: ncol array sizes integer, intent(in) :: nlay array sizes integer, intent(in) :: ngpt array sizes real(kind=wp), intent(inout), dimension(ncol,nlay,ngpt) :: tau1 optical properties to be modified real(kind=wp), intent(in), dimension(ncol,nlay,ngpt) :: tau2 optical properties to be added to original real(kind=wp), intent(in), dimension(ncol,nlay,ngpt) :: ssa2 optical properties to be added to original interface increase absorption optical depth with extinction optical depth (n-stream form) public pure subroutine increment_1scalar_by_nstream(ncol, nlay, ngpt, tau1, tau2, ssa2) bind(C, name=\"0\") Arguments Type Intent Optional Attributes Name integer, intent(in) :: ncol array sizes integer, intent(in) :: nlay array sizes integer, intent(in) :: ngpt array sizes real(kind=wp), intent(inout), dimension(ncol,nlay,ngpt) :: tau1 optical properties to be modified real(kind=wp), intent(in), dimension(ncol,nlay,ngpt) :: tau2 optical properties to be added to original real(kind=wp), intent(in), dimension(ncol,nlay,ngpt) :: ssa2 optical properties to be added to original interface increment two-stream optical properties with absorption optical depth public pure subroutine increment_2stream_by_1scalar(ncol, nlay, ngpt, tau1, ssa1, tau2) bind(C, name=\"0\") Arguments Type Intent Optional Attributes Name integer, intent(in) :: ncol array sizes integer, intent(in) :: nlay array sizes integer, intent(in) :: ngpt array sizes real(kind=wp), intent(inout), dimension(ncol,nlay,ngpt) :: tau1 optical properties to be modified real(kind=wp), intent(inout), dimension(ncol,nlay,ngpt) :: ssa1 optical properties to be modified real(kind=wp), intent(in), dimension(ncol,nlay,ngpt) :: tau2 optical properties to be added to original interface increment two-stream optical properties with a second set public pure subroutine increment_2stream_by_2stream(ncol, nlay, ngpt, tau1, ssa1, g1, tau2, ssa2, g2) bind(C, name=\"0\") Arguments Type Intent Optional Attributes Name integer, intent(in) :: ncol array sizes integer, intent(in) :: nlay array sizes integer, intent(in) :: ngpt array sizes real(kind=wp), intent(inout), dimension(ncol,nlay,ngpt) :: tau1 optical properties to be modified real(kind=wp), intent(inout), dimension(ncol,nlay,ngpt) :: ssa1 optical properties to be modified real(kind=wp), intent(inout), dimension(ncol,nlay,ngpt) :: g1 optical properties to be modified real(kind=wp), intent(in), dimension(ncol,nlay,ngpt) :: tau2 optical properties to be added to original real(kind=wp), intent(in), dimension(ncol,nlay,ngpt) :: ssa2 optical properties to be added to original real(kind=wp), intent(in), dimension(ncol,nlay,ngpt) :: g2 optical properties to be added to original interface increment two-stream optical properties with n -stream public pure subroutine increment_2stream_by_nstream(ncol, nlay, ngpt, nmom2, tau1, ssa1, g1, tau2, ssa2, p2) bind(C, name=\"0\") Arguments Type Intent Optional Attributes Name integer, intent(in) :: ncol array sizes integer, intent(in) :: nlay array sizes integer, intent(in) :: ngpt array sizes integer, intent(in) :: nmom2 array sizes real(kind=wp), intent(inout), dimension(ncol,nlay,ngpt) :: tau1 optical properties to be modified real(kind=wp), intent(inout), dimension(ncol,nlay,ngpt) :: ssa1 optical properties to be modified real(kind=wp), intent(inout), dimension(ncol,nlay,ngpt) :: g1 optical properties to be modified real(kind=wp), intent(in), dimension(ncol,nlay,ngpt) :: tau2 optical properties to be added to original real(kind=wp), intent(in), dimension(ncol,nlay,ngpt) :: ssa2 optical properties to be added to original real(kind=wp), intent(in), dimension(nmom2, ncol,nlay,ngpt) :: p2 moments of the phase function to be added interface increment n -stream optical properties with absorption optical depth public pure subroutine increment_nstream_by_1scalar(ncol, nlay, ngpt, tau1, ssa1, tau2) bind(C, name=\"0\") Arguments Type Intent Optional Attributes Name integer, intent(in) :: ncol array sizes integer, intent(in) :: nlay array sizes integer, intent(in) :: ngpt array sizes real(kind=wp), intent(inout), dimension(ncol,nlay,ngpt) :: tau1 optical properties to be modified real(kind=wp), intent(inout), dimension(ncol,nlay,ngpt) :: ssa1 optical properties to be modified real(kind=wp), intent(in), dimension(ncol,nlay,ngpt) :: tau2 optical properties to be added to original interface increment n -stream optical properties with two-stream values public pure subroutine increment_nstream_by_2stream(ncol, nlay, ngpt, nmom1, tau1, ssa1, p1, tau2, ssa2, g2) bind(C, name=\"0\") Arguments Type Intent Optional Attributes Name integer, intent(in) :: ncol array sizes integer, intent(in) :: nlay array sizes integer, intent(in) :: ngpt array sizes integer, intent(in) :: nmom1 array sizes real(kind=wp), intent(inout), dimension(ncol,nlay,ngpt) :: tau1 optical properties to be modified real(kind=wp), intent(inout), dimension(ncol,nlay,ngpt) :: ssa1 optical properties to be modified real(kind=wp), intent(inout), dimension(nmom1, ncol,nlay,ngpt) :: p1 moments of the phase function be modified real(kind=wp), intent(in), dimension(ncol,nlay,ngpt) :: tau2 optical properties to be added to original real(kind=wp), intent(in), dimension(ncol,nlay,ngpt) :: ssa2 optical properties to be added to original real(kind=wp), intent(in), dimension(ncol,nlay,ngpt) :: g2 optical properties to be added to original interface increment one set of n -stream optical properties with another set public pure subroutine increment_nstream_by_nstream(ncol, nlay, ngpt, nmom1, nmom2, tau1, ssa1, p1, tau2, ssa2, p2) bind(C, name=\"0\") Arguments Type Intent Optional Attributes Name integer, intent(in) :: ncol array sizes integer, intent(in) :: nlay array sizes integer, intent(in) :: ngpt array sizes integer, intent(in) :: nmom1 array sizes integer, intent(in) :: nmom2 array sizes real(kind=wp), intent(inout), dimension(ncol,nlay,ngpt) :: tau1 optical properties to be modified real(kind=wp), intent(inout), dimension(ncol,nlay,ngpt) :: ssa1 optical properties to be modified real(kind=wp), intent(inout), dimension(nmom1, ncol,nlay,ngpt) :: p1 moments of the phase function be modified real(kind=wp), intent(in), dimension(ncol,nlay,ngpt) :: tau2 optical properties to be added to original real(kind=wp), intent(in), dimension(ncol,nlay,ngpt) :: ssa2 optical properties to be added to original real(kind=wp), intent(in), dimension(nmom2, ncol,nlay,ngpt) :: p2 moments of the phase function to be added","tags":"","loc":"module/mo_optical_props_kernels~2.html"},{"title":"mo_fluxes_broadband_kernels – RTE kernels","text":"Kernels for computing broadband fluxes Uses iso_c_binding mo_rte_kind module~~mo_fluxes_broadband_kernels~2~~UsesGraph module~mo_fluxes_broadband_kernels~2 mo_fluxes_broadband_kernels iso_c_binding iso_c_binding module~mo_fluxes_broadband_kernels~2->iso_c_binding mo_rte_kind mo_rte_kind module~mo_fluxes_broadband_kernels~2->mo_rte_kind Help × Graph Key Nodes of different colours represent the following: Graph Key Module Module Submodule Submodule Subroutine Subroutine Function Function Program Program This Page's Entity This Page's Entity Solid arrows point from a submodule to the (sub)module which it is\n descended from. Dashed arrows point from a module or program unit to \n modules which it uses. Contents Interfaces net_broadband sum_broadband Interfaces public interface net_broadband Spectral reduction over all points for net flux\n Overloaded - which routine is called depends on arguments private subroutine net_broadband_full(ncol, nlev, ngpt, spectral_flux_dn, spectral_flux_up, broadband_flux_net) bind(C, name=\"0\") Net flux from g-point fluxes up and down Arguments Type Intent Optional Attributes Name integer, intent(in) :: ncol Array sizes integer, intent(in) :: nlev Array sizes integer, intent(in) :: ngpt Array sizes real(kind=wp), intent(in), dimension(ncol, nlev, ngpt) :: spectral_flux_dn Spectrally-resolved flux up and down real(kind=wp), intent(in), dimension(ncol, nlev, ngpt) :: spectral_flux_up Spectrally-resolved flux up and down real(kind=wp), intent(out), dimension(ncol, nlev) :: broadband_flux_net Net (down minus up) summed over ngpt private subroutine net_broadband_precalc(ncol, nlev, flux_dn, flux_up, broadband_flux_net) bind(C, name=\"0\") Net flux when bradband flux up and down are already available Arguments Type Intent Optional Attributes Name integer, intent(in) :: ncol Array sizes integer, intent(in) :: nlev Array sizes real(kind=wp), intent(in), dimension(ncol, nlev) :: flux_dn Broadband downward and upward fluxes real(kind=wp), intent(in), dimension(ncol, nlev) :: flux_up Broadband downward and upward fluxes real(kind=wp), intent(out), dimension(ncol, nlev) :: broadband_flux_net Net (down minus up) interface Spectral reduction over all points public subroutine sum_broadband(ncol, nlev, ngpt, spectral_flux, broadband_flux) bind(C, name=\"0\") Arguments Type Intent Optional Attributes Name integer, intent(in) :: ncol Array sizes integer, intent(in) :: nlev Array sizes integer, intent(in) :: ngpt Array sizes real(kind=wp), intent(in), dimension(ncol, nlev, ngpt) :: spectral_flux Spectrally-resolved flux real(kind=wp), intent(out), dimension(ncol, nlev) :: broadband_flux Sum of spectrally-resolved flux over ngpt","tags":"","loc":"module/mo_fluxes_broadband_kernels~2.html"},{"title":"mo_rte_solver_kernels – RTE kernels","text":"Numeric calculations for radiative transfer solvers Emission/absorption (no-scattering) calculations solver for multi-angle Gaussian quadrature Extinction-only calculation (direct solar beam) Two-stream calculations:\n solvers for LW and SW with different boundary conditions and source functions Uses iso_c_binding mo_rte_kind module~~mo_rte_solver_kernels~2~~UsesGraph module~mo_rte_solver_kernels~2 mo_rte_solver_kernels iso_c_binding iso_c_binding module~mo_rte_solver_kernels~2->iso_c_binding mo_rte_kind mo_rte_kind module~mo_rte_solver_kernels~2->mo_rte_kind Help × Graph Key Nodes of different colours represent the following: Graph Key Module Module Submodule Submodule Subroutine Subroutine Function Function Program Program This Page's Entity This Page's Entity Solid arrows point from a submodule to the (sub)module which it is\n descended from. Dashed arrows point from a module or program unit to \n modules which it uses. Contents Interfaces lw_solver_2stream lw_solver_noscat sw_solver_2stream sw_solver_noscat Interfaces interface Longwave two-stream calculation:\n - combine RRTMGP-specific sources at levels\n - compute layer reflectance, transmittance\n - compute total source function at levels using linear-in-tau\n - transport public subroutine lw_solver_2stream(ncol, nlay, ngpt, top_at_1, tau, ssa, g, lay_source, lev_source, sfc_emis, sfc_src, inc_flux, flux_up, flux_dn) bind(C, name=\"0\") Arguments Type Intent Optional Attributes Name integer, intent(in) :: ncol Number of columns, layers, g-points integer, intent(in) :: nlay Number of columns, layers, g-points integer, intent(in) :: ngpt Number of columns, layers, g-points logical(kind=wl), intent(in) :: top_at_1 ilay = 1 is the top of the atmosphere? real(kind=wp), intent(in), dimension(ncol,nlay, ngpt) :: tau Optical thickness, single-scattering albedo, asymmetry parameter [] real(kind=wp), intent(in), dimension(ncol,nlay, ngpt) :: ssa Optical thickness, single-scattering albedo, asymmetry parameter [] real(kind=wp), intent(in), dimension(ncol,nlay, ngpt) :: g Optical thickness, single-scattering albedo, asymmetry parameter [] real(kind=wp), intent(in), dimension(ncol,nlay, ngpt) :: lay_source Planck source at layer average temperature [W/m2] real(kind=wp), intent(in), dimension(ncol,nlay+1,ngpt) :: lev_source Planck source at layer edge for radiation [W/m2] real(kind=wp), intent(in), dimension(ncol, ngpt) :: sfc_emis Surface emissivity [] real(kind=wp), intent(in), dimension(ncol, ngpt) :: sfc_src Surface source function [W/m2] real(kind=wp), intent(in), dimension(ncol, ngpt) :: inc_flux Incident diffuse flux, probably 0 [W/m2] real(kind=wp), intent(out), dimension(ncol,nlay+1,ngpt) :: flux_up Fluxes [W/m2] real(kind=wp), intent(out), dimension(ncol,nlay+1,ngpt) :: flux_dn Fluxes [W/m2] interface LW transport, no scattering, multi-angle quadrature\n Users provide a set of weights and quadrature angles\n Routine sums over single-angle solutions for each sets of angles/weights public subroutine lw_solver_noscat(ncol, nlay, ngpt, top_at_1, nmus, Ds, weights, tau, lay_source, lev_source, sfc_emis, sfc_src, inc_flux, flux_up, flux_dn, do_broadband, broadband_up, broadband_dn, do_Jacobians, sfc_srcJac, flux_upJac, do_rescaling, ssa, g) bind(C, name=\"0\") Arguments Type Intent Optional Attributes Name integer, intent(in) :: ncol Number of columns, layers, g-points integer, intent(in) :: nlay Number of columns, layers, g-points integer, intent(in) :: ngpt Number of columns, layers, g-points logical(kind=wl), intent(in) :: top_at_1 ilay = 1 is the top of the atmosphere? integer, intent(in) :: nmus number of quadrature angles real(kind=wp), intent(in), dimension (ncol, ngpt, nmus) :: Ds quadrature secants real(kind=wp), intent(in), dimension(nmus) :: weights quadrature weights real(kind=wp), intent(in), dimension(ncol,nlay, ngpt) :: tau Absorption optical thickness [] real(kind=wp), intent(in), dimension(ncol,nlay, ngpt) :: lay_source Planck source at layer average temperature [W/m2] real(kind=wp), intent(in), dimension(ncol,nlay+1,ngpt) :: lev_source Planck source at layer edge for radiation [W/m2] real(kind=wp), intent(in), dimension(ncol, ngpt) :: sfc_emis Surface emissivity [] real(kind=wp), intent(in), dimension(ncol, ngpt) :: sfc_src Surface source function [W/m2] real(kind=wp), intent(in), dimension(ncol, ngpt) :: inc_flux Incident diffuse flux, probably 0 [W/m2] real(kind=wp), intent(out), dimension(ncol,nlay+1,ngpt), target :: flux_up Fluxes [W/m2] real(kind=wp), intent(out), dimension(ncol,nlay+1,ngpt), target :: flux_dn Fluxes [W/m2] logical(kind=wl), intent(in) :: do_broadband real(kind=wp), intent(out), dimension(ncol,nlay+1 ), target :: broadband_up Spectrally-integrated fluxes [W/m2] real(kind=wp), intent(out), dimension(ncol,nlay+1 ), target :: broadband_dn Spectrally-integrated fluxes [W/m2] logical(kind=wl), intent(in) :: do_Jacobians compute Jacobian with respect to surface temeprature? real(kind=wp), intent(in), dimension(ncol ,ngpt) :: sfc_srcJac surface temperature Jacobian of surface source function [W/m2/K] real(kind=wp), intent(out), dimension(ncol,nlay+1 ), target :: flux_upJac surface temperature Jacobian of Radiances [W/m2-str / K] logical(kind=wl), intent(in) :: do_rescaling Approximate treatment of scattering (10.1175/JAS-D-18-0014.1) real(kind=wp), intent(in), dimension(ncol,nlay ,ngpt) :: ssa single-scattering albedo, asymmetry parameter real(kind=wp), intent(in), dimension(ncol,nlay ,ngpt) :: g single-scattering albedo, asymmetry parameter interface Shortwave two-stream calculation:\n compute layer reflectance, transmittance\n compute solar source function for diffuse radiation\n transport public subroutine sw_solver_2stream(ncol, nlay, ngpt, top_at_1, tau, ssa, g, mu0, sfc_alb_dir, sfc_alb_dif, inc_flux_dir, flux_up, flux_dn, flux_dir, has_dif_bc, inc_flux_dif, do_broadband, broadband_up, broadband_dn, broadband_dir) bind(C, name=\"0\") Arguments Type Intent Optional Attributes Name integer, intent(in) :: ncol Number of columns, layers, g-points integer, intent(in) :: nlay Number of columns, layers, g-points integer, intent(in) :: ngpt Number of columns, layers, g-points logical(kind=wl), intent(in) :: top_at_1 ilay = 1 is the top of the atmosphere? real(kind=wp), intent(in), dimension(ncol,nlay, ngpt) :: tau Optical thickness, single-scattering albedo, asymmetry parameter [] real(kind=wp), intent(in), dimension(ncol,nlay, ngpt) :: ssa Optical thickness, single-scattering albedo, asymmetry parameter [] real(kind=wp), intent(in), dimension(ncol,nlay, ngpt) :: g Optical thickness, single-scattering albedo, asymmetry parameter [] real(kind=wp), intent(in), dimension(ncol,nlay ) :: mu0 cosine of solar zenith angle real(kind=wp), intent(in), dimension(ncol, ngpt) :: sfc_alb_dir Spectral surface albedo for direct and diffuse radiation real(kind=wp), intent(in), dimension(ncol, ngpt) :: sfc_alb_dif Spectral surface albedo for direct and diffuse radiation real(kind=wp), intent(in), dimension(ncol, ngpt) :: inc_flux_dir Direct beam incident flux real(kind=wp), intent(out), dimension(ncol,nlay+1,ngpt), target :: flux_up Fluxes [W/m2] real(kind=wp), intent(out), dimension(ncol,nlay+1,ngpt), target :: flux_dn Fluxes [W/m2] real(kind=wp), intent(out), dimension(ncol,nlay+1,ngpt), target :: flux_dir Fluxes [W/m2] logical(kind=wl), intent(in) :: has_dif_bc Is a boundary condition for diffuse flux supplied? real(kind=wp), intent(in), dimension(ncol, ngpt) :: inc_flux_dif Boundary condition for diffuse flux [W/m2] logical(kind=wl), intent(in) :: do_broadband Provide broadband-integrated, not spectrally-resolved, fluxes? real(kind=wp), intent(out), dimension(ncol,nlay+1 ) :: broadband_up real(kind=wp), intent(out), dimension(ncol,nlay+1 ) :: broadband_dn real(kind=wp), intent(out), dimension(ncol,nlay+1 ) :: broadband_dir interface public pure subroutine sw_solver_noscat(ncol, nlay, ngpt, top_at_1, tau, mu0, inc_flux_dir, flux_dir) bind(C, name=\"0\") Arguments Type Intent Optional Attributes Name integer, intent(in) :: ncol Number of columns, layers, g-points integer, intent(in) :: nlay Number of columns, layers, g-points integer, intent(in) :: ngpt Number of columns, layers, g-points logical(kind=wl), intent(in) :: top_at_1 ilay = 1 is the top of the atmosphere? real(kind=wp), intent(in), dimension(ncol,nlay, ngpt) :: tau Absorption optical thickness [] real(kind=wp), intent(in), dimension(ncol,nlay ) :: mu0 cosine of solar zenith angle real(kind=wp), intent(in), dimension(ncol, ngpt) :: inc_flux_dir Direct beam incident flux [W/m2] real(kind=wp), intent(out), dimension(ncol,nlay+1,ngpt) :: flux_dir","tags":"","loc":"module/mo_rte_solver_kernels~2.html"},{"title":"mo_rte_util_array – RTE kernels","text":"Uses mo_rte_kind module~~mo_rte_util_array~~UsesGraph module~mo_rte_util_array mo_rte_util_array mo_rte_kind mo_rte_kind module~mo_rte_util_array->mo_rte_kind Help × Graph Key Nodes of different colours represent the following: Graph Key Module Module Submodule Submodule Subroutine Subroutine Function Function Program Program This Page's Entity This Page's Entity Solid arrows point from a submodule to the (sub)module which it is\n descended from. Dashed arrows point from a module or program unit to \n modules which it uses. Contents Interfaces zero_array Interfaces public interface zero_array public subroutine zero_array_1D(ni, array) bind(C, name=\"0\") Arguments Type Intent Optional Attributes Name integer, intent(in) :: ni real(kind=wp), intent(out), dimension(ni) :: array public subroutine zero_array_2D(ni, nj, array) bind(C, name=\"0\") Arguments Type Intent Optional Attributes Name integer, intent(in) :: ni integer, intent(in) :: nj real(kind=wp), intent(out), dimension(ni, nj) :: array public subroutine zero_array_3D(ni, nj, nk, array) bind(C, name=\"0\") Arguments Type Intent Optional Attributes Name integer, intent(in) :: ni integer, intent(in) :: nj integer, intent(in) :: nk real(kind=wp), intent(out), dimension(ni, nj, nk) :: array public subroutine zero_array_4D(ni, nj, nk, nl, array) bind(C, name=\"0\") Arguments Type Intent Optional Attributes Name integer, intent(in) :: ni integer, intent(in) :: nj integer, intent(in) :: nk integer, intent(in) :: nl real(kind=wp), intent(out), dimension(ni, nj, nk, nl) :: array","tags":"","loc":"module/mo_rte_util_array.html"},{"title":"mo_optical_props_kernels.F90 – RTE kernels","text":"Contents Modules mo_optical_props_kernels Source Code mo_optical_props_kernels.F90 Source Code ! This code is part of Radiative Transfer for Energetics (RTE) ! ! Contacts: Robert Pincus and Eli Mlawer ! email: rrtmgp@aer.com ! ! Copyright 2015-, Atmospheric and Environmental Research, ! Regents of the University of Colorado, Trustees of Columbia University. All right reserved. ! ! Use and duplication is permitted under the terms of the ! BSD 3-clause license, see http://opensource.org/licenses/BSD-3-Clause ! ------------------------------------------------------------------------------------------------- ! !> ## Kernels for arrays of optical properties: !> - delta-scaling !> - adding two sets of properties !> - extracting subsets along the column dimension ! ! ------------------------------------------------------------------------------------------------- module mo_optical_props_kernels use , intrinsic :: iso_c_binding use mo_rte_kind , only : wp , wl implicit none public !> Delta-scale two-stream optical properties interface delta_scale_2str_kernel module procedure delta_scale_2str_f_k , delta_scale_2str_k end interface !> Subsetting, meaning extracting some portion of the 3D domain interface extract_subset module procedure extract_subset_dim1_3d , extract_subset_dim2_4d module procedure extract_subset_absorption_tau end interface extract_subset real ( wp ), parameter , private :: eps = 3.0_wp * tiny ( 1.0_wp ) contains ! ------------------------------------------------------------------------------------------------- ! ! Delta-scaling is provided only for two-stream properties at present ! ! ------------------------------------------------------------------------------------------------- !> Delta-scale two-stream optical properties given user-provided value of f (forward scattering) ! pure subroutine delta_scale_2str_f_k ( ncol , nlay , ngpt , tau , ssa , g , f ) & bind ( C , name = \"rte_delta_scale_2str_f_k\" ) integer , intent ( in ) :: ncol , nlay , ngpt !! Array sizes real ( wp ), dimension ( ncol , nlay , ngpt ), intent ( inout ) :: tau , ssa , g !! Optical depth, single-scattering albedo, asymmetry parameter real ( wp ), dimension ( ncol , nlay , ngpt ), intent ( in ) :: f !! User-provided forward-scattering fraction real ( wp ) :: wf integer :: icol , ilay , igpt do igpt = 1 , ngpt do ilay = 1 , nlay do icol = 1 , ncol wf = ssa ( icol , ilay , igpt ) * f ( icol , ilay , igpt ) tau ( icol , ilay , igpt ) = ( 1._wp - wf ) * tau ( icol , ilay , igpt ) ssa ( icol , ilay , igpt ) = ( ssa ( icol , ilay , igpt ) - wf ) / max ( eps ,( 1.0_wp - wf )) g ( icol , ilay , igpt ) = ( g ( icol , ilay , igpt ) - f ( icol , ilay , igpt )) / & max ( eps ,( 1._wp - f ( icol , ilay , igpt ))) end do end do end do end subroutine delta_scale_2str_f_k ! --------------------------------- !> Delta-scale assuming forward-scatternig fraction is the square of the asymmetry parameter !> i.e. f = g^2 ! pure subroutine delta_scale_2str_k ( ncol , nlay , ngpt , tau , ssa , g ) & bind ( C , name = \"rte_delta_scale_2str_k\" ) integer , intent ( in ) :: ncol , nlay , ngpt !! Array sizes real ( wp ), dimension ( ncol , nlay , ngpt ), intent ( inout ) :: tau , ssa , g !! Optical depth, single-scattering albedo, asymmetry parameter real ( wp ) :: f , wf integer :: icol , ilay , igpt do igpt = 1 , ngpt do ilay = 1 , nlay do icol = 1 , ncol f = g ( icol , ilay , igpt ) * g ( icol , ilay , igpt ) wf = ssa ( icol , ilay , igpt ) * f tau ( icol , ilay , igpt ) = ( 1._wp - wf ) * tau ( icol , ilay , igpt ) ssa ( icol , ilay , igpt ) = ( ssa ( icol , ilay , igpt ) - wf ) / max ( eps ,( 1.0_wp - wf )) g ( icol , ilay , igpt ) = ( g ( icol , ilay , igpt ) - f ) / max ( eps ,( 1.0_wp - f )) end do end do end do end subroutine delta_scale_2str_k ! ------------------------------------------------------------------------------------------------- ! ! Addition of optical properties: the first set are incremented by the second set. ! ! There are three possible representations of optical properties (scalar = optical depth only; ! two-stream = tau, single-scattering albedo, and asymmetry factor g, and ! n-stream = tau, ssa, and phase function moments p.) Thus we need nine routines, three for ! each choice of representation on the left hand side times three representations of the ! optical properties to be added. ! ! There are two sets of these nine routines. In the first the two sets of optical ! properties are defined at the same spectral resolution. There is also a set of routines ! to add properties defined at lower spectral resolution to a set defined at higher spectral ! resolution (adding properties defined by band to those defined by g-point) ! ! ------------------------------------------------------------------------------------------------- !> increase one absorption optical depth by a second value pure subroutine increment_1scalar_by_1scalar ( ncol , nlay , ngpt , & tau1 , & tau2 ) bind ( C , name = \"rte_increment_1scalar_by_1scalar\" ) integer , intent ( in ) :: ncol , nlay , ngpt !! array sizes real ( wp ), dimension ( ncol , nlay , ngpt ), intent ( inout ) :: tau1 !! optical properties to be modified real ( wp ), dimension ( ncol , nlay , ngpt ), intent ( in ) :: tau2 !! optical properties to be added to original integer :: icol , ilay , igpt do igpt = 1 , ngpt do ilay = 1 , nlay do icol = 1 , ncol tau1 ( icol , ilay , igpt ) = tau1 ( icol , ilay , igpt ) + tau2 ( icol , ilay , igpt ) end do end do end do end subroutine increment_1scalar_by_1scalar ! --------------------------------- !> increase absorption optical depth with extinction optical depth (2-stream form) pure subroutine increment_1scalar_by_2stream ( ncol , nlay , ngpt , & tau1 , & tau2 , ssa2 ) bind ( C , name = \"rte_increment_1scalar_by_2stream\" ) integer , intent ( in ) :: ncol , nlay , ngpt !! array sizes real ( wp ), dimension ( ncol , nlay , ngpt ), intent ( inout ) :: tau1 !! optical properties to be modified real ( wp ), dimension ( ncol , nlay , ngpt ), intent ( in ) :: tau2 , ssa2 !! optical properties to be added to original integer :: icol , ilay , igpt do igpt = 1 , ngpt do ilay = 1 , nlay do icol = 1 , ncol tau1 ( icol , ilay , igpt ) = tau1 ( icol , ilay , igpt ) + & tau2 ( icol , ilay , igpt ) * ( 1._wp - ssa2 ( icol , ilay , igpt )) end do end do end do end subroutine increment_1scalar_by_2stream ! --------------------------------- !> increase absorption optical depth with extinction optical depth (n-stream form) pure subroutine increment_1scalar_by_nstream ( ncol , nlay , ngpt , & tau1 , & tau2 , ssa2 ) bind ( C , name = \"rte_increment_1scalar_by_nstream\" ) integer , intent ( in ) :: ncol , nlay , ngpt !! array sizes real ( wp ), dimension ( ncol , nlay , ngpt ), intent ( inout ) :: tau1 !! optical properties to be modified real ( wp ), dimension ( ncol , nlay , ngpt ), intent ( in ) :: tau2 , ssa2 !! optical properties to be added to original integer :: icol , ilay , igpt do igpt = 1 , ngpt do ilay = 1 , nlay do icol = 1 , ncol tau1 ( icol , ilay , igpt ) = tau1 ( icol , ilay , igpt ) + & tau2 ( icol , ilay , igpt ) * ( 1._wp - ssa2 ( icol , ilay , igpt )) end do end do end do end subroutine increment_1scalar_by_nstream ! --------------------------------- ! --------------------------------- !> increment two-stream optical properties \\tau, \\omega_0, g with absorption optical depth pure subroutine increment_2stream_by_1scalar ( ncol , nlay , ngpt , & tau1 , ssa1 , & tau2 ) bind ( C , name = \"rte_increment_2stream_by_1scalar\" ) integer , intent ( in ) :: ncol , nlay , ngpt !! array sizes real ( wp ), dimension ( ncol , nlay , ngpt ), intent ( inout ) :: tau1 , ssa1 !! optical properties to be modified real ( wp ), dimension ( ncol , nlay , ngpt ), intent ( in ) :: tau2 !! optical properties to be added to original integer :: icol , ilay , igpt real ( wp ) :: tau12 do igpt = 1 , ngpt do ilay = 1 , nlay do icol = 1 , ncol tau12 = tau1 ( icol , ilay , igpt ) + tau2 ( icol , ilay , igpt ) ssa1 ( icol , ilay , igpt ) = tau1 ( icol , ilay , igpt ) * ssa1 ( icol , ilay , igpt ) / max ( eps , tau12 ) tau1 ( icol , ilay , igpt ) = tau12 ! g is unchanged end do end do end do end subroutine increment_2stream_by_1scalar ! --------------------------------- !> increment two-stream optical properties \\tau, \\omega_0, g with a second set pure subroutine increment_2stream_by_2stream ( ncol , nlay , ngpt , & tau1 , ssa1 , g1 , & tau2 , ssa2 , g2 ) bind ( C , name = \"rte_increment_2stream_by_2stream\" ) integer , intent ( in ) :: ncol , nlay , ngpt !! array sizes real ( wp ), dimension ( ncol , nlay , ngpt ), intent ( inout ) :: tau1 , ssa1 , g1 !! optical properties to be modified real ( wp ), dimension ( ncol , nlay , ngpt ), intent ( in ) :: tau2 , ssa2 , g2 !! optical properties to be added to original integer :: icol , ilay , igpt real ( wp ) :: tau12 , tauscat12 do igpt = 1 , ngpt do ilay = 1 , nlay do icol = 1 , ncol ! t=tau1 + tau2 tau12 = tau1 ( icol , ilay , igpt ) + tau2 ( icol , ilay , igpt ) ! w=(tau1*ssa1 + tau2*ssa2) / t tauscat12 = tau1 ( icol , ilay , igpt ) * ssa1 ( icol , ilay , igpt ) + & tau2 ( icol , ilay , igpt ) * ssa2 ( icol , ilay , igpt ) g1 ( icol , ilay , igpt ) = & ( tau1 ( icol , ilay , igpt ) * ssa1 ( icol , ilay , igpt ) * g1 ( icol , ilay , igpt ) + & tau2 ( icol , ilay , igpt ) * ssa2 ( icol , ilay , igpt ) * g2 ( icol , ilay , igpt )) & / max ( eps , tauscat12 ) ssa1 ( icol , ilay , igpt ) = tauscat12 / max ( eps , tau12 ) tau1 ( icol , ilay , igpt ) = tau12 end do end do end do end subroutine increment_2stream_by_2stream ! --------------------------------- !> increment two-stream optical properties \\tau, \\omega_0, g with _n_-stream pure subroutine increment_2stream_by_nstream ( ncol , nlay , ngpt , nmom2 , & tau1 , ssa1 , g1 , & tau2 , ssa2 , p2 ) bind ( C , name = \"rte_increment_2stream_by_nstream\" ) integer , intent ( in ) :: ncol , nlay , ngpt , nmom2 !! array sizes real ( wp ), dimension ( ncol , nlay , ngpt ), intent ( inout ) :: tau1 , ssa1 , g1 !! optical properties to be modified real ( wp ), dimension ( ncol , nlay , ngpt ), intent ( in ) :: tau2 , ssa2 !! optical properties to be added to original real ( wp ), dimension ( nmom2 , & ncol , nlay , ngpt ), intent ( in ) :: p2 !! moments of the phase function to be added integer :: icol , ilay , igpt real ( wp ) :: tau12 , tauscat12 do igpt = 1 , ngpt do ilay = 1 , nlay do icol = 1 , ncol ! t=tau1 + tau2 tau12 = tau1 ( icol , ilay , igpt ) + tau2 ( icol , ilay , igpt ) ! w=(tau1*ssa1 + tau2*ssa2) / t tauscat12 = & tau1 ( icol , ilay , igpt ) * ssa1 ( icol , ilay , igpt ) + & tau2 ( icol , ilay , igpt ) * ssa2 ( icol , ilay , igpt ) g1 ( icol , ilay , igpt ) = & ( tau1 ( icol , ilay , igpt ) * ssa1 ( icol , ilay , igpt ) * g1 ( icol , ilay , igpt ) + & tau2 ( icol , ilay , igpt ) * ssa2 ( icol , ilay , igpt ) * p2 ( 1 , icol , ilay , igpt )) / max ( eps , tauscat12 ) ssa1 ( icol , ilay , igpt ) = tauscat12 / max ( eps , tau12 ) tau1 ( icol , ilay , igpt ) = tau12 end do end do end do end subroutine increment_2stream_by_nstream ! --------------------------------- ! --------------------------------- !> increment _n_-stream optical properties \\tau, \\omega_0, p with absorption optical depth pure subroutine increment_nstream_by_1scalar ( ncol , nlay , ngpt , & tau1 , ssa1 , & tau2 ) bind ( C , name = \"rte_increment_nstream_by_1scalar\" ) integer , intent ( in ) :: ncol , nlay , ngpt !! array sizes real ( wp ), dimension ( ncol , nlay , ngpt ), intent ( inout ) :: tau1 , ssa1 !! optical properties to be modified real ( wp ), dimension ( ncol , nlay , ngpt ), intent ( in ) :: tau2 !! optical properties to be added to original integer :: icol , ilay , igpt real ( wp ) :: tau12 do igpt = 1 , ngpt do ilay = 1 , nlay do icol = 1 , ncol tau12 = tau1 ( icol , ilay , igpt ) + tau2 ( icol , ilay , igpt ) ssa1 ( icol , ilay , igpt ) = tau1 ( icol , ilay , igpt ) * ssa1 ( icol , ilay , igpt ) / max ( eps , tau12 ) tau1 ( icol , ilay , igpt ) = tau12 ! p is unchanged end do end do end do end subroutine increment_nstream_by_1scalar ! --------------------------------- !> increment _n_-stream optical properties \\tau, \\omega_0, p with two-stream values pure subroutine increment_nstream_by_2stream ( ncol , nlay , ngpt , nmom1 , & tau1 , ssa1 , p1 , & tau2 , ssa2 , g2 ) bind ( C , name = \"rte_increment_nstream_by_2stream\" ) integer , intent ( in ) :: ncol , nlay , ngpt , nmom1 !! array sizes real ( wp ), dimension ( ncol , nlay , ngpt ), intent ( inout ) :: tau1 , ssa1 !! optical properties to be modified real ( wp ), dimension ( nmom1 , & ncol , nlay , ngpt ), intent ( inout ) :: p1 !! moments of the phase function be modified real ( wp ), dimension ( ncol , nlay , ngpt ), intent ( in ) :: tau2 , ssa2 , g2 !! optical properties to be added to original integer :: icol , ilay , igpt real ( wp ) :: tau12 , tauscat12 real ( wp ), dimension ( nmom1 ) :: temp_moms ! TK integer :: imom !TK do igpt = 1 , ngpt do ilay = 1 , nlay do icol = 1 , ncol tau12 = tau1 ( icol , ilay , igpt ) + tau2 ( icol , ilay , igpt ) tauscat12 = & tau1 ( icol , ilay , igpt ) * ssa1 ( icol , ilay , igpt ) + & tau2 ( icol , ilay , igpt ) * ssa2 ( icol , ilay , igpt ) ! ! Here assume Henyey-Greenstein ! temp_moms ( 1 ) = g2 ( icol , ilay , igpt ) do imom = 2 , nmom1 temp_moms ( imom ) = temp_moms ( imom - 1 ) * g2 ( icol , ilay , igpt ) end do p1 ( 1 : nmom1 , icol , ilay , igpt ) = & ( tau1 ( icol , ilay , igpt ) * ssa1 ( icol , ilay , igpt ) * p1 ( 1 : nmom1 , icol , ilay , igpt ) + & tau2 ( icol , ilay , igpt ) * ssa2 ( icol , ilay , igpt ) * temp_moms ( 1 : nmom1 ) ) / max ( eps , tauscat12 ) ssa1 ( icol , ilay , igpt ) = tauscat12 / max ( eps , tau12 ) tau1 ( icol , ilay , igpt ) = tau12 end do end do end do end subroutine increment_nstream_by_2stream ! --------------------------------- !> increment one set of _n_-stream optical properties with another set pure subroutine increment_nstream_by_nstream ( ncol , nlay , ngpt , nmom1 , nmom2 , & tau1 , ssa1 , p1 , & tau2 , ssa2 , p2 ) bind ( C , name = \"rte_increment_nstream_by_nstream\" ) integer , intent ( in ) :: ncol , nlay , ngpt , nmom1 , nmom2 !! array sizes real ( wp ), dimension ( ncol , nlay , ngpt ), intent ( inout ) :: tau1 , ssa1 !! optical properties to be modified real ( wp ), dimension ( nmom1 , & ncol , nlay , ngpt ), intent ( inout ) :: p1 !! moments of the phase function be modified real ( wp ), dimension ( ncol , nlay , ngpt ), intent ( in ) :: tau2 , ssa2 !! optical properties to be added to original real ( wp ), dimension ( nmom2 , & ncol , nlay , ngpt ), intent ( in ) :: p2 !! moments of the phase function to be added integer :: icol , ilay , igpt , mom_lim real ( wp ) :: tau12 , tauscat12 mom_lim = min ( nmom1 , nmom2 ) do igpt = 1 , ngpt do ilay = 1 , nlay do icol = 1 , ncol tau12 = tau1 ( icol , ilay , igpt ) + tau2 ( icol , ilay , igpt ) tauscat12 = & tau1 ( icol , ilay , igpt ) * ssa1 ( icol , ilay , igpt ) + & tau2 ( icol , ilay , igpt ) * ssa2 ( icol , ilay , igpt ) ! ! If op2 has more moments than op1 these are ignored; ! if it has fewer moments the higher orders are assumed to be 0 ! p1 ( 1 : mom_lim , icol , ilay , igpt ) = & ( tau1 ( icol , ilay , igpt ) * ssa1 ( icol , ilay , igpt ) * p1 ( 1 : mom_lim , icol , ilay , igpt ) + & tau2 ( icol , ilay , igpt ) * ssa2 ( icol , ilay , igpt ) * p2 ( 1 : mom_lim , icol , ilay , igpt )) / max ( eps , tauscat12 ) ssa1 ( icol , ilay , igpt ) = tauscat12 / max ( eps , tau12 ) tau1 ( icol , ilay , igpt ) = tau12 end do end do end do end subroutine increment_nstream_by_nstream ! ------------------------------------------------------------------------------------------------- ! ! Incrementing when the second set of optical properties is defined at lower spectral resolution ! (e.g. by band instead of by gpoint) ! ! ------------------------------------------------------------------------------------------------- !> increase one absorption optical depth defined on g-points by a second value defined on bands pure subroutine inc_1scalar_by_1scalar_bybnd ( ncol , nlay , ngpt , & tau1 , & tau2 , & nbnd , gpt_lims ) bind ( C , name = \"rte_inc_1scalar_by_1scalar_bybnd\" ) integer , intent ( in ) :: ncol , nlay , ngpt , nbnd !! array sizes real ( wp ), dimension ( ncol , nlay , ngpt ), intent ( inout ) :: tau1 !! optical properties to be modified (defined on g-points) real ( wp ), dimension ( ncol , nlay , nbnd ), intent ( in ) :: tau2 !! optical properties to be added to original (defined on bands) integer , dimension ( 2 , nbnd ), intent ( in ) :: gpt_lims !! Starting and ending gpoint for each band integer :: ibnd , igpt do ibnd = 1 , nbnd do igpt = gpt_lims ( 1 , ibnd ), gpt_lims ( 2 , ibnd ) tau1 (:,:, igpt ) = tau1 (:,:, igpt ) + tau2 (:,:, ibnd ) end do end do end subroutine inc_1scalar_by_1scalar_bybnd ! --------------------------------- !> increase absorption optical depth defined on g-points with extinction optical depth (2-stream form) defined on bands pure subroutine inc_1scalar_by_2stream_bybnd ( ncol , nlay , ngpt , & tau1 , & tau2 , ssa2 , & nbnd , gpt_lims ) bind ( C , name = \"rte_inc_1scalar_by_2stream_bybnd\" ) integer , intent ( in ) :: ncol , nlay , ngpt , nbnd !! array sizes real ( wp ), dimension ( ncol , nlay , ngpt ), intent ( inout ) :: tau1 !! optical properties to be modified (defined on g-points) real ( wp ), dimension ( ncol , nlay , nbnd ), intent ( in ) :: tau2 , ssa2 !! optical properties to be added to original (defined on bands) integer , dimension ( 2 , nbnd ), intent ( in ) :: gpt_lims !! Starting and ending gpoint for each band integer :: ibnd , igpt do ibnd = 1 , nbnd do igpt = gpt_lims ( 1 , ibnd ), gpt_lims ( 2 , ibnd ) tau1 (:,:, igpt ) = tau1 (:,:, igpt ) + tau2 (:,:, ibnd ) * ( 1._wp - ssa2 (:,:, ibnd )) end do end do end subroutine inc_1scalar_by_2stream_bybnd ! --------------------------------- !> increase absorption optical depth defined on g-points with extinction optical depth (n-stream form) defined on bands pure subroutine inc_1scalar_by_nstream_bybnd ( ncol , nlay , ngpt , & tau1 , & tau2 , ssa2 , & nbnd , gpt_lims ) bind ( C , name = \"rte_inc_1scalar_by_nstream_bybnd\" ) integer , intent ( in ) :: ncol , nlay , ngpt , nbnd !! array sizes real ( wp ), dimension ( ncol , nlay , ngpt ), intent ( inout ) :: tau1 !! optical properties to be modified (defined on g-points) real ( wp ), dimension ( ncol , nlay , nbnd ), intent ( in ) :: tau2 , ssa2 !! optical properties to be added to original (defined on bands) integer , dimension ( 2 , nbnd ), intent ( in ) :: gpt_lims !! Starting and ending gpoint for each band integer :: ibnd , igpt do ibnd = 1 , nbnd do igpt = gpt_lims ( 1 , ibnd ), gpt_lims ( 2 , ibnd ) tau1 (:,:, igpt ) = tau1 (:,:, igpt ) + tau2 (:,:, ibnd ) * ( 1._wp - ssa2 (:,:, ibnd )) end do end do end subroutine inc_1scalar_by_nstream_bybnd ! --------------------------------- !> increment two-stream optical properties \\tau, \\omega_0, g defined on g-points with absorption optical depth defined on bands pure subroutine inc_2stream_by_1scalar_bybnd ( ncol , nlay , ngpt , & tau1 , ssa1 , & tau2 , & nbnd , gpt_lims ) bind ( C , name = \"rte_inc_2stream_by_1scalar_bybnd\" ) integer , intent ( in ) :: ncol , nlay , ngpt , nbnd !! array sizes real ( wp ), dimension ( ncol , nlay , ngpt ), intent ( inout ) :: tau1 , ssa1 !! optical properties to be modified (defined on g-points) real ( wp ), dimension ( ncol , nlay , nbnd ), intent ( in ) :: tau2 !! optical properties to be added to original (defined on bands) integer , dimension ( 2 , nbnd ), intent ( in ) :: gpt_lims !! Starting and ending gpoint for each band integer :: icol , ilay , igpt , ibnd real ( wp ) :: tau12 do ibnd = 1 , nbnd do igpt = gpt_lims ( 1 , ibnd ), gpt_lims ( 2 , ibnd ) do ilay = 1 , nlay do icol = 1 , ncol tau12 = tau1 ( icol , ilay , igpt ) + tau2 ( icol , ilay , ibnd ) ssa1 ( icol , ilay , igpt ) = tau1 ( icol , ilay , igpt ) * ssa1 ( icol , ilay , igpt ) / max ( eps , tau12 ) tau1 ( icol , ilay , igpt ) = tau12 ! g is unchanged end do end do end do end do end subroutine inc_2stream_by_1scalar_bybnd ! --------------------------------- !> increment 2-stream optical properties defined on g-points with another set defined on bands pure subroutine inc_2stream_by_2stream_bybnd ( ncol , nlay , ngpt , & tau1 , ssa1 , g1 , & tau2 , ssa2 , g2 , & nbnd , gpt_lims ) bind ( C , name = \"rte_inc_2stream_by_2stream_bybnd\" ) integer , intent ( in ) :: ncol , nlay , ngpt , nbnd !! array sizes real ( wp ), dimension ( ncol , nlay , ngpt ), intent ( inout ) :: tau1 , ssa1 , g1 !! optical properties to be modified (defined on g-points) real ( wp ), dimension ( ncol , nlay , nbnd ), intent ( in ) :: tau2 , ssa2 , g2 !! optical properties to be added to original (defined on bands) integer , dimension ( 2 , nbnd ), intent ( in ) :: gpt_lims !! Starting and ending gpoint for each band integer :: icol , ilay , igpt , ibnd real ( wp ) :: tau12 , tauscat12 do ibnd = 1 , nbnd do igpt = gpt_lims ( 1 , ibnd ), gpt_lims ( 2 , ibnd ) do ilay = 1 , nlay do icol = 1 , ncol ! t=tau1 + tau2 tau12 = tau1 ( icol , ilay , igpt ) + tau2 ( icol , ilay , ibnd ) ! w=(tau1*ssa1 + tau2*ssa2) / t tauscat12 = & tau1 ( icol , ilay , igpt ) * ssa1 ( icol , ilay , igpt ) + & tau2 ( icol , ilay , ibnd ) * ssa2 ( icol , ilay , ibnd ) g1 ( icol , ilay , igpt ) = & ( tau1 ( icol , ilay , igpt ) * ssa1 ( icol , ilay , igpt ) * g1 ( icol , ilay , igpt ) + & tau2 ( icol , ilay , ibnd ) * ssa2 ( icol , ilay , ibnd ) * g2 ( icol , ilay , ibnd )) / max ( eps , tauscat12 ) ssa1 ( icol , ilay , igpt ) = tauscat12 / max ( eps , tau12 ) tau1 ( icol , ilay , igpt ) = tau12 end do end do end do end do end subroutine inc_2stream_by_2stream_bybnd ! --------------------------------- !> increment 2-stream optical properties defined on g-points with _n_-stream properties set defined on bands pure subroutine inc_2stream_by_nstream_bybnd ( ncol , nlay , ngpt , nmom2 , & tau1 , ssa1 , g1 , & tau2 , ssa2 , p2 , & nbnd , gpt_lims ) bind ( C , name = \"rte_inc_2stream_by_nstream_bybnd\" ) integer , intent ( in ) :: ncol , nlay , ngpt , nmom2 , nbnd !! array sizes real ( wp ), dimension ( ncol , nlay , ngpt ), intent ( inout ) :: tau1 , ssa1 , g1 !! optical properties to be modified (defined on g-points) real ( wp ), dimension ( ncol , nlay , nbnd ), intent ( in ) :: tau2 , ssa2 !! optical properties to be added to original (defined on bands) real ( wp ), dimension ( nmom2 , & ncol , nlay , nbnd ), intent ( in ) :: p2 !! moments of the phase function to be added integer , dimension ( 2 , nbnd ), intent ( in ) :: gpt_lims !! Starting and ending gpoint for each band integer :: icol , ilay , igpt , ibnd real ( wp ) :: tau12 , tauscat12 do ibnd = 1 , nbnd do igpt = gpt_lims ( 1 , ibnd ), gpt_lims ( 2 , ibnd ) do ilay = 1 , nlay do icol = 1 , ncol ! t=tau1 + tau2 tau12 = tau1 ( icol , ilay , igpt ) + tau2 ( icol , ilay , ibnd ) ! w=(tau1*ssa1 + tau2*ssa2) / t tauscat12 = & tau1 ( icol , ilay , igpt ) * ssa1 ( icol , ilay , igpt ) + & tau2 ( icol , ilay , ibnd ) * ssa2 ( icol , ilay , ibnd ) g1 ( icol , ilay , igpt ) = & ( tau1 ( icol , ilay , igpt ) * ssa1 ( icol , ilay , igpt ) * g1 ( icol , ilay , igpt ) + & tau2 ( icol , ilay , ibnd ) * ssa2 ( icol , ilay , ibnd ) * p2 ( 1 , icol , ilay , ibnd )) / max ( eps , tauscat12 ) ssa1 ( icol , ilay , igpt ) = tauscat12 / max ( eps , tau12 ) tau1 ( icol , ilay , igpt ) = tau12 end do end do end do end do end subroutine inc_2stream_by_nstream_bybnd ! --------------------------------- ! --------------------------------- !> increment _n_-stream optical properties defined on g-points with absorption optical depth defined on bands pure subroutine inc_nstream_by_1scalar_bybnd ( ncol , nlay , ngpt , & tau1 , ssa1 , & tau2 , & nbnd , gpt_lims ) bind ( C , name = \"rte_inc_nstream_by_1scalar_bybnd\" ) integer , intent ( in ) :: ncol , nlay , ngpt , nbnd !! array sizes real ( wp ), dimension ( ncol , nlay , ngpt ), intent ( inout ) :: tau1 , ssa1 !! optical properties to be modified (defined on g-points) real ( wp ), dimension ( ncol , nlay , nbnd ), intent ( in ) :: tau2 !! optical properties to be added to original (defined on bands) integer , dimension ( 2 , nbnd ), intent ( in ) :: gpt_lims !! Starting and ending gpoint for each band integer :: icol , ilay , igpt , ibnd real ( wp ) :: tau12 do ibnd = 1 , nbnd do igpt = gpt_lims ( 1 , ibnd ), gpt_lims ( 2 , ibnd ) do ilay = 1 , nlay do icol = 1 , ncol tau12 = tau1 ( icol , ilay , igpt ) + tau2 ( icol , ilay , ibnd ) ssa1 ( icol , ilay , igpt ) = tau1 ( icol , ilay , igpt ) * ssa1 ( icol , ilay , igpt ) / max ( eps , tau12 ) tau1 ( icol , ilay , igpt ) = tau12 ! p is unchanged end do end do end do end do end subroutine inc_nstream_by_1scalar_bybnd ! --------------------------------- !> increment n-stream optical properties defined on g-points with 2-stream properties set defined on bands pure subroutine inc_nstream_by_2stream_bybnd ( ncol , nlay , ngpt , nmom1 , & tau1 , ssa1 , p1 , & tau2 , ssa2 , g2 , & nbnd , gpt_lims ) bind ( C , name = \"rte_inc_nstream_by_2stream_bybnd\" ) integer , intent ( in ) :: ncol , nlay , ngpt , nmom1 , nbnd !! array sizes real ( wp ), dimension ( ncol , nlay , ngpt ), intent ( inout ) :: tau1 , ssa1 !! optical properties to be modified (defined on g-points) real ( wp ), dimension ( nmom1 , & ncol , nlay , ngpt ), intent ( inout ) :: p1 !! moments of the phase function be modified real ( wp ), dimension ( ncol , nlay , nbnd ), intent ( in ) :: tau2 , ssa2 , g2 !! optical properties to be added to original (defined on bands) integer , dimension ( 2 , nbnd ), intent ( in ) :: gpt_lims !! Starting and ending gpoint for each band integer :: icol , ilay , igpt , ibnd real ( wp ) :: tau12 , tauscat12 real ( wp ), dimension ( nmom1 ) :: temp_moms ! TK integer :: imom !TK do ibnd = 1 , nbnd do igpt = gpt_lims ( 1 , ibnd ), gpt_lims ( 2 , ibnd ) do ilay = 1 , nlay do icol = 1 , ncol tau12 = tau1 ( icol , ilay , igpt ) + tau2 ( icol , ilay , ibnd ) tauscat12 = & tau1 ( icol , ilay , igpt ) * ssa1 ( icol , ilay , igpt ) + & tau2 ( icol , ilay , ibnd ) * ssa2 ( icol , ilay , ibnd ) ! ! Here assume Henyey-Greenstein ! temp_moms ( 1 ) = g2 ( icol , ilay , ibnd ) do imom = 2 , nmom1 temp_moms ( imom ) = temp_moms ( imom - 1 ) * g2 ( icol , ilay , ibnd ) end do p1 ( 1 : nmom1 , icol , ilay , igpt ) = & ( tau1 ( icol , ilay , igpt ) * ssa1 ( icol , ilay , igpt ) * p1 ( 1 : nmom1 , icol , ilay , igpt ) + & tau2 ( icol , ilay , ibnd ) * ssa2 ( icol , ilay , ibnd ) * temp_moms ( 1 : nmom1 ) ) / max ( eps , tauscat12 ) ssa1 ( icol , ilay , igpt ) = tauscat12 / max ( eps , tau12 ) tau1 ( icol , ilay , igpt ) = tau12 end do end do end do end do end subroutine inc_nstream_by_2stream_bybnd ! --------------------------------- !> increment _n_-stream optical properties defined on g-points with a second set defined on bands pure subroutine inc_nstream_by_nstream_bybnd ( ncol , nlay , ngpt , nmom1 , nmom2 , & tau1 , ssa1 , p1 , & tau2 , ssa2 , p2 , & nbnd , gpt_lims ) bind ( C , name = \"rte_inc_nstream_by_nstream_bybnd\" ) integer , intent ( in ) :: ncol , nlay , ngpt , nmom1 , nmom2 , nbnd !! array sizes real ( wp ), dimension ( ncol , nlay , ngpt ), intent ( inout ) :: tau1 , ssa1 !! optical properties to be modified (defined on g-points) real ( wp ), dimension ( nmom1 , & ncol , nlay , ngpt ), intent ( inout ) :: p1 !! moments of the phase function be modified real ( wp ), dimension ( ncol , nlay , nbnd ), intent ( in ) :: tau2 , ssa2 !! optical properties to be added to original (defined on bands) real ( wp ), dimension ( nmom2 , & ncol , nlay , nbnd ), intent ( in ) :: p2 !! moments of the phase function to be added integer , dimension ( 2 , nbnd ), intent ( in ) :: gpt_lims !! Starting and ending gpoint for each band integer :: icol , ilay , igpt , ibnd , mom_lim real ( wp ) :: tau12 , tauscat12 mom_lim = min ( nmom1 , nmom2 ) do ibnd = 1 , nbnd do igpt = gpt_lims ( 1 , ibnd ), gpt_lims ( 2 , ibnd ) do ilay = 1 , nlay do icol = 1 , ncol tau12 = tau1 ( icol , ilay , igpt ) + tau2 ( icol , ilay , ibnd ) tauscat12 = & tau1 ( icol , ilay , igpt ) * ssa1 ( icol , ilay , igpt ) + & tau2 ( icol , ilay , ibnd ) * ssa2 ( icol , ilay , ibnd ) ! ! If op2 has more moments than op1 these are ignored; ! if it has fewer moments the higher orders are assumed to be 0 ! p1 ( 1 : mom_lim , icol , ilay , igpt ) = & ( tau1 ( icol , ilay , igpt ) * ssa1 ( icol , ilay , igpt ) * p1 ( 1 : mom_lim , icol , ilay , igpt ) + & tau2 ( icol , ilay , ibnd ) * ssa2 ( icol , ilay , ibnd ) * p2 ( 1 : mom_lim , icol , ilay , ibnd )) / max ( eps , tauscat12 ) ssa1 ( icol , ilay , igpt ) = tauscat12 / max ( eps , tau12 ) tau1 ( icol , ilay , igpt ) = tau12 end do end do end do end do end subroutine inc_nstream_by_nstream_bybnd ! ------------------------------------------------------------------------------------------------- ! ! Subsetting, meaning extracting some portion of the 3D domain ! ! ------------------------------------------------------------------------------------------------- !> !> Extract a subset from the first dimension (normally columns) of a 3D field. !> Applicable to most variables e.g. tau, ssa, g !> pure subroutine extract_subset_dim1_3d ( ncol , nlay , ngpt , array_in , colS , colE , array_out ) & bind ( C , name = \"rte_extract_subset_dim1_3d\" ) integer , intent ( in ) :: ncol , nlay , ngpt !! Array sizes real ( wp ), dimension ( ncol , nlay , ngpt ), intent ( in ) :: array_in !! Array to subset integer , intent ( in ) :: colS , colE !! Starting and ending index real ( wp ), dimension ( colE - colS + 1 ,& nlay , ngpt ), intent ( out ) :: array_out !! subset of the input array integer :: icol , ilay , igpt do igpt = 1 , ngpt do ilay = 1 , nlay do icol = colS , colE array_out ( icol - colS + 1 , ilay , igpt ) = array_in ( icol , ilay , igpt ) end do end do end do end subroutine extract_subset_dim1_3d ! --------------------------------- !> Extract a subset from the second dimension (normally columns) of a 4D field. !> Applicable to phase function moments, where the first dimension is the moment pure subroutine extract_subset_dim2_4d ( nmom , ncol , nlay , ngpt , array_in , colS , colE , array_out ) & bind ( C , name = \"rte_extract_subset_dim2_4d\" ) integer , intent ( in ) :: nmom , ncol , nlay , ngpt !! Array sizes real ( wp ), dimension ( nmom , ncol , nlay , ngpt ), intent ( in ) :: array_in !! Array to subset integer , intent ( in ) :: colS , colE !! Starting and ending index real ( wp ), dimension ( nmom , colE - colS + 1 ,& nlay , ngpt ), intent ( out ) :: array_out !! subset of the input array integer :: icol , ilay , igpt , imom do igpt = 1 , ngpt do ilay = 1 , nlay do icol = colS , colE do imom = 1 , nmom array_out ( imom , icol - colS + 1 , ilay , igpt ) = array_in ( imom , icol , ilay , igpt ) end do end do end do end do end subroutine extract_subset_dim2_4d ! --------------------------------- ! !> Extract the absorption optical thickness \\tau_{abs} = 1 - \\omega_0 \\tau_{ext} ! pure subroutine extract_subset_absorption_tau ( ncol , nlay , ngpt , tau_in , ssa_in , & colS , colE , tau_out ) & bind ( C , name = \"rte_extract_subset_absorption_tau\" ) integer , intent ( in ) :: ncol , nlay , ngpt !! Array sizes real ( wp ), dimension ( ncol , nlay , ngpt ), intent ( in ) :: tau_in , ssa_in !! Optical thickness, single scattering albedo integer , intent ( in ) :: colS , colE !! Starting and ending index real ( wp ), dimension ( colE - colS + 1 ,& nlay , ngpt ), intent ( out ) :: tau_out !! absorption optical thickness subset integer :: icol , ilay , igpt do igpt = 1 , ngpt do ilay = 1 , nlay do icol = colS , colE tau_out ( icol - colS + 1 , ilay , igpt ) = & tau_in ( icol , ilay , igpt ) * ( 1._wp - ssa_in ( icol , ilay , igpt )) end do end do end do end subroutine extract_subset_absorption_tau end module mo_optical_props_kernels","tags":"","loc":"sourcefile/mo_optical_props_kernels.f90.html"},{"title":"mo_fluxes_broadband_kernels.F90 – RTE kernels","text":"Contents Modules mo_fluxes_broadband_kernels Source Code mo_fluxes_broadband_kernels.F90 Source Code ! This code is part of Radiative Transfer for Energetics (RTE) ! ! Contacts: Robert Pincus and Eli Mlawer ! email: rrtmgp@aer.com ! ! Copyright 2015-, Atmospheric and Environmental Research, ! Regents of the University of Colorado, Trustees of Columbia University. All right reserved. ! ! Use and duplication is permitted under the terms of the ! BSD 3-clause license, see http://opensource.org/licenses/BSD-3-Clause ! ------------------------------------------------------------------------------------------------- !> !> ## Kernels for computing broadband fluxes !> ! ------------------------------------------------------------------------------------------------- module mo_fluxes_broadband_kernels use , intrinsic :: iso_c_binding use mo_rte_kind , only : wp implicit none private public :: sum_broadband , net_broadband interface net_broadband !! Interface for computing net flux module procedure net_broadband_full , net_broadband_precalc end interface net_broadband contains ! ---------------------------------------------------------------------------- !> !> Spectral reduction over all points !> subroutine sum_broadband ( ncol , nlev , ngpt , spectral_flux , broadband_flux ) bind ( C , name = \"rte_sum_broadband\" ) integer , intent ( in ) :: ncol , nlev , ngpt !! Array sizes real ( wp ), dimension ( ncol , nlev , ngpt ), intent ( in ) :: spectral_flux !! Spectrally-resolved flux real ( wp ), dimension ( ncol , nlev ), intent ( out ) :: broadband_flux !! Sum of spectrally-resolved flux over `ngpt` integer :: icol , ilev , igpt real ( wp ) :: bb_flux_s ! local scalar version !$acc enter data copyin(spectral_flux) create(broadband_flux) !$omp target enter data map(to:spectral_flux) map(alloc:broadband_flux) !$acc parallel loop gang vector collapse(2) !$omp target teams distribute parallel do simd collapse(2) do ilev = 1 , nlev do icol = 1 , ncol bb_flux_s = 0.0_wp do igpt = 1 , ngpt bb_flux_s = bb_flux_s + spectral_flux ( icol , ilev , igpt ) end do broadband_flux ( icol , ilev ) = bb_flux_s end do end do !$acc exit data delete(spectral_flux) copyout(broadband_flux) !$omp target exit data map(release:spectral_flux) map(from:broadband_flux) end subroutine sum_broadband ! ---------------------------------------------------------------------------- !> !> Spectral reduction over all points for net flux !> subroutine net_broadband_full ( ncol , nlev , ngpt , spectral_flux_dn , spectral_flux_up , broadband_flux_net ) & bind ( C , name = \"rte_net_broadband_full\" ) integer , intent ( in ) :: ncol , nlev , ngpt !! Array sizes real ( wp ), dimension ( ncol , nlev , ngpt ), intent ( in ) :: spectral_flux_dn , spectral_flux_up !! Spectrally-resolved flux up and down real ( wp ), dimension ( ncol , nlev ), intent ( out ) :: broadband_flux_net !! Net (down minus up) summed over `ngpt` integer :: icol , ilev , igpt real ( wp ) :: diff !$acc enter data copyin(spectral_flux_dn, spectral_flux_up) create(broadband_flux_net) !$omp target enter data map(to:spectral_flux_dn, spectral_flux_up) map(alloc:broadband_flux_net) !$acc parallel loop collapse(2) !$omp target teams distribute parallel do simd collapse(2) do ilev = 1 , nlev do icol = 1 , ncol diff = spectral_flux_dn ( icol , ilev , 1 ) - spectral_flux_up ( icol , ilev , 1 ) broadband_flux_net ( icol , ilev ) = diff end do end do !$acc parallel loop collapse(3) !$omp target teams distribute parallel do simd collapse(3) do igpt = 2 , ngpt do ilev = 1 , nlev do icol = 1 , ncol diff = spectral_flux_dn ( icol , ilev , igpt ) - spectral_flux_up ( icol , ilev , igpt ) !$acc atomic update !$omp atomic update broadband_flux_net ( icol , ilev ) = broadband_flux_net ( icol , ilev ) + diff end do end do end do !$acc exit data delete(spectral_flux_dn, spectral_flux_up) copyout(broadband_flux_net) !$omp target exit data map(release:spectral_flux_dn, spectral_flux_up) map(from:broadband_flux_net) end subroutine net_broadband_full ! ---------------------------------------------------------------------------- !> !> Net flux when bradband flux up and down are already available !> subroutine net_broadband_precalc ( ncol , nlev , flux_dn , flux_up , broadband_flux_net ) & bind ( C , name = \"rte_net_broadband_precalc\" ) integer , intent ( in ) :: ncol , nlev !! Array sizes real ( wp ), dimension ( ncol , nlev ), intent ( in ) :: flux_dn , flux_up !! Broadband downward and upward fluxes real ( wp ), dimension ( ncol , nlev ), intent ( out ) :: broadband_flux_net !! Net (down minus up) integer :: icol , ilev !$acc enter data copyin(flux_dn, flux_up) create(broadband_flux_net) !$omp target enter data map(to:flux_dn, flux_up) map(alloc:broadband_flux_net) !$acc parallel loop collapse(2) !$omp target teams distribute parallel do simd collapse(2) do ilev = 1 , nlev do icol = 1 , ncol broadband_flux_net ( icol , ilev ) = flux_dn ( icol , ilev ) - flux_up ( icol , ilev ) end do end do !$acc exit data delete(flux_dn, flux_up) copyout(broadband_flux_net) !$omp target exit data map(release:flux_dn, flux_up) map(from:broadband_flux_net) end subroutine net_broadband_precalc ! ---------------------------------------------------------------------------- end module mo_fluxes_broadband_kernels","tags":"","loc":"sourcefile/mo_fluxes_broadband_kernels.f90.html"},{"title":"mo_rte_solver_kernels.F90 – RTE kernels","text":"This file depends on sourcefile~~mo_rte_solver_kernels.f90~~EfferentGraph sourcefile~mo_rte_solver_kernels.f90 mo_rte_solver_kernels.F90 sourcefile~mo_rte_util_array.f90 mo_rte_util_array.F90 sourcefile~mo_rte_solver_kernels.f90->sourcefile~mo_rte_util_array.f90 Help × Graph Key Nodes of different colours represent the following: Graph Key Source File Source File This Page's Entity This Page's Entity Solid arrows point from a file to a file which it depends on. A file\n is dependent upon another if the latter must be compiled before the former\n can be. Contents Modules mo_rte_solver_kernels Source Code mo_rte_solver_kernels.F90 Source Code ! This code is part of Radiative Transfer for Energetics (RTE) ! ! Contacts: Robert Pincus and Eli Mlawer ! email: rrtmgp@aer.com ! ! Copyright 2015-, Atmospheric and Environmental Research, ! Regents of the University of Colorado, Trustees of Columbia University. All right reserved. ! ! Use and duplication is permitted under the terms of the ! BSD 3-clause license, see http://opensource.org/licenses/BSD-3-Clause ! ------------------------------------------------------------------------------------------------- ! !>## Numeric calculations for radiative transfer solvers !> - Emission/absorption (no-scattering) calculations !> - solver for multi-angle Gaussian quadrature !> - solver for a single angle, calling !> - source function computation (linear-in-tau) !> - transport !> - Extinction-only calculation (direct solar beam) !> - Two-stream calculations: !> solvers for LW and SW with different boundary conditions and source functions !> - source function calculation for LW, SW !> - two-stream calculations for LW, SW (using different assumtions about phase function) !> - transport (adding) !> - Application of boundary conditions ! ! ------------------------------------------------------------------------------------------------- module mo_rte_solver_kernels use , intrinsic :: iso_c_binding use mo_rte_kind , only : wp , wl use mo_rte_util_array , only : zero_array implicit none private public :: lw_solver_noscat , lw_solver_2stream , & sw_solver_noscat , sw_solver_2stream real ( wp ), parameter :: pi = acos ( - 1._wp ) contains ! ------------------------------------------------------------------------------------------------- ! ! Top-level longwave kernels ! ! ------------------------------------------------------------------------------------------------- ! !> LW fluxes, no scattering, mu (cosine of integration angle) specified by column !> Does radiation calculation at user-supplied angles; converts radiances to flux !> using user-supplied weights ! ! --------------------------------------------------------------- subroutine lw_solver_noscat_oneangle ( ncol , nlay , ngpt , top_at_1 , D , weight , & tau , lay_source , lev_source , sfc_emis , sfc_src , & incident_flux , & flux_up , flux_dn , & do_broadband , broadband_up , broadband_dn , & do_Jacobians , sfc_srcJac , flux_upJac , & do_rescaling , ssa , g ) integer , intent ( in ) :: ncol , nlay , ngpt ! Number of columns, layers, g-points logical ( wl ), intent ( in ) :: top_at_1 real ( wp ), dimension ( ncol , ngpt ), intent ( in ) :: D ! secant of propagation angle [] real ( wp ), intent ( in ) :: weight ! quadrature weight real ( wp ), dimension ( ncol , nlay , ngpt ), intent ( in ) :: tau ! Absorption optical thickness [] real ( wp ), dimension ( ncol , nlay , ngpt ), intent ( in ) :: lay_source ! Planck source at layer average temperature [W/m2] real ( wp ), dimension ( ncol , nlay + 1 , ngpt ), intent ( in ) :: lev_source ! Planck source at layer edge [W/m2] real ( wp ), dimension ( ncol , ngpt ), intent ( in ) :: sfc_emis ! Surface emissivity [] real ( wp ), dimension ( ncol , ngpt ), intent ( in ) :: sfc_src ! Surface source function [W/m2] real ( wp ), dimension ( ncol , ngpt ), intent ( in ) :: incident_flux ! Boundary condition for flux [W/m2] real ( wp ), dimension ( ncol , nlay + 1 , ngpt ), target , & ! Fluxes [W/m2] intent ( out ) :: flux_up , flux_dn ! ! Optional variables - arrays aren't referenced if corresponding logical == False ! logical ( wl ), intent ( in ) :: do_broadband real ( wp ), dimension ( ncol , nlay + 1 ), intent ( out ) :: broadband_up , broadband_dn ! Spectrally-integrated fluxes [W/m2] logical ( wl ), intent ( in ) :: do_Jacobians real ( wp ), dimension ( ncol , ngpt ), intent ( in ) :: sfc_srcJac ! surface temperature Jacobian of surface source function [W/m2/K] real ( wp ), dimension ( ncol , nlay + 1 ), intent ( out ) :: flux_upJac ! surface temperature Jacobian of Radiances [W/m2-str / K] logical ( wl ), intent ( in ) :: do_rescaling real ( wp ), dimension ( ncol , nlay , ngpt ), intent ( in ) :: ssa , g ! single-scattering albedo, asymmetry parameter ! ------------------------------------ ! Local variables, no g-point dependency ! integer :: icol , ilay , igpt integer :: top_level , sfc_level real ( wp ), dimension ( ncol , nlay ) :: tau_loc , & ! path length (tau/mu) trans ! transmissivity = exp(-tau) real ( wp ), dimension ( ncol , nlay ) :: source_dn , source_up real ( wp ), dimension ( ncol ) :: sfc_albedo real ( wp ), parameter :: pi = acos ( - 1._wp ) ! loc_fluxes hold a single g-point flux if fluxes are being integrated instead of returned ! with spectral detail real ( wp ), dimension ( ncol , nlay + 1 ), & target :: loc_flux_up , loc_flux_dn ! gpt_fluxes point to calculations for the current g-point real ( wp ), dimension (:,:), pointer :: gpt_flux_up , gpt_flux_dn ! ------------------------------------------------------------------------------------------------- ! Optionally, use an approximate treatment of scattering using rescaling ! Implemented based on the paper ! Tang G, et al, 2018: https://doi.org/10.1175/JAS-D-18-0014.1 ! a) relies on rescaling of the optical parameters based on asymetry factor and single scattering albedo ! scaling can be computed by scaling_1rescl ! b) adds adustment term based on cloud properties (lw_transport_1rescl) ! adustment terms is computed based on solution of the Tang equations ! for \"linear-in-tau\" internal source (not in the paper) ! ! Used when approximating scattering ! real ( wp ) :: ssal , wb , scaleTau real ( wp ), dimension ( ncol , nlay ) :: An , Cn real ( wp ), dimension ( ncol , nlay + 1 ) :: gpt_flux_Jac ! ------------------------------------ ! Which way is up? if ( top_at_1 ) then top_level = 1 sfc_level = nlay + 1 else top_level = nlay + 1 sfc_level = 1 end if ! ! Integrated fluxes need zeroing ! if ( do_broadband ) then call zero_array ( ncol , nlay + 1 , broadband_up ) call zero_array ( ncol , nlay + 1 , broadband_dn ) end if if ( do_Jacobians ) & call zero_array ( ncol , nlay + 1 , flux_upJac ) do igpt = 1 , ngpt if ( do_broadband ) then gpt_flux_up => loc_flux_up gpt_flux_dn => loc_flux_dn else gpt_flux_up => flux_up (:,:, igpt ) gpt_flux_dn => flux_dn (:,:, igpt ) end if ! ! Transport is for intensity ! convert flux at top of domain to intensity assuming azimuthal isotropy ! gpt_flux_dn (:, top_level ) = incident_flux (:, igpt ) / ( pi * weight ) ! ! Optical path and transmission, used in source function and transport calculations ! if ( do_rescaling ) then ! ! The scaling and scaleTau terms are independent of propagation ! angle D and could be pre-computed if several values of D are used ! We re-compute them here to keep not have to localize memory use ! do ilay = 1 , nlay do icol = 1 , ncol ssal = ssa ( icol , ilay , igpt ) ! w is the layer single scattering albedo ! b is phase function parameter (Eq.13 of the paper) ! for the similarity principle scaling scheme ! b = (1-g)/2 (where g is phase function avergae cosine) wb = ssal * ( 1._wp - g ( icol , ilay , igpt )) * 0.5_wp ! scaleTau=1-w(1-b) is a scaling factor of the optical thickness representing ! the radiative transfer equation in a nonscattering form Eq(14) of the paper scaleTau = ( 1._wp - ssal + wb ) ! Cn = 0.5*wb/(1-w(1-b)) is parameter of Eq.21-22 of the Tang paper ! Tang paper, p.2222 advises to replace 0.5 with 0.4 based on simulations Cn ( icol , ilay ) = 0.4_wp * wb / scaleTau ! Eqs.15, 18ab and 19 of the paper, ! rescaling of the optical depth multiplied by path length tau_loc ( icol , ilay ) = tau ( icol , ilay , igpt ) * D ( icol , igpt ) * scaleTau end do trans (:, ilay ) = exp ( - tau_loc (:, ilay )) An (:, ilay ) = ( 1._wp - trans (:, ilay ) ** 2 ) end do else do ilay = 1 , nlay tau_loc (:, ilay ) = tau (:, ilay , igpt ) * D (:, igpt ) trans (:, ilay ) = exp ( - tau_loc (:, ilay )) end do end if ! ! Source function for diffuse radiation ! call lw_source_noscat ( ncol , nlay , top_at_1 , & lay_source (:,:, igpt ), lev_source (:,:, igpt ), & tau_loc , trans , source_dn , source_up ) ! ! Transport down ! call lw_transport_noscat_dn ( ncol , nlay , top_at_1 , trans , source_dn , gpt_flux_dn ) ! ! Surface albedo, surface source function, reflection and emission ! sfc_albedo (:) = 1._wp - sfc_emis (:, igpt ) gpt_flux_up (:, sfc_level ) = gpt_flux_dn (:, sfc_level ) * sfc_albedo (:) + & sfc_emis (:, igpt ) * sfc_src (:, igpt ) if ( do_Jacobians ) & gpt_flux_Jac (:, sfc_level ) = sfc_emis (:, igpt ) * sfc_srcJac (:, igpt ) ! ! Transport up, or up and down again if using rescaling ! if ( do_rescaling ) then call lw_transport_1rescl ( ncol , nlay , top_at_1 , trans , & source_dn , source_up , & gpt_flux_up , gpt_flux_dn , An , Cn , & do_Jacobians , gpt_flux_Jac ) ! Standing in for Jacobian, i.e. rad_up_Jac(:,:,igpt), rad_dn_Jac(:,:,igpt)) else call lw_transport_noscat_up ( ncol , nlay , top_at_1 , trans , source_up , gpt_flux_up , & do_Jacobians , gpt_flux_Jac ) end if if ( do_broadband ) then broadband_up (:,:) = broadband_up (:,:) + gpt_flux_up (:,:) broadband_dn (:,:) = broadband_dn (:,:) + gpt_flux_dn (:,:) else ! ! Convert intensity to flux assuming azimuthal isotropy and quadrature weight ! gpt_flux_dn (:,:) = pi * weight * gpt_flux_dn (:,:) gpt_flux_up (:,:) = pi * weight * gpt_flux_up (:,:) end if ! ! Only broadband-integrated Jacobians are provided ! if ( do_Jacobians ) & flux_upJac (:,:) = flux_upJac (:,:) + gpt_flux_Jac (:,:) end do ! g point loop if ( do_broadband ) then broadband_up (:,:) = pi * weight * broadband_up (:,:) broadband_dn (:,:) = pi * weight * broadband_dn (:,:) end if if ( do_Jacobians ) & flux_upJac (:,:) = pi * weight * flux_upJac (:,:) end subroutine lw_solver_noscat_oneangle ! ------------------------------------------------------------------------------------------------- ! !> LW transport, no scattering, multi-angle quadrature !> Users provide a set of weights and quadrature angles !> Routine sums over single-angle solutions for each sets of angles/weights ! ! --------------------------------------------------------------- subroutine lw_solver_noscat ( ncol , nlay , ngpt , top_at_1 , & nmus , Ds , weights , & tau , & lay_source , lev_source , & sfc_emis , sfc_src , & inc_flux , & flux_up , flux_dn , & do_broadband , broadband_up , broadband_dn , & do_Jacobians , sfc_srcJac , flux_upJac , & do_rescaling , ssa , g ) bind ( C , name = \"rte_lw_solver_noscat\" ) integer , intent ( in ) :: ncol , nlay , ngpt !! Number of columns, layers, g-points logical ( wl ), intent ( in ) :: top_at_1 !! ilay = 1 is the top of the atmosphere? integer , intent ( in ) :: nmus !! number of quadrature angles real ( wp ), dimension ( ncol , ngpt , & nmus ), intent ( in ) :: Ds !! quadrature secants real ( wp ), dimension ( nmus ), intent ( in ) :: weights !! quadrature weights real ( wp ), dimension ( ncol , nlay , ngpt ), intent ( in ) :: tau !! Absorption optical thickness [] real ( wp ), dimension ( ncol , nlay , ngpt ), intent ( in ) :: lay_source !! Planck source at layer average temperature [W/m2] real ( wp ), dimension ( ncol , nlay + 1 , ngpt ), intent ( in ) :: lev_source !! Planck source at layer edge for radiation[W/m2] real ( wp ), dimension ( ncol , ngpt ), intent ( in ) :: sfc_emis !! Surface emissivity [] real ( wp ), dimension ( ncol , ngpt ), intent ( in ) :: sfc_src !! Surface source function [W/m2] real ( wp ), dimension ( ncol , ngpt ), intent ( in ) :: inc_flux !! Incident diffuse flux, probably 0 [W/m2] real ( wp ), dimension ( ncol , nlay + 1 , ngpt ), target , & intent ( out ) :: flux_up , flux_dn !! Fluxes [W/m2] ! ! Optional variables - arrays aren't referenced if corresponding logical == False ! logical ( wl ), intent ( in ) :: do_broadband real ( wp ), dimension ( ncol , nlay + 1 ), target , & intent ( out ) :: broadband_up , broadband_dn !! Spectrally-integrated fluxes [W/m2] logical ( wl ), intent ( in ) :: do_Jacobians !! compute Jacobian with respect to surface temeprature? real ( wp ), dimension ( ncol , ngpt ), intent ( in ) :: sfc_srcJac !! surface temperature Jacobian of surface source function [W/m2/K] real ( wp ), dimension ( ncol , nlay + 1 ), target , & intent ( out ) :: flux_upJac !! surface temperature Jacobian of Radiances [W/m2-str / K] logical ( wl ), intent ( in ) :: do_rescaling !! Approximate treatment of scattering (10.1175/JAS-D-18-0014.1) real ( wp ), dimension ( ncol , nlay , ngpt ), intent ( in ) :: ssa , g !! single-scattering albedo, asymmetry parameter ! ------------------------------------ ! ! Local variables - used for a single quadrature angle ! real ( wp ), dimension (:,:,:), pointer :: this_flux_up , this_flux_dn real ( wp ), dimension (:,:), pointer :: this_broadband_up , this_broadband_dn , this_flux_upJac integer :: imu ! ------------------------------------ ! ! For the first angle output arrays store total flux ! call lw_solver_noscat_oneangle ( ncol , nlay , ngpt , & top_at_1 , Ds (:,:, 1 ), weights ( 1 ), tau , & lay_source , lev_source , sfc_emis , sfc_src , & inc_flux , & flux_up , flux_dn , & do_broadband , broadband_up , broadband_dn , & do_Jacobians , sfc_srcJac , flux_upJac , & do_rescaling , ssa , g ) ! ! For more than one angle use local arrays ! if ( nmus > 1 ) then if ( do_broadband ) then allocate ( this_broadband_up ( ncol , nlay + 1 ), this_broadband_dn ( ncol , nlay + 1 )) ! Spectrally-resolved fluxes won't be filled in so can point to caller-supplied memory this_flux_up => flux_up this_flux_dn => flux_dn else allocate ( this_flux_up ( ncol , nlay + 1 , ngpt ), this_flux_dn ( ncol , nlay + 1 , ngpt )) ! Spectrally-integrated fluxes won't be filled in so can point to caller-supplied memory this_broadband_up => broadband_up this_broadband_dn => broadband_dn end if if ( do_Jacobians ) then allocate ( this_flux_upJac ( ncol , nlay + 1 )) else this_flux_upJac => flux_upJac end if end if do imu = 2 , nmus call lw_solver_noscat_oneangle ( ncol , nlay , ngpt , & top_at_1 , Ds (:,:, imu ), weights ( imu ), tau , & lay_source , lev_source , sfc_emis , sfc_src , & inc_flux , & this_flux_up , this_flux_dn , & do_broadband , this_broadband_up , this_broadband_dn , & do_Jacobians , sfc_srcJac , this_flux_upJac , & do_rescaling , ssa , g ) if ( do_broadband ) then broadband_up (:,:) = broadband_up (:,:) + this_broadband_up (:,:) broadband_dn (:,:) = broadband_dn (:,:) + this_broadband_dn (:,:) else flux_up (:,:,:) = flux_up (:,:,:) + this_flux_up (:,:,:) flux_dn (:,:,:) = flux_dn (:,:,:) + this_flux_dn (:,:,:) end if if ( do_Jacobians ) & flux_upJac (:,:) = flux_upJac (:,: ) + this_flux_upJac (:,: ) end do if ( nmus > 1 ) then if ( do_broadband ) deallocate ( this_broadband_up , this_broadband_dn ) if (. not . do_broadband ) deallocate ( this_flux_up , this_flux_dn ) if ( do_Jacobians ) deallocate ( this_flux_upJac ) end if end subroutine lw_solver_noscat ! ------------------------------------------------------------------------------------------------- ! !> Longwave two-stream calculation: !> - combine RRTMGP-specific sources at levels !> - compute layer reflectance, transmittance !> - compute total source function at levels using linear-in-tau !> - transport ! ! ------------------------------------------------------------------------------------------------- subroutine lw_solver_2stream ( ncol , nlay , ngpt , top_at_1 , & tau , ssa , g , & lay_source , lev_source , sfc_emis , sfc_src , & inc_flux , & flux_up , flux_dn ) bind ( C , name = \"rte_lw_solver_2stream\" ) integer , intent ( in ) :: ncol , nlay , ngpt !! Number of columns, layers, g-points logical ( wl ), intent ( in ) :: top_at_1 !! ilay = 1 is the top of the atmosphere? real ( wp ), dimension ( ncol , nlay , ngpt ), intent ( in ) :: tau , ssa , g !! Optical thickness, single-scattering albedo, asymmetry parameter [] real ( wp ), dimension ( ncol , nlay , ngpt ), intent ( in ) :: lay_source !! Planck source at layer average temperature [W/m2] real ( wp ), dimension ( ncol , nlay + 1 , ngpt ), intent ( in ) :: lev_source !! Planck source at layer edge temperature [W/m2] real ( wp ), dimension ( ncol , ngpt ), intent ( in ) :: sfc_emis !! Surface emissivity [] real ( wp ), dimension ( ncol , ngpt ), intent ( in ) :: sfc_src !! Surface source function [W/m2] real ( wp ), dimension ( ncol , ngpt ), intent ( in ) :: inc_flux !! Incident diffuse flux, probably 0 [W/m2] real ( wp ), dimension ( ncol , nlay + 1 , ngpt ), intent ( out ) :: flux_up , flux_dn !! Fluxes [W/m2] ! ---------------------------------------------------------------------- integer :: igpt , top_level real ( wp ), dimension ( ncol , nlay ) :: Rdif , Tdif , gamma1 , gamma2 real ( wp ), dimension ( ncol ) :: sfc_albedo real ( wp ), dimension ( ncol , nlay ) :: source_dn , source_up real ( wp ), dimension ( ncol ) :: source_sfc ! ------------------------------------ top_level = nlay + 1 if ( top_at_1 ) top_level = 1 do igpt = 1 , ngpt ! ! Cell properties: reflection, transmission for diffuse radiation ! Coupling coefficients needed for source function ! call lw_two_stream ( ncol , nlay , & tau (:,:, igpt ), ssa (:,:, igpt ), g (:,:, igpt ), & gamma1 , gamma2 , Rdif , Tdif ) ! ! Source function for diffuse radiation ! call lw_source_2str ( ncol , nlay , top_at_1 , & sfc_emis (:, igpt ), sfc_src (:, igpt ), & lay_source (:,:, igpt ), lev_source , & gamma1 , gamma2 , Rdif , Tdif , tau (:,:, igpt ), & source_dn , source_up , source_sfc ) ! ! Transport ! sfc_albedo ( 1 : ncol ) = 1._wp - sfc_emis (:, igpt ) ! ! Boundary condition ! flux_dn (:, top_level , igpt ) = inc_flux (:, igpt ) call adding ( ncol , nlay , top_at_1 , & sfc_albedo , & Rdif , Tdif , & source_dn , source_up , source_sfc , & flux_up (:,:, igpt ), flux_dn (:,:, igpt )) end do end subroutine lw_solver_2stream ! ------------------------------------------------------------------------------------------------- ! ! Top-level shortwave kernels ! ! ------------------------------------------------------------------------------------------------- ! ! !> Extinction-only shortwave solver i.e. solar direct beam ! ! ------------------------------------------------------------------------------------------------- pure subroutine sw_solver_noscat ( ncol , nlay , ngpt , top_at_1 , & tau , mu0 , inc_flux_dir , flux_dir ) bind ( C , name = \"rte_sw_solver_noscat\" ) integer , intent ( in ) :: ncol , nlay , ngpt ! Number of columns, layers, g-points !! Number of columns, layers, g-points logical ( wl ), intent ( in ) :: top_at_1 !! ilay = 1 is the top of the atmosphere? real ( wp ), dimension ( ncol , nlay , ngpt ), intent ( in ) :: tau !! Absorption optical thickness [] real ( wp ), dimension ( ncol , nlay ), intent ( in ) :: mu0 !! cosine of solar zenith angle real ( wp ), dimension ( ncol , ngpt ), intent ( in ) :: inc_flux_dir !! Direct beam incident flux [W/m2] real ( wp ), dimension ( ncol , nlay + 1 , ngpt ), intent ( out ) :: flux_dir !! Direct-beam flux, spectral [W/m2] integer :: ilev , igpt ! ------------------------------------ ! Indexing into arrays for upward and downward propagation depends on the vertical ! orientation of the arrays (whether the domain top is at the first or last index) ! We write the loops out explicitly so compilers will have no trouble optimizing them. ! Downward propagation if ( top_at_1 ) then ! For the flux at this level, what was the previous level, and which layer has the ! radiation just passed through? ! layer index = level index - 1 ! previous level is up (-1) do igpt = 1 , ngpt flux_dir (:, 1 , igpt ) = inc_flux_dir (:, igpt ) * mu0 (:, 1 ) do ilev = 2 , nlay + 1 flux_dir (:, ilev , igpt ) = flux_dir (:, ilev - 1 , igpt ) * exp ( - tau (:, ilev - 1 , igpt ) / mu0 (:, ilev - 1 )) end do end do else ! layer index = level index ! previous level is up (+1) do igpt = 1 , ngpt flux_dir (:, nlay + 1 , igpt ) = inc_flux_dir (:, igpt ) * mu0 (:, nlay ) do ilev = nlay , 1 , - 1 flux_dir (:, ilev , igpt ) = flux_dir (:, ilev + 1 , igpt ) * exp ( - tau (:, ilev , igpt ) / mu0 (:, ilev )) end do end do end if end subroutine sw_solver_noscat ! ------------------------------------------------------------------------------------------------- ! !> Shortwave two-stream calculation: !> compute layer reflectance, transmittance !> compute solar source function for diffuse radiation !> transport ! ! ------------------------------------------------------------------------------------------------- subroutine sw_solver_2stream ( ncol , nlay , ngpt , top_at_1 , & tau , ssa , g , mu0 , & sfc_alb_dir , sfc_alb_dif , & inc_flux_dir , & flux_up , flux_dn , flux_dir , & has_dif_bc , inc_flux_dif , & do_broadband , broadband_up , & broadband_dn , broadband_dir ) bind ( C , name = \"rte_sw_solver_2stream\" ) integer , intent ( in ) :: ncol , nlay , ngpt !! Number of columns, layers, g-points logical ( wl ), intent ( in ) :: top_at_1 !! ilay = 1 is the top of the atmosphere? real ( wp ), dimension ( ncol , nlay , ngpt ), intent ( in ) :: tau , ssa , g !! Optical thickness, single-scattering albedo, asymmetry parameter [] real ( wp ), dimension ( ncol , nlay ), intent ( in ) :: mu0 !! cosine of solar zenith angle real ( wp ), dimension ( ncol , ngpt ), intent ( in ) :: sfc_alb_dir , sfc_alb_dif !! Spectral surface albedo for direct and diffuse radiation real ( wp ), dimension ( ncol , ngpt ), intent ( in ) :: inc_flux_dir !! Direct beam incident flux real ( wp ), dimension ( ncol , nlay + 1 , ngpt ), target , & intent ( out ) :: flux_up , flux_dn , flux_dir !! Fluxes [W/m2] logical ( wl ), intent ( in ) :: has_dif_bc !! Is a boundary condition for diffuse flux supplied? real ( wp ), dimension ( ncol , ngpt ), intent ( in ) :: inc_flux_dif !! Boundary condition for diffuse flux [W/m2] logical ( wl ), intent ( in ) :: do_broadband !! Provide broadband-integrated, not spectrally-resolved, fluxes? real ( wp ), dimension ( ncol , nlay + 1 ), intent ( out ) :: broadband_up , broadband_dn , broadband_dir !! Broadband integrated fluxes ! ------------------------------------------- integer :: igpt , top_level , top_layer real ( wp ), dimension ( ncol , nlay ) :: Rdif , Tdif real ( wp ), dimension ( ncol , nlay ) :: source_up , source_dn real ( wp ), dimension ( ncol ) :: source_srf ! loc_fluxes hold a single g-point flux if fluxes are being integrated instead of returned ! with spectral detail real ( wp ), dimension ( ncol , nlay + 1 ), & target :: loc_flux_up , loc_flux_dn , loc_flux_dir ! gpt_fluxes point to calculations for the current g-point real ( wp ), dimension (:,:), pointer :: gpt_flux_up , gpt_flux_dn , gpt_flux_dir ! ------------------------------------ if ( top_at_1 ) then top_level = 1 top_layer = 1 else top_level = nlay + 1 top_layer = nlay end if ! ! Integrated fluxes need zeroing ! if ( do_broadband ) then call zero_array ( ncol , nlay + 1 , broadband_up ) call zero_array ( ncol , nlay + 1 , broadband_dn ) call zero_array ( ncol , nlay + 1 , broadband_dir ) end if do igpt = 1 , ngpt if ( do_broadband ) then gpt_flux_up => loc_flux_up gpt_flux_dn => loc_flux_dn gpt_flux_dir => loc_flux_dir else gpt_flux_up => flux_up (:,:, igpt ) gpt_flux_dn => flux_dn (:,:, igpt ) gpt_flux_dir => flux_dir (:,:, igpt ) end if ! ! Boundary conditions direct beam... ! gpt_flux_dir (:, top_level ) = inc_flux_dir (:, igpt ) * mu0 (:, top_layer ) ! ! ... and diffuse field, using 0 if no BC is provided ! if ( has_dif_bc ) then gpt_flux_dn (:, top_level ) = inc_flux_dif (:, igpt ) else gpt_flux_dn (:, top_level ) = 0._wp end if ! ! Cell properties: transmittance and reflectance for diffuse radiation ! Direct-beam and source for diffuse radiation ! call sw_dif_and_source ( ncol , nlay , top_at_1 , mu0 , sfc_alb_dir (:, igpt ), & tau (:,:, igpt ), ssa (:,:, igpt ), g (:,:, igpt ), & Rdif , Tdif , source_dn , source_up , source_srf , & gpt_flux_dir ) ! ! Transport ! call adding ( ncol , nlay , top_at_1 , & sfc_alb_dif (:, igpt ), Rdif , Tdif , & source_dn , source_up , source_srf , gpt_flux_up , gpt_flux_dn ) ! ! adding() computes only diffuse flux; flux_dn is total ! if ( do_broadband ) then broadband_up (:,:) = broadband_up (:,:) + gpt_flux_up (:,:) broadband_dn (:,:) = broadband_dn (:,:) + gpt_flux_dn (:,:) + gpt_flux_dir (:,:) broadband_dir (:,:) = broadband_dir (:,:) + gpt_flux_dir (:,:) else gpt_flux_dn (:,:) = gpt_flux_dn (:,:) + gpt_flux_dir (:,:) end if end do end subroutine sw_solver_2stream ! ------------------------------------------------------------------------------------------------- ! ! Lower-level longwave kernels ! ! ------------------------------------------------------------------------------------------------- ! ! Compute LW source function for upward and downward emission at levels using linear-in-tau assumption ! See Clough et al., 1992, doi: 10.1029/92JD01419, Eq 13 ! ! --------------------------------------------------------------- subroutine lw_source_noscat ( ncol , nlay , top_at_1 , lay_source , lev_source , tau , trans , & source_dn , source_up ) integer , intent ( in ) :: ncol , nlay logical ( wl ), intent ( in ) :: top_at_1 real ( wp ), dimension ( ncol , nlay ), intent ( in ) :: lay_source , & ! Planck source at layer center tau , & ! Optical path (tau/mu) trans ! Transmissivity (exp(-tau)) real ( wp ), dimension ( ncol , nlay + 1 ), intent ( in ) :: lev_source ! Planck source at levels (layer edges) real ( wp ), dimension ( ncol , nlay ), target , & intent ( out ) :: source_dn , source_up ! Source function at layer edges ! Down at the bottom of the layer, up at the top ! -------------------------------- real ( wp ), dimension (:,:), pointer :: source_inc , source_dec integer :: icol , ilay real ( wp ) :: fact real ( wp ), parameter :: tau_thresh = sqrt ( sqrt ( epsilon ( tau ))) ! --------------------------------------------------------------- if ( top_at_1 ) then source_inc => source_dn source_dec => source_up else source_inc => source_up source_dec => source_dn end if do ilay = 1 , nlay do icol = 1 , ncol ! ! Weighting factor. Use 3rd order series expansion when rounding error (~tau^2) ! is of order epsilon (smallest difference from 1. in working precision) ! Thanks to Peter Blossey (UW) for the idea and Dmitry Alexeev (Nvidia) for suggesting 3rd order ! if ( tau ( icol , ilay ) > tau_thresh ) then fact = ( 1._wp - trans ( icol , ilay )) / tau ( icol , ilay ) - trans ( icol , ilay ) else fact = tau ( icol , ilay ) * ( 0.5_wp + tau ( icol , ilay ) * ( - 1._wp / 3._wp + tau ( icol , ilay ) * 1._wp / 8._wp ) ) end if ! ! Equation below is developed in Clough et al., 1992, doi:10.1029/92JD01419, Eq 13 ! source_inc ( icol , ilay ) = ( 1._wp - trans ( icol , ilay )) * lev_source ( icol , ilay + 1 ) + & 2._wp * fact * ( lay_source ( icol , ilay ) - lev_source ( icol , ilay + 1 )) source_dec ( icol , ilay ) = ( 1._wp - trans ( icol , ilay )) * lev_source ( icol , ilay ) + & 2._wp * fact * ( lay_source ( icol , ilay ) - lev_source ( icol , ilay )) ! ! Even better - omit the layer Planck source (not working so well) ! if (. false .) then source_inc ( icol , ilay ) = ( 1._wp - trans ( icol , ilay )) * lev_source ( icol , ilay + 1 ) + & fact * ( lev_source ( icol , ilay ) - lev_source ( icol , ilay + 1 )) source_dec ( icol , ilay ) = ( 1._wp - trans ( icol , ilay )) * lev_source ( icol , ilay ) + & fact * ( lev_source ( icol , ilay + 1 ) - lev_source ( icol , ilay )) end if end do end do end subroutine lw_source_noscat ! ------------------------------------------------------------------------------------------------- ! ! Longwave no-scattering transport - separate routines for up and down ! ! ------------------------------------------------------------------------------------------------- subroutine lw_transport_noscat_dn ( ncol , nlay , top_at_1 , & trans , source_dn , radn_dn ) integer , intent ( in ) :: ncol , nlay ! Number of columns, layers, g-points logical ( wl ), intent ( in ) :: top_at_1 ! real ( wp ), dimension ( ncol , nlay ), intent ( in ) :: trans ! transmissivity = exp(-tau) real ( wp ), dimension ( ncol , nlay ), intent ( in ) :: source_dn ! Diffuse radiation emitted by the layer real ( wp ), dimension ( ncol , nlay + 1 ), intent ( inout ) :: radn_dn ! Radiances [W/m2-str] Top level must contain incident flux boundary condition ! --------------------------------------------------- ! Local variables integer :: ilev ! --------------------------------------------------- if ( top_at_1 ) then ! ! Top of domain is index 1 ! do ilev = 2 , nlay + 1 radn_dn (:, ilev ) = trans (:, ilev - 1 ) * radn_dn (:, ilev - 1 ) + source_dn (:, ilev - 1 ) end do else ! ! Top of domain is index nlay+1 ! do ilev = nlay , 1 , - 1 radn_dn (:, ilev ) = trans (:, ilev ) * radn_dn (:, ilev + 1 ) + source_dn (:, ilev ) end do end if end subroutine lw_transport_noscat_dn ! ------------------------------------------------------------------------------------------------- subroutine lw_transport_noscat_up ( ncol , nlay , top_at_1 , & trans , source_up , radn_up , do_Jacobians , radn_upJac ) integer , intent ( in ) :: ncol , nlay ! Number of columns, layers, g-points logical ( wl ), intent ( in ) :: top_at_1 ! real ( wp ), dimension ( ncol , nlay ), intent ( in ) :: trans ! transmissivity = exp(-tau) real ( wp ), dimension ( ncol , nlay ), intent ( in ) :: source_up ! Diffuse radiation emitted by the layer real ( wp ), dimension ( ncol , nlay + 1 ), intent ( inout ) :: radn_up ! Radiances [W/m2-str] Top level must contain incident flux boundary condition logical ( wl ), intent ( in ) :: do_Jacobians real ( wp ), dimension ( ncol , nlay + 1 ), intent ( inout ) :: radn_upJac ! surface temperature Jacobian of Radiances [W/m2-str / K] ! --------------------------------------------------- ! Local variables integer :: ilev ! --------------------------------------------------- if ( top_at_1 ) then ! ! Top of domain is index 1 ! ! Upward propagation do ilev = nlay , 1 , - 1 radn_up (:, ilev ) = trans (:, ilev ) * radn_up (:, ilev + 1 ) + source_up (:, ilev ) if ( do_Jacobians ) & radn_upJac (:, ilev ) = trans (:, ilev ) * radn_upJac (:, ilev + 1 ) end do else ! ! Top of domain is index nlay+1 ! ! Upward propagation do ilev = 2 , nlay + 1 radn_up (:, ilev ) = trans (:, ilev - 1 ) * radn_up (:, ilev - 1 ) + source_up (:, ilev - 1 ) if ( do_Jacobians ) & radn_upJac (:, ilev ) = trans (:, ilev - 1 ) * radn_upJac (:, ilev - 1 ) end do end if end subroutine lw_transport_noscat_up ! ------------------------------------------------------------------------------------------------- ! Upward and (second) downward transport for re-scaled longwave solution ! adds adjustment factor based on cloud properties ! ! implementation notice: ! the adjustmentFactor computation can be skipped where Cn <= epsilon ! ------------------------------------------------------------------------------------------------- subroutine lw_transport_1rescl ( ncol , nlay , top_at_1 , & trans , source_dn , source_up , & radn_up , radn_dn , An , Cn ,& do_Jacobians , radn_up_Jac ) integer , intent ( in ) :: ncol , nlay ! Number of columns, layers, g-points logical ( wl ), intent ( in ) :: top_at_1 ! real ( wp ), dimension ( ncol , nlay ), intent ( in ) :: trans ! transmissivity = exp(-tau) real ( wp ), dimension ( ncol , nlay ), intent ( in ) :: source_dn , & source_up ! Diffuse radiation emitted by the layer real ( wp ), dimension ( ncol , nlay + 1 ), intent ( inout ) :: radn_up ! Radiances [W/m2-str] real ( wp ), dimension ( ncol , nlay + 1 ), intent ( inout ) :: radn_dn !Top level must contain incident flux boundary condition real ( wp ), dimension ( ncol , nlay ), intent ( in ) :: An , Cn logical ( wl ), intent ( in ) :: do_Jacobians real ( wp ), dimension ( ncol , nlay + 1 ), intent ( inout ) :: radn_up_Jac ! Surface temperature Jacobians [W/m2-str/K] ! ! We could in principle compute a downwelling Jacobian too, but it's small ! (only a small proportion of LW is scattered) and it complicates code and the API, ! so we will not ! ! Local variables integer :: ilev , icol ! --------------------------------------------------- real ( wp ) :: adjustmentFactor if ( top_at_1 ) then ! ! Top of domain is index 1 ! ! Upward propagation ! adjustment factor is obtained as a solution of 18b of the Tang paper ! eqvivalent to Eq.20 of the Tang paper but for linear-in-tau source do ilev = nlay , 1 , - 1 do icol = 1 , ncol adjustmentFactor = Cn ( icol , ilev ) * ( An ( icol , ilev ) * radn_dn ( icol , ilev ) - & trans ( icol , ilev ) * source_dn ( icol , ilev ) - source_up ( icol , ilev ) ) radn_up ( icol , ilev ) = trans ( icol , ilev ) * radn_up ( icol , ilev + 1 ) + source_up ( icol , ilev ) + & adjustmentFactor end do if ( do_Jacobians ) & radn_up_Jac (:, ilev ) = trans (:, ilev ) * radn_up_Jac (:, ilev + 1 ) end do ! Downward propagation ! radn_dn_Jac(:,1) = 0._wp ! adjustment factor is obtained as a solution of 19 of the Tang paper ! eqvivalent to Eq.21 of the Tang paper but for linear-in-tau source do ilev = 1 , nlay ! radn_dn_Jac(:,ilev+1) = trans(:,ilev)*radn_dn_Jac(:,ilev) do icol = 1 , ncol adjustmentFactor = Cn ( icol , ilev ) * ( An ( icol , ilev ) * radn_up ( icol , ilev ) - & trans ( icol , ilev ) * source_up ( icol , ilev ) - source_dn ( icol , ilev ) ) radn_dn ( icol , ilev + 1 ) = trans ( icol , ilev ) * radn_dn ( icol , ilev ) + source_dn ( icol , ilev ) + & adjustmentFactor ! adjustmentFactor = Cn(icol,ilev)*An(icol,ilev)*radn_up_Jac(icol,ilev) ! radn_dn_Jac(icol,ilev+1) = radn_dn_Jac(icol,ilev+1) + adjustmentFactor enddo end do else ! ! Top of domain is index nlay+1 ! ! Upward propagation ! adjustment factor is obtained as a solution of 18b of the Tang paper ! eqvivalent to Eq.20 of the Tang paper but for linear-in-tau source do ilev = 1 , nlay radn_up (:, ilev + 1 ) = trans (:, ilev ) * radn_up (:, ilev ) + source_up (:, ilev ) do icol = 1 , ncol adjustmentFactor = Cn ( icol , ilev ) * ( An ( icol , ilev ) * radn_dn ( icol , ilev + 1 ) - & trans ( icol , ilev ) * source_dn ( icol , ilev ) - source_up ( icol , ilev ) ) radn_up ( icol , ilev + 1 ) = trans ( icol , ilev ) * radn_up ( icol , ilev ) + source_up ( icol , ilev ) + & adjustmentFactor enddo if ( do_Jacobians ) & radn_up_Jac (:, ilev + 1 ) = trans (:, ilev ) * radn_up_Jac (:, ilev ) end do ! Downward propagation ! adjustment factor is obtained as a solution of 19 of the Tang paper ! eqvivalent to Eq.21 of the Tang paper but for linear-in-tau source ! radn_dn_Jac(:,nlay+1) = 0._wp do ilev = nlay , 1 , - 1 ! radn_dn_Jac(:,ilev) = trans(:,ilev)*radn_dn_Jac(:,ilev+1) do icol = 1 , ncol adjustmentFactor = Cn ( icol , ilev ) * ( An ( icol , ilev ) * radn_up ( icol , ilev ) - & trans ( icol , ilev ) * source_up ( icol , ilev ) - source_dn ( icol , ilev ) ) radn_dn ( icol , ilev ) = trans ( icol , ilev ) * radn_dn ( icol , ilev + 1 ) + source_dn ( icol , ilev ) + & adjustmentFactor ! adjustmentFactor = Cn(icol,ilev)*An(icol,ilev)*radn_up_Jac(icol,ilev) ! radn_dn_Jac(icol,ilev) = radn_dn_Jac(icol,ilev) + adjustmentFactor enddo end do end if end subroutine lw_transport_1rescl ! ------------------------------------------------------------------------------------------------- ! ! Longwave two-stream solutions to diffuse reflectance and transmittance for a layer ! with optical depth tau, single scattering albedo w0, and asymmetery parameter g. ! ! Equations are developed in Meador and Weaver, 1980, ! doi:10.1175/1520-0469(1980)037<0630:TSATRT>2.0.CO;2 ! ! ------------------------------------------------------------------------------------------------- pure subroutine lw_two_stream ( ncol , nlay , tau , w0 , g , & gamma1 , gamma2 , Rdif , Tdif ) integer , intent ( in ) :: ncol , nlay real ( wp ), dimension ( ncol , nlay ), intent ( in ) :: tau , w0 , g real ( wp ), dimension ( ncol , nlay ), intent ( out ) :: gamma1 , gamma2 , Rdif , Tdif ! ----------------------- integer :: i , j ! Variables used in Meador and Weaver real ( wp ) :: k ( ncol ) ! Ancillary variables real ( wp ) :: RT_term ( ncol ) real ( wp ) :: exp_minusktau ( ncol ), exp_minus2ktau ( ncol ) real ( wp ), parameter :: LW_diff_sec = 1.66 ! 1./cos(diffusivity angle) ! --------------------------------- do j = 1 , nlay do i = 1 , ncol ! ! Coefficients differ from SW implementation because the phase function is more isotropic ! Here we follow Fu et al. 1997, doi:10.1175/1520-0469(1997)054<2799:MSPITI>2.0.CO;2 ! and use a diffusivity sec of 1.66 ! gamma1 ( i , j ) = LW_diff_sec * ( 1._wp - 0.5_wp * w0 ( i , j ) * ( 1._wp + g ( i , j ))) ! Fu et al. Eq 2.9 gamma2 ( i , j ) = LW_diff_sec * 0.5_wp * w0 ( i , j ) * ( 1._wp - g ( i , j )) ! Fu et al. Eq 2.10 ! Eq 18; k = SQRT(gamma1**2 - gamma2**2), limited below to avoid div by 0. ! k = 0 for isotropic, conservative scattering; this lower limit on k ! gives relative error with respect to conservative solution ! of < 0.1% in Rdif down to tau = 10^-9 k ( i ) = sqrt ( max (( gamma1 ( i , j ) - gamma2 ( i , j )) * ( gamma1 ( i , j ) + gamma2 ( i , j )), 1.e-12_wp )) end do ! Written to encourage vectorization of exponential exp_minusktau ( 1 : ncol ) = exp ( - tau ( 1 : ncol , j ) * k ( 1 : ncol )) ! ! Diffuse reflection and transmission ! do i = 1 , ncol exp_minus2ktau ( i ) = exp_minusktau ( i ) * exp_minusktau ( i ) ! Refactored to avoid rounding errors when k, gamma1 are of very different magnitudes RT_term ( i ) = 1._wp / ( k ( i ) * ( 1._wp + exp_minus2ktau ( i )) + & gamma1 ( i , j ) * ( 1._wp - exp_minus2ktau ( i )) ) ! Equation 25 Rdif ( i , j ) = RT_term ( i ) * gamma2 ( i , j ) * ( 1._wp - exp_minus2ktau ( i )) ! Equation 26 Tdif ( i , j ) = RT_term ( i ) * 2._wp * k ( i ) * exp_minusktau ( i ) end do end do end subroutine lw_two_stream ! --------------------------------------------------------------- ! ! Compute LW source function for upward and downward emission at levels using linear-in-tau assumption ! This version straight from ECRAD ! Source is provided as W/m2-str; factor of pi converts to flux units ! ! --------------------------------------------------------------- subroutine lw_source_2str ( ncol , nlay , top_at_1 , & sfc_emis , sfc_src , & lay_source , lev_source , & gamma1 , gamma2 , rdif , tdif , tau , source_dn , source_up , source_sfc ) & bind ( C , name = \"rte_lw_source_2str\" ) integer , intent ( in ) :: ncol , nlay logical ( wl ), intent ( in ) :: top_at_1 real ( wp ), dimension ( ncol ), intent ( in ) :: sfc_emis , sfc_src real ( wp ), dimension ( ncol , nlay ), intent ( in ) :: lay_source , & ! Planck source at layer center tau , & ! Optical depth (tau) gamma1 , gamma2 ,& ! Coupling coefficients rdif , tdif ! Layer reflectance and transmittance real ( wp ), dimension ( ncol , nlay + 1 ), target , & intent ( in ) :: lev_source ! Planck source at layer edges real ( wp ), dimension ( ncol , nlay ), intent ( out ) :: source_dn , source_up real ( wp ), dimension ( ncol ), intent ( out ) :: source_sfc ! Source function for upward radation at surface integer :: icol , ilay real ( wp ) :: Z , Zup_top , Zup_bottom , Zdn_top , Zdn_bottom real ( wp ), dimension (:), pointer :: lev_source_bot , lev_source_top ! --------------------------------------------------------------- do ilay = 1 , nlay if ( top_at_1 ) then lev_source_top => lev_source (:, ilay ) lev_source_bot => lev_source (:, ilay + 1 ) else lev_source_top => lev_source (:, ilay + 1 ) lev_source_bot => lev_source (:, ilay ) end if do icol = 1 , ncol if ( tau ( icol , ilay ) > 1.0e-8_wp ) then ! ! Toon et al. (JGR 1989) Eqs 26-27 ! Z = ( lev_source_bot ( icol ) - lev_source_top ( icol )) / ( tau ( icol , ilay ) * ( gamma1 ( icol , ilay ) + gamma2 ( icol , ilay ))) Zup_top = Z + lev_source_top ( icol ) Zup_bottom = Z + lev_source_bot ( icol ) Zdn_top = - Z + lev_source_top ( icol ) Zdn_bottom = - Z + lev_source_bot ( icol ) source_up ( icol , ilay ) = pi * ( Zup_top - rdif ( icol , ilay ) * Zdn_top - tdif ( icol , ilay ) * Zup_bottom ) source_dn ( icol , ilay ) = pi * ( Zdn_bottom - rdif ( icol , ilay ) * Zup_bottom - tdif ( icol , ilay ) * Zdn_top ) else source_up ( icol , ilay ) = 0._wp source_dn ( icol , ilay ) = 0._wp end if end do end do do icol = 1 , ncol source_sfc ( icol ) = pi * sfc_emis ( icol ) * sfc_src ( icol ) end do end subroutine lw_source_2str ! ------------------------------------------------------------------------------------------------- ! ! Lower-level shortwave kernels ! ! ------------------------------------------------------------------------------------------------- ! ! Two-stream solutions to diffuse reflectance and transmittance for a layer ! with optical depth tau, single scattering albedo w0, and asymmetery parameter g. ! Direct reflectance and transmittance used to compute direct beam source for diffuse radiation ! in layers and at surface; report direct beam as a byproduct ! Computing the direct-beam source for diffuse radiation at the same time as R and T for ! direct radiation reduces memory traffic and use. ! ! Equations are developed in Meador and Weaver, 1980, ! doi:10.1175/1520-0469(1980)037<0630:TSATRT>2.0.CO;2 ! ! ------------------------------------------------------------------------------------------------- pure subroutine sw_dif_and_source ( ncol , nlay , top_at_1 , mu0 , sfc_albedo , & tau , w0 , g , & Rdif , Tdif , source_dn , source_up , source_sfc , flux_dn_dir ) bind ( C , name = \"rte_sw_source_dir\" ) integer , intent ( in ) :: ncol , nlay logical ( wl ), intent ( in ) :: top_at_1 real ( wp ), dimension ( ncol ), intent ( in ) :: sfc_albedo ! surface albedo for direct radiation real ( wp ), dimension ( ncol , nlay ), intent ( in ) :: tau , w0 , g , mu0 real ( wp ), dimension ( ncol , nlay ), intent ( out ) :: Rdif , Tdif , source_dn , source_up real ( wp ), dimension ( ncol ), intent ( out ) :: source_sfc ! Source function for upward radation at surface real ( wp ), dimension ( ncol , nlay + 1 ), target , & intent ( inout ) :: flux_dn_dir ! Direct beam flux ! ----------------------- integer :: i , j ! Variables used in Meador and Weaver real ( wp ) :: gamma1 , gamma2 , gamma3 , gamma4 , alpha1 , alpha2 ! Ancillary variables real ( wp ), parameter :: min_k = 1.e4_wp * epsilon ( 1._wp ) ! Suggestion from Chiel van Heerwaarden real ( wp ), parameter :: min_mu0 = sqrt ( epsilon ( 1._wp )) real ( wp ) :: k , exp_minusktau , k_mu , k_gamma3 , k_gamma4 real ( wp ) :: RT_term , exp_minus2ktau real ( wp ) :: Rdir , Tdir , Tnoscat real ( wp ), pointer , dimension (:) :: dir_flux_inc , dir_flux_trans integer :: lay_index real ( wp ) :: tau_s , w0_s , g_s , mu0_s ! --------------------------------- do j = 1 , nlay if ( top_at_1 ) then lay_index = j dir_flux_inc => flux_dn_dir (:, lay_index ) dir_flux_trans => flux_dn_dir (:, lay_index + 1 ) else lay_index = nlay - j + 1 dir_flux_inc => flux_dn_dir (:, lay_index + 1 ) dir_flux_trans => flux_dn_dir (:, lay_index ) end if !$OMP SIMD do i = 1 , ncol ! ! Scalars ! tau_s = tau ( i , lay_index ) w0_s = w0 ( i , lay_index ) g_s = g ( i , lay_index ) ! ! Zdunkowski Practical Improved Flux Method \"PIFM\" ! (Zdunkowski et al., 1980; Contributions to Atmospheric Physics 53, 147-66) ! gamma1 = ( 8._wp - w0_s * ( 5._wp + 3._wp * g_s )) * . 25_wp gamma2 = 3._wp * ( w0_s * ( 1._wp - g_s )) * . 25_wp ! ! Direct reflect and transmission ! ! Eq 18; k = SQRT(gamma1**2 - gamma2**2), limited below to avoid div by 0. ! k = 0 for isotropic, conservative scattering; this lower limit on k ! gives relative error with respect to conservative solution ! of < 0.1% in Rdif down to tau = 10^-9 k = sqrt ( max (( gamma1 - gamma2 ) * ( gamma1 + gamma2 ), min_k )) exp_minusktau = exp ( - tau_s * k ) exp_minus2ktau = exp_minusktau * exp_minusktau ! Refactored to avoid rounding errors when k, gamma1 are of very different magnitudes RT_term = 1._wp / ( k * ( 1._wp + exp_minus2ktau ) + & gamma1 * ( 1._wp - exp_minus2ktau ) ) ! Equation 25 Rdif ( i , lay_index ) = RT_term * gamma2 * ( 1._wp - exp_minus2ktau ) ! Equation 26 Tdif ( i , lay_index ) = RT_term * 2._wp * k * exp_minusktau ! ! On a round earth, where mu0 can increase with depth in the atmosphere, ! levels with mu0 <= 0 have no direct beam and hence no source for diffuse light ! Compute transmission and reflection using a nominal value but mask out later ! mu0_s = max ( min_mu0 , mu0 ( i , lay_index )) k_mu = k * mu0_s ! ! Equation 14, multiplying top and bottom by exp(-k*tau) ! and rearranging to avoid div by 0. ! RT_term = w0_s * RT_term / merge ( 1._wp - k_mu * k_mu , & epsilon ( 1._wp ), & abs ( 1._wp - k_mu * k_mu ) >= epsilon ( 1._wp )) ! ! Zdunkowski Practical Improved Flux Method \"PIFM\" ! (Zdunkowski et al., 1980; Contributions to Atmospheric Physics 53, 147-66) ! gamma3 = ( 2._wp - 3._wp * mu0_s * g_s ) * . 25_wp gamma4 = 1._wp - gamma3 alpha1 = gamma1 * gamma4 + gamma2 * gamma3 ! Eq. 16 alpha2 = gamma1 * gamma3 + gamma2 * gamma4 ! Eq. 17 ! ! Transmittance of direct, unscattered beam. ! k_gamma3 = k * gamma3 k_gamma4 = k * gamma4 Tnoscat = exp ( - tau_s / mu0_s ) Rdir = RT_term * & (( 1._wp - k_mu ) * ( alpha2 + k_gamma3 ) - & ( 1._wp + k_mu ) * ( alpha2 - k_gamma3 ) * exp_minus2ktau - & 2.0_wp * ( k_gamma3 - alpha2 * k_mu ) * exp_minusktau * Tnoscat ) ! ! Equation 15, multiplying top and bottom by exp(-k*tau), ! multiplying through by exp(-tau/mu0) to ! prefer underflow to overflow ! Omitting direct transmittance ! Tdir = - RT_term * & (( 1._wp + k_mu ) * ( alpha1 + k_gamma4 ) * Tnoscat - & ( 1._wp - k_mu ) * ( alpha1 - k_gamma4 ) * exp_minus2ktau * Tnoscat - & 2.0_wp * ( k_gamma4 + alpha1 * k_mu ) * exp_minusktau ) ! Final check that energy is not spuriously created, by recognizing that ! the beam can either be reflected, penetrate unscattered to the base of a layer, ! or penetrate through but be scattered on the way - the rest is absorbed ! Makes the equations safer in single precision. Credit: Robin Hogan, Peter Ukkonen Rdir = max ( 0.0_wp , min ( Rdir , ( 1.0_wp - Tnoscat ) )) Tdir = max ( 0.0_wp , min ( Tdir , ( 1.0_wp - Tnoscat - Rdir ) )) source_up ( i , lay_index ) = Rdir * dir_flux_inc ( i ) source_dn ( i , lay_index ) = Tdir * dir_flux_inc ( i ) dir_flux_trans ( i ) = Tnoscat * dir_flux_inc ( i ) end do end do ! ! T and R for the direct beam are computed using nominal values even when the ! sun is below the horizon (mu0 < 0); set those values back to zero ! This won't be efficient if many nighttime columns are passed ! source_sfc (:) = merge ( dir_flux_trans (:) * sfc_albedo (:), & 0._wp , mu0 (:, lay_index ) > 0._wp ) where ( mu0 (:,:) <= 0._wp ) source_up (:,:) = 0._wp source_dn (:,:) = 0._wp end where end subroutine sw_dif_and_source ! --------------------------------------------------------------- ! ! Transport of diffuse radiation through a vertically layered atmosphere. ! Equations are after Shonk and Hogan 2008, doi:10.1175/2007JCLI1940.1 (SH08) ! This routine is shared by longwave and shortwave ! ! ------------------------------------------------------------------------------------------------- subroutine adding ( ncol , nlay , top_at_1 , & albedo_sfc , & rdif , tdif , & src_dn , src_up , src_sfc , & flux_up , flux_dn ) integer , intent ( in ) :: ncol , nlay logical ( wl ), intent ( in ) :: top_at_1 real ( wp ), dimension ( ncol ), intent ( in ) :: albedo_sfc real ( wp ), dimension ( ncol , nlay ), intent ( in ) :: rdif , tdif real ( wp ), dimension ( ncol , nlay ), intent ( in ) :: src_dn , src_up real ( wp ), dimension ( ncol ), intent ( in ) :: src_sfc real ( wp ), dimension ( ncol , nlay + 1 ), intent ( out ) :: flux_up ! intent(inout) because top layer includes incident flux real ( wp ), dimension ( ncol , nlay + 1 ), intent ( inout ) :: flux_dn ! ------------------ integer :: ilev real ( wp ), dimension ( ncol , nlay + 1 ) :: albedo , & ! reflectivity to diffuse radiation below this level ! alpha in SH08 src ! source of diffuse upwelling radiation from emission or ! scattering of direct beam ! G in SH08 real ( wp ), dimension ( ncol , nlay ) :: denom ! beta in SH08 ! ------------------ ! ! Indexing into arrays for upward and downward propagation depends on the vertical ! orientation of the arrays (whether the domain top is at the first or last index) ! We write the loops out explicitly so compilers will have no trouble optimizing them. ! if ( top_at_1 ) then ilev = nlay + 1 ! Albedo of lowest level is the surface albedo... albedo (:, ilev ) = albedo_sfc (:) ! ... and source of diffuse radiation is surface emission src (:, ilev ) = src_sfc (:) ! ! From bottom to top of atmosphere -- ! compute albedo and source of upward radiation ! do ilev = nlay , 1 , - 1 denom (:, ilev ) = 1._wp / ( 1._wp - rdif (:, ilev ) * albedo (:, ilev + 1 )) ! Eq 10 albedo (:, ilev ) = rdif (:, ilev ) + & tdif (:, ilev ) * tdif (:, ilev ) * albedo (:, ilev + 1 ) * denom (:, ilev ) ! Equation 9 ! ! Equation 11 -- source is emitted upward radiation at top of layer plus ! radiation emitted at bottom of layer, ! transmitted through the layer and reflected from layers below (tdiff*src*albedo) ! src (:, ilev ) = src_up (:, ilev ) + & tdif (:, ilev ) * denom (:, ilev ) * & ( src (:, ilev + 1 ) + albedo (:, ilev + 1 ) * src_dn (:, ilev )) end do ! Eq 12, at the top of the domain upwelling diffuse is due to ... ilev = 1 flux_up (:, ilev ) = flux_dn (:, ilev ) * albedo (:, ilev ) + & ! ... reflection of incident diffuse and src (:, ilev ) ! emission from below ! ! From the top of the atmosphere downward -- compute fluxes ! do ilev = 2 , nlay + 1 flux_dn (:, ilev ) = ( tdif (:, ilev - 1 ) * flux_dn (:, ilev - 1 ) + & ! Equation 13 rdif (:, ilev - 1 ) * src (:, ilev ) + & src_dn (:, ilev - 1 )) * denom (:, ilev - 1 ) flux_up (:, ilev ) = flux_dn (:, ilev ) * albedo (:, ilev ) + & ! Equation 12 src (:, ilev ) end do else ilev = 1 ! Albedo of lowest level is the surface albedo... albedo (:, ilev ) = albedo_sfc (:) ! ... and source of diffuse radiation is surface emission src (:, ilev ) = src_sfc (:) ! ! From bottom to top of atmosphere -- ! compute albedo and source of upward radiation ! do ilev = 1 , nlay denom (:, ilev ) = 1._wp / ( 1._wp - rdif (:, ilev ) * albedo (:, ilev )) ! Eq 10 albedo (:, ilev + 1 ) = rdif (:, ilev ) + & tdif (:, ilev ) * tdif (:, ilev ) * albedo (:, ilev ) * denom (:, ilev ) ! Equation 9 ! ! Equation 11 -- source is emitted upward radiation at top of layer plus ! radiation emitted at bottom of layer, ! transmitted through the layer and reflected from layers below (tdiff*src*albedo) ! src (:, ilev + 1 ) = src_up (:, ilev ) + & tdif (:, ilev ) * denom (:, ilev ) * & ( src (:, ilev ) + albedo (:, ilev ) * src_dn (:, ilev )) end do ! Eq 12, at the top of the domain upwelling diffuse is due to ... ilev = nlay + 1 flux_up (:, ilev ) = flux_dn (:, ilev ) * albedo (:, ilev ) + & ! ... reflection of incident diffuse and src (:, ilev ) ! scattering by the direct beam below ! ! From the top of the atmosphere downward -- compute fluxes ! do ilev = nlay , 1 , - 1 flux_dn (:, ilev ) = ( tdif (:, ilev ) * flux_dn (:, ilev + 1 ) + & ! Equation 13 rdif (:, ilev ) * src (:, ilev ) + & src_dn (:, ilev )) * denom (:, ilev ) flux_up (:, ilev ) = flux_dn (:, ilev ) * albedo (:, ilev ) + & ! Equation 12 src (:, ilev ) end do end if end subroutine adding end module mo_rte_solver_kernels","tags":"","loc":"sourcefile/mo_rte_solver_kernels.f90.html"},{"title":"mo_rte_util_array.F90 – RTE kernels","text":"Files dependent on this one sourcefile~~mo_rte_util_array.f90~~AfferentGraph sourcefile~mo_rte_util_array.f90 mo_rte_util_array.F90 sourcefile~mo_rte_solver_kernels.f90 mo_rte_solver_kernels.F90 sourcefile~mo_rte_solver_kernels.f90->sourcefile~mo_rte_util_array.f90 Help × Graph Key Nodes of different colours represent the following: Graph Key Source File Source File This Page's Entity This Page's Entity Solid arrows point from a file to a file which it depends on. A file\n is dependent upon another if the latter must be compiled before the former\n can be. Contents Modules mo_rte_util_array Source Code mo_rte_util_array.F90 Source Code ! This code is part of Radiative Transfer for Energetics (RTE) ! ! Contacts: Robert Pincus and Eli Mlawer ! email: rrtmgp@aer.com ! ! Copyright 2015- Atmospheric and Environmental Research, ! Regents of the University of Colorado, ! Trustees of Columbia University in the City of New York ! All right reserved. ! ! Use and duplication is permitted under the terms of the ! BSD 3-clause license, see http://opensource.org/licenses/BSD-3-Clause ! ------------------------------------------------------------------------------------------------- module mo_rte_util_array use mo_rte_kind , only : wp , wl implicit none !> !> Efficiently set arrays to zero !> interface zero_array module procedure zero_array_1D , zero_array_2D , zero_array_3D , zero_array_4D end interface public :: zero_array contains !------------------------------------------------------------------------------------------------- ! Initializing arrays to 0 !------------------------------------------------------------------------------------------------- subroutine zero_array_1D ( ni , array ) bind ( C , name = \"zero_array_1D\" ) integer , intent ( in ) :: ni real ( wp ), dimension ( ni ), intent ( out ) :: array ! ----------------------- integer :: i ! ----------------------- !$acc parallel loop copyout(array) !$omp target teams distribute parallel do simd map(from:array) do i = 1 , ni array ( i ) = 0.0_wp end do end subroutine zero_array_1D ! ---------------------------------------------------------- subroutine zero_array_2D ( ni , nj , array ) bind ( C , name = \"zero_array_2D\" ) integer , intent ( in ) :: ni , nj real ( wp ), dimension ( ni , nj ), intent ( out ) :: array ! ----------------------- integer :: i , j ! ----------------------- !$acc parallel loop collapse(2) copyout(array) !$omp target teams distribute parallel do simd collapse(2) map(from:array) do j = 1 , nj do i = 1 , ni array ( i , j ) = 0.0_wp end do end do end subroutine zero_array_2D ! ---------------------------------------------------------- subroutine zero_array_3D ( ni , nj , nk , array ) bind ( C , name = \"zero_array_3D\" ) integer , intent ( in ) :: ni , nj , nk real ( wp ), dimension ( ni , nj , nk ), intent ( out ) :: array ! ----------------------- integer :: i , j , k ! ----------------------- !$acc parallel loop collapse(3) copyout(array) !$omp target teams distribute parallel do simd collapse(3) map(from:array) do k = 1 , nk do j = 1 , nj do i = 1 , ni array ( i , j , k ) = 0.0_wp end do end do end do end subroutine zero_array_3D ! ---------------------------------------------------------- subroutine zero_array_4D ( ni , nj , nk , nl , array ) bind ( C , name = \"zero_array_4D\" ) integer , intent ( in ) :: ni , nj , nk , nl real ( wp ), dimension ( ni , nj , nk , nl ), intent ( out ) :: array ! ----------------------- integer :: i , j , k , l ! ----------------------- !$acc parallel loop collapse(4) copyout(array) !$omp target teams distribute parallel do simd collapse(4) map(from:array) do l = 1 , nl do k = 1 , nk do j = 1 , nj do i = 1 , ni array ( i , j , k , l ) = 0.0_wp end do end do end do end do end subroutine zero_array_4D end module mo_rte_util_array","tags":"","loc":"sourcefile/mo_rte_util_array.f90.html"},{"title":"mo_optical_props_kernels.F90 – RTE kernels","text":"Contents Modules mo_optical_props_kernels Source Code mo_optical_props_kernels.F90 Source Code ! This code is part of Radiative Transfer for Energetics (RTE) ! ! Contacts: Robert Pincus and Eli Mlawer ! email: rrtmgp@aer.com ! ! Copyright 2015-, Atmospheric and Environmental Research, ! Regents of the University of Colorado, Trustees of Columbia University. All right reserved. ! ! Use and duplication is permitted under the terms of the ! BSD 3-clause license, see http://opensource.org/licenses/BSD-3-Clause ! ------------------------------------------------------------------------------------------------- ! !> ## Kernels for arrays of optical properties: !> - delta-scaling !> - adding two sets of properties !> - extracting subsets along the column dimension ! ! ------------------------------------------------------------------------------------------------- module mo_optical_props_kernels use , intrinsic :: iso_c_binding use mo_rte_kind , only : wp , wl implicit none public ! ------------------------------------------------------------------------------------------------- ! ! Delta-scaling is provided only for two-stream properties at present ! interface delta_scale_2str_kernel ! ------------------------------------------------------------------------------------------------- !> Delta-scale two-stream optical properties given user-provided value of f (forward scattering) ! pure subroutine delta_scale_2str_f_k ( ncol , nlay , ngpt , tau , ssa , g , f ) & bind ( C , name = \"rte_delta_scale_2str_f_k\" ) use mo_rte_kind , only : wp , wl integer , intent ( in ) :: ncol , nlay , ngpt !! Array sizes real ( wp ), dimension ( ncol , nlay , ngpt ), intent ( inout ) :: tau , ssa , g !! Optical depth, single-scattering albedo, asymmetry parameter real ( wp ), dimension ( ncol , nlay , ngpt ), intent ( in ) :: f !! User-provided forward-scattering fraction end subroutine delta_scale_2str_f_k ! --------------------------------- !> Delta-scale assuming forward-scatternig fraction is the square of the asymmetry parameter !> i.e. f = g^2 ! pure subroutine delta_scale_2str_k ( ncol , nlay , ngpt , tau , ssa , g ) & bind ( C , name = \"rte_delta_scale_2str_k\" ) use mo_rte_kind , only : wp , wl integer , intent ( in ) :: ncol , nlay , ngpt !! Array sizes real ( wp ), dimension ( ncol , nlay , ngpt ), intent ( inout ) :: tau , ssa , g !! Optical depth, single-scattering albedo, asymmetry parameter end subroutine delta_scale_2str_k end interface delta_scale_2str_kernel ! ------------------------------------------------------------------------------------------------- ! ! Addition of optical properties: the first set are incremented by the second set. ! ! There are three possible representations of optical properties (scalar = optical depth only; ! two-stream = tau, single-scattering albedo, and asymmetry factor g, and ! n-stream = tau, ssa, and phase function moments p.) Thus we need nine routines, three for ! each choice of representation on the left hand side times three representations of the ! optical properties to be added. ! ! There are two sets of these nine routines. In the first the two sets of optical ! properties are defined at the same spectral resolution. There is also a set of routines ! to add properties defined at lower spectral resolution to a set defined at higher spectral ! resolution (adding properties defined by band to those defined by g-point) ! ! ------------------------------------------------------------------------------------------------- !> increase one absorption optical depth by a second value interface pure subroutine increment_1scalar_by_1scalar ( ncol , nlay , ngpt , & tau1 , & tau2 ) bind ( C , name = \"rte_increment_1scalar_by_1scalar\" ) use mo_rte_kind , only : wp , wl integer , intent ( in ) :: ncol , nlay , ngpt !! array sizes real ( wp ), dimension ( ncol , nlay , ngpt ), intent ( inout ) :: tau1 !! optical properties to be modified real ( wp ), dimension ( ncol , nlay , ngpt ), intent ( in ) :: tau2 !! optical properties to be added to original end subroutine increment_1scalar_by_1scalar end interface ! --------------------------------- !> increase absorption optical depth with extinction optical depth (2-stream form) interface pure subroutine increment_1scalar_by_2stream ( ncol , nlay , ngpt , & tau1 , & tau2 , ssa2 ) bind ( C , name = \"rte_increment_1scalar_by_2stream\" ) use mo_rte_kind , only : wp , wl integer , intent ( in ) :: ncol , nlay , ngpt !! array sizes real ( wp ), dimension ( ncol , nlay , ngpt ), intent ( inout ) :: tau1 !! optical properties to be modified real ( wp ), dimension ( ncol , nlay , ngpt ), intent ( in ) :: tau2 , ssa2 !! optical properties to be added to original end subroutine increment_1scalar_by_2stream end interface ! --------------------------------- !> increase absorption optical depth with extinction optical depth (n-stream form) interface pure subroutine increment_1scalar_by_nstream ( ncol , nlay , ngpt , & tau1 , & tau2 , ssa2 ) bind ( C , name = \"rte_increment_1scalar_by_nstream\" ) use mo_rte_kind , only : wp , wl integer , intent ( in ) :: ncol , nlay , ngpt !! array sizes real ( wp ), dimension ( ncol , nlay , ngpt ), intent ( inout ) :: tau1 !! optical properties to be modified real ( wp ), dimension ( ncol , nlay , ngpt ), intent ( in ) :: tau2 , ssa2 !! optical properties to be added to original end subroutine increment_1scalar_by_nstream end interface ! --------------------------------- ! --------------------------------- !> increment two-stream optical properties \\tau, \\omega_0, g with absorption optical depth interface pure subroutine increment_2stream_by_1scalar ( ncol , nlay , ngpt , & tau1 , ssa1 , & tau2 ) bind ( C , name = \"rte_increment_2stream_by_1scalar\" ) use mo_rte_kind , only : wp , wl integer , intent ( in ) :: ncol , nlay , ngpt !! array sizes real ( wp ), dimension ( ncol , nlay , ngpt ), intent ( inout ) :: tau1 , ssa1 !! optical properties to be modified real ( wp ), dimension ( ncol , nlay , ngpt ), intent ( in ) :: tau2 !! optical properties to be added to original end subroutine increment_2stream_by_1scalar end interface ! --------------------------------- !> increment two-stream optical properties \\tau, \\omega_0, g with a second set interface pure subroutine increment_2stream_by_2stream ( ncol , nlay , ngpt , & tau1 , ssa1 , g1 , & tau2 , ssa2 , g2 ) bind ( C , name = \"rte_increment_2stream_by_2stream\" ) use mo_rte_kind , only : wp , wl integer , intent ( in ) :: ncol , nlay , ngpt !! array sizes real ( wp ), dimension ( ncol , nlay , ngpt ), intent ( inout ) :: tau1 , ssa1 , g1 !! optical properties to be modified real ( wp ), dimension ( ncol , nlay , ngpt ), intent ( in ) :: tau2 , ssa2 , g2 !! optical properties to be added to original end subroutine increment_2stream_by_2stream end interface ! --------------------------------- !> increment two-stream optical properties \\tau, \\omega_0, g with _n_-stream interface pure subroutine increment_2stream_by_nstream ( ncol , nlay , ngpt , nmom2 , & tau1 , ssa1 , g1 , & tau2 , ssa2 , p2 ) bind ( C , name = \"rte_increment_2stream_by_nstream\" ) use mo_rte_kind , only : wp , wl integer , intent ( in ) :: ncol , nlay , ngpt , nmom2 !! array sizes real ( wp ), dimension ( ncol , nlay , ngpt ), intent ( inout ) :: tau1 , ssa1 , g1 !! optical properties to be modified real ( wp ), dimension ( ncol , nlay , ngpt ), intent ( in ) :: tau2 , ssa2 !! optical properties to be added to original real ( wp ), dimension ( nmom2 , & ncol , nlay , ngpt ), intent ( in ) :: p2 !! moments of the phase function to be added end subroutine increment_2stream_by_nstream end interface ! --------------------------------- ! --------------------------------- !> increment _n_-stream optical properties \\tau, \\omega_0, p with absorption optical depth interface pure subroutine increment_nstream_by_1scalar ( ncol , nlay , ngpt , & tau1 , ssa1 , & tau2 ) bind ( C , name = \"rte_increment_nstream_by_1scalar\" ) use mo_rte_kind , only : wp , wl integer , intent ( in ) :: ncol , nlay , ngpt !! array sizes real ( wp ), dimension ( ncol , nlay , ngpt ), intent ( inout ) :: tau1 , ssa1 !! optical properties to be modified real ( wp ), dimension ( ncol , nlay , ngpt ), intent ( in ) :: tau2 !! optical properties to be added to original end subroutine increment_nstream_by_1scalar end interface ! --------------------------------- !> increment _n_-stream optical properties \\tau, \\omega_0, p with two-stream values interface pure subroutine increment_nstream_by_2stream ( ncol , nlay , ngpt , nmom1 , & tau1 , ssa1 , p1 , & tau2 , ssa2 , g2 ) bind ( C , name = \"rte_increment_nstream_by_2stream\" ) use mo_rte_kind , only : wp , wl integer , intent ( in ) :: ncol , nlay , ngpt , nmom1 !! array sizes real ( wp ), dimension ( ncol , nlay , ngpt ), intent ( inout ) :: tau1 , ssa1 !! optical properties to be modified real ( wp ), dimension ( nmom1 , & ncol , nlay , ngpt ), intent ( inout ) :: p1 !! moments of the phase function be modified real ( wp ), dimension ( ncol , nlay , ngpt ), intent ( in ) :: tau2 , ssa2 , g2 !! optical properties to be added to original end subroutine increment_nstream_by_2stream end interface ! --------------------------------- !> increment one set of _n_-stream optical properties with another set interface pure subroutine increment_nstream_by_nstream ( ncol , nlay , ngpt , nmom1 , nmom2 , & tau1 , ssa1 , p1 , & tau2 , ssa2 , p2 ) bind ( C , name = \"rte_increment_nstream_by_nstream\" ) use mo_rte_kind , only : wp , wl integer , intent ( in ) :: ncol , nlay , ngpt , nmom1 , nmom2 !! array sizes real ( wp ), dimension ( ncol , nlay , ngpt ), intent ( inout ) :: tau1 , ssa1 !! optical properties to be modified real ( wp ), dimension ( nmom1 , & ncol , nlay , ngpt ), intent ( inout ) :: p1 !! moments of the phase function be modified real ( wp ), dimension ( ncol , nlay , ngpt ), intent ( in ) :: tau2 , ssa2 !! optical properties to be added to original real ( wp ), dimension ( nmom2 , & ncol , nlay , ngpt ), intent ( in ) :: p2 !! moments of the phase function to be added end subroutine increment_nstream_by_nstream end interface ! ------------------------------------------------------------------------------------------------- ! ! Incrementing when the second set of optical properties is defined at lower spectral resolution ! (e.g. by band instead of by gpoint) ! ! ------------------------------------------------------------------------------------------------- !> increase one absorption optical depth defined on g-points by a second value defined on bands interface pure subroutine inc_1scalar_by_1scalar_bybnd ( ncol , nlay , ngpt , & tau1 , & tau2 , & nbnd , gpt_lims ) bind ( C , name = \"rte_inc_1scalar_by_1scalar_bybnd\" ) use mo_rte_kind , only : wp , wl integer , intent ( in ) :: ncol , nlay , ngpt , nbnd !! array sizes real ( wp ), dimension ( ncol , nlay , ngpt ), intent ( inout ) :: tau1 !! optical properties to be modified (defined on g-points) real ( wp ), dimension ( ncol , nlay , nbnd ), intent ( in ) :: tau2 !! optical properties to be added to original (defined on bands) integer , dimension ( 2 , nbnd ), intent ( in ) :: gpt_lims !! Starting and ending gpoint for each band end subroutine inc_1scalar_by_1scalar_bybnd end interface ! --------------------------------- !> increase absorption optical depth defined on g-points with extinction optical depth (2-stream form) defined on bands interface pure subroutine inc_1scalar_by_2stream_bybnd ( ncol , nlay , ngpt , & tau1 , & tau2 , ssa2 , & nbnd , gpt_lims ) bind ( C , name = \"rte_inc_1scalar_by_2stream_bybnd\" ) use mo_rte_kind , only : wp , wl integer , intent ( in ) :: ncol , nlay , ngpt , nbnd !! array sizes real ( wp ), dimension ( ncol , nlay , ngpt ), intent ( inout ) :: tau1 !! optical properties to be modified (defined on g-points) real ( wp ), dimension ( ncol , nlay , nbnd ), intent ( in ) :: tau2 , ssa2 !! optical properties to be added to original (defined on bands) integer , dimension ( 2 , nbnd ), intent ( in ) :: gpt_lims !! Starting and ending gpoint for each band end subroutine inc_1scalar_by_2stream_bybnd end interface ! --------------------------------- !> increase absorption optical depth defined on g-points with extinction optical depth (n-stream form) defined on bands interface pure subroutine inc_1scalar_by_nstream_bybnd ( ncol , nlay , ngpt , & tau1 , & tau2 , ssa2 , & nbnd , gpt_lims ) bind ( C , name = \"rte_inc_1scalar_by_nstream_bybnd\" ) use mo_rte_kind , only : wp , wl integer , intent ( in ) :: ncol , nlay , ngpt , nbnd !! array sizes real ( wp ), dimension ( ncol , nlay , ngpt ), intent ( inout ) :: tau1 !! optical properties to be modified (defined on g-points) real ( wp ), dimension ( ncol , nlay , nbnd ), intent ( in ) :: tau2 , ssa2 !! optical properties to be added to original (defined on bands) integer , dimension ( 2 , nbnd ), intent ( in ) :: gpt_lims !! Starting and ending gpoint for each band end subroutine inc_1scalar_by_nstream_bybnd end interface ! --------------------------------- !> increment two-stream optical properties \\tau, \\omega_0, g defined on g-points with absorption optical depth defined on bands interface pure subroutine inc_2stream_by_1scalar_bybnd ( ncol , nlay , ngpt , & tau1 , ssa1 , & tau2 , & nbnd , gpt_lims ) bind ( C , name = \"rte_inc_2stream_by_1scalar_bybnd\" ) use mo_rte_kind , only : wp , wl integer , intent ( in ) :: ncol , nlay , ngpt , nbnd !! array sizes real ( wp ), dimension ( ncol , nlay , ngpt ), intent ( inout ) :: tau1 , ssa1 !! optical properties to be modified (defined on g-points) real ( wp ), dimension ( ncol , nlay , nbnd ), intent ( in ) :: tau2 !! optical properties to be added to original (defined on bands) integer , dimension ( 2 , nbnd ), intent ( in ) :: gpt_lims !! Starting and ending gpoint for each band end subroutine inc_2stream_by_1scalar_bybnd end interface ! --------------------------------- !> increment 2-stream optical properties defined on g-points with another set defined on bands interface pure subroutine inc_2stream_by_2stream_bybnd ( ncol , nlay , ngpt , & tau1 , ssa1 , g1 , & tau2 , ssa2 , g2 , & nbnd , gpt_lims ) bind ( C , name = \"rte_inc_2stream_by_2stream_bybnd\" ) use mo_rte_kind , only : wp , wl integer , intent ( in ) :: ncol , nlay , ngpt , nbnd !! array sizes real ( wp ), dimension ( ncol , nlay , ngpt ), intent ( inout ) :: tau1 , ssa1 , g1 !! optical properties to be modified (defined on g-points) real ( wp ), dimension ( ncol , nlay , nbnd ), intent ( in ) :: tau2 , ssa2 , g2 !! optical properties to be added to original (defined on bands) integer , dimension ( 2 , nbnd ), intent ( in ) :: gpt_lims !! Starting and ending gpoint for each band end subroutine inc_2stream_by_2stream_bybnd end interface ! --------------------------------- !> increment 2-stream optical properties defined on g-points with _n_-stream properties set defined on bands interface pure subroutine inc_2stream_by_nstream_bybnd ( ncol , nlay , ngpt , nmom2 , & tau1 , ssa1 , g1 , & tau2 , ssa2 , p2 , & nbnd , gpt_lims ) bind ( C , name = \"rte_inc_2stream_by_nstream_bybnd\" ) use mo_rte_kind , only : wp , wl integer , intent ( in ) :: ncol , nlay , ngpt , nmom2 , nbnd !! array sizes real ( wp ), dimension ( ncol , nlay , ngpt ), intent ( inout ) :: tau1 , ssa1 , g1 !! optical properties to be modified (defined on g-points) real ( wp ), dimension ( ncol , nlay , nbnd ), intent ( in ) :: tau2 , ssa2 !! optical properties to be added to original (defined on bands) real ( wp ), dimension ( nmom2 , & ncol , nlay , nbnd ), intent ( in ) :: p2 !! moments of the phase function to be added integer , dimension ( 2 , nbnd ), intent ( in ) :: gpt_lims !! Starting and ending gpoint for each band end subroutine inc_2stream_by_nstream_bybnd end interface ! --------------------------------- ! --------------------------------- !> increment _n_-stream optical properties defined on g-points with absorption optical depth defined on bands interface pure subroutine inc_nstream_by_1scalar_bybnd ( ncol , nlay , ngpt , & tau1 , ssa1 , & tau2 , & nbnd , gpt_lims ) bind ( C , name = \"rte_inc_nstream_by_1scalar_bybnd\" ) use mo_rte_kind , only : wp , wl integer , intent ( in ) :: ncol , nlay , ngpt , nbnd !! array sizes real ( wp ), dimension ( ncol , nlay , ngpt ), intent ( inout ) :: tau1 , ssa1 !! optical properties to be modified (defined on g-points) real ( wp ), dimension ( ncol , nlay , nbnd ), intent ( in ) :: tau2 !! optical properties to be added to original (defined on bands) integer , dimension ( 2 , nbnd ), intent ( in ) :: gpt_lims !! Starting and ending gpoint for each band end subroutine inc_nstream_by_1scalar_bybnd end interface ! --------------------------------- !> increment n-stream optical properties defined on g-points with 2-stream properties set defined on bands interface pure subroutine inc_nstream_by_2stream_bybnd ( ncol , nlay , ngpt , nmom1 , & tau1 , ssa1 , p1 , & tau2 , ssa2 , g2 , & nbnd , gpt_lims ) bind ( C , name = \"rte_inc_nstream_by_2stream_bybnd\" ) use mo_rte_kind , only : wp , wl integer , intent ( in ) :: ncol , nlay , ngpt , nmom1 , nbnd !! array sizes real ( wp ), dimension ( ncol , nlay , ngpt ), intent ( inout ) :: tau1 , ssa1 !! optical properties to be modified (defined on g-points) real ( wp ), dimension ( nmom1 , & ncol , nlay , ngpt ), intent ( inout ) :: p1 !! moments of the phase function be modified real ( wp ), dimension ( ncol , nlay , nbnd ), intent ( in ) :: tau2 , ssa2 , g2 !! optical properties to be added to original (defined on bands) integer , dimension ( 2 , nbnd ), intent ( in ) :: gpt_lims !! Starting and ending gpoint for each band end subroutine inc_nstream_by_2stream_bybnd end interface ! --------------------------------- !> increment _n_-stream optical properties defined on g-points with a second set defined on bands interface pure subroutine inc_nstream_by_nstream_bybnd ( ncol , nlay , ngpt , nmom1 , nmom2 , & tau1 , ssa1 , p1 , & tau2 , ssa2 , p2 , & nbnd , gpt_lims ) bind ( C , name = \"rte_inc_nstream_by_nstream_bybnd\" ) use mo_rte_kind , only : wp , wl integer , intent ( in ) :: ncol , nlay , ngpt , nmom1 , nmom2 , nbnd !! array sizes real ( wp ), dimension ( ncol , nlay , ngpt ), intent ( inout ) :: tau1 , ssa1 !! optical properties to be modified (defined on g-points) real ( wp ), dimension ( nmom1 , & ncol , nlay , ngpt ), intent ( inout ) :: p1 !! moments of the phase function be modified real ( wp ), dimension ( ncol , nlay , nbnd ), intent ( in ) :: tau2 , ssa2 !! optical properties to be added to original (defined on bands) real ( wp ), dimension ( nmom2 , & ncol , nlay , nbnd ), intent ( in ) :: p2 !! moments of the phase function to be added integer , dimension ( 2 , nbnd ), intent ( in ) :: gpt_lims !! Starting and ending gpoint for each band end subroutine inc_nstream_by_nstream_bybnd end interface ! ------------------------------------------------------------------------------------------------- ! ! Subsetting, meaning extracting some portion of the 3D domain ! ! ------------------------------------------------------------------------------------------------- !> !> Extract a subset from the first dimension (normally columns) of a 3D field. !> Applicable to most variables e.g. tau, ssa, g !> interface extract_subset pure subroutine extract_subset_dim1_3d ( ncol , nlay , ngpt , array_in , colS , colE , array_out ) & bind ( C , name = \"rte_extract_subset_dim1_3d\" ) use mo_rte_kind , only : wp , wl integer , intent ( in ) :: ncol , nlay , ngpt !! Array sizes real ( wp ), dimension ( ncol , nlay , ngpt ), intent ( in ) :: array_in !! Array to subset integer , intent ( in ) :: colS , colE !! Starting and ending index real ( wp ), dimension ( colE - colS + 1 ,& nlay , ngpt ), intent ( out ) :: array_out !! subset of the input array end subroutine extract_subset_dim1_3d ! --------------------------------- !> Extract a subset from the second dimension (normally columns) of a 4D field. !> Applicable to phase function moments, where the first dimension is the moment pure subroutine extract_subset_dim2_4d ( nmom , ncol , nlay , ngpt , array_in , colS , colE , array_out ) & bind ( C , name = \"rte_extract_subset_dim2_4d\" ) use mo_rte_kind , only : wp , wl integer , intent ( in ) :: nmom , ncol , nlay , ngpt !! Array sizes real ( wp ), dimension ( nmom , ncol , nlay , ngpt ), intent ( in ) :: array_in !! Array to subset integer , intent ( in ) :: colS , colE !! Starting and ending index real ( wp ), dimension ( nmom , colE - colS + 1 ,& nlay , ngpt ), intent ( out ) :: array_out !! subset of the input array end subroutine extract_subset_dim2_4d ! --------------------------------- ! !> Extract the absorption optical thickness \\tau_{abs} = 1 - \\omega_0 \\tau_{ext} ! pure subroutine extract_subset_absorption_tau ( ncol , nlay , ngpt , tau_in , ssa_in , & colS , colE , tau_out ) & bind ( C , name = \"rte_extract_subset_absorption_tau\" ) use mo_rte_kind , only : wp , wl integer , intent ( in ) :: ncol , nlay , ngpt !! Array sizes real ( wp ), dimension ( ncol , nlay , ngpt ), intent ( in ) :: tau_in , ssa_in !! Optical thickness, single scattering albedo integer , intent ( in ) :: colS , colE !! Starting and ending index real ( wp ), dimension ( colE - colS + 1 ,& nlay , ngpt ), intent ( out ) :: tau_out !! absorption optical thickness subset end subroutine extract_subset_absorption_tau end interface extract_subset end module mo_optical_props_kernels","tags":"","loc":"sourcefile/mo_optical_props_kernels.f90~2.html"},{"title":"mo_fluxes_broadband_kernels.F90 – RTE kernels","text":"Contents Modules mo_fluxes_broadband_kernels Source Code mo_fluxes_broadband_kernels.F90 Source Code ! This code is part of Radiative Transfer for Energetics (RTE) ! ! Contacts: Robert Pincus and Eli Mlawer ! email: rrtmgp@aer.com ! ! Copyright 2015-, Atmospheric and Environmental Research, ! Regents of the University of Colorado, Trustees of Columbia University. All right reserved. ! ! Use and duplication is permitted under the terms of the ! BSD 3-clause license, see http://opensource.org/licenses/BSD-3-Clause ! ------------------------------------------------------------------------------------------------- !> !> ## Kernels for computing broadband fluxes !> ! ------------------------------------------------------------------------------------------------- module mo_fluxes_broadband_kernels use , intrinsic :: iso_c_binding use mo_rte_kind , only : wp implicit none private public :: sum_broadband , net_broadband ! ---------------------------------------------------------------------------- !> !> Spectral reduction over all points !> interface subroutine sum_broadband ( ncol , nlev , ngpt , spectral_flux , broadband_flux ) bind ( C , name = \"rte_sum_broadband\" ) use mo_rte_kind , only : wp integer , intent ( in ) :: ncol , nlev , ngpt !! Array sizes real ( wp ), dimension ( ncol , nlev , ngpt ), intent ( in ) :: spectral_flux !! Spectrally-resolved flux real ( wp ), dimension ( ncol , nlev ), intent ( out ) :: broadband_flux !! Sum of spectrally-resolved flux over `ngpt` end subroutine sum_broadband end interface ! ---------------------------------------------------------------------------- !> !> Spectral reduction over all points for net flux !> Overloaded - which routine is called depends on arguments !> interface net_broadband ! ---------------------------------------------------------------------------- !> !> Net flux from g-point fluxes up and down !> subroutine net_broadband_full ( ncol , nlev , ngpt , spectral_flux_dn , spectral_flux_up , broadband_flux_net ) & bind ( C , name = \"rte_net_broadband_full\" ) use mo_rte_kind , only : wp integer , intent ( in ) :: ncol , nlev , ngpt !! Array sizes real ( wp ), dimension ( ncol , nlev , ngpt ), intent ( in ) :: spectral_flux_dn , spectral_flux_up !! Spectrally-resolved flux up and down real ( wp ), dimension ( ncol , nlev ), intent ( out ) :: broadband_flux_net !! Net (down minus up) summed over `ngpt` end subroutine net_broadband_full ! ---------------------------------------------------------------------------- !> !> Net flux when bradband flux up and down are already available !> subroutine net_broadband_precalc ( ncol , nlev , flux_dn , flux_up , broadband_flux_net ) & bind ( C , name = \"rte_net_broadband_precalc\" ) use mo_rte_kind , only : wp integer , intent ( in ) :: ncol , nlev !! Array sizes real ( wp ), dimension ( ncol , nlev ), intent ( in ) :: flux_dn , flux_up !! Broadband downward and upward fluxes real ( wp ), dimension ( ncol , nlev ), intent ( out ) :: broadband_flux_net !! Net (down minus up) end subroutine net_broadband_precalc end interface net_broadband ! ---------------------------------------------------------------------------- end module mo_fluxes_broadband_kernels","tags":"","loc":"sourcefile/mo_fluxes_broadband_kernels.f90~2.html"},{"title":"mo_rte_solver_kernels.F90 – RTE kernels","text":"Contents Modules mo_rte_solver_kernels Source Code mo_rte_solver_kernels.F90 Source Code ! This code is part of Radiative Transfer for Energetics (RTE) ! ! Contacts: Robert Pincus and Eli Mlawer ! email: rrtmgp@aer.com ! ! Copyright 2015-, Atmospheric and Environmental Research, ! Regents of the University of Colorado, Trustees of Columbia University. All right reserved. ! ! Use and duplication is permitted under the terms of the ! BSD 3-clause license, see http://opensource.org/licenses/BSD-3-Clause ! ------------------------------------------------------------------------------------------------- ! !>## Numeric calculations for radiative transfer solvers !> - Emission/absorption (no-scattering) calculations !> - solver for multi-angle Gaussian quadrature !> - Extinction-only calculation (direct solar beam) !> - Two-stream calculations: !> solvers for LW and SW with different boundary conditions and source functions ! ! ------------------------------------------------------------------------------------------------- module mo_rte_solver_kernels use , intrinsic :: iso_c_binding use mo_rte_kind , only : wp , wl implicit none private public :: lw_solver_noscat , lw_solver_2stream , & sw_solver_noscat , sw_solver_2stream ! ------------------------------------------------------------------------------------------------- ! ! Top-level longwave kernels ! ! ------------------------------------------------------------------------------------------------- ! !> LW transport, no scattering, multi-angle quadrature !> Users provide a set of weights and quadrature angles !> Routine sums over single-angle solutions for each sets of angles/weights ! ! --------------------------------------------------------------- interface subroutine lw_solver_noscat ( ncol , nlay , ngpt , top_at_1 , & nmus , Ds , weights , & tau , & lay_source , lev_source , & sfc_emis , sfc_src , & inc_flux , & flux_up , flux_dn , & do_broadband , broadband_up , broadband_dn , & do_Jacobians , sfc_srcJac , flux_upJac , & do_rescaling , ssa , g ) bind ( C , name = \"rte_lw_solver_noscat\" ) use mo_rte_kind , only : wp , wl integer , intent ( in ) :: ncol , nlay , ngpt !! Number of columns, layers, g-points logical ( wl ), intent ( in ) :: top_at_1 !! ilay = 1 is the top of the atmosphere? integer , intent ( in ) :: nmus !! number of quadrature angles real ( wp ), dimension ( ncol , ngpt , & nmus ), intent ( in ) :: Ds !! quadrature secants real ( wp ), dimension ( nmus ), intent ( in ) :: weights !! quadrature weights real ( wp ), dimension ( ncol , nlay , ngpt ), intent ( in ) :: tau !! Absorption optical thickness [] real ( wp ), dimension ( ncol , nlay , ngpt ), intent ( in ) :: lay_source !! Planck source at layer average temperature [W/m2] real ( wp ), dimension ( ncol , nlay + 1 , ngpt ), intent ( in ) :: lev_source !! Planck source at layer edge for radiation [W/m2] real ( wp ), dimension ( ncol , ngpt ), intent ( in ) :: sfc_emis !! Surface emissivity [] real ( wp ), dimension ( ncol , ngpt ), intent ( in ) :: sfc_src !! Surface source function [W/m2] real ( wp ), dimension ( ncol , ngpt ), intent ( in ) :: inc_flux !! Incident diffuse flux, probably 0 [W/m2] real ( wp ), dimension ( ncol , nlay + 1 , ngpt ), target , & intent ( out ) :: flux_up , flux_dn !! Fluxes [W/m2] ! ! Optional variables - arrays aren't referenced if corresponding logical == False ! logical ( wl ), intent ( in ) :: do_broadband real ( wp ), dimension ( ncol , nlay + 1 ), target , & intent ( out ) :: broadband_up , broadband_dn !! Spectrally-integrated fluxes [W/m2] logical ( wl ), intent ( in ) :: do_Jacobians !! compute Jacobian with respect to surface temeprature? real ( wp ), dimension ( ncol , ngpt ), intent ( in ) :: sfc_srcJac !! surface temperature Jacobian of surface source function [W/m2/K] real ( wp ), dimension ( ncol , nlay + 1 ), target , & intent ( out ) :: flux_upJac !! surface temperature Jacobian of Radiances [W/m2-str / K] logical ( wl ), intent ( in ) :: do_rescaling !! Approximate treatment of scattering (10.1175/JAS-D-18-0014.1) real ( wp ), dimension ( ncol , nlay , ngpt ), intent ( in ) :: ssa , g !! single-scattering albedo, asymmetry parameter end subroutine lw_solver_noscat end interface ! ------------------------------------------------------------------------------------------------- ! !> Longwave two-stream calculation: !> - combine RRTMGP-specific sources at levels !> - compute layer reflectance, transmittance !> - compute total source function at levels using linear-in-tau !> - transport ! ! ------------------------------------------------------------------------------------------------- interface subroutine lw_solver_2stream ( ncol , nlay , ngpt , top_at_1 , & tau , ssa , g , & lay_source , lev_source , sfc_emis , sfc_src , & inc_flux , & flux_up , flux_dn ) bind ( C , name = \"rte_lw_solver_2stream\" ) use mo_rte_kind , only : wp , wl integer , intent ( in ) :: ncol , nlay , ngpt !! Number of columns, layers, g-points logical ( wl ), intent ( in ) :: top_at_1 !! ilay = 1 is the top of the atmosphere? real ( wp ), dimension ( ncol , nlay , ngpt ), intent ( in ) :: tau , ssa , g !! Optical thickness, single-scattering albedo, asymmetry parameter [] real ( wp ), dimension ( ncol , nlay , ngpt ), intent ( in ) :: lay_source !! Planck source at layer average temperature [W/m2] real ( wp ), dimension ( ncol , nlay + 1 , ngpt ), intent ( in ) :: lev_source !! Planck source at layer edge for radiation [W/m2] real ( wp ), dimension ( ncol , ngpt ), intent ( in ) :: sfc_emis !! Surface emissivity [] real ( wp ), dimension ( ncol , ngpt ), intent ( in ) :: sfc_src !! Surface source function [W/m2] real ( wp ), dimension ( ncol , ngpt ), intent ( in ) :: inc_flux !! Incident diffuse flux, probably 0 [W/m2] real ( wp ), dimension ( ncol , nlay + 1 , ngpt ), intent ( out ) :: flux_up , flux_dn !! Fluxes [W/m2] end subroutine lw_solver_2stream end interface ! ------------------------------------------------------------------------------------------------- ! ! Top-level shortwave kernels ! ! ------------------------------------------------------------------------------------------------- ! ! !> Extinction-only shortwave solver i.e. solar direct beam ! ! ------------------------------------------------------------------------------------------------- interface pure subroutine sw_solver_noscat ( ncol , nlay , ngpt , top_at_1 , & tau , mu0 , inc_flux_dir , flux_dir ) bind ( C , name = \"rte_sw_solver_noscat\" ) use mo_rte_kind , only : wp , wl integer , intent ( in ) :: ncol , nlay , ngpt ! Number of columns, layers, g-points !! Number of columns, layers, g-points logical ( wl ), intent ( in ) :: top_at_1 !! ilay = 1 is the top of the atmosphere? real ( wp ), dimension ( ncol , nlay , ngpt ), intent ( in ) :: tau !! Absorption optical thickness [] real ( wp ), dimension ( ncol , nlay ), intent ( in ) :: mu0 !! cosine of solar zenith angle real ( wp ), dimension ( ncol , ngpt ), intent ( in ) :: inc_flux_dir !! Direct beam incident flux [W/m2] real ( wp ), dimension ( ncol , nlay + 1 , ngpt ), intent ( out ) :: flux_dir end subroutine sw_solver_noscat end interface ! ------------------------------------------------------------------------------------------------- ! !> Shortwave two-stream calculation: !> compute layer reflectance, transmittance !> compute solar source function for diffuse radiation !> transport ! ! ------------------------------------------------------------------------------------------------- interface subroutine sw_solver_2stream ( ncol , nlay , ngpt , top_at_1 , & tau , ssa , g , mu0 , & sfc_alb_dir , sfc_alb_dif , & inc_flux_dir , & flux_up , flux_dn , flux_dir , & has_dif_bc , inc_flux_dif , & do_broadband , broadband_up , & broadband_dn , broadband_dir ) bind ( C , name = \"rte_sw_solver_2stream\" ) use mo_rte_kind , only : wp , wl integer , intent ( in ) :: ncol , nlay , ngpt !! Number of columns, layers, g-points logical ( wl ), intent ( in ) :: top_at_1 !! ilay = 1 is the top of the atmosphere? real ( wp ), dimension ( ncol , nlay , ngpt ), intent ( in ) :: tau , ssa , g !! Optical thickness, single-scattering albedo, asymmetry parameter [] real ( wp ), dimension ( ncol , nlay ), intent ( in ) :: mu0 !! cosine of solar zenith angle real ( wp ), dimension ( ncol , ngpt ), intent ( in ) :: sfc_alb_dir , sfc_alb_dif !! Spectral surface albedo for direct and diffuse radiation real ( wp ), dimension ( ncol , ngpt ), intent ( in ) :: inc_flux_dir !! Direct beam incident flux real ( wp ), dimension ( ncol , nlay + 1 , ngpt ), target , & intent ( out ) :: flux_up , flux_dn , flux_dir !! Fluxes [W/m2] logical ( wl ), intent ( in ) :: has_dif_bc !! Is a boundary condition for diffuse flux supplied? real ( wp ), dimension ( ncol , ngpt ), intent ( in ) :: inc_flux_dif !! Boundary condition for diffuse flux [W/m2] logical ( wl ), intent ( in ) :: do_broadband !! Provide broadband-integrated, not spectrally-resolved, fluxes? real ( wp ), dimension ( ncol , nlay + 1 ), intent ( out ) :: broadband_up , broadband_dn , broadband_dir end subroutine sw_solver_2stream end interface end module mo_rte_solver_kernels","tags":"","loc":"sourcefile/mo_rte_solver_kernels.f90~2.html"},{"title":"mo_rte_util_array.F90 – RTE kernels","text":"Contents Modules mo_rte_util_array Source Code mo_rte_util_array.F90 Source Code ! This code is part of Radiative Transfer for Energetics (RTE) ! ! Contacts: Robert Pincus and Eli Mlawer ! email: rrtmgp@aer.com ! ! Copyright 2015- Atmospheric and Environmental Research, ! Regents of the University of Colorado, ! Trustees of Columbia University in the City of New York ! All right reserved. ! ! Use and duplication is permitted under the terms of the ! BSD 3-clause license, see http://opensource.org/licenses/BSD-3-Clause ! ------------------------------------------------------------------------------------------------- module mo_rte_util_array use mo_rte_kind , only : wp , wl implicit none public :: zero_array !------------------------------------------------------------------------------------------------- ! Initializing arrays to 0 !------------------------------------------------------------------------------------------------- interface zero_array subroutine zero_array_1D ( ni , array ) bind ( C , name = \"zero_array_1D\" ) use mo_rte_kind , only : wp , wl integer , intent ( in ) :: ni real ( wp ), dimension ( ni ), intent ( out ) :: array end subroutine zero_array_1D ! ---------------------------------------------------------- subroutine zero_array_2D ( ni , nj , array ) bind ( C , name = \"zero_array_2D\" ) use mo_rte_kind , only : wp , wl integer , intent ( in ) :: ni , nj real ( wp ), dimension ( ni , nj ), intent ( out ) :: array end subroutine zero_array_2D ! ---------------------------------------------------------- subroutine zero_array_3D ( ni , nj , nk , array ) bind ( C , name = \"zero_array_3D\" ) use mo_rte_kind , only : wp , wl integer , intent ( in ) :: ni , nj , nk real ( wp ), dimension ( ni , nj , nk ), intent ( out ) :: array end subroutine zero_array_3D ! ---------------------------------------------------------- subroutine zero_array_4D ( ni , nj , nk , nl , array ) bind ( C , name = \"zero_array_4D\" ) use mo_rte_kind , only : wp , wl integer , intent ( in ) :: ni , nj , nk , nl real ( wp ), dimension ( ni , nj , nk , nl ), intent ( out ) :: array end subroutine zero_array_4D end interface zero_array end module mo_rte_util_array","tags":"","loc":"sourcefile/mo_rte_util_array.f90~2.html"}]} \ No newline at end of file diff --git a/release-notes/2022/06/02/Release-notes.html b/release-notes/2022/06/02/Release-notes.html index bbbdf2852..73592311e 100644 --- a/release-notes/2022/06/02/Release-notes.html +++ b/release-notes/2022/06/02/Release-notes.html @@ -32,7 +32,7 @@ -
    How to build and run testsRTE+RRTMGP documentationExplanationsTutorialsHow-to guidesReference (technical documentation)
    +
    How to build and run testsRTE+RRTMGP documentationTutorialsReference (technical documentation)ExplanationsHow-to guides
    diff --git a/release-notes/2023/11/27/v1.7-Release-notes.html b/release-notes/2023/11/27/v1.7-Release-notes.html index e4b43e6fd..816e6a4fc 100644 --- a/release-notes/2023/11/27/v1.7-Release-notes.html +++ b/release-notes/2023/11/27/v1.7-Release-notes.html @@ -32,7 +32,7 @@ -
    How to build and run testsRTE+RRTMGP documentationExplanationsTutorialsHow-to guidesReference (technical documentation)
    +
    How to build and run testsRTE+RRTMGP documentationTutorialsReference (technical documentation)ExplanationsHow-to guides
    diff --git a/tutorials/index.html b/tutorials/index.html index 70a370584..6e30471c9 100644 --- a/tutorials/index.html +++ b/tutorials/index.html @@ -31,7 +31,7 @@ -
    How to build and run testsRTE+RRTMGP documentationExplanationsTutorialsHow-to guidesReference (technical documentation)
    +
    How to build and run testsRTE+RRTMGP documentationTutorialsReference (technical documentation)ExplanationsHow-to guides