├── pumas_kinds.F90 ├── micro_pumas_diags.meta ├── ML_fixer_check.F90 ├── tau_neural_net_quantile.F90 ├── README.md ├── Tag_Notes.readme ├── pumas_gamma_function.F90 ├── module_neural_net.F90 ├── KBARF_tau_kernel.dat ├── pumas_stochastic_collect_tau.F90 ├── micro_pumas_diags.F90 └── micro_pumas_ccpp.F90 /pumas_kinds.F90: -------------------------------------------------------------------------------- 1 | !Define Fortran kinds for use specifically 2 | !within PUMAS. This allows PUMAS to control 3 | !the precision in its internal routines without 4 | !having to depend on a specific host model 5 | !implemention. 6 | 7 | module pumas_kinds 8 | 9 | implicit none 10 | private 11 | save 12 | 13 | integer, public, parameter :: kind_r8 = selected_real_kind(12) !8-byte real 14 | integer, public, parameter :: kind_i8 = selected_int_kind(18) !8-byte integer 15 | 16 | end module pumas_kinds 17 | -------------------------------------------------------------------------------- /micro_pumas_diags.meta: -------------------------------------------------------------------------------- 1 | ################################# 2 | #Metadata file for the PUMAS 3 | #process rates DDT to allow it 4 | #to be passed between PUMAS and 5 | #any CCPP intersitial schemes. 6 | # 7 | #Please note that this file only 8 | #allows for the DDT as a whole to 9 | #be passed between schemes, and 10 | #additional metadata should be 11 | #added if specific process rate 12 | #variables need to be passed 13 | #independent of the DDT. 14 | ################################# 15 | 16 | [ccpp-table-properties] 17 | name = proc_rates_type 18 | type = ddt 19 | 20 | [ccpp-arg-table] 21 | name = proc_rates_type 22 | type = ddt 23 | 24 | ##################### 25 | #End of metadata file 26 | ##################### 27 | -------------------------------------------------------------------------------- /ML_fixer_check.F90: -------------------------------------------------------------------------------- 1 | module ML_fixer_check 2 | 3 | 4 | contains 5 | subroutine ML_fixer_calc(mgncol,dt,qc,nc,qr,nr,qctend,nctend,qrtend,nrtend,fixer,qc_fixer, nc_fixer, qr_fixer, nr_fixer) 6 | 7 | use pumas_kinds, only: r8=>kind_r8 8 | use micro_pumas_utils, only: pi, rhow 9 | 10 | integer, intent(in) :: mgncol 11 | real(r8), intent(in) :: dt 12 | real(r8), intent(in) :: qc(mgncol) 13 | real(r8), intent(in) :: nc(mgncol) 14 | real(r8), intent(in) :: qr(mgncol) 15 | real(r8), intent(in) :: nr(mgncol) 16 | real(r8), intent(inout) :: qctend(mgncol) 17 | real(r8), intent(inout) :: nctend(mgncol) 18 | real(r8), intent(inout) :: qrtend(mgncol) 19 | real(r8), intent(inout) :: nrtend(mgncol) 20 | 21 | real(r8), intent(out) :: qc_fixer(mgncol) 22 | real(r8), intent(out) :: nc_fixer(mgncol) 23 | real(r8), intent(out) :: qr_fixer(mgncol) 24 | real(r8), intent(out) :: nr_fixer(mgncol) 25 | 26 | real(r8), intent(out) :: fixer(mgncol) 27 | 28 | real(r8) :: qc_tmp, nc_tmp, qr_tmp, nr_tmp 29 | integer :: i 30 | 31 | fixer = 0._r8 32 | 33 | qc_fixer = 0._r8 34 | qr_fixer = 0._r8 35 | nc_fixer = 0._r8 36 | nr_fixer = 0._r8 37 | 38 | do i = 1,mgncol 39 | qc_tmp = qc(i)+qctend(i)*dt 40 | nc_tmp = nc(i)+nctend(i)*dt 41 | qr_tmp = qr(i)+qrtend(i)*dt 42 | nr_tmp = nr(i)+nrtend(i)*dt 43 | 44 | if( qc_tmp.lt.0._r8 ) then 45 | fixer(i) = 1._r8 46 | qctend(i) = -qc(i)/dt 47 | qrtend(i) = qc(i)/dt 48 | nctend(i) = -nc(i)/dt 49 | end if 50 | if( qr_tmp.lt.0._r8 ) then 51 | fixer(i) = 1._r8 52 | qrtend(i) = -qr(i)/dt 53 | qctend(i) = qr(i)/dt 54 | nrtend(i) = -nr(i)/dt 55 | end if 56 | if( nc_tmp.lt.0._r8 ) then 57 | fixer(i) = 1._r8 58 | if( qc_tmp.gt.0._r8 ) then 59 | nc_tmp = qc_tmp/(4._r8/3._r8*pi*(5.e-5_r8)**3._r8*rhow) 60 | nctend(i) = (nc_tmp-nc(i))/dt 61 | else 62 | nctend(i) = -nc(i)/dt 63 | end if 64 | end if 65 | if( nr_tmp.lt.0._r8 ) then 66 | fixer(i) = 1._r8 67 | if(qr_tmp.gt.0._r8) then 68 | nr_tmp = qr_tmp/(4._r8/3._r8*pi*(5.e-5_r8)**3._r8*rhow) 69 | nrtend(i) = (nr_tmp-nr(i))/dt 70 | else 71 | nrtend(i) = -nr(i)/dt 72 | end if 73 | end if 74 | 75 | qc_fixer(i) = qc(i)+qctend(i)*dt-qc_tmp 76 | qr_fixer(i) = qr(i)+qrtend(i)*dt-qr_tmp 77 | nc_fixer(i) = nc(i)+nctend(i)*dt-nc_tmp 78 | nr_fixer(i) = nr(i)+nrtend(i)*dt-nr_tmp 79 | end do 80 | 81 | end subroutine ML_fixer_calc 82 | 83 | end module ML_fixer_check 84 | -------------------------------------------------------------------------------- /tau_neural_net_quantile.F90: -------------------------------------------------------------------------------- 1 | module tau_neural_net_quantile 2 | 3 | use pumas_kinds, only : r8=>kind_r8 4 | 5 | use module_neural_net, only : Dense, init_neural_net, load_quantile_scale_values 6 | use module_neural_net, only : quantile_transform, quantile_inv_transform, neural_net_predict 7 | 8 | implicit none 9 | integer, parameter, public :: i8 = selected_int_kind(18) 10 | integer, parameter :: num_inputs = 7 11 | integer, parameter :: num_outputs = 3 12 | integer, parameter :: batch_size = 1 13 | 14 | ! Neural networks and scale values saved within the scope of the module. 15 | ! Need to call initialize_tau_emulators to load weights and tables from disk. 16 | type(Dense), allocatable, save :: q_all(:) 17 | real(r8), dimension(:, :), allocatable, save :: input_scale_values 18 | real(r8), dimension(:, :), allocatable, save :: output_scale_values 19 | contains 20 | 21 | 22 | subroutine initialize_tau_emulators( stochastic_emulated_filename_quantile, stochastic_emulated_filename_input_scale, & 23 | stochastic_emulated_filename_output_scale, iulog, errstring) 24 | 25 | ! Load neural network netCDF files and scaling values. Values are placed in to emulators, 26 | ! input_scale_values, and output_scale_values. 27 | character(len=*), intent(in) :: stochastic_emulated_filename_quantile, stochastic_emulated_filename_input_scale, & 28 | stochastic_emulated_filename_output_scale 29 | integer, intent(in) :: iulog 30 | character(128), intent(out) :: errstring ! output status (non-blank for error return) 31 | 32 | errstring = '' 33 | 34 | write(iulog,*) "Begin loading neural nets" 35 | call init_neural_net(trim(stochastic_emulated_filename_quantile), batch_size, q_all, iulog, errstring) 36 | if (trim(errstring) /= '') return 37 | write(iulog,*) "End loading neural nets" 38 | ! Load the scale values from a csv file. 39 | call load_quantile_scale_values(trim(stochastic_emulated_filename_input_scale), input_scale_values, iulog, errstring) 40 | call load_quantile_scale_values(trim(stochastic_emulated_filename_output_scale), output_scale_values, iulog, errstring) 41 | write(iulog,*) "Loaded neural nets scaling values" 42 | 43 | end subroutine initialize_tau_emulators 44 | 45 | 46 | subroutine tau_emulated_cloud_rain_interactions(qc, nc, qr, nr, rho, lcldm, & 47 | precip_frac, mgncol, q_small, qc_tend, qr_tend, nc_tend, nr_tend) 48 | ! Calculates emulated tau microphysics tendencies from neural networks. 49 | ! 50 | ! Input args: 51 | ! qc: cloud water mixing ratio in kg kg-1 52 | ! nc: cloud water number concentration in particles m-3 53 | ! qr: rain water mixing ratio in kg kg-1 54 | ! nr: rain water number concentration in particles m-3 55 | ! rho: density of air in kg m-3 56 | ! q_small: minimum cloud water mixing ratio value for running the microphysics 57 | ! mgncol: MG number of grid cells in vertical column 58 | ! Output args: 59 | ! qc_tend: qc tendency 60 | ! qr_tend: qr tendency 61 | ! nc_tend: nc tendency 62 | ! nr_tend: nr tendency 63 | ! 64 | integer, intent(in) :: mgncol 65 | real(r8), dimension(mgncol), intent(in) :: qc, qr, nc, nr, rho, lcldm, precip_frac 66 | real(r8), intent(in) :: q_small 67 | real(r8), dimension(mgncol), intent(out) :: qc_tend, qr_tend, nc_tend, nr_tend 68 | integer(i8) :: i 69 | real(r8), dimension(batch_size, num_inputs) :: nn_inputs, nn_quantile_inputs 70 | real(r8), dimension(batch_size, num_outputs) :: nn_quantile_outputs, nn_outputs 71 | real(r8), parameter :: dt = 1800.0_r8 72 | do i = 1, mgncol 73 | if (qc(i) >= q_small) then 74 | nn_inputs(1, 1) = qc(i) 75 | nn_inputs(1, 2) = qr(i) 76 | nn_inputs(1, 3) = nc(i) 77 | nn_inputs(1, 4) = nr(i) 78 | nn_inputs(1, 5) = rho(i) 79 | nn_inputs(1, 6) = precip_frac(i) 80 | nn_inputs(1, 7) = lcldm(i) 81 | call quantile_transform(nn_inputs, input_scale_values, nn_quantile_inputs) 82 | call neural_net_predict(nn_quantile_inputs, q_all, nn_quantile_outputs) 83 | call quantile_inv_transform(nn_quantile_outputs, output_scale_values, nn_outputs) 84 | qr_tend(i) = (nn_outputs(1, 1) - qr(i)) / dt 85 | qr_tend(i) = (nn_outputs(1, 1) - qr(i)) / dt 86 | qc_tend(i) = -qr_tend(i) 87 | nc_tend(i) = (nn_outputs(1, 2) - nc(i)) / dt 88 | nr_tend(i) = (nn_outputs(1, 3) - nr(i)) / dt 89 | else 90 | qc_tend(i) = 0._r8 91 | qr_tend(i) = 0._r8 92 | nc_tend(i) = 0._r8 93 | nr_tend(i) = 0._r8 94 | end if 95 | end do 96 | end subroutine tau_emulated_cloud_rain_interactions 97 | end module tau_neural_net_quantile 98 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | PUMAS 2 | ====== 3 | Parameterization for Unified Microphysics Across Scales 4 | 5 | This repository contains the open source code for most versions of the Morrison-Gettleman (MG) microphysics as well as the most recent releases called the Parameterization for Unified Microphysics Across Scales, or PUMAS. 6 | 7 | Checking out and running PUMAS 8 | ================================ 9 | Running with an ESCOMP/CAM branch 10 | ----------------------------------- 11 | The code in this repository is not sufficient for completing a simulation on its own. To run PUMAS within the Community Atmosphere Model (CAM), you will need to check out a branch of CAM. 12 | 13 | Checking out any CAM branch since cam6_3_046 will give you access to the PUMAS microphysics scheme using the cam_dev or cam7 physics package. 14 | 15 | For more information on checking out and running CAM, please see: 16 | https://github.com/ESCOMP/CAM 17 | 18 | Modifying PUMAS code 19 | ----------------------------------- 20 | PUMAS and CAM are community supported scientific projects. We welcome feedback in the Issues section of our Github repository and Pull Request from contributing community members. For information on the Github workflow for NCAR models and parameterizations, read the wiki description here: 21 | https://github.com/ESCOMP/CAM/wiki 22 | 23 | Because the PUMAS microphysics parameterization is managed in a seperate repository from the NCAR CAM model, any development will need two Github forks. You will need (1) A fork of https://github.com/ESCOMP/CAM and (2) A fork of https://github.com/ESCOMP/PUMAS 24 | 25 | These are instructions for checking out a branch of CAM and pointing to a differnt branch of PUMAS then what you recieve from a checked out CAM branch or tag. 26 | 27 | Clone a repository that contains a CAM source tree. This will likely be your fork, but could be a group fork like the PUMASDevelopment fork. :: 28 | ``` 29 | git clone https://github.com/PUMASDevelopment/CAM.git Github_CAM_PUMAS_Clone 30 | ``` 31 | This will create a directory Github_CAM_PUMAS_Clone in your current working directory. 32 | 33 | Go into the newly created directory and checkout a modified branch. :: 34 | ``` 35 | cd Github_CAM_PUMAS_Clone git checkout username/my_new_branch 36 | ``` 37 | From the root of the CAM clone, run the script manage_externals/checkout_externals. :: 38 | ``` 39 | ./manage_externals/checkout_externals 40 | ``` 41 | The checkout_externals script will populate the cam directory with the relevant versions of each of the components along with the CIME infrastructure code. 42 | 43 | At this point you have all of the code needed for CAM with the PUMAS microphysics available. 44 | 45 | To make changes to PUMAS, first create a branch for your work in the ESCOMP/PUMAS Github repository (or your fork of this repository) by clicking on the "Branch:master" drop down box on the middle left part of the main page (just below the purble line), and type the name of your new branch into the "Find or create a branch..." text area. 46 | 47 | For new branch names, it is generally a good idea to put your Github name first, and then the goal of the branch after a slash. So, a name for a branch to improve graupel tendencies might be "katetc/graupel_upgrade". Hit enter, and your new branch is now shown in Github. 48 | 49 | The second step for making changes in PUMAS is to update the source code in the pumas subdirectory to work with this branch. The easiest way to manage this is by using manage_externals. Edit the `Externals_CAM.cfg` file to point to your fork and branch under the `[pumas]` section. Then run `manage_externals/checkout_externals` from the root of your CAM checkout. You can go into your PUMAS branch to make sure that it is checked out correctly. :: 50 | ``` 51 | cd Github_CAM_PUMAS_Clone/src/physics/pumas 52 | git status 53 | ``` 54 | Once you have your own branch checked out, you can make local changes to the code. When it's time to commit them, you will need to :: 55 | ``` 56 | git add filename.F90 57 | git commit -m "Commit message" 58 | git push 59 | ``` 60 | This will push your changes to your remote branch. When you have finished with ALL of your changes (can be multiple commits), then it will be time to merge your branch changes back to the master branch in the ESCOMP/PUMAS repo. You can do this by clicking "Pull requests" in the PUMAS github repo (or fork) main page, and then the big green "New Pull Request" button. In the gray bar, for the "compare" pull down, click and select your branch. This will show all of the differences between your branch and the main_cam PUMAS branch. If you are happy with these changes, click the green "Create pull request" button again, and that will take you to a pull request form. Fill out a description of your changes and issue the pull request. This request will be reviewed by a software engineer and then merged into the main branch. Your development branch can then be deleted, and you can start a new one for the next issue. 61 | 62 | 63 | References 64 | =========== 65 | Sun, J., Dennis, J. M., Mickelson, S. A., Vanderwende, B., Gettelman, A., & Thayer-Calder, K. (2023). Acceleration of the Parameterization of Unified Microphysics Across Scales (PUMAS) on the graphics processing unit (GPU) with directive-based methods. Journal of Advances in Modeling Earth Systems, 15, e2022MS003515. https://doi.org/10.1029/2022MS003515 66 | 67 | Gettelman, A., Morrison, H., Eidhammer, T., Thayer-Calder, K., Sun, J., Forbes, R., McGraw, Z., Zhu, J., Storelvmo, T., and Dennis, J.: Importance of ice nucleation and precipitation on climate with the Parameterization of Unified Microphysics Across Scales version 1 (PUMASv1), Geosci. Model Dev., 16, 1735–1754, https://doi.org/10.5194/gmd-16-1735-2023, 2023. 68 | 69 | Gettelman, A., H. Morrison, K. Thayer‐Calder, and C. M. Zarzycki. 2019. The Impact of Rimed Ice Hydrometeors on Global and Regional Climate. Journal of Advances in Modeling Earth Systems. https://doi.org/10.1029/2018MS001488. 70 | 71 | Gettelman, A. and H. Morrison, Advanced Two-Moment Microphysics for Global Models. Part I: Off line tests and comparisons with other schemes. J. Climate, 28, 1268-1287. doi: 10.1175/JCLI-D-14-00102.1, 2015. 72 | 73 | Gettelman, A., H. Morrison, S. Santos, P. Bogenschutz and P. H. Caldwell. Advanced Two-Moment Microphysics for Global Models. Part II: Global model solutions and Aerosol-Cloud Interactions. J. Climate, 28, 1288-1307. doi:10.1175/JCLI-D-14-00103.1 , 2015. 74 | -------------------------------------------------------------------------------- /Tag_Notes.readme: -------------------------------------------------------------------------------- 1 | ==================================== 2 | .. pumas_cam-release_v1.39 3 | May 14, 2025 - One line bug fix to support CAM7 testing. Aux_pumas with the Intel compiler passed on Derecho except: 4 | ERP_Ln9.f09_f09_mg17.F2000dev.derecho_intel.cam-outfrq9s_mg3 5 | FAIL ERP_Ln9.f09_f09_mg17.F2000dev.derecho_intel.cam-outfrq9s_mg3 COMPARE_base_rest 6 | ERP_Ln9.f09_f09_mg17.F2000dev.derecho_intel.cam-outfrq9s_mg3.G.aux_pumas_intel_20250514153756.clm2.h0.0001-01-01-16200.nc.base did NOT match ERP_Ln9.f09_f09_mg17.F2000dev.derecho_intel.cam-outfrq9s_mg3.G.aux_pumas_intel_20250514153756.clm2.h0.0001-01-01-16200.nc.rest 7 | Upon discussion with B.Eaton, this is not related to the pumas change and an outdated test. Need to update the aux_pumas suite. 8 | ==================================== 9 | .. pumas_cam-release_v1.38 10 | January 15, 2025 - Removed all CAM dependencies from core PUMAS routines except wv_sat_methods. Also added a Common Community Physics Package (CCPP) wrapper (micro_pumas_ccpp.F90) for micro_pumas_v1.F90, including two new CCPP metadata files (micro_pumas_ccpp.meta and micro_pumas_diags.meta). For CAM-SIMA this wrapper will be called inbetween a "pre" and "post" CCPP scheme which will handle host->PUMAS->host data conversions, diagnostics, etc. A new CAM tag will also be made which calls the wrapper instead of PUMAS directly, although this isn't technically required. 11 | ==================================== 12 | .. pumas_cam-release_v1.37 13 | May 21, 2024 - Renaming and moving the default branch from Master to main_cam (previously release/cam). Added a README.md file to the release code with instructions for contributing to the PUMAS project on the main Github page. This external will work with all cam tags after cam6_3_144. 14 | ==================================== 15 | .. pumas_cam-release_v1.36 16 | April 17, 2024 - Updates to OpenACC directives by @sjsprecious to get CAM GPU regression testing working. All PUMAS ML mods have been integrated with cam_development since cam6_3_144. This PUMAS tag and others that require the "machlrn" branch below should work with all cam tags after cam6_3_144. 17 | ==================================== 18 | .. pumas_cam-release_v1.35 19 | December 5, 2023 - Single line adjustment to vapor deposition onto snow. To run this code use branch https://github.com/PUMASDevelopment/CAM/tree/katetc/machlrn_camdev_pr2_cac until the CAM PR for ML (#858) is done. 20 | ==================================== 21 | .. pumas_cam-release_v1.34 22 | October 11, 2023 - Added support for new namelist field micro_mg_vtrms_factor to be used in new PPE. CAM support in PR phase, to run this code use branch https://github.com/PUMASDevelopment/CAM/tree/katetc/machlrn_camdev_pr2_cac until the CAM PR (#858) is done. 23 | ==================================== 24 | .. pumas_cam-release_v1.33 25 | October 5, 2023 - Added support for four more new ML output fields and updated field names. CAM support in PR phase, to run this code use branch https://github.com/PUMASDevelopment/CAM/tree/katetc/machlrn_camdev_pr2_cac until the CAM PR (#858) is done. 26 | ==================================== 27 | .. pumas_cam-release_v1.32 28 | September 20, 2023 - Moved new history output fields from ML only to always available. CAM support in PR phase, to run this code use branch https://github.com/PUMASDevelopment/CAM/tree/katetc/machlrn_camdev_pr2_cac until the CAM PR (#858) is done. 29 | ==================================== 30 | .. pumas_cam-release_v1.31 31 | September 19, 2023 - More support for machine learning including GPU code clean up, extra output for emulators and final cleanup from Cheryl. CAM support in PR phase, to run this code use branch https://github.com/PUMASDevelopment/CAM/tree/katetc/machlrn_camdev_pr2_cac until the CAM PR (#858) is done. 32 | ==================================== 33 | .. pumas_cam-release_v1.30 34 | July 17, 2023 - Adding in support for the machine learning emulators. CAM support in PR phase, to run this code use branch https://github.com/PUMASDevelopment/CAM/tree/katetc/machlrn_camdev_pr2_cac until the CAM PR is done. 35 | ==================================== 36 | .. pumas_cam-release_v1.29 37 | March 1, 2023 - Mainly updates to the heterogenious ice nucleation methods for cam_dev tuning. These tags are currently supported on the cam_development branch. 38 | ==================================== 39 | .. pumas_cam-release_v1.28 40 | October 11, 2022 - Creation and implimentation of a derived data type (DDT) for process rates. Not supported by cam_development yet. The CAM changes are currently in https://github.com/ESCOMP/CAM/pull/632 41 | ==================================== 42 | .. pumas_cam-release_v1.27 43 | August 24, 2022 - New tag for cam_development. Initialized nnudep and mnudep. 44 | ==================================== 45 | .. pumas_cam-release_v1.26 46 | June 7, 2022 - Cam Tag cam6_3_063 now supports PUMAS interface changes in the F2000dev compset 47 | (cam_dev version of micro_pumas_cam.F90). This applies to the previous two tags as well. 48 | ==================================== 49 | .. pumas_cam-release_v1.25 50 | June 2, 2022 - Notes from v1.23 still apply. The CAM PR does not have a tag yet. 51 | ==================================== 52 | .. pumas_cam-release_v1.24 53 | May 27, 2022 - Notes from v1.23 still apply. The CAM PR does not have a tag yet. 54 | ==================================== 55 | .. pumas_cam-release_v1.23 56 | May 23, 2022 - Adding new output arguments for number tendencies. This changes the PUMAS_tend 57 | interface, so the correct CAM tag will need to run with this. The CAM changes are currently in 58 | https://github.com/ESCOMP/CAM/pull/597 59 | ==================================== 60 | .. pumas_cam-release_v1.22 61 | Jan 19, 2022 - Renames for pumas_v1 and use in cam_dev from here on. All changes required to run 62 | the head of pumas/cam/release will be integrated into cam_dev physics in cam6_3_046, most likely. 63 | ==================================== 64 | .. pumas_cam-release_v1.21 65 | Nov 29, 2021 - Rain reflectivity bug fix. Notes from v1.19 still apply. 66 | ==================================== 67 | .. pumas_cam-release_v1.20 68 | Nov 15, 2021 - Small bug fix. Notes from v1.19 still apply. 69 | ==================================== 70 | .. pumas_cam-release_v1.19 71 | Oct 26, 2021 - This tag depends on changes to cam_development that have not been brought to a PR 72 | (or merged) yet. To use this code, you must include the changes from the gettelman_pumas_update0821 73 | branch of https://github.com/PUMASDevelopment/CAM at commit 2f2346bb92. 74 | ==================================== 75 | -------------------------------------------------------------------------------- /pumas_gamma_function.F90: -------------------------------------------------------------------------------- 1 | !Note: This code was taken directly from the shared code 2 | ! library used by the NCAR Community Earth System Model (CESM). 3 | ! A version can be found on Github here: 4 | ! https://github.com/ESCOMP/CESM_share/blob/main/src/shr_spfn_mod.F90 5 | 6 | ! Define flags for compilers supporting Fortran 2008 intrinsics 7 | ! HAVE_GAMMA_INTRINSICS: gamma and log_gamma 8 | 9 | ! These compilers have the intrinsics. 10 | ! Intel also has them (and Cray), but as of mid-2015, our implementation is 11 | ! actually faster, in part because they do not properly vectorize, so we 12 | ! pretend that the compiler version doesn't exist. 13 | #if defined CPRIBM || defined __GFORTRAN__ 14 | #define HAVE_GAMMA_INTRINSICS 15 | #endif 16 | 17 | ! As of 5.3.1, NAG does not have any of these. 18 | 19 | module pumas_gamma_function 20 | ! Module containg PUMAS gamma function 21 | 22 | use pumas_kinds, only: r8 => kind_r8 23 | 24 | implicit none 25 | private 26 | save 27 | 28 | real(r8), parameter :: pi = 3.1415926535897932384626434E0_r8 29 | 30 | ! Gamma functions 31 | ! Note that we lack an implementation of log_gamma, but we do have an 32 | ! implementation of the upper incomplete gamma function, which is not in 33 | ! Fortran 2008. 34 | 35 | ! Note also that this gamma function is only for double precision. We 36 | ! haven't needed an r4 version yet. 37 | 38 | public :: pumas_gamma 39 | 40 | interface pumas_gamma 41 | module procedure pumas_gamma_r8 42 | end interface pumas_gamma 43 | 44 | ! Mathematical constants 45 | ! sqrt(pi) 46 | real(r8), parameter :: sqrtpi = 1.77245385090551602729_r8 47 | 48 | ! Define machine-specific constants needed in this module. 49 | ! These were used by the original gamma and calerf functions to guarantee 50 | ! safety against overflow, and precision, on many different machines. 51 | 52 | ! By defining the constants in this way, we assume that 1/xmin is 53 | ! representable (i.e. does not overflow the real type). This assumption was 54 | ! not in the original code, but is valid for IEEE single and double 55 | ! precision. 56 | 57 | ! Double precision 58 | !--------------------------------------------------------------------- 59 | ! Machine epsilon 60 | real(r8), parameter :: epsr8 = epsilon(1._r8) 61 | ! "Huge" value is returned when actual value would be infinite. 62 | real(r8), parameter :: xinfr8 = huge(1._r8) 63 | ! Smallest normal value. 64 | real(r8), parameter :: xminr8 = tiny(1._r8) 65 | ! Largest number that, when added to 1., yields 1. 66 | real(r8), parameter :: xsmallr8 = epsr8/2._r8 67 | ! Largest argument for which erfcx > 0. 68 | real(r8), parameter :: xmaxr8 = 1._r8/(sqrtpi*xminr8) 69 | 70 | ! For gamma 71 | ! Approximate value of largest acceptable argument to gamma, 72 | ! for IEEE double-precision. 73 | real(r8), parameter :: xbig_gamma = 171.624_r8 74 | 75 | !$acc declare copyin(xinfr8,epsr8,xminr8,xbig_gamma) 76 | 77 | contains 78 | 79 | elemental function pumas_gamma_r8(x) result(res) 80 | !$acc routine seq 81 | real(r8), intent(in) :: x 82 | real(r8) :: res 83 | 84 | #if defined HAVE_GAMMA_INTRINSICS 85 | ! Call intrinsic gamma. 86 | intrinsic gamma 87 | res = gamma(x) 88 | #else 89 | ! No intrinsic 90 | res = pumas_gamma_nonintrinsic_r8(x) 91 | #endif 92 | 93 | end function pumas_gamma_r8 94 | 95 | !cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc 96 | 97 | pure function pumas_gamma_nonintrinsic_r8(X) result(gamma) 98 | !$acc routine seq 99 | 100 | !cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc 101 | ! 102 | ! 7 Feb 2013 -- S. Santos 103 | ! The following comments are from the original version. Changes have 104 | ! been made to update syntax and allow inclusion into this module. 105 | ! 106 | !---------------------------------------------------------------------- 107 | ! 108 | ! THIS ROUTINE CALCULATES THE GAMMA FUNCTION FOR A REAL ARGUMENT X. 109 | ! COMPUTATION IS BASED ON AN ALGORITHM OUTLINED IN REFERENCE 1. 110 | ! THE PROGRAM USES RATIONAL FUNCTIONS THAT APPROXIMATE THE GAMMA 111 | ! FUNCTION TO AT LEAST 20 SIGNIFICANT DECIMAL DIGITS. COEFFICIENTS 112 | ! FOR THE APPROXIMATION OVER THE INTERVAL (1,2) ARE UNPUBLISHED. 113 | ! THOSE FOR THE APPROXIMATION FOR X .GE. 12 ARE FROM REFERENCE 2. 114 | ! THE ACCURACY ACHIEVED DEPENDS ON THE ARITHMETIC SYSTEM, THE 115 | ! COMPILER, THE INTRINSIC FUNCTIONS, AND PROPER SELECTION OF THE 116 | ! MACHINE-DEPENDENT CONSTANTS. 117 | ! 118 | ! 119 | !******************************************************************* 120 | !******************************************************************* 121 | ! 122 | ! EXPLANATION OF MACHINE-DEPENDENT CONSTANTS 123 | ! 124 | ! BETA - RADIX FOR THE FLOATING-POINT REPRESENTATION 125 | ! MAXEXP - THE SMALLEST POSITIVE POWER OF BETA THAT OVERFLOWS 126 | ! XBIG - THE LARGEST ARGUMENT FOR WHICH GAMMA(X) IS REPRESENTABLE 127 | ! IN THE MACHINE, I.E., THE SOLUTION TO THE EQUATION 128 | ! GAMMA(XBIG) = BETA**MAXEXP 129 | ! XINF - THE LARGEST MACHINE REPRESENTABLE FLOATING-POINT NUMBER; 130 | ! APPROXIMATELY BETA**MAXEXP 131 | ! EPS - THE SMALLEST POSITIVE FLOATING-POINT NUMBER SUCH THAT 132 | ! 1.0+EPS .GT. 1.0 133 | ! XMININ - THE SMALLEST POSITIVE FLOATING-POINT NUMBER SUCH THAT 134 | ! 1/XMININ IS MACHINE REPRESENTABLE 135 | ! 136 | ! APPROXIMATE VALUES FOR SOME IMPORTANT MACHINES ARE: 137 | ! 138 | ! BETA MAXEXP XBIG 139 | ! 140 | ! CRAY-1 (S.P.) 2 8191 966.961 141 | ! CYBER 180/855 142 | ! UNDER NOS (S.P.) 2 1070 177.803 143 | ! IEEE (IBM/XT, 144 | ! SUN, ETC.) (S.P.) 2 128 35.040 145 | ! IEEE (IBM/XT, 146 | ! SUN, ETC.) (D.P.) 2 1024 171.624 147 | ! IBM 3033 (D.P.) 16 63 57.574 148 | ! VAX D-FORMAT (D.P.) 2 127 34.844 149 | ! VAX G-FORMAT (D.P.) 2 1023 171.489 150 | ! 151 | ! XINF EPS XMININ 152 | ! 153 | ! CRAY-1 (S.P.) 5.45E+2465 7.11E-15 1.84E-2466 154 | ! CYBER 180/855 155 | ! UNDER NOS (S.P.) 1.26E+322 3.55E-15 3.14E-294 156 | ! IEEE (IBM/XT, 157 | ! SUN, ETC.) (S.P.) 3.40E+38 1.19E-7 1.18E-38 158 | ! IEEE (IBM/XT, 159 | ! SUN, ETC.) (D.P.) 1.79D+308 2.22D-16 2.23D-308 160 | ! IBM 3033 (D.P.) 7.23D+75 2.22D-16 1.39D-76 161 | ! VAX D-FORMAT (D.P.) 1.70D+38 1.39D-17 5.88D-39 162 | ! VAX G-FORMAT (D.P.) 8.98D+307 1.11D-16 1.12D-308 163 | ! 164 | !******************************************************************* 165 | !******************************************************************* 166 | ! 167 | ! ERROR RETURNS 168 | ! 169 | ! THE PROGRAM RETURNS THE VALUE XINF FOR SINGULARITIES OR 170 | ! WHEN OVERFLOW WOULD OCCUR. THE COMPUTATION IS BELIEVED 171 | ! TO BE FREE OF UNDERFLOW AND OVERFLOW. 172 | ! 173 | ! 174 | ! INTRINSIC FUNCTIONS REQUIRED ARE: 175 | ! 176 | ! INT, DBLE, EXP, LOG, REAL, SIN 177 | ! 178 | ! 179 | ! REFERENCES: AN OVERVIEW OF SOFTWARE DEVELOPMENT FOR SPECIAL 180 | ! FUNCTIONS W. J. CODY, LECTURE NOTES IN MATHEMATICS, 181 | ! 506, NUMERICAL ANALYSIS DUNDEE, 1975, G. A. WATSON 182 | ! (ED.), SPRINGER VERLAG, BERLIN, 1976. 183 | ! 184 | ! COMPUTER APPROXIMATIONS, HART, ET. AL., WILEY AND 185 | ! SONS, NEW YORK, 1968. 186 | ! 187 | ! LATEST MODIFICATION: OCTOBER 12, 1989 188 | ! 189 | ! AUTHORS: W. J. CODY AND L. STOLTZ 190 | ! APPLIED MATHEMATICS DIVISION 191 | ! ARGONNE NATIONAL LABORATORY 192 | ! ARGONNE, IL 60439 193 | ! 194 | !---------------------------------------------------------------------- 195 | 196 | real(r8), intent(in) :: x 197 | real(r8) :: gamma 198 | real(r8) :: fact, res, sum, xden, xnum, y, y1, ysq, z 199 | 200 | integer :: i, n 201 | logical :: negative_odd 202 | 203 | ! log(2*pi)/2 204 | real(r8), parameter :: logsqrt2pi = 0.9189385332046727417803297E0_r8 205 | 206 | !---------------------------------------------------------------------- 207 | ! NUMERATOR AND DENOMINATOR COEFFICIENTS FOR RATIONAL MINIMAX 208 | ! APPROXIMATION OVER (1,2). 209 | !---------------------------------------------------------------------- 210 | real(r8), parameter :: P(8) = & 211 | (/-1.71618513886549492533811E+0_r8, 2.47656508055759199108314E+1_r8, & 212 | -3.79804256470945635097577E+2_r8, 6.29331155312818442661052E+2_r8, & 213 | 8.66966202790413211295064E+2_r8,-3.14512729688483675254357E+4_r8, & 214 | -3.61444134186911729807069E+4_r8, 6.64561438202405440627855E+4_r8 /) 215 | real(r8), parameter :: Q(8) = & 216 | (/-3.08402300119738975254353E+1_r8, 3.15350626979604161529144E+2_r8, & 217 | -1.01515636749021914166146E+3_r8,-3.10777167157231109440444E+3_r8, & 218 | 2.25381184209801510330112E+4_r8, 4.75584627752788110767815E+3_r8, & 219 | -1.34659959864969306392456E+5_r8,-1.15132259675553483497211E+5_r8 /) 220 | !---------------------------------------------------------------------- 221 | ! COEFFICIENTS FOR MINIMAX APPROXIMATION OVER (12, INF). 222 | !---------------------------------------------------------------------- 223 | real(r8), parameter :: C(7) = & 224 | (/-1.910444077728E-03_r8, 8.4171387781295E-04_r8, & 225 | -5.952379913043012E-04_r8, 7.93650793500350248E-04_r8, & 226 | -2.777777777777681622553E-03_r8, 8.333333333333333331554247E-02_r8, & 227 | 5.7083835261E-03_r8 /) 228 | 229 | negative_odd = .false. 230 | fact = 1._r8 231 | n = 0 232 | y = x 233 | if (y <= 0._r8) then 234 | !---------------------------------------------------------------------- 235 | ! ARGUMENT IS NEGATIVE 236 | !---------------------------------------------------------------------- 237 | y = -x 238 | y1 = aint(y) 239 | res = y - y1 240 | if (res /= 0._r8) then 241 | negative_odd = (y1 /= aint(y1*0.5_r8)*2._r8) 242 | fact = -pi/sin(pi*res) 243 | y = y + 1._r8 244 | else 245 | gamma = xinfr8 246 | return 247 | end if 248 | end if 249 | !---------------------------------------------------------------------- 250 | ! ARGUMENT IS POSITIVE 251 | !---------------------------------------------------------------------- 252 | if (y < epsr8) then 253 | !---------------------------------------------------------------------- 254 | ! ARGUMENT .LT. EPS 255 | !---------------------------------------------------------------------- 256 | if (y >= xminr8) then 257 | res = 1._r8/y 258 | else 259 | gamma = xinfr8 260 | return 261 | end if 262 | elseif (y < 12._r8) then 263 | y1 = y 264 | if (y < 1._r8) then 265 | !---------------------------------------------------------------------- 266 | ! 0.0 .LT. ARGUMENT .LT. 1.0 267 | !---------------------------------------------------------------------- 268 | z = y 269 | y = y + 1._r8 270 | else 271 | !---------------------------------------------------------------------- 272 | ! 1.0 .LT. ARGUMENT .LT. 12.0, REDUCE ARGUMENT IF NECESSARY 273 | !---------------------------------------------------------------------- 274 | n = int(y) - 1 275 | y = y - real(n, r8) 276 | z = y - 1._r8 277 | end if 278 | !---------------------------------------------------------------------- 279 | ! EVALUATE APPROXIMATION FOR 1.0 .LT. ARGUMENT .LT. 2.0 280 | !---------------------------------------------------------------------- 281 | xnum = 0._r8 282 | xden = 1._r8 283 | do i=1,8 284 | xnum = (xnum+P(i))*z 285 | xden = xden*z + Q(i) 286 | end do 287 | res = xnum/xden + 1._r8 288 | if (y1 < y) then 289 | !---------------------------------------------------------------------- 290 | ! ADJUST RESULT FOR CASE 0.0 .LT. ARGUMENT .LT. 1.0 291 | !---------------------------------------------------------------------- 292 | res = res/y1 293 | elseif (y1 > y) then 294 | !---------------------------------------------------------------------- 295 | ! ADJUST RESULT FOR CASE 2.0 .LT. ARGUMENT .LT. 12.0 296 | !---------------------------------------------------------------------- 297 | do i = 1,n 298 | res = res*y 299 | y = y + 1._r8 300 | end do 301 | end if 302 | else 303 | !---------------------------------------------------------------------- 304 | ! EVALUATE FOR ARGUMENT .GE. 12.0, 305 | !---------------------------------------------------------------------- 306 | if (y <= xbig_gamma) then 307 | ysq = y*y 308 | sum = C(7) 309 | do i=1,6 310 | sum = sum/ysq + C(i) 311 | end do 312 | sum = sum/y - y + logsqrt2pi 313 | sum = sum + (y-0.5_r8)*log(y) 314 | res = exp(sum) 315 | else 316 | gamma = xinfr8 317 | return 318 | end if 319 | end if 320 | !---------------------------------------------------------------------- 321 | ! FINAL ADJUSTMENTS AND RETURN 322 | !---------------------------------------------------------------------- 323 | if (negative_odd) res = -res 324 | if (fact /= 1._r8) res = fact/res 325 | gamma = res 326 | ! ---------- LAST LINE OF GAMMA ---------- 327 | end function pumas_gamma_nonintrinsic_r8 328 | 329 | end module pumas_gamma_function 330 | -------------------------------------------------------------------------------- /module_neural_net.F90: -------------------------------------------------------------------------------- 1 | module module_neural_net 2 | use netcdf 3 | use pumas_kinds, only: r8=>kind_r8 4 | 5 | implicit none 6 | type Dense 7 | integer :: input_size 8 | integer :: output_size 9 | integer :: batch_size 10 | integer :: activation 11 | real(kind=r8), allocatable :: weights(:, :) 12 | real(kind=r8), allocatable :: bias(:) 13 | end type Dense 14 | 15 | type DenseData 16 | real(kind=r8), allocatable :: input(:, :) 17 | real(kind=r8), allocatable :: output(:, :) 18 | end type DenseData 19 | 20 | contains 21 | 22 | subroutine apply_dense(input, layer, output) 23 | ! Description: Pass a set of input data through a single dense layer and nonlinear activation function 24 | ! 25 | ! Inputs: 26 | ! layer (input): a single Dense object 27 | ! input (input): a 2D array where the rows are different examples and 28 | ! the columns are different model inputs 29 | ! 30 | ! Output: 31 | ! output: output of the dense layer as a 2D array with shape (number of inputs, number of neurons) 32 | real(kind=r8), dimension(:, :), intent(in) :: input 33 | type(Dense), intent(in) :: layer 34 | real(kind=r8), dimension(size(input, 1), layer%output_size), intent(out) :: output 35 | real(kind=r8), dimension(size(input, 1), layer%output_size) :: dense_output 36 | integer :: i, j, num_examples 37 | real(kind=r8) :: alpha, beta 38 | external :: dgemm 39 | alpha = 1 40 | beta = 1 41 | dense_output = 0 42 | output = 0 43 | num_examples = size(input, 1) 44 | call dgemm('n', 'n', num_examples, layer%output_size, layer%input_size, & 45 | alpha, input, num_examples, layer%weights, layer%input_size, beta, dense_output, num_examples) 46 | do i=1, num_examples 47 | do j=1, layer%output_size 48 | dense_output(i, j) = dense_output(i, j) + layer%bias(j) 49 | end do 50 | end do 51 | call apply_activation(dense_output, layer%activation, output) 52 | end subroutine apply_dense 53 | 54 | subroutine apply_activation(input, activation_type, output) 55 | ! Description: Apply a nonlinear activation function to a given array of input values. 56 | ! 57 | ! Inputs: 58 | ! input: A 2D array 59 | ! activation_type: string describing which activation is being applied. If the activation 60 | ! type does not match any of the available options, the linear activation is applied. 61 | ! Currently supported activations are: 62 | ! relu 63 | ! elu 64 | ! selu 65 | ! sigmoid 66 | ! tanh 67 | ! softmax 68 | ! linear 69 | ! Output: 70 | ! output: Array of the same dimensions as input with the nonlinear activation applied. 71 | real(kind=r8), dimension(:, :), intent(in) :: input 72 | integer, intent(in) :: activation_type 73 | real(kind=r8), dimension(size(input, 1), size(input, 2)), intent(out) :: output 74 | 75 | real(kind=r8), dimension(size(input, 1)) :: softmax_sum 76 | real(kind=r8), parameter :: selu_alpha = 1.6732 77 | real(kind=r8), parameter :: selu_lambda = 1.0507 78 | real(kind=r8), parameter :: zero = 0.0 79 | integer :: i, j 80 | select case (activation_type) 81 | case (0) 82 | output = input 83 | case (1) 84 | do i=1,size(input, 1) 85 | do j=1, size(input,2) 86 | output(i, j) = dmax1(input(i, j), zero) 87 | end do 88 | end do 89 | case (2) 90 | output = 1.0 / (1.0 + dexp(-input)) 91 | case (3) 92 | do i=1,size(input, 1) 93 | do j=1, size(input,2) 94 | if (input(i, j) >= 0) then 95 | output(i, j) = input(i, j) 96 | else 97 | output(i, j) = dexp(input(i, j))-1.0_r8 98 | end if 99 | end do 100 | end do 101 | case (4) 102 | do i=1,size(input, 1) 103 | do j=1, size(input,2) 104 | if (input(i, j) >= 0) then 105 | output(i, j) = input(i, j) 106 | else 107 | output(i, j) = selu_lambda * ( selu_alpha * dexp(input(i, j)) - selu_alpha) 108 | end if 109 | end do 110 | end do 111 | case (5) 112 | output = tanh(input) 113 | case (6) 114 | softmax_sum = sum(dexp(input), dim=2) 115 | do i=1, size(input, 1) 116 | do j=1, size(input, 2) 117 | output(i, j) = dexp(input(i, j)) / softmax_sum(i) 118 | end do 119 | end do 120 | case default 121 | output = input 122 | end select 123 | end subroutine apply_activation 124 | 125 | subroutine init_neural_net(filename, batch_size, neural_net_model, iulog, errstring) 126 | ! init_neuralnet 127 | ! Description: Loads dense neural network weights from a netCDF file and builds an array of 128 | ! Dense types from the weights and activations. 129 | ! 130 | ! Input: 131 | ! filename: Full path to the netCDF file 132 | ! batch_size: number of items in single batch. Used to set intermediate array sizes. 133 | ! 134 | ! Output: 135 | ! neural_net_model (output): array of Dense layers composing a densely connected neural network 136 | ! 137 | character(len=*), intent(in) :: filename 138 | integer, intent(in) :: batch_size 139 | type(Dense), allocatable, intent(out) :: neural_net_model(:) 140 | integer, intent(in) :: iulog 141 | character(128), intent(out) :: errstring ! output status (non-blank for error return) 142 | 143 | integer :: ncid, num_layers_id, num_layers 144 | integer :: layer_names_var_id, i, layer_in_dimid, layer_out_dimid 145 | integer :: layer_in_dim, layer_out_dim 146 | integer :: layer_weight_var_id 147 | integer :: layer_bias_var_id 148 | 149 | character (len=8), allocatable :: layer_names(:) 150 | character (len=10) :: num_layers_dim_name = "num_layers" 151 | character (len=11) :: layer_name_var = "layer_names" 152 | character (len=11) :: layer_in_dim_name 153 | character (len=12) :: layer_out_dim_name 154 | character (len=10) :: activation_name 155 | real (kind=r8), allocatable :: temp_weights(:, :) 156 | 157 | errstring = '' 158 | 159 | ! Open netCDF file 160 | call check(nf90_open(filename, nf90_nowrite, ncid),errstring) 161 | if (trim(errstring) /= '') return 162 | ! Get the number of layers in the neural network 163 | call check(nf90_inq_dimid(ncid, num_layers_dim_name, num_layers_id),errstring) 164 | if (trim(errstring) /= '') return 165 | call check(nf90_inquire_dimension(ncid, num_layers_id, & 166 | num_layers_dim_name, num_layers),errstring) 167 | if (trim(errstring) /= '') return 168 | call check(nf90_inq_varid(ncid, layer_name_var, layer_names_var_id),errstring) 169 | if (trim(errstring) /= '') return 170 | allocate(layer_names(num_layers)) 171 | call check(nf90_get_var(ncid, layer_names_var_id, layer_names),errstring) 172 | if (trim(errstring) /= '') return 173 | write(iulog,*) "load neural network " // filename 174 | allocate(neural_net_model(1:num_layers)) 175 | ! Loop through each layer and load the weights, bias term, and activation function 176 | do i=1, num_layers 177 | layer_in_dim_name = trim(layer_names(i)) // "_in" 178 | layer_out_dim_name = trim(layer_names(i)) // "_out" 179 | layer_in_dimid = -1 180 | ! Get layer input and output dimensions 181 | call check(nf90_inq_dimid(ncid, trim(layer_in_dim_name), layer_in_dimid),errstring) 182 | if (trim(errstring) /= '') return 183 | call check(nf90_inquire_dimension(ncid, layer_in_dimid, layer_in_dim_name, layer_in_dim),errstring) 184 | if (trim(errstring) /= '') return 185 | call check(nf90_inq_dimid(ncid, trim(layer_out_dim_name), layer_out_dimid),errstring) 186 | if (trim(errstring) /= '') return 187 | call check(nf90_inquire_dimension(ncid, layer_out_dimid, layer_out_dim_name, layer_out_dim),errstring) 188 | if (trim(errstring) /= '') return 189 | call check(nf90_inq_varid(ncid, trim(layer_names(i)) // "_weights", & 190 | layer_weight_var_id),errstring) 191 | if (trim(errstring) /= '') return 192 | call check(nf90_inq_varid(ncid, trim(layer_names(i)) // "_bias", & 193 | layer_bias_var_id),errstring) 194 | if (trim(errstring) /= '') return 195 | neural_net_model(i)%input_size = layer_in_dim 196 | neural_net_model(i)%output_size = layer_out_dim 197 | neural_net_model(i)%batch_size = batch_size 198 | ! Fortran loads 2D arrays in the opposite order from Python/C, so I 199 | ! first load the data into a temporary array and then apply the 200 | ! transpose operation to copy the weights into the Dense layer 201 | allocate(neural_net_model(i)%weights(layer_in_dim, layer_out_dim)) 202 | allocate(temp_weights(layer_out_dim, layer_in_dim)) 203 | 204 | call check(nf90_get_var(ncid, layer_weight_var_id, & 205 | temp_weights),errstring) 206 | if (trim(errstring) /= '') return 207 | neural_net_model(i)%weights = transpose(temp_weights) 208 | deallocate(temp_weights) 209 | ! Load the bias weights 210 | allocate(neural_net_model(i)%bias(layer_out_dim)) 211 | call check(nf90_get_var(ncid, layer_bias_var_id, & 212 | neural_net_model(i)%bias),errstring) 213 | if (trim(errstring) /= '') return 214 | ! Get the name of the activation function, which is stored as an attribute of the weights variable 215 | call check(nf90_get_att(ncid, layer_weight_var_id, "activation", & 216 | activation_name),errstring) 217 | if (trim(errstring) /= '') return 218 | select case (trim(activation_name)) 219 | case ("linear") 220 | neural_net_model(i)%activation = 0 221 | case ("relu") 222 | neural_net_model(i)%activation = 1 223 | case ("sigmoid") 224 | neural_net_model(i)%activation = 2 225 | case ("elu") 226 | neural_net_model(i)%activation = 3 227 | case ("selu") 228 | neural_net_model(i)%activation = 4 229 | case ("tanh") 230 | neural_net_model(i)%activation = 5 231 | case ("softmax") 232 | neural_net_model(i)%activation = 6 233 | case default 234 | neural_net_model(i)%activation = 7 235 | end select 236 | end do 237 | call check(nf90_close(ncid),errstring) 238 | if (trim(errstring) /= '') return 239 | 240 | end subroutine init_neural_net 241 | 242 | subroutine load_quantile_scale_values(filename, scale_values, iulog, errstring) 243 | character(len = *), intent(in) :: filename 244 | real(kind = r8), allocatable, intent(out) :: scale_values(:, :) 245 | integer, intent(in) :: iulog 246 | character(128), intent(out) :: errstring ! output status (non-blank for error return) 247 | 248 | real(kind = r8), allocatable :: temp_scale_values(:, :) 249 | character(len=8) :: quantile_dim_name = "quantile" 250 | character(len=7) :: column_dim_name = "column" 251 | character(len=9) :: ref_var_name = "reference" 252 | character(len=9) :: quant_var_name = "quantiles" 253 | integer :: ncid, quantile_id, column_id, quantile_dim, column_dim, ref_var_id, quant_var_id 254 | 255 | errstring = '' 256 | 257 | call check(nf90_open(filename, nf90_nowrite, ncid),errstring) 258 | if (trim(errstring) /= '') return 259 | call check(nf90_inq_dimid(ncid, quantile_dim_name, quantile_id),errstring) 260 | if (trim(errstring) /= '') return 261 | call check(nf90_inq_dimid(ncid, column_dim_name, column_id),errstring) 262 | if (trim(errstring) /= '') return 263 | call check(nf90_inquire_dimension(ncid, quantile_id, & 264 | quantile_dim_name, quantile_dim),errstring) 265 | if (trim(errstring) /= '') return 266 | call check(nf90_inquire_dimension(ncid, column_id, & 267 | column_dim_name, column_dim),errstring) 268 | if (trim(errstring) /= '') return 269 | allocate(scale_values(quantile_dim, column_dim + 1)) 270 | allocate(temp_scale_values(column_dim + 1, quantile_dim)) 271 | call check(nf90_inq_varid(ncid, ref_var_name, ref_var_id),errstring) 272 | if (trim(errstring) /= '') return 273 | write(iulog,*) "load ref var" 274 | call check(nf90_get_var(ncid, ref_var_id, temp_scale_values(1, :)),errstring) 275 | if (trim(errstring) /= '') return 276 | call check(nf90_inq_varid(ncid, quant_var_name, quant_var_id),errstring) 277 | if (trim(errstring) /= '') return 278 | write(iulog,*) "load quant var" 279 | call check(nf90_get_var(ncid, quant_var_id, temp_scale_values(2:column_dim + 1, :)),errstring) 280 | if (trim(errstring) /= '') return 281 | scale_values = transpose(temp_scale_values) 282 | call check(nf90_close(ncid),errstring) 283 | if (trim(errstring) /= '') return 284 | end subroutine load_quantile_scale_values 285 | 286 | subroutine linear_interp(x_in, xs, ys, y_in) 287 | real(kind = r8), dimension(:), intent(in) :: x_in 288 | real(kind = r8), dimension(:), intent(in) :: xs 289 | real(kind = r8), dimension(:), intent(in) :: ys 290 | real(kind = r8), dimension(size(x_in, 1)), intent(out) :: y_in 291 | integer :: i, j, x_in_size, xs_size, x_pos 292 | x_in_size = size(x_in, 1) 293 | xs_size = size(xs, 1) 294 | do i = 1, x_in_size 295 | if (x_in(i) <= xs(1)) then 296 | y_in(i) = ys(1) 297 | else if (x_in(i) >= xs(xs_size)) then 298 | y_in(i) = ys(xs_size) 299 | else 300 | j = 1 301 | do while (xs(j) < x_in(i)) 302 | j = j + 1 303 | end do 304 | y_in(i) = (ys(j - 1) * (xs(j) - x_in(i)) + ys(j) * (x_in(i) - xs(j - 1))) / (xs(j) - xs(j - 1)) 305 | end if 306 | end do 307 | end subroutine linear_interp 308 | 309 | subroutine quantile_transform(x_inputs, scale_values, x_transformed) 310 | real(kind = r8), dimension(:, :), intent(in) :: x_inputs 311 | real(kind = r8), dimension(:, :), intent(in) :: scale_values 312 | real(kind = r8), dimension(size(x_inputs, 1), size(x_inputs, 2)), intent(out) :: x_transformed 313 | integer :: j, x_size, scale_size 314 | x_size = size(x_inputs, 1) 315 | scale_size = size(scale_values, 1) 316 | do j = 1, size(x_inputs, 2) 317 | call linear_interp(x_inputs(:, j), scale_values(:, j + 1), & 318 | scale_values(:, 1), x_transformed(:, j)) 319 | end do 320 | end subroutine quantile_transform 321 | 322 | subroutine quantile_inv_transform(x_inputs, scale_values, x_transformed) 323 | real(kind = r8), dimension(:, :), intent(in) :: x_inputs 324 | real(kind = r8), dimension(:, :), intent(in) :: scale_values 325 | real(kind = r8), dimension(size(x_inputs, 1), size(x_inputs, 2)), intent(out) :: x_transformed 326 | integer :: j, x_size, scale_size 327 | x_size = size(x_inputs, 1) 328 | scale_size = size(scale_values, 1) 329 | do j = 1, size(x_inputs, 2) 330 | call linear_interp(x_inputs(:, j), scale_values(:, 1), scale_values(:, j + 1), x_transformed(:, j)) 331 | end do 332 | end subroutine quantile_inv_transform 333 | 334 | subroutine neural_net_predict(input, neural_net_model, prediction) 335 | ! neural_net_predict 336 | ! Description: generate prediction from neural network model for an arbitrary set of input values 337 | ! 338 | ! Args: 339 | ! input (input): 2D array of input values. Each row is a separate instance and each column is a model input. 340 | ! neural_net_model (input): Array of type(Dense) objects 341 | ! prediction (output): The prediction of the neural network as a 2D array of dimension (examples, outputs) 342 | real(kind=r8), intent(in) :: input(:, :) 343 | type(Dense), intent(in) :: neural_net_model(:) 344 | real(kind=r8), intent(out) :: prediction(size(input, 1), neural_net_model(size(neural_net_model))%output_size) 345 | integer :: bi, i, j, num_layers 346 | integer :: batch_size 347 | integer :: input_size 348 | integer :: batch_index_size 349 | integer, allocatable :: batch_indices(:) 350 | type(DenseData) :: neural_net_data(size(neural_net_model)) 351 | input_size = size(input, 1) 352 | num_layers = size(neural_net_model) 353 | batch_size = neural_net_model(1)%batch_size 354 | batch_index_size = input_size / batch_size 355 | allocate(batch_indices(batch_index_size)) 356 | i = 1 357 | do bi=batch_size, input_size, batch_size 358 | batch_indices(i) = bi 359 | i = i + 1 360 | end do 361 | do j=1, num_layers 362 | allocate(neural_net_data(j)%input(batch_size, neural_net_model(j)%input_size)) 363 | allocate(neural_net_data(j)%output(batch_size, neural_net_model(j)%output_size)) 364 | end do 365 | batch_indices(batch_index_size) = input_size 366 | do bi=1, batch_index_size 367 | neural_net_data(1)%input = input(batch_indices(bi)-batch_size+1:batch_indices(bi), :) 368 | do i=1, num_layers - 1 369 | call apply_dense(neural_net_data(i)%input, neural_net_model(i), neural_net_data(i)%output) 370 | neural_net_data(i + 1)%input = neural_net_data(i)%output 371 | end do 372 | call apply_dense(neural_net_data(num_layers)%input, neural_net_model(num_layers), & 373 | neural_net_data(num_layers)%output) 374 | prediction(batch_indices(bi)-batch_size + 1:batch_indices(bi), :) = & 375 | neural_net_data(num_layers)%output 376 | end do 377 | do j=1, num_layers 378 | deallocate(neural_net_data(j)%input) 379 | deallocate(neural_net_data(j)%output) 380 | end do 381 | deallocate(batch_indices) 382 | end subroutine neural_net_predict 383 | 384 | subroutine standard_scaler_transform(input_data, scale_values, transformed_data, errstring) 385 | ! Perform z-score normalization of input_data table. Equivalent to scikit-learn StandardScaler. 386 | ! 387 | ! Inputs: 388 | ! input_data: 2D array where rows are examples and columns are variables 389 | ! scale_values: 2D array where rows are the input variables and columns are mean and standard deviation 390 | ! Output: 391 | ! transformed_data: 2D array with the same shape as input_data containing the transformed values. 392 | real(r8), intent(in) :: input_data(:, :) 393 | real(r8), intent(in) :: scale_values(:, :) 394 | real(r8), intent(out) :: transformed_data(size(input_data, 1), size(input_data, 2)) 395 | character(128), intent(out) :: errstring ! output status (non-blank for error return) 396 | integer :: i 397 | 398 | errstring = '' 399 | if (size(input_data, 2) /= size(scale_values, 1)) then 400 | write(errstring,*) "Size mismatch between input data and scale values", size(input_data, 2), size(scale_values, 1) 401 | return 402 | end if 403 | do i=1, size(input_data, 2) 404 | transformed_data(:, i) = (input_data(:, i) - scale_values(i, 1)) / scale_values(i, 2) 405 | end do 406 | end subroutine standard_scaler_transform 407 | 408 | subroutine load_scale_values(filename, num_inputs, scale_values) 409 | character(len=*), intent(in) :: filename 410 | integer, intent(in) :: num_inputs 411 | real(r8), intent(out) :: scale_values(num_inputs, 2) 412 | character(len=40) :: row_name 413 | integer :: isu, i 414 | isu = 2 415 | open(isu, file=filename, access="sequential", form="formatted") 416 | read(isu, "(A)") 417 | do i=1, num_inputs 418 | read(isu, *) row_name, scale_values(i, 1), scale_values(i, 2) 419 | end do 420 | close(isu) 421 | end subroutine load_scale_values 422 | 423 | 424 | subroutine standard_scaler_inverse_transform(input_data, scale_values, transformed_data, errstring) 425 | ! Perform inverse z-score normalization of input_data table. Equivalent to scikit-learn StandardScaler. 426 | ! 427 | ! Inputs: 428 | ! input_data: 2D array where rows are examples and columns are variables 429 | ! scale_values: 2D array where rows are the input variables and columns are mean and standard deviation 430 | ! Output: 431 | ! transformed_data: 2D array with the same shape as input_data containing the transformed values. 432 | real(r8), intent(in) :: input_data(:, :) 433 | real(r8), intent(in) :: scale_values(:, :) 434 | real(r8), intent(out) :: transformed_data(size(input_data, 1), size(input_data, 2)) 435 | character(128), intent(out) :: errstring ! output status (non-blank for error return) 436 | integer :: i 437 | if (size(input_data, 2) /= size(scale_values, 1)) then 438 | write(errstring,*) "Size mismatch between input data and scale values", size(input_data, 2), size(scale_values, 1) 439 | return 440 | end if 441 | do i=1, size(input_data, 2) 442 | transformed_data(:, i) = input_data(:, i) * scale_values(i, 2) + scale_values(i, 1) 443 | end do 444 | end subroutine standard_scaler_inverse_transform 445 | 446 | subroutine minmax_scaler_transform(input_data, scale_values, transformed_data, errstring) 447 | ! Perform min-max scaling of input_data table. Equivalent to scikit-learn MinMaxScaler. 448 | ! 449 | ! Inputs: 450 | ! input_data: 2D array where rows are examples and columns are variables 451 | ! scale_values: 2D array where rows are the input variables and columns are min and max. 452 | ! Output: 453 | ! transformed_data: 2D array with the same shape as input_data containing the transformed values. 454 | real(r8), intent(in) :: input_data(:, :) 455 | real(r8), intent(in) :: scale_values(:, :) 456 | real(r8), intent(out) :: transformed_data(size(input_data, 1), size(input_data, 2)) 457 | character(128), intent(out) :: errstring ! output status (non-blank for error return) 458 | 459 | integer :: i 460 | if (size(input_data, 2) /= size(scale_values, 1)) then 461 | write(errstring,*) "Size mismatch between input data and scale values", size(input_data, 2), size(scale_values, 1) 462 | return 463 | end if 464 | do i=1, size(input_data, 2) 465 | transformed_data(:, i) = (input_data(:, i) - scale_values(i, 1)) / (scale_values(i, 2) - scale_values(i ,1)) 466 | end do 467 | end subroutine minmax_scaler_transform 468 | 469 | subroutine minmax_scaler_inverse_transform(input_data, scale_values, transformed_data, errstring) 470 | ! Perform inverse min-max scaling of input_data table. Equivalent to scikit-learn MinMaxScaler. 471 | ! 472 | ! Inputs: 473 | ! input_data: 2D array where rows are examples and columns are variables 474 | ! scale_values: 2D array where rows are the input variables and columns are min and max. 475 | ! Output: 476 | ! transformed_data: 2D array with the same shape as input_data containing the transformed values. 477 | real(r8), intent(in) :: input_data(:, :) 478 | real(r8), intent(in) :: scale_values(:, :) 479 | real(r8), intent(out) :: transformed_data(size(input_data, 1), size(input_data, 2)) 480 | character(128), intent(out) :: errstring ! output status (non-blank for error return) 481 | 482 | integer :: i 483 | if (size(input_data, 2) /= size(scale_values, 1)) then 484 | write(errstring,*) "Size mismatch between input data and scale values", size(input_data, 2), size(scale_values, 1) 485 | return 486 | end if 487 | do i=1, size(input_data, 2) 488 | transformed_data(:, i) = input_data(:, i) * (scale_values(i, 2) - scale_values(i ,1)) + scale_values(i, 1) 489 | end do 490 | end subroutine minmax_scaler_inverse_transform 491 | 492 | subroutine check(status, errstring) 493 | ! Check for netCDF errors 494 | integer, intent ( in) :: status 495 | character(128), intent(out) :: errstring ! output status (non-blank for error return) 496 | 497 | errstring = '' 498 | if(status /= nf90_noerr) then 499 | errstring = trim(nf90_strerror(status)) 500 | end if 501 | end subroutine check 502 | 503 | end module module_neural_net 504 | -------------------------------------------------------------------------------- /KBARF_tau_kernel.dat: -------------------------------------------------------------------------------- 1 | -.47757E-01 1 1 .44485E-27 2 | -.26460E+00 2 1 .61177E-28 3 | -.47965E-01 2 2 .17541E-26 4 | -.82258E+00 3 1 .21848E-27 5 | -.26760E+00 3 2 .38305E-27 6 | -.20453E-01 3 3 .25739E-26 7 | -.19050E+01 4 1 .76990E-27 8 | -.82072E+00 4 2 .13604E-26 9 | -.11992E+00 4 3 .23890E-26 10 | .78909E-01 4 4 .52169E-25 11 | -.39171E+01 5 1 .28173E-26 12 | -.18915E+01 5 2 .48901E-26 13 | -.33270E+00 5 3 .84230E-26 14 | .41936E+00 5 4 .14824E-25 15 | .34801E+00 5 5 .87935E-24 16 | -.76415E+01 6 1 .10807E-25 17 | -.38808E+01 6 2 .18196E-25 18 | -.73737E+00 6 3 .31062E-25 19 | .14121E+01 6 4 .51763E-25 20 | .18851E+01 6 5 .91364E-25 21 | .99793E+00 6 6 .99683E-23 22 | -.14595E+02 7 1 .42464E-25 23 | -.75638E+01 7 2 .70076E-25 24 | -.14861E+01 7 3 .11799E-24 25 | .33598E+01 7 4 .19733E-24 26 | .61219E+01 7 5 .31492E-24 27 | .54314E+01 7 6 .55802E-24 28 | .24751E+01 7 7 .98373E-22 29 | -.27720E+02 8 1 .16832E-24 30 | -.14442E+02 8 2 .27473E-24 31 | -.28741E+01 8 3 .45660E-24 32 | .69895E+01 8 4 .76886E-24 33 | .14394E+02 8 5 .12538E-23 34 | .17479E+02 8 6 .18895E-23 35 | .13500E+02 8 7 .33663E-23 36 | .57110E+01 8 8 .90526E-21 37 | -.52737E+02 9 1 .66933E-24 38 | -.27428E+02 9 2 .10852E-23 39 | -.54729E+01 9 3 .17852E-23 40 | .13703E+02 9 4 .29923E-23 41 | .29792E+02 9 5 .50391E-23 42 | .40971E+02 9 6 .79673E-23 43 | .43267E+02 9 7 .11117E-22 44 | .31185E+02 9 8 .19960E-22 45 | .12630E+02 9 9 .79931E-20 46 | -.10083E+03 10 1 .26657E-23 47 | -.52188E+02 10 2 .43020E-23 48 | -.10391E+02 10 3 .70222E-23 49 | .26218E+02 10 4 .11662E-22 50 | .58283E+02 10 5 .19745E-22 51 | .84686E+02 10 6 .33254E-22 52 | .10128E+03 10 7 .50640E-22 53 | .99726E+02 10 8 .63546E-22 54 | .69014E+02 10 9 .95867E-19 55 | .27176E+02 10 10 .68713E-19 56 | -.19396E+03 11 1 .10627E-22 57 | -.99799E+02 11 2 .17090E-22 58 | -.19790E+02 11 3 .27732E-22 59 | .49801E+02 11 4 .45641E-22 60 | .11143E+03 11 5 .76658E-22 61 | .16558E+03 11 6 .13133E-21 62 | .20922E+03 11 7 .22121E-21 63 | .23326E+03 11 8 .32195E-21 64 | .22039E+03 11 9 .12255E-17 65 | .14858E+03 11 10 .71179E-20 66 | .57396E+02 11 11 .57998E-18 67 | -.37536E+03 12 1 .42395E-22 68 | -.19200E+03 12 2 .67995E-22 69 | -.37896E+02 12 3 .10983E-21 70 | .94692E+02 12 4 .17942E-21 71 | .21165E+03 12 5 .29822E-21 72 | .31650E+03 12 6 .50763E-21 73 | .40896E+03 12 7 .88157E-21 74 | .48169E+03 12 8 .14851E-20 75 | .51524E+03 12 9 .64845E-17 76 | .47402E+03 12 10 .79167E-17 77 | .31389E+03 12 11 .47676E-17 78 | .11962E+03 12 12 .48321E-17 79 | -.73047E+03 13 1 .16923E-21 80 | -.37164E+03 13 2 .27083E-21 81 | -.73015E+02 13 3 .43590E-21 82 | .18089E+03 13 4 .70788E-21 83 | .40253E+03 13 5 .11659E-20 84 | .60115E+03 13 6 .19610E-20 85 | .78166E+03 13 7 .33903E-20 86 | .94143E+03 13 8 .59790E-20 87 | .10638E+04 13 9 .26019E-16 88 | .11078E+04 13 10 .46657E-16 89 | .10008E+04 13 11 .51348E-16 90 | .65436E+03 13 12 .68775E-16 91 | .24691E+03 13 13 .39877E-16 92 | -.14285E+04 14 1 .67579E-21 93 | -.72333E+03 14 2 .10797E-20 94 | -.14152E+03 14 3 .17328E-20 95 | .34764E+03 14 4 .28010E-20 96 | .76925E+03 14 5 .45788E-20 97 | .11434E+04 14 6 .76158E-20 98 | .14846E+04 14 7 .12990E-19 99 | .17993E+04 14 8 .48011E-16 100 | .20789E+04 14 9 .94878E-16 101 | .22870E+04 14 10 .19035E-15 102 | .23385E+04 14 11 .34012E-15 103 | .20854E+04 14 12 .33468E-15 104 | .13509E+04 14 13 .74471E-15 105 | .50600E+03 14 14 .32677E-15 106 | -.41365E+04 15 1 .38255E-20 107 | -.20869E+04 15 2 .61934E-20 108 | -.40697E+03 15 3 .10103E-19 109 | .99310E+03 15 4 .16658E-19 110 | .21878E+04 15 5 .27883E-19 111 | .32394E+04 15 6 .47683E-19 112 | .41995E+04 15 7 .84060E-19 113 | .51084E+04 15 8 .15470E-18 114 | .59888E+04 15 9 .30172E-18 115 | .68297E+04 15 10 .62635E-18 116 | .75528E+04 15 11 .13249E-17 117 | .79583E+04 15 12 .24867E-17 118 | .76785E+04 15 13 .34182E-17 119 | .62489E+04 15 14 .20723E-13 120 | .76776E+03 15 15 .19801E-14 121 | .63760E+04 16 1 .41016E-18 122 | .64739E+04 16 2 .10408E-17 123 | .65970E+04 16 3 .26399E-17 124 | .67516E+04 16 4 .66840E-17 125 | .69451E+04 16 5 .16843E-16 126 | .71861E+04 16 6 .42006E-16 127 | .74835E+04 16 7 .10257E-15 128 | .78448E+04 16 8 .23981E-15 129 | .82709E+04 16 9 .51017E-15 130 | .87453E+04 16 10 .84716E-15 131 | .92111E+04 16 11 .26504E-15 132 | .95276E+04 16 12 .62734E-14 133 | .94079E+04 16 13 .23956E-16 134 | .83797E+04 16 14 .52050E-16 135 | .26045E+04 16 15 .32324E-16 136 | .89777E+03 16 16 .93027E-14 137 | .62974E+04 17 1 .64452E-18 138 | .63746E+04 17 2 .16330E-17 139 | .64717E+04 17 3 .41373E-17 140 | .65934E+04 17 4 .10473E-16 141 | .67457E+04 17 5 .26437E-16 142 | .69355E+04 17 6 .66333E-16 143 | .71702E+04 17 7 .16437E-15 144 | .74571E+04 17 8 .39721E-15 145 | .78005E+04 17 9 .91214E-15 146 | .81957E+04 17 10 .18703E-14 147 | .86163E+04 17 11 .27805E-14 148 | .89879E+04 17 12 .10164E-14 149 | .91399E+04 17 13 .31464E-13 150 | .87394E+04 17 14 .99699E-16 151 | .46530E+04 17 15 .16628E-15 152 | .26045E+04 17 16 .12930E-15 153 | .89777E+03 17 17 .37211E-13 154 | .62353E+04 18 1 .10144E-17 155 | .62963E+04 18 2 .25664E-17 156 | .63729E+04 18 3 .64932E-17 157 | .64689E+04 18 4 .16420E-16 158 | .65889E+04 18 5 .41451E-16 159 | .67383E+04 18 6 .10424E-15 160 | .69233E+04 18 7 .26010E-15 161 | .71502E+04 18 8 .63902E-15 162 | .74238E+04 18 9 .15230E-14 163 | .77446E+04 18 10 .34111E-14 164 | .81009E+04 18 11 .66225E-14 165 | .84538E+04 18 12 .80571E-14 166 | .87067E+04 18 13 .14531E-13 167 | .86514E+04 18 14 .15797E-12 168 | .59471E+04 18 15 .43757E-15 169 | .46530E+04 18 16 .66514E-15 170 | .26045E+04 18 17 .51718E-15 171 | .89777E+03 18 18 .14884E-12 172 | .61862E+04 19 1 .15990E-17 173 | .62344E+04 19 2 .40399E-17 174 | .62949E+04 19 3 .10207E-16 175 | .63707E+04 19 4 .25778E-16 176 | .64653E+04 19 5 .65025E-16 177 | .65831E+04 19 6 .16359E-15 178 | .67290E+04 19 7 .40939E-15 179 | .69080E+04 19 8 .10140E-14 180 | .71250E+04 19 9 .24632E-14 181 | .73819E+04 19 10 .57602E-14 182 | .76742E+04 19 11 .12448E-13 183 | .79815E+04 19 12 .22162E-13 184 | .82491E+04 19 13 .16782E-13 185 | .83524E+04 19 14 .11086E-12 186 | .66125E+04 19 15 .74054E-15 187 | .59471E+04 19 16 .17503E-14 188 | .46530E+04 19 17 .26605E-14 189 | .26045E+04 19 18 .20687E-14 190 | .89777E+03 19 19 .59537E-12 191 | .61474E+04 20 1 .25237E-17 192 | .61855E+04 20 2 .63686E-17 193 | .62334E+04 20 3 .16070E-16 194 | .62932E+04 20 4 .40531E-16 195 | .63679E+04 20 5 .10213E-15 196 | .64608E+04 20 6 .25681E-15 197 | .65759E+04 20 7 .64322E-15 198 | .67172E+04 20 8 .15993E-14 199 | .68887E+04 20 9 .39232E-14 200 | .70932E+04 20 10 .93844E-14 201 | .73291E+04 20 11 .21369E-13 202 | .75856E+04 20 12 .43759E-13 203 | .78311E+04 20 13 .66840E-13 204 | .79911E+04 20 14 .10713E-13 205 | .68735E+04 20 15 .11602E-11 206 | .66125E+04 20 16 .29622E-14 207 | .59471E+04 20 17 .70011E-14 208 | .46530E+04 20 18 .10642E-13 209 | .26045E+04 20 19 .82749E-14 210 | .89777E+03 20 20 .23815E-11 211 | .61166E+04 21 1 .39874E-17 212 | .61468E+04 21 2 .10052E-16 213 | .61847E+04 21 3 .25336E-16 214 | .62320E+04 21 4 .63825E-16 215 | .62910E+04 21 5 .16063E-15 216 | .63644E+04 21 6 .40356E-15 217 | .64552E+04 21 7 .10106E-14 218 | .65668E+04 21 8 .25167E-14 219 | .67023E+04 21 9 .62045E-14 220 | .68644E+04 21 10 .15023E-13 221 | .70531E+04 21 11 .35177E-13 222 | .72625E+04 21 12 .77047E-13 223 | .74738E+04 21 13 .14464E-12 224 | .76415E+04 21 14 .15745E-12 225 | .69140E+04 21 15 .11169E-11 226 | .68735E+04 21 16 .46407E-11 227 | .66125E+04 21 17 .11849E-13 228 | .59471E+04 21 18 .28004E-13 229 | .46530E+04 21 19 .42569E-13 230 | .26045E+04 21 20 .33100E-13 231 | .89777E+03 21 21 .95259E-11 232 | .60923E+04 22 1 .63057E-17 233 | .61162E+04 22 2 .15883E-16 234 | .61462E+04 22 3 .39994E-16 235 | .61836E+04 22 4 .10064E-15 236 | .62303E+04 22 5 .25301E-15 237 | .62883E+04 22 6 .63500E-15 238 | .63600E+04 22 7 .15893E-14 239 | .64481E+04 22 8 .39589E-14 240 | .65553E+04 22 9 .97833E-14 241 | .66836E+04 22 10 .23847E-13 242 | .68338E+04 22 11 .56717E-13 243 | .70027E+04 22 12 .12881E-12 244 | .71786E+04 22 13 .26572E-12 245 | .73330E+04 22 14 .42537E-12 246 | .68498E+04 22 15 .89024E-12 247 | .69140E+04 22 16 .44676E-11 248 | .68735E+04 22 17 .18563E-10 249 | .66125E+04 22 18 .47395E-13 250 | .59471E+04 22 19 .11202E-12 251 | .46530E+04 22 20 .17027E-12 252 | .26045E+04 22 21 .13240E-12 253 | .89777E+03 22 22 .38104E-10 254 | .60730E+04 23 1 .99792E-17 255 | .60919E+04 23 2 .25119E-16 256 | .61157E+04 23 3 .63198E-16 257 | .61453E+04 23 4 .15889E-15 258 | .61823E+04 23 5 .39905E-15 259 | .62281E+04 23 6 .10005E-14 260 | .62848E+04 23 7 .25021E-14 261 | .63545E+04 23 8 .62312E-14 262 | .64392E+04 23 9 .15414E-13 263 | .65408E+04 23 10 .37706E-13 264 | .66601E+04 23 11 .90492E-13 265 | .67953E+04 23 12 .20986E-12 266 | .69391E+04 23 13 .45531E-12 267 | .70729E+04 23 14 .84882E-12 268 | .67447E+04 23 15 .40983E-12 269 | .68498E+04 23 16 .35609E-11 270 | .69140E+04 23 17 .17870E-10 271 | .68735E+04 23 18 .74252E-10 272 | .66125E+04 23 19 .18958E-12 273 | .59471E+04 23 20 .44807E-12 274 | .46530E+04 23 21 .68110E-12 275 | .26045E+04 23 22 .52960E-12 276 | .89777E+03 23 23 .15241E-09 277 | .60577E+04 24 1 .15802E-16 278 | .60727E+04 24 2 .39754E-16 279 | .60915E+04 24 3 .99952E-16 280 | .61150E+04 24 4 .25110E-15 281 | .61443E+04 24 5 .63010E-15 282 | .61806E+04 24 6 .15784E-14 283 | .62254E+04 24 7 .39441E-14 284 | .62805E+04 24 8 .98172E-14 285 | .63475E+04 24 9 .24290E-13 286 | .64279E+04 24 10 .59531E-13 287 | .65225E+04 24 11 .14363E-12 288 | .66304E+04 24 12 .33730E-12 289 | .67467E+04 24 13 .75371E-12 290 | .68590E+04 24 14 .15191E-11 291 | .66311E+04 24 15 .46273E-12 292 | .67447E+04 24 16 .16393E-11 293 | .68498E+04 24 17 .14244E-10 294 | .69140E+04 24 18 .71481E-10 295 | .68735E+04 24 19 .29701E-09 296 | .66125E+04 24 20 .75832E-12 297 | .59471E+04 24 21 .17923E-11 298 | .46530E+04 24 22 .27244E-11 299 | .26045E+04 24 23 .21184E-11 300 | .89777E+03 24 24 .60966E-09 301 | .77967E+04 25 1 .22946E-14 302 | .78122E+04 25 2 .46275E-14 303 | .78316E+04 25 3 .93513E-14 304 | .78560E+04 25 4 .18945E-13 305 | .78863E+04 25 5 .38501E-13 306 | .79242E+04 25 6 .78539E-13 307 | .79713E+04 25 7 .16094E-12 308 | .80294E+04 25 8 .33158E-12 309 | .81008E+04 25 9 .68743E-12 310 | .81878E+04 25 10 .14353E-11 311 | .82924E+04 25 11 .30201E-11 312 | .84158E+04 25 12 .64043E-11 313 | .85571E+04 25 13 .13675E-10 314 | .87104E+04 25 14 .29316E-10 315 | .86265E+04 25 15 .60102E-10 316 | .88325E+04 25 16 .76923E-13 317 | .90719E+04 25 17 .16378E-12 318 | .93363E+04 25 18 .32973E-12 319 | .95996E+04 25 19 .57859E-12 320 | .98007E+04 25 20 .18485E-08 321 | .98157E+04 25 21 .16727E-08 322 | .94274E+04 25 22 .34267E-08 323 | .83361E+04 25 23 .13144E-10 324 | .63023E+04 25 24 .19019E-10 325 | .57988E+03 25 25 .15762E-08 326 | .69349E+04 26 1 .40614E-14 327 | .69458E+04 26 2 .81766E-14 328 | .69595E+04 26 3 .16489E-13 329 | .69766E+04 26 4 .33318E-13 330 | .69979E+04 26 5 .67494E-13 331 | .70244E+04 26 6 .13714E-12 332 | .70573E+04 26 7 .27968E-12 333 | .70978E+04 26 8 .57289E-12 334 | .71473E+04 26 9 .11795E-11 335 | .72072E+04 26 10 .24428E-11 336 | .72788E+04 26 11 .50921E-11 337 | .73623E+04 26 12 .10686E-10 338 | .74565E+04 26 13 .22563E-10 339 | .75566E+04 26 14 .47841E-10 340 | .74715E+04 26 15 .97722E-10 341 | .76064E+04 26 16 .20983E-09 342 | .77647E+04 26 17 .26524E-12 343 | .79435E+04 26 18 .55820E-12 344 | .81311E+04 26 19 .11029E-11 345 | .82983E+04 26 20 .18658E-11 346 | .83827E+04 26 21 .58100E-08 347 | .82640E+04 26 22 .41061E-08 348 | .77406E+04 26 23 .15502E-07 349 | .65488E+04 26 24 .44953E-10 350 | .15807E+04 26 25 .29331E-10 351 | .51662E+03 26 26 .56170E-08 352 | .61704E+04 27 1 .71981E-14 353 | .61781E+04 27 2 .14472E-13 354 | .61877E+04 27 3 .29135E-13 355 | .61997E+04 27 4 .58750E-13 356 | .62147E+04 27 5 .11870E-12 357 | .62333E+04 27 6 .24042E-12 358 | .62562E+04 27 7 .48841E-12 359 | .62843E+04 27 8 .99569E-12 360 | .63186E+04 27 9 .20383E-11 361 | .63598E+04 27 10 .41928E-11 362 | .64086E+04 27 11 .86706E-11 363 | .64648E+04 27 12 .18031E-10 364 | .65271E+04 27 13 .37693E-10 365 | .65912E+04 27 14 .79097E-10 366 | .65100E+04 27 15 .16076E-09 367 | .65961E+04 27 16 .34204E-09 368 | .66976E+04 27 17 .73034E-09 369 | .68135E+04 27 18 .90966E-12 370 | .69382E+04 27 19 .18874E-11 371 | .70574E+04 27 20 .36418E-11 372 | .71390E+04 27 21 .12167E-07 373 | .71194E+04 27 22 .17595E-07 374 | .68816E+04 27 23 .72145E-08 375 | .62379E+04 27 24 .68406E-07 376 | .26526E+04 27 25 .12639E-09 377 | .14083E+04 27 26 .10452E-09 378 | .46025E+03 27 27 .20017E-07 379 | .54916E+04 28 1 .12771E-13 380 | .54971E+04 28 2 .25650E-13 381 | .55038E+04 28 3 .51568E-13 382 | .55123E+04 28 4 .10381E-12 383 | .55228E+04 28 5 .20931E-12 384 | .55357E+04 28 6 .42286E-12 385 | .55517E+04 28 7 .85630E-12 386 | .55712E+04 28 8 .17389E-11 387 | .55949E+04 28 9 .35432E-11 388 | .56232E+04 28 10 .72475E-11 389 | .56562E+04 28 11 .14888E-10 390 | .56938E+04 28 12 .30723E-10 391 | .57345E+04 28 13 .63674E-10 392 | .57747E+04 28 14 .13238E-09 393 | .57001E+04 28 15 .26765E-09 394 | .57533E+04 28 16 .56391E-09 395 | .58161E+04 28 17 .11941E-08 396 | .58880E+04 28 18 .25330E-08 397 | .59661E+04 28 19 .53468E-08 398 | .60426E+04 28 20 .63186E-11 399 | .61008E+04 28 21 .21903E-07 400 | .61062E+04 28 22 .38739E-07 401 | .59940E+04 28 23 .50266E-07 402 | .56500E+04 28 24 .39631E-08 403 | .31742E+04 28 25 .28831E-09 404 | .23632E+04 28 26 .45042E-09 405 | .12546E+04 28 27 .37248E-09 406 | .41004E+03 28 28 .71332E-07 407 | .48886E+04 29 1 .22680E-13 408 | .48924E+04 29 2 .45510E-13 409 | .48971E+04 29 3 .91398E-13 410 | .49031E+04 29 4 .18375E-12 411 | .49104E+04 29 5 .36987E-12 412 | .49195E+04 29 6 .74567E-12 413 | .49306E+04 29 7 .15062E-11 414 | .49441E+04 29 8 .30491E-11 415 | .49604E+04 29 9 .61891E-11 416 | .49797E+04 29 10 .12601E-10 417 | .50020E+04 29 11 .25745E-10 418 | .50269E+04 29 12 .52788E-10 419 | .50530E+04 29 13 .10860E-09 420 | .50774E+04 29 14 .22398E-09 421 | .50108E+04 29 15 .45069E-09 422 | .50422E+04 29 16 .94066E-09 423 | .50792E+04 29 17 .19737E-08 424 | .51212E+04 29 18 .41560E-08 425 | .51667E+04 29 19 .87483E-08 426 | .52111E+04 29 20 .18263E-07 427 | .52447E+04 29 21 .37207E-07 428 | .52486E+04 29 22 .71527E-07 429 | .51861E+04 29 23 .11958E-06 430 | .49913E+04 29 24 .12938E-06 431 | .32935E+04 29 25 .41820E-09 432 | .28279E+04 29 26 .10274E-08 433 | .21054E+04 29 27 .16051E-08 434 | .11177E+04 29 28 .13274E-08 435 | .36530E+03 29 29 .25420E-06 436 | .43524E+04 30 1 .40303E-13 437 | .43551E+04 30 2 .80818E-13 438 | .43585E+04 30 3 .16217E-12 439 | .43626E+04 30 4 .32567E-12 440 | .43678E+04 30 5 .65468E-12 441 | .43741E+04 30 6 .13177E-11 442 | .43818E+04 30 7 .26561E-11 443 | .43912E+04 30 8 .53635E-11 444 | .44024E+04 30 9 .10854E-10 445 | .44155E+04 30 10 .22016E-10 446 | .44304E+04 30 11 .44779E-10 447 | .44467E+04 30 12 .91332E-10 448 | .44631E+04 30 13 .18676E-09 449 | .44771E+04 30 14 .38257E-09 450 | .44188E+04 30 15 .76664E-09 451 | .44361E+04 30 16 .15866E-08 452 | .44561E+04 30 17 .32995E-08 453 | .44786E+04 30 18 .68899E-08 454 | .45022E+04 30 19 .14413E-07 455 | .45241E+04 30 20 .30062E-07 456 | .45384E+04 30 21 .61915E-07 457 | .45339E+04 30 22 .12351E-06 458 | .44893E+04 30 23 .22879E-06 459 | .43663E+04 30 24 .35225E-06 460 | .31847E+04 30 25 .28071E-06 461 | .29342E+04 30 26 .14903E-08 462 | .25193E+04 30 27 .36613E-08 463 | .18757E+04 30 28 .57200E-08 464 | .99579E+03 30 29 .47303E-08 465 | .32545E+03 30 30 .90586E-06 466 | .38756E+04 31 1 .71658E-13 467 | .38775E+04 31 2 .14362E-12 468 | .38799E+04 31 3 .28798E-12 469 | .38828E+04 31 4 .57784E-12 470 | .38864E+04 31 5 .11604E-11 471 | .38908E+04 31 6 .23324E-11 472 | .38961E+04 31 7 .46938E-11 473 | .39026E+04 31 8 .94593E-11 474 | .39102E+04 31 9 .19094E-10 475 | .39191E+04 31 10 .38616E-10 476 | .39290E+04 31 11 .78259E-10 477 | .39395E+04 31 12 .15893E-09 478 | .39494E+04 31 13 .32339E-09 479 | .39568E+04 31 14 .65874E-09 480 | .39066E+04 31 15 .13156E-08 481 | .39149E+04 31 16 .27027E-08 482 | .39241E+04 31 17 .55758E-08 483 | .39340E+04 31 18 .11548E-07 484 | .39435E+04 31 19 .23979E-07 485 | .39507E+04 31 20 .49775E-07 486 | .39516E+04 31 21 .10267E-06 487 | .39392E+04 31 22 .20798E-06 488 | .39006E+04 31 23 .40380E-06 489 | .38129E+04 31 24 .71088E-06 490 | .29707E+04 31 25 .13440E-06 491 | .28372E+04 31 26 .10003E-05 492 | .26141E+04 31 27 .53108E-08 493 | .22445E+04 31 28 .13047E-07 494 | .16710E+04 31 29 .20384E-07 495 | .88715E+03 31 30 .16857E-07 496 | .28994E+03 31 31 .32281E-05 497 | .30106E+04 32 1 .16714E-15 498 | .30118E+04 32 2 .33478E-15 499 | .30132E+04 32 3 .67084E-15 500 | .30149E+04 32 4 .13449E-14 501 | .30171E+04 32 5 .26978E-14 502 | .30197E+04 32 6 .54157E-14 503 | .30229E+04 32 7 .10882E-13 504 | .30266E+04 32 8 .21888E-13 505 | .30309E+04 32 9 .44087E-13 506 | .30357E+04 32 10 .88941E-13 507 | .30408E+04 32 11 .17976E-12 508 | .30456E+04 32 12 .36411E-12 509 | .30491E+04 32 13 .73920E-12 510 | .30494E+04 32 14 .15042E-11 511 | .30032E+04 32 15 .30385E-11 512 | .30013E+04 32 16 .62367E-11 513 | .29981E+04 32 17 .12869E-10 514 | .29929E+04 32 18 .26709E-10 515 | .29844E+04 32 19 .55774E-10 516 | .29706E+04 32 20 .11715E-09 517 | .29480E+04 32 21 .24720E-09 518 | .29111E+04 32 22 .52221E-09 519 | .28504E+04 32 23 .10970E-08 520 | .27503E+04 32 24 .22610E-08 521 | .20956E+04 32 25 .36770E-08 522 | .19717E+04 32 26 .69287E-08 523 | .17926E+04 32 27 .11462E-07 524 | .15245E+04 32 28 .14570E-07 525 | .11243E+04 32 29 .10669E-07 526 | .55892E+03 32 30 .34365E-08 527 | .22135E+03 32 31 .12194E-04 528 | 0.00000E+00 32 32 0.00000E+00 529 | .23888E+04 33 1 .26499E-15 530 | .23895E+04 33 2 .53062E-15 531 | .23903E+04 33 3 .10628E-14 532 | .23914E+04 33 4 .21297E-14 533 | .23927E+04 33 5 .42694E-14 534 | .23943E+04 33 6 .85638E-14 535 | .23962E+04 33 7 .17190E-13 536 | .23983E+04 33 8 .34535E-13 537 | .24007E+04 33 9 .69451E-13 538 | .24033E+04 33 10 .13984E-12 539 | .24057E+04 33 11 .28197E-12 540 | .24075E+04 33 12 .56942E-12 541 | .24077E+04 33 13 .11518E-11 542 | .24049E+04 33 14 .23332E-11 543 | .23645E+04 33 15 .46879E-11 544 | .23582E+04 33 16 .95590E-11 545 | .23497E+04 33 17 .19570E-10 546 | .23382E+04 33 18 .40244E-10 547 | .23225E+04 33 19 .83154E-10 548 | .23007E+04 33 20 .17262E-09 549 | .22699E+04 33 21 .35970E-09 550 | .22258E+04 33 22 .75068E-09 551 | .21613E+04 33 23 .15615E-08 552 | .20655E+04 33 24 .32074E-08 553 | .15572E+04 33 25 .52764E-08 554 | .14495E+04 33 26 .10318E-07 555 | .13057E+04 33 27 .18719E-07 556 | .11057E+04 33 28 .29250E-07 557 | .82055E+03 33 29 .34130E-07 558 | .41732E+03 33 30 .24528E-07 559 | .17636E+03 33 31 .19000E-04 560 | 0.00000E+00 33 32 0.00000E+00 561 | 0.00000E+00 33 33 0.00000E+00 562 | .18955E+04 34 1 .42024E-15 563 | .18959E+04 34 2 .84127E-15 564 | .18964E+04 34 3 .16845E-14 565 | .18971E+04 34 4 .33741E-14 566 | .18979E+04 34 5 .67607E-14 567 | .18988E+04 34 6 .13552E-13 568 | .18999E+04 34 7 .27182E-13 569 | .19011E+04 34 8 .54555E-13 570 | .19024E+04 34 9 .10958E-12 571 | .19036E+04 34 10 .22030E-12 572 | .19045E+04 34 11 .44333E-12 573 | .19047E+04 34 12 .89315E-12 574 | .19033E+04 34 13 .18012E-11 575 | .18990E+04 34 14 .36355E-11 576 | .18647E+04 34 15 .72724E-11 577 | .18567E+04 34 16 .14749E-10 578 | .18462E+04 34 17 .29997E-10 579 | .18326E+04 34 18 .61207E-10 580 | .18145E+04 34 19 .12532E-09 581 | .17905E+04 34 20 .25743E-09 582 | .17581E+04 34 21 .53022E-09 583 | .17138E+04 34 22 .10930E-08 584 | .16525E+04 34 23 .22468E-08 585 | .15662E+04 34 24 .45719E-08 586 | .11695E+04 34 25 .75105E-08 587 | .10771E+04 34 26 .14833E-07 588 | .95995E+03 34 27 .27924E-07 589 | .80547E+03 34 28 .47749E-07 590 | .59516E+03 34 29 .67416E-07 591 | .30433E+03 34 30 .65143E-07 592 | .13287E+03 34 31 .28252E-04 593 | 0.00000E+00 34 32 0.00000E+00 594 | 0.00000E+00 34 33 0.00000E+00 595 | 0.00000E+00 34 34 0.00000E+00 596 | .15041E+04 35 1 .66657E-15 597 | .15044E+04 35 2 .13341E-14 598 | .15047E+04 35 3 .26708E-14 599 | .15051E+04 35 4 .53478E-14 600 | .15056E+04 35 5 .10711E-13 601 | .15061E+04 35 6 .21461E-13 602 | .15067E+04 35 7 .43017E-13 603 | .15074E+04 35 8 .86267E-13 604 | .15080E+04 35 9 .17310E-12 605 | .15084E+04 35 10 .34758E-12 606 | .15085E+04 35 11 .69840E-12 607 | .15079E+04 35 12 .14043E-11 608 | .15058E+04 35 13 .28253E-11 609 | .15011E+04 35 14 .56855E-11 610 | .14725E+04 35 15 .11333E-10 611 | .14642E+04 35 16 .22881E-10 612 | .14536E+04 35 17 .46285E-10 613 | .14399E+04 35 18 .93829E-10 614 | .14221E+04 35 19 .19063E-09 615 | .13988E+04 35 20 .38806E-09 616 | .13682E+04 35 21 .79104E-09 617 | .13274E+04 35 22 .16121E-08 618 | .12725E+04 35 23 .32742E-08 619 | .11976E+04 35 24 .65870E-08 620 | .88682E+03 35 25 .10744E-07 621 | .80897E+03 35 26 .21158E-07 622 | .71340E+03 35 27 .40252E-07 623 | .59221E+03 35 28 .71430E-07 624 | .43360E+03 35 29 .10997E-06 625 | .22074E+03 35 30 .12335E-06 626 | .97241E+02 35 31 .41130E-04 627 | 0.00000E+00 35 32 0.00000E+00 628 | 0.00000E+00 35 33 0.00000E+00 629 | 0.00000E+00 35 34 0.00000E+00 630 | 0.00000E+00 35 35 0.00000E+00 631 | .11936E+04 36 1 .10575E-14 632 | .11938E+04 36 2 .21162E-14 633 | .11940E+04 36 3 .42355E-14 634 | .11942E+04 36 4 .84787E-14 635 | .11945E+04 36 5 .16977E-13 636 | .11948E+04 36 6 .34001E-13 637 | .11951E+04 36 7 .68119E-13 638 | .11954E+04 36 8 .13652E-12 639 | .11957E+04 36 9 .27373E-12 640 | .11957E+04 36 10 .54908E-12 641 | .11954E+04 36 11 .11019E-11 642 | .11943E+04 36 12 .22122E-11 643 | .11921E+04 36 13 .44422E-11 644 | .11876E+04 36 14 .89180E-11 645 | .11640E+04 36 15 .17724E-10 646 | .11563E+04 36 16 .35656E-10 647 | .11464E+04 36 17 .71810E-10 648 | .11337E+04 36 18 .14479E-09 649 | .11174E+04 36 19 .29227E-09 650 | .10963E+04 36 20 .59043E-09 651 | .10689E+04 36 21 .11928E-08 652 | .10330E+04 36 22 .24064E-08 653 | .98554E+03 36 23 .48332E-08 654 | .92214E+03 36 24 .96116E-08 655 | .67808E+03 36 25 .15536E-07 656 | .61344E+03 36 26 .30338E-07 657 | .53582E+03 36 27 .57603E-07 658 | .44015E+03 36 28 .10342E-06 659 | .31885E+03 36 29 .16540E-06 660 | .16089E+03 36 30 .20078E-06 661 | .70536E+02 36 31 .59652E-04 662 | 0.00000E+00 36 32 0.00000E+00 663 | 0.00000E+00 36 33 0.00000E+00 664 | 0.00000E+00 36 34 0.00000E+00 665 | 0.00000E+00 36 35 0.00000E+00 666 | 0.00000E+00 36 36 0.00000E+00 667 | -------------------------------------------------------------------------------- /pumas_stochastic_collect_tau.F90: -------------------------------------------------------------------------------- 1 | module pumas_stochastic_collect_tau 2 | ! From Morrison (Lebo, originally TAU bin code) 3 | ! Gettelman and Chen 2018 4 | !the subroutines take in air density, air temperature, and the bin mass boundaries, and 5 | !output the mass and number mixing ratio tendencies in each bin directly. 6 | !this is then wrapped for CAM. 7 | 8 | ! note, this is now coded locally. Want the CAM interface to be over i,k I think. 9 | 10 | #ifndef HAVE_GAMMA_INTRINSICS 11 | use pumas_gamma_function, only: gamma=>pumas_gamma 12 | #endif 13 | 14 | use pumas_kinds, only: r8=>kind_r8 15 | use micro_pumas_utils, only: pi, rhow, qsmall, VLENS 16 | 17 | implicit none 18 | private 19 | save 20 | 21 | ! Subroutines 22 | public :: pumas_stochastic_kernel_init, pumas_stochastic_collect_tau_tend 23 | 24 | !In the module top, declare the following so that these can be used throughout the module: 25 | 26 | integer, parameter, public :: ncd = 35 27 | integer, parameter, public :: ncdp = ncd + 1 28 | integer, parameter, public :: ncdl = ncd 29 | integer, parameter, public :: ncdpl = ncdl+1 30 | 31 | ! for Zach's collision-coalescence code 32 | 33 | real(r8), private :: knn(ncd,ncd) 34 | 35 | real(r8), private :: mmean(ncd), diammean(ncd) ! kg & m at bin mid-points 36 | real(r8), private :: medge(ncdp), diamedge(ncdp) ! kg & m at bin edges 37 | integer, private :: cutoff_id ! cutoff between cloud water and rain drop, D = 40 microns 38 | 39 | ! Assume 6 microns for each... 40 | real(r8), parameter :: m1 = 4._r8/3._r8*pi*rhow*(6.e-6_r8)**3 41 | 42 | !$acc declare create(knn,cutoff_id,mmean,diammean,medge,diamedge) 43 | 44 | !=============================================================================== 45 | contains 46 | !=============================================================================== 47 | 48 | subroutine calc_bins 49 | 50 | real(r8) :: DIAM(ncdp) 51 | real(r8) :: X(ncdp) 52 | real(r8) :: radsl(ncdp) 53 | real(r8) :: radl(ncd) 54 | integer :: L, lcl 55 | real(r8) :: kkfac 56 | 57 | !Then before doing any calculations you'll need to calculate the bin mass grid 58 | ! (note this code could be cleaned up, I'm just taking it as it's used in our bin scheme). 59 | ! This only needs to be done once, since we'll use the same bin mass grid for all calculations. 60 | 61 | ! use mass doubling bins from Graham Feingold (note cgs units) 62 | 63 | DIAM(1)=1.5625*2.E-04_r8 ! cm 64 | X(1)=PI/6._r8*DIAM(1)**3*rhow/1000._r8 ! rhow kg/m3 --> g/cm3 65 | radsl(1) = X(1) ! grams 66 | 67 | DO l=2,ncdp 68 | X(l)=2._r8*X(l-1) 69 | DIAM(l)=(6._r8/pi*X(l)*1000._r8/rhow)**(1._r8/3._r8) ! cm 70 | radsl(l)=X(l) 71 | ENDDO 72 | 73 | ! now get bin mid-points 74 | 75 | do l=1,ncd 76 | radl(l)=(radsl(l)+radsl(l+1))/2._r8 ! grams 77 | diammean(l) = (6._r8/pi*radl(l)*1000._r8/rhow)**(1._r8/3._r8) ! cm 78 | end do 79 | 80 | ! set bin grid for method of moments 81 | 82 | ! for method of moments 83 | 84 | do lcl = 1,ncd+1 85 | medge(lcl) = radsl(lcl) ! grams 86 | diamedge(lcl) = DIAM(lcl) ! cm 87 | enddo 88 | 89 | do lcl = 1,ncd 90 | mmean(lcl) = radl(lcl) 91 | diammean(lcl) = diammean(lcl) 92 | enddo 93 | 94 | do lcl = ncdp,1,-1 95 | if( diamedge(lcl).ge.40.e-4_r8 ) cutoff_id = lcl 96 | end do 97 | 98 | end subroutine calc_bins 99 | 100 | subroutine pumas_stochastic_kernel_init(kernel_filename) 101 | 102 | character(len=*), intent(in) :: kernel_filename ! Full pathname to kernel file 103 | 104 | integer :: iunit ! unit number of opened file for collection kernel code from a lookup table. 105 | 106 | integer :: idd, jdd 107 | real(r8) :: kkfac 108 | 109 | call calc_bins 110 | 111 | ! Read in the collection kernel code from a lookup table. Again, this only needs to be done once. 112 | ! use kernel from Zach (who got it from Jerry) 113 | 114 | KNN(:,:)=0._r8 ! initialize values 115 | kkfac=1.5_r8 ! from Zach 116 | 117 | open(newunit=iunit,file=kernel_filename,status='old') 118 | 119 | do idd=1,ncd 120 | do jdd=1,idd 121 | READ(iunit,941) KNN(IDD,JDD) 122 | 941 FORMAT(2X,E12.5) 123 | 124 | KNN(IDD,JDD)=(mmean(IDD)*kkfac+mmean(JDD)*kkfac)*KNN(IDD,JDD) 125 | if (knn(idd,jdd) < 0._r8) knn(idd,jdd)=0._r8 126 | end do 127 | end do 128 | 129 | !$acc update device(knn,cutoff_id,mmean,diammean,medge,diamedge) 130 | 131 | end subroutine pumas_stochastic_kernel_init 132 | 133 | !main driver routine 134 | !needs to pull in i,k fields (so might need dimensions here too) 135 | 136 | subroutine pumas_stochastic_collect_tau_tend(deltatin,t,rho,qc,qr,qcin, & 137 | ncin,qrin,nrin,lcldm,precip_frac,mu_c,lambda_c, & 138 | n0r,lambda_r,qcin_new,ncin_new,qrin_new,nrin_new, & 139 | qctend,nctend,qrtend,nrtend,qctend_TAU,nctend_TAU, & 140 | qrtend_TAU,nrtend_TAU,scale_qc,scale_nc,scale_qr, & 141 | scale_nr,amk_c,ank_c,amk_r,ank_r,amk,ank,amk_out, & 142 | ank_out,gmnnn_lmnnn_TAU,mgncol,nlev) 143 | 144 | !inputs: mgncol,nlev,t,rho,qcin,ncin,qrin,nrin 145 | !outputs: qctend,nctend,qrtend,nrtend 146 | !not sure if we want to output bins (extra dimension). Good for testing? 147 | 148 | integer, intent(in) :: mgncol,nlev 149 | real(r8), intent(in) :: deltatin 150 | real(r8), intent(in) :: t(mgncol,nlev) 151 | real(r8), intent(in) :: rho(mgncol,nlev) 152 | real(r8), intent(in) :: qc(mgncol,nlev) 153 | real(r8), intent(in) :: qr(mgncol,nlev) 154 | real(r8), intent(in) :: qcin(mgncol,nlev) 155 | real(r8), intent(in) :: ncin(mgncol,nlev) 156 | real(r8), intent(in) :: qrin(mgncol,nlev) 157 | real(r8), intent(in) :: nrin(mgncol,nlev) 158 | real(r8), intent(in) :: lcldm(mgncol,nlev) 159 | real(r8), intent(in) :: precip_frac(mgncol,nlev) 160 | real(r8), intent(inout) :: qctend(mgncol,nlev) 161 | real(r8), intent(inout) :: nctend(mgncol,nlev) 162 | real(r8), intent(inout) :: qrtend(mgncol,nlev) 163 | real(r8), intent(inout) :: nrtend(mgncol,nlev) 164 | real(r8), intent(out) :: qctend_TAU(mgncol,nlev) 165 | real(r8), intent(out) :: nctend_TAU(mgncol,nlev) 166 | real(r8), intent(out) :: qrtend_TAU(mgncol,nlev) 167 | real(r8), intent(out) :: nrtend_TAU(mgncol,nlev) 168 | 169 | real(r8), intent(out) :: scale_qc(mgncol,nlev) 170 | real(r8), intent(out) :: scale_nc(mgncol,nlev) 171 | real(r8), intent(out) :: scale_qr(mgncol,nlev) 172 | real(r8), intent(out) :: scale_nr(mgncol,nlev) 173 | 174 | real(r8), intent(out) :: amk_c(mgncol,nlev,ncd) 175 | real(r8), intent(out) :: ank_c(mgncol,nlev,ncd) 176 | real(r8), intent(out) :: amk_r(mgncol,nlev,ncd) 177 | real(r8), intent(out) :: ank_r(mgncol,nlev,ncd) 178 | real(r8), intent(out) :: amk(mgncol,nlev,ncd) 179 | real(r8), intent(out) :: ank(mgncol,nlev,ncd) 180 | real(r8), intent(out) :: amk_out(mgncol,nlev,ncd) 181 | real(r8), intent(out) :: ank_out(mgncol,nlev,ncd) 182 | 183 | real(r8), intent(out) :: mu_c(mgncol,nlev) 184 | real(r8), intent(out) :: lambda_c(mgncol,nlev) 185 | real(r8), intent(out) :: lambda_r(mgncol,nlev) 186 | real(r8), intent(out) :: n0r(mgncol,nlev) 187 | 188 | real(r8), intent(out) :: qcin_new(mgncol,nlev) 189 | real(r8), intent(out) :: ncin_new(mgncol,nlev) 190 | real(r8), intent(out) :: qrin_new(mgncol,nlev) 191 | real(r8), intent(out) :: nrin_new(mgncol,nlev) 192 | real(r8), intent(out) :: gmnnn_lmnnn_TAU(mgncol,nlev) 193 | 194 | ! Local variables 195 | 196 | integer :: i,k,n,lcl 197 | integer :: cutoff_amk(mgncol,nlev),cutoff(mgncol,nlev) 198 | 199 | real(r8) :: all_gmnnn,all_lmnnn 200 | real(r8) :: qscl 201 | 202 | real(r8) :: qcin_old(mgncol,nlev) 203 | real(r8) :: ncin_old(mgncol,nlev) 204 | real(r8) :: qrin_old(mgncol,nlev) 205 | real(r8) :: nrin_old(mgncol,nlev) 206 | 207 | real(r8) :: amk0(mgncol,nlev,ncd) 208 | real(r8) :: ank0(mgncol,nlev,ncd) 209 | real(r8) :: gnnnn(mgncol,nlev,ncd) 210 | real(r8) :: gmnnn(mgncol,nlev,ncd) 211 | real(r8) :: lnnnn(mgncol,nlev,ncd) 212 | real(r8) :: lmnnn(mgncol,nlev,ncd) 213 | real(r8) :: gnnnn0(mgncol,nlev,ncd) 214 | real(r8) :: gmnnn0(mgncol,nlev,ncd) 215 | real(r8) :: lnnnn0(mgncol,nlev,ncd) 216 | real(r8) :: lmnnn0(mgncol,nlev,ncd) 217 | 218 | integer, parameter :: sub_step = 60 219 | 220 | !$acc data create (cutoff_amk,cutoff,qcin_old,ncin_old,qrin_old, & 221 | !$acc nrin_old,amk0,ank0,gnnnn,gmnnn,lnnnn,lmnnn, & 222 | !$acc gnnnn0,gmnnn0,lnnnn0,lmnnn0) 223 | 224 | !$acc parallel vector_length(VLENS) default(present) 225 | !$acc loop gang vector collapse(2) 226 | do k=1,nlev 227 | do i=1,mgncol 228 | cutoff(i,k) = cutoff_id - 1 229 | end do 230 | end do 231 | !$acc end parallel 232 | 233 | ! First make bins from cam size distribution (bins are diagnostic) 234 | 235 | call cam_bin_distribute(qc,qr,qcin,ncin,qrin,nrin,mu_c,lambda_c, & 236 | lambda_r,n0r,lcldm,precip_frac,scale_qc, & 237 | scale_nc,scale_qr,scale_nr,amk_c,ank_c, & 238 | amk_r,ank_r,amk,ank,cutoff_amk,mgncol,nlev) 239 | 240 | !$acc parallel vector_length(VLENS) default(present) 241 | !$acc loop gang vector collapse(2) 242 | do k=1,nlev 243 | do i=1,mgncol 244 | if ( cutoff_amk(i,k) > 0 ) then 245 | cutoff(i,k) = cutoff_amk(i,k) 246 | end if 247 | end do 248 | end do 249 | !$acc end parallel 250 | 251 | !Then call the subroutines that actually do the calculations. The inputs/ouputs are described in comments below. 252 | 253 | !This part of the code needs to be called each time for each process rate calculation 254 | ! (i.e., for each sampled cloud/rain gamma distribution): 255 | 256 | ! note: variables passed to compute_column_params are all inputs, 257 | ! outputs from this subroutine are stored as global variables 258 | 259 | ! inputs: t --> input air temperature (K) 260 | ! rho --> input air density (kg/m^3) 261 | ! medge --> bin mass boundary (g) 262 | ! amk --> array of bin mass mixing ratio, i.e., the input drop mass distribution (kg/kg) 263 | ! ank --> array of bin number mixing ratio, i.e., the input drop number distribution (kg^-1) 264 | 265 | ! inputs: medge --> bin mass boundary (g), same as above 266 | 267 | ! outputs: gnnnn --> bin number mass mixing tendency gain, array in bins (#/cm^3/s) 268 | ! lnnnn --> bin number mass mixing tendency loss, array in bins (#/cm^3/s) 269 | ! gmnnn --> bin mass mixing ratio tendency gain, array in bins (g/cm^3/s) 270 | ! lmnnn --> bin mass mixing ratio tendency loss, array in bins (g/cm^3/s) 271 | 272 | 273 | ! Call Kernel 274 | 275 | !$acc parallel vector_length(VLENS) default(present) 276 | !$acc loop gang vector collapse(2) 277 | do k=1,nlev 278 | do i=1,mgncol 279 | qcin_new(i,k) = 0._r8 280 | ncin_new(i,k) = 0._r8 281 | qrin_new(i,k) = 0._r8 282 | nrin_new(i,k) = 0._r8 283 | 284 | qcin_old(i,k) = 0._r8 285 | ncin_old(i,k) = 0._r8 286 | qrin_old(i,k) = 0._r8 287 | nrin_old(i,k) = 0._r8 288 | 289 | qctend_TAU(i,k) = 0._r8 290 | nctend_TAU(i,k) = 0._r8 291 | qrtend_TAU(i,k) = 0._r8 292 | nrtend_TAU(i,k) = 0._r8 293 | end do 294 | end do 295 | !$acc end parallel 296 | 297 | !$acc parallel vector_length(VLENS) default(present) 298 | !$acc loop gang vector collapse(3) 299 | do lcl=1,ncd 300 | do k=1,nlev 301 | do i=1,mgncol 302 | gnnnn(i,k,lcl) = 0._r8 303 | gmnnn(i,k,lcl) = 0._r8 304 | lnnnn(i,k,lcl) = 0._r8 305 | lmnnn(i,k,lcl) = 0._r8 306 | end do 307 | end do 308 | end do 309 | !$acc end parallel 310 | 311 | ! update qc, nc, qr, nr 312 | 313 | !$acc parallel vector_length(VLENS) default(present) 314 | !$acc loop gang vector collapse(2) 315 | do k=1,nlev 316 | do i=1,mgncol 317 | !$acc loop seq 318 | do lcl=1,ncd 319 | amk0(i,k,lcl) = amk(i,k,lcl) 320 | ank0(i,k,lcl) = ank(i,k,lcl) 321 | end do 322 | ! substep bin code 323 | !$acc loop seq 324 | do n=1,sub_step 325 | call compute_coll_params(rho(i,k),medge,amk0(i,k,1:ncd),ank0(i,k,1:ncd),gnnnn0(i,k,1:ncd),gmnnn0(i,k,1:ncd),lnnnn0(i,k,1:ncd),lmnnn0(i,k,1:ncd)) 326 | 327 | all_gmnnn=0._r8 328 | all_lmnnn=0._r8 329 | !scaling gmnnn, lmnnn 330 | !$acc loop seq 331 | do lcl=1,ncd 332 | all_gmnnn = all_gmnnn+gmnnn0(i,k,lcl) 333 | all_lmnnn = all_lmnnn+lmnnn0(i,k,lcl) 334 | end do 335 | 336 | if ( (all_gmnnn == 0._r8) .or. (all_lmnnn == 0._r8) ) then 337 | !$acc loop seq 338 | do lcl=1,ncd 339 | gmnnn0(i,k,lcl) = 0._r8 340 | lmnnn0(i,k,lcl) = 0._r8 341 | end do 342 | else 343 | !$acc loop seq 344 | do lcl=1,ncd 345 | lmnnn0(i,k,lcl) = lmnnn0(i,k,lcl)*(all_gmnnn/all_lmnnn) 346 | end do 347 | end if 348 | 349 | !$acc loop seq 350 | do lcl=1,ncd 351 | amk0(i,k,lcl) = amk0(i,k,lcl)+(gmnnn0(i,k,lcl)-lmnnn0(i,k,lcl))*1.e3_r8/ & 352 | rho(i,k)*deltatin/dble(sub_step) 353 | ank0(i,k,lcl) = ank0(i,k,lcl)+(gnnnn0(i,k,lcl)-lnnnn0(i,k,lcl))*1.e6_r8/ & 354 | rho(i,k)*deltatin/dble(sub_step) 355 | gmnnn(i,k,lcl) = gmnnn(i,k,lcl)+gmnnn0(i,k,lcl)/sub_step 356 | gnnnn(i,k,lcl) = gnnnn(i,k,lcl)+gnnnn0(i,k,lcl)/sub_step 357 | lmnnn(i,k,lcl) = lmnnn(i,k,lcl)+lmnnn0(i,k,lcl)/sub_step 358 | lnnnn(i,k,lcl) = lnnnn(i,k,lcl)+lnnnn0(i,k,lcl)/sub_step 359 | end do 360 | end do ! end of loop "sub_step" 361 | 362 | ! cloud water 363 | !$acc loop seq 364 | do lcl=1,cutoff(i,k) 365 | qcin_old(i,k) = qcin_old(i,k)+amk(i,k,lcl) 366 | ncin_old(i,k) = ncin_old(i,k)+ank(i,k,lcl) 367 | qcin_new(i,k) = qcin_new(i,k)+(gmnnn(i,k,lcl)-lmnnn(i,k,lcl))*1.e3_r8/rho(i,k)*deltatin 368 | ncin_new(i,k) = ncin_new(i,k)+(gnnnn(i,k,lcl)-lnnnn(i,k,lcl))*1.e6_r8/rho(i,k)*deltatin 369 | qctend_TAU(i,k) = qctend_TAU(i,k)+(amk0(i,k,lcl)-amk(i,k,lcl))/deltatin 370 | nctend_TAU(i,k) = nctend_TAU(i,k)+(ank0(i,k,lcl)-ank(i,k,lcl))/deltatin 371 | gmnnn_lmnnn_TAU(i,k) = gmnnn_lmnnn_TAU(i,k)+gmnnn(i,k,lcl)-lmnnn(i,k,lcl) 372 | end do 373 | 374 | ! rain 375 | !$acc loop seq 376 | do lcl=cutoff(i,k)+1,ncd 377 | qrin_old(i,k) = qrin_old(i,k)+amk(i,k,lcl) 378 | nrin_old(i,k) = nrin_old(i,k)+ank(i,k,lcl) 379 | qrin_new(i,k) = qrin_new(i,k)+(gmnnn(i,k,lcl)-lmnnn(i,k,lcl))*1.e3_r8/rho(i,k)*deltatin 380 | nrin_new(i,k) = nrin_new(i,k)+(gnnnn(i,k,lcl)-lnnnn(i,k,lcl))*1.e6_r8/rho(i,k)*deltatin 381 | qrtend_TAU(i,k) = qrtend_TAU(i,k)+(amk0(i,k,lcl)-amk(i,k,lcl))/deltatin 382 | nrtend_TAU(i,k) = nrtend_TAU(i,k)+(ank0(i,k,lcl)-ank(i,k,lcl))/deltatin 383 | gmnnn_lmnnn_TAU(i,k) = gmnnn_lmnnn_TAU(i,k)+gmnnn(i,k,lcl)-lmnnn(i,k,lcl) 384 | end do 385 | 386 | !$acc loop seq 387 | do lcl=1,ncd 388 | amk_out(i,k,lcl) = amk(i,k,lcl) + (gmnnn(i,k,lcl)-lmnnn(i,k,lcl))*1.e3_r8/rho(i,k)*deltatin 389 | ank_out(i,k,lcl) = ank(i,k,lcl) + (gnnnn(i,k,lcl)-lnnnn(i,k,lcl))*1.e6_r8/rho(i,k)*deltatin 390 | end do 391 | 392 | qcin_new(i,k) = qcin_new(i,k)+qcin_old(i,k) 393 | ncin_new(i,k) = ncin_new(i,k)+ncin_old(i,k) 394 | qrin_new(i,k) = qrin_new(i,k)+qrin_old(i,k) 395 | nrin_new(i,k) = nrin_new(i,k)+nrin_old(i,k) 396 | end do 397 | end do 398 | !$acc end parallel 399 | 400 | ! Conservation checks 401 | ! AG: Added May 2023 402 | 403 | !$acc parallel vector_length(VLENS) default(present) 404 | !$acc loop gang vector collapse(2) 405 | do k=1,nlev 406 | do i=1,mgncol 407 | 408 | ! First make sure all not negative 409 | qcin_new(i,k)=max(qcin_new(i,k),0._r8) 410 | ncin_new(i,k)=max(ncin_new(i,k),0._r8) 411 | qrin_new(i,k)=max(qrin_new(i,k),0._r8) 412 | nrin_new(i,k)=max(nrin_new(i,k),0._r8) 413 | 414 | ! Now adjust so that sign is correct. qc_new,nc_new <= input, qr_new >= input 415 | ! NOte that due to self collection nr can be larger or smaller than input.... 416 | ! Makes above check redundant I think. 417 | 418 | qcin_new(i,k)=min(qcin_new(i,k),qcin(i,k)) 419 | ncin_new(i,k)=min(ncin_new(i,k),ncin(i,k)) 420 | qrin_new(i,k)=max(qrin_new(i,k),qrin(i,k)) 421 | 422 | ! Next scale mass...so output qc+qr is the same as input 423 | 424 | if ( (qcin_new(i,k)+qrin_new(i,k)) > 0._r8 ) then 425 | qscl = (qcin(i,k)+qrin(i,k))/(qcin_new(i,k)+qrin_new(i,k)) 426 | else 427 | qscl = 0._r8 428 | end if 429 | qcin_new(i,k) = qcin_new(i,k) * qscl 430 | qrin_new(i,k) = qrin_new(i,k) * qscl 431 | 432 | ! Now zero nr,nc if either small or no mass? 433 | 434 | if ( qcin_new(i,k) < qsmall ) then 435 | ncin_new(i,k) = 0._r8 436 | end if 437 | 438 | if ( qrin_new(i,k) < qsmall ) then 439 | nrin_new(i,k) = 0._r8 440 | end if 441 | 442 | !Finally add number if mass but no (or super small) number 443 | 444 | if ( qcin_new(i,k) > qsmall .and. ncin_new(i,k) < qsmall ) then 445 | ncin_new(i,k) = qcin_new(i,k)/m1 446 | end if 447 | 448 | if ( qrin_new(i,k) > qsmall .and. nrin_new(i,k) < qsmall) then 449 | nrin_new(i,k) = qrin_new(i,k)/m1 450 | end if 451 | 452 | ! Then recalculate tendencies based on difference 453 | ! Clip tendencies for cloud (qc,nc) to be <= 0. 454 | ! Qrtend is not used in pumas (-qctend is used) but clip that too). 455 | ! Nr tend can be muliply signed. 456 | 457 | qctend_TAU(i,k)= min((qcin_new(i,k) - qcin(i,k)) / deltatin,0._r8) 458 | nctend_TAU(i,k)= min((ncin_new(i,k) - ncin(i,k)) / deltatin,0._r8) 459 | qrtend_TAU(i,k)= max((qrin_new(i,k) - qrin(i,k)) / deltatin,0._r8) 460 | nrtend_TAU(i,k)= (nrin_new(i,k) - nrin(i,k)) / deltatin 461 | 462 | end do 463 | end do 464 | !$acc end parallel 465 | 466 | !$acc end data 467 | 468 | end subroutine pumas_stochastic_collect_tau_tend 469 | 470 | subroutine cam_bin_distribute(qc_all,qr_all,qc,nc,qr,nr,mu_c,lambda_c, & 471 | lambda_r,n0r,lcldm,precip_frac,scale_qc, & 472 | scale_nc,scale_qr,scale_nr,amk_c,ank_c, & 473 | amk_r,ank_r,amk,ank,cutoff_amk,mgncol,nlev) 474 | 475 | implicit none 476 | 477 | integer, intent(in) :: mgncol,nlev 478 | real(r8), dimension(mgncol,nlev), intent(in) :: qc_all,qr_all,qc,nc,qr,nr,mu_c, & 479 | lambda_c,lambda_r,n0r,lcldm, & 480 | precip_frac 481 | real(r8), dimension(mgncol,nlev,ncd), intent(out) :: amk_c,ank_c,amk_r,ank_r,amk,ank 482 | real(r8), dimension(mgncol,nlev), intent(out) :: scale_nc,scale_qc,scale_nr,scale_qr 483 | integer, dimension(mgncol,nlev), intent(out) :: cutoff_amk 484 | 485 | ! Local variables 486 | 487 | integer :: i,j,k 488 | real(r8) :: phi 489 | integer :: id_max_qc, id_max_qr 490 | real(r8) :: max_qc, max_qr, min_amk 491 | 492 | !$acc parallel vector_length(VLENS) default(present) 493 | !$acc loop gang vector collapse(3) 494 | do j=1,ncd 495 | do k=1,nlev 496 | do i=1,mgncol 497 | ank_c(i,k,j) = 0._r8 498 | amk_c(i,k,j) = 0._r8 499 | ank_r(i,k,j) = 0._r8 500 | amk_r(i,k,j) = 0._r8 501 | ank(i,k,j) = 0._r8 502 | amk(i,k,j) = 0._r8 503 | end do 504 | end do 505 | end do 506 | !$acc end parallel 507 | 508 | !$acc parallel vector_length(VLENS) default(present) 509 | !$acc loop gang vector collapse(2) 510 | do k=1,nlev 511 | do i=1,mgncol 512 | scale_nc(i,k) = 0._r8 513 | scale_qc(i,k) = 0._r8 514 | scale_nr(i,k) = 0._r8 515 | scale_qr(i,k) = 0._r8 516 | cutoff_amk(i,k) = 0 517 | 518 | id_max_qc = 0 519 | id_max_qr = 0 520 | max_qc = 0._r8 521 | max_qr = 0._r8 522 | 523 | ! cloud water, nc in #/m3 --> #/cm3 524 | if ( (qc_all(i,k) > qsmall) .and. (qc(i,k) > qsmall) ) then 525 | !$acc loop seq 526 | do j=1,ncd 527 | phi = nc(i,k)*lambda_c(i,k)**(mu_c(i,k)+1._r8)/ & 528 | gamma(mu_c(i,k)+1._r8)*(diammean(j)*1.e-2_r8)**mu_c(i,k)* & 529 | exp(-lambda_c(i,k)*diammean(j)*1.e-2_r8) ! D cm --> m 530 | ank_c(i,k,j) = phi*(diamedge(j+1)-diamedge(j))*1.e-2_r8 ! D cm --> m 531 | amk_c(i,k,j) = phi*(diamedge(j+1)-diamedge(j))*1.e-2_r8*mmean(j)*1.e-3_r8 ! mass in bin g --> kg 532 | scale_nc(i,k) = scale_nc(i,k)+ank_c(i,k,j) 533 | scale_qc(i,k) = scale_qc(i,k)+amk_c(i,k,j) 534 | end do 535 | scale_nc(i,k) = scale_nc(i,k)/nc(i,k) 536 | scale_qc(i,k) = scale_qc(i,k)/qc(i,k) 537 | 538 | !$acc loop seq 539 | do j=1,ncd 540 | ank_c(i,k,j) = ank_c(i,k,j)/scale_nc(i,k)*lcldm(i,k) 541 | amk_c(i,k,j) = amk_c(i,k,j)/scale_qc(i,k)*lcldm(i,k) 542 | if ( amk_c(i,k,j) > max_qc ) then 543 | id_max_qc = j 544 | max_qc = amk_c(i,k,j) 545 | end if 546 | end do 547 | end if 548 | 549 | ! rain drop 550 | if ( (qr_all(i,k) > qsmall) .and. (qr(i,k) > qsmall) ) then 551 | !$acc loop seq 552 | do j=1,ncd 553 | phi = n0r(i,k)*exp(-lambda_r(i,k)*diammean(j)*1.e-2_r8) ! D cm --> m 554 | ank_r(i,k,j) = phi*(diamedge(j+1)-diamedge(j))*1.e-2_r8 ! D cm --> m 555 | amk_r(i,k,j) = phi*(diamedge(j+1)-diamedge(j))*1.e-2_r8*mmean(j)*1.e-3_r8 556 | scale_nr(i,k) = scale_nr(i,k) + ank_r(i,k,j) 557 | scale_qr(i,k) = scale_qr(i,k) + amk_r(i,k,j) 558 | end do 559 | scale_nr(i,k) = scale_nr(i,k)/nr(i,k) 560 | scale_qr(i,k) = scale_qr(i,k)/qr(i,k) 561 | 562 | !$acc loop seq 563 | do j=1,ncd 564 | ank_r(i,k,j) = ank_r(i,k,j)/scale_nr(i,k)*precip_frac(i,k) 565 | amk_r(i,k,j) = amk_r(i,k,j)/scale_qr(i,k)*precip_frac(i,k) 566 | if ( amk_r(i,k,j) > max_qr ) then 567 | id_max_qr = j 568 | max_qr = amk_r(i,k,j) 569 | end if 570 | end do 571 | end if 572 | 573 | !$acc loop seq 574 | do j=1,ncd 575 | amk(i,k,j) = amk_c(i,k,j) + amk_r(i,k,j) 576 | ank(i,k,j) = ank_c(i,k,j) + ank_r(i,k,j) 577 | end do 578 | 579 | if ( (id_max_qc > 0) .and. (id_max_qr > 0) ) then 580 | if ( (max_qc/max_qr < 10._r8) .or. (max_qc/max_qr > 0.1_r8) ) then 581 | min_amk = amk(i,k,id_max_qc) 582 | !$acc loop seq 583 | do j=id_max_qc,id_max_qr 584 | if ( amk(i,k,j) <= min_amk ) then 585 | cutoff_amk(i,k) = j 586 | min_amk = amk(i,k,j) 587 | end if 588 | end do 589 | end if 590 | end if 591 | end do ! end of loop "mgncol" 592 | end do ! end of loop "nlev" 593 | !$acc end parallel 594 | 595 | !input: qc,nc,qr,nr, medge (bin edges). May also need # bins? 596 | !output: amk, ank (mixing ratio and number in each bin) 597 | 598 | !this part will take a bit of thinking about. 599 | !use size distribution parameters (mu, lambda) to generate the values at discrete size points 600 | !need to also ensure mass conservation 601 | 602 | end subroutine cam_bin_distribute 603 | 604 | ! here are the subroutines called above that actually do the collision-coalescence calculations: 605 | 606 | ! The Kernel is from Jerry from many moons ago (included) 607 | 608 | ! I read in the file data and multiply by the summed mass of the individual bins 609 | ! (with a factor of 1.5 so that the values represent the middle of the bin 610 | 611 | ! 941 FORMAT(2X,E12.5) 612 | ! READ(iunit,941) KNN(IDD,JDD) 613 | ! KNN(IDD,JDD)=(XK_GR(IDD)*kkfac+XK_GR(JDD)*kkfac)*KNN(IDD,JDD) 614 | 615 | !where idd and jdd are the indexes for the bins and xk_gr is the mass of drops in a bin in grams 616 | ! 617 | 618 | !************************************************************************************ 619 | ! Setup variables needed for collection 620 | ! Either pass in or define globally the following variables 621 | ! tbase(height) - temperature in K as a function of height 622 | ! rhon(height) - air density as a function of height in kg/m^3 623 | ! xk_gr(bins) - mass of single drop in each bin in grams 624 | ! lsmall - small number 625 | ! QC - mass mixing ratio in kg/kg 626 | ! QN - number mixing ratio in #/kg 627 | ! All parameters are defined to be global in my version so that they are readily available throughout the code: 628 | ! SMN0,SNN0,SMCN,APN,AMN2,AMN3,PSIN,FN,FPSIN,XPSIN,HPSIN,FN2,XXPSIN (all arrays of drop bins) 629 | !************************************************************************************ 630 | 631 | !AG: Global arrays need to be passed around I think? Right now at the module level. Is that okay? 632 | 633 | SUBROUTINE COMPUTE_COLL_PARAMS(rhon,xk_gr,qc,qn,gnnnn,gmnnn,lnnnn,lmnnn) 634 | 635 | !$acc routine seq 636 | 637 | IMPLICIT NONE 638 | 639 | ! variable declarations (added by hm, 020118) 640 | ! note: vertical array looping is stripped out, this subroutine operates 641 | ! only on LOCAL values 642 | 643 | real(r8), dimension(ncd) :: qc,qn 644 | real(r8), dimension(ncdp) :: xk_gr 645 | real(r8) :: tbase,rhon 646 | integer :: lk 647 | integer :: l 648 | real(r8), parameter :: lsmall = 1.e-12_r8 649 | real(r8), dimension(ncd) :: smn0,snn0,smcn,amn2,amn3,psin,fn,fpsin, & 650 | xpsin,hpsin,fn2,xxpsin 651 | real(r8) :: apn 652 | 653 | real(r8), dimension(ncd) :: gnnnn,gmnnn,lnnnn,lmnnn 654 | integer :: lm1,ll 655 | 656 | lk=ncd 657 | 658 | DO L=1,LK 659 | SMN0(L)=QC(L)*RHON/1.E3_r8 660 | SNN0(L)=QN(L)*RHON/1.E6_r8 661 | 662 | IF(SMN0(L).LT.lsmall.OR.SNN0(L).LT.lsmall)THEN 663 | SMN0(L)=0.0_r8 664 | SNN0(L)=0.0_r8 665 | ENDIF 666 | ENDDO 667 | 668 | DO L=1,LK 669 | IF(SMN0(L) .gt. 0._r8.AND.SNN0(L) .gt. 0._r8)THEN 670 | SMCN(L)=SMN0(L)/SNN0(L) 671 | IF((SMCN(L) .GT. 2._r8*XK_GR(L)))THEN 672 | SMCN(L) = (2._r8*XK_GR(L)) 673 | ENDIF 674 | IF((SMCN(L) .LT. XK_GR(L)))THEN 675 | SMCN(L) = XK_GR(L) 676 | ENDIF 677 | ELSE 678 | SMCN(L)=0._r8 679 | ENDIF 680 | IF (SMCN(L).LT.XK_GR(L).OR.SMCN(L).GT.(2._r8*XK_GR(L)).OR.SMCN(L).EQ.0.0_r8)THEN 681 | APN=1.0_r8 682 | ELSE 683 | APN=0.5_r8*(1._r8+3._r8*(XK_GR(L)/SMCN(L))-2._r8*((XK_GR(L)/SMCN(L))**2._r8)) 684 | ENDIF 685 | 686 | IF(SNN0(L) .GT. LSMALL)THEN 687 | AMN2(L)=APN*SMN0(L)*SMN0(L)/SNN0(L) 688 | AMN3(L)=APN*APN*APN*SMN0(L)*SMN0(L)*SMN0(L)/(SNN0(L)*SNN0(L)) 689 | ELSE 690 | AMN2(L)=0._r8 691 | AMN3(L)=0._r8 692 | ENDIF 693 | 694 | IF(SMCN(L).LT.XK_GR(L))THEN 695 | PSIN(L)=0.0_r8 696 | FN(L)=2._r8*SNN0(L)/XK_GR(L) 697 | ELSE 698 | IF(SMCN(L).GT.(2._r8*XK_GR(L)))THEN 699 | FN(L)=0.0_r8 700 | PSIN(L)=2._r8*SNN0(L)/XK_GR(L) 701 | ELSE 702 | PSIN(L)=2._r8/XK_GR(L)*(SMN0(L)/XK_GR(L)-SNN0(L)) 703 | FN(L)=2._r8/XK_GR(L)*(2._r8*SNN0(L)-SMN0(L)/XK_GR(L)) 704 | ENDIF 705 | ENDIF 706 | 707 | IF(SNN0(L).LT.LSMALL.OR.SMN0(L).LT.LSMALL)THEN 708 | PSIN(L)=0.0_r8 709 | FN(L)=0.0_r8 710 | ENDIF 711 | 712 | FPSIN(L)=0.5_r8/XK_GR(L)*(PSIN(L)-FN(L)) 713 | XPSIN(L)=2._r8*XK_GR(L)*PSIN(L) 714 | HPSIN(L)=PSIN(L)-0.5_r8*FN(L) 715 | FN2(L)=FN(L)/2._r8 716 | 717 | IF(L.GT.1)THEN 718 | XXPSIN(L)=XK_GR(L)*PSIN(L-1) 719 | ENDIF 720 | ENDDO 721 | 722 | !************************************************************************************ 723 | ! Compute collision coalescence 724 | ! Either pass in or define globally the following variables 725 | ! Gain terms begin with G, loss terms begin with L 726 | ! Second letter defines mass (M) or number (N) 727 | ! Third and fourth letters define the types of particles colling, i.e., NN means drops colliding with drops 728 | ! Last letter defines the category the new particles go into, in this case just N for liquid drops 729 | ! The resulting rates are in units of #/cm^3/s and g/cm^3/s 730 | ! Relies on predefined kernel array KNN(bins,bins) - see top of this file 731 | !************************************************************************************ 732 | 733 | GMNNN = 0._r8 734 | GNNNN = 0._r8 735 | LMNNN = 0._r8 736 | LNNNN = 0._r8 737 | ! remove verical array index, calculate gain/loss terms locally 738 | 739 | DO L=3,LK-1 740 | LM1=L-1 741 | DO LL=1,L-2 742 | GNNNN(L)=GNNNN(L)+(PSIN(LM1)*SMN0(LL)-FPSIN(LM1)*AMN2(LL))*KNN(LM1,LL) 743 | GMNNN(L)=GMNNN(L)+(XK_GR(L)*PSIN(LM1)*SMN0(LL)+FN2(LM1)*AMN2(LL)-FPSIN(LM1)*AMN3(LL))*KNN(LM1,LL) 744 | ENDDO 745 | ENDDO 746 | 747 | DO L=2,LK-1 748 | LM1=L-1 749 | GNNNN(L)=GNNNN(L)+0.5_r8*SNN0(LM1)*SNN0(LM1)*KNN(LM1,LM1) 750 | GMNNN(L)=GMNNN(L)+0.5_r8*(SNN0(LM1)*SMN0(LM1)+SMN0(LM1)*SNN0(LM1))*KNN(LM1,LM1) 751 | DO LL=1,L-1 752 | LNNNN(L)=LNNNN(L)+(PSIN(L)*SMN0(LL)-FPSIN(L)*AMN2(LL))*KNN(L,LL) 753 | GMNNN(L)=GMNNN(L)+(SMN0(LL)*SNN0(L)-PSIN(L)*AMN2(LL)+FPSIN(L)*AMN3(LL))*KNN(L,LL) 754 | LMNNN(L)=LMNNN(L)+(XPSIN(L)*SMN0(LL)-HPSIN(L)*AMN2(LL))*KNN(L,LL) 755 | ENDDO 756 | ENDDO 757 | 758 | DO L=1,LK-1 759 | DO LL=L,LK-1 760 | LNNNN(L)=LNNNN(L)+(SNN0(LL)*SNN0(L))*KNN(LL,L) 761 | LMNNN(L)=LMNNN(L)+(SNN0(LL)*SMN0(L))*KNN(LL,L) 762 | ENDDO 763 | ENDDO 764 | 765 | END SUBROUTINE COMPUTE_COLL_PARAMS 766 | 767 | 768 | end module pumas_stochastic_collect_tau 769 | -------------------------------------------------------------------------------- /micro_pumas_diags.F90: -------------------------------------------------------------------------------- 1 | module micro_pumas_diags 2 | 3 | !---------------------------------------- 4 | ! PUMAS diagnostics support package 5 | !---------------------------------------- 6 | 7 | use pumas_kinds, only: r8=>kind_r8 8 | 9 | !> \section arg_table_proc_rates_type Argument Table 10 | !! \htmlinclude proc_rates_type.html 11 | type, public :: proc_rates_type 12 | 13 | real(r8), allocatable :: prodsnow(:,:) ! production of snow (kg/kg/s) 14 | real(r8), allocatable :: evapsnow(:,:) ! sublimation rate of snow (1/s) 15 | real(r8), allocatable :: qcsevap(:,:) ! cloud water evaporation due to sedimentation (1/s) 16 | real(r8), allocatable :: qisevap(:,:) ! cloud ice sublimation due to sublimation (1/s) 17 | real(r8), allocatable :: qvres(:,:) ! residual condensation term to ensure RH < 100% (1/s) 18 | real(r8), allocatable :: cmeitot(:,:) ! grid-mean cloud ice sub/dep (1/s) 19 | real(r8), allocatable :: vtrmc(:,:) ! mass-weighted cloud water fallspeed (m/s) 20 | real(r8), allocatable :: vtrmi(:,:) ! mass-weighted cloud ice fallspeed (m/s) 21 | real(r8), allocatable :: umr(:,:) ! mass weighted rain fallspeed (m/s) 22 | real(r8), allocatable :: ums(:,:) ! mass weighted snow fallspeed (m/s) 23 | real(r8), allocatable :: umg(:,:) ! mass weighted graupel/hail fallspeed (m/s) 24 | real(r8), allocatable :: qgsedten(:,:) ! qg sedimentation tendency (1/s) 25 | real(r8), allocatable :: qcsedten(:,:) ! qc sedimentation tendency (1/s) 26 | real(r8), allocatable :: qisedten(:,:) ! qi sedimentation tendency (1/s) 27 | real(r8), allocatable :: qrsedten(:,:) ! qr sedimentation tendency (1/s) 28 | real(r8), allocatable :: qssedten(:,:) ! qs sedimentation tendency (1/s) 29 | 30 | real(r8), allocatable :: pratot(:,:) 31 | real(r8), allocatable :: prctot(:,:) 32 | real(r8), allocatable :: mnuccctot(:,:) 33 | real(r8), allocatable :: mnuccttot(:,:) 34 | real(r8), allocatable :: msacwitot(:,:) 35 | real(r8), allocatable :: psacwstot(:,:) 36 | real(r8), allocatable :: bergstot(:,:) 37 | real(r8), allocatable :: vapdepstot(:,:) 38 | real(r8), allocatable :: bergtot(:,:) 39 | real(r8), allocatable :: melttot(:,:) 40 | real(r8), allocatable :: meltstot(:,:) 41 | real(r8), allocatable :: meltgtot(:,:) 42 | real(r8), allocatable :: homotot(:,:) 43 | real(r8), allocatable :: qcrestot(:,:) 44 | real(r8), allocatable :: prcitot(:,:) 45 | real(r8), allocatable :: praitot(:,:) 46 | real(r8), allocatable :: qirestot(:,:) 47 | real(r8), allocatable :: mnuccrtot(:,:) 48 | real(r8), allocatable :: mnudeptot(:,:) 49 | real(r8), allocatable :: mnuccritot(:,:) 50 | real(r8), allocatable :: pracstot(:,:) 51 | real(r8), allocatable :: meltsdttot(:,:) 52 | real(r8), allocatable :: frzrdttot(:,:) 53 | real(r8), allocatable :: mnuccdtot(:,:) 54 | real(r8), allocatable :: pracgtot(:,:) 55 | real(r8), allocatable :: psacwgtot(:,:) 56 | real(r8), allocatable :: pgsacwtot(:,:) 57 | real(r8), allocatable :: pgracstot(:,:) 58 | real(r8), allocatable :: prdgtot(:,:) 59 | real(r8), allocatable :: qmultgtot(:,:) 60 | real(r8), allocatable :: qmultrgtot(:,:) 61 | real(r8), allocatable :: psacrtot(:,:) 62 | real(r8), allocatable :: npracgtot(:,:) 63 | real(r8), allocatable :: nscngtot(:,:) 64 | real(r8), allocatable :: ngracstot(:,:) 65 | real(r8), allocatable :: nmultgtot(:,:) 66 | real(r8), allocatable :: nmultrgtot(:,:) 67 | real(r8), allocatable :: npsacwgtot(:,:) 68 | 69 | real(r8), allocatable :: nnuccctot(:,:) ! change n due to Immersion freezing of cloud water 70 | real(r8), allocatable :: nnuccttot(:,:) ! change n due to Contact freezing of cloud water 71 | real(r8), allocatable :: nnuccdtot(:,:) ! change n due to Ice nucleation 72 | real(r8), allocatable :: nnudeptot(:,:) ! change n due to Deposition Nucleation 73 | real(r8), allocatable :: nhomotot(:,:) ! change n due to Homogeneous freezing of cloud water 74 | real(r8), allocatable :: nnuccrtot(:,:) ! change n due to heterogeneous freezing of rain to snow (1/s) 75 | real(r8), allocatable :: nnuccritot(:,:) ! change n due to Heterogeneous freezing of rain to ice 76 | real(r8), allocatable :: nsacwitot(:,:) ! change n due to Conversion of cloud water [to cloud ice] 77 | ! from rime-splintering 78 | real(r8), allocatable :: npratot(:,:) ! change n due to Accretion of cloud water by rain 79 | real(r8), allocatable :: npsacwstot(:,:) ! change n due to Accretion of cloud water by snow 80 | real(r8), allocatable :: npraitot(:,:) ! change n due to Accretion of cloud ice to snow 81 | real(r8), allocatable :: npracstot(:,:) ! change n due to Accretion of rain by snow 82 | real(r8), allocatable :: nprctot(:,:) ! change nr due to Autoconversion of cloud water [to rain] 83 | real(r8), allocatable :: nprcitot(:,:) ! change n due to Autoconversion of cloud ice to snow 84 | real(r8), allocatable :: ncsedten(:,:) ! change n due to cloud liquid sedimentation 85 | real(r8), allocatable :: nisedten(:,:) ! change n due to cloud ice sedimentation 86 | real(r8), allocatable :: nrsedten(:,:) ! change n due to rain sedimentation 87 | real(r8), allocatable :: nssedten(:,:) ! change n due to snow sedimentation 88 | real(r8), allocatable :: ngsedten(:,:) ! change n due to graupel sedimentation 89 | real(r8), allocatable :: nmelttot(:,:) ! change n due to Melting of cloud ice 90 | real(r8), allocatable :: nmeltstot(:,:) ! change n due to Melting of snow 91 | real(r8), allocatable :: nmeltgtot(:,:) ! change n due to Melting of graupel 92 | 93 | ! TAU diagnostic variables 94 | real(r8), allocatable :: nraggtot(:,:) ! change nr due to self collection of rain 95 | 96 | 97 | real(r8), allocatable :: pgam_out(:,:) ! Liquid Size distribution parameter Mu for output 98 | real(r8), allocatable :: lamc_out(:,:) ! Liquid Size distribution parameter Lambda for output 99 | real(r8), allocatable :: lamr_out(:,:) ! Rain Size distribution parameter Lambda for output 100 | real(r8), allocatable :: n0r_out(:,:) ! Size distribution parameter n0 for output 101 | real(r8), allocatable :: scale_qc(:,:) !TAU scaling factor for liquid mass to ensure conservation 102 | real(r8), allocatable :: scale_nc(:,:) !TAU scaling factor for liquid number to ensure conservation 103 | real(r8), allocatable :: scale_qr(:,:) !TAU scaling factor for rain mass to ensure conservation 104 | real(r8), allocatable :: scale_nr(:,:) !TAU scaling factor for rain_number to ensure conservation 105 | real(r8), allocatable :: amk_c(:,:,:) !TAU cloud liquid mass from bins 106 | real(r8), allocatable :: ank_c(:,:,:) !TAU cloud liquid number from bins 107 | real(r8), allocatable :: amk_r(:,:,:) !TAU cloud rain mass from bins 108 | real(r8), allocatable :: ank_r(:,:,:) !TAU cloud rain number from bins 109 | real(r8), allocatable :: amk(:,:,:) !TAU all liquid mass from bins 110 | real(r8), allocatable :: ank(:,:,:) !TAU all liquid number from bins 111 | real(r8), allocatable :: amk_out(:,:,:) !TAU all liquid number from bins output 112 | real(r8), allocatable :: ank_out(:,:,:) !TAU all liquid mass from bins output 113 | real(r8), allocatable :: qc_out_TAU(:,:) !TAU: output total cloud liquid mass 114 | real(r8), allocatable :: nc_out_TAU(:,:) !TAU: output total cloud liquid number 115 | real(r8), allocatable :: qr_out_TAU(:,:) !TAU: output total rain mass 116 | real(r8), allocatable :: nr_out_TAU(:,:) !TAU: output total cloud rain number 117 | real(r8), allocatable :: qc_in_TAU(:,:) !TAU: input total cloud liquid mass 118 | real(r8), allocatable :: nc_in_TAU(:,:) !TAU: input total cloud liquid number 119 | real(r8), allocatable :: qr_in_TAU(:,:) !TAU: input total rain mass 120 | real(r8), allocatable :: nr_in_TAU(:,:) !TAU: input total cloud rain number 121 | real(r8), allocatable :: qctend_KK2000(:,:) !cloud liquid mass tendency due to autoconversion & accretion from KK2000 122 | real(r8), allocatable :: nctend_KK2000(:,:) !cloud liquid number tendency due to autoconversion & accretion from KK2000 123 | real(r8), allocatable :: qrtend_KK2000(:,:) !rain mass tendency due to autoconversion & accretion from KK2000 124 | real(r8), allocatable :: nrtend_KK2000(:,:) !rain number tendency due to autoconversion & accretion from KK2000 125 | real(r8), allocatable :: qctend_SB2001(:,:) !cloud liquid mass tendency due to autoconversion & accretion from SB2001 126 | real(r8), allocatable :: nctend_SB2001(:,:) !cloud liquid number tendency due to autoconversion & accretion from SB2001 127 | real(r8), allocatable :: qrtend_SB2001(:,:) !rain mass tendency due to autoconversion & accretion from SB2001 128 | real(r8), allocatable :: nrtend_SB2001(:,:) !rain number tendency due to autoconversion & accretion from SB2001 129 | real(r8), allocatable :: qctend_TAU(:,:) !cloud liquid mass tendency due to autoconversion & accretion from TAU or Emulator code 130 | real(r8), allocatable :: nctend_TAU(:,:) !cloud liquid number tendency due to autoconversion & accretion from TAU or Emulator code 131 | real(r8), allocatable :: qrtend_TAU(:,:) !rain mass tendency due to autoconversion & accretion from TAU or Emulator code 132 | real(r8), allocatable :: nrtend_TAU(:,:) !rain number tendency due to autoconversion & accretion from TAU or Emulatorcode 133 | real(r8), allocatable :: gmnnn_lmnnn_TAU(:,:) ! TAU sum of mass gain and loss from bin code 134 | real(r8), allocatable :: ML_fixer(:,:) !Emulated: frequency of ML fixer is activated 135 | real(r8), allocatable :: QC_fixer(:,:) !Emulated: change in cloud liquid mass due to ML fixer 136 | real(r8), allocatable :: NC_fixer(:,:) !Emulated: change in cloud number number due to ML fixer 137 | real(r8), allocatable :: QR_fixer(:,:) !Emulated: change in rain mass due to ML fixer 138 | real(r8), allocatable :: NR_fixer(:,:) !Emulated: change in rain number due to ML fixer 139 | 140 | contains 141 | procedure :: allocate => proc_rates_allocate 142 | procedure :: deallocate => proc_rates_deallocate 143 | end type proc_rates_type 144 | 145 | contains 146 | 147 | subroutine proc_rates_allocate(this, psetcols, nlev, ncd, warm_rain, errstring) 148 | !-------------------------------------------------------------- 149 | ! Routine to allocate the elements of the proc_rates DDT 150 | !-------------------------------------------------------------- 151 | 152 | implicit none 153 | 154 | class(proc_rates_type) :: this 155 | 156 | integer, intent(in) :: psetcols, nlev 157 | integer, intent(in) :: ncd 158 | character(len=16), intent(in) :: warm_rain ! 'tau','emulated','sb2001' or 'kk2000' 159 | character(128), intent(out) :: errstring 160 | 161 | integer :: ierr 162 | 163 | errstring=' ' 164 | 165 | allocate(this%prodsnow(psetcols,nlev), stat=ierr) 166 | if (ierr /= 0) then 167 | errstring='Error allocating this%prodsnow' 168 | end if 169 | allocate(this%evapsnow(psetcols,nlev), stat=ierr) 170 | if (ierr /= 0) then 171 | errstring='Error allocating this%evapsnow' 172 | end if 173 | allocate(this%qcsevap(psetcols,nlev), stat=ierr) 174 | if (ierr /= 0) then 175 | errstring='Error allocating this%qcsevap' 176 | end if 177 | allocate(this%qisevap(psetcols,nlev), stat=ierr) 178 | if (ierr /= 0) then 179 | errstring='Error allocating this%qisevap' 180 | end if 181 | allocate(this%qvres(psetcols,nlev), stat=ierr) 182 | if (ierr /= 0) then 183 | errstring='Error allocating this%qvres' 184 | end if 185 | allocate(this%cmeitot(psetcols,nlev), stat=ierr) 186 | if (ierr /= 0) then 187 | errstring='Error allocating this%cmeitot' 188 | end if 189 | allocate(this%vtrmc(psetcols,nlev), stat=ierr) 190 | if (ierr /= 0) then 191 | errstring='Error allocating this%vtrmc' 192 | end if 193 | allocate(this%vtrmi(psetcols,nlev), stat=ierr) 194 | if (ierr /= 0) then 195 | errstring='Error allocating this%vtrmi' 196 | end if 197 | allocate(this%umr(psetcols,nlev), stat=ierr) 198 | if (ierr /= 0) then 199 | errstring='Error allocating this%umr' 200 | end if 201 | allocate(this%ums(psetcols,nlev), stat=ierr) 202 | if (ierr /= 0) then 203 | errstring='Error allocating this%ums' 204 | end if 205 | allocate(this%umg(psetcols,nlev), stat=ierr) 206 | if (ierr /= 0) then 207 | errstring='Error allocating this%umg' 208 | end if 209 | allocate(this%qgsedten(psetcols,nlev), stat=ierr) 210 | if (ierr /= 0) then 211 | errstring='Error allocating this%qgsedten' 212 | end if 213 | allocate(this%qcsedten(psetcols,nlev), stat=ierr) 214 | if (ierr /= 0) then 215 | errstring='Error allocating this%qcsedten' 216 | end if 217 | allocate(this%qisedten(psetcols,nlev), stat=ierr) 218 | if (ierr /= 0) then 219 | errstring='Error allocating this%qisedten' 220 | end if 221 | allocate(this%qrsedten(psetcols,nlev), stat=ierr) 222 | if (ierr /= 0) then 223 | errstring='Error allocating this%qrsedten' 224 | end if 225 | allocate(this%qssedten(psetcols,nlev), stat=ierr) 226 | if (ierr /= 0) then 227 | errstring='Error allocating this%qssedten' 228 | end if 229 | allocate(this%pratot(psetcols,nlev), stat=ierr) 230 | if (ierr /= 0) then 231 | errstring='Error allocating this%pratot' 232 | end if 233 | allocate(this%prctot(psetcols,nlev), stat=ierr) 234 | if (ierr /= 0) then 235 | errstring='Error allocating this%prctot' 236 | end if 237 | allocate(this%mnuccctot(psetcols,nlev), stat=ierr) 238 | if (ierr /= 0) then 239 | errstring='Error allocating this%mnuccctot' 240 | end if 241 | allocate(this%mnuccttot(psetcols,nlev), stat=ierr) 242 | if (ierr /= 0) then 243 | errstring='Error allocating this%mnuccttot' 244 | end if 245 | allocate(this%msacwitot(psetcols,nlev), stat=ierr) 246 | if (ierr /= 0) then 247 | errstring='Error allocating this%msacwitot' 248 | end if 249 | allocate(this%psacwstot(psetcols,nlev), stat=ierr) 250 | if (ierr /= 0) then 251 | errstring='Error allocating this%psacwstot' 252 | end if 253 | allocate(this%bergstot(psetcols,nlev), stat=ierr) 254 | if (ierr /= 0) then 255 | errstring='Error allocating this%bergstot' 256 | end if 257 | allocate(this%vapdepstot(psetcols,nlev), stat=ierr) 258 | if (ierr /= 0) then 259 | errstring='Error allocating this%vapdepstot' 260 | end if 261 | allocate(this%bergtot(psetcols,nlev), stat=ierr) 262 | if (ierr /= 0) then 263 | errstring='Error allocating this%bergtot' 264 | end if 265 | allocate(this%melttot(psetcols,nlev), stat=ierr) 266 | if (ierr /= 0) then 267 | errstring='Error allocating this%melttot' 268 | end if 269 | allocate(this%meltstot(psetcols,nlev), stat=ierr) 270 | if (ierr /= 0) then 271 | errstring='Error allocating this%meltstot' 272 | end if 273 | allocate(this%meltgtot(psetcols,nlev), stat=ierr) 274 | if (ierr /= 0) then 275 | errstring='Error allocating this%meltgtot' 276 | end if 277 | allocate(this%homotot(psetcols,nlev), stat=ierr) 278 | if (ierr /= 0) then 279 | errstring='Error allocating this%homotot' 280 | end if 281 | allocate(this%qcrestot(psetcols,nlev), stat=ierr) 282 | if (ierr /= 0) then 283 | errstring='Error allocating this%qcrestot' 284 | end if 285 | allocate(this%prcitot(psetcols,nlev), stat=ierr) 286 | if (ierr /= 0) then 287 | errstring='Error allocating this%prcitot' 288 | end if 289 | allocate(this%praitot(psetcols,nlev), stat=ierr) 290 | if (ierr /= 0) then 291 | errstring='Error allocating this%praitot' 292 | end if 293 | allocate(this%qirestot(psetcols,nlev), stat=ierr) 294 | if (ierr /= 0) then 295 | errstring='Error allocating this%qirestot' 296 | end if 297 | allocate(this%mnuccrtot(psetcols,nlev), stat=ierr) 298 | if (ierr /= 0) then 299 | errstring='Error allocating this%mnuccrtot' 300 | end if 301 | allocate(this%mnudeptot(psetcols,nlev), stat=ierr) 302 | if (ierr /= 0) then 303 | errstring='Error allocating this%mnudeptot' 304 | end if 305 | allocate(this%mnuccritot(psetcols,nlev), stat=ierr) 306 | if (ierr /= 0) then 307 | errstring='Error allocating this%mnuccritot' 308 | end if 309 | allocate(this%pracstot(psetcols,nlev), stat=ierr) 310 | if (ierr /= 0) then 311 | errstring='Error allocating this%pracstot' 312 | end if 313 | allocate(this%meltsdttot(psetcols,nlev), stat=ierr) 314 | if (ierr /= 0) then 315 | errstring='Error allocating this%meltsdttot' 316 | end if 317 | allocate(this%frzrdttot(psetcols,nlev), stat=ierr) 318 | if (ierr /= 0) then 319 | errstring='Error allocating this%frzrdttot' 320 | end if 321 | allocate(this%mnuccdtot(psetcols,nlev), stat=ierr) 322 | if (ierr /= 0) then 323 | errstring='Error allocating this%mnuccdtot' 324 | end if 325 | allocate(this%pracgtot(psetcols,nlev), stat=ierr) 326 | if (ierr /= 0) then 327 | errstring='Error allocating this%pracgtot' 328 | end if 329 | allocate(this%psacwgtot(psetcols,nlev), stat=ierr) 330 | if (ierr /= 0) then 331 | errstring='Error allocating this%psacwgtot' 332 | end if 333 | allocate(this%pgsacwtot(psetcols,nlev), stat=ierr) 334 | if (ierr /= 0) then 335 | errstring='Error allocating this%pgsacwtot' 336 | end if 337 | allocate(this%pgracstot(psetcols,nlev), stat=ierr) 338 | if (ierr /= 0) then 339 | errstring='Error allocating this%pgracstot' 340 | end if 341 | allocate(this%prdgtot(psetcols,nlev), stat=ierr) 342 | if (ierr /= 0) then 343 | errstring='Error allocating this%prdgtot' 344 | end if 345 | allocate(this%qmultgtot(psetcols,nlev), stat=ierr) 346 | if (ierr /= 0) then 347 | errstring='Error allocating this%qmultgtot' 348 | end if 349 | allocate(this%qmultrgtot(psetcols,nlev), stat=ierr) 350 | if (ierr /= 0) then 351 | errstring='Error allocating this%qmultrgtot' 352 | end if 353 | allocate(this%psacrtot(psetcols,nlev), stat=ierr) 354 | if (ierr /= 0) then 355 | errstring='Error allocating this%psacrtot' 356 | end if 357 | allocate(this%npracgtot(psetcols,nlev), stat=ierr) 358 | if (ierr /= 0) then 359 | errstring='Error allocating this%npracgtot' 360 | end if 361 | allocate(this%nscngtot(psetcols,nlev), stat=ierr) 362 | if (ierr /= 0) then 363 | errstring='Error allocating this%nscngtot' 364 | end if 365 | allocate(this%ngracstot(psetcols,nlev), stat=ierr) 366 | if (ierr /= 0) then 367 | errstring='Error allocating this%ngracstot' 368 | end if 369 | allocate(this%nmultgtot(psetcols,nlev), stat=ierr) 370 | if (ierr /= 0) then 371 | errstring='Error allocating this%nmultgtot' 372 | end if 373 | allocate(this%nmultrgtot(psetcols,nlev), stat=ierr) 374 | if (ierr /= 0) then 375 | errstring='Error allocating this%nmultrgtot' 376 | end if 377 | allocate(this%npsacwgtot(psetcols,nlev), stat=ierr) 378 | if (ierr /= 0) then 379 | errstring='Error allocating this%npsacwgtot' 380 | end if 381 | allocate(this%nnuccctot(psetcols,nlev), stat=ierr) 382 | if (ierr /= 0) then 383 | errstring='Error allocating this%nnuccctot' 384 | end if 385 | allocate(this%nnuccttot(psetcols,nlev), stat=ierr) 386 | if (ierr /= 0) then 387 | errstring='Error allocating this%nnuccttot' 388 | end if 389 | allocate(this%nnuccdtot(psetcols,nlev), stat=ierr) 390 | if (ierr /= 0) then 391 | errstring='Error allocating this%nnuccdtot' 392 | end if 393 | allocate(this%nnudeptot(psetcols,nlev), stat=ierr) 394 | if (ierr /= 0) then 395 | errstring='Error allocating this%nnudeptot' 396 | end if 397 | allocate(this%nhomotot(psetcols,nlev), stat=ierr) 398 | if (ierr /= 0) then 399 | errstring='Error allocating this%nhomotot' 400 | end if 401 | allocate(this%nnuccrtot(psetcols,nlev), stat=ierr) 402 | if (ierr /= 0) then 403 | errstring='Error allocating this%nnuccrtot' 404 | end if 405 | allocate(this%nnuccritot(psetcols,nlev), stat=ierr) 406 | if (ierr /= 0) then 407 | errstring='Error allocating this%nnuccritot' 408 | end if 409 | allocate(this%nsacwitot(psetcols,nlev), stat=ierr) 410 | if (ierr /= 0) then 411 | errstring='Error allocating this%nsacwitot' 412 | end if 413 | allocate(this%npratot(psetcols,nlev), stat=ierr) 414 | if (ierr /= 0) then 415 | errstring='Error allocating this%npratot' 416 | end if 417 | allocate(this%npsacwstot(psetcols,nlev), stat=ierr) 418 | if (ierr /= 0) then 419 | errstring='Error allocating this%npsacwstot' 420 | end if 421 | allocate(this%npraitot(psetcols,nlev), stat=ierr) 422 | if (ierr /= 0) then 423 | errstring='Error allocating this%npraitot' 424 | end if 425 | allocate(this%npracstot(psetcols,nlev), stat=ierr) 426 | if (ierr /= 0) then 427 | errstring='Error allocating this%npracstot' 428 | end if 429 | allocate(this%nprctot(psetcols,nlev), stat=ierr) 430 | if (ierr /= 0) then 431 | errstring='Error allocating this%nprctot' 432 | end if 433 | allocate(this%nraggtot(psetcols,nlev), stat=ierr) 434 | if (ierr /= 0) then 435 | errstring='Error allocating this%nraggtot' 436 | end if 437 | allocate(this%nprcitot(psetcols,nlev), stat=ierr) 438 | if (ierr /= 0) then 439 | errstring='Error allocating this%nprcitot' 440 | end if 441 | allocate(this%ncsedten(psetcols,nlev), stat=ierr) 442 | if (ierr /= 0) then 443 | errstring='Error allocating this%ncsedten' 444 | end if 445 | allocate(this%nisedten(psetcols,nlev), stat=ierr) 446 | if (ierr /= 0) then 447 | errstring='Error allocating this%nisedten' 448 | end if 449 | allocate(this%nrsedten(psetcols,nlev), stat=ierr) 450 | if (ierr /= 0) then 451 | errstring='Error allocating this%nrsedten' 452 | end if 453 | allocate(this%nssedten(psetcols,nlev), stat=ierr) 454 | if (ierr /= 0) then 455 | errstring='Error allocating this%nssedten' 456 | end if 457 | allocate(this%ngsedten(psetcols,nlev), stat=ierr) 458 | if (ierr /= 0) then 459 | errstring='Error allocating this%ngsedten' 460 | end if 461 | allocate(this%nmelttot(psetcols,nlev), stat=ierr) 462 | if (ierr /= 0) then 463 | errstring='Error allocating this%nmelttot' 464 | end if 465 | allocate(this%nmeltstot(psetcols,nlev), stat=ierr) 466 | if (ierr /= 0) then 467 | errstring='Error allocating this%nmeltstot' 468 | end if 469 | allocate(this%nmeltgtot(psetcols,nlev), stat=ierr) 470 | if (ierr /= 0) then 471 | errstring='Error allocating this%nmeltgtot' 472 | end if 473 | allocate(this%lamc_out(psetcols,nlev), stat=ierr) 474 | if (ierr /= 0) then 475 | errstring='Error allocating this%lamc_out' 476 | end if 477 | allocate(this%lamr_out(psetcols,nlev), stat=ierr) 478 | if (ierr /= 0) then 479 | errstring='Error allocating this%lamr_out' 480 | end if 481 | allocate(this%pgam_out(psetcols,nlev), stat=ierr) 482 | if (ierr /= 0) then 483 | errstring='Error allocating this%pgam_out' 484 | end if 485 | allocate(this%n0r_out(psetcols,nlev), stat=ierr) 486 | if (ierr /= 0) then 487 | errstring='Error allocating this%n0r_out' 488 | end if 489 | 490 | ! Only allocate these variables if machine learning turned on 491 | 492 | if (trim(warm_rain) == 'tau' .or. trim(warm_rain) == 'emulated') then 493 | allocate(this%scale_qc(psetcols,nlev), stat=ierr) 494 | if (ierr /= 0) then 495 | errstring='Error allocating this%scale_qc' 496 | end if 497 | allocate(this%scale_nc(psetcols,nlev), stat=ierr) 498 | if (ierr /= 0) then 499 | errstring='Error allocating this%scale_nc' 500 | end if 501 | allocate(this%scale_qr(psetcols,nlev), stat=ierr) 502 | if (ierr /= 0) then 503 | errstring='Error allocating this%scale_qr' 504 | end if 505 | allocate(this%scale_nr(psetcols,nlev), stat=ierr) 506 | if (ierr /= 0) then 507 | errstring='Error allocating this%scale_nr' 508 | end if 509 | allocate(this%amk_c(psetcols,nlev,ncd), stat=ierr) 510 | if (ierr /= 0) then 511 | errstring='Error allocating this%amk_c' 512 | end if 513 | allocate(this%ank_c(psetcols,nlev,ncd), stat=ierr) 514 | if (ierr /= 0) then 515 | errstring='Error allocating this%ank_c' 516 | end if 517 | allocate(this%amk_r(psetcols,nlev,ncd), stat=ierr) 518 | if (ierr /= 0) then 519 | errstring='Error allocating this%amk_r' 520 | end if 521 | allocate(this%ank_r(psetcols,nlev,ncd), stat=ierr) 522 | if (ierr /= 0) then 523 | errstring='Error allocating this%ank_r' 524 | end if 525 | allocate(this%amk(psetcols,nlev,ncd), stat=ierr) 526 | if (ierr /= 0) then 527 | errstring='Error allocating this%amk' 528 | end if 529 | allocate(this%ank(psetcols,nlev,ncd), stat=ierr) 530 | if (ierr /= 0) then 531 | errstring='Error allocating this%ank' 532 | end if 533 | allocate(this%amk_out(psetcols,nlev,ncd), stat=ierr) 534 | if (ierr /= 0) then 535 | errstring='Error allocating this%amk_out' 536 | end if 537 | allocate(this%ank_out(psetcols,nlev,ncd), stat=ierr) 538 | if (ierr /= 0) then 539 | errstring='Error allocating this%ank_out' 540 | end if 541 | allocate(this%qc_out_TAU(psetcols,nlev), stat=ierr) 542 | if (ierr /= 0) then 543 | errstring='Error allocating this%qc_out_TAU' 544 | end if 545 | allocate(this%nc_out_TAU(psetcols,nlev), stat=ierr) 546 | if (ierr /= 0) then 547 | errstring='Error allocating this%nc_out_TAU' 548 | end if 549 | allocate(this%qr_out_TAU(psetcols,nlev), stat=ierr) 550 | if (ierr /= 0) then 551 | errstring='Error allocating this%qr_out_TAU' 552 | end if 553 | allocate(this%nr_out_TAU(psetcols,nlev), stat=ierr) 554 | if (ierr /= 0) then 555 | errstring='Error allocating this%nr_out_TAU' 556 | end if 557 | allocate(this%qc_in_TAU(psetcols,nlev), stat=ierr) 558 | if (ierr /= 0) then 559 | errstring='Error allocating this%qc_in_TAU' 560 | end if 561 | allocate(this%nc_in_TAU(psetcols,nlev), stat=ierr) 562 | if (ierr /= 0) then 563 | errstring='Error allocating this%nc_in_TAU' 564 | end if 565 | allocate(this%qr_in_TAU(psetcols,nlev), stat=ierr) 566 | if (ierr /= 0) then 567 | errstring='Error allocating this%qr_in_TAU' 568 | end if 569 | allocate(this%nr_in_TAU(psetcols,nlev), stat=ierr) 570 | if (ierr /= 0) then 571 | errstring='Error allocating this%nr_in_TAU' 572 | end if 573 | allocate(this%qctend_TAU(psetcols,nlev), stat=ierr) 574 | if (ierr /= 0) then 575 | errstring='Error allocating this%qctend_TAU' 576 | end if 577 | allocate(this%nctend_TAU(psetcols,nlev), stat=ierr) 578 | if (ierr /= 0) then 579 | errstring='Error allocating this%nctend_TAU' 580 | end if 581 | allocate(this%qrtend_TAU(psetcols,nlev), stat=ierr) 582 | if (ierr /= 0) then 583 | errstring='Error allocating this%qrtend_TAU' 584 | end if 585 | allocate(this%nrtend_TAU(psetcols,nlev), stat=ierr) 586 | if (ierr /= 0) then 587 | errstring='Error allocating this%nrtend_TAU' 588 | end if 589 | allocate(this%gmnnn_lmnnn_TAU(psetcols,nlev), stat=ierr) 590 | if (ierr /= 0) then 591 | errstring='Error allocating this%gmnnn_lmnnn_TAU' 592 | end if 593 | allocate(this%ML_fixer(psetcols,nlev), stat=ierr) 594 | if (ierr /= 0) then 595 | errstring='Error allocating this%ML_fixer' 596 | end if 597 | allocate(this%QC_fixer(psetcols,nlev), stat=ierr) 598 | if (ierr /= 0) then 599 | errstring='Error allocating this%QC_fixer' 600 | end if 601 | allocate(this%NC_fixer(psetcols,nlev), stat=ierr) 602 | if (ierr /= 0) then 603 | errstring='Error allocating this%NC_fixer' 604 | end if 605 | allocate(this%QR_fixer(psetcols,nlev), stat=ierr) 606 | if (ierr /= 0) then 607 | errstring='Error allocating this%QR_fixer' 608 | end if 609 | allocate(this%NR_fixer(psetcols,nlev), stat=ierr) 610 | if (ierr /= 0) then 611 | errstring='Error allocating this%NR_fixer' 612 | end if 613 | else if (warm_rain == 'sb2001') then 614 | ! Classic default (non-ML) microphysics 615 | allocate(this%qctend_SB2001(psetcols,nlev), stat=ierr) 616 | if (ierr /= 0) then 617 | errstring='Error allocating this%qctend_SB2001' 618 | end if 619 | allocate(this%nctend_SB2001(psetcols,nlev), stat=ierr) 620 | if (ierr /= 0) then 621 | errstring='Error allocating this%nctend_SB2001' 622 | end if 623 | allocate(this%qrtend_SB2001(psetcols,nlev), stat=ierr) 624 | if (ierr /= 0) then 625 | errstring='Error allocating this%artend_SB2001' 626 | end if 627 | allocate(this%nrtend_SB2001(psetcols,nlev), stat=ierr) 628 | if (ierr /= 0) then 629 | errstring='Error allocating this%nrtend_SB2001' 630 | end if 631 | end if 632 | 633 | ! Variables which are needed by all code (Machine Learning and non-ML) 634 | allocate(this%qctend_KK2000(psetcols,nlev), stat=ierr) 635 | if (ierr /= 0) then 636 | errstring='Error allocating this%qctend_KK2000' 637 | end if 638 | allocate(this%nctend_KK2000(psetcols,nlev), stat=ierr) 639 | if (ierr /= 0) then 640 | errstring='Error allocating this%nctend_KK2000' 641 | end if 642 | allocate(this%qrtend_KK2000(psetcols,nlev), stat=ierr) 643 | if (ierr /= 0) then 644 | errstring='Error allocating this%artend_KK2000' 645 | end if 646 | allocate(this%nrtend_KK2000(psetcols,nlev), stat=ierr) 647 | if (ierr /= 0) then 648 | errstring='Error allocating this%nrtend_KK2000' 649 | end if 650 | 651 | end subroutine proc_rates_allocate 652 | 653 | subroutine proc_rates_deallocate(this, warm_rain) 654 | !-------------------------------------------------------------- 655 | ! Routine to deallocate the elements of the proc_rates DDT 656 | !-------------------------------------------------------------- 657 | 658 | class(proc_rates_type) :: this 659 | character(len=16), intent(in) :: warm_rain ! 'tau','emulated','sb2001' or 'kk2000' 660 | 661 | deallocate(this%prodsnow) 662 | deallocate(this%evapsnow) 663 | deallocate(this%qcsevap) 664 | deallocate(this%qisevap) 665 | deallocate(this%qvres) 666 | deallocate(this%cmeitot) 667 | deallocate(this%vtrmc) 668 | deallocate(this%vtrmi) 669 | deallocate(this%umr) 670 | deallocate(this%ums) 671 | deallocate(this%umg) 672 | deallocate(this%qgsedten) 673 | deallocate(this%qcsedten) 674 | deallocate(this%qisedten) 675 | deallocate(this%qrsedten) 676 | deallocate(this%qssedten) 677 | deallocate(this%pratot) 678 | deallocate(this%prctot) 679 | deallocate(this%mnuccctot) 680 | deallocate(this%mnuccttot) 681 | deallocate(this%msacwitot) 682 | deallocate(this%psacwstot) 683 | deallocate(this%bergstot) 684 | deallocate(this%vapdepstot) 685 | deallocate(this%bergtot) 686 | deallocate(this%melttot) 687 | deallocate(this%meltstot) 688 | deallocate(this%meltgtot) 689 | deallocate(this%homotot) 690 | deallocate(this%qcrestot) 691 | deallocate(this%prcitot) 692 | deallocate(this%praitot) 693 | deallocate(this%qirestot) 694 | deallocate(this%mnuccrtot) 695 | deallocate(this%mnudeptot) 696 | deallocate(this%mnuccritot) 697 | deallocate(this%pracstot) 698 | deallocate(this%meltsdttot) 699 | deallocate(this%frzrdttot) 700 | deallocate(this%mnuccdtot) 701 | deallocate(this%pracgtot) 702 | deallocate(this%psacwgtot) 703 | deallocate(this%pgsacwtot) 704 | deallocate(this%pgracstot) 705 | deallocate(this%prdgtot) 706 | deallocate(this%qmultgtot) 707 | deallocate(this%qmultrgtot) 708 | deallocate(this%psacrtot) 709 | deallocate(this%npracgtot) 710 | deallocate(this%nscngtot) 711 | deallocate(this%ngracstot) 712 | deallocate(this%nmultgtot) 713 | deallocate(this%nmultrgtot) 714 | deallocate(this%npsacwgtot) 715 | deallocate(this%nnuccctot) 716 | deallocate(this%nnuccttot) 717 | deallocate(this%nnuccdtot) 718 | deallocate(this%nnudeptot) 719 | deallocate(this%nhomotot) 720 | deallocate(this%nnuccrtot) 721 | deallocate(this%nnuccritot) 722 | deallocate(this%nsacwitot) 723 | deallocate(this%npratot) 724 | deallocate(this%npsacwstot) 725 | deallocate(this%npraitot) 726 | deallocate(this%npracstot) 727 | deallocate(this%nprctot) 728 | deallocate(this%nraggtot) 729 | deallocate(this%nprcitot) 730 | deallocate(this%ncsedten) 731 | deallocate(this%nisedten) 732 | deallocate(this%nrsedten) 733 | deallocate(this%nssedten) 734 | deallocate(this%ngsedten) 735 | deallocate(this%nmelttot) 736 | deallocate(this%nmeltstot) 737 | deallocate(this%nmeltgtot) 738 | 739 | deallocate(this%qctend_KK2000) 740 | deallocate(this%nctend_KK2000) 741 | deallocate(this%qrtend_KK2000) 742 | deallocate(this%nrtend_KK2000) 743 | 744 | deallocate(this%lamc_out) 745 | deallocate(this%lamr_out) 746 | deallocate(this%pgam_out) 747 | deallocate(this%n0r_out) 748 | 749 | if (trim(warm_rain) == 'tau' .or. trim(warm_rain) == 'emulated') then 750 | deallocate(this%scale_qc) 751 | deallocate(this%scale_nc) 752 | deallocate(this%scale_qr) 753 | deallocate(this%scale_nr) 754 | deallocate(this%amk_c) 755 | deallocate(this%ank_c) 756 | deallocate(this%amk_r) 757 | deallocate(this%ank_r) 758 | deallocate(this%amk) 759 | deallocate(this%ank) 760 | deallocate(this%amk_out) 761 | deallocate(this%ank_out) 762 | deallocate(this%qc_out_TAU) 763 | deallocate(this%nc_out_TAU) 764 | deallocate(this%qr_out_TAU) 765 | deallocate(this%nr_out_TAU) 766 | deallocate(this%qc_in_TAU) 767 | deallocate(this%nc_in_TAU) 768 | deallocate(this%qr_in_TAU) 769 | deallocate(this%nr_in_TAU) 770 | deallocate(this%qctend_TAU) 771 | deallocate(this%nctend_TAU) 772 | deallocate(this%qrtend_TAU) 773 | deallocate(this%nrtend_TAU) 774 | deallocate(this%gmnnn_lmnnn_TAU) 775 | deallocate(this%ML_fixer) 776 | deallocate(this%QC_fixer) 777 | deallocate(this%NC_fixer) 778 | deallocate(this%QR_fixer) 779 | deallocate(this%NR_fixer) 780 | else if (trim(warm_rain) == 'sb2001') then 781 | deallocate(this%qctend_SB2001) 782 | deallocate(this%nctend_SB2001) 783 | deallocate(this%qrtend_SB2001) 784 | deallocate(this%nrtend_SB2001) 785 | end if 786 | 787 | end subroutine proc_rates_deallocate 788 | 789 | end module micro_pumas_diags 790 | -------------------------------------------------------------------------------- /micro_pumas_ccpp.F90: -------------------------------------------------------------------------------- 1 | !Common Community Physics Package (CCPP) wrapper for PUMAS. 2 | module micro_pumas_ccpp 3 | 4 | implicit none 5 | private 6 | save 7 | 8 | public :: micro_pumas_ccpp_init 9 | public :: micro_pumas_ccpp_run 10 | 11 | contains 12 | 13 | !> \section arg_table_micro_pumas_ccpp_init Argument Table 14 | !! \htmlinclude micro_pumas_ccpp_init.html 15 | subroutine micro_pumas_ccpp_init(gravit, rair, rh2o, cpair, tmelt, latvap, latice, & 16 | rhmini, iulog, micro_mg_do_hail, micro_mg_do_graupel, & 17 | microp_uniform, do_cldice, use_hetfrz_classnuc, & 18 | remove_supersat, micro_mg_evap_sed_off, & 19 | micro_mg_icenuc_rh_off, micro_mg_icenuc_use_meyers, & 20 | micro_mg_evap_scl_ifs, micro_mg_evap_rhthrsh_ifs, & 21 | micro_mg_rainfreeze_ifs, micro_mg_ifs_sed, & 22 | micro_mg_precip_fall_corr, micro_mg_accre_sees_auto, & 23 | micro_mg_implicit_fall, micro_mg_nccons, & 24 | micro_mg_nicons, micro_mg_ngcons, micro_mg_nrcons, & 25 | micro_mg_nscons, micro_mg_precip_frac_method, & 26 | micro_mg_warm_rain, & 27 | stochastic_emulated_filename_quantile, & 28 | stochastic_emulated_filename_input_scale, & 29 | stochastic_emulated_filename_output_scale, & 30 | micro_mg_dcs_in, & 31 | micro_mg_berg_eff_factor_in, micro_mg_accre_enhan_fact_in, & 32 | micro_mg_autocon_fact_in, micro_mg_autocon_nd_exp_in, & 33 | micro_mg_autocon_lwp_exp_in, micro_mg_homog_size_in, & 34 | micro_mg_vtrmi_factor_in, micro_mg_vtrms_factor_in, & 35 | micro_mg_effi_factor_in, micro_mg_iaccr_factor_in, & 36 | micro_mg_max_nicons_in, micro_mg_ncnst_in, & 37 | micro_mg_ninst_in, micro_mg_ngnst_in, micro_mg_nrnst_in, & 38 | micro_mg_nsnst_in, errmsg, errcode) 39 | 40 | !External dependencies: 41 | use ccpp_kinds, only: kind_phys 42 | use micro_pumas_v1, only: micro_pumas_init 43 | use pumas_kinds, only: pumas_r8=>kind_r8 44 | 45 | !Subroutine (dummy) arguments: 46 | 47 | !Host model constants: 48 | real(kind_phys), intent(in) :: gravit !standard gravitational acceleration (m s-2) 49 | real(kind_phys), intent(in) :: rair !gas constant for dry air (J kg-1 K-1) 50 | real(kind_phys), intent(in) :: rh2o !gas constat for water vapor (J kg-1 K-1) 51 | real(kind_phys), intent(in) :: cpair !specific heat of dry air at constant pressure (J kg-1 K-1) 52 | real(kind_phys), intent(in) :: tmelt !freezing point of water (K) 53 | real(kind_phys), intent(in) :: latvap !latent heat of vaporization of water at 0 degrees C (J kg-1) 54 | real(kind_phys), intent(in) :: latice !latent heat of fusion of water at 0 degrees C (J kg-1) 55 | real(kind_phys), intent(in) :: rhmini !Minimum RH for ice cloud fraction > 0 (fraction) 56 | 57 | !Host model variables: 58 | integer, intent(in) :: iulog !Log output unit number (1) 59 | 60 | !PUMAS-specific parameters: 61 | !------------------------- 62 | logical, intent(in) :: micro_mg_do_hail !flag for PUMAS to simulate hail (flag) 63 | logical, intent(in) :: micro_mg_do_graupel !flag for PUMAS to simulate graupel (flag) 64 | logical, intent(in) :: microp_uniform !flag for PUMAS to perform uniform calc. (flag) 65 | logical, intent(in) :: do_cldice !flag for PUMAS to simulate cloud ice (flag) 66 | logical, intent(in) :: use_hetfrz_classnuc !flag to turn on PUMAS heterogeneous freezing (flag) 67 | logical, intent(in) :: remove_supersat !flag to remove supersaturation after sedimentation loop (flag) 68 | logical, intent(in) :: micro_mg_evap_sed_off !flag to turn off condensate evap. after sedimentation (flag) 69 | logical, intent(in) :: micro_mg_icenuc_rh_off !flag to turn off RH threshold for ice nucleation (flag) 70 | logical, intent(in) :: micro_mg_icenuc_use_meyers !flag to use Meyers 1992 temp. dependent ice nucleation (flag) 71 | logical, intent(in) :: micro_mg_evap_scl_ifs !flag to apply IFS precipitation evap. scaling (flag) 72 | logical, intent(in) :: micro_mg_evap_rhthrsh_ifs !flag to use IFS precipitation evap. RH threshold (flag) 73 | logical, intent(in) :: micro_mg_rainfreeze_ifs !flag to freeze rain at 0 degrees C as is done in IFS (flag) 74 | logical, intent(in) :: micro_mg_ifs_sed !flag to use IFS sedimentation fall speeds (flag) 75 | logical, intent(in) :: micro_mg_precip_fall_corr !flag to ensure non-zero precip fall speed if precip above (flag) 76 | logical, intent(in) :: micro_mg_accre_sees_auto !flag to add autoconverted liuqid to rain before accretion (flag) 77 | logical, intent(in) :: micro_mg_implicit_fall !flag to use implicit fall speed routine for all hydrometeors (flag) 78 | logical, intent(in) :: micro_mg_nccons !flag to have PUMAS hold cloud droplet number constant (flag) 79 | logical, intent(in) :: micro_mg_nicons !flag to have PUMAS hold cloud ice number constant (flag) 80 | logical, intent(in) :: micro_mg_ngcons !flag to have PUMAS hold cloud graupel number constant (flag) 81 | logical, intent(in) :: micro_mg_nrcons !flag to have PUMAS hold cloud rain number constant (flag) 82 | logical, intent(in) :: micro_mg_nscons !flag to have PUMAS hold cloud snow number constant (flag) 83 | 84 | !type of precipitation fraction method (none): 85 | character(len=*), intent(in) :: micro_mg_precip_frac_method 86 | !type of warm rain autoconversion/accr.method to use (none): 87 | character(len=*), intent(in) :: micro_mg_warm_rain 88 | !neural net file for warm_rain machine learning (none): 89 | character(len=*), intent(in) :: stochastic_emulated_filename_quantile 90 | !neural net input scaling values files for warm_rain machine learning (none): 91 | character(len=*), intent(in) :: stochastic_emulated_filename_input_scale 92 | !Neural net output scaling values file for warm_rain machine learning (none): 93 | character(len=*), intent(in) :: stochastic_emulated_filename_output_scale 94 | 95 | real(kind_phys), intent(in) :: micro_mg_dcs_in !autoconversion size threshold (um) 96 | real(kind_phys), intent(in) :: micro_mg_berg_eff_factor_in !efficienty factor for Bergeron process (1) 97 | real(kind_phys), intent(in) :: micro_mg_accre_enhan_fact_in !accretion enhancement factor (1) 98 | real(kind_phys), intent(in) :: micro_mg_autocon_fact_in !autoconverion enhancement prefactor (1) 99 | real(kind_phys), intent(in) :: micro_mg_autocon_nd_exp_in !autconversion cloud liquid exponent factor (1) 100 | real(kind_phys), intent(in) :: micro_mg_autocon_lwp_exp_in !autoconversion LWP exponent factor (1) 101 | real(kind_phys), intent(in) :: micro_mg_homog_size_in !mean volume radius of homoegenous freezing ice (m) 102 | real(kind_phys), intent(in) :: micro_mg_vtrmi_factor_in !ice fall velocity enhancement factor (1) 103 | real(kind_phys), intent(in) :: micro_mg_vtrms_factor_in !snow fall velocity enhancement factor (1) 104 | real(kind_phys), intent(in) :: micro_mg_effi_factor_in !ice effective radius enhancement factor (1) 105 | real(kind_phys), intent(in) :: micro_mg_iaccr_factor_in !ice accretion factor (1) 106 | real(kind_phys), intent(in) :: micro_mg_max_nicons_in !max allowed ice number concentration (m-3) 107 | 108 | !In-cloud droplet number concentration if micro_mg_nccons is True (m-3): 109 | real(kind_phys), intent(in) :: micro_mg_ncnst_in 110 | !In-cloud ice number concentration if micro_mg_nicons is True (m-3): 111 | real(kind_phys), intent(in) :: micro_mg_ninst_in 112 | !In-cloud graupel number concentration if micro_mg_ngcons is True (m-3): 113 | real(kind_phys), intent(in) :: micro_mg_ngnst_in 114 | !In-cloud rain number concentration when micro_mg_nrcons is True (m-3): 115 | real(kind_phys), intent(in) :: micro_mg_nrnst_in 116 | !In-cloud snow number concentration when micro_mg_nscons is True (m-3): 117 | real(kind_phys), intent(in) :: micro_mg_nsnst_in 118 | !------------------------- 119 | 120 | !Output variables: 121 | character(len=512), intent(out) :: errmsg !PUMAS/CCPP error message (none) 122 | integer, intent(out) :: errcode !CCPP error code (1) 123 | 124 | !Local variables: 125 | real(pumas_r8) :: micro_mg_dcs !autoconversion size threshold (um) 126 | real(pumas_r8) :: micro_mg_berg_eff_factor !efficienty factor for Bergeron process (1) 127 | real(pumas_r8) :: micro_mg_accre_enhan_fact !accretion enhancement factor (1) 128 | real(pumas_r8) :: micro_mg_autocon_fact !autoconverion enhancement prefactor (1) 129 | real(pumas_r8) :: micro_mg_autocon_nd_exp !autconversion cloud liquid exponent factor (1) 130 | real(pumas_r8) :: micro_mg_autocon_lwp_exp !autoconversion LWP exponent factor (1) 131 | real(pumas_r8) :: micro_mg_homog_size !mean volume radius of homoegenous freezing ice (m) 132 | real(pumas_r8) :: micro_mg_vtrmi_factor !ice fall velocity enhancement factor (1) 133 | real(pumas_r8) :: micro_mg_vtrms_factor !snow fall velocity enhancement factor (1) 134 | real(pumas_r8) :: micro_mg_effi_factor !ice effective radius enhancement factor (1) 135 | real(pumas_r8) :: micro_mg_iaccr_factor !ice accretion factor (1) 136 | real(pumas_r8) :: micro_mg_max_nicons !max allowed ice number concentration (m-3) 137 | 138 | !In-cloud droplet number concentration if micro_mg_nccons is True (m-3): 139 | real(pumas_r8) :: micro_mg_ncnst 140 | !In-cloud ice number concentration if micro_mg_nicons is True (m-3): 141 | real(pumas_r8) :: micro_mg_ninst 142 | !In-cloud graupel number concentration if micro_mg_ngcons is True (m-3): 143 | real(pumas_r8) :: micro_mg_ngnst 144 | !In-cloud rain number concentration when micro_mg_nrcons is True (m-3): 145 | real(pumas_r8) :: micro_mg_nrnst 146 | !In-cloud snow number concentration when micro_mg_nscons is True (m-3): 147 | real(pumas_r8) :: micro_mg_nsnst 148 | 149 | !Local PUMAS error message 150 | character(len=128) :: pumas_errstring 151 | 152 | !Initialize error message and error code: 153 | errmsg = '' 154 | errcode = 0 155 | 156 | !Convert real-type input fields into appropriate kind: 157 | micro_mg_dcs = real(micro_mg_dcs_in, pumas_r8) 158 | micro_mg_berg_eff_factor = real(micro_mg_berg_eff_factor_in, pumas_r8) 159 | micro_mg_accre_enhan_fact = real(micro_mg_accre_enhan_fact_in, pumas_r8) 160 | micro_mg_autocon_fact = real(micro_mg_autocon_fact_in, pumas_r8) 161 | micro_mg_autocon_nd_exp = real(micro_mg_autocon_nd_exp_in, pumas_r8) 162 | micro_mg_autocon_lwp_exp = real(micro_mg_autocon_lwp_exp_in, pumas_r8) 163 | micro_mg_homog_size = real(micro_mg_homog_size_in, pumas_r8) 164 | micro_mg_vtrmi_factor = real(micro_mg_vtrmi_factor_in, pumas_r8) 165 | micro_mg_vtrms_factor = real(micro_mg_vtrms_factor_in, pumas_r8) 166 | micro_mg_effi_factor = real(micro_mg_effi_factor_in, pumas_r8) 167 | micro_mg_iaccr_factor = real(micro_mg_iaccr_factor_in, pumas_r8) 168 | micro_mg_max_nicons = real(micro_mg_max_nicons_in, pumas_r8) 169 | micro_mg_ncnst = real(micro_mg_ncnst_in, pumas_r8) 170 | micro_mg_ninst = real(micro_mg_ninst_in, pumas_r8) 171 | micro_mg_ngnst = real(micro_mg_ngnst_in, pumas_r8) 172 | micro_mg_nrnst = real(micro_mg_nrnst_in, pumas_r8) 173 | micro_mg_nsnst = real(micro_mg_nsnst_in, pumas_r8) 174 | 175 | !Call PUMAS initialization routine: 176 | call micro_pumas_init( & 177 | pumas_r8, gravit, rair, rh2o, cpair, & 178 | tmelt, latvap, latice, rhmini, & 179 | micro_mg_dcs, & 180 | micro_mg_do_hail,micro_mg_do_graupel, & 181 | microp_uniform, do_cldice, use_hetfrz_classnuc, & 182 | micro_mg_precip_frac_method, micro_mg_berg_eff_factor, & 183 | micro_mg_accre_enhan_fact , & 184 | micro_mg_autocon_fact , micro_mg_autocon_nd_exp, micro_mg_autocon_lwp_exp, micro_mg_homog_size, & 185 | micro_mg_vtrmi_factor, micro_mg_vtrms_factor, micro_mg_effi_factor, & 186 | micro_mg_iaccr_factor, micro_mg_max_nicons, & 187 | remove_supersat, micro_mg_warm_rain, & 188 | micro_mg_evap_sed_off, micro_mg_icenuc_rh_off, micro_mg_icenuc_use_meyers, & 189 | micro_mg_evap_scl_ifs, micro_mg_evap_rhthrsh_ifs, & 190 | micro_mg_rainfreeze_ifs, micro_mg_ifs_sed, micro_mg_precip_fall_corr,& 191 | micro_mg_accre_sees_auto, micro_mg_implicit_fall, & 192 | micro_mg_nccons, micro_mg_nicons, micro_mg_ncnst, & 193 | micro_mg_ninst, micro_mg_ngcons, micro_mg_ngnst, & 194 | micro_mg_nrcons, micro_mg_nrnst, micro_mg_nscons, micro_mg_nsnst, & 195 | stochastic_emulated_filename_quantile, stochastic_emulated_filename_input_scale, & 196 | stochastic_emulated_filename_output_scale, iulog, pumas_errstring) 197 | 198 | !Set error code to non-zero value if PUMAS returns an error message: 199 | if (trim(pumas_errstring) /= "") then 200 | errcode = 1 201 | errmsg = trim(pumas_errstring) 202 | end if 203 | 204 | end subroutine micro_pumas_ccpp_init 205 | 206 | !> \section arg_table_micro_pumas_ccpp_run Argument Table 207 | !! \htmlinclude micro_pumas_ccpp_run.html 208 | subroutine micro_pumas_ccpp_run(micro_ncol, micro_nlev, micro_nlevp1, & 209 | micro_dust_nbins, micro_timestep_in, & 210 | micro_airT_in, micro_airq_in, micro_cldliq_in, & 211 | micro_cldice_in, micro_numliq_in, & 212 | micro_numice_in, micro_rainliq_in, & 213 | micro_snowice_in, micro_numrain_in, & 214 | micro_numsnow_in, micro_graupice_in, & 215 | micro_numgraup_in, micro_relvar_in, & 216 | micro_accre_enhan_in, micro_pmid_in, & 217 | micro_pdel_in, micro_pint_in, & 218 | micro_strat_cldfrc_in, micro_strat_liq_cldfrc_in, & 219 | micro_strat_ice_cldfrc_in, micro_qsatfac_in, & 220 | micro_naai_in, micro_npccn_in, & 221 | micro_rndst_in, micro_nacon_in, & 222 | micro_snowice_tend_external_in, & 223 | micro_numsnow_tend_external_in, & 224 | micro_effi_external_in, micro_frzimm_in, & 225 | micro_frzcnt_in, micro_frzdep_in, & 226 | micro_qcsinksum_rate1ord_out, & 227 | micro_airT_tend_out, micro_airq_tend_out, & 228 | micro_cldliq_tend_out, micro_cldice_tend_out, & 229 | micro_numliq_tend_out, micro_numice_tend_out, & 230 | micro_rainliq_tend_out, micro_snowice_tend_out, & 231 | micro_numrain_tend_out, micro_numsnow_tend_out, & 232 | micro_graupice_tend_out, micro_numgraup_tend_out, & 233 | micro_effc_out, micro_effc_fn_out, & 234 | micro_effi_out, micro_sadice_out, & 235 | micro_sadsnow_out, micro_prect_out, & 236 | micro_preci_out, micro_prec_evap_out, & 237 | micro_am_evap_st_out, micro_prec_prod_out, & 238 | micro_cmeice_out, micro_deffi_out, & 239 | micro_pgamrad_out, micro_lamcrad_out, & 240 | micro_snowice_in_prec_out, & 241 | micro_scaled_diam_snow_out, & 242 | micro_graupice_in_prec_out, & 243 | micro_numgraup_vol_in_prec_out, & 244 | micro_scaled_diam_graup_out, & 245 | micro_lflx_out, micro_iflx_out, micro_gflx_out, & 246 | micro_rflx_out, micro_sflx_out, & 247 | micro_rainliq_in_prec_out, micro_reff_rain_out, & 248 | micro_reff_snow_out, micro_reff_grau_out, & 249 | micro_numrain_vol_in_prec_out, & 250 | micro_numsnow_vol_in_prec_out, & 251 | micro_refl_out, micro_arefl_out, & 252 | micro_areflz_out, micro_frefl_out, & 253 | micro_csrfl_out, micro_acsrfl_out, & 254 | micro_fcsrfl_out, micro_refl10cm_out, & 255 | micro_reflz10cm_out, micro_rercld_out, & 256 | micro_ncai_out, micro_ncal_out, & 257 | micro_rainliq_out, micro_snowice_out, & 258 | micro_numrain_vol_out, micro_numsnow_vol_out, & 259 | micro_diam_rain_out, micro_diam_snow_out, & 260 | micro_graupice_out, micro_numgraup_vol_out, & 261 | micro_diam_graup_out, micro_freq_graup_out, & 262 | micro_freq_snow_out, micro_freq_rain_out, & 263 | micro_frac_ice_out, micro_frac_cldliq_tend_out, & 264 | micro_rain_evap_out, micro_proc_rates_inout, & 265 | errmsg, errcode) 266 | 267 | !External dependencies: 268 | use ccpp_kinds, only: kind_phys 269 | use micro_pumas_v1, only: micro_pumas_tend 270 | use micro_pumas_diags, only: proc_rates_type 271 | use pumas_kinds, only: pumas_r8=>kind_r8 272 | 273 | !Subroutine (dummy) input arguments: 274 | 275 | !Host model dimensions/parameters: 276 | integer, intent(in) :: micro_ncol !Number of horizontal microphysics columns (count) 277 | integer, intent(in) :: micro_nlev !Number of microphysics vertical layers (count) 278 | integer, intent(in) :: micro_nlevp1 !Number of microphysics vertical interfaces (count) 279 | integer, intent(in) :: micro_dust_nbins !Number of dust size bins 280 | real(kind_phys), intent(in) :: micro_timestep_in !Microphysics time step (s) 281 | 282 | !Host model state variables: 283 | 284 | !Microphysics Air temperature (K) 285 | real(kind_phys), intent(in) :: micro_airT_in(:,:) 286 | !Microphysics Water vapor mixing ratio wrt moist air and condensed water (kg kg-1) 287 | real(kind_phys), intent(in) :: micro_airq_in(:,:) 288 | !Microphysics cloud liquid water mixing ratio wrt moist air and condensed water (kg kg-1) 289 | real(kind_phys), intent(in) :: micro_cldliq_in(:,:) 290 | !Microphysics cloud ice mixing ratio wrt moist air and condensed water (kg kg-1) 291 | real(kind_phys), intent(in) :: micro_cldice_in(:,:) 292 | !microphysics mass number concentration of cloud liquid water wrt moist air and condensed water (kg-1) 293 | real(kind_phys), intent(in) :: micro_numliq_in(:,:) 294 | !microphysics mass number concentration of cloud ice wrt moist air and condensed water (kg-1) 295 | real(kind_phys), intent(in) :: micro_numice_in(:,:) 296 | !microphysics rain mixing ratio wrt moist air and condensed water (kg kg-1) 297 | real(kind_phys), intent(in) :: micro_rainliq_in(:,:) 298 | !microphysics snow mixing ratio wrt moist air and condensed water (kg kg-1) 299 | real(kind_phys), intent(in) :: micro_snowice_in(:,:) 300 | !microphysics mass number concentration of rain wrt moist air and condensed water (kg-1) 301 | real(kind_phys), intent(in) :: micro_numrain_in(:,:) 302 | !microphysics mass number concentration of snow wrt moist air and condensed water (kg-1) 303 | real(kind_phys), intent(in) :: micro_numsnow_in(:,:) 304 | !microphysics graupel mixing ratio wrt moist air and condensed water (kg kg-1) 305 | real(kind_phys), intent(in) :: micro_graupice_in(:,:) 306 | !microphysics mass number concentration of graupel wrt moist air and condensed water (kg-1) 307 | real(kind_phys), intent(in) :: micro_numgraup_in(:,:) 308 | !microphysics relative variance of cloud water (1) 309 | real(kind_phys), intent(in) :: micro_relvar_in(:,:) 310 | !microphysics accretion enhancement factor (1) 311 | real(kind_phys), intent(in) :: micro_accre_enhan_in(:,:) 312 | !microphysics air pressure (Pa) 313 | real(kind_phys), intent(in) :: micro_pmid_in(:,:) 314 | !microphysics air pressure thickness (Pa) 315 | real(kind_phys), intent(in) :: micro_pdel_in(:,:) 316 | !microphysics air pressure at interfaces (Pa) 317 | real(kind_phys), intent(in) :: micro_pint_in(:,:) 318 | !microphysics stratiform cloud area fraction (fraction) 319 | real(kind_phys), intent(in) :: micro_strat_cldfrc_in(:,:) 320 | !microphysics stratiform cloud liquid area fraction (fraction) 321 | real(kind_phys), intent(in) :: micro_strat_liq_cldfrc_in(:,:) 322 | !microphysics stratiform cloud ice area fraction (fraction) 323 | real(kind_phys), intent(in) :: micro_strat_ice_cldfrc_in(:,:) 324 | !microphysics subgrid cloud water saturation scaling factor (1) 325 | real(kind_phys), intent(in) :: micro_qsatfac_in(:,:) 326 | !microphysics tendency of activated ice nuclei mass number concentration (kg-1 s-1) 327 | real(kind_phys), intent(in) :: micro_naai_in(:,:) 328 | !microphysics tendency of activated cloud condensation nuclei mass number concentration (kg-1 s-1) 329 | real(kind_phys), intent(in) :: micro_npccn_in(:,:) 330 | !microphysics dust radii by size bin (m) 331 | real(kind_phys), intent(in) :: micro_rndst_in(:,:,:) 332 | !microphysics dust number concentration by size bin (m-3) 333 | real(kind_phys), intent(in) :: micro_nacon_in(:,:,:) 334 | !microphysics tendency of snow mixing ratio wrt moist air and condensed water from external microphysics (kg kg-1 s-1) 335 | real(kind_phys), intent(in) :: micro_snowice_tend_external_in(:,:) 336 | !microphysics tendency of mass number concentration of snow wrt moist air and condensed water from external microphysics 337 | !(kg-1 s-1) 338 | real(kind_phys), intent(in) :: micro_numsnow_tend_external_in(:,:) 339 | !microphysics effective radius of stratiform cloud ice particle from external microphysics (m) 340 | real(kind_phys), intent(in) :: micro_effi_external_in(:,:) 341 | !microphysics tendency of cloud liquid droplet number concentration due to immersion freezing (cm-3) 342 | real(kind_phys), intent(in) :: micro_frzimm_in(:,:) 343 | !microphysics tendency of cloud liquid droplet number concentration due to contact freezing (cm-3) 344 | real(kind_phys), intent(in) :: micro_frzcnt_in(:,:) 345 | !microphysics tendency of cloud ice number concentration due to deposition nucleation (cm-3) 346 | real(kind_phys), intent(in) :: micro_frzdep_in(:,:) 347 | 348 | !Subroutine output arguments: 349 | 350 | !microphysics direct conversion rate of stratiform cloud water to precipitation (s-1) 351 | real(kind_phys), intent(out) :: micro_qcsinksum_rate1ord_out(:,:) 352 | !microphysics tendency of dry air enthalpy at constant pressure (J kg-1 s-1) 353 | real(kind_phys), intent(out) :: micro_airT_tend_out(:,:) 354 | !microphysics tendency of water vapor mixing ratio wrt moist air and condensed water (kg kg-1 s-1) 355 | real(kind_phys), intent(out) :: micro_airq_tend_out(:,:) 356 | !microphysics tendency of cloud liquid water mixing ratio wrt moist air and condensed water (kg kg-1 s-1) 357 | real(kind_phys), intent(out) :: micro_cldliq_tend_out(:,:) 358 | !microphysics tendency of cloud ice mixing ratio wrt moist air and condensed water (kg kg-1 s-1) 359 | real(kind_phys), intent(out) :: micro_cldice_tend_out(:,:) 360 | !microphysics tendency of mass number concentration of cloud liquid water wrt moist air and condensed water (kg-1 s-1) 361 | real(kind_phys), intent(out) :: micro_numliq_tend_out(:,:) 362 | !microphysics tendency of mass number concentration of cloud ice wrt moist air and condensed water (kg-1 s-1) 363 | real(kind_phys), intent(out) :: micro_numice_tend_out(:,:) 364 | !microphysics tendency of rain mixing ratio wrt moist air and condensed water (kg kg-1 s-1) 365 | real(kind_phys), intent(out) :: micro_rainliq_tend_out(:,:) 366 | !microphysics tendency of snow mixing ratio wrt moist air and condensed water (kg kg-1 s-1) 367 | real(kind_phys), intent(out) :: micro_snowice_tend_out(:,:) 368 | !microphysics tendency of mass number concentration of rain wrt moist air and condensed water (kg-1 s-1) 369 | real(kind_phys), intent(out) :: micro_numrain_tend_out(:,:) 370 | !microphysics tendency of mass number concentration of snow wrt moist air and condensed water (kg-1 s-1) 371 | real(kind_phys), intent(out) :: micro_numsnow_tend_out(:,:) 372 | !microphysics tendency of graupel mixing ratio wrt moist air and condensed water (kg kg-1 s-1) 373 | real(kind_phys), intent(out) :: micro_graupice_tend_out(:,:) 374 | !microphysics tendency of mass number concentration of graupel wrt moist air and condensed water (kg-1 s-1) 375 | real(kind_phys), intent(out) :: micro_numgraup_tend_out(:,:) 376 | !microphysics effective radius of stratiform cloud liquid water particle (um) 377 | real(kind_phys), intent(out) :: micro_effc_out(:,:) 378 | !microphysics effective radius of stratiform cloud liquid water particle assuming droplet number concentration of 1e8 kg-1 (um) 379 | real(kind_phys), intent(out) :: micro_effc_fn_out(:,:) 380 | !microphysics effective radius of stratiform cloud ice particle (um) 381 | real(kind_phys), intent(out) :: micro_effi_out(:,:) 382 | !microphysics cloud ice surface area density (cm2 cm-3) 383 | real(kind_phys), intent(out) :: micro_sadice_out(:,:) 384 | !microphysics snow surface area density (cm2 cm-3) 385 | real(kind_phys), intent(out) :: micro_sadsnow_out(:,:) 386 | !microphysics LWE large scale precipitation rate at surface (m s-1) 387 | real(kind_phys), intent(out) :: micro_prect_out(:) 388 | !microphysics LWE large scale snowfall rate at surface (m s-1) 389 | real(kind_phys), intent(out) :: micro_preci_out(:) 390 | !microphysics precipitation evaporation rate wrt moist air and condensed water (kg kg-1 s-1) 391 | real(kind_phys), intent(out) :: micro_prec_evap_out(:,:) 392 | !microphysics precipitation evaporation area (fraction) 393 | real(kind_phys), intent(out) :: micro_am_evap_st_out(:,:) 394 | !microphysics precipitation production rate wrt moist air and condensed water (kg kg-1 s-1) 395 | real(kind_phys), intent(out) :: micro_prec_prod_out(:,:) 396 | !microphysics condensation minus evaporation rate of in-cloud ice wrt moist air and condensed water (kg kg-1 s-1) 397 | real(kind_phys), intent(out) :: micro_cmeice_out(:,:) 398 | !microphysics effective diameter of stratiform cloud ice particles for radiation (um) 399 | real(kind_phys), intent(out) :: micro_deffi_out(:,:) 400 | !microphysics cloud particle size distribution shape parameter (1) 401 | real(kind_phys), intent(out) :: micro_pgamrad_out(:,:) 402 | !microphysics cloud particle size distribution slope parameter (1) 403 | real(kind_phys), intent(out) :: micro_lamcrad_out(:,:) 404 | !microphysics snow mixing ratio wrt moist air and condensed water of new state in precipitating fraction of gridcell (kg kg-1) 405 | real(kind_phys), intent(out) :: micro_snowice_in_prec_out(:,:) 406 | !microphysics snow scaled diameter (m) 407 | real(kind_phys), intent(out) :: micro_scaled_diam_snow_out(:,:) 408 | !microphysics graupel mixing ratio wrt moist air and condensed water of new state in precipitating fraction of gridcell (kg kg-1) 409 | real(kind_phys), intent(out) :: micro_graupice_in_prec_out(:,:) 410 | !microphysics graupel number concentration of new state in precipitating fraction of gridcell (m-3) 411 | real(kind_phys), intent(out) :: micro_numgraup_vol_in_prec_out(:,:) 412 | !microphysics graupel scaled diameter (m) 413 | real(kind_phys), intent(out) :: micro_scaled_diam_graup_out(:,:) 414 | !microphysics cloud liquid sedimentation flux (kg m-2 s-1) 415 | real(kind_phys), intent(out) :: micro_lflx_out(:,:) 416 | !microphysics cloud ice sedimentation flux (kg m-2 s-1) 417 | real(kind_phys), intent(out) :: micro_iflx_out(:,:) 418 | !microphysics graupel sedimentation flux (kg m-2 s-1) 419 | real(kind_phys), intent(out) :: micro_gflx_out(:,:) 420 | !microphysics rain sedimentation flux (kg m-2 s-1) 421 | real(kind_phys), intent(out) :: micro_rflx_out(:,:) 422 | !microphysics snow sedimentation flux (kg m-2 s-1) 423 | real(kind_phys), intent(out) :: micro_sflx_out(:,:) 424 | !microphysics rain mixing ratio wrt moist air and condensed water of new state in precipitating fraction of gridcell (kg kg-1) 425 | real(kind_phys), intent(out) :: micro_rainliq_in_prec_out(:,:) 426 | !microphysics effective radius of stratiform rain particle (um) 427 | real(kind_phys), intent(out) :: micro_reff_rain_out(:,:) 428 | !microphysics effective radius of stratiform snow particle (um) 429 | real(kind_phys), intent(out) :: micro_reff_snow_out(:,:) 430 | !microphysics effective radius of stratiform graupel particle (um) 431 | real(kind_phys), intent(out) :: micro_reff_grau_out(:,:) 432 | !microphysics rain number concentration of new state in precipitating fraction of gridcell (m-3) 433 | real(kind_phys), intent(out) :: micro_numrain_vol_in_prec_out(:,:) 434 | !microphysics snow number concentration of new state in precipitating fraction of gridcell (m-3) 435 | real(kind_phys), intent(out) :: micro_numsnow_vol_in_prec_out(:,:) 436 | !microphysics analytic radar reflectivity at 94 GHz in precipitating fraction of gridcell (dBZ) 437 | real(kind_phys), intent(out) :: micro_refl_out(:,:) 438 | !microphysics analytic radar reflectivity at 94 GHz (dBZ) 439 | real(kind_phys), intent(out) :: micro_arefl_out(:,:) 440 | !microphysics analytic radar reflectivity z factor at 94 GHz (mm6 m-3) 441 | real(kind_phys), intent(out) :: micro_areflz_out(:,:) 442 | !microphysics fraction of gridcell with nonzero radar reflectivity (fraction) 443 | real(kind_phys), intent(out) :: micro_frefl_out(:,:) 444 | !microphysics analytic radar reflectivity at 94 GHz with CloudSat thresholds in precipitating fraction of gridcell (dBZ) 445 | real(kind_phys), intent(out) :: micro_csrfl_out(:,:) 446 | !microphysics analytic radar reflectivity at 94 GHz with CloudSat thresholds (dBZ) 447 | real(kind_phys), intent(out) :: micro_acsrfl_out(:,:) 448 | !microphysics fraction of gridcell with nonzero radar reflectivity with CloudSat thresholds (fraction) 449 | real(kind_phys), intent(out) :: micro_fcsrfl_out(:,:) 450 | !microphysics analytic radar reflectivity at 10 cm wavelength (dBZ) 451 | real(kind_phys), intent(out) :: micro_refl10cm_out(:,:) 452 | !microphysics analytic radar reflectivity z factor at 10 cm wavelength (mm6 m-3) 453 | real(kind_phys), intent(out) :: micro_reflz10cm_out(:,:) 454 | !microphysics effective radius of stratiform cloud liquid plus rain particles (m) 455 | real(kind_phys), intent(out) :: micro_rercld_out(:,:) 456 | !microphysics available ice nuclei number concentration of new state (m-3) 457 | real(kind_phys), intent(out) :: micro_ncai_out(:,:) 458 | !microphysics available cloud condensation nuclei number concentration of new state (m-3) 459 | real(kind_phys), intent(out) :: micro_ncal_out(:,:) 460 | !microphysics rain mixing ratio wrt moist air and condensed water of new state (kg kg-1) 461 | real(kind_phys), intent(out) :: micro_rainliq_out(:,:) 462 | !microphysics snow mixing ratio wrt moist air and condensed water of new state (kg kg-1) 463 | real(kind_phys), intent(out) :: micro_snowice_out(:,:) 464 | !microphysics rain number concentration of new state (m-3) 465 | real(kind_phys), intent(out) :: micro_numrain_vol_out(:,:) 466 | !microphysics snow number concentration of new state in precipitating fraction of gridcell (m-3) 467 | real(kind_phys), intent(out) :: micro_numsnow_vol_out(:,:) 468 | !microphysics average diameter of stratiform rain particle (m) 469 | real(kind_phys), intent(out) :: micro_diam_rain_out(:,:) 470 | !microphysics average diameter of stratiform snow particle (m) 471 | real(kind_phys), intent(out) :: micro_diam_snow_out(:,:) 472 | !microphysics graupel mixing ratio wrt moist air and condensed water of new state (kg kg-1) 473 | real(kind_phys), intent(out) :: micro_graupice_out(:,:) 474 | !microphysics graupel number concentration of new state (m-3) 475 | real(kind_phys), intent(out) :: micro_numgraup_vol_out(:,:) 476 | !microphysics average diameter of stratiform graupel particle (m) 477 | real(kind_phys), intent(out) :: micro_diam_graup_out(:,:) 478 | !microphysics fraction of gridcell with graupel (fraction) 479 | real(kind_phys), intent(out) :: micro_freq_graup_out(:,:) 480 | !microphysics fraction of gridcell with snow (fraction) 481 | real(kind_phys), intent(out) :: micro_freq_snow_out(:,:) 482 | !microphysics fraction of gridcell with rain (fraction) 483 | real(kind_phys), intent(out) :: micro_freq_rain_out(:,:) 484 | !microphysics fraction of frozen water to total condensed water (fraction) 485 | real(kind_phys), intent(out) :: micro_frac_ice_out(:,:) 486 | !microphysics fraction of cloud liquid tendency applied to state (fraction) 487 | real(kind_phys), intent(out) :: micro_frac_cldliq_tend_out(:,:) 488 | !microphysics rain evaporation rate wrt moist air and condensed water (kg kg-1 s-1) 489 | real(kind_phys), intent(out) :: micro_rain_evap_out(:,:) 490 | !microphysics process rates (none) 491 | type(proc_rates_type), intent(inout) :: micro_proc_rates_inout 492 | 493 | character(len=512), intent(out) :: errmsg !PUMAS/CCPP error message (none) 494 | integer, intent(out) :: errcode !CCPP error code (1) 495 | 496 | !Local variables: 497 | real(pumas_r8) :: micro_timestep 498 | real(pumas_r8) :: airT(micro_ncol, micro_nlev) 499 | real(pumas_r8) :: airq(micro_ncol, micro_nlev) 500 | real(pumas_r8) :: cldliq(micro_ncol, micro_nlev) 501 | real(pumas_r8) :: cldice(micro_ncol, micro_nlev) 502 | real(pumas_r8) :: numliq(micro_ncol, micro_nlev) 503 | real(pumas_r8) :: numice(micro_ncol, micro_nlev) 504 | real(pumas_r8) :: rainliq(micro_ncol, micro_nlev) 505 | real(pumas_r8) :: snowice(micro_ncol, micro_nlev) 506 | real(pumas_r8) :: numrain(micro_ncol, micro_nlev) 507 | real(pumas_r8) :: numsnow(micro_ncol, micro_nlev) 508 | real(pumas_r8) :: graupice(micro_ncol, micro_nlev) 509 | real(pumas_r8) :: numgraup(micro_ncol, micro_nlev) 510 | real(pumas_r8) :: relvar(micro_ncol, micro_nlev) 511 | real(pumas_r8) :: accre_enhan(micro_ncol, micro_nlev) 512 | real(pumas_r8) :: pmid(micro_ncol, micro_nlev) 513 | real(pumas_r8) :: pdel(micro_ncol, micro_nlev) 514 | real(pumas_r8) :: pint(micro_ncol, micro_nlevp1) 515 | real(pumas_r8) :: strat_cldfrc(micro_ncol, micro_nlev) 516 | real(pumas_r8) :: strat_liq_cldfrc(micro_ncol, micro_nlev) 517 | real(pumas_r8) :: strat_ice_cldfrc(micro_ncol, micro_nlev) 518 | real(pumas_r8) :: qsatfac(micro_ncol, micro_nlev) 519 | real(pumas_r8) :: naai(micro_ncol, micro_nlev) 520 | real(pumas_r8) :: npccn(micro_ncol, micro_nlev) 521 | real(pumas_r8) :: rndst(micro_ncol, micro_nlev, micro_dust_nbins) 522 | real(pumas_r8) :: nacon(micro_ncol, micro_nlev, micro_dust_nbins) 523 | real(pumas_r8) :: snowice_tend_external(micro_ncol, micro_nlev) 524 | real(pumas_r8) :: numsnow_tend_external(micro_ncol, micro_nlev) 525 | real(pumas_r8) :: effi_external(micro_ncol, micro_nlev) 526 | real(pumas_r8) :: frzimm(micro_ncol, micro_nlev) 527 | real(pumas_r8) :: frzcnt(micro_ncol, micro_nlev) 528 | real(pumas_r8) :: frzdep(micro_ncol, micro_nlev) 529 | real(pumas_r8) :: qcsinksum_rate1ord(micro_ncol, micro_nlev) 530 | real(pumas_r8) :: airT_tend(micro_ncol, micro_nlev) 531 | real(pumas_r8) :: airq_tend(micro_ncol, micro_nlev) 532 | real(pumas_r8) :: cldliq_tend(micro_ncol, micro_nlev) 533 | real(pumas_r8) :: cldice_tend(micro_ncol, micro_nlev) 534 | real(pumas_r8) :: numliq_tend(micro_ncol, micro_nlev) 535 | real(pumas_r8) :: numice_tend(micro_ncol, micro_nlev) 536 | real(pumas_r8) :: rainliq_tend(micro_ncol, micro_nlev) 537 | real(pumas_r8) :: snowice_tend(micro_ncol, micro_nlev) 538 | real(pumas_r8) :: numrain_tend(micro_ncol, micro_nlev) 539 | real(pumas_r8) :: numsnow_tend(micro_ncol, micro_nlev) 540 | real(pumas_r8) :: graupice_tend(micro_ncol, micro_nlev) 541 | real(pumas_r8) :: numgraup_tend(micro_ncol, micro_nlev) 542 | real(pumas_r8) :: effc(micro_ncol, micro_nlev) 543 | real(pumas_r8) :: effc_fn(micro_ncol, micro_nlev) 544 | real(pumas_r8) :: effi(micro_ncol, micro_nlev) 545 | real(pumas_r8) :: sadice(micro_ncol, micro_nlev) 546 | real(pumas_r8) :: sadsnow(micro_ncol, micro_nlev) 547 | real(pumas_r8) :: prect(micro_ncol) 548 | real(pumas_r8) :: preci(micro_ncol) 549 | real(pumas_r8) :: prec_evap(micro_ncol, micro_nlev) 550 | real(pumas_r8) :: am_evap_st(micro_ncol, micro_nlev) 551 | real(pumas_r8) :: prec_prod(micro_ncol, micro_nlev) 552 | real(pumas_r8) :: cmeice(micro_ncol, micro_nlev) 553 | real(pumas_r8) :: deffi(micro_ncol, micro_nlev) 554 | real(pumas_r8) :: pgamrad(micro_ncol, micro_nlev) 555 | real(pumas_r8) :: lamcrad(micro_ncol, micro_nlev) 556 | real(pumas_r8) :: snowice_in_prec_out(micro_ncol, micro_nlev) 557 | real(pumas_r8) :: scaled_diam_snow_out(micro_ncol, micro_nlev) 558 | real(pumas_r8) :: graupice_in_prec_out(micro_ncol, micro_nlev) 559 | real(pumas_r8) :: numgraup_vol_in_prec_out(micro_ncol, micro_nlev) 560 | real(pumas_r8) :: scaled_diam_graup_out(micro_ncol, micro_nlev) 561 | real(pumas_r8) :: lflx(micro_ncol, micro_nlevp1) 562 | real(pumas_r8) :: iflx(micro_ncol, micro_nlevp1) 563 | real(pumas_r8) :: gflx(micro_ncol, micro_nlevp1) 564 | real(pumas_r8) :: rflx(micro_ncol, micro_nlevp1) 565 | real(pumas_r8) :: sflx(micro_ncol, micro_nlevp1) 566 | real(pumas_r8) :: rainliq_in_prec_out(micro_ncol, micro_nlev) 567 | real(pumas_r8) :: reff_rain(micro_ncol, micro_nlev) 568 | real(pumas_r8) :: reff_snow(micro_ncol, micro_nlev) 569 | real(pumas_r8) :: reff_grau(micro_ncol, micro_nlev) 570 | real(pumas_r8) :: numrain_vol_in_prec_out(micro_ncol, micro_nlev) 571 | real(pumas_r8) :: numsnow_vol_in_prec_out(micro_ncol, micro_nlev) 572 | real(pumas_r8) :: refl(micro_ncol, micro_nlev) 573 | real(pumas_r8) :: arefl(micro_ncol, micro_nlev) 574 | real(pumas_r8) :: areflz(micro_ncol, micro_nlev) 575 | real(pumas_r8) :: frefl(micro_ncol, micro_nlev) 576 | real(pumas_r8) :: csrfl(micro_ncol, micro_nlev) 577 | real(pumas_r8) :: acsrfl(micro_ncol, micro_nlev) 578 | real(pumas_r8) :: fcsrfl(micro_ncol, micro_nlev) 579 | real(pumas_r8) :: refl10cm(micro_ncol, micro_nlev) 580 | real(pumas_r8) :: reflz10cm(micro_ncol, micro_nlev) 581 | real(pumas_r8) :: rercld(micro_ncol, micro_nlev) 582 | real(pumas_r8) :: ncai(micro_ncol, micro_nlev) 583 | real(pumas_r8) :: ncal(micro_ncol, micro_nlev) 584 | real(pumas_r8) :: rainliq_out(micro_ncol, micro_nlev) 585 | real(pumas_r8) :: snowice_out(micro_ncol, micro_nlev) 586 | real(pumas_r8) :: numrain_vol_out(micro_ncol, micro_nlev) 587 | real(pumas_r8) :: numsnow_vol_out(micro_ncol, micro_nlev) 588 | real(pumas_r8) :: diam_rain_out(micro_ncol, micro_nlev) 589 | real(pumas_r8) :: diam_snow_out(micro_ncol, micro_nlev) 590 | real(pumas_r8) :: graupice_out(micro_ncol, micro_nlev) 591 | real(pumas_r8) :: numgraup_vol_out(micro_ncol, micro_nlev) 592 | real(pumas_r8) :: diam_graup_out(micro_ncol, micro_nlev) 593 | real(pumas_r8) :: freq_graup(micro_ncol, micro_nlev) 594 | real(pumas_r8) :: freq_snow(micro_ncol, micro_nlev) 595 | real(pumas_r8) :: freq_rain(micro_ncol, micro_nlev) 596 | real(pumas_r8) :: frac_ice(micro_ncol, micro_nlev) 597 | real(pumas_r8) :: frac_cldliq_tend(micro_ncol, micro_nlev) 598 | real(pumas_r8) :: micro_rain_evap(micro_ncol, micro_nlev) 599 | 600 | !Local PUMAS error message 601 | character(len=128) :: pumas_errstring 602 | 603 | !Initialize error message and error code: 604 | errmsg = '' 605 | errcode = 0 606 | 607 | !Convert all CCPP input real variables to PUMAS precision: 608 | micro_timestep = real(micro_timestep_in, pumas_r8) 609 | airT = real(micro_airT_in, pumas_r8) 610 | airq = real(micro_airq_in, pumas_r8) 611 | cldliq = real(micro_cldliq_in, pumas_r8) 612 | cldice = real(micro_cldice_in, pumas_r8) 613 | numliq = real(micro_numliq_in, pumas_r8) 614 | numice = real(micro_numice_in, pumas_r8) 615 | rainliq = real(micro_rainliq_in, pumas_r8) 616 | snowice = real(micro_snowice_in, pumas_r8) 617 | numrain = real(micro_numrain_in, pumas_r8) 618 | numsnow = real(micro_numsnow_in, pumas_r8) 619 | graupice = real(micro_graupice_in, pumas_r8) 620 | numgraup = real(micro_numgraup_in, pumas_r8) 621 | relvar = real(micro_relvar_in, pumas_r8) 622 | accre_enhan = real(micro_accre_enhan_in, pumas_r8) 623 | pmid = real(micro_pmid_in, pumas_r8) 624 | pdel = real(micro_pdel_in, pumas_r8) 625 | pint = real(micro_pint_in, pumas_r8) 626 | strat_cldfrc = real(micro_strat_cldfrc_in, pumas_r8) 627 | strat_liq_cldfrc = real(micro_strat_liq_cldfrc_in, pumas_r8) 628 | strat_ice_cldfrc = real(micro_strat_ice_cldfrc_in, pumas_r8) 629 | qsatfac = real(micro_qsatfac_in, pumas_r8) 630 | naai = real(micro_naai_in, pumas_r8) 631 | npccn = real(micro_npccn_in, pumas_r8) 632 | rndst = real(micro_rndst_in, pumas_r8) 633 | nacon = real(micro_nacon_in, pumas_r8) 634 | snowice_tend_external = real(micro_snowice_tend_external_in, pumas_r8) 635 | numsnow_tend_external = real(micro_numsnow_tend_external_in, pumas_r8) 636 | effi_external = real(micro_effi_external_in, pumas_r8) 637 | frzimm = real(micro_frzimm_in, pumas_r8) 638 | frzcnt = real(micro_frzcnt_in, pumas_r8) 639 | frzdep = real(micro_frzdep_in, pumas_r8) 640 | 641 | !Call main PUMAS run routine: 642 | !--------------------------- 643 | 644 | call micro_pumas_tend( & 645 | micro_ncol, micro_nlev, micro_timestep, & 646 | airT, airq, & 647 | cldliq, cldice, & 648 | numliq, numice, & 649 | rainliq, snowice, & 650 | numrain, numsnow, & 651 | graupice, numgraup, & 652 | relvar, accre_enhan, & 653 | pmid, pdel, pint, & 654 | strat_cldfrc, strat_liq_cldfrc, & 655 | strat_ice_cldfrc, qsatfac, & 656 | qcsinksum_rate1ord, & 657 | naai, npccn, & 658 | rndst, nacon, & 659 | airT_tend, airq_tend, & 660 | cldliq_tend, cldice_tend, & 661 | numliq_tend, numice_tend, & 662 | rainliq_tend, snowice_tend, & 663 | numrain_tend, numsnow_tend, & 664 | graupice_tend, numgraup_tend, & 665 | effc, effc_fn, effi, & 666 | sadice, sadsnow, & 667 | prect, preci, & 668 | prec_evap, am_evap_st, & 669 | prec_prod, & 670 | cmeice, deffi, & 671 | pgamrad, lamcrad, & 672 | snowice_in_prec_out, scaled_diam_snow_out, & 673 | graupice_in_prec_out, numgraup_vol_in_prec_out, & 674 | scaled_diam_graup_out, & 675 | lflx, iflx, & 676 | gflx, & 677 | rflx, sflx, rainliq_in_prec_out, & 678 | reff_rain, reff_snow, reff_grau, & 679 | numrain_vol_in_prec_out, numsnow_vol_in_prec_out, & 680 | refl, arefl, areflz, & 681 | frefl, csrfl, acsrfl, & 682 | fcsrfl, refl10cm, reflz10cm, rercld, & 683 | ncai, ncal, & 684 | rainliq_out, snowice_out, & 685 | numrain_vol_out, numsnow_vol_out, & 686 | diam_rain_out, diam_snow_out, & 687 | graupice_out, numgraup_vol_out, diam_graup_out, & 688 | freq_graup, freq_snow, freq_rain, & 689 | frac_ice, frac_cldliq_tend, & 690 | micro_proc_rates_inout, pumas_errstring, & 691 | snowice_tend_external, numsnow_tend_external, & 692 | effi_external, micro_rain_evap, & 693 | frzimm, frzcnt, frzdep ) 694 | 695 | !--------------------------- 696 | 697 | !Convert all PUMAS output real variables to CCPP precision: 698 | micro_qcsinksum_rate1ord_out = real(qcsinksum_rate1ord, kind_phys) 699 | micro_airT_tend_out = real(airT_tend, kind_phys) 700 | micro_airq_tend_out = real(airq_tend, kind_phys) 701 | micro_cldliq_tend_out = real(cldliq_tend, kind_phys) 702 | micro_cldice_tend_out = real(cldice_tend, kind_phys) 703 | micro_numliq_tend_out = real(numliq_tend, kind_phys) 704 | micro_numice_tend_out = real(numice_tend, kind_phys) 705 | micro_rainliq_tend_out = real(rainliq_tend, kind_phys) 706 | micro_snowice_tend_out = real(snowice_tend, kind_phys) 707 | micro_numrain_tend_out = real(numrain_tend, kind_phys) 708 | micro_numsnow_tend_out = real(numsnow_tend, kind_phys) 709 | micro_graupice_tend_out = real(graupice_tend, kind_phys) 710 | micro_numgraup_tend_out = real(numgraup_tend, kind_phys) 711 | micro_effc_out = real(effc, kind_phys) 712 | micro_effc_fn_out = real(effc_fn, kind_phys) 713 | micro_effi_out = real(effi, kind_phys) 714 | micro_sadice_out = real(sadice, kind_phys) 715 | micro_sadsnow_out = real(sadsnow, kind_phys) 716 | micro_prect_out = real(prect, kind_phys) 717 | micro_preci_out = real(preci, kind_phys) 718 | micro_prec_evap_out = real(prec_evap, kind_phys) 719 | micro_am_evap_st_out = real(am_evap_st, kind_phys) 720 | micro_prec_prod_out = real(prec_prod, kind_phys) 721 | micro_cmeice_out = real(cmeice, kind_phys) 722 | micro_deffi_out = real(deffi, kind_phys) 723 | micro_pgamrad_out = real(pgamrad, kind_phys) 724 | micro_lamcrad_out = real(lamcrad, kind_phys) 725 | micro_snowice_in_prec_out = real(snowice_in_prec_out, kind_phys) 726 | micro_scaled_diam_snow_out = real(scaled_diam_snow_out, kind_phys) 727 | micro_graupice_in_prec_out = real(graupice_in_prec_out, kind_phys) 728 | micro_numgraup_vol_in_prec_out = real(numgraup_vol_in_prec_out, kind_phys) 729 | micro_scaled_diam_graup_out = real(scaled_diam_graup_out, kind_phys) 730 | micro_lflx_out = real(lflx, kind_phys) 731 | micro_iflx_out = real(iflx, kind_phys) 732 | micro_gflx_out = real(gflx, kind_phys) 733 | micro_rflx_out = real(rflx, kind_phys) 734 | micro_sflx_out = real(sflx, kind_phys) 735 | micro_rainliq_in_prec_out = real(rainliq_in_prec_out, kind_phys) 736 | micro_reff_rain_out = real(reff_rain, kind_phys) 737 | micro_reff_snow_out = real(reff_snow, kind_phys) 738 | micro_reff_grau_out = real(reff_grau, kind_phys) 739 | micro_numrain_vol_in_prec_out = real(numrain_vol_in_prec_out, kind_phys) 740 | micro_numsnow_vol_in_prec_out = real(numsnow_vol_in_prec_out, kind_phys) 741 | micro_refl_out = real(refl, kind_phys) 742 | micro_arefl_out = real(arefl, kind_phys) 743 | micro_areflz_out = real(areflz, kind_phys) 744 | micro_frefl_out = real(frefl, kind_phys) 745 | micro_csrfl_out = real(csrfl, kind_phys) 746 | micro_acsrfl_out = real(acsrfl, kind_phys) 747 | micro_fcsrfl_out = real(fcsrfl, kind_phys) 748 | micro_refl10cm_out = real(refl10cm, kind_phys) 749 | micro_reflz10cm_out = real(reflz10cm, kind_phys) 750 | micro_rercld_out = real(rercld, kind_phys) 751 | micro_ncai_out = real(ncai, kind_phys) 752 | micro_ncal_out = real(ncal, kind_phys) 753 | micro_rainliq_out = real(rainliq_out, kind_phys) 754 | micro_snowice_out = real(snowice_out, kind_phys) 755 | micro_numrain_vol_out = real(numrain_vol_out, kind_phys) 756 | micro_numsnow_vol_out = real(numsnow_vol_out, kind_phys) 757 | micro_diam_rain_out = real(diam_rain_out, kind_phys) 758 | micro_diam_snow_out = real(diam_snow_out, kind_phys) 759 | micro_graupice_out = real(graupice_out, kind_phys) 760 | micro_numgraup_vol_out = real(numgraup_vol_out, kind_phys) 761 | micro_diam_graup_out = real(diam_graup_out, kind_phys) 762 | micro_freq_graup_out = real(freq_graup, kind_phys) 763 | micro_freq_snow_out = real(freq_snow, kind_phys) 764 | micro_freq_rain_out = real(freq_rain, kind_phys) 765 | micro_frac_ice_out = real(frac_ice, kind_phys) 766 | micro_frac_cldliq_tend_out = real(frac_cldliq_tend, kind_phys) 767 | micro_rain_evap_out = real(micro_rain_evap, kind_phys) 768 | 769 | !Set error code to non-zero value if PUMAS returns an error message: 770 | if (trim(errmsg) /= "") then 771 | errcode = 1 772 | errmsg = trim(pumas_errstring) 773 | end if 774 | 775 | end subroutine micro_pumas_ccpp_run 776 | 777 | end module micro_pumas_ccpp 778 | --------------------------------------------------------------------------------