From 3ef7b5ab4bbf61b173bb8e0b3ecb0596d48dc636 Mon Sep 17 00:00:00 2001 From: MichaelSt98 Date: Thu, 31 Aug 2023 11:21:20 +0300 Subject: [PATCH 1/4] Manual (or rather semi-automatically generated) HIP versions of cloudsc including arch files for Lumi --- CMakeLists.txt | 2 +- arch/eurohpc/lumi/cray-gpu/15.0.1/env.sh | 51 + .../lumi/cray-gpu/15.0.1/toolchain.cmake | 43 + bundle.yml | 4 + src/CMakeLists.txt | 1 + src/cloudsc_hip/CMakeLists.txt | 168 ++ src/cloudsc_hip/cloudsc/cloudsc_c.cpp | 2632 ++++++++++++++++ src/cloudsc_hip/cloudsc/cloudsc_c.h | 44 + src/cloudsc_hip/cloudsc/cloudsc_c_hoist.cpp | 2651 +++++++++++++++++ src/cloudsc_hip/cloudsc/cloudsc_c_hoist.h | 50 + .../cloudsc/cloudsc_c_k_caching.cpp | 2630 ++++++++++++++++ src/cloudsc_hip/cloudsc/cloudsc_c_k_caching.h | 44 + src/cloudsc_hip/cloudsc/cloudsc_driver.cpp | 607 ++++ src/cloudsc_hip/cloudsc/cloudsc_driver.h | 23 + .../cloudsc/cloudsc_driver_hoist.cpp | 666 +++++ .../cloudsc/cloudsc_driver_hoist.h | 23 + src/cloudsc_hip/cloudsc/cloudsc_validate.cpp | 244 ++ src/cloudsc_hip/cloudsc/cloudsc_validate.h | 17 + src/cloudsc_hip/cloudsc/load_state.cpp | 447 +++ src/cloudsc_hip/cloudsc/load_state.h | 40 + src/cloudsc_hip/cloudsc/mycpu.cpp | 31 + src/cloudsc_hip/cloudsc/mycpu.h | 11 + src/cloudsc_hip/cloudsc/yoecldp_c.h | 145 + src/cloudsc_hip/dwarf_cloudsc.cpp | 44 + 24 files changed, 10617 insertions(+), 1 deletion(-) create mode 100644 arch/eurohpc/lumi/cray-gpu/15.0.1/env.sh create mode 100644 arch/eurohpc/lumi/cray-gpu/15.0.1/toolchain.cmake create mode 100644 src/cloudsc_hip/CMakeLists.txt create mode 100644 src/cloudsc_hip/cloudsc/cloudsc_c.cpp create mode 100644 src/cloudsc_hip/cloudsc/cloudsc_c.h create mode 100644 src/cloudsc_hip/cloudsc/cloudsc_c_hoist.cpp create mode 100644 src/cloudsc_hip/cloudsc/cloudsc_c_hoist.h create mode 100644 src/cloudsc_hip/cloudsc/cloudsc_c_k_caching.cpp create mode 100644 src/cloudsc_hip/cloudsc/cloudsc_c_k_caching.h create mode 100644 src/cloudsc_hip/cloudsc/cloudsc_driver.cpp create mode 100644 src/cloudsc_hip/cloudsc/cloudsc_driver.h create mode 100644 src/cloudsc_hip/cloudsc/cloudsc_driver_hoist.cpp create mode 100644 src/cloudsc_hip/cloudsc/cloudsc_driver_hoist.h create mode 100644 src/cloudsc_hip/cloudsc/cloudsc_validate.cpp create mode 100644 src/cloudsc_hip/cloudsc/cloudsc_validate.h create mode 100644 src/cloudsc_hip/cloudsc/load_state.cpp create mode 100644 src/cloudsc_hip/cloudsc/load_state.h create mode 100644 src/cloudsc_hip/cloudsc/mycpu.cpp create mode 100644 src/cloudsc_hip/cloudsc/mycpu.h create mode 100644 src/cloudsc_hip/cloudsc/yoecldp_c.h create mode 100644 src/cloudsc_hip/dwarf_cloudsc.cpp diff --git a/CMakeLists.txt b/CMakeLists.txt index 64403990..9a454395 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -83,7 +83,7 @@ endif() ecbuild_add_option( FEATURE SERIALBOX DESCRIPTION "Use Serialbox to read input and reference data" REQUIRED_PACKAGES "Serialbox" - CONDITION NOT HAVE_HDF5 + CONDITION NOT HAVE_HDF5 OR HAVE_SERIALBOX DEFAULT OFF ) if( HAVE_SERIALBOX ) list(APPEND CLOUDSC_DEFINITIONS HAVE_SERIALBOX) diff --git a/arch/eurohpc/lumi/cray-gpu/15.0.1/env.sh b/arch/eurohpc/lumi/cray-gpu/15.0.1/env.sh new file mode 100644 index 00000000..9a66e150 --- /dev/null +++ b/arch/eurohpc/lumi/cray-gpu/15.0.1/env.sh @@ -0,0 +1,51 @@ +# (C) Copyright 1988- ECMWF. +# +# This software is licensed under the terms of the Apache Licence Version 2.0 +# which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. +# In applying this licence, ECMWF does not waive the privileges and immunities +# granted to it by virtue of its status as an intergovernmental organisation +# nor does it submit to any jurisdiction. + +# Source me to get the correct configure/build/run environment + +# Store tracing and disable (module is *way* too verbose) +{ tracing_=${-//[^x]/}; set +x; } 2>/dev/null + +module_load() { + echo "+ module load $1" + module load $1 +} +module_unload() { + echo "+ module unload $1" + module unload $1 +} + +# Unload to be certain +module reset + +# Load modules +module_load PrgEnv-cray/8.3.3 +module_load LUMI/23.03 +# module_load partition/G +module_load rocm/5.2.3 +module_load cce/15.0.1 +module_load cray-libsci/22.08.1.1 +module_load cray-mpich/8.1.18 +module_load craype/2.7.20 +module_load craype-accel-amd-gfx90a +module_load buildtools/23.03 +module_load cray-hdf5/1.12.1.5 +module_load cray-python/3.9.12.1 +module_load Boost/1.81.0-cpeCray-23.03 +module_load partition/G + +module list + +set -x + +export CC=cc CXX=CC FC=ftn + +# Restore tracing to stored setting +{ if [[ -n "$tracing_" ]]; then set -x; else set +x; fi } 2>/dev/null + +export ECBUILD_TOOLCHAIN="./toolchain.cmake" diff --git a/arch/eurohpc/lumi/cray-gpu/15.0.1/toolchain.cmake b/arch/eurohpc/lumi/cray-gpu/15.0.1/toolchain.cmake new file mode 100644 index 00000000..4aed4cdc --- /dev/null +++ b/arch/eurohpc/lumi/cray-gpu/15.0.1/toolchain.cmake @@ -0,0 +1,43 @@ +# (C) Copyright 1988- ECMWF. +# +# This software is licensed under the terms of the Apache Licence Version 2.0 +# which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. +# In applying this licence, ECMWF does not waive the privileges and immunities +# granted to it by virtue of its status as an intergovernmental organisation +# nor does it submit to any jurisdiction. + +#################################################################### +# COMPILER +#################################################################### + +set( ECBUILD_FIND_MPI OFF ) +set( ENABLE_USE_STMT_FUNC ON CACHE STRING "" ) + +#################################################################### +# OpenMP FLAGS +#################################################################### + +set( ENABLE_OMP ON CACHE STRING "" ) +set( OpenMP_C_FLAGS "-homp" CACHE STRING "" ) +set( OpenMP_Fortran_FLAGS "-homp -hnoacc -hlist=aimd -maxrregcount 64" CACHE STRING "" ) + +#################################################################### +# OpenACC FLAGS +#################################################################### + +set( ENABLE_ACC ON CACHE STRING "" ) +set( OpenACC_C_FLAGS "-hacc" ) +set( OpenACC_CXX_FLAGS "-hacc" ) +set( OpenACC_Fortran_FLAGS "-hacc -h acc_model=deep_copy" ) + +#################################################################### +# Compiler FLAGS +#################################################################### + +# General Flags (add to default) +set(ECBUILD_Fortran_FLAGS "-hcontiguous") +set(ECBUILD_Fortran_FLAGS "${ECBUILD_Fortran_FLAGS} -hbyteswapio") +set(ECBUILD_Fortran_FLAGS "${ECBUILD_Fortran_FLAGS} -Wl, --as-needed") + +set(ECBUILD_Fortran_FLAGS_BIT "-O3 -G2 -haggress -DNDEBUG") +# set(ECBUILD_Fortran_FLAGS_BIT "-O3 -hfp1 -hscalar3 -hvector3 -G2 -haggress -DNDEBUG") diff --git a/bundle.yml b/bundle.yml index c087d131..77c26c63 100644 --- a/bundle.yml +++ b/bundle.yml @@ -78,6 +78,10 @@ options : ENABLE_CLOUDSC_GPU_SCC_CUF=ON ENABLE_CLOUDSC_GPU_SCC_CUF_K_CACHING=ON BUILD_field_api=ON + - with-hip : + help: Enable GPU kernel variant based on HIP + cmake: > + ENABLE_CLOUDSC_HIP=ON - with-mpi : help : Enable MPI-parallel kernel diff --git a/src/CMakeLists.txt b/src/CMakeLists.txt index f6789f08..52f7eb9e 100644 --- a/src/CMakeLists.txt +++ b/src/CMakeLists.txt @@ -13,5 +13,6 @@ add_subdirectory(cloudsc_pyiface) add_subdirectory(cloudsc_python) add_subdirectory(cloudsc_c) add_subdirectory(cloudsc_cuda) +add_subdirectory(cloudsc_hip) add_subdirectory(cloudsc_gpu) add_subdirectory(cloudsc_loki) diff --git a/src/cloudsc_hip/CMakeLists.txt b/src/cloudsc_hip/CMakeLists.txt new file mode 100644 index 00000000..768bee1a --- /dev/null +++ b/src/cloudsc_hip/CMakeLists.txt @@ -0,0 +1,168 @@ +# (C) Copyright 1988- ECMWF. +# +# This software is licensed under the terms of the Apache Licence Version 2.0 +# which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. +# In applying this licence, ECMWF does not waive the privileges and immunities +# granted to it by virtue of its status as an intergovernmental organisation +# nor does it submit to any jurisdiction. + +# Define this dwarf variant as an ECBuild feature +ecbuild_add_option( FEATURE CLOUDSC_HIP + DESCRIPTION "Build the HIP version CLOUDSC using Serialbox" DEFAULT OFF + CONDITION Serialbox_FOUND +) + +if( HAVE_CLOUDSC_HIP ) + + + if(NOT DEFINED ROCM_PATH) + if(DEFINED ENV{ROCM_PATH}) + set(ROCM_PATH $ENV{ROCM_PATH} CACHE PATH "Path to which ROCM has been installed") + else() + set(ROCM_PATH "/opt/rocm" CACHE PATH "Path to which ROCM has been installed") + endif() + endif() + + find_package(hip REQUIRED) + + set(CMAKE_C_COMPILER "${ROCM_PATH}/bin/hipcc") + set(CMAKE_CXX_COMPILER "${ROCM_PATH}/bin/hipcc") + # set(CMAKE_HIP_FLAGS "${CMAKE_HIP_FLAGS} -03 -ffast-math") + + ###### SCC-HIP #### + ecbuild_add_library( + TARGET dwarf-cloudsc-hip-lib + INSTALL_HEADERS LISTED + SOURCES + cloudsc/yoecldp_c.h + cloudsc/load_state.h + cloudsc/load_state.cpp + cloudsc/cloudsc_c.h + cloudsc/cloudsc_c.cpp + cloudsc/cloudsc_driver.h + cloudsc/cloudsc_driver.cpp + cloudsc/cloudsc_validate.h + cloudsc/cloudsc_validate.cpp + cloudsc/mycpu.h + cloudsc/mycpu.cpp + PUBLIC_INCLUDES + $ + $ + PUBLIC_LIBS + hip::device + Serialbox::Serialbox_C + $<${HAVE_OMP}:OpenMP::OpenMP_C> + ) + + target_include_directories(dwarf-cloudsc-hip-lib PUBLIC $ $) + target_link_libraries(dwarf-cloudsc-hip-lib PUBLIC hip::device Serialbox::Serialbox_C $<${HAVE_OMP}:OpenMP::OpenMP_C>) + + target_compile_options(dwarf-cloudsc-hip-lib PRIVATE --offload-arch=gfx90a) + + ecbuild_add_executable( + TARGET dwarf-cloudsc-hip + SOURCES dwarf_cloudsc.cpp + LIBS dwarf-cloudsc-hip-lib + ) + + ## + + ###### SCC-HOIST-HIP #### + ecbuild_add_library( + TARGET dwarf-cloudsc-hip-hoist-lib + INSTALL_HEADERS LISTED + SOURCES + cloudsc/yoecldp_c.h + cloudsc/load_state.h + cloudsc/load_state.cpp + cloudsc/cloudsc_c_hoist.h + cloudsc/cloudsc_c_hoist.cpp + cloudsc/cloudsc_driver_hoist.h + cloudsc/cloudsc_driver_hoist.cpp + cloudsc/cloudsc_validate.h + cloudsc/cloudsc_validate.cpp + cloudsc/mycpu.h + cloudsc/mycpu.cpp + PUBLIC_INCLUDES + $ + $ + PUBLIC_LIBS + hip::device + Serialbox::Serialbox_C + $<${HAVE_OMP}:OpenMP::OpenMP_C> + ) + + target_include_directories(dwarf-cloudsc-hip-hoist-lib PUBLIC $ $) + target_link_libraries(dwarf-cloudsc-hip-hoist-lib PUBLIC hip::device Serialbox::Serialbox_C $<${HAVE_OMP}:OpenMP::OpenMP_C>) + + target_compile_options(dwarf-cloudsc-hip-hoist-lib PRIVATE --offload-arch=gfx90a) + + ecbuild_add_executable( + TARGET dwarf-cloudsc-hip-hoist + SOURCES dwarf_cloudsc.cpp + LIBS dwarf-cloudsc-hip-hoist-lib + ) + + ## + + ###### SCC-K-CACHING-HIP #### + ecbuild_add_library( + TARGET dwarf-cloudsc-hip-k-caching-lib + INSTALL_HEADERS LISTED + SOURCES + cloudsc/yoecldp_c.h + cloudsc/load_state.h + cloudsc/load_state.cpp + cloudsc/cloudsc_c_k_caching.h + cloudsc/cloudsc_c_k_caching.cpp + cloudsc/cloudsc_driver.h + cloudsc/cloudsc_driver.cpp + cloudsc/cloudsc_validate.h + cloudsc/cloudsc_validate.cpp + cloudsc/mycpu.h + cloudsc/mycpu.cpp + PUBLIC_INCLUDES + $ + $ + PUBLIC_LIBS + hip::device + Serialbox::Serialbox_C + $<${HAVE_OMP}:OpenMP::OpenMP_C> + ) + + target_include_directories(dwarf-cloudsc-hip-k-caching-lib PUBLIC $ $) + target_link_libraries(dwarf-cloudsc-hip-k-caching-lib PUBLIC hip::device Serialbox::Serialbox_C $<${HAVE_OMP}:OpenMP::OpenMP_C>) + + target_compile_options(dwarf-cloudsc-hip-k-caching-lib PRIVATE --offload-arch=gfx90a) + + ecbuild_add_executable( + TARGET dwarf-cloudsc-hip-k-caching + SOURCES dwarf_cloudsc.cpp + LIBS dwarf-cloudsc-hip-k-caching-lib + ) + + ## + + + + # Create symlink for the input data + execute_process(COMMAND ${CMAKE_COMMAND} -E create_symlink + ${CMAKE_CURRENT_SOURCE_DIR}/../../data ${CMAKE_CURRENT_BINARY_DIR}/../../../data ) + + ecbuild_add_test( + TARGET dwarf-cloudsc-hip-serial + COMMAND bin/dwarf-cloudsc-hip + ARGS 1 100 16 + WORKING_DIRECTORY ${CMAKE_CURRENT_BINARY_DIR}/../../.. + OMP 1 + ) + ecbuild_add_test( + TARGET dwarf-cloudsc-hip-omp + COMMAND bin/dwarf-cloudsc-hip + ARGS 4 100 16 + WORKING_DIRECTORY ${CMAKE_CURRENT_BINARY_DIR}/../../.. + OMP 4 + CONDITION HAVE_OMP + ) + +endif() diff --git a/src/cloudsc_hip/cloudsc/cloudsc_c.cpp b/src/cloudsc_hip/cloudsc/cloudsc_c.cpp new file mode 100644 index 00000000..1bca62cc --- /dev/null +++ b/src/cloudsc_hip/cloudsc/cloudsc_c.cpp @@ -0,0 +1,2632 @@ +#include "hip/hip_runtime.h" +/* + * (C) Copyright 1988- ECMWF. + * + * This software is licensed under the terms of the Apache Licence Version 2.0 + * which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. + * In applying this licence, ECMWF does not waive the privileges and immunities + * granted to it by virtue of its status as an intergovernmental organisation + * nor does it submit to any jurisdiction. + */ +#include "cloudsc_c.h" +#include + +__global__ void cloudsc_c(int kidia, int kfdia, int klon, double ptsphy, + const double * __restrict__ pt, + const double * __restrict__ pq, const double * __restrict__ tendency_tmp_t, + const double * __restrict__ tendency_tmp_q, const double * __restrict__ tendency_tmp_a, + const double * __restrict__ tendency_tmp_cld, double * __restrict__ tendency_loc_t, + double * __restrict__ tendency_loc_q, double * __restrict__ tendency_loc_a, + double * __restrict__ tendency_loc_cld, const double * __restrict__ pvfa, + const double * __restrict__ pvfl, const double * __restrict__ pvfi, const double * __restrict__ pdyna, + const double * __restrict__ pdynl, const double * __restrict__ pdyni, const double * __restrict__ phrsw, + double * __restrict__ phrlw, const double * __restrict__ pvervel, const double * __restrict__ pap, + const double * __restrict__ paph, const double * __restrict__ plsm, + const int * ktype, const double * __restrict__ plu, double * __restrict__ plude, + const double * __restrict__ psnde, const double * __restrict__ pmfu, const double * __restrict__ pmfd, + const double * __restrict__ pa, const double * __restrict__ pclv, const double * __restrict__ psupsat, + const double * __restrict__ plcrit_aer, const double * __restrict__ picrit_aer, + const double * __restrict__ pre_ice, const double * __restrict__ pccn, const double * __restrict__ pnice, + double * __restrict__ pcovptot, double * __restrict__ prainfrac_toprfz, + double * __restrict__ pfsqlf, double * __restrict__ pfsqif, double * __restrict__ pfcqnng, + double * __restrict__ pfcqlng, double * __restrict__ pfsqrf, double * __restrict__ pfsqsf, + double * __restrict__ pfcqrng, double * __restrict__ pfcqsng, + double * __restrict__ pfsqltur, double * __restrict__ pfsqitur, + double * __restrict__ pfplsl, double * __restrict__ pfplsn, double * __restrict__ pfhpsl, + double * __restrict__ pfhpsn, struct TECLDP *yrecldp, int ngpblks, + double rg, double rd, double rcpd, double retv, double rlvtt, double rlstt, double rlmlt, double rtt, + double rv, double r2es, double r3les, double r3ies, double r4les, double r4ies, double r5les, + double r5ies, double r5alvcp, double r5alscp, double ralvdcp, double ralsdcp, double ralfdcp, + double rtwat, double rtice, double rticecu, double rtwat_rtice_r, double rtwat_rticecu_r, + double rkoop1, double rkoop2) { + + //------------------------------------------------------------------------------- + // Declare input/output arguments + //------------------------------------------------------------------------------- + + // PLCRIT_AER : critical liquid mmr for rain autoconversion process + // PICRIT_AER : critical liquid mmr for snow autoconversion process + // PRE_LIQ : liq Re + // PRE_ICE : ice Re + // PCCN : liquid cloud condensation nuclei + // PNICE : ice number concentration (cf. CCN) + + const int klev = 137; // Number of levels + + double zlcond1, zlcond2, zlevapl, zlevapi, zrainaut, zsnowaut, zliqcld, zicecld; + double zlevap, zleros; + // condensation and evaporation terms + // autoconversion terms + double zfokoop; + double zfoealfa[klev + 1]; + double zicenuclei; // number concentration of ice nuclei + + double zlicld; + double zacond; + double zaeros; + double zlfinalsum; + double zdqs; + double ztold; + double zqold; + double zdtgdp; + double zrdtgdp; + double ztrpaus; + double zcovpclr; + double zpreclr; + double zcovptot; + double zcovpmax; + double zqpretot; + double zdpevap; + double zdtforc; + double zdtdiab; + double ztp1[klev]; + double zldefr; + double zldifdt; + double zdtgdpf; + double zlcust[5]; + double zacust; + double zmf; + + double zrho; + double ztmp1, ztmp2, ztmp3; + double ztmp4, ztmp5, ztmp6, ztmp7; + double zalfawm; + + // Accumulators of A,B,and C factors for cloud equations + double zsolab; // -ve implicit CC + double zsolac; // linear CC + double zanew; + double zanewm1; + + double zgdp; + + //---for flux calculation + double zda; + double zli[klev], za[klev]; + double zaorig[klev]; // start of scheme value for CC + + int llflag; + int llo1; + + int icall, ik, jk, jl, jm, jn, jo, jlen, is; + + double zdp, zpaphd; + + double zalfa; + // & ZALFACU, ZALFALS + double zalfaw; + double zbeta, zbeta1; + //REAL(KIND=JPRB) :: ZBOTT + double zcfpr; + double zcor; + double zcdmax; + double zmin; + double zlcondlim; + double zdenom; + double zdpmxdt; + double zdpr; + double zdtdp; + double ze; + double zepsec; + double zfac, zfaci, zfacw; + double zgdcp; + double zinew; + double zlcrit; + double zmfdn; + double zprecip; + double zqe; + double zqsat, zqtmst, zrdcp; + double zrhc, zsig, zsigk; + double zwtot; + double zzco, zzdl, zzrh, zzzdt, zqadj; + double zqnew, ztnew; + double zrg_r, zgdph_r, zcons1, zcond, zcons1a; + double zlfinal; + double zmelt; + double zevap; + double zfrz; + double zvpliq, zvpice; + double zadd, zbdd, zcvds, zice0, zdepos; + double zsupsat; + double zfall; + double zre_ice; + double zrldcp; + double zqp1env; + + //---------------------------- + // Arrays for new microphysics + //---------------------------- + int iphase[5]; // marker for water phase of each species + // 0=vapour, 1=liquid, 2=ice + + int imelt[5]; // marks melting linkage for ice categories + // ice->liquid, snow->rain + + int llfall[5]; // marks falling species + // LLFALL=0, cloud cover must > 0 for zqx > 0 + // LLFALL=1, no cloud needed, zqx can evaporate + + int llindex1[5]; // index variable + int llindex3[5 * 5]; // index variable + double zmax; + double zrat; + int iorder[5]; // array for sorting explicit terms + + double zliqfrac[klev]; // cloud liquid water fraction: ql/(ql+qi) + double zicefrac[klev]; // cloud ice water fraction: qi/(ql+qi) + double zqxn[5]; // new values for zqx at time+1 + double zqxfg[5]; // first guess values including precip + double zqxnm1[5]; // new values for zqx at time+1 at level above + double zfluxq[5]; // fluxes convergence of species (needed?) + // Keep the following for possible future total water variance scheme? + //REAL(KIND=JPRB) :: ZTL(KLON,KLEV) ! liquid water temperature + //REAL(KIND=JPRB) :: ZABETA(KLON,KLEV) ! cloud fraction + //REAL(KIND=JPRB) :: ZVAR(KLON,KLEV) ! temporary variance + //REAL(KIND=JPRB) :: ZQTMIN(KLON,KLEV) + //REAL(KIND=JPRB) :: ZQTMAX(KLON,KLEV) + + double zmeltmax; + double zfrzmax; + double zicetot; + + + double zqsmix[klev]; // diagnostic mixed phase saturation + //REAL(KIND=JPRB) :: ZQSBIN(KLON,KLEV) ! binary switched ice/liq saturation + double zqsliq[klev]; // liquid water saturation + double zqsice[klev]; // ice water saturation + + //REAL(KIND=JPRB) :: ZRHM(KLON,KLEV) ! diagnostic mixed phase RH + //REAL(KIND=JPRB) :: ZRHL(KLON,KLEV) ! RH wrt liq + //REAL(KIND=JPRB) :: ZRHI(KLON,KLEV) ! RH wrt ice + + double zfoeewmt[klev]; + double zfoeew[klev]; + double zfoeeliqt[klev]; + //REAL(KIND=JPRB) :: ZFOEEICET(KLON,KLEV) + + double zdqsliqdt, zdqsicedt, zdqsmixdt; + double zcorqsliq; + double zcorqsice; + //REAL(KIND=JPRB) :: ZCORQSBIN(KLON) + double zcorqsmix; + double zevaplimliq, zevaplimice, zevaplimmix; + + //------------------------------------------------------- + // SOURCE/SINK array for implicit and explicit terms + //------------------------------------------------------- + // a POSITIVE value entered into the arrays is a... + // Source of this variable + // | + // | Sink of this variable + // | | + // V V + // ZSOLQA(JL,IQa,IQb) = explicit terms + // ZSOLQB(JL,IQa,IQb) = implicit terms + // Thus if ZSOLAB(JL,NCLDQL,IQV)=K where K>0 then this is + // a source of NCLDQL and a sink of IQV + // put 'magic' source terms such as PLUDE from + // detrainment into explicit source/sink array diagnognal + // ZSOLQA(NCLDQL,NCLDQL)= -PLUDE + // i.e. A positive value is a sink!????? weird... + //------------------------------------------------------- + + double zsolqa[5 * 5]; // explicit sources and sinks + double zsolqb[5 * 5]; // implicit sources and sinks + // e.g. microphysical pathways between ice variables. + double zqlhs[5 * 5]; // n x n matrix storing the LHS of implicit solver + double zvqx[5]; // fall speeds of three categories + double zexplicit; + double zratio[5], zsinksum[5]; + + // for sedimentation source/sink terms + double zfallsink[5]; + double zfallsrce[5]; + + // for convection detrainment source and subsidence source/sink terms + double zconvsrce[5]; + double zconvsink[5]; + + // for supersaturation source term from previous timestep + double zpsupsatsrce[5]; + + // Numerical fit to wet bulb temperature + double ztw1 = (double) 1329.31; + double ztw2 = (double) 0.0074615; + double ztw3 = (double) 0.85E5; + double ztw4 = (double) 40.637; + double ztw5 = (double) 275.0; + + double zsubsat; // Subsaturation for snow melting term + double ztdmtw0; // Diff between dry-bulb temperature and + // temperature when wet-bulb = 0degC + + // Variables for deposition term + double ztcg; // Temperature dependent function for ice PSD + double zfacx1i, zfacx1s; // PSD correction factor + double zaplusb, zcorrfac, zcorrfac2, zpr02, zterm1, zterm2; // for ice dep + double zcldtopdist; // Distance from cloud top + double zinfactor; // No. of ice nuclei factor for deposition + + // Autoconversion/accretion/riming/evaporation + int iwarmrain; + int ievaprain; + int ievapsnow; + int idepice; + double zrainacc; + double zraincld; + double zsnowrime; + double zsnowcld; + double zesatliq; + double zfallcorr; + double zlambda; + double zevap_denom; + double zcorr2; + double zka; + double zconst; + double ztemp; + + // Rain freezing + int llrainliq; // True if majority of raindrops are liquid (no ice core) + + //---------------------------- + // End: new microphysics + //---------------------------- + + //---------------------- + // SCM budget statistics + //---------------------- + double zrain; + + double zhook_handle; + double ztmpl, ztmpi, ztmpa; + + double zmm, zrr; + double zrg; + + double zzsum, zzratio; + double zepsilon; + + double zcond1, zqp; + + double psum_solqa; + int ibl; + int i_llfall_0; + double zqx[5 * klev]; + double zqx0[5 * klev]; + double zpfplsx[5 * (klev + 1)]; + double zlneg[5 * klev]; + double zqxn2d[5 * klev]; + + jl = threadIdx.x; + ibl = blockIdx.x; + + + //=============================================================================== + //IF (LHOOK) CALL DR_HOOK('CLOUDSC',0,ZHOOK_HANDLE) + + //=============================================================================== + // 0.0 Beginning of timestep book-keeping + //---------------------------------------------------------------------- + + + //###################################################################### + // 0. *** SET UP CONSTANTS *** + //###################################################################### + + zepsilon = (double) 100.*DBL_EPSILON; + + // --------------------------------------------------------------------- + // Set version of warm-rain autoconversion/accretion + // IWARMRAIN = 1 ! Sundquist + // IWARMRAIN = 2 ! Khairoutdinov and Kogan (2000) + // --------------------------------------------------------------------- + iwarmrain = 2; + // --------------------------------------------------------------------- + // Set version of rain evaporation + // IEVAPRAIN = 1 ! Sundquist + // IEVAPRAIN = 2 ! Abel and Boutle (2013) + // --------------------------------------------------------------------- + ievaprain = 2; + // --------------------------------------------------------------------- + // Set version of snow evaporation + // IEVAPSNOW = 1 ! Sundquist + // IEVAPSNOW = 2 ! New + // --------------------------------------------------------------------- + ievapsnow = 1; + // --------------------------------------------------------------------- + // Set version of ice deposition + // IDEPICE = 1 ! Rotstayn (2001) + // IDEPICE = 2 ! New + // --------------------------------------------------------------------- + idepice = 1; + + // --------------------- + // Some simple constants + // --------------------- + zqtmst = (double) 1.0 / ptsphy; + zgdcp = rg / rcpd; + zrdcp = rd / rcpd; + zcons1a = rcpd / (rlmlt*rg*(*yrecldp).rtaumel); + zepsec = (double) 1.E-14; + zrg_r = (double) 1.0 / rg; + zrldcp = (double) 1.0 / (ralsdcp - ralvdcp); + + // Note: Defined in module/yoecldp.F90 + // NCLDQL=1 ! liquid cloud water + // NCLDQI=2 ! ice cloud water + // NCLDQR=3 ! rain water + // NCLDQS=4 ! snow + // NCLDQV=5 ! vapour + + // ----------------------------------------------- + // Define species phase, 0=vapour, 1=liquid, 2=ice + // ----------------------------------------------- + iphase[4] = 0; + iphase[0] = 1; + iphase[2] = 1; + iphase[1] = 2; + iphase[3] = 2; + + // --------------------------------------------------- + // Set up melting/freezing index, + // if an ice category melts/freezes, where does it go? + // --------------------------------------------------- + imelt[4] = -99; + imelt[0] = 2; + imelt[2] = 4; + imelt[1] = 3; + imelt[3] = 3; + + // ----------------------------------------------- + // INITIALIZATION OF OUTPUT TENDENCIES + // ----------------------------------------------- + for (jk = 0; jk <= klev + -1; jk += 1) { + tendency_loc_t[jl + klon*(jk + klev*(ibl))] = (double) 0.0; + tendency_loc_q[jl + klon*(jk + klev*(ibl))] = (double) 0.0; + tendency_loc_a[jl + klon*(jk + klev*(ibl))] = (double) 0.0; + } + for (jm = 0; jm <= 5 - 1 + -1; jm += 1) { + for (jk = 0; jk <= klev + -1; jk += 1) { + tendency_loc_cld[jl + klon*(jk + klev*(jm + 5*(ibl)))] = (double) 0.0; + } + } + + //-- These were uninitialized : meaningful only when we compare error differences + for (jk = 0; jk <= klev + -1; jk += 1) { + pcovptot[jl + klon*(jk + klev*(ibl))] = (double) 0.0; + tendency_loc_cld[jl + klon*(jk + klev*(4 + 5*(ibl)))] = (double) 0.0 + ; + } + + // ------------------------- + // set up fall speeds in m/s + // ------------------------- + zvqx[4] = (double) 0.0; + zvqx[0] = (double) 0.0; + zvqx[1] = (*yrecldp).rvice; + zvqx[2] = (*yrecldp).rvrain; + zvqx[3] = (*yrecldp).rvsnow; + for (i_llfall_0 = 0; i_llfall_0 <= 5 + -1; i_llfall_0 += 1) { + llfall[i_llfall_0] = false; + } + for (jm = 0; jm <= 5 + -1; jm += 1) { + if (zvqx[jm] > (double) 0.0) { + llfall[jm] = true; + } + // falling species + } + // Set LLFALL to false for ice (but ice still sediments!) + // Need to rationalise this at some point + llfall[1] = false; + + + //###################################################################### + // 1. *** INITIAL VALUES FOR VARIABLES *** + //###################################################################### + + + // ---------------------- + // non CLV initialization + // ---------------------- + for (jk = 0; jk <= klev + -1; jk += 1) { + ztp1[jk] = pt[jl + klon*(jk + klev*(ibl))] + ptsphy*tendency_tmp_t[ + jl + klon*(jk + klev*(ibl))]; + zqx[jk + klev*(4)] = pq[jl + klon*(jk + klev*(ibl))] + + ptsphy*tendency_tmp_q[jl + klon*(jk + klev*(ibl))]; + zqx0[jk + klev*(4)] = pq[jl + klon*(jk + klev*(ibl))] + + ptsphy*tendency_tmp_q[jl + klon*(jk + klev*(ibl))]; + za[jk] = pa[jl + klon*(jk + klev*(ibl))] + ptsphy*tendency_tmp_a[jl + + klon*(jk + klev*(ibl))]; + zaorig[jk] = pa[jl + klon*(jk + klev*(ibl))] + ptsphy*tendency_tmp_a[ + jl + klon*(jk + klev*(ibl))]; + } + + // ------------------------------------- + // initialization for CLV family + // ------------------------------------- + for (jm = 0; jm <= 5 - 1 + -1; jm += 1) { + for (jk = 0; jk <= klev + -1; jk += 1) { + zqx[jk + klev*jm] = pclv[jl + klon*(jk + klev*(jm + 5*(ibl)))] + + ptsphy*tendency_tmp_cld[jl + klon*(jk + klev*(jm + 5*(ibl)))]; + zqx0[jk + klev*jm] = pclv[jl + klon*(jk + klev*(jm + 5*(ibl)))] + + ptsphy*tendency_tmp_cld[jl + klon*(jk + klev*(jm + 5*(ibl)))]; + } + } + + //------------- + // zero arrays + //------------- + for (jm = 0; jm <= 5 + -1; jm += 1) { + for (jk = 0; jk <= klev + 1 + -1; jk += 1) { + zpfplsx[jk + (klev + 1)*jm] = (double) 0.0; // precip fluxes + } + } + + for (jm = 0; jm <= 5 + -1; jm += 1) { + for (jk = 0; jk <= klev + -1; jk += 1) { + zqxn2d[jk + klev*jm] = (double) 0.0; // end of timestep values in 2D + zlneg[jk + klev*jm] = (double) 0.0; // negative input check + } + } + + prainfrac_toprfz[jl + klon*(ibl)] = (double) 0.0; // rain fraction at top of refreezing layer + llrainliq = true; // Assume all raindrops are liquid initially + + // ---------------------------------------------------- + // Tidy up very small cloud cover or total cloud water + // ---------------------------------------------------- + for (jk = 0; jk <= klev + -1; jk += 1) { + if (zqx[jk + klev*(0)] + zqx[jk + klev*(1)] < (*yrecldp).rlmin || za[jk] + < (*yrecldp).ramin) { + + // Evaporate small cloud liquid water amounts + zlneg[jk + klev*(0)] = zlneg[jk + klev*(0)] + zqx[jk + klev*(0)]; + zqadj = zqx[jk + klev*(0)]*zqtmst; + tendency_loc_q[jl + klon*(jk + klev*(ibl))] = + tendency_loc_q[jl + klon*(jk + klev*(ibl))] + zqadj; + tendency_loc_t[jl + klon*(jk + klev*(ibl))] = + tendency_loc_t[jl + klon*(jk + klev*(ibl))] - ralvdcp*zqadj; + zqx[jk + klev*(4)] = zqx[jk + klev*(4)] + zqx[jk + klev*(0)]; + zqx[jk + klev*(0)] = (double) 0.0; + + // Evaporate small cloud ice water amounts + zlneg[jk + klev*(1)] = zlneg[jk + klev*(1)] + zqx[jk + klev*(1)]; + zqadj = zqx[jk + klev*(1)]*zqtmst; + tendency_loc_q[jl + klon*(jk + klev*(ibl))] = + tendency_loc_q[jl + klon*(jk + klev*(ibl))] + zqadj; + tendency_loc_t[jl + klon*(jk + klev*(ibl))] = + tendency_loc_t[jl + klon*(jk + klev*(ibl))] - ralsdcp*zqadj; + zqx[jk + klev*(4)] = zqx[jk + klev*(4)] + zqx[jk + klev*(1)]; + zqx[jk + klev*(1)] = (double) 0.0; + + // Set cloud cover to zero + za[jk] = (double) 0.0; + + } + } + + // --------------------------------- + // Tidy up small CLV variables + // --------------------------------- + //DIR$ IVDEP + for (jm = 0; jm <= 5 - 1 + -1; jm += 1) { + //DIR$ IVDEP + for (jk = 0; jk <= klev + -1; jk += 1) { + //DIR$ IVDEP + if (zqx[jk + klev*jm] < (*yrecldp).rlmin) { + zlneg[jk + klev*jm] = zlneg[jk + klev*jm] + zqx[jk + klev*jm]; + zqadj = zqx[jk + klev*jm]*zqtmst; + tendency_loc_q[jl + klon*(jk + klev*(ibl))] = + tendency_loc_q[jl + klon*(jk + klev*(ibl))] + zqadj; + if (iphase[jm] == 1) { + tendency_loc_t[jl + klon*(jk + klev*(ibl))] = + tendency_loc_t[jl + klon*(jk + klev*(ibl))] - ralvdcp*zqadj; + } + if (iphase[jm] == 2) { + tendency_loc_t[jl + klon*(jk + klev*(ibl))] = + tendency_loc_t[jl + klon*(jk + klev*(ibl))] - ralsdcp*zqadj; + } + zqx[jk + klev*(4)] = zqx[jk + klev*(4)] + zqx[jk + klev*jm]; + zqx[jk + klev*jm] = (double) 0.0; + } + } + } + + + // ------------------------------ + // Define saturation values + // ------------------------------ + for (jk = 0; jk <= klev + -1; jk += 1) { + //---------------------------------------- + // old *diagnostic* mixed phase saturation + //---------------------------------------- + zfoealfa[jk] = ((double)(fmin(1.0, pow((fmax(rtice, fmin(rtwat, ztp1[jk])) - rtice)*rtwat_rtice_r, 2)))); + zfoeewmt[jk] = + fmin(((double)(r2es*((double)(fmin(1.0, pow((fmax(rtice, fmin(rtwat, ztp1[jk])) - rtice)*rtwat_rtice_r, 2)))*exp((r3les*(ztp1[jk] - rtt))/(ztp1[jk] - r4les)) + (1.0 - (double)(fmin(1.0, pow((fmax(rtice, fmin(rtwat, ztp1[jk])) - rtice)*rtwat_rtice_r, 2))))*exp((r3ies*(ztp1[jk] - rtt))/(ztp1[jk] - r4ies))))) / pap[jl + klon*(jk + klev*(ibl))], (double) 0.5); + zqsmix[jk] = zfoeewmt[jk]; + zqsmix[jk] = zqsmix[jk] / ((double) 1.0 - retv*zqsmix[jk]); + + //--------------------------------------------- + // ice saturation T<273K + // liquid water saturation for T>273K + //--------------------------------------------- + zalfa = ((double)(fmax(0.0, copysign(1.0, ztp1[jk] - rtt)))); + zfoeew[jk] = fmin((zalfa*((double)(r2es*exp((r3les*(ztp1[jk] - rtt))/(ztp1[jk] - r4les)))) + ((double) 1.0 - zalfa)*((double)(r2es*exp((r3ies*(ztp1[jk] - rtt))/(ztp1[jk] - r4ies))))) / pap[jl + + klon*(jk + klev*(ibl))], (double) 0.5); + zfoeew[jk] = fmin((double) 0.5, zfoeew[jk]); + zqsice[jk] = zfoeew[jk] / ((double) 1.0 - retv*zfoeew[jk]); + + //---------------------------------- + // liquid water saturation + //---------------------------------- + zfoeeliqt[jk] = + fmin(((double)(r2es*exp((r3les*(ztp1[jk] - rtt))/(ztp1[jk] - r4les)))) / pap[jl + klon*(jk + klev*(ibl))], (double) 0.5); + zqsliq[jk] = zfoeeliqt[jk]; + zqsliq[jk] = zqsliq[jk] / ((double) 1.0 - retv*zqsliq[jk]); + + // !---------------------------------- + // ! ice water saturation + // !---------------------------------- + // ZFOEEICET(JL,JK)=MIN(((double)(r2es*exp((r3ies*(ztp1[jk] - rtt))/(ztp1[jk] - r4ies))))(ZTP1(JL,JK))/PAP(JL,JK),0.5_JPRB) + // ZQSICE(JL,JK)=ZFOEEICET(JL,JK) + // ZQSICE(JL,JK)=ZQSICE(JL,JK)/(1.0_JPRB-RETV*ZQSICE(JL,JK)) + + } + + for (jk = 0; jk <= klev + -1; jk += 1) { + + + //------------------------------------------ + // Ensure cloud fraction is between 0 and 1 + //------------------------------------------ + za[jk] = fmax((double) 0.0, fmin((double) 1.0, za[jk])); + + //------------------------------------------------------------------- + // Calculate liq/ice fractions (no longer a diagnostic relationship) + //------------------------------------------------------------------- + zli[jk] = zqx[jk + klev*(0)] + zqx[jk + klev*(1)]; + if (zli[jk] > (*yrecldp).rlmin) { + zliqfrac[jk] = zqx[jk + klev*(0)] / zli[jk]; + zicefrac[jk] = (double) 1.0 - zliqfrac[jk]; + } else { + zliqfrac[jk] = (double) 0.0; + zicefrac[jk] = (double) 0.0; + } + + } + + //###################################################################### + // 2. *** CONSTANTS AND PARAMETERS *** + //###################################################################### + // Calculate L in updrafts of bl-clouds + // Specify QS, P/PS for tropopause (for c2) + // And initialize variables + //------------------------------------------ + + //--------------------------------- + // Find tropopause level (ZTRPAUS) + //--------------------------------- + ztrpaus = (double) 0.1; + zpaphd = (double) 1.0 / paph[jl + klon*(klev + (klev + 1)*(ibl))]; + for (jk = 0; jk <= klev - 1 + -1; jk += 1) { + zsig = pap[jl + klon*(jk + klev*(ibl))]*zpaphd; + if (zsig > (double) 0.1 && zsig < (double) 0.4 && ztp1[jk] > ztp1[1 + jk]) { + ztrpaus = zsig; + } + } + + //----------------------------- + // Reset single level variables + //----------------------------- + + zanewm1 = (double) 0.0; + zda = (double) 0.0; + zcovpclr = (double) 0.0; + zcovpmax = (double) 0.0; + zcovptot = (double) 0.0; + zcldtopdist = (double) 0.0; + + //###################################################################### + // 3. *** PHYSICS *** + //###################################################################### + + + //---------------------------------------------------------------------- + // START OF VERTICAL LOOP + //---------------------------------------------------------------------- + + for (jk = -1 + (*yrecldp).ncldtop; jk <= klev + -1; jk += 1) { + + //---------------------------------------------------------------------- + // 3.0 INITIALIZE VARIABLES + //---------------------------------------------------------------------- + + //--------------------------------- + // First guess microphysics + //--------------------------------- + for (jm = 0; jm <= 5 + -1; jm += 1) { + zqxfg[jm] = zqx[jk + klev*jm]; + } + + //--------------------------------- + // Set KLON arrays to zero + //--------------------------------- + + zlicld = (double) 0.0; + zrainaut = (double) 0.0; // currently needed for diags + zrainacc = (double) 0.0; // currently needed for diags + zsnowaut = (double) 0.0; // needed + zldefr = (double) 0.0; + zacust = (double) 0.0; // set later when needed + zqpretot = (double) 0.0; + zlfinalsum = (double) 0.0; + + // Required for first guess call + zlcond1 = (double) 0.0; + zlcond2 = (double) 0.0; + zsupsat = (double) 0.0; + zlevapl = (double) 0.0; + zlevapi = (double) 0.0; + + //------------------------------------- + // solvers for cloud fraction + //------------------------------------- + zsolab = (double) 0.0; + zsolac = (double) 0.0; + + zicetot = (double) 0.0; + + //------------------------------------------ + // reset matrix so missing pathways are set + //------------------------------------------ + for (jm = 0; jm <= 5 + -1; jm += 1) { + for (jn = 0; jn <= 5 + -1; jn += 1) { + zsolqb[jn + 5*jm] = (double) 0.0; + zsolqa[jn + 5*jm] = (double) 0.0; + } + } + + //---------------------------------- + // reset new microphysics variables + //---------------------------------- + for (jm = 0; jm <= 5 + -1; jm += 1) { + zfallsrce[jm] = (double) 0.0; + zfallsink[jm] = (double) 0.0; + zconvsrce[jm] = (double) 0.0; + zconvsink[jm] = (double) 0.0; + zpsupsatsrce[jm] = (double) 0.0; + zratio[jm] = (double) 0.0; + } + + + //------------------------- + // derived variables needed + //------------------------- + + zdp = paph[jl + klon*(1 + jk + (klev + 1)*(ibl))] - paph[jl + + klon*(jk + (klev + 1)*(ibl))]; // dp + zgdp = rg / zdp; // g/dp + zrho = pap[jl + klon*(jk + klev*(ibl))] / (rd*ztp1[jk]); // p/RT air density + + zdtgdp = ptsphy*zgdp; // dt g/dp + zrdtgdp = zdp*((double) 1.0 / (ptsphy*rg)); // 1/(dt g/dp) + + if (jk + 1 > 1) { + zdtgdpf = ptsphy*rg / (pap[jl + klon*(jk + klev*(ibl))] - pap[jl + + klon*(-1 + jk + klev*(ibl))]); + } + + //------------------------------------ + // Calculate dqs/dT correction factor + //------------------------------------ + // Reminder: RETV=RV/RD-1 + + // liquid + zfacw = r5les / (pow((ztp1[jk] - r4les), 2)); + zcor = (double) 1.0 / ((double) 1.0 - retv*zfoeeliqt[jk]); + zdqsliqdt = zfacw*zcor*zqsliq[jk]; + zcorqsliq = (double) 1.0 + ralvdcp*zdqsliqdt; + + // ice + zfaci = r5ies / (pow((ztp1[jk] - r4ies), 2)); + zcor = (double) 1.0 / ((double) 1.0 - retv*zfoeew[jk]); + zdqsicedt = zfaci*zcor*zqsice[jk]; + zcorqsice = (double) 1.0 + ralsdcp*zdqsicedt; + + // diagnostic mixed + zalfaw = zfoealfa[jk]; + zalfawm = zalfaw; + zfac = zalfaw*zfacw + ((double) 1.0 - zalfaw)*zfaci; + zcor = (double) 1.0 / ((double) 1.0 - retv*zfoeewmt[jk]); + zdqsmixdt = zfac*zcor*zqsmix[jk]; + zcorqsmix = (double) 1.0 + ((double)((double)(fmin(1.0, pow((fmax(rtice, fmin(rtwat, ztp1[jk])) - rtice)*rtwat_rtice_r, 2)))*ralvdcp + (1.0 - (double)(fmin(1.0, pow((fmax(rtice, fmin(rtwat, ztp1[jk])) - rtice)*rtwat_rtice_r, 2))))*ralsdcp))*zdqsmixdt; + + // evaporation/sublimation limits + zevaplimmix = + fmax((zqsmix[jk] - zqx[jk + klev*(4)]) / zcorqsmix, (double) 0.0); + zevaplimliq = + fmax((zqsliq[jk] - zqx[jk + klev*(4)]) / zcorqsliq, (double) 0.0); + zevaplimice = + fmax((zqsice[jk] - zqx[jk + klev*(4)]) / zcorqsice, (double) 0.0); + + //-------------------------------- + // in-cloud consensate amount + //-------------------------------- + ztmpa = (double) 1.0 / fmax(za[jk], zepsec); + zliqcld = zqx[jk + klev*(0)]*ztmpa; + zicecld = zqx[jk + klev*(1)]*ztmpa; + zlicld = zliqcld + zicecld; + + + //------------------------------------------------ + // Evaporate very small amounts of liquid and ice + //------------------------------------------------ + + if (zqx[jk + klev*(0)] < (*yrecldp).rlmin) { + zsolqa[4 + 5*(0)] = zqx[jk + klev*(0)]; + zsolqa[0 + 5*(4)] = -zqx[jk + klev*(0)]; + } + + if (zqx[jk + klev*(1)] < (*yrecldp).rlmin) { + zsolqa[4 + 5*(1)] = zqx[jk + klev*(1)]; + zsolqa[1 + 5*(4)] = -zqx[jk + klev*(1)]; + } + + + //--------------------------------------------------------------------- + // 3.1 ICE SUPERSATURATION ADJUSTMENT + //--------------------------------------------------------------------- + // Note that the supersaturation adjustment is made with respect to + // liquid saturation: when T>0C + // ice saturation: when T<0C + // with an adjustment made to allow for ice + // supersaturation in the clear sky + // Note also that the KOOP factor automatically clips the supersaturation + // to a maximum set by the liquid water saturation mixing ratio + // important for temperatures near to but below 0C + //----------------------------------------------------------------------- + + //DIR$ NOFUSION + + //----------------------------------- + // 3.1.1 Supersaturation limit (from Koop) + //----------------------------------- + // Needs to be set for all temperatures + zfokoop = ((double)(fmin(rkoop1 - rkoop2*ztp1[jk], (double)(r2es*exp((r3les*(ztp1[jk] - rtt))/(ztp1[jk] - r4les)))*1.0/(double)(r2es*exp((r3ies*(ztp1[jk] - rtt))/(ztp1[jk] - r4ies)))))); + + if (ztp1[jk] >= rtt || (*yrecldp).nssopt == 0) { + zfac = (double) 1.0; + zfaci = (double) 1.0; + } else { + zfac = za[jk] + zfokoop*((double) 1.0 - za[jk]); + zfaci = ptsphy / (*yrecldp).rkooptau; + } + + //------------------------------------------------------------------- + // 3.1.2 Calculate supersaturation wrt Koop including dqs/dT + // correction factor + // [#Note: QSICE or QSLIQ] + //------------------------------------------------------------------- + + // Calculate supersaturation to add to cloud + if (za[jk] > (double) 1.0 - (*yrecldp).ramin) { + zsupsat = + fmax((zqx[jk + klev*(4)] - zfac*zqsice[jk]) / zcorqsice, (double) 0.0); + } else { + // Calculate environmental humidity supersaturation + zqp1env = (zqx[jk + klev*(4)] - za[jk]*zqsice[jk]) / fmax((double) 1.0 - + za[jk], zepsilon); + //& SIGN(MAX(ABS(1.0_JPRB-ZA(JL,JK)),ZEPSILON),1.0_JPRB-ZA(JL,JK)) + zsupsat = fmax(((double) 1.0 - za[jk])*(zqp1env - zfac*zqsice[jk]) / zcorqsice, + (double) 0.0); + } + + //------------------------------------------------------------------- + // Here the supersaturation is turned into liquid water + // However, if the temperature is below the threshold for homogeneous + // freezing then the supersaturation is turned instantly to ice. + //-------------------------------------------------------------------- + + if (zsupsat > zepsec) { + + if (ztp1[jk] > (*yrecldp).rthomo) { + // Turn supersaturation into liquid water + zsolqa[0 + 5*(4)] = zsolqa[0 + 5*(4)] + zsupsat; + zsolqa[4 + 5*(0)] = zsolqa[4 + 5*(0)] - zsupsat; + // Include liquid in first guess + zqxfg[0] = zqxfg[0] + zsupsat; + } else { + // Turn supersaturation into ice water + zsolqa[1 + 5*(4)] = zsolqa[1 + 5*(4)] + zsupsat; + zsolqa[4 + 5*(1)] = zsolqa[4 + 5*(1)] - zsupsat; + // Add ice to first guess for deposition term + zqxfg[1] = zqxfg[1] + zsupsat; + } + + // Increase cloud amount using RKOOPTAU timescale + zsolac = ((double) 1.0 - za[jk])*zfaci; + + } + + //------------------------------------------------------- + // 3.1.3 Include supersaturation from previous timestep + // (Calculated in sltENDIF semi-lagrangian LDSLPHY=T) + //------------------------------------------------------- + if (psupsat[jl + klon*(jk + klev*(ibl))] > zepsec) { + if (ztp1[jk] > (*yrecldp).rthomo) { + // Turn supersaturation into liquid water + zsolqa[0 + 5*(0)] = + zsolqa[0 + 5*(0)] + psupsat[jl + klon*(jk + klev*(ibl))]; + zpsupsatsrce[0] = psupsat[jl + klon*(jk + klev*(ibl))]; + // Add liquid to first guess for deposition term + zqxfg[0] = zqxfg[0] + psupsat[jl + klon*(jk + klev*(ibl))]; + // Store cloud budget diagnostics if required + } else { + // Turn supersaturation into ice water + zsolqa[1 + 5*(1)] = + zsolqa[1 + 5*(1)] + psupsat[jl + klon*(jk + klev*(ibl))]; + zpsupsatsrce[1] = psupsat[jl + klon*(jk + klev*(ibl))]; + // Add ice to first guess for deposition term + zqxfg[1] = zqxfg[1] + psupsat[jl + klon*(jk + klev*(ibl))]; + // Store cloud budget diagnostics if required + } + + // Increase cloud amount using RKOOPTAU timescale + zsolac = ((double) 1.0 - za[jk])*zfaci; + // Store cloud budget diagnostics if required + } + + // on JL + + //--------------------------------------------------------------------- + // 3.2 DETRAINMENT FROM CONVECTION + //--------------------------------------------------------------------- + // * Diagnostic T-ice/liq split retained for convection + // Note: This link is now flexible and a future convection + // scheme can detrain explicit seperate budgets of: + // cloud water, ice, rain and snow + // * There is no (1-ZA) multiplier term on the cloud detrainment + // term, since is now written in mass-flux terms + // [#Note: Should use ZFOEALFACU used in convection rather than ZFOEALFA] + //--------------------------------------------------------------------- + if (jk + 1 < klev && jk + 1 >= (*yrecldp).ncldtop) { + + + plude[jl + klon*(jk + klev*(ibl))] = + plude[jl + klon*(jk + klev*(ibl))]*zdtgdp; + + if (/*ldcum[jl + klon*(ibl)] &&*/ plude[jl + klon*(jk + klev*(ibl + ))] > (*yrecldp).rlmin && plu[jl + klon*(1 + jk + klev*(ibl))] > + zepsec) { + + zsolac = zsolac + plude[jl + klon*(jk + klev*(ibl))] / plu[jl + + klon*(1 + jk + klev*(ibl))]; + // *diagnostic temperature split* + zalfaw = zfoealfa[jk]; + zconvsrce[0] = zalfaw*plude[jl + klon*(jk + klev*(ibl))]; + zconvsrce[1] = + ((double) 1.0 - zalfaw)*plude[jl + klon*(jk + klev*(ibl))]; + zsolqa[0 + 5*(0)] = zsolqa[0 + 5*(0)] + zconvsrce[0]; + zsolqa[1 + 5*(1)] = zsolqa[1 + 5*(1)] + zconvsrce[1]; + + } else { + + plude[jl + klon*(jk + klev*(ibl))] = (double) 0.0; + + } + // *convective snow detrainment source + //if (ldcum[jl + klon*(ibl)]) { + zsolqa[3 + 5*(3)] = zsolqa[3 + 5*(3)] + psnde[jl + + klon*(jk + klev*(ibl))]*zdtgdp; + //} + + + } + // JK (*yrecldp).ncldtop) { + + zmf = fmax((double) 0.0, (pmfu[jl + klon*(jk + klev*(ibl))] + pmfd[-1 + + jl + klon*(jk + klev*(ibl))])*zdtgdp); + zacust = zmf*zanewm1; + + for (jm = 0; jm <= 5 + -1; jm += 1) { + if (!llfall[jm] && iphase[jm] > 0) { + zlcust[jm] = zmf*zqxnm1[jm]; + // record total flux for enthalpy budget: + zconvsrce[jm] = zconvsrce[jm] + zlcust[jm]; + } + } + + // Now have to work out how much liquid evaporates at arrival point + // since there is no prognostic memory for in-cloud humidity, i.e. + // we always assume cloud is saturated. + + zdtdp = zrdcp*(double) 0.5*(ztp1[-1 + jk] + ztp1[jk]) / paph[jl + klon*(jk + + (klev + 1)*(ibl))]; + zdtforc = zdtdp*(pap[jl + klon*(jk + klev*(ibl))] - pap[jl + + klon*(-1 + jk + klev*(ibl))]); + //[#Note: Diagnostic mixed phase should be replaced below] + zdqs = zanewm1*zdtforc*zdqsmixdt; + + for (jm = 0; jm <= 5 + -1; jm += 1) { + if (!llfall[jm] && iphase[jm] > 0) { + zlfinal = fmax((double) 0.0, zlcust[jm] - zdqs); //lim to zero + // no supersaturation allowed incloud ---V + zevap = fmin((zlcust[jm] - zlfinal), zevaplimmix); + // ZEVAP=0.0_JPRB + zlfinal = zlcust[jm] - zevap; + zlfinalsum = zlfinalsum + zlfinal; // sum + + zsolqa[jm + 5*jm] = zsolqa[jm + 5*jm] + zlcust[jm]; // whole sum + zsolqa[4 + 5*jm] = zsolqa[4 + 5*jm] + zevap; + zsolqa[jm + 5*(4)] = zsolqa[jm + 5*(4)] - zevap; + } + } + + // Reset the cloud contribution if no cloud water survives to this level: + if (zlfinalsum < zepsec) { + zacust = (double) 0.0; + } + zsolac = zsolac + zacust; + + } + // on JK>NCLDTOP + + //--------------------------------------------------------------------- + // Subsidence sink of cloud to the layer below + // (Implicit - re. CFL limit on convective mass flux) + //--------------------------------------------------------------------- + + + if (jk + 1 < klev) { + + zmfdn = fmax((double) 0.0, (pmfu[jl + klon*(1 + jk + klev*(ibl))] + + pmfd[jl + klon*(1 + jk + klev*(ibl))])*zdtgdp); + + zsolab = zsolab + zmfdn; + zsolqb[0 + 5*(0)] = zsolqb[0 + 5*(0)] + zmfdn; + zsolqb[1 + 5*(1)] = zsolqb[1 + 5*(1)] + zmfdn; + + // Record sink for cloud budget and enthalpy budget diagnostics + zconvsink[0] = zmfdn; + zconvsink[1] = zmfdn; + + } + + + //---------------------------------------------------------------------- + // 3.4 EROSION OF CLOUDS BY TURBULENT MIXING + //---------------------------------------------------------------------- + // NOTE: In default tiedtke scheme this process decreases the cloud + // area but leaves the specific cloud water content + // within clouds unchanged + //---------------------------------------------------------------------- + + // ------------------------------ + // Define turbulent erosion rate + // ------------------------------ + zldifdt = (*yrecldp).rcldiff*ptsphy; //original version + //Increase by factor of 5 for convective points + if (ktype[jl + klon*(ibl)] > 0 && plude[jl + klon*(jk + klev*( + ibl))] > zepsec) { + zldifdt = (*yrecldp).rcldiff_convi*zldifdt; + } + + // At the moment, works on mixed RH profile and partitioned ice/liq fraction + // so that it is similar to previous scheme + // Should apply RHw for liquid cloud and RHi for ice cloud separately + if (zli[jk] > zepsec) { + // Calculate environmental humidity + // ZQE=(ZQX(JL,JK,NCLDQV)-ZA(JL,JK)*ZQSMIX(JL,JK))/& + // & MAX(ZEPSEC,1.0_JPRB-ZA(JL,JK)) + // ZE=ZLDIFDT(JL)*MAX(ZQSMIX(JL,JK)-ZQE,0.0_JPRB) + ze = zldifdt*fmax(zqsmix[jk] - zqx[jk + klev*(4)], (double) 0.0); + zleros = za[jk]*ze; + zleros = fmin(zleros, zevaplimmix); + zleros = fmin(zleros, zli[jk]); + zaeros = zleros / zlicld; //if linear term + + // Erosion is -ve LINEAR in L,A + zsolac = zsolac - zaeros; //linear + + zsolqa[4 + 5*(0)] = zsolqa[4 + 5*(0)] + zliqfrac[jk]*zleros; + zsolqa[0 + 5*(4)] = zsolqa[0 + 5*(4)] - zliqfrac[jk]*zleros; + zsolqa[4 + 5*(1)] = zsolqa[4 + 5*(1)] + zicefrac[jk]*zleros; + zsolqa[1 + 5*(4)] = zsolqa[1 + 5*(4)] - zicefrac[jk]*zleros; + + } + + //---------------------------------------------------------------------- + // 3.4 CONDENSATION/EVAPORATION DUE TO DQSAT/DT + //---------------------------------------------------------------------- + // calculate dqs/dt + // Note: For the separate prognostic Qi and Ql, one would ideally use + // Qsat/DT wrt liquid/Koop here, since the physics is that new clouds + // forms by liquid droplets [liq] or when aqueous aerosols [Koop] form. + // These would then instantaneous freeze if T<-38C or lead to ice growth + // by deposition in warmer mixed phase clouds. However, since we do + // not have a separate prognostic equation for in-cloud humidity or a + // statistical scheme approach in place, the depositional growth of ice + // in the mixed phase can not be modelled and we resort to supersaturation + // wrt ice instanteously converting to ice over one timestep + // (see Tompkins et al. QJRMS 2007 for details) + // Thus for the initial implementation the diagnostic mixed phase is + // retained for the moment, and the level of approximation noted. + //---------------------------------------------------------------------- + + zdtdp = zrdcp*ztp1[jk] / pap[jl + klon*(jk + klev*(ibl))]; + zdpmxdt = zdp*zqtmst; + zmfdn = (double) 0.0; + if (jk + 1 < klev) { + zmfdn = pmfu[jl + klon*(1 + jk + klev*(ibl))] + pmfd[jl + klon*(1 + + jk + klev*(ibl))]; + } + zwtot = pvervel[jl + klon*(jk + klev*(ibl))] + (double) 0.5*rg*(pmfu[ + jl + klon*(jk + klev*(ibl))] + pmfd[jl + klon*(jk + klev*(ibl))] + + zmfdn); + zwtot = fmin(zdpmxdt, fmax(-zdpmxdt, zwtot)); + zzzdt = phrsw[jl + klon*(jk + klev*(ibl))] + phrlw[jl + klon*(jk + + klev*(ibl))]; + zdtdiab = fmin(zdpmxdt*zdtdp, fmax(-zdpmxdt*zdtdp, zzzdt))*ptsphy + ralfdcp*zldefr; + // Note: ZLDEFR should be set to the difference between the mixed phase functions + // in the convection and cloud scheme, but this is not calculated, so is zero and + // the functions must be the same + zdtforc = zdtdp*zwtot*ptsphy + zdtdiab; + zqold = zqsmix[jk]; + ztold = ztp1[jk]; + ztp1[jk] = ztp1[jk] + zdtforc; + ztp1[jk] = fmax(ztp1[jk], (double) 160.0); + llflag = true; + + // Formerly a call to CUADJTQ(..., ICALL=5) + zqp = (double) 1.0 / pap[jl + klon*(jk + klev*(ibl))]; + zqsat = ((double)(r2es*((double)(fmin(1.0, pow((fmax(rtice, fmin(rtwat, ztp1[jk])) - rtice)*rtwat_rtice_r, 2)))*exp((r3les*(ztp1[jk] - rtt))/(ztp1[jk] - r4les)) + (1.0 - (double)(fmin(1.0, pow((fmax(rtice, fmin(rtwat, ztp1[jk])) - rtice)*rtwat_rtice_r, 2))))*exp((r3ies*(ztp1[jk] - rtt))/(ztp1[jk] - r4ies)))))*zqp; + zqsat = fmin((double) 0.5, zqsat); + zcor = (double) 1.0 / ((double) 1.0 - retv*zqsat); + zqsat = zqsat*zcor; + zcond = (zqsmix[jk] - zqsat) / ((double) 1.0 + zqsat*zcor*((double)(((double)(fmin(1.0, pow((fmax(rtice, fmin(rtwat, ztp1[jk])) - rtice)*rtwat_rtice_r, 2)))*r5alvcp)*(1.0/pow(ztp1[jk] - r4les, 2)) + ((1.0 - (double)(fmin(1.0, pow((fmax(rtice, fmin(rtwat, ztp1[jk])) - rtice)*rtwat_rtice_r, 2))))*r5alscp)*(1.0/pow(ztp1[jk] - r4ies, 2))))); + ztp1[jk] = ztp1[jk] + ((double)((double)(fmin(1.0, pow((fmax(rtice, fmin(rtwat, ztp1[jk])) - rtice)*rtwat_rtice_r, 2)))*ralvdcp + (1.0 - (double)(fmin(1.0, pow((fmax(rtice, fmin(rtwat, ztp1[jk])) - rtice)*rtwat_rtice_r, 2))))*ralsdcp))*zcond; + zqsmix[jk] = zqsmix[jk] - zcond; + zqsat = ((double)(r2es*((double)(fmin(1.0, pow((fmax(rtice, fmin(rtwat, ztp1[jk])) - rtice)*rtwat_rtice_r, 2)))*exp((r3les*(ztp1[jk] - rtt))/(ztp1[jk] - r4les)) + (1.0 - (double)(fmin(1.0, pow((fmax(rtice, fmin(rtwat, ztp1[jk])) - rtice)*rtwat_rtice_r, 2))))*exp((r3ies*(ztp1[jk] - rtt))/(ztp1[jk] - r4ies)))))*zqp; + zqsat = fmin((double) 0.5, zqsat); + zcor = (double) 1.0 / ((double) 1.0 - retv*zqsat); + zqsat = zqsat*zcor; + zcond1 = (zqsmix[jk] - zqsat) / ((double) 1.0 + zqsat*zcor*((double)(((double)(fmin(1.0, pow((fmax(rtice, fmin(rtwat, ztp1[jk])) - rtice)*rtwat_rtice_r, 2)))*r5alvcp)*(1.0/pow(ztp1[jk] - r4les, 2)) + ((1.0 - (double)(fmin(1.0, pow((fmax(rtice, fmin(rtwat, ztp1[jk])) - rtice)*rtwat_rtice_r, 2))))*r5alscp)*(1.0/pow(ztp1[jk] - r4ies, 2))))); + ztp1[jk] = ztp1[jk] + ((double)((double)(fmin(1.0, pow((fmax(rtice, fmin(rtwat, ztp1[jk])) - rtice)*rtwat_rtice_r, 2)))*ralvdcp + (1.0 - (double)(fmin(1.0, pow((fmax(rtice, fmin(rtwat, ztp1[jk])) - rtice)*rtwat_rtice_r, 2))))*ralsdcp))*zcond1; + zqsmix[jk] = zqsmix[jk] - zcond1; + + zdqs = zqsmix[jk] - zqold; + zqsmix[jk] = zqold; + ztp1[jk] = ztold; + + //---------------------------------------------------------------------- + // 3.4a ZDQS(JL) > 0: EVAPORATION OF CLOUDS + // ---------------------------------------------------------------------- + // Erosion term is LINEAR in L + // Changed to be uniform distribution in cloud region + + + // Previous function based on DELTA DISTRIBUTION in cloud: + if (zdqs > (double) 0.0) { + // If subsidence evaporation term is turned off, then need to use updated + // liquid and cloud here? + // ZLEVAP = MAX(ZA(JL,JK)+ZACUST(JL),1.0_JPRB)*MIN(ZDQS(JL),ZLICLD(JL)+ZLFINALSUM(JL)) + zlevap = za[jk]*fmin(zdqs, zlicld); + zlevap = fmin(zlevap, zevaplimmix); + zlevap = fmin(zlevap, fmax(zqsmix[jk] - zqx[jk + klev*(4)], (double) 0.0)); + + // For first guess call + zlevapl = zliqfrac[jk]*zlevap; + zlevapi = zicefrac[jk]*zlevap; + + zsolqa[4 + 5*(0)] = zsolqa[4 + 5*(0)] + zliqfrac[jk]*zlevap; + zsolqa[0 + 5*(4)] = zsolqa[0 + 5*(4)] - zliqfrac[jk]*zlevap; + + zsolqa[4 + 5*(1)] = zsolqa[4 + 5*(1)] + zicefrac[jk]*zlevap; + zsolqa[1 + 5*(4)] = zsolqa[1 + 5*(4)] - zicefrac[jk]*zlevap; + + } + + + //---------------------------------------------------------------------- + // 3.4b ZDQS(JL) < 0: FORMATION OF CLOUDS + //---------------------------------------------------------------------- + // (1) Increase of cloud water in existing clouds + if (za[jk] > zepsec && zdqs <= -(*yrecldp).rlmin) { + + zlcond1 = fmax(-zdqs, (double) 0.0); //new limiter + + //old limiter (significantly improves upper tropospheric humidity rms) + if (za[jk] > (double) 0.99) { + zcor = (double) 1.0 / ((double) 1.0 - retv*zqsmix[jk]); + zcdmax = (zqx[jk + klev*(4)] - zqsmix[jk]) / ((double) 1.0 + + zcor*zqsmix[jk]*((double)(((double)(fmin(1.0, pow((fmax(rtice, fmin(rtwat, ztp1[jk])) - rtice)*rtwat_rtice_r, 2)))*r5alvcp)*(1.0/pow(ztp1[jk] - r4les, 2)) + ((1.0 - (double)(fmin(1.0, pow((fmax(rtice, fmin(rtwat, ztp1[jk])) - rtice)*rtwat_rtice_r, 2))))*r5alscp)*(1.0/pow(ztp1[jk] - r4ies, 2))))); + } else { + zcdmax = (zqx[jk + klev*(4)] - za[jk]*zqsmix[jk]) / za[jk]; + } + zlcond1 = fmax(fmin(zlcond1, zcdmax), (double) 0.0); + // end old limiter + + zlcond1 = za[jk]*zlcond1; + if (zlcond1 < (*yrecldp).rlmin) { + zlcond1 = (double) 0.0; + } + + //------------------------------------------------------------------------- + // All increase goes into liquid unless so cold cloud homogeneously freezes + // Include new liquid formation in first guess value, otherwise liquid + // remains at cold temperatures until next timestep. + //------------------------------------------------------------------------- + if (ztp1[jk] > (*yrecldp).rthomo) { + zsolqa[0 + 5*(4)] = zsolqa[0 + 5*(4)] + zlcond1; + zsolqa[4 + 5*(0)] = zsolqa[4 + 5*(0)] - zlcond1; + zqxfg[0] = zqxfg[0] + zlcond1; + } else { + zsolqa[1 + 5*(4)] = zsolqa[1 + 5*(4)] + zlcond1; + zsolqa[4 + 5*(1)] = zsolqa[4 + 5*(1)] - zlcond1; + zqxfg[1] = zqxfg[1] + zlcond1; + } + } + + // (2) Generation of new clouds (da/dt>0) + + + if (zdqs <= -(*yrecldp).rlmin && za[jk] < (double) 1.0 - zepsec) { + + //--------------------------- + // Critical relative humidity + //--------------------------- + zrhc = (*yrecldp).ramid; + zsigk = pap[jl + klon*(jk + klev*(ibl))] / paph[jl + klon*(klev + + (klev + 1)*(ibl))]; + // Increase RHcrit to 1.0 towards the surface (eta>0.8) + if (zsigk > (double) 0.8) { + zrhc = (*yrecldp).ramid + ((double) 1.0 - (*yrecldp).ramid)*(pow(((zsigk - + (double) 0.8) / (double) 0.2), 2)); + } + + // Commented out for CY37R1 to reduce humidity in high trop and strat + // ! Increase RHcrit to 1.0 towards the tropopause (trop-0.2) and above + // ZBOTT=ZTRPAUS(JL)+0.2_JPRB + // IF(ZSIGK < ZBOTT) THEN + // ZRHC=RAMID+(1.0_JPRB-RAMID)*MIN(((ZBOTT-ZSIGK)/0.2_JPRB)**2,1.0_JPRB) + // ENDIF + + //--------------------------- + // Supersaturation options + //--------------------------- + if ((*yrecldp).nssopt == 0) { + // No scheme + zqe = (zqx[jk + klev*(4)] - za[jk]*zqsice[jk]) / fmax(zepsec, (double) 1.0 + - za[jk]); + zqe = fmax((double) 0.0, zqe); + } else if ((*yrecldp).nssopt == 1) { + // Tompkins + zqe = (zqx[jk + klev*(4)] - za[jk]*zqsice[jk]) / fmax(zepsec, (double) 1.0 + - za[jk]); + zqe = fmax((double) 0.0, zqe); + } else if ((*yrecldp).nssopt == 2) { + // Lohmann and Karcher + zqe = zqx[jk + klev*(4)]; + } else if ((*yrecldp).nssopt == 3) { + // Gierens + zqe = zqx[jk + klev*(4)] + zli[jk]; + } + + if (ztp1[jk] >= rtt || (*yrecldp).nssopt == 0) { + // No ice supersaturation allowed + zfac = (double) 1.0; + } else { + // Ice supersaturation + zfac = zfokoop; + } + + if (zqe >= zrhc*zqsice[jk]*zfac && zqe < zqsice[jk]*zfac) { + // note: not **2 on 1-a term if ZQE is used. + // Added correction term ZFAC to numerator 15/03/2010 + zacond = -((double) 1.0 - za[jk])*zfac*zdqs / fmax((double) + 2.0*(zfac*zqsice[jk] - zqe), zepsec); + + zacond = fmin(zacond, (double) 1.0 - za[jk]); //PUT THE LIMITER BACK + + // Linear term: + // Added correction term ZFAC 15/03/2010 + zlcond2 = -zfac*zdqs*(double) 0.5*zacond; //mine linear + + // new limiter formulation + zzdl = + (double) 2.0*(zfac*zqsice[jk] - zqe) / fmax(zepsec, (double) 1.0 - za[jk]); + // Added correction term ZFAC 15/03/2010 + if (zfac*zdqs < -zzdl) { + // ZLCONDLIM=(ZA(JL,JK)-1.0_JPRB)*ZDQS(JL)-ZQSICE(JL,JK)+ZQX(JL,JK,NCLDQV) + zlcondlim = (za[jk] - (double) 1.0)*zfac*zdqs - zfac*zqsice[jk] + zqx[jk + + klev*(4)]; + zlcond2 = fmin(zlcond2, zlcondlim); + } + zlcond2 = fmax(zlcond2, (double) 0.0); + + if (zlcond2 < (*yrecldp).rlmin || ((double) 1.0 - za[jk]) < zepsec) { + zlcond2 = (double) 0.0; + zacond = (double) 0.0; + } + if (zlcond2 == (double) 0.0) { + zacond = (double) 0.0; + } + + // Large-scale generation is LINEAR in A and LINEAR in L + zsolac = zsolac + zacond; //linear + + //------------------------------------------------------------------------ + // All increase goes into liquid unless so cold cloud homogeneously freezes + // Include new liquid formation in first guess value, otherwise liquid + // remains at cold temperatures until next timestep. + //------------------------------------------------------------------------ + if (ztp1[jk] > (*yrecldp).rthomo) { + zsolqa[0 + 5*(4)] = zsolqa[0 + 5*(4)] + zlcond2; + zsolqa[4 + 5*(0)] = zsolqa[4 + 5*(0)] - zlcond2; + zqxfg[0] = zqxfg[0] + zlcond2; + } else { + // homogeneous freezing + zsolqa[1 + 5*(4)] = zsolqa[1 + 5*(4)] + zlcond2; + zsolqa[4 + 5*(1)] = zsolqa[4 + 5*(1)] - zlcond2; + zqxfg[1] = zqxfg[1] + zlcond2; + } + + } + } + + //---------------------------------------------------------------------- + // 3.7 Growth of ice by vapour deposition + //---------------------------------------------------------------------- + // Following Rotstayn et al. 2001: + // does not use the ice nuclei number from cloudaer.F90 + // but rather a simple Meyers et al. 1992 form based on the + // supersaturation and assuming clouds are saturated with + // respect to liquid water (well mixed), (or Koop adjustment) + // Growth considered as sink of liquid water if present so + // Bergeron-Findeisen adjustment in autoconversion term no longer needed + //---------------------------------------------------------------------- + + //-------------------------------------------------------- + //- + //- Ice deposition following Rotstayn et al. (2001) + //- (monodisperse ice particle size distribution) + //- + //-------------------------------------------------------- + if (idepice == 1) { + + + //-------------------------------------------------------------- + // Calculate distance from cloud top + // defined by cloudy layer below a layer with cloud frac <0.01 + // ZDZ = ZDP(JL)/(ZRHO(JL)*RG) + //-------------------------------------------------------------- + + if (za[-1 + jk] < (*yrecldp).rcldtopcf && za[jk] >= (*yrecldp).rcldtopcf) { + zcldtopdist = (double) 0.0; + } else { + zcldtopdist = zcldtopdist + zdp / (zrho*rg); + } + + //-------------------------------------------------------------- + // only treat depositional growth if liquid present. due to fact + // that can not model ice growth from vapour without additional + // in-cloud water vapour variable + //-------------------------------------------------------------- + if (ztp1[jk] < rtt && zqxfg[0] > (*yrecldp).rlmin) { + // T<273K + + zvpice = ((double)(r2es*exp((r3ies*(ztp1[jk] - rtt))/(ztp1[jk] - r4ies))))*rv / rd; + zvpliq = zvpice*zfokoop; + zicenuclei = (double) 1000.0*exp((double) 12.96*(zvpliq - zvpice) / zvpliq - + (double) 0.639); + + //------------------------------------------------ + // 2.4e-2 is conductivity of air + // 8.8 = 700**1/3 = density of ice to the third + //------------------------------------------------ + zadd = + rlstt*(rlstt / (rv*ztp1[jk]) - (double) 1.0) / ((double) 2.4E-2*ztp1[jk]); + zbdd = rv*ztp1[jk]*pap[jl + klon*(jk + klev*(ibl))] / ((double) + 2.21*zvpice); + zcvds = (double) 7.8*(pow((zicenuclei / zrho), (double) 0.666))*(zvpliq - + zvpice) / ((double) 8.87*(zadd + zbdd)*zvpice); + + //----------------------------------------------------- + // RICEINIT=1.E-12_JPRB is initial mass of ice particle + //----------------------------------------------------- + zice0 = fmax(zicecld, zicenuclei*(*yrecldp).riceinit / zrho); + + //------------------ + // new value of ice: + //------------------ + zinew = pow(((double) 0.666*zcvds*ptsphy + (pow(zice0, (double) 0.666))), + (double) 1.5); + + //--------------------------- + // grid-mean deposition rate: + //--------------------------- + zdepos = fmax(za[jk]*(zinew - zice0), (double) 0.0); + + //-------------------------------------------------------------------- + // Limit deposition to liquid water amount + // If liquid is all frozen, ice would use up reservoir of water + // vapour in excess of ice saturation mixing ratio - However this + // can not be represented without a in-cloud humidity variable. Using + // the grid-mean humidity would imply a large artificial horizontal + // flux from the clear sky to the cloudy area. We thus rely on the + // supersaturation check to clean up any remaining supersaturation + //-------------------------------------------------------------------- + zdepos = fmin(zdepos, zqxfg[0]); // limit to liquid water amount + + //-------------------------------------------------------------------- + // At top of cloud, reduce deposition rate near cloud top to account for + // small scale turbulent processes, limited ice nucleation and ice fallout + //-------------------------------------------------------------------- + // ZDEPOS = ZDEPOS*MIN(RDEPLIQREFRATE+ZCLDTOPDIST(JL)/RDEPLIQREFDEPTH,1.0_JPRB) + // Change to include dependence on ice nuclei concentration + // to increase deposition rate with decreasing temperatures + zinfactor = fmin(zicenuclei / (double) 15000., (double) 1.0); + zdepos = zdepos*fmin(zinfactor + ((double) 1.0 - zinfactor)*((*yrecldp) + .rdepliqrefrate + zcldtopdist / (*yrecldp).rdepliqrefdepth), (double) 1.0); + + //-------------- + // add to matrix + //-------------- + zsolqa[1 + 5*(0)] = zsolqa[1 + 5*(0)] + zdepos; + zsolqa[0 + 5*(1)] = zsolqa[0 + 5*(1)] - zdepos; + zqxfg[1] = zqxfg[1] + zdepos; + zqxfg[0] = zqxfg[0] - zdepos; + + } + + //-------------------------------------------------------- + //- + //- Ice deposition assuming ice PSD + //- + //-------------------------------------------------------- + } else if (idepice == 2) { + + + //-------------------------------------------------------------- + // Calculate distance from cloud top + // defined by cloudy layer below a layer with cloud frac <0.01 + // ZDZ = ZDP(JL)/(ZRHO(JL)*RG) + //-------------------------------------------------------------- + + if (za[-1 + jk] < (*yrecldp).rcldtopcf && za[jk] >= (*yrecldp).rcldtopcf) { + zcldtopdist = (double) 0.0; + } else { + zcldtopdist = zcldtopdist + zdp / (zrho*rg); + } + + //-------------------------------------------------------------- + // only treat depositional growth if liquid present. due to fact + // that can not model ice growth from vapour without additional + // in-cloud water vapour variable + //-------------------------------------------------------------- + if (ztp1[jk] < rtt && zqxfg[0] > (*yrecldp).rlmin) { + // T<273K + + zvpice = ((double)(r2es*exp((r3ies*(ztp1[jk] - rtt))/(ztp1[jk] - r4ies))))*rv / rd; + zvpliq = zvpice*zfokoop; + zicenuclei = (double) 1000.0*exp((double) 12.96*(zvpliq - zvpice) / zvpliq - + (double) 0.639); + + //----------------------------------------------------- + // RICEINIT=1.E-12_JPRB is initial mass of ice particle + //----------------------------------------------------- + zice0 = fmax(zicecld, zicenuclei*(*yrecldp).riceinit / zrho); + + // Particle size distribution + ztcg = (double) 1.0; + zfacx1i = (double) 1.0; + + zaplusb = (*yrecldp).rcl_apb1*zvpice - (*yrecldp).rcl_apb2*zvpice*ztp1[jk] + + pap[jl + klon*(jk + klev*(ibl))]*(*yrecldp).rcl_apb3*(pow(ztp1[jk], + (double) 3.)); + zcorrfac = pow(((double) 1.0 / zrho), (double) 0.5); + zcorrfac2 = (pow((ztp1[jk] / (double) 273.0), (double) 1.5))*((double) 393.0 / + (ztp1[jk] + (double) 120.0)); + + zpr02 = zrho*zice0*(*yrecldp).rcl_const1i / (ztcg*zfacx1i); + + zterm1 = (zvpliq - zvpice)*(pow(ztp1[jk], (double) 2.0)) + *zvpice*zcorrfac2*ztcg*(*yrecldp).rcl_const2i*zfacx1i / (zrho*zaplusb*zvpice) + ; + zterm2 = (double) 0.65*(*yrecldp).rcl_const6i*(pow(zpr02, (*yrecldp) + .rcl_const4i)) + (*yrecldp).rcl_const3i*(pow(zcorrfac, (double) 0.5)) + *(pow(zrho, (double) 0.5))*(pow(zpr02, (*yrecldp).rcl_const5i)) / + (pow(zcorrfac2, (double) 0.5)); + + zdepos = fmax(za[jk]*zterm1*zterm2*ptsphy, (double) 0.0); + + //-------------------------------------------------------------------- + // Limit deposition to liquid water amount + // If liquid is all frozen, ice would use up reservoir of water + // vapour in excess of ice saturation mixing ratio - However this + // can not be represented without a in-cloud humidity variable. Using + // the grid-mean humidity would imply a large artificial horizontal + // flux from the clear sky to the cloudy area. We thus rely on the + // supersaturation check to clean up any remaining supersaturation + //-------------------------------------------------------------------- + zdepos = fmin(zdepos, zqxfg[0]); // limit to liquid water amount + + //-------------------------------------------------------------------- + // At top of cloud, reduce deposition rate near cloud top to account for + // small scale turbulent processes, limited ice nucleation and ice fallout + //-------------------------------------------------------------------- + // Change to include dependence on ice nuclei concentration + // to increase deposition rate with decreasing temperatures + zinfactor = fmin(zicenuclei / (double) 15000., (double) 1.0); + zdepos = zdepos*fmin(zinfactor + ((double) 1.0 - zinfactor)*((*yrecldp) + .rdepliqrefrate + zcldtopdist / (*yrecldp).rdepliqrefdepth), (double) 1.0); + + //-------------- + // add to matrix + //-------------- + zsolqa[1 + 5*(0)] = zsolqa[1 + 5*(0)] + zdepos; + zsolqa[0 + 5*(1)] = zsolqa[0 + 5*(1)] - zdepos; + zqxfg[1] = zqxfg[1] + zdepos; + zqxfg[0] = zqxfg[0] - zdepos; + } + + } + // on IDEPICE + + //###################################################################### + // 4 *** PRECIPITATION PROCESSES *** + //###################################################################### + + //---------------------------------- + // revise in-cloud consensate amount + //---------------------------------- + ztmpa = (double) 1.0 / fmax(za[jk], zepsec); + zliqcld = zqxfg[0]*ztmpa; + zicecld = zqxfg[1]*ztmpa; + zlicld = zliqcld + zicecld; + + //---------------------------------------------------------------------- + // 4.2 SEDIMENTATION/FALLING OF *ALL* MICROPHYSICAL SPECIES + // now that rain, snow, graupel species are prognostic + // the precipitation flux can be defined directly level by level + // There is no vertical memory required from the flux variable + //---------------------------------------------------------------------- + + for (jm = 0; jm <= 5 + -1; jm += 1) { + if (llfall[jm] || jm + 1 == 2) { + //------------------------ + // source from layer above + //------------------------ + if (jk + 1 > (*yrecldp).ncldtop) { + zfallsrce[jm] = zpfplsx[jk + (klev + 1)*jm]*zdtgdp; + zsolqa[jm + 5*jm] = zsolqa[jm + 5*jm] + zfallsrce[jm]; + zqxfg[jm] = zqxfg[jm] + zfallsrce[jm]; + // use first guess precip----------V + zqpretot = zqpretot + zqxfg[jm]; + } + //------------------------------------------------- + // sink to next layer, constant fall speed + //------------------------------------------------- + // if aerosol effect then override + // note that for T>233K this is the same as above. + if ((*yrecldp).laericesed && jm + 1 == 2) { + zre_ice = pre_ice[jl + klon*(jk + klev*(ibl))]; + // The exponent value is from + // Morrison et al. JAS 2005 Appendix + zvqx[1] = (double) 0.002*(pow(zre_ice, (double) 1.0)); + } + zfall = zvqx[jm]*zrho; + //------------------------------------------------- + // modified by Heymsfield and Iaquinta JAS 2000 + //------------------------------------------------- + // ZFALL = ZFALL*((PAP(JL,JK)*RICEHI1)**(-0.178_JPRB)) & + // &*((ZTP1(JL,JK)*RICEHI2)**(-0.394_JPRB)) + + zfallsink[jm] = zdtgdp*zfall; + // Cloud budget diagnostic stored at end as implicit + // jl + } + // LLFALL + } + // jm + + //--------------------------------------------------------------- + // Precip cover overlap using MAX-RAN Overlap + // Since precipitation is now prognostic we must + // 1) apply an arbitrary minimum coverage (0.3) if precip>0 + // 2) abandon the 2-flux clr/cld treatment + // 3) Thus, since we have no memory of the clear sky precip + // fraction, we mimic the previous method by reducing + // ZCOVPTOT(JL), which has the memory, proportionally with + // the precip evaporation rate, taking cloud fraction + // into account + // #3 above leads to much smoother vertical profiles of + // precipitation fraction than the Klein-Jakob scheme which + // monotonically increases precip fraction and then resets + // it to zero in a step function once clear-sky precip reaches + // zero. + //--------------------------------------------------------------- + if (zqpretot > zepsec) { + zcovptot = (double) 1.0 - (((double) 1.0 - zcovptot)*((double) 1.0 - fmax(za[jk], + za[-1 + jk])) / ((double) 1.0 - fmin(za[-1 + jk], (double) 1.0 - (double) + 1.E-06))); + zcovptot = fmax(zcovptot, (*yrecldp).rcovpmin); + zcovpclr = fmax((double) 0.0, zcovptot - za[jk]); // clear sky proportion + zraincld = zqxfg[2] / zcovptot; + zsnowcld = zqxfg[3] / zcovptot; + zcovpmax = fmax(zcovptot, zcovpmax); + } else { + zraincld = (double) 0.0; + zsnowcld = (double) 0.0; + zcovptot = (double) 0.0; // no flux - reset cover + zcovpclr = (double) 0.0; // reset clear sky proportion + zcovpmax = (double) 0.0; // reset max cover for ZZRH calc + } + + //---------------------------------------------------------------------- + // 4.3a AUTOCONVERSION TO SNOW + //---------------------------------------------------------------------- + + if (ztp1[jk] <= rtt) { + //----------------------------------------------------- + // Snow Autoconversion rate follow Lin et al. 1983 + //----------------------------------------------------- + if (zicecld > zepsec) { + + zzco = ptsphy*(*yrecldp).rsnowlin1*exp((*yrecldp).rsnowlin2*(ztp1[jk] - rtt)); + + if ((*yrecldp).laericeauto) { + zlcrit = picrit_aer[jl + klon*(jk + klev*(ibl))]; + // 0.3 = N**0.333 with N=0.027 + zzco = zzco*(pow(((*yrecldp).rnice / pnice[jl + klon*(jk + klev*( + ibl))]), (double) 0.333)); + } else { + zlcrit = (*yrecldp).rlcritsnow; + } + + zsnowaut = zzco*((double) 1.0 - exp(-(pow((zicecld / zlcrit), 2)))); + zsolqb[3 + 5*(1)] = zsolqb[3 + 5*(1)] + zsnowaut; + + } + } + + //---------------------------------------------------------------------- + // 4.3b AUTOCONVERSION WARM CLOUDS + // Collection and accretion will require separate treatment + // but for now we keep this simple treatment + //---------------------------------------------------------------------- + + if (zliqcld > zepsec) { + + //-------------------------------------------------------- + //- + //- Warm-rain process follow Sundqvist (1989) + //- + //-------------------------------------------------------- + if (iwarmrain == 1) { + + zzco = (*yrecldp).rkconv*ptsphy; + + if ((*yrecldp).laerliqautolsp) { + zlcrit = plcrit_aer[jl + klon*(jk + klev*(ibl))]; + // 0.3 = N**0.333 with N=125 cm-3 + zzco = zzco*(pow(((*yrecldp).rccn / pccn[jl + klon*(jk + klev*(ibl) + )]), (double) 0.333)); + } else { + // Modify autoconversion threshold dependent on: + // land (polluted, high CCN, smaller droplets, higher threshold) + // sea (clean, low CCN, larger droplets, lower threshold) + if (plsm[jl + klon*(ibl)] > (double) 0.5) { + zlcrit = (*yrecldp).rclcrit_land; // land + } else { + zlcrit = (*yrecldp).rclcrit_sea; // ocean + } + } + + //------------------------------------------------------------------ + // Parameters for cloud collection by rain and snow. + // Note that with new prognostic variable it is now possible + // to REPLACE this with an explicit collection parametrization + //------------------------------------------------------------------ + zprecip = (zpfplsx[jk + (klev + 1)*(3)] + zpfplsx[jk + (klev + 1)*(2) + ]) / fmax(zepsec, zcovptot); + zcfpr = (double) 1.0 + (*yrecldp).rprc1*sqrt(fmax(zprecip, (double) 0.0)); + // ZCFPR=1.0_JPRB + RPRC1*SQRT(MAX(ZPRECIP,0.0_JPRB))*& + // &ZCOVPTOT(JL)/(MAX(ZA(JL,JK),ZEPSEC)) + + if ((*yrecldp).laerliqcoll) { + // 5.0 = N**0.333 with N=125 cm-3 + zcfpr = zcfpr*(pow(((*yrecldp).rccn / pccn[jl + klon*(jk + klev*( + ibl))]), (double) 0.333)); + } + + zzco = zzco*zcfpr; + zlcrit = zlcrit / fmax(zcfpr, zepsec); + + if (zliqcld / zlcrit < (double) 20.0) { + // Security for exp for some compilers + zrainaut = zzco*((double) 1.0 - exp(-(pow((zliqcld / zlcrit), 2)))); + } else { + zrainaut = zzco; + } + + // rain freezes instantly + if (ztp1[jk] <= rtt) { + zsolqb[3 + 5*(0)] = zsolqb[3 + 5*(0)] + zrainaut; + } else { + zsolqb[2 + 5*(0)] = zsolqb[2 + 5*(0)] + zrainaut; + } + + //-------------------------------------------------------- + //- + //- Warm-rain process follow Khairoutdinov and Kogan (2000) + //- + //-------------------------------------------------------- + } else if (iwarmrain == 2) { + + if (plsm[jl + klon*(ibl)] > (double) 0.5) { + // land + zconst = (*yrecldp).rcl_kk_cloud_num_land; + zlcrit = (*yrecldp).rclcrit_land; + } else { + // ocean + zconst = (*yrecldp).rcl_kk_cloud_num_sea; + zlcrit = (*yrecldp).rclcrit_sea; + } + + if (zliqcld > zlcrit) { + + zrainaut = (double) 1.5*za[jk]*ptsphy*(*yrecldp).rcl_kkaau*(pow(zliqcld, + (*yrecldp).rcl_kkbauq))*(pow(zconst, (*yrecldp).rcl_kkbaun)); + + zrainaut = fmin(zrainaut, zqxfg[0]); + if (zrainaut < zepsec) { + zrainaut = (double) 0.0; + } + + zrainacc = (double) 2.0*za[jk]*ptsphy*(*yrecldp) + .rcl_kkaac*(pow((zliqcld*zraincld), (*yrecldp).rcl_kkbac)); + + zrainacc = fmin(zrainacc, zqxfg[0]); + if (zrainacc < zepsec) { + zrainacc = (double) 0.0; + } + + } else { + zrainaut = (double) 0.0; + zrainacc = (double) 0.0; + } + + // If temperature < 0, then autoconversion produces snow rather than rain + // Explicit + if (ztp1[jk] <= rtt) { + zsolqa[3 + 5*(0)] = zsolqa[3 + 5*(0)] + zrainaut; + zsolqa[3 + 5*(0)] = zsolqa[3 + 5*(0)] + zrainacc; + zsolqa[0 + 5*(3)] = zsolqa[0 + 5*(3)] - zrainaut; + zsolqa[0 + 5*(3)] = zsolqa[0 + 5*(3)] - zrainacc; + } else { + zsolqa[2 + 5*(0)] = zsolqa[2 + 5*(0)] + zrainaut; + zsolqa[2 + 5*(0)] = zsolqa[2 + 5*(0)] + zrainacc; + zsolqa[0 + 5*(2)] = zsolqa[0 + 5*(2)] - zrainaut; + zsolqa[0 + 5*(2)] = zsolqa[0 + 5*(2)] - zrainacc; + } + + } + // on IWARMRAIN + + } + // on ZLIQCLD > ZEPSEC + + + //---------------------------------------------------------------------- + // RIMING - COLLECTION OF CLOUD LIQUID DROPS BY SNOW AND ICE + // only active if T<0degC and supercooled liquid water is present + // AND if not Sundquist autoconversion (as this includes riming) + //---------------------------------------------------------------------- + if (iwarmrain > 1) { + + if (ztp1[jk] <= rtt && zliqcld > zepsec) { + + // Fallspeed air density correction + zfallcorr = pow(((*yrecldp).rdensref / zrho), (double) 0.4); + + //------------------------------------------------------------------ + // Riming of snow by cloud water - implicit in lwc + //------------------------------------------------------------------ + if (zsnowcld > zepsec && zcovptot > (double) 0.01) { + + // Calculate riming term + // Factor of liq water taken out because implicit + zsnowrime = (double) 0.3*zcovptot*ptsphy*(*yrecldp) + .rcl_const7s*zfallcorr*(pow((zrho*zsnowcld*(*yrecldp).rcl_const1s), + (*yrecldp).rcl_const8s)); + + // Limit snow riming term + zsnowrime = fmin(zsnowrime, (double) 1.0); + + zsolqb[3 + 5*(0)] = zsolqb[3 + 5*(0)] + zsnowrime; + + } + + //------------------------------------------------------------------ + // Riming of ice by cloud water - implicit in lwc + // NOT YET ACTIVE + //------------------------------------------------------------------ + // IF (ZICECLD(JL)>ZEPSEC .AND. ZA(JL,JK)>0.01_JPRB) THEN + // + // ! Calculate riming term + // ! Factor of liq water taken out because implicit + // ZSNOWRIME(JL) = ZA(JL,JK)*PTSPHY*RCL_CONST7S*ZFALLCORR & + // & *(ZRHO(JL)*ZICECLD(JL)*RCL_CONST1S)**RCL_CONST8S + // + // ! Limit ice riming term + // ZSNOWRIME(JL)=MIN(ZSNOWRIME(JL),1.0_JPRB) + // + // ZSOLQB(JL,NCLDQI,NCLDQL) = ZSOLQB(JL,NCLDQI,NCLDQL) + ZSNOWRIME(JL) + // + // ENDIF + } + + } + // on IWARMRAIN > 1 + + + //---------------------------------------------------------------------- + // 4.4a MELTING OF SNOW and ICE + // with new implicit solver this also has to treat snow or ice + // precipitating from the level above... i.e. local ice AND flux. + // in situ ice and snow: could arise from LS advection or warming + // falling ice and snow: arrives by precipitation process + //---------------------------------------------------------------------- + + zicetot = zqxfg[1] + zqxfg[3]; + zmeltmax = (double) 0.0; + + // If there are frozen hydrometeors present and dry-bulb temperature > 0degC + if (zicetot > zepsec && ztp1[jk] > rtt) { + + // Calculate subsaturation + zsubsat = fmax(zqsice[jk] - zqx[jk + klev*(4)], (double) 0.0); + + // Calculate difference between dry-bulb (ZTP1) and the temperature + // at which the wet-bulb=0degC (RTT-ZSUBSAT*....) using an approx. + // Melting only occurs if the wet-bulb temperature >0 + // i.e. warming of ice particle due to melting > cooling + // due to evaporation. + ztdmtw0 = ztp1[jk] - rtt - zsubsat*(ztw1 + ztw2*(pap[jl + klon*(jk + + klev*(ibl))] - ztw3) - ztw4*(ztp1[jk] - ztw5)); + // Not implicit yet... + // Ensure ZCONS1 is positive so that ZMELTMAX=0 if ZTDMTW0<0 + zcons1 = fabs(ptsphy*((double) 1.0 + (double) 0.5*ztdmtw0) / (*yrecldp).rtaumel); + zmeltmax = fmax(ztdmtw0*zcons1*zrldcp, (double) 0.0); + } + + // Loop over frozen hydrometeors (ice, snow) + for (jm = 0; jm <= 5 + -1; jm += 1) { + if (iphase[jm] == 2) { + jn = imelt[jm]; + if (zmeltmax > zepsec && zicetot > zepsec) { + // Apply melting in same proportion as frozen hydrometeor fractions + zalfa = zqxfg[jm] / zicetot; + zmelt = fmin(zqxfg[jm], zalfa*zmeltmax); + // needed in first guess + // This implies that zqpretot has to be recalculated below + // since is not conserved here if ice falls and liquid doesn't + zqxfg[jm] = zqxfg[jm] - zmelt; + zqxfg[-1 + jn] = zqxfg[-1 + jn] + zmelt; + zsolqa[-1 + jn + 5*jm] = zsolqa[-1 + jn + 5*jm] + zmelt; + zsolqa[jm + 5*(-1 + jn)] = zsolqa[jm + 5*(-1 + jn)] - zmelt; + } + } + } + + //---------------------------------------------------------------------- + // 4.4b FREEZING of RAIN + //---------------------------------------------------------------------- + + // If rain present + if (zqx[jk + klev*(2)] > zepsec) { + + if (ztp1[jk] <= rtt && ztp1[-1 + jk] > rtt) { + // Base of melting layer/top of refreezing layer so + // store rain/snow fraction for precip type diagnosis + // If mostly rain, then supercooled rain slow to freeze + // otherwise faster to freeze (snow or ice pellets) + zqpretot = fmax(zqx[jk + klev*(3)] + zqx[jk + klev*(2)], zepsec); + prainfrac_toprfz[jl + klon*(ibl)] = + zqx[jk + klev*(2)] / zqpretot; + if (prainfrac_toprfz[jl + klon*(ibl)] > 0.8) { + llrainliq = true; + } else { + llrainliq = false; + } + } + + // If temperature less than zero + if (ztp1[jk] < rtt) { + + if (prainfrac_toprfz[jl + klon*(ibl)] > 0.8) { + + // Majority of raindrops completely melted + // Refreezing is by slow heterogeneous freezing + + // Slope of rain particle size distribution + zlambda = pow(((*yrecldp).rcl_fac1 / (zrho*zqx[jk + klev*(2)])), + (*yrecldp).rcl_fac2); + + // Calculate freezing rate based on Bigg(1953) and Wisner(1972) + ztemp = (*yrecldp).rcl_fzrab*(ztp1[jk] - rtt); + zfrz = ptsphy*((*yrecldp).rcl_const5r / zrho)*(exp(ztemp) - (double) 1.) + *(pow(zlambda, (*yrecldp).rcl_const6r)); + zfrzmax = fmax(zfrz, (double) 0.0); + + } else { + + // Majority of raindrops only partially melted + // Refreeze with a shorter timescale (reverse of melting...for now) + + zcons1 = fabs(ptsphy*((double) 1.0 + (double) 0.5*(rtt - ztp1[jk])) / + (*yrecldp).rtaumel); + zfrzmax = fmax((rtt - ztp1[jk])*zcons1*zrldcp, (double) 0.0); + + } + + if (zfrzmax > zepsec) { + zfrz = fmin(zqx[jk + klev*(2)], zfrzmax); + zsolqa[3 + 5*(2)] = zsolqa[3 + 5*(2)] + zfrz; + zsolqa[2 + 5*(3)] = zsolqa[2 + 5*(3)] - zfrz; + } + } + + } + + + //---------------------------------------------------------------------- + // 4.4c FREEZING of LIQUID + //---------------------------------------------------------------------- + // not implicit yet... + zfrzmax = fmax(((*yrecldp).rthomo - ztp1[jk])*zrldcp, (double) 0.0); + + jm = 1; + jn = imelt[-1 + jm]; + if (zfrzmax > zepsec && zqxfg[-1 + jm] > zepsec) { + zfrz = fmin(zqxfg[-1 + jm], zfrzmax); + zsolqa[-1 + jn + 5*(-1 + jm)] = zsolqa[-1 + jn + 5*(-1 + jm)] + zfrz; + zsolqa[-1 + jm + 5*(-1 + jn)] = zsolqa[-1 + jm + 5*(-1 + jn)] - zfrz; + } + + //---------------------------------------------------------------------- + // 4.5 EVAPORATION OF RAIN/SNOW + //---------------------------------------------------------------------- + + //---------------------------------------- + // Rain evaporation scheme from Sundquist + //---------------------------------------- + if (ievaprain == 1) { + + // Rain + + + zzrh = (*yrecldp).rprecrhmax + ((double) 1.0 - (*yrecldp).rprecrhmax)*zcovpmax / + fmax(zepsec, (double) 1.0 - za[jk]); + zzrh = fmin(fmax(zzrh, (*yrecldp).rprecrhmax), (double) 1.0); + + zqe = (zqx[jk + klev*(4)] - za[jk]*zqsliq[jk]) / fmax(zepsec, (double) 1.0 - + za[jk]); + //--------------------------------------------- + // humidity in moistest ZCOVPCLR part of domain + //--------------------------------------------- + zqe = fmax((double) 0.0, fmin(zqe, zqsliq[jk])); + llo1 = zcovpclr > zepsec && zqxfg[2] > zepsec && zqe < zzrh*zqsliq[jk]; + + if (llo1) { + // note: zpreclr is a rain flux + zpreclr = zqxfg[2]*zcovpclr / copysign(fmax(fabs(zcovptot*zdtgdp), + zepsilon), zcovptot*zdtgdp); + + //-------------------------------------- + // actual microphysics formula in zbeta + //-------------------------------------- + + zbeta1 = sqrt(pap[jl + klon*(jk + klev*(ibl))] / paph[jl + + klon*(klev + (klev + 1)*(ibl))]) / (*yrecldp).rvrfactor*zpreclr / + fmax(zcovpclr, zepsec); + + zbeta = rg*(*yrecldp).rpecons*(double) 0.5*(pow(zbeta1, (double) 0.5777)); + + zdenom = (double) 1.0 + zbeta*ptsphy*zcorqsliq; + zdpr = zcovpclr*zbeta*(zqsliq[jk] - zqe) / zdenom*zdp*zrg_r; + zdpevap = zdpr*zdtgdp; + + //--------------------------------------------------------- + // add evaporation term to explicit sink. + // this has to be explicit since if treated in the implicit + // term evaporation can not reduce rain to zero and model + // produces small amounts of rainfall everywhere. + //--------------------------------------------------------- + + // Evaporate rain + zevap = fmin(zdpevap, zqxfg[2]); + + zsolqa[4 + 5*(2)] = zsolqa[4 + 5*(2)] + zevap; + zsolqa[2 + 5*(4)] = zsolqa[2 + 5*(4)] - zevap; + + //------------------------------------------------------------- + // Reduce the total precip coverage proportional to evaporation + // to mimic the previous scheme which had a diagnostic + // 2-flux treatment, abandoned due to the new prognostic precip + //------------------------------------------------------------- + zcovptot = fmax((*yrecldp).rcovpmin, zcovptot - fmax((double) 0.0, (zcovptot - + za[jk])*zevap / zqxfg[2])); + + // Update fg field + zqxfg[2] = zqxfg[2] - zevap; + + } + + + //--------------------------------------------------------- + // Rain evaporation scheme based on Abel and Boutle (2013) + //--------------------------------------------------------- + } else if (ievaprain == 2) { + + + //----------------------------------------------------------------------- + // Calculate relative humidity limit for rain evaporation + // to avoid cloud formation and saturation of the grid box + //----------------------------------------------------------------------- + // Limit RH for rain evaporation dependent on precipitation fraction + zzrh = (*yrecldp).rprecrhmax + ((double) 1.0 - (*yrecldp).rprecrhmax)*zcovpmax / + fmax(zepsec, (double) 1.0 - za[jk]); + zzrh = fmin(fmax(zzrh, (*yrecldp).rprecrhmax), (double) 1.0); + + // Critical relative humidity + //ZRHC=RAMID + //ZSIGK=PAP(JL,JK)/PAPH(JL,KLEV+1) + // Increase RHcrit to 1.0 towards the surface (eta>0.8) + //IF(ZSIGK > 0.8_JPRB) THEN + // ZRHC=RAMID+(1.0_JPRB-RAMID)*((ZSIGK-0.8_JPRB)/0.2_JPRB)**2 + //ENDIF + //ZZRH = MIN(ZRHC,ZZRH) + + // Further limit RH for rain evaporation to 80% (RHcrit in free troposphere) + zzrh = fmin((double) 0.8, zzrh); + + zqe = fmax((double) 0.0, fmin(zqx[jk + klev*(4)], zqsliq[jk])); + + llo1 = zcovpclr > zepsec && zqxfg[2] > zepsec && zqe < zzrh*zqsliq[jk]; + + if (llo1) { + + //------------------------------------------- + // Abel and Boutle (2012) evaporation + //------------------------------------------- + // Calculate local precipitation (kg/kg) + zpreclr = zqxfg[2] / zcovptot; + + // Fallspeed air density correction + zfallcorr = pow(((*yrecldp).rdensref / zrho), 0.4); + + // Saturation vapour pressure with respect to liquid phase + zesatliq = rv / rd*((double)(r2es*exp((r3les*(ztp1[jk] - rtt))/(ztp1[jk] - r4les)))); + + // Slope of particle size distribution + zlambda = pow(((*yrecldp).rcl_fac1 / (zrho*zpreclr)), (*yrecldp).rcl_fac2); // ZPRECLR=kg/kg + + zevap_denom = (*yrecldp).rcl_cdenom1*zesatliq - (*yrecldp) + .rcl_cdenom2*ztp1[jk]*zesatliq + (*yrecldp).rcl_cdenom3*(pow(ztp1[jk], + (double) 3.))*pap[jl + klon*(jk + klev*(ibl))]; + + // Temperature dependent conductivity + zcorr2 = (pow((ztp1[jk] / (double) 273.), (double) 1.5))*(double) 393. / + (ztp1[jk] + (double) 120.); + zka = (*yrecldp).rcl_ka273*zcorr2; + + zsubsat = fmax(zzrh*zqsliq[jk] - zqe, (double) 0.0); + + zbeta = ((double) 0.5 / zqsliq[jk])*(pow(ztp1[jk], (double) 2.)) + *zesatliq*(*yrecldp).rcl_const1r*(zcorr2 / zevap_denom)*((double) 0.78 / + (pow(zlambda, (*yrecldp).rcl_const4r)) + (*yrecldp) + .rcl_const2r*(pow((zrho*zfallcorr), (double) 0.5)) / ((pow(zcorr2, (double) + 0.5))*(pow(zlambda, (*yrecldp).rcl_const3r)))); + + zdenom = (double) 1.0 + zbeta*ptsphy; //*ZCORQSLIQ(JL) + zdpevap = zcovpclr*zbeta*ptsphy*zsubsat / zdenom; + + //--------------------------------------------------------- + // Add evaporation term to explicit sink. + // this has to be explicit since if treated in the implicit + // term evaporation can not reduce rain to zero and model + // produces small amounts of rainfall everywhere. + //--------------------------------------------------------- + + // Limit rain evaporation + zevap = fmin(zdpevap, zqxfg[2]); + + zsolqa[4 + 5*(2)] = zsolqa[4 + 5*(2)] + zevap; + zsolqa[2 + 5*(4)] = zsolqa[2 + 5*(4)] - zevap; + + //------------------------------------------------------------- + // Reduce the total precip coverage proportional to evaporation + // to mimic the previous scheme which had a diagnostic + // 2-flux treatment, abandoned due to the new prognostic precip + //------------------------------------------------------------- + zcovptot = fmax((*yrecldp).rcovpmin, zcovptot - fmax((double) 0.0, (zcovptot - + za[jk])*zevap / zqxfg[2])); + + // Update fg field + zqxfg[2] = zqxfg[2] - zevap; + + } + + } + // on IEVAPRAIN + + //---------------------------------------------------------------------- + // 4.5 EVAPORATION OF SNOW + //---------------------------------------------------------------------- + // Snow + if (ievapsnow == 1) { + + zzrh = (*yrecldp).rprecrhmax + ((double) 1.0 - (*yrecldp).rprecrhmax)*zcovpmax / + fmax(zepsec, (double) 1.0 - za[jk]); + zzrh = fmin(fmax(zzrh, (*yrecldp).rprecrhmax), (double) 1.0); + zqe = (zqx[jk + klev*(4)] - za[jk]*zqsice[jk]) / fmax(zepsec, (double) 1.0 - + za[jk]); + + //--------------------------------------------- + // humidity in moistest ZCOVPCLR part of domain + //--------------------------------------------- + zqe = fmax((double) 0.0, fmin(zqe, zqsice[jk])); + llo1 = zcovpclr > zepsec && zqxfg[3] > zepsec && zqe < zzrh*zqsice[jk]; + + if (llo1) { + // note: zpreclr is a rain flux a + zpreclr = zqxfg[3]*zcovpclr / copysign(fmax(fabs(zcovptot*zdtgdp), + zepsilon), zcovptot*zdtgdp); + + //-------------------------------------- + // actual microphysics formula in zbeta + //-------------------------------------- + + zbeta1 = sqrt(pap[jl + klon*(jk + klev*(ibl))] / paph[jl + + klon*(klev + (klev + 1)*(ibl))]) / (*yrecldp).rvrfactor*zpreclr / + fmax(zcovpclr, zepsec); + + zbeta = rg*(*yrecldp).rpecons*(pow(zbeta1, (double) 0.5777)); + + zdenom = (double) 1.0 + zbeta*ptsphy*zcorqsice; + zdpr = zcovpclr*zbeta*(zqsice[jk] - zqe) / zdenom*zdp*zrg_r; + zdpevap = zdpr*zdtgdp; + + //--------------------------------------------------------- + // add evaporation term to explicit sink. + // this has to be explicit since if treated in the implicit + // term evaporation can not reduce snow to zero and model + // produces small amounts of snowfall everywhere. + //--------------------------------------------------------- + + // Evaporate snow + zevap = fmin(zdpevap, zqxfg[3]); + + zsolqa[4 + 5*(3)] = zsolqa[4 + 5*(3)] + zevap; + zsolqa[3 + 5*(4)] = zsolqa[3 + 5*(4)] - zevap; + + //------------------------------------------------------------- + // Reduce the total precip coverage proportional to evaporation + // to mimic the previous scheme which had a diagnostic + // 2-flux treatment, abandoned due to the new prognostic precip + //------------------------------------------------------------- + zcovptot = fmax((*yrecldp).rcovpmin, zcovptot - fmax((double) 0.0, (zcovptot - + za[jk])*zevap / zqxfg[3])); + + //Update first guess field + zqxfg[3] = zqxfg[3] - zevap; + + } + //--------------------------------------------------------- + } else if (ievapsnow == 2) { + + + + //----------------------------------------------------------------------- + // Calculate relative humidity limit for snow evaporation + //----------------------------------------------------------------------- + zzrh = (*yrecldp).rprecrhmax + ((double) 1.0 - (*yrecldp).rprecrhmax)*zcovpmax / + fmax(zepsec, (double) 1.0 - za[jk]); + zzrh = fmin(fmax(zzrh, (*yrecldp).rprecrhmax), (double) 1.0); + zqe = (zqx[jk + klev*(4)] - za[jk]*zqsice[jk]) / fmax(zepsec, (double) 1.0 - + za[jk]); + + //--------------------------------------------- + // humidity in moistest ZCOVPCLR part of domain + //--------------------------------------------- + zqe = fmax((double) 0.0, fmin(zqe, zqsice[jk])); + llo1 = + zcovpclr > zepsec && zqx[jk + klev*(3)] > zepsec && zqe < zzrh*zqsice[jk]; + + if (llo1) { + + // Calculate local precipitation (kg/kg) + zpreclr = zqx[jk + klev*(3)] / zcovptot; + zvpice = ((double)(r2es*exp((r3ies*(ztp1[jk] - rtt))/(ztp1[jk] - r4ies))))*rv / rd; + + // Particle size distribution + // ZTCG increases Ni with colder temperatures - essentially a + // Fletcher or Meyers scheme? + ztcg = (double) 1.0; //v1 EXP(RCL_X3I*(273.15_JPRB-ZTP1(JL,JK))/8.18_JPRB) + // ZFACX1I modification is based on Andrew Barrett's results + zfacx1s = (double) 1.0; //v1 (ZICE0/1.E-5_JPRB)**0.627_JPRB + + zaplusb = (*yrecldp).rcl_apb1*zvpice - (*yrecldp).rcl_apb2*zvpice*ztp1[jk] + + pap[jl + klon*(jk + klev*(ibl))]*(*yrecldp).rcl_apb3*(pow(ztp1[jk], + 3)); + zcorrfac = pow((1.0 / zrho), 0.5); + zcorrfac2 = (pow((ztp1[jk] / 273.0), 1.5))*(393.0 / (ztp1[jk] + 120.0)); + + zpr02 = zrho*zpreclr*(*yrecldp).rcl_const1s / (ztcg*zfacx1s); + + zterm1 = (zqsice[jk] - zqe)*(pow(ztp1[jk], 2))*zvpice*zcorrfac2*ztcg*(*yrecldp) + .rcl_const2s*zfacx1s / (zrho*zaplusb*zqsice[jk]); + zterm2 = 0.65*(*yrecldp).rcl_const6s*(pow(zpr02, (*yrecldp).rcl_const4s)) + + (*yrecldp).rcl_const3s*(pow(zcorrfac, 0.5))*(pow(zrho, 0.5))*(pow(zpr02, + (*yrecldp).rcl_const5s)) / (pow(zcorrfac2, 0.5)); + + zdpevap = fmax(zcovpclr*zterm1*zterm2*ptsphy, (double) 0.0); + + //-------------------------------------------------------------------- + // Limit evaporation to snow amount + //-------------------------------------------------------------------- + zevap = fmin(zdpevap, zevaplimice); + zevap = fmin(zevap, zqx[jk + klev*(3)]); + + + zsolqa[4 + 5*(3)] = zsolqa[4 + 5*(3)] + zevap; + zsolqa[3 + 5*(4)] = zsolqa[3 + 5*(4)] - zevap; + + //------------------------------------------------------------- + // Reduce the total precip coverage proportional to evaporation + // to mimic the previous scheme which had a diagnostic + // 2-flux treatment, abandoned due to the new prognostic precip + //------------------------------------------------------------- + zcovptot = fmax((*yrecldp).rcovpmin, zcovptot - fmax((double) 0.0, (zcovptot - + za[jk])*zevap / zqx[jk + klev*(3)])); + + //Update first guess field + zqxfg[3] = zqxfg[3] - zevap; + + } + + } + // on IEVAPSNOW + + //-------------------------------------- + // Evaporate small precipitation amounts + //-------------------------------------- + for (jm = 0; jm <= 5 + -1; jm += 1) { + if (llfall[jm]) { + if (zqxfg[jm] < (*yrecldp).rlmin) { + zsolqa[4 + 5*jm] = zsolqa[4 + 5*jm] + zqxfg[jm]; + zsolqa[jm + 5*(4)] = zsolqa[jm + 5*(4)] - zqxfg[jm]; + } + } + } + + //###################################################################### + // 5.0 *** SOLVERS FOR A AND L *** + // now use an implicit solution rather than exact solution + // solver is forward in time, upstream difference for advection + //###################################################################### + + //--------------------------- + // 5.1 solver for cloud cover + //--------------------------- + zanew = (za[jk] + zsolac) / ((double) 1.0 + zsolab); + zanew = fmin(zanew, (double) 1.0); + if (zanew < (*yrecldp).ramin) { + zanew = (double) 0.0; + } + zda = zanew - zaorig[jk]; + //--------------------------------- + // variables needed for next level + //--------------------------------- + zanewm1 = zanew; + + //-------------------------------- + // 5.2 solver for the microphysics + //-------------------------------- + + //-------------------------------------------------------------- + // Truncate explicit sinks to avoid negatives + // Note: Species are treated in the order in which they run out + // since the clipping will alter the balance for the other vars + //-------------------------------------------------------------- + + for (jm = 0; jm <= 5 + -1; jm += 1) { + for (jn = 0; jn <= 5 + -1; jn += 1) { + llindex3[jn + 5*jm] = false; + } + zsinksum[jm] = (double) 0.0; + } + + //---------------------------- + // collect sink terms and mark + //---------------------------- + for (jm = 0; jm <= 5 + -1; jm += 1) { + for (jn = 0; jn <= 5 + -1; jn += 1) { + zsinksum[jm] = zsinksum[jm] - zsolqa[jm + 5*jn]; // +ve total is bad + } + } + + //--------------------------------------- + // calculate overshoot and scaling factor + //--------------------------------------- + for (jm = 0; jm <= 5 + -1; jm += 1) { + zmax = fmax(zqx[jk + klev*jm], zepsec); + zrat = fmax(zsinksum[jm], zmax); + zratio[jm] = zmax / zrat; + } + + //-------------------------------------------- + // scale the sink terms, in the correct order, + // recalculating the scale factor each time + //-------------------------------------------- + for (jm = 0; jm <= 5 + -1; jm += 1) { + zsinksum[jm] = (double) 0.0; + } + + //---------------- + // recalculate sum + //---------------- + for (jm = 0; jm <= 5 + -1; jm += 1) { + psum_solqa = 0.0; + for (jn = 0; jn <= 5 + -1; jn += 1) { + psum_solqa = psum_solqa + zsolqa[jm + 5*jn]; + } + // ZSINKSUM(JL,JM)=ZSINKSUM(JL,JM)-SUM(ZSOLQA(JL,JM,1:NCLV)) + zsinksum[jm] = zsinksum[jm] - psum_solqa; + //--------------------------- + // recalculate scaling factor + //--------------------------- + zmm = fmax(zqx[jk + klev*jm], zepsec); + zrr = fmax(zsinksum[jm], zmm); + zratio[jm] = zmm / zrr; + //------ + // scale + //------ + zzratio = zratio[jm]; + //DIR$ IVDEP + //DIR$ PREFERVECTOR + for (jn = 0; jn <= 5 + -1; jn += 1) { + if (zsolqa[jm + 5*jn] < (double) 0.0) { + zsolqa[jm + 5*jn] = zsolqa[jm + 5*jn]*zzratio; + zsolqa[jn + 5*jm] = zsolqa[jn + 5*jm]*zzratio; + } + } + } + + //-------------------------------------------------------------- + // 5.2.2 Solver + //------------------------ + + //------------------------ + // set the LHS of equation + //------------------------ + for (jm = 0; jm <= 5 + -1; jm += 1) { + for (jn = 0; jn <= 5 + -1; jn += 1) { + //---------------------------------------------- + // diagonals: microphysical sink terms+transport + //---------------------------------------------- + if (jn + 1 == jm + 1) { + zqlhs[jn + 5*jm] = (double) 1.0 + zfallsink[jm]; + for (jo = 0; jo <= 5 + -1; jo += 1) { + zqlhs[jn + 5*jm] = zqlhs[jn + 5*jm] + zsolqb[jo + 5*jn]; + } + //------------------------------------------ + // non-diagonals: microphysical source terms + //------------------------------------------ + } else { + zqlhs[jn + 5*jm] = -zsolqb[jn + 5*jm]; // here is the delta T - missing from doc. + } + } + } + + //------------------------ + // set the RHS of equation + //------------------------ + for (jm = 0; jm <= 5 + -1; jm += 1) { + //--------------------------------- + // sum the explicit source and sink + //--------------------------------- + zexplicit = (double) 0.0; + for (jn = 0; jn <= 5 + -1; jn += 1) { + zexplicit = zexplicit + zsolqa[jm + 5*jn]; // sum over middle index + } + zqxn[jm] = zqx[jk + klev*jm] + zexplicit; + } + + //----------------------------------- + // *** solve by LU decomposition: *** + //----------------------------------- + + // Note: This fast way of solving NCLVxNCLV system + // assumes a good behaviour (i.e. non-zero diagonal + // terms with comparable orders) of the matrix stored + // in ZQLHS. For the moment this is the case but + // be aware to preserve it when doing eventual + // modifications. + + // Non pivoting recursive factorization + for (jn = 0; jn <= 5 - 1 + -1; jn += 1) { + // number of steps + for (jm = jn + 1; jm <= 5 + -1; jm += 1) { + // row index + zqlhs[jm + 5*jn] = zqlhs[jm + 5*jn] / zqlhs[jn + 5*jn]; + for (ik = jn + 1; ik <= 5 + -1; ik += 1) { + // column index + zqlhs[jm + 5*ik] = zqlhs[jm + 5*ik] - zqlhs[jm + 5*jn]*zqlhs[jn + 5*ik]; + } + } + } + + // Backsubstitution + // step 1 + for (jn = 1; jn <= 5 + -1; jn += 1) { + for (jm = 0; jm <= jn + 1 - 1 + -1; jm += 1) { + zqxn[jn] = zqxn[jn] - zqlhs[jn + 5*jm]*zqxn[jm]; + } + } + // step 2 + zqxn[4] = zqxn[4] / zqlhs[4 + 5*(4)]; + for (jn = -2 + 5; jn >= 1 + -1; jn += -1) { + for (jm = jn + 1; jm <= 5 + -1; jm += 1) { + zqxn[jn] = zqxn[jn] - zqlhs[jn + 5*jm]*zqxn[jm]; + } + zqxn[jn] = zqxn[jn] / zqlhs[jn + 5*jn]; + } + + // Ensure no small values (including negatives) remain in cloud variables nor + // precipitation rates. + // Evaporate l,i,r,s to water vapour. Latent heating taken into account below + for (jn = 0; jn <= 5 - 1 + -1; jn += 1) { + if (zqxn[jn] < zepsec) { + zqxn[4] = zqxn[4] + zqxn[jn]; + zqxn[jn] = (double) 0.0; + } + } + + //-------------------------------- + // variables needed for next level + //-------------------------------- + for (jm = 0; jm <= 5 + -1; jm += 1) { + zqxnm1[jm] = zqxn[jm]; + zqxn2d[jk + klev*jm] = zqxn[jm]; + } + + //------------------------------------------------------------------------ + // 5.3 Precipitation/sedimentation fluxes to next level + // diagnostic precipitation fluxes + // It is this scaled flux that must be used for source to next layer + //------------------------------------------------------------------------ + + for (jm = 0; jm <= 5 + -1; jm += 1) { + zpfplsx[1 + jk + (klev + 1)*jm] = zfallsink[jm]*zqxn[jm]*zrdtgdp; + } + + // Ensure precipitation fraction is zero if no precipitation + zqpretot = + zpfplsx[1 + jk + (klev + 1)*(3)] + zpfplsx[1 + jk + (klev + 1)*(2)]; + if (zqpretot < zepsec) { + zcovptot = (double) 0.0; + } + + //###################################################################### + // 6 *** UPDATE TENDANCIES *** + //###################################################################### + + //-------------------------------- + // 6.1 Temperature and CLV budgets + //-------------------------------- + + for (jm = 0; jm <= 5 - 1 + -1; jm += 1) { + + // calculate fluxes in and out of box for conservation of TL + zfluxq[jm] = zpsupsatsrce[jm] + zconvsrce[jm] + zfallsrce[jm] - (zfallsink[jm] + + zconvsink[jm])*zqxn[jm]; + + if (iphase[jm] == 1) { + tendency_loc_t[jl + klon*(jk + klev*(ibl))] = tendency_loc_t[jl + + klon*(jk + klev*(ibl))] + ralvdcp*(zqxn[jm] - zqx[jk + klev*jm] - + zfluxq[jm])*zqtmst; + } + + if (iphase[jm] == 2) { + tendency_loc_t[jl + klon*(jk + klev*(ibl))] = tendency_loc_t[jl + + klon*(jk + klev*(ibl))] + ralsdcp*(zqxn[jm] - zqx[jk + klev*jm] - + zfluxq[jm])*zqtmst; + } + + //---------------------------------------------------------------------- + // New prognostic tendencies - ice,liquid rain,snow + // Note: CLV arrays use PCLV in calculation of tendency while humidity + // uses ZQX. This is due to clipping at start of cloudsc which + // include the tendency already in TENDENCY_LOC_T and TENDENCY_LOC_q. ZQX was reset + //---------------------------------------------------------------------- + tendency_loc_cld[jl + klon*(jk + klev*(jm + 5*(ibl)))] = + tendency_loc_cld[jl + klon*(jk + klev*(jm + 5*(ibl)))] + (zqxn[jm] - + zqx0[jk + klev*jm])*zqtmst; + + } + + //---------------------- + // 6.2 Humidity budget + //---------------------- + tendency_loc_q[jl + klon*(jk + klev*(ibl))] = tendency_loc_q[jl + + klon*(jk + klev*(ibl))] + (zqxn[4] - zqx[jk + klev*(4)])*zqtmst; + + //------------------- + // 6.3 cloud cover + //----------------------- + tendency_loc_a[jl + klon*(jk + klev*(ibl))] = + tendency_loc_a[jl + klon*(jk + klev*(ibl))] + zda*zqtmst; + + //-------------------------------------------------- + // Copy precipitation fraction into output variable + //------------------------------------------------- + pcovptot[jl + klon*(jk + klev*(ibl))] = zcovptot; + + } + // on vertical level JK + //---------------------------------------------------------------------- + // END OF VERTICAL LOOP + //---------------------------------------------------------------------- + + //###################################################################### + // 8 *** FLUX/DIAGNOSTICS COMPUTATIONS *** + //###################################################################### + + //-------------------------------------------------------------------- + // Copy general precip arrays back into PFP arrays for GRIB archiving + // Add rain and liquid fluxes, ice and snow fluxes + //-------------------------------------------------------------------- + for (jk = 0; jk <= klev + 1 + -1; jk += 1) { + pfplsl[jl + klon*(jk + (klev + 1)*(ibl))] = + zpfplsx[jk + (klev + 1)*(2)] + zpfplsx[jk + (klev + 1)*(0)]; + pfplsn[jl + klon*(jk + (klev + 1)*(ibl))] = + zpfplsx[jk + (klev + 1)*(3)] + zpfplsx[jk + (klev + 1)*(1)]; + } + + //-------- + // Fluxes: + //-------- + pfsqlf[jl + klon*(0 + (klev + 1)*(ibl))] = (double) 0.0; + pfsqif[jl + klon*(0 + (klev + 1)*(ibl))] = (double) 0.0; + pfsqrf[jl + klon*(0 + (klev + 1)*(ibl))] = (double) 0.0; + pfsqsf[jl + klon*(0 + (klev + 1)*(ibl))] = (double) 0.0; + pfcqlng[jl + klon*(0 + (klev + 1)*(ibl))] = (double) 0.0; + pfcqnng[jl + klon*(0 + (klev + 1)*(ibl))] = (double) 0.0; + pfcqrng[jl + klon*(0 + (klev + 1)*(ibl))] = (double) 0.0; //rain + pfcqsng[jl + klon*(0 + (klev + 1)*(ibl))] = (double) 0.0; //snow + // fluxes due to turbulence + pfsqltur[jl + klon*(0 + (klev + 1)*(ibl))] = (double) 0.0; + pfsqitur[jl + klon*(0 + (klev + 1)*(ibl))] = (double) 0.0; + + for (jk = 0; jk <= klev + -1; jk += 1) { + + zgdph_r = -zrg_r*(paph[jl + klon*(1 + jk + (klev + 1)*(ibl))] - paph[ + jl + klon*(jk + (klev + 1)*(ibl))])*zqtmst; + pfsqlf[jl + klon*(1 + jk + (klev + 1)*(ibl))] = + pfsqlf[jl + klon*(jk + (klev + 1)*(ibl))]; + pfsqif[jl + klon*(1 + jk + (klev + 1)*(ibl))] = + pfsqif[jl + klon*(jk + (klev + 1)*(ibl))]; + pfsqrf[jl + klon*(1 + jk + (klev + 1)*(ibl))] = + pfsqlf[jl + klon*(jk + (klev + 1)*(ibl))]; + pfsqsf[jl + klon*(1 + jk + (klev + 1)*(ibl))] = + pfsqif[jl + klon*(jk + (klev + 1)*(ibl))]; + pfcqlng[jl + klon*(1 + jk + (klev + 1)*(ibl))] = + pfcqlng[jl + klon*(jk + (klev + 1)*(ibl))]; + pfcqnng[jl + klon*(1 + jk + (klev + 1)*(ibl))] = + pfcqnng[jl + klon*(jk + (klev + 1)*(ibl))]; + pfcqrng[jl + klon*(1 + jk + (klev + 1)*(ibl))] = + pfcqlng[jl + klon*(jk + (klev + 1)*(ibl))]; + pfcqsng[jl + klon*(1 + jk + (klev + 1)*(ibl))] = + pfcqnng[jl + klon*(jk + (klev + 1)*(ibl))]; + pfsqltur[jl + klon*(1 + jk + (klev + 1)*(ibl))] = + pfsqltur[jl + klon*(jk + (klev + 1)*(ibl))]; + pfsqitur[jl + klon*(1 + jk + (klev + 1)*(ibl))] = + pfsqitur[jl + klon*(jk + (klev + 1)*(ibl))]; + + zalfaw = zfoealfa[jk]; + + // Liquid , LS scheme minus detrainment + pfsqlf[jl + klon*(1 + jk + (klev + 1)*(ibl))] = pfsqlf[jl + klon*(1 + + jk + (klev + 1)*(ibl))] + (zqxn2d[jk + klev*(0)] - zqx0[jk + klev*(-1 + + 1)] + pvfl[jl + klon*(jk + klev*(ibl))]*ptsphy - zalfaw*plude[ + jl + klon*(jk + klev*(ibl))])*zgdph_r; + // liquid, negative numbers + pfcqlng[jl + klon*(1 + jk + (klev + 1)*(ibl))] = pfcqlng[jl + + klon*(1 + jk + (klev + 1)*(ibl))] + zlneg[jk + klev*(0)]*zgdph_r; + + // liquid, vertical diffusion + pfsqltur[jl + klon*(1 + jk + (klev + 1)*(ibl))] = pfsqltur[jl + + klon*(1 + jk + (klev + 1)*(ibl))] + pvfl[jl + klon*(jk + klev*(ibl + ))]*ptsphy*zgdph_r; + + // Rain, LS scheme + pfsqrf[jl + klon*(1 + jk + (klev + 1)*(ibl))] = pfsqrf[jl + klon*(1 + + jk + (klev + 1)*(ibl))] + (zqxn2d[jk + klev*(2)] - zqx0[jk + klev*(-1 + + 3)])*zgdph_r; + // rain, negative numbers + pfcqrng[jl + klon*(1 + jk + (klev + 1)*(ibl))] = pfcqrng[jl + + klon*(1 + jk + (klev + 1)*(ibl))] + zlneg[jk + klev*(2)]*zgdph_r; + + // Ice , LS scheme minus detrainment + pfsqif[jl + klon*(1 + jk + (klev + 1)*(ibl))] = pfsqif[jl + klon*(1 + + jk + (klev + 1)*(ibl))] + (zqxn2d[jk + klev*(1)] - zqx0[jk + klev*(-1 + + 2)] + pvfi[jl + klon*(jk + klev*(ibl))]*ptsphy - ((double) 1.0 - + zalfaw)*plude[jl + klon*(jk + klev*(ibl))])*zgdph_r; + // ice, negative numbers + pfcqnng[jl + klon*(1 + jk + (klev + 1)*(ibl))] = pfcqnng[jl + + klon*(1 + jk + (klev + 1)*(ibl))] + zlneg[jk + klev*(1)]*zgdph_r; + + // ice, vertical diffusion + pfsqitur[jl + klon*(1 + jk + (klev + 1)*(ibl))] = pfsqitur[jl + + klon*(1 + jk + (klev + 1)*(ibl))] + pvfi[jl + klon*(jk + klev*(ibl + ))]*ptsphy*zgdph_r; + + // snow, LS scheme + pfsqsf[jl + klon*(1 + jk + (klev + 1)*(ibl))] = pfsqsf[jl + klon*(1 + + jk + (klev + 1)*(ibl))] + (zqxn2d[jk + klev*(3)] - zqx0[jk + klev*(-1 + + 4)])*zgdph_r; + // snow, negative numbers + pfcqsng[jl + klon*(1 + jk + (klev + 1)*(ibl))] = pfcqsng[jl + + klon*(1 + jk + (klev + 1)*(ibl))] + zlneg[jk + klev*(3)]*zgdph_r; + } + + //----------------------------------- + // enthalpy flux due to precipitation + //----------------------------------- + for (jk = 0; jk <= klev + 1 + -1; jk += 1) { + pfhpsl[jl + klon*(jk + (klev + 1)*(ibl))] = + -rlvtt*pfplsl[jl + klon*(jk + (klev + 1)*(ibl))]; + pfhpsn[jl + klon*(jk + (klev + 1)*(ibl))] = + -rlstt*pfplsn[jl + klon*(jk + (klev + 1)*(ibl))]; + } +} + diff --git a/src/cloudsc_hip/cloudsc/cloudsc_c.h b/src/cloudsc_hip/cloudsc/cloudsc_c.h new file mode 100644 index 00000000..e4d0364b --- /dev/null +++ b/src/cloudsc_hip/cloudsc/cloudsc_c.h @@ -0,0 +1,44 @@ +#include "hip/hip_runtime.h" +/* + * (C) Copyright 1988- ECMWF. + * + * This software is licensed under the terms of the Apache Licence Version 2.0 + * which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. + * In applying this licence, ECMWF does not waive the privileges and immunities + * granted to it by virtue of its status as an intergovernmental organisation + * nor does it submit to any jurisdiction. + */ + +#include "hip/hip_runtime.h" +#include "yoecldp_c.h" +#include + +__global__ void __launch_bounds__(128, 1) cloudsc_c(int kidia, int kfdia, int klon, double ptsphy, + const double * __restrict__ pt, + const double * __restrict__ pq, const double * __restrict__ tendency_tmp_t, + const double * __restrict__ tendency_tmp_q, const double * __restrict__ tendency_tmp_a, + const double * __restrict__ tendency_tmp_cld, double * __restrict__ tendency_loc_t, + double * __restrict__ tendency_loc_q, double * __restrict__ tendency_loc_a, + double * __restrict__ tendency_loc_cld, const double * __restrict__ pvfa, + const double * __restrict__ pvfl, const double * __restrict__ pvfi, const double * __restrict__ pdyna, + const double * __restrict__ pdynl, const double * __restrict__ pdyni, const double * __restrict__ phrsw, + double * __restrict__ phrlw, const double * __restrict__ pvervel, const double * __restrict__ pap, + const double * __restrict__ paph, const double * __restrict__ plsm, + const int * ktype, const double * __restrict__ plu, double * __restrict__ plude, + const double * __restrict__ psnde, const double * __restrict__ pmfu, const double * __restrict__ pmfd, + const double * __restrict__ pa, const double * __restrict__ pclv, const double * __restrict__ psupsat, + const double * __restrict__ plcrit_aer, const double * __restrict__ picrit_aer, + const double * __restrict__ pre_ice, const double * __restrict__ pccn, const double * __restrict__ pnice, + double * __restrict__ pcovptot, double * __restrict__ prainfrac_toprfz, + double * __restrict__ pfsqlf, double * __restrict__ pfsqif, double * __restrict__ pfcqnng, + double * __restrict__ pfcqlng, double * __restrict__ pfsqrf, double * __restrict__ pfsqsf, + double * __restrict__ pfcqrng, double * __restrict__ pfcqsng, + double * __restrict__ pfsqltur, double * __restrict__ pfsqitur, + double * __restrict__ pfplsl, double * __restrict__ pfplsn, double * __restrict__ pfhpsl, + double * __restrict__ pfhpsn, struct TECLDP *yrecldp, int ngpblks, + double rg, double rd, double rcpd, double retv, double rlvtt, double rlstt, double rlmlt, double rtt, + double rv, double r2es, double r3les, double r3ies, double r4les, double r4ies, double r5les, + double r5ies, double r5alvcp, double r5alscp, double ralvdcp, double ralsdcp, double ralfdcp, + double rtwat, double rtice, double rticecu, double rtwat_rtice_r, double rtwat_rticecu_r, + double rkoop1, double rkoop2); + diff --git a/src/cloudsc_hip/cloudsc/cloudsc_c_hoist.cpp b/src/cloudsc_hip/cloudsc/cloudsc_c_hoist.cpp new file mode 100644 index 00000000..9506d2c6 --- /dev/null +++ b/src/cloudsc_hip/cloudsc/cloudsc_c_hoist.cpp @@ -0,0 +1,2651 @@ +#include "hip/hip_runtime.h" +/* + * (C) Copyright 1988- ECMWF. + * + * This software is licensed under the terms of the Apache Licence Version 2.0 + * which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. + * In applying this licence, ECMWF does not waive the privileges and immunities + * granted to it by virtue of its status as an intergovernmental organisation + * nor does it submit to any jurisdiction. + */ +#include "cloudsc_c_hoist.h" +#include + +__global__ void cloudsc_c(int kidia, int kfdia, int klon, double ptsphy, + const double * __restrict__ pt, + const double * __restrict__ pq, const double * __restrict__ tendency_tmp_t, + const double * __restrict__ tendency_tmp_q, const double * __restrict__ tendency_tmp_a, + const double * __restrict__ tendency_tmp_cld, double * __restrict__ tendency_loc_t, + double * __restrict__ tendency_loc_q, double * __restrict__ tendency_loc_a, + double * __restrict__ tendency_loc_cld, const double * __restrict__ pvfa, + const double * __restrict__ pvfl, const double * __restrict__ pvfi, const double * __restrict__ pdyna, + const double * __restrict__ pdynl, const double * __restrict__ pdyni, const double * __restrict__ phrsw, + double * __restrict__ phrlw, const double * __restrict__ pvervel, const double * __restrict__ pap, + const double * __restrict__ paph, const double * __restrict__ plsm, + const int * ktype, const double * __restrict__ plu, double * __restrict__ plude, + const double * __restrict__ psnde, const double * __restrict__ pmfu, const double * __restrict__ pmfd, + const double * __restrict__ pa, const double * __restrict__ pclv, const double * __restrict__ psupsat, + const double * __restrict__ plcrit_aer, const double * __restrict__ picrit_aer, + const double * __restrict__ pre_ice, const double * __restrict__ pccn, const double * __restrict__ pnice, + double * __restrict__ pcovptot, double * __restrict__ prainfrac_toprfz, + double * __restrict__ pfsqlf, double * __restrict__ pfsqif, double * __restrict__ pfcqnng, + double * __restrict__ pfcqlng, double * __restrict__ pfsqrf, double * __restrict__ pfsqsf, + double * __restrict__ pfcqrng, double * __restrict__ pfcqsng, + double * __restrict__ pfsqltur, double * __restrict__ pfsqitur, + double * __restrict__ pfplsl, double * __restrict__ pfplsn, double * __restrict__ pfhpsl, + double * __restrict__ pfhpsn, struct TECLDP *yrecldp, int ngpblks, + double rg, double rd, double rcpd, double retv, double rlvtt, double rlstt, double rlmlt, double rtt, + double rv, double r2es, double r3les, double r3ies, double r4les, double r4ies, double r5les, + double r5ies, double r5alvcp, double r5alscp, double ralvdcp, double ralsdcp, double ralfdcp, + double rtwat, double rtice, double rticecu, double rtwat_rtice_r, double rtwat_rticecu_r, + double rkoop1, double rkoop2, + double * __restrict__ zfoealfa, double * __restrict__ ztp1, double * __restrict__ zli, + double * __restrict__ za, double * __restrict__ zaorig, double * __restrict__ zliqfrac, + double * __restrict__ zicefrac, double * __restrict__ zqx, double * __restrict__ zqx0, + double * __restrict__ zpfplsx, double * __restrict__ zlneg, double * __restrict__ zqxn2d, + double * __restrict__ zqsmix, double * __restrict__ zqsliq, double * __restrict__ zqsice, + double * __restrict__ zfoeewmt, double * __restrict__ zfoeew, double * __restrict__ zfoeeliqt) { + + //------------------------------------------------------------------------------- + // Declare input/output arguments + //------------------------------------------------------------------------------- + + // PLCRIT_AER : critical liquid mmr for rain autoconversion process + // PICRIT_AER : critical liquid mmr for snow autoconversion process + // PRE_LIQ : liq Re + // PRE_ICE : ice Re + // PCCN : liquid cloud condensation nuclei + // PNICE : ice number concentration (cf. CCN) + + const int klev = 137; // Number of levels + + double zlcond1, zlcond2, zlevapl, zlevapi, zrainaut, zsnowaut, zliqcld, zicecld; + double zlevap, zleros; + // condensation and evaporation terms + // autoconversion terms + double zfokoop; + //double zfoealfa[klev + 1]; + double zicenuclei; // number concentration of ice nuclei + + double zlicld; + double zacond; + double zaeros; + double zlfinalsum; + double zdqs; + double ztold; + double zqold; + double zdtgdp; + double zrdtgdp; + double ztrpaus; + double zcovpclr; + double zpreclr; + double zcovptot; + double zcovpmax; + double zqpretot; + double zdpevap; + double zdtforc; + double zdtdiab; + //double ztp1[klev]; + double zldefr; + double zldifdt; + double zdtgdpf; + double zlcust[5]; + double zacust; + double zmf; + + double zrho; + double ztmp1, ztmp2, ztmp3; + double ztmp4, ztmp5, ztmp6, ztmp7; + double zalfawm; + + // Accumulators of A,B,and C factors for cloud equations + double zsolab; // -ve implicit CC + double zsolac; // linear CC + double zanew; + double zanewm1; + + double zgdp; + + //---for flux calculation + double zda; + //double zli[klev], za[klev]; + //double zaorig[klev]; // start of scheme value for CC + + int llflag; + int llo1; + + int icall, ik, jk, jl, jm, jn, jo, jlen, is; + + double zdp, zpaphd; + + double zalfa; + // & ZALFACU, ZALFALS + double zalfaw; + double zbeta, zbeta1; + //REAL(KIND=JPRB) :: ZBOTT + double zcfpr; + double zcor; + double zcdmax; + double zmin; + double zlcondlim; + double zdenom; + double zdpmxdt; + double zdpr; + double zdtdp; + double ze; + double zepsec; + double zfac, zfaci, zfacw; + double zgdcp; + double zinew; + double zlcrit; + double zmfdn; + double zprecip; + double zqe; + double zqsat, zqtmst, zrdcp; + double zrhc, zsig, zsigk; + double zwtot; + double zzco, zzdl, zzrh, zzzdt, zqadj; + double zqnew, ztnew; + double zrg_r, zgdph_r, zcons1, zcond, zcons1a; + double zlfinal; + double zmelt; + double zevap; + double zfrz; + double zvpliq, zvpice; + double zadd, zbdd, zcvds, zice0, zdepos; + double zsupsat; + double zfall; + double zre_ice; + double zrldcp; + double zqp1env; + + //---------------------------- + // Arrays for new microphysics + //---------------------------- + int iphase[5]; // marker for water phase of each species + // 0=vapour, 1=liquid, 2=ice + + int imelt[5]; // marks melting linkage for ice categories + // ice->liquid, snow->rain + + int llfall[5]; // marks falling species + // LLFALL=0, cloud cover must > 0 for zqx > 0 + // LLFALL=1, no cloud needed, zqx can evaporate + + int llindex1[5]; // index variable + int llindex3[5 * 5]; // index variable + double zmax; + double zrat; + int iorder[5]; // array for sorting explicit terms + + //double zliqfrac[klev]; // cloud liquid water fraction: ql/(ql+qi) + //double zicefrac[klev]; // cloud ice water fraction: qi/(ql+qi) + double zqxn[5]; // new values for zqx at time+1 + double zqxfg[5]; // first guess values including precip + double zqxnm1[5]; // new values for zqx at time+1 at level above + double zfluxq[5]; // fluxes convergence of species (needed?) + // Keep the following for possible future total water variance scheme? + //REAL(KIND=JPRB) :: ZTL(KLON,KLEV) ! liquid water temperature + //REAL(KIND=JPRB) :: ZABETA(KLON,KLEV) ! cloud fraction + //REAL(KIND=JPRB) :: ZVAR(KLON,KLEV) ! temporary variance + //REAL(KIND=JPRB) :: ZQTMIN(KLON,KLEV) + //REAL(KIND=JPRB) :: ZQTMAX(KLON,KLEV) + + double zmeltmax; + double zfrzmax; + double zicetot; + + + //double zqsmix[klev]; // diagnostic mixed phase saturation + //REAL(KIND=JPRB) :: ZQSBIN(KLON,KLEV) ! binary switched ice/liq saturation + //double zqsliq[klev]; // liquid water saturation + //double zqsice[klev]; // ice water saturation + + //REAL(KIND=JPRB) :: ZRHM(KLON,KLEV) ! diagnostic mixed phase RH + //REAL(KIND=JPRB) :: ZRHL(KLON,KLEV) ! RH wrt liq + //REAL(KIND=JPRB) :: ZRHI(KLON,KLEV) ! RH wrt ice + + //double zfoeewmt[klev]; + //double zfoeew[klev]; + //double zfoeeliqt[klev]; + //REAL(KIND=JPRB) :: ZFOEEICET(KLON,KLEV) + + double zdqsliqdt, zdqsicedt, zdqsmixdt; + double zcorqsliq; + double zcorqsice; + //REAL(KIND=JPRB) :: ZCORQSBIN(KLON) + double zcorqsmix; + double zevaplimliq, zevaplimice, zevaplimmix; + + //------------------------------------------------------- + // SOURCE/SINK array for implicit and explicit terms + //------------------------------------------------------- + // a POSITIVE value entered into the arrays is a... + // Source of this variable + // | + // | Sink of this variable + // | | + // V V + // ZSOLQA(JL,IQa,IQb) = explicit terms + // ZSOLQB(JL,IQa,IQb) = implicit terms + // Thus if ZSOLAB(JL,NCLDQL,IQV)=K where K>0 then this is + // a source of NCLDQL and a sink of IQV + // put 'magic' source terms such as PLUDE from + // detrainment into explicit source/sink array diagnognal + // ZSOLQA(NCLDQL,NCLDQL)= -PLUDE + // i.e. A positive value is a sink!????? weird... + //------------------------------------------------------- + + double zsolqa[5 * 5]; // explicit sources and sinks + double zsolqb[5 * 5]; // implicit sources and sinks + // e.g. microphysical pathways between ice variables. + double zqlhs[5 * 5]; // n x n matrix storing the LHS of implicit solver + double zvqx[5]; // fall speeds of three categories + double zexplicit; + double zratio[5], zsinksum[5]; + + // for sedimentation source/sink terms + double zfallsink[5]; + double zfallsrce[5]; + + // for convection detrainment source and subsidence source/sink terms + double zconvsrce[5]; + double zconvsink[5]; + + // for supersaturation source term from previous timestep + double zpsupsatsrce[5]; + + // Numerical fit to wet bulb temperature + double ztw1 = (double) 1329.31; + double ztw2 = (double) 0.0074615; + double ztw3 = (double) 0.85E5; + double ztw4 = (double) 40.637; + double ztw5 = (double) 275.0; + + double zsubsat; // Subsaturation for snow melting term + double ztdmtw0; // Diff between dry-bulb temperature and + // temperature when wet-bulb = 0degC + + // Variables for deposition term + double ztcg; // Temperature dependent function for ice PSD + double zfacx1i, zfacx1s; // PSD correction factor + double zaplusb, zcorrfac, zcorrfac2, zpr02, zterm1, zterm2; // for ice dep + double zcldtopdist; // Distance from cloud top + double zinfactor; // No. of ice nuclei factor for deposition + + // Autoconversion/accretion/riming/evaporation + int iwarmrain; + int ievaprain; + int ievapsnow; + int idepice; + double zrainacc; + double zraincld; + double zsnowrime; + double zsnowcld; + double zesatliq; + double zfallcorr; + double zlambda; + double zevap_denom; + double zcorr2; + double zka; + double zconst; + double ztemp; + + // Rain freezing + int llrainliq; // True if majority of raindrops are liquid (no ice core) + + //---------------------------- + // End: new microphysics + //---------------------------- + + //---------------------- + // SCM budget statistics + //---------------------- + double zrain; + + double zhook_handle; + double ztmpl, ztmpi, ztmpa; + + double zmm, zrr; + double zrg; + + double zzsum, zzratio; + double zepsilon; + + double zcond1, zqp; + + double psum_solqa; + int ibl; + int i_llfall_0; + //double zqx[5 * klev]; + //double zqx0[5 * klev]; + //double zpfplsx[5 * (klev + 1)]; + //double zlneg[5 * klev]; + //double zqxn2d[5 * klev]; + + jl = threadIdx.x; + ibl = blockIdx.x; //blockIdx.z; + + + //=============================================================================== + //IF (LHOOK) CALL DR_HOOK('CLOUDSC',0,ZHOOK_HANDLE) + + //=============================================================================== + // 0.0 Beginning of timestep book-keeping + //---------------------------------------------------------------------- + + + //###################################################################### + // 0. *** SET UP CONSTANTS *** + //###################################################################### + + zepsilon = (double) 100.*DBL_EPSILON; + + // --------------------------------------------------------------------- + // Set version of warm-rain autoconversion/accretion + // IWARMRAIN = 1 ! Sundquist + // IWARMRAIN = 2 ! Khairoutdinov and Kogan (2000) + // --------------------------------------------------------------------- + iwarmrain = 2; + // --------------------------------------------------------------------- + // Set version of rain evaporation + // IEVAPRAIN = 1 ! Sundquist + // IEVAPRAIN = 2 ! Abel and Boutle (2013) + // --------------------------------------------------------------------- + ievaprain = 2; + // --------------------------------------------------------------------- + // Set version of snow evaporation + // IEVAPSNOW = 1 ! Sundquist + // IEVAPSNOW = 2 ! New + // --------------------------------------------------------------------- + ievapsnow = 1; + // --------------------------------------------------------------------- + // Set version of ice deposition + // IDEPICE = 1 ! Rotstayn (2001) + // IDEPICE = 2 ! New + // --------------------------------------------------------------------- + idepice = 1; + + // --------------------- + // Some simple constants + // --------------------- + zqtmst = (double) 1.0 / ptsphy; + zgdcp = rg / rcpd; + zrdcp = rd / rcpd; + zcons1a = rcpd / (rlmlt*rg*(*yrecldp).rtaumel); + zepsec = (double) 1.E-14; + zrg_r = (double) 1.0 / rg; + zrldcp = (double) 1.0 / (ralsdcp - ralvdcp); + + // Note: Defined in module/yoecldp.F90 + // NCLDQL=1 ! liquid cloud water + // NCLDQI=2 ! ice cloud water + // NCLDQR=3 ! rain water + // NCLDQS=4 ! snow + // NCLDQV=5 ! vapour + + // ----------------------------------------------- + // Define species phase, 0=vapour, 1=liquid, 2=ice + // ----------------------------------------------- + iphase[4] = 0; + iphase[0] = 1; + iphase[2] = 1; + iphase[1] = 2; + iphase[3] = 2; + + // --------------------------------------------------- + // Set up melting/freezing index, + // if an ice category melts/freezes, where does it go? + // --------------------------------------------------- + imelt[4] = -99; + imelt[0] = 2; + imelt[2] = 4; + imelt[1] = 3; + imelt[3] = 3; + + // ----------------------------------------------- + // INITIALIZATION OF OUTPUT TENDENCIES + // ----------------------------------------------- + for (jk = 0; jk <= klev + -1; jk += 1) { + tendency_loc_t[jl + klon*(jk + klev*ibl)] = (double) 0.0; + tendency_loc_q[jl + klon*(jk + klev*ibl)] = (double) 0.0; + tendency_loc_a[jl + klon*(jk + klev*ibl)] = (double) 0.0; + } + for (jm = 0; jm <= 5 - 1 + -1; jm += 1) { + for (jk = 0; jk <= klev + -1; jk += 1) { + tendency_loc_cld[jl + klon*(jk + klev*(jm + 5*ibl))] = (double) 0.0; + } + } + + //-- These were uninitialized : meaningful only when we compare error differences + for (jk = 0; jk <= klev + -1; jk += 1) { + pcovptot[jl + klon*(jk + klev*ibl)] = (double) 0.0; + tendency_loc_cld[jl + klon*(jk + klev*(4 + 5*ibl))] = (double) 0.0; + } + + // ------------------------- + // set up fall speeds in m/s + // ------------------------- + zvqx[4] = (double) 0.0; + zvqx[0] = (double) 0.0; + zvqx[1] = (*yrecldp).rvice; + zvqx[2] = (*yrecldp).rvrain; + zvqx[3] = (*yrecldp).rvsnow; + for (i_llfall_0 = 0; i_llfall_0 <= 5 + -1; i_llfall_0 += 1) { + llfall[i_llfall_0] = false; + } + for (jm = 0; jm <= 5 + -1; jm += 1) { + if (zvqx[jm] > (double) 0.0) { + llfall[jm] = true; + } + // falling species + } + // Set LLFALL to false for ice (but ice still sediments!) + // Need to rationalise this at some point + llfall[1] = false; + + + //###################################################################### + // 1. *** INITIAL VALUES FOR VARIABLES *** + //###################################################################### + + + // ---------------------- + // non CLV initialization + // ---------------------- + for (jk = 0; jk <= klev + -1; jk += 1) { + ztp1[jl + klon*(jk + klev*ibl)] = + pt[jl + klon*(jk + klev*ibl)] + ptsphy*tendency_tmp_t[jl + klon*(jk + klev*ibl)]; + zqx[jl + klon*(jk + klev*(4 + 5*ibl))] = + pq[jl + klon*(jk + klev*ibl)] + ptsphy*tendency_tmp_q[jl + klon*(jk + klev*ibl)]; + zqx0[jl + klon*(jk + klev*(4 + 5*ibl))] = + pq[jl + klon*(jk + klev*ibl)] + ptsphy*tendency_tmp_q[jl + klon*(jk + klev*ibl)]; + za[jl + klon*(jk + klev*ibl)] = + pa[jl + klon*(jk + klev*ibl)] + ptsphy*tendency_tmp_a[jl + klon*(jk + klev*ibl)]; + zaorig[jl + klon*(jk + klev*ibl)] = + pa[jl + klon*(jk + klev*ibl)] + ptsphy*tendency_tmp_a[jl + klon*(jk + klev*ibl)]; + } + + // ------------------------------------- + // initialization for CLV family + // ------------------------------------- + for (jm = 0; jm <= 5 - 1 + -1; jm += 1) { + for (jk = 0; jk <= klev + -1; jk += 1) { + zqx[jl + klon*(jk + klev*(jm + 5*ibl))] = pclv[jl + klon*(jk + klev*(jm + 5*ibl))] + + ptsphy*tendency_tmp_cld[jl + klon*(jk + klev*(jm + 5*ibl))]; + zqx0[jl + klon*(jk + klev*(jm + 5*ibl))] = pclv[jl + klon*(jk + klev*(jm + 5*ibl))] + + ptsphy*tendency_tmp_cld[jl + klon*(jk + klev*(jm + 5*ibl))]; + } + } + + //------------- + // zero arrays + //------------- + for (jm = 0; jm <= 5 + -1; jm += 1) { + for (jk = 0; jk <= klev + 1 + -1; jk += 1) { + zpfplsx[jl + klon*(jk + (klev + 1)*(jm + 5*ibl))] = (double) 0.0; // precip fluxes + } + } + + for (jm = 0; jm <= 5 + -1; jm += 1) { + for (jk = 0; jk <= klev + -1; jk += 1) { + zqxn2d[jl + klon*(jk + klev*(jm + 5*ibl))] = (double) 0.0; // end of timestep values in 2D + zlneg[jl + klon*(jk + klev*(jm + 5*ibl))] = (double) 0.0; // negative input check + } + } + + prainfrac_toprfz[jl + klon*ibl] = (double) 0.0; // rain fraction at top of refreezing layer + llrainliq = true; // Assume all raindrops are liquid initially + + // ---------------------------------------------------- + // Tidy up very small cloud cover or total cloud water + // ---------------------------------------------------- + for (jk = 0; jk <= klev + -1; jk += 1) { + if (zqx[jl + klon*(jk + klev*(0 + 5*ibl))] + + zqx[jl + klon*(jk + klev*(1 + 5*ibl))] < (*yrecldp).rlmin || + za[jl + klon*(jk + klev*ibl)] < (*yrecldp).ramin) { + + // Evaporate small cloud liquid water amounts + zlneg[jl + klon*(jk + klev*(0 + 5*ibl))] = zlneg[jl + klon*(jk + klev*(0 + 5*ibl))] + + zqx[jl + klon*(jk + klev*(0 + 5*ibl))]; + zqadj = zqx[jl + klon*(jk + klev*(0 + 5*ibl))]*zqtmst; + tendency_loc_q[jl + klon*(jk + klev*ibl)] = + tendency_loc_q[jl + klon*(jk + klev*ibl)] + zqadj; + tendency_loc_t[jl + klon*(jk + klev*ibl)] = + tendency_loc_t[jl + klon*(jk + klev*ibl)] - ralvdcp*zqadj; + zqx[jl + klon*(jk + klev*(4 + 5*ibl))] = zqx[jl + klon*(jk + klev*(4 + 5*ibl))] + + zqx[jl + klon*(jk + klev*(0 + 5*ibl))]; + zqx[jl + klon*(jk + klev*(0 + 5*ibl))] = (double) 0.0; + + // Evaporate small cloud ice water amounts + zlneg[jl + klon*(jk + klev*(1 + 5*ibl))] = zlneg[jl + klon*(jk + klev*(1 + 5*ibl))] + + zqx[jl + klon*(jk + klev*(1 + 5*ibl))]; + zqadj = zqx[jl + klon*(jk + klev*(1 + 5*ibl))]*zqtmst; + tendency_loc_q[jl + klon*(jk + klev*ibl)] = + tendency_loc_q[jl + klon*(jk + klev*ibl)] + zqadj; + tendency_loc_t[jl + klon*(jk + klev*ibl)] = + tendency_loc_t[jl + klon*(jk + klev*ibl)] - ralsdcp*zqadj; + zqx[jl + klon*(jk + klev*(4 + 5*ibl))] = zqx[jl + klon*(jk + klev*(4 + 5*ibl))] + + zqx[jl + klon*(jk + klev*(1 + 5*ibl))]; + zqx[jl + klon*(jk + klev*(1 + 5*ibl))] = (double) 0.0; + + // Set cloud cover to zero + za[jl + klon*(jk + klev*ibl)] = (double) 0.0; + + } + } + + // --------------------------------- + // Tidy up small CLV variables + // --------------------------------- + for (jm = 0; jm <= 5 - 1 + -1; jm += 1) { + for (jk = 0; jk <= klev + -1; jk += 1) { + if (zqx[jl + klon*(jk + klev*(jm + 5*ibl))] < (*yrecldp).rlmin) { + zlneg[jl + klon*(jk + klev*(jm + 5*ibl))] = zlneg[jl + klon*(jk + klev*(jm + 5*ibl))] + + zqx[jl + klon*(jk + klev*(jm + 5*ibl))]; + zqadj = zqx[jl + klon*(jk + klev*(jm + 5*ibl))]*zqtmst; + tendency_loc_q[jl + klon*(jk + klev*ibl)] = + tendency_loc_q[jl + klon*(jk + klev*ibl)] + zqadj; + if (iphase[jm] == 1) { + tendency_loc_t[jl + klon*(jk + klev*ibl)] = + tendency_loc_t[jl + klon*(jk + klev*ibl)] - ralvdcp*zqadj; + } + if (iphase[jm] == 2) { + tendency_loc_t[jl + klon*(jk + klev*ibl)] = + tendency_loc_t[jl + klon*(jk + klev*ibl)] - ralsdcp*zqadj; + } + zqx[jl + klon*(jk + klev*(4 + 5*ibl))] = zqx[jl + klon*(jk + klev*(4 + 5*ibl))] + + zqx[jl + klon*(jk + klev*(jm + 5*ibl))]; + zqx[jl + klon*(jk + klev*(jm + 5*ibl))] = (double) 0.0; + } + } + } + + + // ------------------------------ + // Define saturation values + // ------------------------------ + for (jk = 0; jk <= klev + -1; jk += 1) { + //---------------------------------------- + // old *diagnostic* mixed phase saturation + //---------------------------------------- + zfoealfa[jl + klon*(jk + (klev + 1)*ibl)] = + ((double)(fmin(1.0, pow((fmax(rtice, fmin(rtwat, ztp1[jl + klon*(jk + klev*ibl)])) - rtice)*rtwat_rtice_r, 2)))); + zfoeewmt[jl + klon*(jk + klev*ibl)] = + fmin(((double)(r2es*((double)(fmin(1.0, pow((fmax(rtice, fmin(rtwat, ztp1[jl + klon*(jk + klev*ibl)])) - rtice)*rtwat_rtice_r, 2)))* + exp((r3les*(ztp1[jl + klon*(jk + klev*ibl)] - rtt))/(ztp1[jl + klon*(jk + klev*ibl)] - r4les)) + + (1.0 - (double)(fmin(1.0, pow((fmax(rtice, fmin(rtwat, ztp1[jl + klon*(jk + klev*ibl)])) - rtice)*rtwat_rtice_r, 2))))* + exp((r3ies*(ztp1[jl + klon*(jk + klev*ibl)] - rtt))/(ztp1[jl + klon*(jk + klev*ibl)] - r4ies))))) / + pap[jl + klon*(jk + klev*ibl)], (double) 0.5); + zqsmix[jl + klon*(jk + klev*ibl)] = zfoeewmt[jl + klon*(jk + klev*ibl)]; + zqsmix[jl + klon*(jk + klev*ibl)] = zqsmix[jl + klon*(jk + klev*ibl)] / + ((double) 1.0 - retv*zqsmix[jl + klon*(jk + klev*ibl)]); + + //--------------------------------------------- + // ice saturation T<273K + // liquid water saturation for T>273K + //--------------------------------------------- + zalfa = ((double)(fmax(0.0, copysign(1.0, ztp1[jl + klon*(jk + klev*ibl)] - rtt)))); + zfoeew[jl + klon*(jk + klev*ibl)] = fmin((zalfa*((double)(r2es*exp((r3les*(ztp1[jl + klon*(jk + klev*ibl)] - rtt))/ + (ztp1[jl + klon*(jk + klev*ibl)] - r4les)))) + ((double) 1.0 - zalfa)* + ((double)(r2es*exp((r3ies*(ztp1[jl + klon*(jk + klev*ibl)] - rtt))/(ztp1[jl + klon*(jk + klev*ibl)] - r4ies)))))/ + pap[jl + klon*(jk + klev*ibl)], (double) 0.5); + zfoeew[jl + klon*(jk + klev*ibl)] = fmin((double) 0.5, zfoeew[jl + klon*(jk + klev*ibl)]); + zqsice[jl + klon*(jk + klev*ibl)] = zfoeew[jl + klon*(jk + klev*ibl)] / + ((double) 1.0 - retv*zfoeew[jl + klon*(jk + klev*ibl)]); + + //---------------------------------- + // liquid water saturation + //---------------------------------- + zfoeeliqt[jl + klon*(jk + klev*ibl)] = fmin(((double)(r2es*exp((r3les*(ztp1[jl + klon*(jk + klev*ibl)] - rtt))/ + (ztp1[jl + klon*(jk + klev*ibl)] - r4les)))) / pap[jl + klon*(jk + klev*ibl)], (double) 0.5); + zqsliq[jl + klon*(jk + klev*ibl)] = zfoeeliqt[jl + klon*(jk + klev*ibl)]; + zqsliq[jl + klon*(jk + klev*ibl)] = zqsliq[jl + klon*(jk + klev*ibl)] / + ((double) 1.0 - retv*zqsliq[jl + klon*(jk + klev*ibl)]); + + // !---------------------------------- + // ! ice water saturation + // !---------------------------------- + // ZFOEEICET(JL,JK)=MIN(FOEEICE(ZTP1(JL,JK))/PAP(JL,JK),0.5_JPRB) + // ZQSICE(JL,JK)=ZFOEEICET(JL,JK) + // ZQSICE(JL,JK)=ZQSICE(JL,JK)/(1.0_JPRB-RETV*ZQSICE(JL,JK)) + + } + + for (jk = 0; jk <= klev + -1; jk += 1) { + + + //------------------------------------------ + // Ensure cloud fraction is between 0 and 1 + //------------------------------------------ + za[jl + klon*(jk + klev*ibl)] = + fmax((double) 0.0, fmin((double) 1.0, za[jl + klon*(jk + klev*ibl)])); + + //------------------------------------------------------------------- + // Calculate liq/ice fractions (no longer a diagnostic relationship) + //------------------------------------------------------------------- + zli[jl + klon*(jk + klev*ibl)] = zqx[jl + klon*(jk + klev*(0 + 5*ibl))] + + zqx[jl + klon*(jk + klev*(1 + 5*ibl))]; + if (zli[jl + klon*(jk + klev*ibl)] > (*yrecldp).rlmin) { + zliqfrac[jl + klon*(jk + klev*ibl)] = + zqx[jl + klon*(jk + klev*(0 + 5*ibl))] / zli[jl + klon*(jk + klev*ibl)]; + zicefrac[jl + klon*(jk + klev*ibl)] = + (double) 1.0 - zliqfrac[jl + klon*(jk + klev*ibl)]; + } else { + zliqfrac[jl + klon*(jk + klev*ibl)] = (double) 0.0; + zicefrac[jl + klon*(jk + klev*ibl)] = (double) 0.0; + } + } + + //###################################################################### + // 2. *** CONSTANTS AND PARAMETERS *** + //###################################################################### + // Calculate L in updrafts of bl-clouds + // Specify QS, P/PS for tropopause (for c2) + // And initialize variables + //------------------------------------------ + + //--------------------------------- + // Find tropopause level (ZTRPAUS) + //--------------------------------- + ztrpaus = (double) 0.1; + zpaphd = (double) 1.0 / paph[jl + klon*(klev + (klev + 1)*ibl)]; + for (jk = 0; jk <= klev - 1 + -1; jk += 1) { + zsig = pap[jl + klon*(jk + klev*ibl)]*zpaphd; + if (zsig > (double) 0.1 && zsig < (double) 0.4 && ztp1[jl + klon*(jk + klev*ibl)] > + ztp1[jl + klon*(1 + jk + klev*ibl)]) { + ztrpaus = zsig; + } + } + + //----------------------------- + // Reset single level variables + //----------------------------- + + zanewm1 = (double) 0.0; + zda = (double) 0.0; + zcovpclr = (double) 0.0; + zcovpmax = (double) 0.0; + zcovptot = (double) 0.0; + zcldtopdist = (double) 0.0; + + //###################################################################### + // 3. *** PHYSICS *** + //###################################################################### + + + //---------------------------------------------------------------------- + // START OF VERTICAL LOOP + //---------------------------------------------------------------------- + + for (jk = -1 + (*yrecldp).ncldtop; jk <= klev + -1; jk += 1) { + + //---------------------------------------------------------------------- + // 3.0 INITIALIZE VARIABLES + //---------------------------------------------------------------------- + + //--------------------------------- + // First guess microphysics + //--------------------------------- + for (jm = 0; jm <= 5 + -1; jm += 1) { + zqxfg[jm] = zqx[jl + klon*(jk + klev*(jm + 5*ibl))]; + } + + //--------------------------------- + // Set KLON arrays to zero + //--------------------------------- + + zlicld = (double) 0.0; + zrainaut = (double) 0.0; // currently needed for diags + zrainacc = (double) 0.0; // currently needed for diags + zsnowaut = (double) 0.0; // needed + zldefr = (double) 0.0; + zacust = (double) 0.0; // set later when needed + zqpretot = (double) 0.0; + zlfinalsum = (double) 0.0; + + // Required for first guess call + zlcond1 = (double) 0.0; + zlcond2 = (double) 0.0; + zsupsat = (double) 0.0; + zlevapl = (double) 0.0; + zlevapi = (double) 0.0; + + //------------------------------------- + // solvers for cloud fraction + //------------------------------------- + zsolab = (double) 0.0; + zsolac = (double) 0.0; + + zicetot = (double) 0.0; + + //------------------------------------------ + // reset matrix so missing pathways are set + //------------------------------------------ + for (jm = 0; jm <= 5 + -1; jm += 1) { + for (jn = 0; jn <= 5 + -1; jn += 1) { + zsolqb[jn + 5*jm] = (double) 0.0; + zsolqa[jn + 5*jm] = (double) 0.0; + } + } + + //---------------------------------- + // reset new microphysics variables + //---------------------------------- + for (jm = 0; jm <= 5 + -1; jm += 1) { + zfallsrce[jm] = (double) 0.0; + zfallsink[jm] = (double) 0.0; + zconvsrce[jm] = (double) 0.0; + zconvsink[jm] = (double) 0.0; + zpsupsatsrce[jm] = (double) 0.0; + zratio[jm] = (double) 0.0; + } + + + //------------------------- + // derived variables needed + //------------------------- + + zdp = paph[jl + klon*(1 + jk + (klev + 1)*ibl)] - + paph[jl + klon*(jk + (klev + 1)*ibl)]; // dp + zgdp = rg / zdp; // g/dp + zrho = pap[jl + klon*(jk + klev*ibl)] / (rd*ztp1[jl + klon*(jk + klev*ibl)]); // p/RT air density + + zdtgdp = ptsphy*zgdp; // dt g/dp + zrdtgdp = zdp*((double) 1.0 / (ptsphy*rg)); // 1/(dt g/dp) + + if (jk + 1 > 1) { + zdtgdpf = ptsphy*rg / (pap[jl + klon*(jk + klev*ibl)] - + pap[jl + klon*(-1 + jk + klev*ibl)]); + } + + //------------------------------------ + // Calculate dqs/dT correction factor + //------------------------------------ + // Reminder: RETV=RV/RD-1 + + // liquid + zfacw = r5les / (pow((ztp1[jl + klon*(jk + klev*ibl)] - r4les), 2)); + zcor = (double) 1.0 / ((double) 1.0 - retv*zfoeeliqt[jl + klon*(jk + klev*ibl)]); + zdqsliqdt = zfacw*zcor*zqsliq[jl + klon*(jk + klev*ibl)]; + zcorqsliq = (double) 1.0 + ralvdcp*zdqsliqdt; + + // ice + zfaci = r5ies / (pow((ztp1[jl + klon*(jk + klev*ibl)] - r4ies), 2)); + zcor = (double) 1.0 / ((double) 1.0 - retv*zfoeew[jl + klon*(jk + klev*ibl)]); + zdqsicedt = zfaci*zcor*zqsice[jl + klon*(jk + klev*ibl)]; + zcorqsice = (double) 1.0 + ralsdcp*zdqsicedt; + + // diagnostic mixed + zalfaw = zfoealfa[jl + klon*(jk + (klev + 1)*ibl)]; + zalfawm = zalfaw; + zfac = zalfaw*zfacw + ((double) 1.0 - zalfaw)*zfaci; + zcor = (double) 1.0 / ((double) 1.0 - retv*zfoeewmt[jl + klon*(jk + klev*ibl)]); + zdqsmixdt = zfac*zcor*zqsmix[jl + klon*(jk + klev*ibl)]; + zcorqsmix = (double) 1.0 + ((double)((double)(fmin(1.0, pow((fmax(rtice, fmin(rtwat, ztp1[jl + klon*(jk + klev*ibl)])) - rtice)* + rtwat_rtice_r, 2)))*ralvdcp + (1.0 - (double)(fmin(1.0, pow((fmax(rtice, fmin(rtwat, ztp1[jl + klon*(jk + klev*ibl)])) - rtice)* + rtwat_rtice_r, 2))))*ralsdcp))*zdqsmixdt; + + // evaporation/sublimation limits + zevaplimmix = fmax((zqsmix[jl + klon*(jk + klev*ibl)] - + zqx[jl + klon*(jk + klev*(4 + 5*ibl))]) / zcorqsmix, (double) 0.0); + zevaplimliq = fmax((zqsliq[jl + klon*(jk + klev*ibl)] - + zqx[jl + klon*(jk + klev*(4 + 5*ibl))]) / zcorqsliq, (double) 0.0); + zevaplimice = fmax((zqsice[jl + klon*(jk + klev*ibl)] - + zqx[jl + klon*(jk + klev*(4 + 5*ibl))]) / zcorqsice, (double) 0.0); + + //-------------------------------- + // in-cloud consensate amount + //-------------------------------- + ztmpa = (double) 1.0 / fmax(za[jl + klon*(jk + klev*ibl)], zepsec); + zliqcld = zqx[jl + klon*(jk + klev*(0 + 5*ibl))]*ztmpa; + zicecld = zqx[jl + klon*(jk + klev*(1 + 5*ibl))]*ztmpa; + zlicld = zliqcld + zicecld; + + + //------------------------------------------------ + // Evaporate very small amounts of liquid and ice + //------------------------------------------------ + + if (zqx[jl + klon*(jk + klev*(0 + 5*ibl))] < (*yrecldp).rlmin) { + zsolqa[4 + 5*(0)] = zqx[jl + klon*(jk + klev*(0 + 5*ibl))]; + zsolqa[0 + 5*(4)] = -zqx[jl + klon*(jk + klev*(0 + 5*ibl))]; + } + + if (zqx[jl + klon*(jk + klev*(1 + 5*ibl))] < (*yrecldp).rlmin) { + zsolqa[4 + 5*(1)] = zqx[jl + klon*(jk + klev*(1 + 5*ibl))]; + zsolqa[1 + 5*(4)] = -zqx[jl + klon*(jk + klev*(1 + 5*ibl))]; + } + + + //--------------------------------------------------------------------- + // 3.1 ICE SUPERSATURATION ADJUSTMENT + //--------------------------------------------------------------------- + // Note that the supersaturation adjustment is made with respect to + // liquid saturation: when T>0C + // ice saturation: when T<0C + // with an adjustment made to allow for ice + // supersaturation in the clear sky + // Note also that the KOOP factor automatically clips the supersaturation + // to a maximum set by the liquid water saturation mixing ratio + // important for temperatures near to but below 0C + //----------------------------------------------------------------------- + + //----------------------------------- + // 3.1.1 Supersaturation limit (from Koop) + //----------------------------------- + // Needs to be set for all temperatures + zfokoop = ((double)(fmin(rkoop1 - rkoop2*ztp1[jl + klon*(jk + klev*ibl)], (double)(r2es*exp((r3les*(ztp1[jl + klon*(jk + klev*ibl)] - rtt))/ + (ztp1[jl + klon*(jk + klev*ibl)] - r4les)))*1.0/(double)(r2es*exp((r3ies*(ztp1[jl + klon*(jk + klev*ibl)] - rtt))/ + (ztp1[jl + klon*(jk + klev*ibl)] - r4ies)))))); + + if (ztp1[jl + klon*(jk + klev*ibl)] >= rtt || (*yrecldp).nssopt == 0) { + zfac = (double) 1.0; + zfaci = (double) 1.0; + } else { + zfac = za[jl + klon*(jk + klev*ibl)] + zfokoop*((double) 1.0 - za[jl + klon*(jk +klev*ibl)]); + zfaci = ptsphy / (*yrecldp).rkooptau; + } + + //------------------------------------------------------------------- + // 3.1.2 Calculate supersaturation wrt Koop including dqs/dT + // correction factor + // [#Note: QSICE or QSLIQ] + //------------------------------------------------------------------- + + // Calculate supersaturation to add to cloud + if (za[jl + klon*(jk + klev*ibl)] > (double) 1.0 - (*yrecldp).ramin) { + zsupsat = fmax((zqx[jl + klon*(jk + klev*(4 + 5*ibl))] - zfac*zqsice[jl + klon*(jk + klev*ibl)]) / + zcorqsice, (double) 0.0); + } else { + // Calculate environmental humidity supersaturation + zqp1env = (zqx[jl + klon*(jk + klev*(4 + 5*ibl))] - + za[jl + klon*(jk + klev*ibl)]*zqsice[jl + klon*(jk + klev*ibl)]) / + fmax((double) 1.0 - za[jl + klon*(jk + klev*ibl)], zepsilon); + //& SIGN(MAX(ABS(1.0_JPRB-ZA(JL,JK)),ZEPSILON),1.0_JPRB-ZA(JL,JK)) + zsupsat = fmax(((double) 1.0 - za[jl + klon*(jk + klev*ibl)])*(zqp1env - zfac*zqsice[jl + klon*(jk + klev*ibl)]) / + zcorqsice, (double) 0.0); + } + + //------------------------------------------------------------------- + // Here the supersaturation is turned into liquid water + // However, if the temperature is below the threshold for homogeneous + // freezing then the supersaturation is turned instantly to ice. + //-------------------------------------------------------------------- + + if (zsupsat > zepsec) { + + if (ztp1[jl + klon*(jk + klev*ibl)] > (*yrecldp).rthomo) { + // Turn supersaturation into liquid water + zsolqa[0 + 5*(4)] = zsolqa[0 + 5*(4)] + zsupsat; + zsolqa[4 + 5*(0)] = zsolqa[4 + 5*(0)] - zsupsat; + // Include liquid in first guess + zqxfg[0] = zqxfg[0] + zsupsat; + } else { + // Turn supersaturation into ice water + zsolqa[1 + 5*(4)] = zsolqa[1 + 5*(4)] + zsupsat; + zsolqa[4 + 5*(1)] = zsolqa[4 + 5*(1)] - zsupsat; + // Add ice to first guess for deposition term + zqxfg[1] = zqxfg[1] + zsupsat; + } + + // Increase cloud amount using RKOOPTAU timescale + zsolac = ((double) 1.0 - za[jl + klon*(jk + klev*ibl)])*zfaci; + + } + + //------------------------------------------------------- + // 3.1.3 Include supersaturation from previous timestep + // (Calculated in sltENDIF semi-lagrangian LDSLPHY=T) + //------------------------------------------------------- + if (psupsat[jl + klon*(jk + klev*ibl)] > zepsec) { + if (ztp1[jl + klon*(jk + klev*ibl)] > (*yrecldp).rthomo) { + // Turn supersaturation into liquid water + zsolqa[0 + 5*(0)] = zsolqa[0 + 5*(0)] + psupsat[jl + klon*(jk + klev*ibl)]; + zpsupsatsrce[0] = psupsat[jl + klon*(jk + klev*ibl)]; + // Add liquid to first guess for deposition term + zqxfg[0] = zqxfg[0] + psupsat[jl + klon*(jk + klev*ibl)]; + // Store cloud budget diagnostics if required + } else { + // Turn supersaturation into ice water + zsolqa[1 + 5*(1)] = zsolqa[1 + 5*(1)] + psupsat[jl + klon*(jk + klev*ibl)]; + zpsupsatsrce[1] = psupsat[jl + klon*(jk + klev*ibl)]; + // Add ice to first guess for deposition term + zqxfg[1] = zqxfg[1] + psupsat[jl + klon*(jk + klev*ibl)]; + // Store cloud budget diagnostics if required + } + + // Increase cloud amount using RKOOPTAU timescale + zsolac = ((double) 1.0 - za[jl + klon*(jk + klev*ibl)])*zfaci; + // Store cloud budget diagnostics if required + } + + // on JL + + //--------------------------------------------------------------------- + // 3.2 DETRAINMENT FROM CONVECTION + //--------------------------------------------------------------------- + // * Diagnostic T-ice/liq split retained for convection + // Note: This link is now flexible and a future convection + // scheme can detrain explicit seperate budgets of: + // cloud water, ice, rain and snow + // * There is no (1-ZA) multiplier term on the cloud detrainment + // term, since is now written in mass-flux terms + // [#Note: Should use ZFOEALFACU used in convection rather than ZFOEALFA] + //--------------------------------------------------------------------- + if (jk + 1 < klev && jk + 1 >= (*yrecldp).ncldtop) { + + + plude[jl + klon*(jk + klev*ibl)] = plude[jl + klon*(jk + klev*ibl)]*zdtgdp; + + if (/*ldcum[jl + klon*ibl] &&*/ plude[jl + klon*(jk + klev*ibl)] > (*yrecldp).rlmin + && plu[jl + klon*(1 + jk + klev*ibl)] > zepsec) { + + zsolac = zsolac + plude[jl + klon*(jk + klev*ibl)] / + plu[jl + klon*(1 + jk + klev*ibl)]; + // *diagnostic temperature split* + zalfaw = zfoealfa[jl + klon*(jk + (klev + 1)*ibl)]; + zconvsrce[0] = zalfaw*plude[jl + klon*(jk + klev*ibl)]; + zconvsrce[1] = ((double) 1.0 - zalfaw)*plude[jl + klon*(jk + klev*ibl)]; + zsolqa[0 + 5*(0)] = zsolqa[0 + 5*(0)] + zconvsrce[0]; + zsolqa[1 + 5*(1)] = zsolqa[1 + 5*(1)] + zconvsrce[1]; + + } else { + + plude[jl + klon*(jk + klev*ibl)] = (double) 0.0; + + } + // *convective snow detrainment source + //if (ldcum[jl + klon*ibl]) { + zsolqa[3 + 5*(3)] = zsolqa[3 + 5*(3)] + psnde[jl + klon*(jk + klev*ibl)]*zdtgdp; + //} + + + } + // JK (*yrecldp).ncldtop) { + + zmf = fmax((double) 0.0, (pmfu[jl + klon*(jk + klev*ibl)] + pmfd[jl + klon*(jk + klev*ibl)])*zdtgdp); + zacust = zmf*zanewm1; + + for (jm = 0; jm <= 5 + -1; jm += 1) { + if (!llfall[jm] && iphase[jm] > 0) { + zlcust[jm] = zmf*zqxnm1[jm]; + // record total flux for enthalpy budget: + zconvsrce[jm] = zconvsrce[jm] + zlcust[jm]; + } + } + + // Now have to work out how much liquid evaporates at arrival point + // since there is no prognostic memory for in-cloud humidity, i.e. + // we always assume cloud is saturated. + + zdtdp = zrdcp*(double) 0.5*(ztp1[jl + klon*(-1 + jk + klev*ibl)] + + ztp1[jl + klon*(jk + klev*ibl)]) / paph[jl + klon*(jk + (klev + 1)*ibl)]; + zdtforc = zdtdp*(pap[jl + klon*(jk + klev*ibl)] - pap[jl + klon*(-1 + jk + klev*ibl)]); + //[#Note: Diagnostic mixed phase should be replaced below] + zdqs = zanewm1*zdtforc*zdqsmixdt; + + for (jm = 0; jm <= 5 + -1; jm += 1) { + if (!llfall[jm] && iphase[jm] > 0) { + zlfinal = fmax((double) 0.0, zlcust[jm] - zdqs); //lim to zero + // no supersaturation allowed incloud ---V + zevap = fmin((zlcust[jm] - zlfinal), zevaplimmix); + // ZEVAP=0.0_JPRB + zlfinal = zlcust[jm] - zevap; + zlfinalsum = zlfinalsum + zlfinal; // sum + + zsolqa[jm + 5*jm] = zsolqa[jm + 5*jm] + zlcust[jm]; // whole sum + zsolqa[4 + 5*jm] = zsolqa[4 + 5*jm] + zevap; + zsolqa[jm + 5*(4)] = zsolqa[jm + 5*(4)] - zevap; + } + } + + // Reset the cloud contribution if no cloud water survives to this level: + if (zlfinalsum < zepsec) { + zacust = (double) 0.0; + } + zsolac = zsolac + zacust; + + } + // on JK>NCLDTOP + + //--------------------------------------------------------------------- + // Subsidence sink of cloud to the layer below + // (Implicit - re. CFL limit on convective mass flux) + //--------------------------------------------------------------------- + + + if (jk + 1 < klev) { + + zmfdn = fmax((double) 0.0, (pmfu[jl + klon*(1 + jk + klev*ibl)] + + pmfd[jl + klon*(1 + jk + klev*ibl)])*zdtgdp); + + zsolab = zsolab + zmfdn; + zsolqb[0 + 5*(0)] = zsolqb[0 + 5*(0)] + zmfdn; + zsolqb[1 + 5*(1)] = zsolqb[1 + 5*(1)] + zmfdn; + + // Record sink for cloud budget and enthalpy budget diagnostics + zconvsink[0] = zmfdn; + zconvsink[1] = zmfdn; + + } + + + //---------------------------------------------------------------------- + // 3.4 EROSION OF CLOUDS BY TURBULENT MIXING + //---------------------------------------------------------------------- + // NOTE: In default tiedtke scheme this process decreases the cloud + // area but leaves the specific cloud water content + // within clouds unchanged + //---------------------------------------------------------------------- + + // ------------------------------ + // Define turbulent erosion rate + // ------------------------------ + zldifdt = (*yrecldp).rcldiff*ptsphy; //original version + //Increase by factor of 5 for convective points + if (ktype[jl + klon*ibl] > 0 && plude[jl + klon*(jk + klev*ibl)] > zepsec) { + zldifdt = (*yrecldp).rcldiff_convi*zldifdt; + } + + // At the moment, works on mixed RH profile and partitioned ice/liq fraction + // so that it is similar to previous scheme + // Should apply RHw for liquid cloud and RHi for ice cloud separately + if (zli[jl + klon*(jk + klev*ibl)] > zepsec) { + // Calculate environmental humidity + // ZQE=(ZQX(JL,JK,NCLDQV)-ZA(JL,JK)*ZQSMIX(JL,JK))/& + // & MAX(ZEPSEC,1.0_JPRB-ZA(JL,JK)) + // ZE=ZLDIFDT(JL)*MAX(ZQSMIX(JL,JK)-ZQE,0.0_JPRB) + ze = zldifdt*fmax(zqsmix[jl + klon*(jk + klev*ibl)] - + zqx[jl + klon*(jk + klev*(4 + 5*ibl))], (double) 0.0); + zleros = za[jl + klon*(jk + klev*ibl)]*ze; + zleros = fmin(zleros, zevaplimmix); + zleros = fmin(zleros, zli[jl + klon*(jk + klev*ibl)]); + zaeros = zleros / zlicld; //if linear term + + // Erosion is -ve LINEAR in L,A + zsolac = zsolac - zaeros; //linear + + zsolqa[4 + 5*(0)] = zsolqa[4 + 5*(0)] + zliqfrac[jl + klon*(jk + klev*ibl)]*zleros; + zsolqa[0 + 5*(4)] = zsolqa[0 + 5*(4)] - zliqfrac[jl + klon*(jk + klev*ibl)]*zleros; + zsolqa[4 + 5*(1)] = zsolqa[4 + 5*(1)] + zicefrac[jl + klon*(jk + klev*ibl)]*zleros; + zsolqa[1 + 5*(4)] = zsolqa[1 + 5*(4)] - zicefrac[jl + klon*(jk + klev*ibl)]*zleros; + + } + + //---------------------------------------------------------------------- + // 3.4 CONDENSATION/EVAPORATION DUE TO DQSAT/DT + //---------------------------------------------------------------------- + // calculate dqs/dt + // Note: For the separate prognostic Qi and Ql, one would ideally use + // Qsat/DT wrt liquid/Koop here, since the physics is that new clouds + // forms by liquid droplets [liq] or when aqueous aerosols [Koop] form. + // These would then instantaneous freeze if T<-38C or lead to ice growth + // by deposition in warmer mixed phase clouds. However, since we do + // not have a separate prognostic equation for in-cloud humidity or a + // statistical scheme approach in place, the depositional growth of ice + // in the mixed phase can not be modelled and we resort to supersaturation + // wrt ice instanteously converting to ice over one timestep + // (see Tompkins et al. QJRMS 2007 for details) + // Thus for the initial implementation the diagnostic mixed phase is + // retained for the moment, and the level of approximation noted. + //---------------------------------------------------------------------- + + zdtdp = zrdcp*ztp1[jl + klon*(jk + klev*ibl)] / pap[jl + klon*(jk + klev*ibl)]; + zdpmxdt = zdp*zqtmst; + zmfdn = (double) 0.0; + if (jk + 1 < klev) { + zmfdn = pmfu[jl + klon*(1 + jk + klev*ibl)] + pmfd[jl + klon*(1 + jk + klev*ibl)]; + } + zwtot = pvervel[jl + klon*(jk + klev*ibl)] + + (double) 0.5*rg*(pmfu[jl + klon*(jk + klev*ibl)] + pmfd[jl + klon*(jk + klev*ibl)] + zmfdn); + zwtot = fmin(zdpmxdt, fmax(-zdpmxdt, zwtot)); + zzzdt = phrsw[jl + klon*(jk + klev*ibl)] + phrlw[jl + klon*(jk + klev*ibl)]; + zdtdiab = fmin(zdpmxdt*zdtdp, fmax(-zdpmxdt*zdtdp, zzzdt))*ptsphy + ralfdcp*zldefr; + // Note: ZLDEFR should be set to the difference between the mixed phase functions + // in the convection and cloud scheme, but this is not calculated, so is zero and + // the functions must be the same + zdtforc = zdtdp*zwtot*ptsphy + zdtdiab; + zqold = zqsmix[jl + klon*(jk + klev*ibl)]; + ztold = ztp1[jl + klon*(jk + klev*ibl)]; + ztp1[jl + klon*(jk + klev*ibl)] = ztp1[jl + klon*(jk + klev*ibl)] + zdtforc; + ztp1[jl + klon*(jk + klev*ibl)] = fmax(ztp1[jl + klon*(jk + klev*ibl)], (double) 160.0); + llflag = true; + + // Formerly a call to CUADJTQ(..., ICALL=5) + zqp = (double) 1.0 / pap[jl + klon*(jk + klev*ibl)]; + zqsat = ((double)(r2es*((double)(fmin(1.0, pow((fmax(rtice, fmin(rtwat, ztp1[jl + klon*(jk + klev*ibl)])) - rtice)*rtwat_rtice_r, 2)))* + exp((r3les*(ztp1[jl + klon*(jk + klev*ibl)] - rtt))/(ztp1[jl + klon*(jk + klev*ibl)] - r4les)) + + (1.0 - (double)(fmin(1.0, pow((fmax(rtice, fmin(rtwat, ztp1[jl + klon*(jk + klev*ibl)])) - rtice)*rtwat_rtice_r, 2))))* + exp((r3ies*(ztp1[jl + klon*(jk + klev*ibl)] - rtt))/(ztp1[jl + klon*(jk + klev*ibl)] - r4ies)))))*zqp; + zqsat = fmin((double) 0.5, zqsat); + zcor = (double) 1.0 / ((double) 1.0 - retv*zqsat); + zqsat = zqsat*zcor; + zcond = (zqsmix[jl + klon*(jk + klev*ibl)] - zqsat) / + ((double) 1.0 + zqsat*zcor*((double)(((double)(fmin(1.0, pow((fmax(rtice, fmin(rtwat, ztp1[jl + klon*(jk + klev*ibl)])) - + rtice)*rtwat_rtice_r, 2)))*r5alvcp)*(1.0/pow(ztp1[jl + klon*(jk + klev*ibl)] - r4les, 2)) + + ((1.0 - (double)(fmin(1.0, pow((fmax(rtice, fmin(rtwat, ztp1[jl + klon*(jk + klev*ibl)])) - rtice)*rtwat_rtice_r, 2))))*r5alscp)* + (1.0/pow(ztp1[jl + klon*(jk + klev*ibl)] - r4ies, 2))))); + ztp1[jl + klon*(jk + klev*ibl)] = ztp1[jl + klon*(jk + klev*ibl)] + + ((double)((double)(fmin(1.0, pow((fmax(rtice, fmin(rtwat, ztp1[jl + klon*(jk + klev*ibl)])) - rtice)*rtwat_rtice_r, 2)))*ralvdcp + + (1.0 - (double)(fmin(1.0, pow((fmax(rtice, fmin(rtwat, ztp1[jl + klon*(jk + klev*ibl)])) - rtice)*rtwat_rtice_r, 2))))*ralsdcp))*zcond; + zqsmix[jl + klon*(jk + klev*ibl)] = zqsmix[jl + klon*(jk + klev*ibl)] - zcond; + zqsat = ((double)(r2es*((double)(fmin(1.0, pow((fmax(rtice, fmin(rtwat, ztp1[jl + klon*(jk + klev*ibl)])) - rtice)*rtwat_rtice_r, 2)))* + exp((r3les*(ztp1[jl + klon*(jk + klev*ibl)] - rtt))/(ztp1[jl + klon*(jk + klev*ibl)] - r4les)) + + (1.0 - (double)(fmin(1.0, pow((fmax(rtice, fmin(rtwat, ztp1[jl + klon*(jk + klev*ibl)])) - rtice)*rtwat_rtice_r, 2))))* + exp((r3ies*(ztp1[jl + klon*(jk + klev*ibl)] - rtt))/(ztp1[jl + klon*(jk + klev*ibl)] - r4ies)))))*zqp; + zqsat = fmin((double) 0.5, zqsat); + zcor = (double) 1.0 / ((double) 1.0 - retv*zqsat); + zqsat = zqsat*zcor; + zcond1 = (zqsmix[jl + klon*(jk + klev*ibl)] - zqsat) / + ((double) 1.0 + zqsat*zcor*((double)(((double)(fmin(1.0, pow((fmax(rtice, fmin(rtwat, ztp1[jl + klon*(jk + klev*ibl)])) - + rtice)*rtwat_rtice_r, 2)))*r5alvcp)*(1.0/pow(ztp1[jl + klon*(jk + klev*ibl)] - r4les, 2)) + + ((1.0 - (double)(fmin(1.0, pow((fmax(rtice, fmin(rtwat, ztp1[jl + klon*(jk + klev*ibl)])) - rtice)*rtwat_rtice_r, 2))))*r5alscp)* + (1.0/pow(ztp1[jl + klon*(jk + klev*ibl)] - r4ies, 2))))); + ztp1[jl + klon*(jk + klev*ibl)] = ztp1[jl + klon*(jk + klev*ibl)] + + ((double)((double)(fmin(1.0, pow((fmax(rtice, fmin(rtwat, ztp1[jl + klon*(jk + klev*ibl)])) - rtice)*rtwat_rtice_r, 2)))*ralvdcp + + (1.0 - (double)(fmin(1.0, pow((fmax(rtice, fmin(rtwat, ztp1[jl + klon*(jk + klev*ibl)])) - rtice)*rtwat_rtice_r, 2))))*ralsdcp))*zcond1; + zqsmix[jl + klon*(jk + klev*ibl)] = zqsmix[jl + klon*(jk + klev*ibl)] - zcond1; + + zdqs = zqsmix[jl + klon*(jk + klev*ibl)] - zqold; + zqsmix[jl + klon*(jk + klev*ibl)] = zqold; + ztp1[jl + klon*(jk + klev*ibl)] = ztold; + + //---------------------------------------------------------------------- + // 3.4a ZDQS(JL) > 0: EVAPORATION OF CLOUDS + // ---------------------------------------------------------------------- + // Erosion term is LINEAR in L + // Changed to be uniform distribution in cloud region + + + // Previous function based on DELTA DISTRIBUTION in cloud: + if (zdqs > (double) 0.0) { + // If subsidence evaporation term is turned off, then need to use updated + // liquid and cloud here? + // ZLEVAP = MAX(ZA(JL,JK)+ZACUST(JL),1.0_JPRB)*MIN(ZDQS(JL),ZLICLD(JL)+ZLFINALSUM(JL)) + zlevap = za[jl + klon*(jk + klev*ibl)]*fmin(zdqs, zlicld); + zlevap = fmin(zlevap, zevaplimmix); + zlevap = fmin(zlevap, fmax(zqsmix[jl + klon*(jk + klev*ibl)] - + zqx[jl + klon*(jk + klev*(4 + 5*ibl))], (double) 0.0)); + + // For first guess call + zlevapl = zliqfrac[jl + klon*(jk + klev*ibl)]*zlevap; + zlevapi = zicefrac[jl + klon*(jk + klev*ibl)]*zlevap; + + zsolqa[4 + 5*(0)] = zsolqa[4 + 5*(0)] + zliqfrac[jl + klon*(jk + klev*ibl)]*zlevap; + zsolqa[0 + 5*(4)] = zsolqa[0 + 5*(4)] - zliqfrac[jl + klon*(jk + klev*ibl)]*zlevap; + + zsolqa[4 + 5*(1)] = zsolqa[4 + 5*(1)] + zicefrac[jl + klon*(jk + klev*ibl)]*zlevap; + zsolqa[1 + 5*(4)] = zsolqa[1 + 5*(4)] - zicefrac[jl + klon*(jk + klev*ibl)]*zlevap; + + } + + + //---------------------------------------------------------------------- + // 3.4b ZDQS(JL) < 0: FORMATION OF CLOUDS + //---------------------------------------------------------------------- + // (1) Increase of cloud water in existing clouds + if (za[jl + klon*(jk + klev*ibl)] > zepsec && zdqs <= -(*yrecldp).rlmin) { + + zlcond1 = fmax(-zdqs, (double) 0.0); //new limiter + + //old limiter (significantly improves upper tropospheric humidity rms) + if (za[jl + klon*(jk + klev*ibl)] > (double) 0.99) { + zcor = (double) 1.0 / ((double) 1.0 - retv*zqsmix[jl + klon*(jk + klev*ibl)]); + zcdmax = (zqx[jl + klon*(jk + klev*(4 + 5*ibl))] - zqsmix[jl + klon*(jk + klev*ibl)]) / + ((double) 1.0 + zcor*zqsmix[jl + klon*(jk + klev*ibl)]*((double)(((double) + (fmin(1.0, pow((fmax(rtice, fmin(rtwat, ztp1[jl + klon*(jk + klev*ibl)])) - rtice)*rtwat_rtice_r, 2)))*r5alvcp)* + (1.0/pow(ztp1[jl + klon*(jk + klev*ibl)] - r4les, 2)) + + ((1.0 - (double)(fmin(1.0, pow((fmax(rtice, fmin(rtwat, ztp1[jl + klon*(jk + klev*ibl)])) - rtice)*rtwat_rtice_r, 2)))) + *r5alscp)*(1.0/pow(ztp1[jl + klon*(jk + klev*ibl)] - r4ies, 2))))); + } else { + zcdmax = (zqx[jl + klon*(jk + klev*(4 + 5*ibl))] - za[jl + klon*(jk + klev*ibl)]*zqsmix[jl + klon*(jk + klev*ibl)]) / + za[jl + klon*(jk + klev*ibl)]; + } + zlcond1 = fmax(fmin(zlcond1, zcdmax), (double) 0.0); + // end old limiter + + zlcond1 = za[jl + klon*(jk + klev*ibl)]*zlcond1; + if (zlcond1 < (*yrecldp).rlmin) { + zlcond1 = (double) 0.0; + } + + //------------------------------------------------------------------------- + // All increase goes into liquid unless so cold cloud homogeneously freezes + // Include new liquid formation in first guess value, otherwise liquid + // remains at cold temperatures until next timestep. + //------------------------------------------------------------------------- + if (ztp1[jl + klon*(jk + klev*ibl)] > (*yrecldp).rthomo) { + zsolqa[0 + 5*(4)] = zsolqa[0 + 5*(4)] + zlcond1; + zsolqa[4 + 5*(0)] = zsolqa[4 + 5*(0)] - zlcond1; + zqxfg[0] = zqxfg[0] + zlcond1; + } else { + zsolqa[1 + 5*(4)] = zsolqa[1 + 5*(4)] + zlcond1; + zsolqa[4 + 5*(1)] = zsolqa[4 + 5*(1)] - zlcond1; + zqxfg[1] = zqxfg[1] + zlcond1; + } + } + + // (2) Generation of new clouds (da/dt>0) + + + if (zdqs <= -(*yrecldp).rlmin && za[jl + klon*(jk + klev*ibl)] < (double) 1.0 - zepsec) { + + //--------------------------- + // Critical relative humidity + //--------------------------- + zrhc = (*yrecldp).ramid; + zsigk = pap[jl + klon*(jk + klev*ibl)] / paph[jl + klon*(klev + (klev + 1)*ibl)]; + // Increase RHcrit to 1.0 towards the surface (eta>0.8) + if (zsigk > (double) 0.8) { + zrhc = (*yrecldp).ramid + ((double) 1.0 - (*yrecldp).ramid)*(pow(((zsigk - (double) 0.8) / + (double) 0.2), 2)); + } + + // Commented out for CY37R1 to reduce humidity in high trop and strat + // ! Increase RHcrit to 1.0 towards the tropopause (trop-0.2) and above + // ZBOTT=ZTRPAUS(JL)+0.2_JPRB + // IF(ZSIGK < ZBOTT) THEN + // ZRHC=RAMID+(1.0_JPRB-RAMID)*MIN(((ZBOTT-ZSIGK)/0.2_JPRB)**2,1.0_JPRB) + // ENDIF + + //--------------------------- + // Supersaturation options + //--------------------------- + if ((*yrecldp).nssopt == 0) { + // No scheme + zqe = (zqx[jl + klon*(jk + klev*(4 + 5*ibl))] - za[jl + klon*(jk + klev*ibl)]* + zqsice[jl + klon*(jk + klev*ibl)]) / fmax(zepsec, (double) 1.0 - za[jl + klon*(jk + klev*ibl)]); + zqe = fmax((double) 0.0, zqe); + } else if ((*yrecldp).nssopt == 1) { + // Tompkins + zqe = (zqx[jl + klon*(jk + klev*(4 + 5*ibl))] - za[jl + klon*(jk + klev*ibl)]* + zqsice[jl + klon*(jk + klev*ibl)]) / fmax(zepsec, (double) 1.0 - + za[jl + klon*(jk + klev*ibl)]); + zqe = fmax((double) 0.0, zqe); + } else if ((*yrecldp).nssopt == 2) { + // Lohmann and Karcher + zqe = zqx[jl + klon*(jk + klev*(4 + 5*ibl))]; + } else if ((*yrecldp).nssopt == 3) { + // Gierens + zqe = + zqx[jl + klon*(jk + klev*(4 + 5*ibl))] + zli[jl + klon*(jk + klev*ibl)]; + } + + if (ztp1[jl + klon*(jk + klev*ibl)] >= rtt || (*yrecldp).nssopt == 0) { + // No ice supersaturation allowed + zfac = (double) 1.0; + } else { + // Ice supersaturation + zfac = zfokoop; + } + + if (zqe >= zrhc*zqsice[jl + klon*(jk + klev*ibl)]*zfac && + zqe < zqsice[jl + klon*(jk + klev*ibl)]*zfac) { + // note: not **2 on 1-a term if ZQE is used. + // Added correction term ZFAC to numerator 15/03/2010 + zacond = -((double) 1.0 - za[jl + klon*(jk + klev*ibl)])*zfac*zdqs / + fmax((double) 2.0*(zfac*zqsice[jl + klon*(jk + klev*ibl)] - zqe), zepsec); + + zacond = fmin(zacond, (double) 1.0 - za[jl + klon*(jk + klev*ibl)]); //PUT THE LIMITER BACK + + // Linear term: + // Added correction term ZFAC 15/03/2010 + zlcond2 = -zfac*zdqs*(double) 0.5*zacond; //mine linear + + // new limiter formulation + zzdl = (double) 2.0*(zfac*zqsice[jl + klon*(jk + klev*ibl)] - zqe) / + fmax(zepsec, (double) 1.0 - za[jl + klon*(jk + klev*ibl)]); + // Added correction term ZFAC 15/03/2010 + if (zfac*zdqs < -zzdl) { + // ZLCONDLIM=(ZA(JL,JK)-1.0_JPRB)*ZDQS(JL)-ZQSICE(JL,JK)+ZQX(JL,JK,NCLDQV) + zlcondlim = (za[jl + klon*(jk + klev*ibl)] - (double) 1.0)*zfac*zdqs - zfac* + zqsice[jl + klon*(jk + klev*ibl)] + zqx[jl + klon*(jk + klev*(4 + 5*ibl))]; + zlcond2 = fmin(zlcond2, zlcondlim); + } + zlcond2 = fmax(zlcond2, (double) 0.0); + + if (zlcond2 < (*yrecldp).rlmin || ((double) 1.0 - + za[jl + klon*(jk + klev*ibl)]) < zepsec) { + zlcond2 = (double) 0.0; + zacond = (double) 0.0; + } + if (zlcond2 == (double) 0.0) { + zacond = (double) 0.0; + } + + // Large-scale generation is LINEAR in A and LINEAR in L + zsolac = zsolac + zacond; //linear + + //------------------------------------------------------------------------ + // All increase goes into liquid unless so cold cloud homogeneously freezes + // Include new liquid formation in first guess value, otherwise liquid + // remains at cold temperatures until next timestep. + //------------------------------------------------------------------------ + if (ztp1[jl + klon*(jk + klev*ibl)] > (*yrecldp).rthomo) { + zsolqa[0 + 5*(4)] = zsolqa[0 + 5*(4)] + zlcond2; + zsolqa[4 + 5*(0)] = zsolqa[4 + 5*(0)] - zlcond2; + zqxfg[0] = zqxfg[0] + zlcond2; + } else { + // homogeneous freezing + zsolqa[1 + 5*(4)] = zsolqa[1 + 5*(4)] + zlcond2; + zsolqa[4 + 5*(1)] = zsolqa[4 + 5*(1)] - zlcond2; + zqxfg[1] = zqxfg[1] + zlcond2; + } + + } + } + + //---------------------------------------------------------------------- + // 3.7 Growth of ice by vapour deposition + //---------------------------------------------------------------------- + // Following Rotstayn et al. 2001: + // does not use the ice nuclei number from cloudaer.F90 + // but rather a simple Meyers et al. 1992 form based on the + // supersaturation and assuming clouds are saturated with + // respect to liquid water (well mixed), (or Koop adjustment) + // Growth considered as sink of liquid water if present so + // Bergeron-Findeisen adjustment in autoconversion term no longer needed + //---------------------------------------------------------------------- + + //-------------------------------------------------------- + //- + //- Ice deposition following Rotstayn et al. (2001) + //- (monodisperse ice particle size distribution) + //- + //-------------------------------------------------------- + if (idepice == 1) { + + + //-------------------------------------------------------------- + // Calculate distance from cloud top + // defined by cloudy layer below a layer with cloud frac <0.01 + // ZDZ = ZDP(JL)/(ZRHO(JL)*RG) + //-------------------------------------------------------------- + + if (za[jl + klon*(-1 + jk + klev*ibl)] < (*yrecldp).rcldtopcf && + za[jl + klon*(jk + klev*ibl)] >= (*yrecldp).rcldtopcf) { + zcldtopdist = (double) 0.0; + } else { + zcldtopdist = zcldtopdist + zdp / (zrho*rg); + } + + //-------------------------------------------------------------- + // only treat depositional growth if liquid present. due to fact + // that can not model ice growth from vapour without additional + // in-cloud water vapour variable + //-------------------------------------------------------------- + if (ztp1[jl + klon*(jk + klev*ibl)] < rtt && zqxfg[0] > (*yrecldp).rlmin) { + // T<273K + + zvpice = ((double)(r2es*exp((r3ies*(ztp1[jl + klon*(jk + klev*ibl)] - rtt))/ + (ztp1[jl + klon*(jk + klev*ibl)] - r4ies))))*rv / rd; + zvpliq = zvpice*zfokoop; + zicenuclei = (double) 1000.0*exp((double) 12.96*(zvpliq - zvpice) / zvpliq - (double) 0.639); + + //------------------------------------------------ + // 2.4e-2 is conductivity of air + // 8.8 = 700**1/3 = density of ice to the third + //------------------------------------------------ + zadd = rlstt*(rlstt / (rv*ztp1[jl + klon*(jk + klev*ibl)]) - (double) 1.0) / + ((double) 2.4E-2*ztp1[jl + klon*(jk + klev*ibl)]); + zbdd = rv*ztp1[jl + klon*(jk + klev*ibl)]*pap[jl + klon*(jk + klev*ibl)] / + ((double) 2.21*zvpice); + zcvds = (double) 7.8*(pow((zicenuclei / zrho), (double) 0.666))*(zvpliq - + zvpice) / ((double) 8.87*(zadd + zbdd)*zvpice); + + //----------------------------------------------------- + // RICEINIT=1.E-12_JPRB is initial mass of ice particle + //----------------------------------------------------- + zice0 = fmax(zicecld, zicenuclei*(*yrecldp).riceinit / zrho); + + //------------------ + // new value of ice: + //------------------ + zinew = pow(((double) 0.666*zcvds*ptsphy + (pow(zice0, (double) 0.666))), (double) 1.5); + + //--------------------------- + // grid-mean deposition rate: + //--------------------------- + zdepos = fmax(za[jl + klon*(jk + klev*ibl)]*(zinew - zice0), (double) 0.0); + + //-------------------------------------------------------------------- + // Limit deposition to liquid water amount + // If liquid is all frozen, ice would use up reservoir of water + // vapour in excess of ice saturation mixing ratio - However this + // can not be represented without a in-cloud humidity variable. Using + // the grid-mean humidity would imply a large artificial horizontal + // flux from the clear sky to the cloudy area. We thus rely on the + // supersaturation check to clean up any remaining supersaturation + //-------------------------------------------------------------------- + zdepos = fmin(zdepos, zqxfg[0]); // limit to liquid water amount + + //-------------------------------------------------------------------- + // At top of cloud, reduce deposition rate near cloud top to account for + // small scale turbulent processes, limited ice nucleation and ice fallout + //-------------------------------------------------------------------- + // ZDEPOS = ZDEPOS*MIN(RDEPLIQREFRATE+ZCLDTOPDIST(JL)/RDEPLIQREFDEPTH,1.0_JPRB) + // Change to include dependence on ice nuclei concentration + // to increase deposition rate with decreasing temperatures + zinfactor = fmin(zicenuclei / (double) 15000., (double) 1.0); + zdepos = zdepos*fmin(zinfactor + ((double) 1.0 - zinfactor)*((*yrecldp).rdepliqrefrate + + zcldtopdist / (*yrecldp).rdepliqrefdepth), (double) 1.0); + + //-------------- + // add to matrix + //-------------- + zsolqa[1 + 5*(0)] = zsolqa[1 + 5*(0)] + zdepos; + zsolqa[0 + 5*(1)] = zsolqa[0 + 5*(1)] - zdepos; + zqxfg[1] = zqxfg[1] + zdepos; + zqxfg[0] = zqxfg[0] - zdepos; + + } + + //-------------------------------------------------------- + //- + //- Ice deposition assuming ice PSD + //- + //-------------------------------------------------------- + } else if (idepice == 2) { + + + //-------------------------------------------------------------- + // Calculate distance from cloud top + // defined by cloudy layer below a layer with cloud frac <0.01 + // ZDZ = ZDP(JL)/(ZRHO(JL)*RG) + //-------------------------------------------------------------- + + if (za[jl + klon*(-1 + jk + klev*ibl)] < (*yrecldp).rcldtopcf && + za[jl + klon*(jk + klev*ibl)] >= (*yrecldp).rcldtopcf) { + zcldtopdist = (double) 0.0; + } else { + zcldtopdist = zcldtopdist + zdp / (zrho*rg); + } + + //-------------------------------------------------------------- + // only treat depositional growth if liquid present. due to fact + // that can not model ice growth from vapour without additional + // in-cloud water vapour variable + //-------------------------------------------------------------- + if (ztp1[jl + klon*(jk + klev*ibl)] < rtt && zqxfg[0] > (*yrecldp).rlmin) { + // T<273K + + zvpice = ((double)(r2es*exp((r3ies*(ztp1[jl + klon*(jk + klev*ibl)] - rtt))/ + (ztp1[jl + klon*(jk + klev*ibl)] - r4ies))))*rv / rd; + zvpliq = zvpice*zfokoop; + zicenuclei = (double) 1000.0*exp((double) 12.96*(zvpliq - zvpice) / zvpliq - (double) 0.639); + + //----------------------------------------------------- + // RICEINIT=1.E-12_JPRB is initial mass of ice particle + //----------------------------------------------------- + zice0 = fmax(zicecld, zicenuclei*(*yrecldp).riceinit / zrho); + + // Particle size distribution + ztcg = (double) 1.0; + zfacx1i = (double) 1.0; + + zaplusb = (*yrecldp).rcl_apb1*zvpice - (*yrecldp).rcl_apb2*zvpice* + ztp1[jl + klon*(jk + klev*ibl)] + pap[jl + klon*(jk + klev*ibl)]* + (*yrecldp).rcl_apb3*(pow(ztp1[jl + klon*(jk + klev*ibl)], (double) 3.)); + zcorrfac = pow(((double) 1.0 / zrho), (double) 0.5); + zcorrfac2 = (pow((ztp1[jl + klon*(jk + klev*ibl)] / (double) 273.0), (double)1.5))* + ((double) 393.0 / (ztp1[jl + klon*(jk + klev*ibl)] + (double) 120.0)); + + zpr02 = zrho*zice0*(*yrecldp).rcl_const1i / (ztcg*zfacx1i); + + zterm1 = (zvpliq - zvpice)*(pow(ztp1[jl + klon*(jk + klev*ibl)], (double) 2.0))* + zvpice*zcorrfac2*ztcg*(*yrecldp).rcl_const2i*zfacx1i / (zrho*zaplusb*zvpice); + zterm2 = (double) 0.65*(*yrecldp).rcl_const6i*(pow(zpr02, (*yrecldp).rcl_const4i)) + + (*yrecldp).rcl_const3i*(pow(zcorrfac, (double) 0.5))*(pow(zrho, (double) 0.5))* + (pow(zpr02, (*yrecldp).rcl_const5i)) / (pow(zcorrfac2, (double) 0.5)); + + zdepos = fmax(za[jl + klon*(jk + klev*ibl)]*zterm1*zterm2*ptsphy, (double) 0.0); + + //-------------------------------------------------------------------- + // Limit deposition to liquid water amount + // If liquid is all frozen, ice would use up reservoir of water + // vapour in excess of ice saturation mixing ratio - However this + // can not be represented without a in-cloud humidity variable. Using + // the grid-mean humidity would imply a large artificial horizontal + // flux from the clear sky to the cloudy area. We thus rely on the + // supersaturation check to clean up any remaining supersaturation + //-------------------------------------------------------------------- + zdepos = fmin(zdepos, zqxfg[0]); // limit to liquid water amount + + //-------------------------------------------------------------------- + // At top of cloud, reduce deposition rate near cloud top to account for + // small scale turbulent processes, limited ice nucleation and ice fallout + //-------------------------------------------------------------------- + // Change to include dependence on ice nuclei concentration + // to increase deposition rate with decreasing temperatures + zinfactor = fmin(zicenuclei / (double) 15000., (double) 1.0); + zdepos = zdepos*fmin(zinfactor + ((double) 1.0 - zinfactor)* + ((*yrecldp).rdepliqrefrate + zcldtopdist / (*yrecldp).rdepliqrefdepth), (double) 1.0); + + //-------------- + // add to matrix + //-------------- + zsolqa[1 + 5*(0)] = zsolqa[1 + 5*(0)] + zdepos; + zsolqa[0 + 5*(1)] = zsolqa[0 + 5*(1)] - zdepos; + zqxfg[1] = zqxfg[1] + zdepos; + zqxfg[0] = zqxfg[0] - zdepos; + } + + } + // on IDEPICE + + //###################################################################### + // 4 *** PRECIPITATION PROCESSES *** + //###################################################################### + + //---------------------------------- + // revise in-cloud consensate amount + //---------------------------------- + ztmpa = (double) 1.0 / fmax(za[jl + klon*(jk + klev*ibl)], zepsec); + zliqcld = zqxfg[0]*ztmpa; + zicecld = zqxfg[1]*ztmpa; + zlicld = zliqcld + zicecld; + + //---------------------------------------------------------------------- + // 4.2 SEDIMENTATION/FALLING OF *ALL* MICROPHYSICAL SPECIES + // now that rain, snow, graupel species are prognostic + // the precipitation flux can be defined directly level by level + // There is no vertical memory required from the flux variable + //---------------------------------------------------------------------- + + for (jm = 0; jm <= 5 + -1; jm += 1) { + if (llfall[jm] || jm + 1 == 2) { + //------------------------ + // source from layer above + //------------------------ + if (jk + 1 > (*yrecldp).ncldtop) { + zfallsrce[jm] = zpfplsx[jl + klon*(jk + (klev + 1)*(jm + 5*ibl))]*zdtgdp; + zsolqa[jm + 5*jm] = zsolqa[jm + 5*jm] + zfallsrce[jm]; + zqxfg[jm] = zqxfg[jm] + zfallsrce[jm]; + // use first guess precip----------V + zqpretot = zqpretot + zqxfg[jm]; + } + //------------------------------------------------- + // sink to next layer, constant fall speed + //------------------------------------------------- + // if aerosol effect then override + // note that for T>233K this is the same as above. + if ((*yrecldp).laericesed && jm + 1 == 2) { + zre_ice = pre_ice[jl + klon*(jk + klev*ibl)]; + // The exponent value is from + // Morrison et al. JAS 2005 Appendix + zvqx[1] = (double) 0.002*(pow(zre_ice, (double) 1.0)); + } + zfall = zvqx[jm]*zrho; + //------------------------------------------------- + // modified by Heymsfield and Iaquinta JAS 2000 + //------------------------------------------------- + // ZFALL = ZFALL*((PAP(JL,JK)*RICEHI1)**(-0.178_JPRB)) & + // &*((ZTP1(JL,JK)*RICEHI2)**(-0.394_JPRB)) + + zfallsink[jm] = zdtgdp*zfall; + // Cloud budget diagnostic stored at end as implicit + // jl + } + // LLFALL + } + // jm + + //--------------------------------------------------------------- + // Precip cover overlap using MAX-RAN Overlap + // Since precipitation is now prognostic we must + // 1) apply an arbitrary minimum coverage (0.3) if precip>0 + // 2) abandon the 2-flux clr/cld treatment + // 3) Thus, since we have no memory of the clear sky precip + // fraction, we mimic the previous method by reducing + // ZCOVPTOT(JL), which has the memory, proportionally with + // the precip evaporation rate, taking cloud fraction + // into account + // #3 above leads to much smoother vertical profiles of + // precipitation fraction than the Klein-Jakob scheme which + // monotonically increases precip fraction and then resets + // it to zero in a step function once clear-sky precip reaches + // zero. + //--------------------------------------------------------------- + if (zqpretot > zepsec) { + zcovptot = (double) 1.0 - (((double) 1.0 - zcovptot)*((double) 1.0 - + fmax(za[jl + klon*(jk + klev*ibl)], za[jl + klon*(-1 + jk + klev*ibl)])) / + ((double) 1.0 - fmin(za[jl + klon*(-1 + jk + klev*ibl)], (double) 1.0 - (double) 1.E-06))); + zcovptot = fmax(zcovptot, (*yrecldp).rcovpmin); + zcovpclr = fmax((double) 0.0, zcovptot - za[jl + klon*(jk + klev*ibl)]); // clear sky proportion + zraincld = zqxfg[2] / zcovptot; + zsnowcld = zqxfg[3] / zcovptot; + zcovpmax = fmax(zcovptot, zcovpmax); + } else { + zraincld = (double) 0.0; + zsnowcld = (double) 0.0; + zcovptot = (double) 0.0; // no flux - reset cover + zcovpclr = (double) 0.0; // reset clear sky proportion + zcovpmax = (double) 0.0; // reset max cover for ZZRH calc + } + + //---------------------------------------------------------------------- + // 4.3a AUTOCONVERSION TO SNOW + //---------------------------------------------------------------------- + + if (ztp1[jl + klon*(jk + klev*ibl)] <= rtt) { + //----------------------------------------------------- + // Snow Autoconversion rate follow Lin et al. 1983 + //----------------------------------------------------- + if (zicecld > zepsec) { + + zzco = ptsphy*(*yrecldp).rsnowlin1*exp((*yrecldp).rsnowlin2* + (ztp1[jl + klon*(jk + klev*ibl)] - rtt)); + + if ((*yrecldp).laericeauto) { + zlcrit = picrit_aer[jl + klon*(jk + klev*ibl)]; + // 0.3 = N**0.333 with N=0.027 + zzco = zzco*(pow(((*yrecldp).rnice / pnice[jl + klon*(jk + klev*ibl)]), (double) 0.333)); + } else { + zlcrit = (*yrecldp).rlcritsnow; + } + + zsnowaut = zzco*((double) 1.0 - exp(-(pow((zicecld / zlcrit), 2)))); + zsolqb[3 + 5*(1)] = zsolqb[3 + 5*(1)] + zsnowaut; + + } + } + + //---------------------------------------------------------------------- + // 4.3b AUTOCONVERSION WARM CLOUDS + // Collection and accretion will require separate treatment + // but for now we keep this simple treatment + //---------------------------------------------------------------------- + + if (zliqcld > zepsec) { + + //-------------------------------------------------------- + //- + //- Warm-rain process follow Sundqvist (1989) + //- + //-------------------------------------------------------- + if (iwarmrain == 1) { + + zzco = (*yrecldp).rkconv*ptsphy; + + if ((*yrecldp).laerliqautolsp) { + zlcrit = plcrit_aer[jl + klon*(jk + klev*ibl)]; + // 0.3 = N**0.333 with N=125 cm-3 + zzco = zzco*(pow(((*yrecldp).rccn / pccn[jl + klon*(jk + klev*ibl)]), (double) 0.333)); + } else { + // Modify autoconversion threshold dependent on: + // land (polluted, high CCN, smaller droplets, higher threshold) + // sea (clean, low CCN, larger droplets, lower threshold) + if (plsm[jl + klon*ibl] > (double) 0.5) { + zlcrit = (*yrecldp).rclcrit_land; // land + } else { + zlcrit = (*yrecldp).rclcrit_sea; // ocean + } + } + + //------------------------------------------------------------------ + // Parameters for cloud collection by rain and snow. + // Note that with new prognostic variable it is now possible + // to REPLACE this with an explicit collection parametrization + //------------------------------------------------------------------ + zprecip = (zpfplsx[jl + klon*(jk + (klev + 1)*(3 + 5*ibl))] + + zpfplsx[jl + klon*(jk + (klev + 1)*(2 + 5*ibl))]) / fmax(zepsec, zcovptot); + zcfpr = (double) 1.0 + (*yrecldp).rprc1*sqrt(fmax(zprecip, (double) 0.0)); + // ZCFPR=1.0_JPRB + RPRC1*SQRT(MAX(ZPRECIP,0.0_JPRB))*& + // &ZCOVPTOT(JL)/(MAX(ZA(JL,JK),ZEPSEC)) + + if ((*yrecldp).laerliqcoll) { + // 5.0 = N**0.333 with N=125 cm-3 + zcfpr = zcfpr*(pow(((*yrecldp).rccn / pccn[jl + klon*(jk + klev*ibl)]), (double) 0.333)); + } + + zzco = zzco*zcfpr; + zlcrit = zlcrit / fmax(zcfpr, zepsec); + + if (zliqcld / zlcrit < (double) 20.0) { + // Security for exp for some compilers + zrainaut = zzco*((double) 1.0 - exp(-(pow((zliqcld / zlcrit), 2)))); + } else { + zrainaut = zzco; + } + + // rain freezes instantly + if (ztp1[jl + klon*(jk + klev*ibl)] <= rtt) { + zsolqb[3 + 5*(0)] = zsolqb[3 + 5*(0)] + zrainaut; + } else { + zsolqb[2 + 5*(0)] = zsolqb[2 + 5*(0)] + zrainaut; + } + + //-------------------------------------------------------- + //- + //- Warm-rain process follow Khairoutdinov and Kogan (2000) + //- + //-------------------------------------------------------- + } else if (iwarmrain == 2) { + + if (plsm[jl + klon*ibl] > (double) 0.5) { + // land + zconst = (*yrecldp).rcl_kk_cloud_num_land; + zlcrit = (*yrecldp).rclcrit_land; + } else { + // ocean + zconst = (*yrecldp).rcl_kk_cloud_num_sea; + zlcrit = (*yrecldp).rclcrit_sea; + } + + if (zliqcld > zlcrit) { + + zrainaut = (double) 1.5*za[jl + klon*(jk + klev*ibl)]*ptsphy* + (*yrecldp).rcl_kkaau*(pow(zliqcld, (*yrecldp).rcl_kkbauq))* + (pow(zconst, (*yrecldp).rcl_kkbaun)); + + zrainaut = fmin(zrainaut, zqxfg[0]); + if (zrainaut < zepsec) { + zrainaut = (double) 0.0; + } + + zrainacc = (double) 2.0*za[jl + klon*(jk + klev*ibl)]*ptsphy*(*yrecldp).rcl_kkaac* + (pow((zliqcld*zraincld), (*yrecldp).rcl_kkbac)); + + zrainacc = fmin(zrainacc, zqxfg[0]); + if (zrainacc < zepsec) { + zrainacc = (double) 0.0; + } + + } else { + zrainaut = (double) 0.0; + zrainacc = (double) 0.0; + } + + // If temperature < 0, then autoconversion produces snow rather than rain + // Explicit + if (ztp1[jl + klon*(jk + klev*ibl)] <= rtt) { + zsolqa[3 + 5*(0)] = zsolqa[3 + 5*(0)] + zrainaut; + zsolqa[3 + 5*(0)] = zsolqa[3 + 5*(0)] + zrainacc; + zsolqa[0 + 5*(3)] = zsolqa[0 + 5*(3)] - zrainaut; + zsolqa[0 + 5*(3)] = zsolqa[0 + 5*(3)] - zrainacc; + } else { + zsolqa[2 + 5*(0)] = zsolqa[2 + 5*(0)] + zrainaut; + zsolqa[2 + 5*(0)] = zsolqa[2 + 5*(0)] + zrainacc; + zsolqa[0 + 5*(2)] = zsolqa[0 + 5*(2)] - zrainaut; + zsolqa[0 + 5*(2)] = zsolqa[0 + 5*(2)] - zrainacc; + } + + } + // on IWARMRAIN + + } + // on ZLIQCLD > ZEPSEC + + + //---------------------------------------------------------------------- + // RIMING - COLLECTION OF CLOUD LIQUID DROPS BY SNOW AND ICE + // only active if T<0degC and supercooled liquid water is present + // AND if not Sundquist autoconversion (as this includes riming) + //---------------------------------------------------------------------- + if (iwarmrain > 1) { + + if (ztp1[jl + klon*(jk + klev*ibl)] <= rtt && zliqcld > zepsec) { + + // Fallspeed air density correction + zfallcorr = pow(((*yrecldp).rdensref / zrho), (double) 0.4); + + //------------------------------------------------------------------ + // Riming of snow by cloud water - implicit in lwc + //------------------------------------------------------------------ + if (zsnowcld > zepsec && zcovptot > (double) 0.01) { + + // Calculate riming term + // Factor of liq water taken out because implicit + zsnowrime = (double) 0.3*zcovptot*ptsphy*(*yrecldp).rcl_const7s* + zfallcorr*(pow((zrho*zsnowcld*(*yrecldp).rcl_const1s), (*yrecldp).rcl_const8s)); + + // Limit snow riming term + zsnowrime = fmin(zsnowrime, (double) 1.0); + + zsolqb[3 + 5*(0)] = zsolqb[3 + 5*(0)] + zsnowrime; + + } + + //------------------------------------------------------------------ + // Riming of ice by cloud water - implicit in lwc + // NOT YET ACTIVE + //------------------------------------------------------------------ + // IF (ZICECLD(JL)>ZEPSEC .AND. ZA(JL,JK)>0.01_JPRB) THEN + // + // ! Calculate riming term + // ! Factor of liq water taken out because implicit + // ZSNOWRIME(JL) = ZA(JL,JK)*PTSPHY*RCL_CONST7S*ZFALLCORR & + // & *(ZRHO(JL)*ZICECLD(JL)*RCL_CONST1S)**RCL_CONST8S + // + // ! Limit ice riming term + // ZSNOWRIME(JL)=MIN(ZSNOWRIME(JL),1.0_JPRB) + // + // ZSOLQB(JL,NCLDQI,NCLDQL) = ZSOLQB(JL,NCLDQI,NCLDQL) + ZSNOWRIME(JL) + // + // ENDIF + } + + } + // on IWARMRAIN > 1 + + + //---------------------------------------------------------------------- + // 4.4a MELTING OF SNOW and ICE + // with new implicit solver this also has to treat snow or ice + // precipitating from the level above... i.e. local ice AND flux. + // in situ ice and snow: could arise from LS advection or warming + // falling ice and snow: arrives by precipitation process + //---------------------------------------------------------------------- + + zicetot = zqxfg[1] + zqxfg[3]; + zmeltmax = (double) 0.0; + + // If there are frozen hydrometeors present and dry-bulb temperature > 0degC + if (zicetot > zepsec && ztp1[jl + klon*(jk + klev*ibl)] > rtt) { + + // Calculate subsaturation + zsubsat = fmax(zqsice[jl + klon*(jk + klev*ibl)] - + zqx[jl + klon*(jk + klev*(4 + 5*ibl))], (double) 0.0); + + // Calculate difference between dry-bulb (ZTP1) and the temperature + // at which the wet-bulb=0degC (RTT-ZSUBSAT*....) using an approx. + // Melting only occurs if the wet-bulb temperature >0 + // i.e. warming of ice particle due to melting > cooling + // due to evaporation. + ztdmtw0 = ztp1[jl + klon*(jk + klev*ibl)] - rtt - zsubsat*(ztw1 + ztw2*(pap[jl + klon*(jk + klev*ibl)] - ztw3) - + ztw4*(ztp1[jl + klon*(jk + klev*ibl)] - ztw5)); + // Not implicit yet... + // Ensure ZCONS1 is positive so that ZMELTMAX=0 if ZTDMTW0<0 + zcons1 = fabs(ptsphy*((double) 1.0 + (double) 0.5*ztdmtw0) / (*yrecldp).rtaumel); + zmeltmax = fmax(ztdmtw0*zcons1*zrldcp, (double) 0.0); + } + + // Loop over frozen hydrometeors (ice, snow) + for (jm = 0; jm <= 5 + -1; jm += 1) { + if (iphase[jm] == 2) { + jn = imelt[jm]; + if (zmeltmax > zepsec && zicetot > zepsec) { + // Apply melting in same proportion as frozen hydrometeor fractions + zalfa = zqxfg[jm] / zicetot; + zmelt = fmin(zqxfg[jm], zalfa*zmeltmax); + // needed in first guess + // This implies that zqpretot has to be recalculated below + // since is not conserved here if ice falls and liquid doesn't + zqxfg[jm] = zqxfg[jm] - zmelt; + zqxfg[-1 + jn] = zqxfg[-1 + jn] + zmelt; + zsolqa[-1 + jn + 5*jm] = zsolqa[-1 + jn + 5*jm] + zmelt; + zsolqa[jm + 5*(-1 + jn)] = zsolqa[jm + 5*(-1 + jn)] - zmelt; + } + } + } + + //---------------------------------------------------------------------- + // 4.4b FREEZING of RAIN + //---------------------------------------------------------------------- + + // If rain present + if (zqx[jl + klon*(jk + klev*(2 + 5*ibl))] > zepsec) { + + if (ztp1[jl + klon*(jk + klev*ibl)] <= rtt && ztp1[jl + klon*(-1 + jk + klev*ibl)] > rtt) { + // Base of melting layer/top of refreezing layer so + // store rain/snow fraction for precip type diagnosis + // If mostly rain, then supercooled rain slow to freeze + // otherwise faster to freeze (snow or ice pellets) + zqpretot = fmax(zqx[jl + klon*(jk + klev*(3 + 5*ibl))] + + zqx[jl + klon*(jk + klev*(2 + 5*ibl))], zepsec); + prainfrac_toprfz[jl + klon*ibl] = zqx[jl + klon*(jk + klev*(2 + 5*ibl))] / zqpretot; + if (prainfrac_toprfz[jl + klon*ibl] > 0.8) { + llrainliq = true; + } else { + llrainliq = false; + } + } + + // If temperature less than zero + if (ztp1[jl + klon*(jk + klev*ibl)] < rtt) { + + if (prainfrac_toprfz[jl + klon*ibl] > 0.8) { + + // Majority of raindrops completely melted + // Refreezing is by slow heterogeneous freezing + + // Slope of rain particle size distribution + zlambda = pow(((*yrecldp).rcl_fac1 / (zrho*zqx[jl + klon*(jk + klev*(2 +5*ibl))])), + (*yrecldp).rcl_fac2); + + // Calculate freezing rate based on Bigg(1953) and Wisner(1972) + ztemp = (*yrecldp).rcl_fzrab*(ztp1[jl + klon*(jk + klev*ibl)] - rtt); + zfrz = ptsphy*((*yrecldp).rcl_const5r / zrho)*(exp(ztemp) - + (double) 1.)*(pow(zlambda, (*yrecldp).rcl_const6r)); + zfrzmax = fmax(zfrz, (double) 0.0); + + } else { + + // Majority of raindrops only partially melted + // Refreeze with a shorter timescale (reverse of melting...for now) + + zcons1 = fabs(ptsphy*((double) 1.0 + (double) 0.5*(rtt - + ztp1[jl + klon*(jk + klev*ibl)])) / (*yrecldp).rtaumel); + zfrzmax = fmax((rtt - ztp1[jl + klon*(jk + klev*ibl)])*zcons1*zrldcp, (double) 0.0); + + } + + if (zfrzmax > zepsec) { + zfrz = fmin(zqx[jl + klon*(jk + klev*(2 + 5*ibl))], zfrzmax); + zsolqa[3 + 5*(2)] = zsolqa[3 + 5*(2)] + zfrz; + zsolqa[2 + 5*(3)] = zsolqa[2 + 5*(3)] - zfrz; + } + } + + } + + + //---------------------------------------------------------------------- + // 4.4c FREEZING of LIQUID + //---------------------------------------------------------------------- + // not implicit yet... + zfrzmax = fmax(((*yrecldp).rthomo - ztp1[jl + klon*(jk + klev*ibl)])*zrldcp, (double) 0.0); + + jm = 1; + jn = imelt[-1 + jm]; + if (zfrzmax > zepsec && zqxfg[-1 + jm] > zepsec) { + zfrz = fmin(zqxfg[-1 + jm], zfrzmax); + zsolqa[-1 + jn + 5*(-1 + jm)] = zsolqa[-1 + jn + 5*(-1 + jm)] + zfrz; + zsolqa[-1 + jm + 5*(-1 + jn)] = zsolqa[-1 + jm + 5*(-1 + jn)] - zfrz; + } + + //---------------------------------------------------------------------- + // 4.5 EVAPORATION OF RAIN/SNOW + //---------------------------------------------------------------------- + + //---------------------------------------- + // Rain evaporation scheme from Sundquist + //---------------------------------------- + if (ievaprain == 1) { + + // Rain + + + zzrh = (*yrecldp).rprecrhmax + ((double) 1.0 - (*yrecldp).rprecrhmax)*zcovpmax / + fmax(zepsec, (double) 1.0 - za[jl + klon*(jk + klev*ibl)]); + zzrh = fmin(fmax(zzrh, (*yrecldp).rprecrhmax), (double) 1.0); + + zqe = (zqx[jl + klon*(jk + klev*(4 + 5*ibl))] - za[jl + klon*(jk + klev*ibl)]* + zqsliq[jl + klon*(jk + klev*ibl)]) / fmax(zepsec, (double) 1.0 - za[jl + klon*(jk + klev*ibl)]); + //--------------------------------------------- + // humidity in moistest ZCOVPCLR part of domain + //--------------------------------------------- + zqe = fmax((double) 0.0, fmin(zqe, zqsliq[jl + klon*(jk + klev*ibl)])); + llo1 = zcovpclr > zepsec && zqxfg[2] > zepsec && zqe < zzrh*zqsliq[jl + klon*(jk + klev*ibl)]; + + if (llo1) { + // note: zpreclr is a rain flux + zpreclr = zqxfg[2]*zcovpclr / copysign(fmax(fabs(zcovptot*zdtgdp), zepsilon), zcovptot*zdtgdp); + + //-------------------------------------- + // actual microphysics formula in zbeta + //-------------------------------------- + + zbeta1 = sqrt(pap[jl + klon*(jk + klev*ibl)] / paph[jl + klon*(klev + (klev + 1)*ibl)]) / + (*yrecldp).rvrfactor*zpreclr / fmax(zcovpclr, zepsec); + + zbeta = rg*(*yrecldp).rpecons*(double) 0.5*(pow(zbeta1, (double) 0.5777)); + + zdenom = (double) 1.0 + zbeta*ptsphy*zcorqsliq; + zdpr = zcovpclr*zbeta*(zqsliq[jl + klon*(jk + klev*ibl)] - zqe) / zdenom*zdp*zrg_r; + zdpevap = zdpr*zdtgdp; + + //--------------------------------------------------------- + // add evaporation term to explicit sink. + // this has to be explicit since if treated in the implicit + // term evaporation can not reduce rain to zero and model + // produces small amounts of rainfall everywhere. + //--------------------------------------------------------- + + // Evaporate rain + zevap = fmin(zdpevap, zqxfg[2]); + + zsolqa[4 + 5*(2)] = zsolqa[4 + 5*(2)] + zevap; + zsolqa[2 + 5*(4)] = zsolqa[2 + 5*(4)] - zevap; + + //------------------------------------------------------------- + // Reduce the total precip coverage proportional to evaporation + // to mimic the previous scheme which had a diagnostic + // 2-flux treatment, abandoned due to the new prognostic precip + //------------------------------------------------------------- + zcovptot = fmax((*yrecldp).rcovpmin, zcovptot - fmax((double) 0.0, + (zcovptot - za[jl + klon*(jk + klev*ibl)])*zevap / zqxfg[2])); + + // Update fg field + zqxfg[2] = zqxfg[2] - zevap; + + } + + + //--------------------------------------------------------- + // Rain evaporation scheme based on Abel and Boutle (2013) + //--------------------------------------------------------- + } else if (ievaprain == 2) { + + + //----------------------------------------------------------------------- + // Calculate relative humidity limit for rain evaporation + // to avoid cloud formation and saturation of the grid box + //----------------------------------------------------------------------- + // Limit RH for rain evaporation dependent on precipitation fraction + zzrh = (*yrecldp).rprecrhmax + ((double) 1.0 - (*yrecldp).rprecrhmax)*zcovpmax / + fmax(zepsec, (double) 1.0 - za[jl + klon*(jk + klev*ibl)]); + zzrh = fmin(fmax(zzrh, (*yrecldp).rprecrhmax), (double) 1.0); + + // Critical relative humidity + //ZRHC=RAMID + //ZSIGK=PAP(JL,JK)/PAPH(JL,KLEV+1) + // Increase RHcrit to 1.0 towards the surface (eta>0.8) + //IF(ZSIGK > 0.8_JPRB) THEN + // ZRHC=RAMID+(1.0_JPRB-RAMID)*((ZSIGK-0.8_JPRB)/0.2_JPRB)**2 + //ENDIF + //ZZRH = MIN(ZRHC,ZZRH) + + // Further limit RH for rain evaporation to 80% (RHcrit in free troposphere) + zzrh = fmin((double) 0.8, zzrh); + + zqe = fmax((double) 0.0, fmin(zqx[jl + klon*(jk + klev*(4 + 5*ibl))], + zqsliq[jl + klon*(jk + klev*ibl)])); + + llo1 = zcovpclr > zepsec && zqxfg[2] > zepsec && + zqe < zzrh*zqsliq[jl + klon*(jk + klev*ibl)]; + + if (llo1) { + + //------------------------------------------- + // Abel and Boutle (2012) evaporation + //------------------------------------------- + // Calculate local precipitation (kg/kg) + zpreclr = zqxfg[2] / zcovptot; + + // Fallspeed air density correction + zfallcorr = pow(((*yrecldp).rdensref / zrho), 0.4); + + // Saturation vapour pressure with respect to liquid phase + zesatliq = rv / rd*((double)(r2es*exp((r3les*(ztp1[jl + klon*(jk + klev*ibl)] - rtt))/ + (ztp1[jl + klon*(jk + klev*ibl)] - r4les)))); + + // Slope of particle size distribution + zlambda = pow(((*yrecldp).rcl_fac1 / (zrho*zpreclr)), (*yrecldp).rcl_fac2); // ZPRECLR=kg/kg + + zevap_denom = (*yrecldp).rcl_cdenom1*zesatliq - (*yrecldp).rcl_cdenom2* + ztp1[jl + klon*(jk + klev*ibl)]*zesatliq + (*yrecldp).rcl_cdenom3* + (pow(ztp1[jl + klon*(jk + klev*ibl)], (double) 3.))*pap[jl + klon*(jk + klev*ibl)]; + + // Temperature dependent conductivity + zcorr2 = (pow((ztp1[jl + klon*(jk + klev*ibl)] / (double) 273.), (double) 1.5))*(double) 393. / + (ztp1[jl + klon*(jk + klev*ibl)] + (double) 120.); + zka = (*yrecldp).rcl_ka273*zcorr2; + + zsubsat = fmax(zzrh*zqsliq[jl + klon*(jk + klev*ibl)] - zqe, (double) 0.0); + + zbeta = ((double) 0.5 / zqsliq[jl + klon*(jk + klev*ibl)])* + (pow(ztp1[jl + klon*(jk + klev*ibl)], (double) 2.))*zesatliq*(*yrecldp).rcl_const1r*(zcorr2 / + zevap_denom)*((double) 0.78 / (pow(zlambda, (*yrecldp).rcl_const4r)) + + (*yrecldp).rcl_const2r*(pow((zrho*zfallcorr), (double) 0.5)) / ((pow(zcorr2, + (double) 0.5))*(pow(zlambda, (*yrecldp).rcl_const3r)))); + + zdenom = (double) 1.0 + zbeta*ptsphy; //*ZCORQSLIQ(JL) + zdpevap = zcovpclr*zbeta*ptsphy*zsubsat / zdenom; + + //--------------------------------------------------------- + // Add evaporation term to explicit sink. + // this has to be explicit since if treated in the implicit + // term evaporation can not reduce rain to zero and model + // produces small amounts of rainfall everywhere. + //--------------------------------------------------------- + + // Limit rain evaporation + zevap = fmin(zdpevap, zqxfg[2]); + + zsolqa[4 + 5*(2)] = zsolqa[4 + 5*(2)] + zevap; + zsolqa[2 + 5*(4)] = zsolqa[2 + 5*(4)] - zevap; + + //------------------------------------------------------------- + // Reduce the total precip coverage proportional to evaporation + // to mimic the previous scheme which had a diagnostic + // 2-flux treatment, abandoned due to the new prognostic precip + //------------------------------------------------------------- + zcovptot = fmax((*yrecldp).rcovpmin, zcovptot - fmax((double) 0.0, (zcovptot - + za[jl + klon*(jk + klev*ibl)])*zevap / zqxfg[2])); + + // Update fg field + zqxfg[2] = zqxfg[2] - zevap; + + } + + } + // on IEVAPRAIN + + //---------------------------------------------------------------------- + // 4.5 EVAPORATION OF SNOW + //---------------------------------------------------------------------- + // Snow + if (ievapsnow == 1) { + + zzrh = (*yrecldp).rprecrhmax + ((double) 1.0 - (*yrecldp).rprecrhmax)*zcovpmax / + fmax(zepsec, (double) 1.0 - za[jl + klon*(jk + klev*ibl)]); + zzrh = fmin(fmax(zzrh, (*yrecldp).rprecrhmax), (double) 1.0); + zqe = (zqx[jl + klon*(jk + klev*(4 + 5*ibl))] - za[jl + klon*(jk + klev*ibl)]* + zqsice[jl + klon*(jk + klev*ibl)]) / fmax(zepsec, (double) 1.0 - za[jl + klon*(jk + klev*ibl)]); + + //--------------------------------------------- + // humidity in moistest ZCOVPCLR part of domain + //--------------------------------------------- + zqe = fmax((double) 0.0, fmin(zqe, zqsice[jl + klon*(jk + klev*ibl)])); + llo1 = zcovpclr > zepsec && zqxfg[3] > zepsec && + zqe < zzrh*zqsice[jl + klon*(jk + klev*ibl)]; + + if (llo1) { + // note: zpreclr is a rain flux a + zpreclr = zqxfg[3]*zcovpclr / copysign(fmax(fabs(zcovptot*zdtgdp), zepsilon), zcovptot*zdtgdp); + + //-------------------------------------- + // actual microphysics formula in zbeta + //-------------------------------------- + + zbeta1 = sqrt(pap[jl + klon*(jk + klev*ibl)] / paph[jl + klon*(klev + (klev + 1)*ibl)]) / + (*yrecldp).rvrfactor*zpreclr / fmax(zcovpclr, zepsec); + + zbeta = rg*(*yrecldp).rpecons*(pow(zbeta1, (double) 0.5777)); + + zdenom = (double) 1.0 + zbeta*ptsphy*zcorqsice; + zdpr = zcovpclr*zbeta*(zqsice[jl + klon*(jk + klev*ibl)] - zqe) / zdenom*zdp*zrg_r; + zdpevap = zdpr*zdtgdp; + + //--------------------------------------------------------- + // add evaporation term to explicit sink. + // this has to be explicit since if treated in the implicit + // term evaporation can not reduce snow to zero and model + // produces small amounts of snowfall everywhere. + //--------------------------------------------------------- + + // Evaporate snow + zevap = fmin(zdpevap, zqxfg[3]); + + zsolqa[4 + 5*(3)] = zsolqa[4 + 5*(3)] + zevap; + zsolqa[3 + 5*(4)] = zsolqa[3 + 5*(4)] - zevap; + + //------------------------------------------------------------- + // Reduce the total precip coverage proportional to evaporation + // to mimic the previous scheme which had a diagnostic + // 2-flux treatment, abandoned due to the new prognostic precip + //------------------------------------------------------------- + zcovptot = fmax((*yrecldp).rcovpmin, zcovptot - fmax((double) 0.0, (zcovptot - + za[jl + klon*(jk + klev*ibl)])*zevap / zqxfg[3])); + + //Update first guess field + zqxfg[3] = zqxfg[3] - zevap; + + } + //--------------------------------------------------------- + } else if (ievapsnow == 2) { + + + + //----------------------------------------------------------------------- + // Calculate relative humidity limit for snow evaporation + //----------------------------------------------------------------------- + zzrh = (*yrecldp).rprecrhmax + ((double) 1.0 - (*yrecldp).rprecrhmax)*zcovpmax / + fmax(zepsec, (double) 1.0 - za[jl + klon*(jk + klev*ibl)]); + zzrh = fmin(fmax(zzrh, (*yrecldp).rprecrhmax), (double) 1.0); + zqe = (zqx[jl + klon*(jk + klev*(4 + 5*ibl))] - za[jl + klon*(jk + klev*ibl)]* + zqsice[jl + klon*(jk + klev*ibl)]) / fmax(zepsec, (double) 1.0 - za[jl + klon*(jk + klev*ibl)]); + + //--------------------------------------------- + // humidity in moistest ZCOVPCLR part of domain + //--------------------------------------------- + zqe = fmax((double) 0.0, fmin(zqe, zqsice[jl + klon*(jk + klev*ibl)])); + llo1 = zcovpclr > zepsec && zqx[jl + klon*(jk + klev*(3 + 5*ibl))] > zepsec + && zqe < zzrh*zqsice[jl + klon*(jk + klev*ibl)]; + + if (llo1) { + + // Calculate local precipitation (kg/kg) + zpreclr = zqx[jl + klon*(jk + klev*(3 + 5*ibl))] / zcovptot; + zvpice = ((double)(r2es*exp((r3ies*(ztp1[jl + klon*(jk + klev*ibl)] - rtt))/(ztp1[jl + klon*(jk + klev*ibl)] - r4ies))))*rv / rd; + + // Particle size distribution + // ZTCG increases Ni with colder temperatures - essentially a + // Fletcher or Meyers scheme? + ztcg = (double) 1.0; //v1 EXP(RCL_X3I*(273.15_JPRB-ZTP1(JL,JK))/8.18_JPRB) + // ZFACX1I modification is based on Andrew Barrett's results + zfacx1s = (double) 1.0; //v1 (ZICE0/1.E-5_JPRB)**0.627_JPRB + + zaplusb = (*yrecldp).rcl_apb1*zvpice - (*yrecldp).rcl_apb2*zvpice* + ztp1[jl + klon*(jk + klev*ibl)] + pap[jl + klon*(jk + klev*ibl)]*(*yrecldp).rcl_apb3* + (pow(ztp1[jl + klon*(jk + klev*ibl)], 3)); + zcorrfac = pow((1.0 / zrho), 0.5); + zcorrfac2 = (pow((ztp1[jl + klon*(jk + klev*ibl)] / 273.0), 1.5))*(393.0 / (ztp1[jl + klon*(jk + klev*ibl)] + 120.0)); + + zpr02 = zrho*zpreclr*(*yrecldp).rcl_const1s / (ztcg*zfacx1s); + + zterm1 = (zqsice[jl + klon*(jk + klev*ibl)] - zqe)*(pow(ztp1[jl + klon*(jk + klev*ibl)], 2))* + zvpice*zcorrfac2*ztcg*(*yrecldp).rcl_const2s*zfacx1s / (zrho*zaplusb*zqsice[jl + klon*(jk + klev*ibl)]); + zterm2 = 0.65*(*yrecldp).rcl_const6s*(pow(zpr02, (*yrecldp).rcl_const4s)) + + (*yrecldp).rcl_const3s*(pow(zcorrfac, 0.5))*(pow(zrho, 0.5))*(pow(zpr02, + (*yrecldp).rcl_const5s)) / (pow(zcorrfac2, 0.5)); + + zdpevap = fmax(zcovpclr*zterm1*zterm2*ptsphy, (double) 0.0); + + //-------------------------------------------------------------------- + // Limit evaporation to snow amount + //-------------------------------------------------------------------- + zevap = fmin(zdpevap, zevaplimice); + zevap = fmin(zevap, zqx[jl + klon*(jk + klev*(3 + 5*ibl))]); + + + zsolqa[4 + 5*(3)] = zsolqa[4 + 5*(3)] + zevap; + zsolqa[3 + 5*(4)] = zsolqa[3 + 5*(4)] - zevap; + + //------------------------------------------------------------- + // Reduce the total precip coverage proportional to evaporation + // to mimic the previous scheme which had a diagnostic + // 2-flux treatment, abandoned due to the new prognostic precip + //------------------------------------------------------------- + zcovptot = fmax((*yrecldp).rcovpmin, zcovptot - fmax((double) 0.0, (zcovptot - + za[jl + klon*(jk + klev*ibl)])*zevap / zqx[jl + klon*(jk + klev*(3 + 5*ibl))])); + + //Update first guess field + zqxfg[3] = zqxfg[3] - zevap; + + } + + } + // on IEVAPSNOW + + //-------------------------------------- + // Evaporate small precipitation amounts + //-------------------------------------- + for (jm = 0; jm <= 5 + -1; jm += 1) { + if (llfall[jm]) { + if (zqxfg[jm] < (*yrecldp).rlmin) { + zsolqa[4 + 5*jm] = zsolqa[4 + 5*jm] + zqxfg[jm]; + zsolqa[jm + 5*(4)] = zsolqa[jm + 5*(4)] - zqxfg[jm]; + } + } + } + + //###################################################################### + // 5.0 *** SOLVERS FOR A AND L *** + // now use an implicit solution rather than exact solution + // solver is forward in time, upstream difference for advection + //###################################################################### + + //--------------------------- + // 5.1 solver for cloud cover + //--------------------------- + zanew = (za[jl + klon*(jk + klev*ibl)] + zsolac) / ((double) 1.0 + zsolab); + zanew = fmin(zanew, (double) 1.0); + if (zanew < (*yrecldp).ramin) { + zanew = (double) 0.0; + } + zda = zanew - zaorig[jl + klon*(jk + klev*ibl)]; + //--------------------------------- + // variables needed for next level + //--------------------------------- + zanewm1 = zanew; + + //-------------------------------- + // 5.2 solver for the microphysics + //-------------------------------- + + //-------------------------------------------------------------- + // Truncate explicit sinks to avoid negatives + // Note: Species are treated in the order in which they run out + // since the clipping will alter the balance for the other vars + //-------------------------------------------------------------- + + for (jm = 0; jm <= 5 + -1; jm += 1) { + for (jn = 0; jn <= 5 + -1; jn += 1) { + llindex3[jn + 5*jm] = false; + } + zsinksum[jm] = (double) 0.0; + } + + //---------------------------- + // collect sink terms and mark + //---------------------------- + for (jm = 0; jm <= 5 + -1; jm += 1) { + for (jn = 0; jn <= 5 + -1; jn += 1) { + zsinksum[jm] = zsinksum[jm] - zsolqa[jm + 5*jn]; // +ve total is bad + } + } + + //--------------------------------------- + // calculate overshoot and scaling factor + //--------------------------------------- + for (jm = 0; jm <= 5 + -1; jm += 1) { + zmax = fmax(zqx[jl + klon*(jk + klev*(jm + 5*ibl))], zepsec); + zrat = fmax(zsinksum[jm], zmax); + zratio[jm] = zmax / zrat; + } + + //-------------------------------------------- + // scale the sink terms, in the correct order, + // recalculating the scale factor each time + //-------------------------------------------- + for (jm = 0; jm <= 5 + -1; jm += 1) { + zsinksum[jm] = (double) 0.0; + } + + //---------------- + // recalculate sum + //---------------- + for (jm = 0; jm <= 5 + -1; jm += 1) { + psum_solqa = 0.0; + for (jn = 0; jn <= 5 + -1; jn += 1) { + psum_solqa = psum_solqa + zsolqa[jm + 5*jn]; + } + // ZSINKSUM(JL,JM)=ZSINKSUM(JL,JM)-SUM(ZSOLQA(JL,JM,1:NCLV)) + zsinksum[jm] = zsinksum[jm] - psum_solqa; + //--------------------------- + // recalculate scaling factor + //--------------------------- + zmm = fmax(zqx[jl + klon*(jk + klev*(jm + 5*ibl))], zepsec); + zrr = fmax(zsinksum[jm], zmm); + zratio[jm] = zmm / zrr; + //------ + // scale + //------ + zzratio = zratio[jm]; + //DIR$ IVDEP + //DIR$ PREFERVECTOR + for (jn = 0; jn <= 5 + -1; jn += 1) { + if (zsolqa[jm + 5*jn] < (double) 0.0) { + zsolqa[jm + 5*jn] = zsolqa[jm + 5*jn]*zzratio; + zsolqa[jn + 5*jm] = zsolqa[jn + 5*jm]*zzratio; + } + } + } + + //-------------------------------------------------------------- + // 5.2.2 Solver + //------------------------ + + //------------------------ + // set the LHS of equation + //------------------------ + for (jm = 0; jm <= 5 + -1; jm += 1) { + for (jn = 0; jn <= 5 + -1; jn += 1) { + //---------------------------------------------- + // diagonals: microphysical sink terms+transport + //---------------------------------------------- + if (jn + 1 == jm + 1) { + zqlhs[jn + 5*jm] = (double) 1.0 + zfallsink[jm]; + for (jo = 0; jo <= 5 + -1; jo += 1) { + zqlhs[jn + 5*jm] = zqlhs[jn + 5*jm] + zsolqb[jo + 5*jn]; + } + //------------------------------------------ + // non-diagonals: microphysical source terms + //------------------------------------------ + } else { + zqlhs[jn + 5*jm] = -zsolqb[jn + 5*jm]; // here is the delta T - missing from doc. + } + } + } + + //------------------------ + // set the RHS of equation + //------------------------ + for (jm = 0; jm <= 5 + -1; jm += 1) { + //--------------------------------- + // sum the explicit source and sink + //--------------------------------- + zexplicit = (double) 0.0; + for (jn = 0; jn <= 5 + -1; jn += 1) { + zexplicit = zexplicit + zsolqa[jm + 5*jn]; // sum over middle index + } + zqxn[jm] = zqx[jl + klon*(jk + klev*(jm + 5*ibl))] + zexplicit; + } + + //----------------------------------- + // *** solve by LU decomposition: *** + //----------------------------------- + + // Note: This fast way of solving NCLVxNCLV system + // assumes a good behaviour (i.e. non-zero diagonal + // terms with comparable orders) of the matrix stored + // in ZQLHS. For the moment this is the case but + // be aware to preserve it when doing eventual + // modifications. + + // Non pivoting recursive factorization + for (jn = 0; jn <= 5 - 1 + -1; jn += 1) { + // number of steps + for (jm = jn + 1; jm <= 5 + -1; jm += 1) { + // row index + zqlhs[jm + 5*jn] = zqlhs[jm + 5*jn] / zqlhs[jn + 5*jn]; + for (ik = jn + 1; ik <= 5 + -1; ik += 1) { + // column index + zqlhs[jm + 5*ik] = zqlhs[jm + 5*ik] - zqlhs[jm + 5*jn]*zqlhs[jn + 5*ik]; + } + } + } + + // Backsubstitution + // step 1 + for (jn = 1; jn <= 5 + -1; jn += 1) { + for (jm = 0; jm <= jn + 1 - 1 + -1; jm += 1) { + zqxn[jn] = zqxn[jn] - zqlhs[jn + 5*jm]*zqxn[jm]; + } + } + // step 2 + zqxn[4] = zqxn[4] / zqlhs[4 + 5*(4)]; + for (jn = -2 + 5; jn >= 1 + -1; jn += -1) { + for (jm = jn + 1; jm <= 5 + -1; jm += 1) { + zqxn[jn] = zqxn[jn] - zqlhs[jn + 5*jm]*zqxn[jm]; + } + zqxn[jn] = zqxn[jn] / zqlhs[jn + 5*jn]; + } + + // Ensure no small values (including negatives) remain in cloud variables nor + // precipitation rates. + // Evaporate l,i,r,s to water vapour. Latent heating taken into account below + for (jn = 0; jn <= 5 - 1 + -1; jn += 1) { + if (zqxn[jn] < zepsec) { + zqxn[4] = zqxn[4] + zqxn[jn]; + zqxn[jn] = (double) 0.0; + } + } + + //-------------------------------- + // variables needed for next level + //-------------------------------- + for (jm = 0; jm <= 5 + -1; jm += 1) { + zqxnm1[jm] = zqxn[jm]; + zqxn2d[jl + klon*(jk + klev*(jm + 5*ibl))] = zqxn[jm]; + } + + //------------------------------------------------------------------------ + // 5.3 Precipitation/sedimentation fluxes to next level + // diagnostic precipitation fluxes + // It is this scaled flux that must be used for source to next layer + //------------------------------------------------------------------------ + + for (jm = 0; jm <= 5 + -1; jm += 1) { + zpfplsx[jl + klon*(1 + jk + (klev + 1)*(jm + 5*ibl))] = + zfallsink[jm]*zqxn[jm]*zrdtgdp; + } + + // Ensure precipitation fraction is zero if no precipitation + zqpretot = zpfplsx[jl + klon*(1 + jk + (klev + 1)*(3 + 5*ibl))] + + zpfplsx[jl + klon*(1 + jk + (klev + 1)*(2 + 5*ibl))]; + if (zqpretot < zepsec) { + zcovptot = (double) 0.0; + } + + //###################################################################### + // 6 *** UPDATE TENDANCIES *** + //###################################################################### + + //-------------------------------- + // 6.1 Temperature and CLV budgets + //-------------------------------- + + for (jm = 0; jm <= 5 - 1 + -1; jm += 1) { + + // calculate fluxes in and out of box for conservation of TL + zfluxq[jm] = zpsupsatsrce[jm] + zconvsrce[jm] + zfallsrce[jm] - + (zfallsink[jm] + zconvsink[jm])*zqxn[jm]; + + if (iphase[jm] == 1) { + tendency_loc_t[jl + klon*(jk + klev*ibl)] = tendency_loc_t[jl + klon*(jk + klev*ibl)] + + ralvdcp*(zqxn[jm] - zqx[jl + klon*(jk + klev*(jm + 5*ibl))] - zfluxq[jm])*zqtmst; + } + + if (iphase[jm] == 2) { + tendency_loc_t[jl + klon*(jk + klev*ibl)] = tendency_loc_t[jl + klon*(jk + klev*ibl)] + + ralsdcp*(zqxn[jm] - zqx[jl + klon*(jk + klev*(jm + 5*ibl))] - zfluxq[jm])*zqtmst; + } + + //---------------------------------------------------------------------- + // New prognostic tendencies - ice,liquid rain,snow + // Note: CLV arrays use PCLV in calculation of tendency while humidity + // uses ZQX. This is due to clipping at start of cloudsc which + // include the tendency already in TENDENCY_LOC_T and TENDENCY_LOC_q. ZQX was reset + //---------------------------------------------------------------------- + tendency_loc_cld[jl + klon*(jk + klev*(jm + 5*ibl))] = tendency_loc_cld[jl + klon*(jk + klev*(jm + 5*ibl))] + + (zqxn[jm] - zqx0[jl + klon*(jk + klev*(jm + 5*ibl))])*zqtmst; + + } + + //---------------------- + // 6.2 Humidity budget + //---------------------- + tendency_loc_q[jl + klon*(jk + klev*ibl)] = tendency_loc_q[jl + klon*(jk + klev*ibl)] + + (zqxn[4] - zqx[jl + klon*(jk + klev*(4 + 5*ibl))])*zqtmst; + + //------------------- + // 6.3 cloud cover + //----------------------- + tendency_loc_a[jl + klon*(jk + klev*ibl)] = tendency_loc_a[jl + klon*(jk + klev*ibl)] + zda*zqtmst; + + //-------------------------------------------------- + // Copy precipitation fraction into output variable + //------------------------------------------------- + pcovptot[jl + klon*(jk + klev*ibl)] = zcovptot; + + } + // on vertical level JK + //---------------------------------------------------------------------- + // END OF VERTICAL LOOP + //---------------------------------------------------------------------- + + //###################################################################### + // 8 *** FLUX/DIAGNOSTICS COMPUTATIONS *** + //###################################################################### + + //-------------------------------------------------------------------- + // Copy general precip arrays back into PFP arrays for GRIB archiving + // Add rain and liquid fluxes, ice and snow fluxes + //-------------------------------------------------------------------- + for (jk = 0; jk <= klev + 1 + -1; jk += 1) { + pfplsl[jl + klon*(jk + (klev + 1)*ibl)] = zpfplsx[jl + klon*(jk + (klev + 1)*(2 + 5*ibl))] + + zpfplsx[jl + klon*(jk + (klev + 1)*(0 + 5*ibl))]; + pfplsn[jl + klon*(jk + (klev + 1)*ibl)] = zpfplsx[jl + klon*(jk + (klev + 1)*(3 + 5*ibl))] + + zpfplsx[jl + klon*(jk + (klev + 1)*(1 + 5*ibl))]; + } + + //-------- + // Fluxes: + //-------- + pfsqlf[jl + klon*(0 + (klev + 1)*ibl)] = (double) 0.0; + pfsqif[jl + klon*(0 + (klev + 1)*ibl)] = (double) 0.0; + pfsqrf[jl + klon*(0 + (klev + 1)*ibl)] = (double) 0.0; + pfsqsf[jl + klon*(0 + (klev + 1)*ibl)] = (double) 0.0; + pfcqlng[jl + klon*(0 + (klev + 1)*ibl)] = (double) 0.0; + pfcqnng[jl + klon*(0 + (klev + 1)*ibl)] = (double) 0.0; + pfcqrng[jl + klon*(0 + (klev + 1)*ibl)] = (double) 0.0; //rain + pfcqsng[jl + klon*(0 + (klev + 1)*ibl)] = (double) 0.0; //snow + // fluxes due to turbulence + pfsqltur[jl + klon*(0 + (klev + 1)*ibl)] = (double) 0.0; + pfsqitur[jl + klon*(0 + (klev + 1)*ibl)] = (double) 0.0; + + for (jk = 0; jk <= klev + -1; jk += 1) { + + zgdph_r = -zrg_r*(paph[jl + klon*(1 + jk + (klev + 1)*ibl)] - + paph[jl + klon*(jk + (klev + 1)*ibl)])*zqtmst; + pfsqlf[jl + klon*(1 + jk + (klev + 1)*ibl)] = pfsqlf[jl + klon*(jk + (klev + 1)*ibl)]; + pfsqif[jl + klon*(1 + jk + (klev + 1)*ibl)] = pfsqif[jl + klon*(jk + (klev + 1)*ibl)]; + pfsqrf[jl + klon*(1 + jk + (klev + 1)*ibl)] = pfsqlf[jl + klon*(jk + (klev + 1)*ibl)]; + pfsqsf[jl + klon*(1 + jk + (klev + 1)*ibl)] = pfsqif[jl + klon*(jk + (klev + 1)*ibl)]; + pfcqlng[jl + klon*(1 + jk + (klev + 1)*ibl)] = pfcqlng[jl + klon*(jk + (klev + 1)*ibl)]; + pfcqnng[jl + klon*(1 + jk + (klev + 1)*ibl)] = pfcqnng[jl + klon*(jk + (klev + 1)*ibl)]; + pfcqrng[jl + klon*(1 + jk + (klev + 1)*ibl)] = pfcqlng[jl + klon*(jk + (klev + 1)*ibl)]; + pfcqsng[jl + klon*(1 + jk + (klev + 1)*ibl)] = pfcqnng[jl + klon*(jk + (klev + 1)*ibl)]; + pfsqltur[jl + klon*(1 + jk + (klev + 1)*ibl)] = pfsqltur[jl + klon*(jk + (klev + 1)*ibl)]; + pfsqitur[jl + klon*(1 + jk + (klev + 1)*ibl)] = pfsqitur[jl + klon*(jk + (klev + 1)*ibl)]; + + zalfaw = zfoealfa[jl + klon*(jk + (klev + 1)*ibl)]; + + // Liquid , LS scheme minus detrainment + pfsqlf[jl + klon*(1 + jk + (klev + 1)*ibl)] = pfsqlf[jl + klon*(1 + jk + (klev + 1)*ibl)] + + (zqxn2d[jl + klon*(jk + klev*(0 + 5*ibl))] - zqx0[jl + klon*(jk + klev*(0 + 5*ibl))] + + pvfl[jl + klon*(jk + klev*ibl)]*ptsphy - zalfaw*plude[jl + klon*(jk + klev*ibl)])*zgdph_r; + // liquid, negative numbers + pfcqlng[jl + klon*(1 + jk + (klev + 1)*ibl)] = pfcqlng[jl + klon*(1 + jk + (klev + 1)*ibl)] + + zlneg[jl + klon*(jk + klev*(0 + 5*ibl))]*zgdph_r; + + // liquid, vertical diffusion + pfsqltur[jl + klon*(1 + jk + (klev + 1)*ibl)] = pfsqltur[jl + klon*(1 + jk + (klev + 1)*ibl)] + + pvfl[jl + klon*(jk + klev*ibl)]*ptsphy*zgdph_r; + + // Rain, LS scheme + pfsqrf[jl + klon*(1 + jk + (klev + 1)*ibl)] = pfsqrf[jl + klon*(1 + jk + (klev + 1)*ibl)] + + (zqxn2d[jl + klon*(jk + klev*(2 + 5*ibl))] - zqx0[jl + klon*(jk + klev*(2 + 5*ibl))])*zgdph_r; + // rain, negative numbers + pfcqrng[jl + klon*(1 + jk + (klev + 1)*ibl)] = pfcqrng[jl + klon*(1 + jk + (klev + 1)*ibl)] + + zlneg[jl + klon*(jk + klev*(2 + 5*ibl))]*zgdph_r; + + // Ice , LS scheme minus detrainment + pfsqif[jl + klon*(1 + jk + (klev + 1)*ibl)] = pfsqif[jl + klon*(1 + jk + (klev + 1)*ibl)] + + (zqxn2d[jl + klon*(jk + klev*(1 + 5*ibl))] - zqx0[jl + klon*(jk + klev*(1 + 5*ibl))] + + pvfi[jl + klon*(jk + klev*ibl)]*ptsphy - ((double) 1.0 - zalfaw)*plude[jl + klon*(jk + klev*ibl)])*zgdph_r; + // ice, negative numbers + pfcqnng[jl + klon*(1 + jk + (klev + 1)*ibl)] = pfcqnng[jl + klon*(1 + jk + (klev + 1)*ibl)] + + zlneg[jl + klon*(jk + klev*(1 + 5*ibl))]*zgdph_r; + + // ice, vertical diffusion + pfsqitur[jl + klon*(1 + jk + (klev + 1)*ibl)] = pfsqitur[jl + klon*(1 + jk + (klev + 1)*ibl)] + + pvfi[jl + klon*(jk + klev*ibl)]*ptsphy*zgdph_r; + + // snow, LS scheme + pfsqsf[jl + klon*(1 + jk + (klev + 1)*ibl)] = pfsqsf[jl + klon*(1 + jk + (klev + 1)*ibl)] + + (zqxn2d[jl + klon*(jk + klev*(3 + 5*ibl))] - zqx0[jl + klon*(jk + klev*(3 + 5*ibl))])*zgdph_r; + // snow, negative numbers + pfcqsng[jl + klon*(1 + jk + (klev + 1)*ibl)] = pfcqsng[jl + klon*(1 + jk + (klev + 1)*ibl)] + + zlneg[jl + klon*(jk + klev*(3 + 5*ibl))]*zgdph_r; + } + + //----------------------------------- + // enthalpy flux due to precipitation + //----------------------------------- + for (jk = 0; jk <= klev + 1 + -1; jk += 1) { + pfhpsl[jl + klon*(jk + (klev + 1)*ibl)] = -rlvtt*pfplsl[jl + klon*(jk + (klev + 1)*ibl)]; + pfhpsn[jl + klon*(jk + (klev + 1)*ibl)] = -rlstt*pfplsn[jl + klon*(jk + (klev + 1)*ibl)]; + } +} + diff --git a/src/cloudsc_hip/cloudsc/cloudsc_c_hoist.h b/src/cloudsc_hip/cloudsc/cloudsc_c_hoist.h new file mode 100644 index 00000000..f8949673 --- /dev/null +++ b/src/cloudsc_hip/cloudsc/cloudsc_c_hoist.h @@ -0,0 +1,50 @@ +#include "hip/hip_runtime.h" +/* + * (C) Copyright 1988- ECMWF. + * + * This software is licensed under the terms of the Apache Licence Version 2.0 + * which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. + * In applying this licence, ECMWF does not waive the privileges and immunities + * granted to it by virtue of its status as an intergovernmental organisation + * nor does it submit to any jurisdiction. + */ + +#include "hip/hip_runtime.h" +#include "yoecldp_c.h" +#include + +__global__ void __launch_bounds__(128, 1) cloudsc_c(int kidia, int kfdia, int klon, double ptsphy, + const double * __restrict__ pt, + const double * __restrict__ pq, const double * __restrict__ tendency_tmp_t, + const double * __restrict__ tendency_tmp_q, const double * __restrict__ tendency_tmp_a, + const double * __restrict__ tendency_tmp_cld, double * __restrict__ tendency_loc_t, + double * __restrict__ tendency_loc_q, double * __restrict__ tendency_loc_a, + double * __restrict__ tendency_loc_cld, const double * __restrict__ pvfa, + const double * __restrict__ pvfl, const double * __restrict__ pvfi, const double * __restrict__ pdyna, + const double * __restrict__ pdynl, const double * __restrict__ pdyni, const double * __restrict__ phrsw, + double * __restrict__ phrlw, const double * __restrict__ pvervel, const double * __restrict__ pap, + const double * __restrict__ paph, const double * __restrict__ plsm, + const int * ktype, const double * __restrict__ plu, double * __restrict__ plude, + const double * __restrict__ psnde, const double * __restrict__ pmfu, const double * __restrict__ pmfd, + const double * __restrict__ pa, const double * __restrict__ pclv, const double * __restrict__ psupsat, + const double * __restrict__ plcrit_aer, const double * __restrict__ picrit_aer, + const double * __restrict__ pre_ice, const double * __restrict__ pccn, const double * __restrict__ pnice, + double * __restrict__ pcovptot, double * __restrict__ prainfrac_toprfz, + double * __restrict__ pfsqlf, double * __restrict__ pfsqif, double * __restrict__ pfcqnng, + double * __restrict__ pfcqlng, double * __restrict__ pfsqrf, double * __restrict__ pfsqsf, + double * __restrict__ pfcqrng, double * __restrict__ pfcqsng, + double * __restrict__ pfsqltur, double * __restrict__ pfsqitur, + double * __restrict__ pfplsl, double * __restrict__ pfplsn, double * __restrict__ pfhpsl, + double * __restrict__ pfhpsn, struct TECLDP *yrecldp, int ngpblks, + double rg, double rd, double rcpd, double retv, double rlvtt, double rlstt, double rlmlt, double rtt, + double rv, double r2es, double r3les, double r3ies, double r4les, double r4ies, double r5les, + double r5ies, double r5alvcp, double r5alscp, double ralvdcp, double ralsdcp, double ralfdcp, + double rtwat, double rtice, double rticecu, double rtwat_rtice_r, double rtwat_rticecu_r, + double rkoop1, double rkoop2, + double * __restrict__ zfoealfa, double * __restrict__ ztp1, double * __restrict__ zli, + double * __restrict__ za, double * __restrict__ zaorig, double * __restrict__ zliqfrac, + double * __restrict__ zicefrac, double * __restrict__ zqx, double * __restrict__ zqx0, + double * __restrict__ zpfplsx, double * __restrict__ zlneg, double * __restrict__ zqxn2d, + double * __restrict__ zqsmix, double * __restrict__ zqsliq, double * __restrict__ zqsice, + double * __restrict__ zfoeewmt, double * __restrict__ zfoeew, double * __restrict__ zfoeeliqt); + diff --git a/src/cloudsc_hip/cloudsc/cloudsc_c_k_caching.cpp b/src/cloudsc_hip/cloudsc/cloudsc_c_k_caching.cpp new file mode 100644 index 00000000..07d267cc --- /dev/null +++ b/src/cloudsc_hip/cloudsc/cloudsc_c_k_caching.cpp @@ -0,0 +1,2630 @@ +#include "hip/hip_runtime.h" +/* + * (C) Copyright 1988- ECMWF. + * + * This software is licensed under the terms of the Apache Licence Version 2.0 + * which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. + * In applying this licence, ECMWF does not waive the privileges and immunities + * granted to it by virtue of its status as an intergovernmental organisation + * nor does it submit to any jurisdiction. + */ +#include "cloudsc_c.h" +#include + +__global__ void cloudsc_c(int kidia, int kfdia, int klon, double ptsphy, + const double * __restrict__ pt, + const double * __restrict__ pq, const double * __restrict__ tendency_tmp_t, + const double * __restrict__ tendency_tmp_q, const double * __restrict__ tendency_tmp_a, + const double * __restrict__ tendency_tmp_cld, double * __restrict__ tendency_loc_t, + double * __restrict__ tendency_loc_q, double * __restrict__ tendency_loc_a, + double * __restrict__ tendency_loc_cld, const double * __restrict__ pvfa, + const double * __restrict__ pvfl, const double * __restrict__ pvfi, const double * __restrict__ pdyna, + const double * __restrict__ pdynl, const double * __restrict__ pdyni, const double * __restrict__ phrsw, + double * __restrict__ phrlw, const double * __restrict__ pvervel, const double * __restrict__ pap, + const double * __restrict__ paph, const double * __restrict__ plsm, + const int * ktype, const double * __restrict__ plu, double * __restrict__ plude, + const double * __restrict__ psnde, const double * __restrict__ pmfu, const double * __restrict__ pmfd, + const double * __restrict__ pa, const double * __restrict__ pclv, const double * __restrict__ psupsat, + const double * __restrict__ plcrit_aer, const double * __restrict__ picrit_aer, + const double * __restrict__ pre_ice, const double * __restrict__ pccn, const double * __restrict__ pnice, + double * __restrict__ pcovptot, double * __restrict__ prainfrac_toprfz, + double * __restrict__ pfsqlf, double * __restrict__ pfsqif, double * __restrict__ pfcqnng, + double * __restrict__ pfcqlng, double * __restrict__ pfsqrf, double * __restrict__ pfsqsf, + double * __restrict__ pfcqrng, double * __restrict__ pfcqsng, + double * __restrict__ pfsqltur, double * __restrict__ pfsqitur, + double * __restrict__ pfplsl, double * __restrict__ pfplsn, double * __restrict__ pfhpsl, + double * __restrict__ pfhpsn, struct TECLDP *yrecldp, int ngpblks, + double rg, double rd, double rcpd, double retv, double rlvtt, double rlstt, double rlmlt, double rtt, + double rv, double r2es, double r3les, double r3ies, double r4les, double r4ies, double r5les, + double r5ies, double r5alvcp, double r5alscp, double ralvdcp, double ralsdcp, double ralfdcp, + double rtwat, double rtice, double rticecu, double rtwat_rtice_r, double rtwat_rticecu_r, + double rkoop1, double rkoop2) { + + //------------------------------------------------------------------------------- + // Declare input/output arguments + //------------------------------------------------------------------------------- + + // PLCRIT_AER : critical liquid mmr for rain autoconversion process + // PICRIT_AER : critical liquid mmr for snow autoconversion process + // PRE_LIQ : liq Re + // PRE_ICE : ice Re + // PCCN : liquid cloud condensation nuclei + // PNICE : ice number concentration (cf. CCN) + + const int klev = 137; // Number of levels + + double zlcond1, zlcond2, zlevapl, zlevapi, zrainaut, zsnowaut, zliqcld, zicecld; + double zlevap, zleros; + // condensation and evaporation terms + // autoconversion terms + double zfokoop; + double zfoealfa; + double zicenuclei; // number concentration of ice nuclei + + double zlicld; + double zacond; + double zaeros; + double zlfinalsum; + double zdqs; + double ztold; + double zqold; + double zdtgdp; + double zrdtgdp; + double ztrpaus; + double zcovpclr; + double zpreclr; + double zcovptot; + double zcovpmax; + double zqpretot; + double zdpevap; + double zdtforc; + double zdtdiab; + double ztp1[2]; + double zldefr; + double zldifdt; + double zdtgdpf; + double zlcust[5]; + double zacust; + double zmf; + + double zrho; + double ztmp1, ztmp2, ztmp3; + double ztmp4, ztmp5, ztmp6, ztmp7; + double zalfawm; + + // Accumulators of A,B,and C factors for cloud equations + double zsolab; // -ve implicit CC + double zsolac; // linear CC + double zanew; + double zanewm1; + + double zgdp; + + //---for flux calculation + double zda; + double zli; + double za[2]; + double zaorig; + + int llflag; + int llo1; + + int icall, ik, jk, jl, jm, jn, jo, jlen, is; + + double zdp, zpaphd; + + double zalfa; + // & ZALFACU, ZALFALS + double zalfaw; + double zbeta, zbeta1; + double zcfpr; + double zcor; + double zcdmax; + double zmin; + double zlcondlim; + double zdenom; + double zdpmxdt; + double zdpr; + double zdtdp; + double ze; + double zepsec; + double zfac, zfaci, zfacw; + double zgdcp; + double zinew; + double zlcrit; + double zmfdn; + double zprecip; + double zqe; + double zqsat, zqtmst, zrdcp; + double zrhc, zsig, zsigk; + double zwtot; + double zzco, zzdl, zzrh, zzzdt, zqadj; + double zqnew, ztnew; + double zrg_r, zgdph_r, zcons1, zcond, zcons1a; + double zlfinal; + double zmelt; + double zevap; + double zfrz; + double zvpliq, zvpice; + double zadd, zbdd, zcvds, zice0, zdepos; + double zsupsat; + double zfall; + double zre_ice; + double zrldcp; + double zqp1env; + + //---------------------------- + // Arrays for new microphysics + //---------------------------- + int iphase[5]; // marker for water phase of each species + // 0=vapour, 1=liquid, 2=ice + + int imelt[5]; // marks melting linkage for ice categories + // ice->liquid, snow->rain + + int llfall[5]; // marks falling species + // LLFALL=0, cloud cover must > 0 for zqx > 0 + // LLFALL=1, no cloud needed, zqx can evaporate + + int llindex1[5]; // index variable + int llindex3[5*5]; // index variable + double zmax; + double zrat; + int iorder[5]; // array for sorting explicit terms + + double zliqfrac; + double zicefrac; + double zqx[5]; + double zqx0[5]; + double zqxn[5]; // new values for zqx at time+1 + double zqxfg[5]; // first guess values including precip + double zqxnm1[5]; // new values for zqx at time+1 at level above + double zfluxq[5]; // fluxes convergence of species (needed?) + // Keep the following for possible future total water variance scheme? + //REAL(KIND=JPRB) :: ZTL(KLON,KLEV) ! liquid water temperature + //REAL(KIND=JPRB) :: ZABETA(KLON,KLEV) ! cloud fraction + //REAL(KIND=JPRB) :: ZVAR(KLON,KLEV) ! temporary variance + //REAL(KIND=JPRB) :: ZQTMIN(KLON,KLEV) + //REAL(KIND=JPRB) :: ZQTMAX(KLON,KLEV) + + double zlneg[5]; + double zmeltmax; + double zfrzmax; + double zicetot; + + double zqxn2d[5]; + + double zqsmix; + //REAL(KIND=JPRB) :: ZQSBIN(KLON,KLEV) ! binary switched ice/liq saturation + double zqsliq; + double zqsice; + + //REAL(KIND=JPRB) :: ZRHM(KLON,KLEV) ! diagnostic mixed phase RH + //REAL(KIND=JPRB) :: ZRHL(KLON,KLEV) ! RH wrt liq + //REAL(KIND=JPRB) :: ZRHI(KLON,KLEV) ! RH wrt ice + + double zfoeewmt; + double zfoeew; + double zfoeeliqt; + + //REAL(KIND=JPRB) :: ZFOEEICET(KLON,KLEV) + + double zdqsliqdt, zdqsicedt, zdqsmixdt; + double zcorqsliq; + double zcorqsice; + //REAL(KIND=JPRB) :: ZCORQSBIN(KLON) + double zcorqsmix; + double zevaplimliq, zevaplimice, zevaplimmix; + + //------------------------------------------------------- + // SOURCE/SINK array for implicit and explicit terms + //------------------------------------------------------- + // a POSITIVE value entered into the arrays is a... + // Source of this variable + // | + // | Sink of this variable + // | | + // V V + // ZSOLQA(JL,IQa,IQb) = explicit terms + // ZSOLQB(JL,IQa,IQb) = implicit terms + // Thus if ZSOLAB(JL,NCLDQL,IQV)=K where K>0 then this is + // a source of NCLDQL and a sink of IQV + // put 'magic' source terms such as PLUDE from + // detrainment into explicit source/sink array diagnognal + // ZSOLQA(NCLDQL,NCLDQL)= -PLUDE + // i.e. A positive value is a sink!????? weird... + //------------------------------------------------------- + + double zsolqa[5*5]; // explicit sources and sinks + double zsolqb[5*5]; // implicit sources and sinks + // e.g. microphysical pathways between ice variables. + double zqlhs[5*5]; // n x n matrix storing the LHS of implicit solver + double zvqx[5]; // fall speeds of three categories + double zexplicit; + double zratio[5], zsinksum[5]; + + // for sedimentation source/sink terms + double zfallsink[5]; + double zfallsrce[5]; + + // for convection detrainment source and subsidence source/sink terms + double zconvsrce[5]; + double zconvsink[5]; + + // for supersaturation source term from previous timestep + double zpsupsatsrce[5]; + + // Numerical fit to wet bulb temperature + double ztw1 = (double) 1329.31; + double ztw2 = (double) 0.0074615; + double ztw3 = (double) 0.85E5; + double ztw4 = (double) 40.637; + double ztw5 = (double) 275.0; + + double zsubsat; // Subsaturation for snow melting term + double ztdmtw0; // Diff between dry-bulb temperature and + // temperature when wet-bulb = 0degC + + // Variables for deposition term + double ztcg; // Temperature dependent function for ice PSD + double zfacx1i, zfacx1s; // PSD correction factor + double zaplusb, zcorrfac, zcorrfac2, zpr02, zterm1, zterm2; // for ice dep + double zcldtopdist; // Distance from cloud top + double zinfactor; // No. of ice nuclei factor for deposition + + // Autoconversion/accretion/riming/evaporation + int iwarmrain; + int ievaprain; + int ievapsnow; + int idepice; + double zrainacc; + double zraincld; + double zsnowrime; + double zsnowcld; + double zesatliq; + double zfallcorr; + double zlambda; + double zevap_denom; + double zcorr2; + double zka; + double zconst; + double ztemp; + + // Rain freezing + int llrainliq; // True if majority of raindrops are liquid (no ice core) + + //---------------------------- + // End: new microphysics + //---------------------------- + + //---------------------- + // SCM budget statistics + //---------------------- + double zrain; + + double zhook_handle; + double ztmpl, ztmpi, ztmpa; + + double zmm, zrr; + double zrg; + + double zzsum, zzratio; + double zepsilon; + + double zcond1, zqp; + + double psum_solqa; + + int ibl; + int i_llfall_0; + //double zqx[5 * klev]; + //double zqx0[5 * klev]; + double zpfplsx[5 * 2]; + //double zlneg[5 * klev]; + //double zqxn2d[5 * klev]; + + jl = threadIdx.x; + ibl = blockIdx.x; + + int jk_i; + int jk_ip1; + int jk_im1; + + zepsilon = (double) 100.*DBL_EPSILON; + + // --------------------------------------------------------------------- + // Set version of warm-rain autoconversion/accretion + // IWARMRAIN = 1 ! Sundquist + // IWARMRAIN = 2 ! Khairoutdinov and Kogan (2000) + // --------------------------------------------------------------------- + iwarmrain = 2; + // --------------------------------------------------------------------- + // Set version of rain evaporation + // IEVAPRAIN = 1 ! Sundquist + // IEVAPRAIN = 2 ! Abel and Boutle (2013) + // --------------------------------------------------------------------- + ievaprain = 2; + // --------------------------------------------------------------------- + // Set version of snow evaporation + // IEVAPSNOW = 1 ! Sundquist + // IEVAPSNOW = 2 ! New + // --------------------------------------------------------------------- + ievapsnow = 1; + // --------------------------------------------------------------------- + // Set version of ice deposition + // IDEPICE = 1 ! Rotstayn (2001) + // IDEPICE = 2 ! New + // --------------------------------------------------------------------- + idepice = 1; + + // --------------------- + // Some simple constants + // --------------------- + zqtmst = (double) 1.0 / ptsphy; + zgdcp = rg / rcpd; + zrdcp = rd / rcpd; + zcons1a = rcpd / (rlmlt*rg*(*yrecldp).rtaumel); + zepsec = (double) 1.E-14; + zrg_r = (double) 1.0 / rg; + zrldcp = (double) 1.0 / (ralsdcp - ralvdcp); + + // Note: Defined in module/yoecldp.F90 + // NCLDQL=1 ! liquid cloud water + // NCLDQI=2 ! ice cloud water + // NCLDQR=3 ! rain water + // NCLDQS=4 ! snow + // NCLDQV=5 ! vapour + + // ----------------------------------------------- + // Define species phase, 0=vapour, 1=liquid, 2=ice + // ----------------------------------------------- + iphase[4] = 0; + iphase[0] = 1; + iphase[2] = 1; + iphase[1] = 2; + iphase[3] = 2; + + // --------------------------------------------------- + // Set up melting/freezing index, + // if an ice category melts/freezes, where does it go? + // --------------------------------------------------- + imelt[4] = -99; + imelt[0] = 2; + imelt[2] = 4; + imelt[1] = 3; + imelt[3] = 3; + + // ----------------------------------------------- + // INITIALIZATION OF OUTPUT TENDENCIES + // ----------------------------------------------- + for (jk = 0; jk <= klev + -1; jk += 1) { + tendency_loc_t[jl + klon*(jk + klev*ibl)] = (double) 0.0; + tendency_loc_q[jl + klon*(jk + klev*ibl)] = (double) 0.0; + tendency_loc_a[jl + klon*(jk + klev*ibl)] = (double) 0.0; + } + for (jm = 0; jm <= 5 - 1 + -1; jm += 1) { + for (jk = 0; jk <= klev + -1; jk += 1) { + tendency_loc_cld[jl + klon*(jk + klev*(jm + 5*ibl))] = (double) 0.0; + } + } + + //-- These were uninitialized : meaningful only when we compare error differences + for (jk = 0; jk <= klev + -1; jk += 1) { + pcovptot[jl + klon*(jk + klev*ibl)] = (double) 0.0; + tendency_loc_cld[jl + klon*(jk + klev*(5 - 1 + 5*(ibl)))] = (double) 0.0; + } + + //-------- + // Fluxes: + //-------- + pfsqlf[jl + klon*(0 + (klev + 1)*ibl)] = (double) 0.0; + pfsqif[jl + klon*(0 + (klev + 1)*ibl)] = (double) 0.0; + pfsqrf[jl + klon*(0 + (klev + 1)*ibl)] = (double) 0.0; + pfsqsf[jl + klon*(0 + (klev + 1)*ibl)] = (double) 0.0; + pfcqlng[jl + klon*(0 + (klev + 1)*ibl)] = (double) 0.0; + pfcqnng[jl + klon*(0 + (klev + 1)*ibl)] = (double) 0.0; + pfcqrng[jl + klon*(0 + (klev + 1)*ibl)] = (double) 0.0; //rain + pfcqsng[jl + klon*(0 + (klev + 1)*ibl)] = (double) 0.0; //snow + // fluxes due to turbulence + pfsqltur[jl + klon*(0 + (klev + 1)*ibl)] = (double) 0.0; + pfsqitur[jl + klon*(0 + (klev + 1)*ibl)] = (double) 0.0; + + // ------------------------- + // set up fall speeds in m/s + // ------------------------- + zvqx[4] = (double) 0.0; + zvqx[0] = (double) 0.0; + zvqx[1] = (*yrecldp).rvice; + zvqx[2] = (*yrecldp).rvrain; + zvqx[3] = (*yrecldp).rvsnow; + for (i_llfall_0 = 0; i_llfall_0 <= 5 + -1; i_llfall_0 += 1) { + llfall[i_llfall_0] = false; + } + for (jm = 0; jm <= 5 + -1; jm += 1) { + if (zvqx[jm] > (double) 0.0) { + llfall[jm] = true; + } + // falling species + } + // Set LLFALL to false for ice (but ice still sediments!) + // Need to rationalise this at some point + llfall[1] = false; + + prainfrac_toprfz[jl + klon*ibl] = (double) 0.0; // rain fraction at top of refreezing layer + llrainliq = true; // Assume all raindrops are liquid initially + + //###################################################################### + // 1. *** INITIAL VALUES FOR VARIABLES *** + //###################################################################### + + //----------------------------- + // Reset single level variables + //----------------------------- + + zanewm1 = (double) 0.0; + zda = (double) 0.0; + zcovpclr = (double) 0.0; + zcovpmax = (double) 0.0; + zcovptot = (double) 0.0; + zcldtopdist = (double) 0.0; + //------------- + // zero arrays + //------------- + for (jm = 0; jm <= 5 + -1; jm += 1) { + zpfplsx[0 + 2*jm] = (double) 0.0; // precip fluxes + zpfplsx[1 + 2*jm] = (double) 0.0; + } + + // ---------------------- + // non CLV initialization + // ---------------------- + for (jk = 0; jk <= klev + 1 + -1; jk += 1) { + + // Fortran counting is beautiful! + jk_i = (jk + 1) % 2; + jk_ip1 = (jk + 2) % 2; + jk_im1 = (jk) % 2; + + if (1 <= jk + 1 && jk + 1 <= klev) { + ztp1[jk_i] = pt[jl + klon*(jk + klev*ibl)] + ptsphy* + tendency_tmp_t[jl + klon*(jk + klev*ibl)]; + zqx[4] = pq[jl + klon*(jk + klev*ibl)] + ptsphy* + tendency_tmp_q[jl + klon*(jk + klev*ibl)]; + zqx0[4] = pq[jl + klon*(jk + klev*ibl)] + ptsphy* + tendency_tmp_q[jl + klon*(jk + klev*ibl)]; + za[jk_i] = pa[jl + klon*(jk + klev*ibl)] + ptsphy* + tendency_tmp_a[jl + klon*(jk + klev*ibl)]; + zaorig = pa[jl + klon*(jk + klev*ibl)] + ptsphy* + tendency_tmp_a[jl + klon*(jk + klev*ibl)]; + + // ------------------------------------- + // initialization for CLV family + // ------------------------------------- + for (jm = 0; jm <= 5 - 1 + -1; jm += 1) { + zqx[jm] = pclv[jl + klon*(jk + klev*(jm + 5*ibl))] + ptsphy* + tendency_tmp_cld[jl + klon*(jk + klev*(jm + 5*ibl))]; + zqx0[jm] = pclv[jl + klon*(jk + klev*(jm + 5*ibl))] + ptsphy* + tendency_tmp_cld[jl + klon*(jk + klev*(jm + 5*ibl))]; + } + + for (jm = 0; jm <= 5 + -1; jm += 1) { + zqxn2d[jm] = (double) 0.0; // end of timestep values in 2D + zlneg[jm] = (double) 0.0; // negative input check + } + + + // ---------------------------------------------------- + // Tidy up very small cloud cover or total cloud water + // ---------------------------------------------------- + if (zqx[0] + zqx[1] < (*yrecldp).rlmin || za[jk_i] < (*yrecldp) + .ramin) { + + // Evaporate small cloud liquid water amounts + zlneg[0] = zlneg[0] + zqx[0]; + zqadj = zqx[0]*zqtmst; + tendency_loc_q[jl + klon*(jk + klev*ibl)] = + tendency_loc_q[jl + klon*(jk + klev*ibl)] + zqadj; + tendency_loc_t[jl + klon*(jk + klev*ibl)] = + tendency_loc_t[jl + klon*(jk + klev*ibl)] - ralvdcp*zqadj; + zqx[4] = zqx[4] + zqx[0]; + zqx[0] = (double) 0.0; + + // Evaporate small cloud ice water amounts + zlneg[1] = zlneg[1] + zqx[1]; + zqadj = zqx[1]*zqtmst; + tendency_loc_q[jl + klon*(jk + klev*ibl)] = + tendency_loc_q[jl + klon*(jk + klev*ibl)] + zqadj; + tendency_loc_t[jl + klon*(jk + klev*ibl)] = + tendency_loc_t[jl + klon*(jk + klev*ibl)] - ralsdcp*zqadj; + zqx[4] = zqx[4] + zqx[1]; + zqx[1] = (double) 0.0; + + // Set cloud cover to zero + za[jk_i] = (double) 0.0; + + } + + // --------------------------------- + // Tidy up small CLV variables + // --------------------------------- + //DIR$ IVDEP + for (jm = 0; jm <= 5 - 1 + -1; jm += 1) { + if (zqx[jm] < (*yrecldp).rlmin) { + zlneg[jm] = zlneg[jm] + zqx[jm]; + zqadj = zqx[jm]*zqtmst; + tendency_loc_q[jl + klon*(jk + klev*ibl)] = + tendency_loc_q[jl + klon*(jk + klev*ibl)] + zqadj; + if (iphase[jm] == 1) { + tendency_loc_t[jl + klon*(jk + klev*ibl)] = + tendency_loc_t[jl + klon*(jk + klev*ibl)] - ralvdcp*zqadj; + } + if (iphase[jm] == 2) { + tendency_loc_t[jl + klon*(jk + klev*ibl)] = + tendency_loc_t[jl + klon*(jk + klev*ibl)] - ralsdcp*zqadj; + } + zqx[4] = zqx[4] + zqx[jm]; + zqx[jm] = (double) 0.0; + } + } + + // ------------------------------ + // Define saturation values + // ------------------------------ + //---------------------------------------- + // old *diagnostic* mixed phase saturation + //---------------------------------------- + zfoealfa = ((double)(fmin(1.0, pow((fmax(rtice, fmin(rtwat, ztp1[jk_i])) - rtice)*rtwat_rtice_r, 2)))); + zfoeewmt = fmin(((double)(r2es*((double)(fmin(1.0, pow((fmax(rtice, fmin(rtwat, ztp1[jk_i])) - rtice)*rtwat_rtice_r, 2)))* + exp((r3les*(ztp1[jk_i] - rtt))/(ztp1[jk_i] - r4les)) + + (1.0 - (double)(fmin(1.0, pow((fmax(rtice, fmin(rtwat, ztp1[jk_i])) - rtice)*rtwat_rtice_r, 2))))* + exp((r3ies*(ztp1[jk_i] - rtt))/(ztp1[jk_i] - r4ies))))) / pap[jl + klon*(jk + klev*ibl)], (double) 0.5); + zqsmix = zfoeewmt; + zqsmix = zqsmix / ((double) 1.0 - retv*zqsmix); + + //--------------------------------------------- + // ice saturation T<273K + // liquid water saturation for T>273K + //--------------------------------------------- + zalfa = ((double)(fmax(0.0, copysign(1.0, ztp1[jk_i] - rtt)))); + zfoeew = fmin((zalfa*((double)(r2es*exp((r3les*(ztp1[jk_i] - rtt))/(ztp1[jk_i] - r4les)))) + + ((double) 1.0 - zalfa)*((double)(r2es*exp((r3ies*(ztp1[jk_i] - rtt))/(ztp1[jk_i] - r4ies))))) / + pap[jl + klon*(jk + klev*ibl)], (double) 0.5); + zfoeew = fmin((double) 0.5, zfoeew); + zqsice = zfoeew / ((double) 1.0 - retv*zfoeew); + + //---------------------------------- + // liquid water saturation + //---------------------------------- + zfoeeliqt = fmin(((double)(r2es*exp((r3les*(ztp1[jk_i] - rtt))/(ztp1[jk_i] - r4les)))) / + pap[jl + klon*(jk + klev*ibl)], (double) 0.5); + zqsliq = zfoeeliqt; + zqsliq = zqsliq / ((double) 1.0 - retv*zqsliq); + + // !---------------------------------- + // ! ice water saturation + // !---------------------------------- + // ZFOEEICET(JL,JK)=MIN(FOEEICE(ZTP1(JL,JK))/PAP(JL,JK),0.5_JPRB) + // ZQSICE(JL,JK)=ZFOEEICET(JL,JK) + // ZQSICE(JL,JK)=ZQSICE(JL,JK)/(1.0_JPRB-retv*ZQSICE(JL,JK)) + + + //------------------------------------------ + // Ensure cloud fraction is between 0 and 1 + //------------------------------------------ + za[jk_i] = fmax((double) 0.0, fmin((double) 1.0, za[jk_i])); + + //------------------------------------------------------------------- + // Calculate liq/ice fractions (no longer a diagnostic relationship) + //------------------------------------------------------------------- + zli = zqx[0] + zqx[1]; + if (zli > (*yrecldp).rlmin) { + zliqfrac = zqx[0] / zli; + zicefrac = (double) 1.0 - zliqfrac; + } else { + zliqfrac = (double) 0.0; + zicefrac = (double) 0.0; + } + + //###################################################################### + // 2. *** CONSTANTS AND PARAMETERS *** + //###################################################################### + // Calculate L in updrafts of bl-clouds + // Specify QS, P/PS for tropopause (for c2) + // And initialize variables + //------------------------------------------ + + //--------------------------------- + // Find tropopause level (ZTRPAUS) + //--------------------------------- + //ZTRPAUS = 0.1_JPRB + //ZPAPHD = 1.0_JPRB / PAPH(JL, KLEV + 1, IBL) + //DO JK=1,KLEV - 1 + // ZSIG = PAP(JL, JK, IBL)*ZPAPHD + // IF (ZSIG > 0.1_JPRB .and. ZSIG < 0.4_JPRB .and. ZTP1(JK_I) > ZTP1(JL, JK + 1, IBL)) THEN + // ZTRPAUS = ZSIG + // END IF + //END DO + + //----------------------------- + // Reset single level variables + //----------------------------- + + //ZANEWM1 = 0.0_JPRB + //ZDA = 0.0_JPRB + //ZCOVPCLR = 0.0_JPRB + //ZCOVPMAX = 0.0_JPRB + //ZCOVPTOT = 0.0_JPRB + //ZCLDTOPDIST = 0.0_JPRB + + //###################################################################### + // 3. *** PHYSICS *** + //###################################################################### + + + //---------------------------------------------------------------------- + // START OF VERTICAL LOOP + //---------------------------------------------------------------------- + + if ((*yrecldp).ncldtop <= jk + 1 && jk + 1 <= klev) { + + //---------------------------------------------------------------------- + // 3.0 INITIALIZE VARIABLES + //---------------------------------------------------------------------- + + //--------------------------------- + // First guess microphysics + //--------------------------------- + for (jm = 0; jm <= 5 + -1; jm += 1) { + zqxfg[jm] = zqx[jm]; + } + + //--------------------------------- + // Set KLON arrays to zero + //--------------------------------- + + zlicld = (double) 0.0; + zrainaut = (double) 0.0; // currently needed for diags + zrainacc = (double) 0.0; // currently needed for diags + zsnowaut = (double) 0.0; // needed + zldefr = (double) 0.0; + zacust = (double) 0.0; // set later when needed + zqpretot = (double) 0.0; + zlfinalsum = (double) 0.0; + + // Required for first guess call + zlcond1 = (double) 0.0; + zlcond2 = (double) 0.0; + zsupsat = (double) 0.0; + zlevapl = (double) 0.0; + zlevapi = (double) 0.0; + + //------------------------------------- + // solvers for cloud fraction + //------------------------------------- + zsolab = (double) 0.0; + zsolac = (double) 0.0; + + zicetot = (double) 0.0; + + //------------------------------------------ + // reset matrix so missing pathways are set + //------------------------------------------ + for (jm = 0; jm <= 5 + -1; jm += 1) { + for (jn = 0; jn <= 5 + -1; jn += 1) { + zsolqb[jn + 5*jm] = (double) 0.0; + zsolqa[jn + 5*jm] = (double) 0.0; + } + } + + //---------------------------------- + // reset new microphysics variables + //---------------------------------- + for (jm = 0; jm <= 5 + -1; jm += 1) { + zfallsrce[jm] = (double) 0.0; + zfallsink[jm] = (double) 0.0; + zconvsrce[jm] = (double) 0.0; + zconvsink[jm] = (double) 0.0; + zpsupsatsrce[jm] = (double) 0.0; + zratio[jm] = (double) 0.0; + } + + + //------------------------- + // derived variables needed + //------------------------- + + zdp = paph[jl + klon*(1 + jk + (klev + 1)*ibl)] - paph[jl + klon*(jk + (klev + + 1)*ibl)]; // dp + zgdp = rg / zdp; // g/dp + zrho = pap[jl + klon*(jk + klev*ibl)] / (rd*ztp1[jk_i]); // p/RT air density + + zdtgdp = ptsphy*zgdp; // dt g/dp + zrdtgdp = zdp*((double) 1.0 / (ptsphy*rg)); // 1/(dt g/dp) + + if (jk + 1 > 1) { + zdtgdpf = ptsphy*rg / (pap[jl + klon*(jk + klev*ibl)] - pap[jl + klon*(-1 + + jk + klev*ibl)]); + } + + //------------------------------------ + // Calculate dqs/dT correction factor + //------------------------------------ + // Reminder: retv=rv/rd-1 + + // liquid + zfacw = r5les / (pow((ztp1[jk_i] - r4les), 2)); + zcor = (double) 1.0 / ((double) 1.0 - retv*zfoeeliqt); + zdqsliqdt = zfacw*zcor*zqsliq; + zcorqsliq = (double) 1.0 + ralvdcp*zdqsliqdt; + + // ice + zfaci = r5ies / (pow((ztp1[jk_i] - r4ies), 2)); + zcor = (double) 1.0 / ((double) 1.0 - retv*zfoeew); + zdqsicedt = zfaci*zcor*zqsice; + zcorqsice = (double) 1.0 + ralsdcp*zdqsicedt; + + // diagnostic mixed + zalfaw = zfoealfa; + zalfawm = zalfaw; + zfac = zalfaw*zfacw + ((double) 1.0 - zalfaw)*zfaci; + zcor = (double) 1.0 / ((double) 1.0 - retv*zfoeewmt); + zdqsmixdt = zfac*zcor*zqsmix; + zcorqsmix = (double) 1.0 + ((double)((double)(fmin(1.0, pow((fmax(rtice, fmin(rtwat, ztp1[jk_i])) - rtice)*rtwat_rtice_r, 2)))* + ralvdcp + (1.0 - (double)(fmin(1.0, pow((fmax(rtice, fmin(rtwat, ztp1[jk_i])) - rtice)*rtwat_rtice_r, 2))))*ralsdcp))*zdqsmixdt; + + // evaporation/sublimation limits + zevaplimmix = fmax((zqsmix - zqx[4]) / zcorqsmix, (double) 0.0); + zevaplimliq = fmax((zqsliq - zqx[4]) / zcorqsliq, (double) 0.0); + zevaplimice = fmax((zqsice - zqx[4]) / zcorqsice, (double) 0.0); + + //-------------------------------- + // in-cloud consensate amount + //-------------------------------- + ztmpa = (double) 1.0 / fmax(za[jk_i], zepsec); + zliqcld = zqx[0]*ztmpa; + zicecld = zqx[1]*ztmpa; + zlicld = zliqcld + zicecld; + + + //------------------------------------------------ + // Evaporate very small amounts of liquid and ice + //------------------------------------------------ + + if (zqx[0] < (*yrecldp).rlmin) { + zsolqa[4 + 5*(0)] = zqx[0]; + zsolqa[0 + 5*(4)] = -zqx[0]; + } + + if (zqx[1] < (*yrecldp).rlmin) { + zsolqa[4 + 5*(1)] = zqx[1]; + zsolqa[1 + 5*(4)] = -zqx[1]; + } + + + //--------------------------------------------------------------------- + // 3.1 ICE SUPERSATURATION ADJUSTMENT + //--------------------------------------------------------------------- + // Note that the supersaturation adjustment is made with respect to + // liquid saturation: when T>0C + // ice saturation: when T<0C + // with an adjustment made to allow for ice + // supersaturation in the clear sky + // Note also that the KOOP factor automatically clips the supersaturation + // to a maximum set by the liquid water saturation mixing ratio + // important for temperatures near to but below 0C + //----------------------------------------------------------------------- + + //DIR$ NOFUSION + + //----------------------------------- + // 3.1.1 Supersaturation limit (from Koop) + //----------------------------------- + // Needs to be set for all temperatures + zfokoop = ((double)(fmin(rkoop1 - rkoop2*ztp1[jk_i], (double)(r2es*exp((r3les*(ztp1[jk_i] - rtt))/ + (ztp1[jk_i] - r4les)))*1.0/(double)(r2es*exp((r3ies*(ztp1[jk_i] - rtt))/(ztp1[jk_i] - r4ies)))))); + + if (ztp1[jk_i] >= rtt || (*yrecldp).nssopt == 0) { + zfac = (double) 1.0; + zfaci = (double) 1.0; + } else { + zfac = za[jk_i] + zfokoop*((double) 1.0 - za[jk_i]); + zfaci = ptsphy / (*yrecldp).rkooptau; + } + + //------------------------------------------------------------------- + // 3.1.2 Calculate supersaturation wrt Koop including dqs/dT + // correction factor + // [#Note: QSICE or QSLIQ] + //------------------------------------------------------------------- + + // Calculate supersaturation to add to cloud + if (za[jk_i] > (double) 1.0 - (*yrecldp).ramin) { + zsupsat = fmax((zqx[4] - zfac*zqsice) / zcorqsice, (double) 0.0); + } else { + // Calculate environmental humidity supersaturation + zqp1env = (zqx[4] - za[jk_i]*zqsice) / fmax((double) 1.0 - za[jk_i], zepsilon); + //& SIGN(MAX(ABS(1.0_JPRB-ZA(JL,JK)),ZEPSILON),1.0_JPRB-ZA(JL,JK)) + zsupsat = fmax(((double) 1.0 - za[jk_i])*(zqp1env - zfac*zqsice) / + zcorqsice, (double) 0.0); + } + + //------------------------------------------------------------------- + // Here the supersaturation is turned into liquid water + // However, if the temperature is below the threshold for homogeneous + // freezing then the supersaturation is turned instantly to ice. + //-------------------------------------------------------------------- + + if (zsupsat > zepsec) { + + if (ztp1[jk_i] > (*yrecldp).rthomo) { + // Turn supersaturation into liquid water + zsolqa[0 + 5*(4)] = zsolqa[0 + 5*(4)] + zsupsat; + zsolqa[4 + 5*(0)] = zsolqa[4 + 5*(0)] - zsupsat; + // Include liquid in first guess + zqxfg[0] = zqxfg[0] + zsupsat; + } else { + // Turn supersaturation into ice water + zsolqa[1 + 5*(4)] = zsolqa[1 + 5*(4)] + zsupsat; + zsolqa[4 + 5*(1)] = zsolqa[4 + 5*(1)] - zsupsat; + // Add ice to first guess for deposition term + zqxfg[1] = zqxfg[1] + zsupsat; + } + + // Increase cloud amount using RKOOPTAU timescale + zsolac = ((double) 1.0 - za[jk_i])*zfaci; + + } + + //------------------------------------------------------- + // 3.1.3 Include supersaturation from previous timestep + // (Calculated in sltENDIF semi-lagrangian LDSLPHY=T) + //------------------------------------------------------- + if (psupsat[jl + klon*(jk + klev*ibl)] > zepsec) { + if (ztp1[jk_i] > (*yrecldp).rthomo) { + // Turn supersaturation into liquid water + zsolqa[0 + 5*(0)] = + zsolqa[0 + 5*(0)] + psupsat[jl + klon*(jk + klev*ibl)]; + zpsupsatsrce[0] = psupsat[jl + klon*(jk + klev*ibl)]; + // Add liquid to first guess for deposition term + zqxfg[0] = zqxfg[0] + psupsat[jl + klon*(jk + klev*ibl)]; + // Store cloud budget diagnostics if required + } else { + // Turn supersaturation into ice water + zsolqa[1 + 5*(1)] = + zsolqa[1 + 5*(1)] + psupsat[jl + klon*(jk + klev*ibl)]; + zpsupsatsrce[1] = psupsat[jl + klon*(jk + klev*ibl)]; + // Add ice to first guess for deposition term + zqxfg[1] = zqxfg[1] + psupsat[jl + klon*(jk + klev*ibl)]; + // Store cloud budget diagnostics if required + } + + // Increase cloud amount using RKOOPTAU timescale + zsolac = ((double) 1.0 - za[jk_i])*zfaci; + // Store cloud budget diagnostics if required + } + + // on JL + + //--------------------------------------------------------------------- + // 3.2 DETRAINMENT FROM CONVECTION + //--------------------------------------------------------------------- + // * Diagnostic T-ice/liq split retained for convection + // Note: This link is now flexible and a future convection + // scheme can detrain explicit seperate budgets of: + // cloud water, ice, rain and snow + // * There is no (1-ZA) multiplier term on the cloud detrainment + // term, since is now written in mass-flux terms + // [#Note: Should use ZFOEALFACU used in convection rather than ZFOEALFA] + //--------------------------------------------------------------------- + if (jk + 1 < klev && jk + 1 >= (*yrecldp).ncldtop) { + + + plude[jl + klon*(jk + klev*ibl)] = plude[jl + klon*(jk + klev*ibl)]*zdtgdp; + + if (/*ldcum[jl + klon*ibl] &&*/ plude[jl + klon*(jk + klev*ibl)] > (*yrecldp) + .rlmin && plu[jl + klon*(1 + jk + klev*ibl)] > zepsec) { + + zsolac = zsolac + plude[jl + klon*(jk + klev*ibl)] / plu[jl + klon*(1 + jk + + klev*ibl)]; + // *diagnostic temperature split* + zalfaw = zfoealfa; + zconvsrce[0] = zalfaw*plude[jl + klon*(jk + klev*ibl)]; + zconvsrce[1] = + ((double) 1.0 - zalfaw)*plude[jl + klon*(jk + klev*ibl)]; + zsolqa[0 + 5*(0)] = + zsolqa[0 + 5*(0)] + zconvsrce[0]; + zsolqa[1 + 5*(1)] = + zsolqa[1 + 5*(1)] + zconvsrce[1]; + + } else { + + plude[jl + klon*(jk + klev*ibl)] = (double) 0.0; + + } + // *convective snow detrainment source + //if (ldcum[jl + klon*ibl]) { + zsolqa[3 + 5*(3)] = + zsolqa[3 + 5*(3)] + psnde[jl + klon*(jk + klev*ibl)]*zdtgdp; + //} + + + } + // JK (*yrecldp).ncldtop) { + + zmf = fmax((double) 0.0, (pmfu[jl + klon*(jk + klev*ibl)] + pmfd[jl + + klon*(jk + klev*ibl)])*zdtgdp); + zacust = zmf*zanewm1; + + for (jm = 0; jm <= 5 + -1; jm += 1) { + if (!llfall[jm] && iphase[jm] > 0) { + zlcust[jm] = zmf*zqxnm1[jm]; + // record total flux for enthalpy budget: + zconvsrce[jm] = zconvsrce[jm] + zlcust[jm]; + } + } + + // Now have to work out how much liquid evaporates at arrival point + // since there is no prognostic memory for in-cloud humidity, i.e. + // we always assume cloud is saturated. + + zdtdp = zrdcp*(double) 0.5*(ztp1[jk_im1] + ztp1[jk_i]) / paph[jl + + klon*(jk + (klev + 1)*ibl)]; + zdtforc = zdtdp*(pap[jl + klon*(jk + klev*ibl)] - pap[jl + klon*(-1 + jk + + klev*ibl)]); + //[#Note: Diagnostic mixed phase should be replaced below] + zdqs = zanewm1*zdtforc*zdqsmixdt; + + for (jm = 0; jm <= 5 + -1; jm += 1) { + if (!llfall[jm] && iphase[jm] > 0) { + zlfinal = fmax((double) 0.0, zlcust[jm] - zdqs); //lim to zero + // no supersaturation allowed incloud ---V + zevap = fmin((zlcust[jm] - zlfinal), zevaplimmix); + // ZEVAP=0.0_JPRB + zlfinal = zlcust[jm] - zevap; + zlfinalsum = zlfinalsum + zlfinal; // sum + + zsolqa[jm + 5*jm] = zsolqa[jm + 5*jm] + zlcust[jm]; // whole sum + zsolqa[4 + 5*jm] = zsolqa[4 + 5*jm] + zevap; + zsolqa[jm + 5*(4)] = zsolqa[jm + 5*(4)] - zevap; + } + } + + // Reset the cloud contribution if no cloud water survives to this level: + if (zlfinalsum < zepsec) { + zacust = (double) 0.0; + } + zsolac = zsolac + zacust; + + } + // on JK>NCLDTOP + + //--------------------------------------------------------------------- + // Subsidence sink of cloud to the layer below + // (Implicit - re. CFL limit on convective mass flux) + //--------------------------------------------------------------------- + + + if (jk + 1 < klev) { + + zmfdn = fmax((double) 0.0, (pmfu[jl + klon*(1 + jk + klev*ibl)] + pmfd[jl + + klon*(1 + jk + klev*ibl)])*zdtgdp); + + zsolab = zsolab + zmfdn; + zsolqb[0 + 5*(0)] = zsolqb[0 + 5*(0)] + zmfdn; + zsolqb[1 + 5*(1)] = zsolqb[1 + 5*(1)] + zmfdn; + + // Record sink for cloud budget and enthalpy budget diagnostics + zconvsink[0] = zmfdn; + zconvsink[1] = zmfdn; + + } + + + //---------------------------------------------------------------------- + // 3.4 EROSION OF CLOUDS BY TURBULENT MIXING + //---------------------------------------------------------------------- + // NOTE: In default tiedtke scheme this process decreases the cloud + // area but leaves the specific cloud water content + // within clouds unchanged + //---------------------------------------------------------------------- + + // ------------------------------ + // Define turbulent erosion rate + // ------------------------------ + zldifdt = (*yrecldp).rcldiff*ptsphy; //original version + //Increase by factor of 5 for convective points + if (ktype[jl + klon*ibl] > 0 && plude[jl + klon*(jk + klev*ibl)] > zepsec) { + zldifdt = (*yrecldp).rcldiff_convi*zldifdt; + } + + // At the moment, works on mixed RH profile and partitioned ice/liq fraction + // so that it is similar to previous scheme + // Should apply RHw for liquid cloud and RHi for ice cloud separately + if (zli > zepsec) { + // Calculate environmental humidity + // ZQE=(ZQX(JL,JK,NCLDQV)-ZA(JL,JK)*ZQSMIX(JL,JK))/& + // & MAX(ZEPSEC,1.0_JPRB-ZA(JL,JK)) + // ZE=ZLDIFDT(JL)*MAX(ZQSMIX(JL,JK)-ZQE,0.0_JPRB) + ze = zldifdt*fmax(zqsmix - zqx[4], (double) 0.0); + zleros = za[jk_i]*ze; + zleros = fmin(zleros, zevaplimmix); + zleros = fmin(zleros, zli); + zaeros = zleros / zlicld; //if linear term + + // Erosion is -ve LINEAR in L,A + zsolac = zsolac - zaeros; //linear + + zsolqa[4 + 5*(0)] = zsolqa[4 + 5*(0)] + zliqfrac*zleros; + zsolqa[0 + 5*(4)] = zsolqa[0 + 5*(4)] - zliqfrac*zleros; + zsolqa[4 + 5*(1)] = zsolqa[4 + 5*(1)] + zicefrac*zleros; + zsolqa[1 + 5*(4)] = zsolqa[1 + 5*(4)] - zicefrac*zleros; + + } + + //---------------------------------------------------------------------- + // 3.4 CONDENSATION/EVAPORATION DUE TO DQSAT/DT + //---------------------------------------------------------------------- + // calculate dqs/dt + // Note: For the separate prognostic Qi and Ql, one would ideally use + // Qsat/DT wrt liquid/Koop here, since the physics is that new clouds + // forms by liquid droplets [liq] or when aqueous aerosols [Koop] form. + // These would then instantaneous freeze if T<-38C or lead to ice growth + // by deposition in warmer mixed phase clouds. However, since we do + // not have a separate prognostic equation for in-cloud humidity or a + // statistical scheme approach in place, the depositional growth of ice + // in the mixed phase can not be modelled and we resort to supersaturation + // wrt ice instanteously converting to ice over one timestep + // (see Tompkins et al. QJRMS 2007 for details) + // Thus for the initial implementation the diagnostic mixed phase is + // retained for the moment, and the level of approximation noted. + //---------------------------------------------------------------------- + + zdtdp = zrdcp*ztp1[jk_i] / pap[jl + klon*(jk + klev*ibl)]; + zdpmxdt = zdp*zqtmst; + zmfdn = (double) 0.0; + if (jk + 1 < klev) { + zmfdn = + pmfu[jl + klon*(1 + jk + klev*ibl)] + pmfd[jl + klon*(1 + jk + klev*ibl)]; + } + zwtot = pvervel[jl + klon*(jk + klev*ibl)] + (double) 0.5*rg*(pmfu[jl + + klon*(jk + klev*ibl)] + pmfd[jl + klon*(jk + klev*ibl)] + zmfdn); + zwtot = fmin(zdpmxdt, fmax(-zdpmxdt, zwtot)); + zzzdt = phrsw[jl + klon*(jk + klev*ibl)] + phrlw[jl + klon*(jk + klev*ibl)]; + zdtdiab = + fmin(zdpmxdt*zdtdp, fmax(-zdpmxdt*zdtdp, zzzdt))*ptsphy + ralfdcp*zldefr; + // Note: ZLDEFR should be set to the difference between the mixed phase functions + // in the convection and cloud scheme, but this is not calculated, so is zero and + // the functions must be the same + zdtforc = zdtdp*zwtot*ptsphy + zdtdiab; + zqold = zqsmix; + ztold = ztp1[jk_i]; + ztp1[jk_i] = ztp1[jk_i] + zdtforc; + ztp1[jk_i] = fmax(ztp1[jk_i], (double) 160.0); + llflag = true; + + // Formerly a call to CUADJTQ(..., ICALL=5) + zqp = (double) 1.0 / pap[jl + klon*(jk + klev*ibl)]; + zqsat = ((double)(r2es*((double)(fmin(1.0, pow((fmax(rtice, fmin(rtwat, ztp1[jk_i])) - rtice)*rtwat_rtice_r, 2)))* + exp((r3les*(ztp1[jk_i] - rtt))/(ztp1[jk_i] - r4les)) + + (1.0 - (double)(fmin(1.0, pow((fmax(rtice, fmin(rtwat, ztp1[jk_i])) - rtice)*rtwat_rtice_r, 2))))* + exp((r3ies*(ztp1[jk_i] - rtt))/(ztp1[jk_i] - r4ies)))))*zqp; + zqsat = fmin((double) 0.5, zqsat); + zcor = (double) 1.0 / ((double) 1.0 - retv*zqsat); + zqsat = zqsat*zcor; + zcond = (zqsmix - zqsat) / ((double) 1.0 + zqsat*zcor*((double)(((double)(fmin(1.0, pow((fmax(rtice, fmin(rtwat, ztp1[jk_i])) - rtice)*rtwat_rtice_r, 2)))*r5alvcp)* + (1.0/pow(ztp1[jk_i] - r4les, 2)) + ((1.0 - (double)(fmin(1.0, pow((fmax(rtice, fmin(rtwat, ztp1[jk_i])) - rtice)*rtwat_rtice_r, 2))))*r5alscp)* + (1.0/pow(ztp1[jk_i] - r4ies, 2))))); + ztp1[jk_i] = ztp1[jk_i] + ((double)((double)(fmin(1.0, pow((fmax(rtice, fmin(rtwat, ztp1[jk_i])) - rtice)*rtwat_rtice_r, 2)))*ralvdcp + + (1.0 - (double)(fmin(1.0, pow((fmax(rtice, fmin(rtwat, ztp1[jk_i])) - rtice)*rtwat_rtice_r, 2))))*ralsdcp))*zcond; + zqsmix = zqsmix - zcond; + zqsat = ((double)(r2es*((double)(fmin(1.0, pow((fmax(rtice, fmin(rtwat, ztp1[jk_i])) - rtice)*rtwat_rtice_r, 2)))* + exp((r3les*(ztp1[jk_i] - rtt))/(ztp1[jk_i] - r4les)) + + (1.0 - (double)(fmin(1.0, pow((fmax(rtice, fmin(rtwat, ztp1[jk_i])) - rtice)*rtwat_rtice_r, 2))))* + exp((r3ies*(ztp1[jk_i] - rtt))/(ztp1[jk_i] - r4ies)))))*zqp; + zqsat = fmin((double) 0.5, zqsat); + zcor = (double) 1.0 / ((double) 1.0 - retv*zqsat); + zqsat = zqsat*zcor; + zcond1 = (zqsmix - zqsat) / ((double) 1.0 + zqsat*zcor*((double)(((double)(fmin(1.0, pow((fmax(rtice, fmin(rtwat, ztp1[jk_i])) - rtice)*rtwat_rtice_r, 2)))*r5alvcp)* + (1.0/pow(ztp1[jk_i] - r4les, 2)) + ((1.0 - (double)(fmin(1.0, pow((fmax(rtice, fmin(rtwat, ztp1[jk_i])) - rtice)*rtwat_rtice_r, 2))))*r5alscp)* + (1.0/pow(ztp1[jk_i] - r4ies, 2))))); + ztp1[jk_i] = ztp1[jk_i] + ((double)((double)(fmin(1.0, pow((fmax(rtice, fmin(rtwat, ztp1[jk_i])) - rtice)*rtwat_rtice_r, 2)))*ralvdcp + + (1.0 - (double)(fmin(1.0, pow((fmax(rtice, fmin(rtwat, ztp1[jk_i])) - rtice)*rtwat_rtice_r, 2))))*ralsdcp))*zcond1; + zqsmix = zqsmix - zcond1; + + zdqs = zqsmix - zqold; + zqsmix = zqold; + ztp1[jk_i] = ztold; + + //---------------------------------------------------------------------- + // 3.4a ZDQS(JL) > 0: EVAPORATION OF CLOUDS + // ---------------------------------------------------------------------- + // Erosion term is LINEAR in L + // Changed to be uniform distribution in cloud region + + + // Previous function based on DELTA DISTRIBUTION in cloud: + if (zdqs > (double) 0.0) { + // If subsidence evaporation term is turned off, then need to use updated + // liquid and cloud here? + // ZLEVAP = MAX(ZA(JL,JK)+ZACUST(JL),1.0_JPRB)*MIN(ZDQS(JL),ZLICLD(JL)+ZLFINALSUM(JL)) + zlevap = za[jk_i]*fmin(zdqs, zlicld); + zlevap = fmin(zlevap, zevaplimmix); + zlevap = fmin(zlevap, fmax(zqsmix - zqx[4], (double) 0.0)); + + // For first guess call + zlevapl = zliqfrac*zlevap; + zlevapi = zicefrac*zlevap; + + zsolqa[4 + 5*(0)] = zsolqa[4 + 5*(0)] + zliqfrac*zlevap; + zsolqa[0 + 5*(4)] = zsolqa[0 + 5*(4)] - zliqfrac*zlevap; + + zsolqa[4 + 5*(1)] = zsolqa[4 + 5*(1)] + zicefrac*zlevap; + zsolqa[1 + 5*(4)] = zsolqa[1 + 5*(4)] - zicefrac*zlevap; + + } + + + //---------------------------------------------------------------------- + // 3.4b ZDQS(JL) < 0: FORMATION OF CLOUDS + //---------------------------------------------------------------------- + // (1) Increase of cloud water in existing clouds + if (za[jk_i] > zepsec && zdqs <= -(*yrecldp).rlmin) { + + zlcond1 = fmax(-zdqs, (double) 0.0); //new limiter + + //old limiter (significantly improves upper tropospheric humidity rms) + if (za[jk_i] > (double) 0.99) { + zcor = (double) 1.0 / ((double) 1.0 - retv*zqsmix); + zcdmax = (zqx[4] - zqsmix) / ((double) 1.0 + zcor*zqsmix*((double)(((double)(fmin(1.0, pow((fmax(rtice, fmin(rtwat, ztp1[jk_i])) - rtice)*rtwat_rtice_r, 2)))*r5alvcp)* + (1.0/pow(ztp1[jk_i] - r4les, 2)) + ((1.0 - (double)(fmin(1.0, pow((fmax(rtice, fmin(rtwat, ztp1[jk_i])) - rtice)*rtwat_rtice_r, 2))))*r5alscp)* + (1.0/pow(ztp1[jk_i] - r4ies, 2))))); + } else { + zcdmax = (zqx[4] - za[jk_i]*zqsmix) / za[jk_i]; + } + zlcond1 = fmax(fmin(zlcond1, zcdmax), (double) 0.0); + // end old limiter + + zlcond1 = za[jk_i]*zlcond1; + if (zlcond1 < (*yrecldp).rlmin) { + zlcond1 = (double) 0.0; + } + + //------------------------------------------------------------------------- + // All increase goes into liquid unless so cold cloud homogeneously freezes + // Include new liquid formation in first guess value, otherwise liquid + // remains at cold temperatures until next timestep. + //------------------------------------------------------------------------- + if (ztp1[jk_i] > (*yrecldp).rthomo) { + zsolqa[0 + 5*(4)] = zsolqa[0 + 5*(4)] + zlcond1; + zsolqa[4 + 5*(0)] = zsolqa[4 + 5*(0)] - zlcond1; + zqxfg[0] = zqxfg[0] + zlcond1; + } else { + zsolqa[1 + 5*(4)] = zsolqa[1 + 5*(4)] + zlcond1; + zsolqa[4 + 5*(1)] = zsolqa[4 + 5*(1)] - zlcond1; + zqxfg[1] = zqxfg[1] + zlcond1; + } + } + + // (2) Generation of new clouds (da/dt>0) + + + if (zdqs <= -(*yrecldp).rlmin && za[jk_i] < (double) 1.0 - zepsec) { + + //--------------------------- + // Critical relative humidity + //--------------------------- + zrhc = (*yrecldp).ramid; + zsigk = + pap[jl + klon*(jk + klev*ibl)] / paph[jl + klon*(klev + (klev + 1)*ibl)]; + // Increase RHcrit to 1.0 towards the surface (eta>0.8) + if (zsigk > (double) 0.8) { + zrhc = (*yrecldp).ramid + ((double) 1.0 - (*yrecldp).ramid)*(pow(((zsigk - + (double) 0.8) / (double) 0.2), 2)); + } + + // Commented out for CY37R1 to reduce humidity in high trop and strat + // ! Increase RHcrit to 1.0 towards the tropopause (trop-0.2) and above + // ZBOTT=ZTRPAUS(JL)+0.2_JPRB + // IF(ZSIGK < ZBOTT) THEN + // ZRHC=RAMID+(1.0_JPRB-RAMID)*MIN(((ZBOTT-ZSIGK)/0.2_JPRB)**2,1.0_JPRB) + // ENDIF + + //--------------------------- + // Supersaturation options + //--------------------------- + if ((*yrecldp).nssopt == 0) { + // No scheme + zqe = (zqx[4] - za[jk_i]*zqsice) / fmax(zepsec, (double) 1.0 - + za[jk_i]); + zqe = fmax((double) 0.0, zqe); + } else if ((*yrecldp).nssopt == 1) { + // Tompkins + zqe = (zqx[4] - za[jk_i]*zqsice) / fmax(zepsec, (double) 1.0 - + za[jk_i]); + zqe = fmax((double) 0.0, zqe); + } else if ((*yrecldp).nssopt == 2) { + // Lohmann and Karcher + zqe = zqx[4]; + } else if ((*yrecldp).nssopt == 3) { + // Gierens + zqe = zqx[4] + zli; + } + + if (ztp1[jk_i] >= rtt || (*yrecldp).nssopt == 0) { + // No ice supersaturation allowed + zfac = (double) 1.0; + } else { + // Ice supersaturation + zfac = zfokoop; + } + + if (zqe >= zrhc*zqsice*zfac && zqe < zqsice*zfac) { + // note: not **2 on 1-a term if ZQE is used. + // Added correction term ZFAC to numerator 15/03/2010 + zacond = -((double) 1.0 - za[jk_i])*zfac*zdqs / fmax((double) + 2.0*(zfac*zqsice - zqe), zepsec); + + zacond = fmin(zacond, (double) 1.0 - za[jk_i]); //PUT THE LIMITER BACK + + // Linear term: + // Added correction term ZFAC 15/03/2010 + zlcond2 = -zfac*zdqs*(double) 0.5*zacond; //mine linear + + // new limiter formulation + zzdl = (double) 2.0*(zfac*zqsice - zqe) / fmax(zepsec, (double) 1.0 - za[jk_i]); + // Added correction term ZFAC 15/03/2010 + if (zfac*zdqs < -zzdl) { + // ZLCONDLIM=(ZA(JL,JK)-1.0_JPRB)*ZDQS(JL)-ZQSICE(JL,JK)+ZQX(JL,JK,NCLDQV) + zlcondlim = + (za[jk_i] - (double) 1.0)*zfac*zdqs - zfac*zqsice + zqx[4]; + zlcond2 = fmin(zlcond2, zlcondlim); + } + zlcond2 = fmax(zlcond2, (double) 0.0); + + if (zlcond2 < (*yrecldp).rlmin || ((double) 1.0 - za[jk_i]) < zepsec + ) { + zlcond2 = (double) 0.0; + zacond = (double) 0.0; + } + if (zlcond2 == (double) 0.0) { + zacond = (double) 0.0; + } + + // Large-scale generation is LINEAR in A and LINEAR in L + zsolac = zsolac + zacond; //linear + + //------------------------------------------------------------------------ + // All increase goes into liquid unless so cold cloud homogeneously freezes + // Include new liquid formation in first guess value, otherwise liquid + // remains at cold temperatures until next timestep. + //------------------------------------------------------------------------ + if (ztp1[jk_i] > (*yrecldp).rthomo) { + zsolqa[0 + 5*(4)] = zsolqa[0 + 5*(4)] + zlcond2; + zsolqa[4 + 5*(0)] = zsolqa[4 + 5*(0)] - zlcond2; + zqxfg[0] = zqxfg[0] + zlcond2; + } else { + // homogeneous freezing + zsolqa[1 + 5*(4)] = zsolqa[1 + 5*(4)] + zlcond2; + zsolqa[4 + 5*(1)] = zsolqa[4 + 5*(1)] - zlcond2; + zqxfg[1] = zqxfg[1] + zlcond2; + } + + } + } + + //---------------------------------------------------------------------- + // 3.7 Growth of ice by vapour deposition + //---------------------------------------------------------------------- + // Following Rotstayn et al. 2001: + // does not use the ice nuclei number from cloudaer.F90 + // but rather a simple Meyers et al. 1992 form based on the + // supersaturation and assuming clouds are saturated with + // respect to liquid water (well mixed), (or Koop adjustment) + // Growth considered as sink of liquid water if present so + // Bergeron-Findeisen adjustment in autoconversion term no longer needed + //---------------------------------------------------------------------- + + //-------------------------------------------------------- + //- + //- Ice deposition following Rotstayn et al. (2001) + //- (monodisperse ice particle size distribution) + //- + //-------------------------------------------------------- + if (idepice == 1) { + + + //-------------------------------------------------------------- + // Calculate distance from cloud top + // defined by cloudy layer below a layer with cloud frac <0.01 + // ZDZ = ZDP(JL)/(ZRHO(JL)*rg) + //-------------------------------------------------------------- + + if (za[jk_im1] < (*yrecldp).rcldtopcf && za[jk_i] >= (*yrecldp) + .rcldtopcf) { + zcldtopdist = (double) 0.0; + } else { + zcldtopdist = zcldtopdist + zdp / (zrho*rg); + } + + //-------------------------------------------------------------- + // only treat depositional growth if liquid present. due to fact + // that can not model ice growth from vapour without additional + // in-cloud water vapour variable + //-------------------------------------------------------------- + if (ztp1[jk_i] < rtt && zqxfg[0] > (*yrecldp).rlmin) { + // T<273K + + zvpice = (((double)(r2es*exp((r3ies*(ztp1[jk_i] - rtt))/(ztp1[jk_i] - r4ies))))*rv) / rd; + zvpliq = zvpice*zfokoop; + zicenuclei = (double) 1000.0*exp((double) 12.96*(zvpliq - zvpice) / zvpliq + - (double) 0.639); + + //------------------------------------------------ + // 2.4e-2 is conductivity of air + // 8.8 = 700**1/3 = density of ice to the third + //------------------------------------------------ + zadd = rlstt*(rlstt / (rv*ztp1[jk_i]) - (double) 1.0) / ((double) + 2.4E-2*ztp1[jk_i]); + zbdd = rv*ztp1[jk_i]*pap[jl + klon*(jk + klev*ibl)] / ((double) + 2.21*zvpice); + zcvds = (double) 7.8*(pow((zicenuclei / zrho), (double) 0.666))*(zvpliq - + zvpice) / ((double) 8.87*(zadd + zbdd)*zvpice); + + //----------------------------------------------------- + // RICEINIT=1.E-12_JPRB is initial mass of ice particle + //----------------------------------------------------- + zice0 = fmax(zicecld, zicenuclei*(*yrecldp).riceinit / zrho); + + //------------------ + // new value of ice: + //------------------ + zinew = pow(((double) 0.666*zcvds*ptsphy + (pow(zice0, (double) 0.666))), + (double) 1.5); + + //--------------------------- + // grid-mean deposition rate: + //--------------------------- + zdepos = fmax(za[jk_i]*(zinew - zice0), (double) 0.0); + + //-------------------------------------------------------------------- + // Limit deposition to liquid water amount + // If liquid is all frozen, ice would use up reservoir of water + // vapour in excess of ice saturation mixing ratio - However this + // can not be represented without a in-cloud humidity variable. Using + // the grid-mean humidity would imply a large artificial horizontal + // flux from the clear sky to the cloudy area. We thus rely on the + // supersaturation check to clean up any remaining supersaturation + //-------------------------------------------------------------------- + zdepos = fmin(zdepos, zqxfg[0]); // limit to liquid water amount + + //-------------------------------------------------------------------- + // At top of cloud, reduce deposition rate near cloud top to account for + // small scale turbulent processes, limited ice nucleation and ice fallout + //-------------------------------------------------------------------- + // ZDEPOS = ZDEPOS*MIN(RDEPLIQREFRATE+ZCLDTOPDIST(JL)/RDEPLIQREFDEPTH,1.0_JPRB) + // Change to include dependence on ice nuclei concentration + // to increase deposition rate with decreasing temperatures + zinfactor = fmin(zicenuclei / (double) 15000., (double) 1.0); + zdepos = zdepos*fmin(zinfactor + ((double) 1.0 - zinfactor)*((*yrecldp) + .rdepliqrefrate + zcldtopdist / (*yrecldp).rdepliqrefdepth), (double) 1.0 + ); + + //-------------- + // add to matrix + //-------------- + zsolqa[1 + 5*(0)] = zsolqa[1 + 5*(0)] + zdepos; + zsolqa[0 + 5*(1)] = zsolqa[0 + 5*(1)] - zdepos; + zqxfg[1] = zqxfg[1] + zdepos; + zqxfg[0] = zqxfg[0] - zdepos; + + } + + //-------------------------------------------------------- + //- + //- Ice deposition assuming ice PSD + //- + //-------------------------------------------------------- + } else if (idepice == 2) { + + + //-------------------------------------------------------------- + // Calculate distance from cloud top + // defined by cloudy layer below a layer with cloud frac <0.01 + // ZDZ = ZDP(JL)/(ZRHO(JL)*rg) + //-------------------------------------------------------------- + + if (za[jk_im1] < (*yrecldp).rcldtopcf && za[jk_i] >= (*yrecldp) + .rcldtopcf) { + zcldtopdist = (double) 0.0; + } else { + zcldtopdist = zcldtopdist + zdp / (zrho*rg); + } + + //-------------------------------------------------------------- + // only treat depositional growth if liquid present. due to fact + // that can not model ice growth from vapour without additional + // in-cloud water vapour variable + //-------------------------------------------------------------- + if (ztp1[jk_i] < rtt && zqxfg[0] > (*yrecldp).rlmin) { + // T<273K + + zvpice = (((double)(r2es*exp((r3ies*(ztp1[jk_i] - rtt))/(ztp1[jk_i] - r4ies))))*rv) / rd; + zvpliq = zvpice*zfokoop; + zicenuclei = (double) 1000.0*exp((double) 12.96*(zvpliq - zvpice) / zvpliq + - (double) 0.639); + + //----------------------------------------------------- + // RICEINIT=1.E-12_JPRB is initial mass of ice particle + //----------------------------------------------------- + zice0 = fmax(zicecld, zicenuclei*(*yrecldp).riceinit / zrho); + + // Particle size distribution + ztcg = (double) 1.0; + zfacx1i = (double) 1.0; + + zaplusb = (*yrecldp).rcl_apb1*zvpice - (*yrecldp).rcl_apb2*zvpice*ztp1[jk_i] + + pap[jl + klon*(jk + klev*ibl)]*(*yrecldp).rcl_apb3*(pow(ztp1[jk_i], (double) 3.)); + zcorrfac = pow(((double) 1.0 / zrho), (double) 0.5); + zcorrfac2 = (pow((ztp1[jk_i] / (double) 273.0), (double) 1.5)) + *((double) 393.0 / (ztp1[jk_i] + (double) 120.0)); + + zpr02 = zrho*zice0*(*yrecldp).rcl_const1i / (ztcg*zfacx1i); + + zterm1 = (zvpliq - zvpice)*(pow(ztp1[jk_i], (double) 2.0)) + *zvpice*zcorrfac2*ztcg*(*yrecldp).rcl_const2i*zfacx1i / + (zrho*zaplusb*zvpice); + zterm2 = (double) 0.65*(*yrecldp).rcl_const6i*(pow(zpr02, (*yrecldp) + .rcl_const4i)) + (*yrecldp).rcl_const3i*(pow(zcorrfac, (double) 0.5)) + *(pow(zrho, (double) 0.5))*(pow(zpr02, (*yrecldp).rcl_const5i)) / + (pow(zcorrfac2, (double) 0.5)); + + zdepos = fmax(za[jk_i]*zterm1*zterm2*ptsphy, (double) 0.0); + + //-------------------------------------------------------------------- + // Limit deposition to liquid water amount + // If liquid is all frozen, ice would use up reservoir of water + // vapour in excess of ice saturation mixing ratio - However this + // can not be represented without a in-cloud humidity variable. Using + // the grid-mean humidity would imply a large artificial horizontal + // flux from the clear sky to the cloudy area. We thus rely on the + // supersaturation check to clean up any remaining supersaturation + //-------------------------------------------------------------------- + zdepos = fmin(zdepos, zqxfg[0]); // limit to liquid water amount + + //-------------------------------------------------------------------- + // At top of cloud, reduce deposition rate near cloud top to account for + // small scale turbulent processes, limited ice nucleation and ice fallout + //-------------------------------------------------------------------- + // Change to include dependence on ice nuclei concentration + // to increase deposition rate with decreasing temperatures + zinfactor = fmin(zicenuclei / (double) 15000., (double) 1.0); + zdepos = zdepos*fmin(zinfactor + ((double) 1.0 - zinfactor)*((*yrecldp) + .rdepliqrefrate + zcldtopdist / (*yrecldp).rdepliqrefdepth), (double) 1.0 + ); + + //-------------- + // add to matrix + //-------------- + zsolqa[1 + 5*(0)] = zsolqa[1 + 5*(0)] + zdepos; + zsolqa[0 + 5*(1)] = zsolqa[0 + 5*(1)] - zdepos; + zqxfg[1] = zqxfg[1] + zdepos; + zqxfg[0] = zqxfg[0] - zdepos; + } + + } + // on IDEPICE + + //###################################################################### + // 4 *** PRECIPITATION PROCESSES *** + //###################################################################### + + //---------------------------------- + // revise in-cloud consensate amount + //---------------------------------- + ztmpa = (double) 1.0 / fmax(za[jk_i], zepsec); + zliqcld = zqxfg[0]*ztmpa; + zicecld = zqxfg[1]*ztmpa; + zlicld = zliqcld + zicecld; + + //---------------------------------------------------------------------- + // 4.2 SEDIMENTATION/FALLING OF *ALL* MICROPHYSICAL SPECIES + // now that rain, snow, graupel species are prognostic + // the precipitation flux can be defined directly level by level + // There is no vertical memory required from the flux variable + //---------------------------------------------------------------------- + + for (jm = 0; jm <= 5 + -1; jm += 1) { + if (llfall[jm] || jm + 1 == 2) { + //------------------------ + // source from layer above + //------------------------ + if (jk + 1 > (*yrecldp).ncldtop) { + zfallsrce[jm] = zpfplsx[jk_i + 2*jm]*zdtgdp; + zsolqa[jm + 5*jm] = zsolqa[jm + 5*jm] + zfallsrce[jm]; + zqxfg[jm] = zqxfg[jm] + zfallsrce[jm]; + // use first guess precip----------V + zqpretot = zqpretot + zqxfg[jm]; + } + //------------------------------------------------- + // sink to next layer, constant fall speed + //------------------------------------------------- + // if aerosol effect then override + // note that for T>233K this is the same as above. + if ((*yrecldp).laericesed && jm + 1 == 2) { + zre_ice = pre_ice[jl + klon*(jk + klev*ibl)]; + // The exponent value is from + // Morrison et al. JAS 2005 Appendix + zvqx[1] = (double) 0.002*(pow(zre_ice, (double) 1.0)); + } + zfall = zvqx[jm]*zrho; + //------------------------------------------------- + // modified by Heymsfield and Iaquinta JAS 2000 + //------------------------------------------------- + // ZFALL = ZFALL*((PAP(JL,JK)*RICEHI1)**(-0.178_JPRB)) & + // &*((ZTP1(JL,JK)*RICEHI2)**(-0.394_JPRB)) + + zfallsink[jm] = zdtgdp*zfall; + // Cloud budget diagnostic stored at end as implicit + // jl + } + // LLFALL + } + // jm + + //--------------------------------------------------------------- + // Precip cover overlap using MAX-RAN Overlap + // Since precipitation is now prognostic we must + // 1) apply an arbitrary minimum coverage (0.3) if precip>0 + // 2) abandon the 2-flux clr/cld treatment + // 3) Thus, since we have no memory of the clear sky precip + // fraction, we mimic the previous method by reducing + // ZCOVPTOT(JL), which has the memory, proportionally with + // the precip evaporation rate, taking cloud fraction + // into account + // #3 above leads to much smoother vertical profiles of + // precipitation fraction than the Klein-Jakob scheme which + // monotonically increases precip fraction and then resets + // it to zero in a step function once clear-sky precip reaches + // zero. + //--------------------------------------------------------------- + if (zqpretot > zepsec) { + zcovptot = (double) 1.0 - (((double) 1.0 - zcovptot)*((double) 1.0 - + fmax(za[jk_i], za[jk_im1]))) / ((double) 1.0 - fmin(za[jk_im1], (double) 1.0 - (double) 1.E-06)); // here!!! + zcovptot = fmax(zcovptot, (*yrecldp).rcovpmin); + zcovpclr = fmax((double) 0.0, zcovptot - za[jk_i]); // clear sky proportion + zraincld = zqxfg[2] / zcovptot; + zsnowcld = zqxfg[3] / zcovptot; + zcovpmax = fmax(zcovptot, zcovpmax); + } else { + zraincld = (double) 0.0; + zsnowcld = (double) 0.0; + zcovptot = (double) 0.0; // no flux - reset cover + zcovpclr = (double) 0.0; // reset clear sky proportion + zcovpmax = (double) 0.0; // reset max cover for ZZRH calc + } + + //---------------------------------------------------------------------- + // 4.3a AUTOCONVERSION TO SNOW + //---------------------------------------------------------------------- + + if (ztp1[jk_i] <= rtt) { + //----------------------------------------------------- + // Snow Autoconversion rate follow Lin et al. 1983 + //----------------------------------------------------- + if (zicecld > zepsec) { + + zzco = ptsphy*(*yrecldp).rsnowlin1*exp((*yrecldp).rsnowlin2*(ztp1[jk_i] - rtt)); + + if ((*yrecldp).laericeauto) { + zlcrit = picrit_aer[jl + klon*(jk + klev*ibl)]; + // 0.3 = N**0.333 with N=0.027 + zzco = zzco*(pow(((*yrecldp).rnice / pnice[jl + klon*(jk + klev*ibl)]), + (double) 0.333)); + } else { + zlcrit = (*yrecldp).rlcritsnow; + } + + zsnowaut = zzco*((double) 1.0 - exp(-(pow((zicecld / zlcrit), 2)))); + zsolqb[3 + 5*(1)] = zsolqb[3 + 5*(1)] + zsnowaut; + + } + } + + //---------------------------------------------------------------------- + // 4.3b AUTOCONVERSION WARM CLOUDS + // Collection and accretion will require separate treatment + // but for now we keep this simple treatment + //---------------------------------------------------------------------- + + if (zliqcld > zepsec) { + + //-------------------------------------------------------- + //- + //- Warm-rain process follow Sundqvist (1989) + //- + //-------------------------------------------------------- + if (iwarmrain == 1) { + + zzco = (*yrecldp).rkconv*ptsphy; + + if ((*yrecldp).laerliqautolsp) { + zlcrit = plcrit_aer[jl + klon*(jk + klev*ibl)]; + // 0.3 = N**0.333 with N=125 cm-3 + zzco = zzco*(pow(((*yrecldp).rccn / pccn[jl + klon*(jk + klev*ibl)]), + (double) 0.333)); + } else { + // Modify autoconversion threshold dependent on: + // land (polluted, high CCN, smaller droplets, higher threshold) + // sea (clean, low CCN, larger droplets, lower threshold) + if (plsm[jl + klon*ibl] > (double) 0.5) { + zlcrit = (*yrecldp).rclcrit_land; // land + } else { + zlcrit = (*yrecldp).rclcrit_sea; // ocean + } + } + + //------------------------------------------------------------------ + // Parameters for cloud collection by rain and snow. + // Note that with new prognostic variable it is now possible + // to REPLACE this with an explicit collection parametrization + //------------------------------------------------------------------ + zprecip = (zpfplsx[jk_i + 2*(3)] + zpfplsx[jk_i + 2*(2) + ]) / fmax(zepsec, zcovptot); + zcfpr = (double) 1.0 + (*yrecldp).rprc1*sqrt(fmax(zprecip, (double) 0.0)); + // ZCFPR=1.0_JPRB + RPRC1*SQRT(MAX(ZPRECIP,0.0_JPRB))*& + // &ZCOVPTOT(JL)/(MAX(ZA(JL,JK),ZEPSEC)) + + if ((*yrecldp).laerliqcoll) { + // 5.0 = N**0.333 with N=125 cm-3 + zcfpr = zcfpr*(pow(((*yrecldp).rccn / pccn[jl + klon*(jk + klev*ibl)]), + (double) 0.333)); + } + + zzco = zzco*zcfpr; + zlcrit = zlcrit / fmax(zcfpr, zepsec); + + if (zliqcld / zlcrit < (double) 20.0) { + // Security for exp for some compilers + zrainaut = zzco*((double) 1.0 - exp(-(pow((zliqcld / zlcrit), 2)))); + } else { + zrainaut = zzco; + } + + // rain freezes instantly + if (ztp1[jk_i] <= rtt) { + zsolqb[3 + 5*(0)] = zsolqb[3 + 5*(0)] + zrainaut; + } else { + zsolqb[2 + 5*(0)] = zsolqb[2 + 5*(0)] + zrainaut; + } + + //-------------------------------------------------------- + //- + //- Warm-rain process follow Khairoutdinov and Kogan (2000) + //- + //-------------------------------------------------------- + } else if (iwarmrain == 2) { + + if (plsm[jl + klon*ibl] > (double) 0.5) { + // land + zconst = (*yrecldp).rcl_kk_cloud_num_land; + zlcrit = (*yrecldp).rclcrit_land; + } else { + // ocean + zconst = (*yrecldp).rcl_kk_cloud_num_sea; + zlcrit = (*yrecldp).rclcrit_sea; + } + + if (zliqcld > zlcrit) { + + zrainaut = (double) 1.5*za[jk_i]*ptsphy*(*yrecldp) + .rcl_kkaau*(pow(zliqcld, (*yrecldp).rcl_kkbauq))*(pow(zconst, (*yrecldp + ).rcl_kkbaun)); + + zrainaut = fmin(zrainaut, zqxfg[0]); + if (zrainaut < zepsec) { + zrainaut = (double) 0.0; + } + + zrainacc = (double) 2.0*za[jk_i]*ptsphy*(*yrecldp) + .rcl_kkaac*(pow((zliqcld*zraincld), (*yrecldp).rcl_kkbac)); + + zrainacc = fmin(zrainacc, zqxfg[0]); + if (zrainacc < zepsec) { + zrainacc = (double) 0.0; + } + + } else { + zrainaut = (double) 0.0; + zrainacc = (double) 0.0; + } + + // If temperature < 0, then autoconversion produces snow rather than rain + // Explicit + if (ztp1[jk_i] <= rtt) { + zsolqa[3 + 5*(0)] = zsolqa[3 + 5*(0)] + zrainaut; + zsolqa[3 + 5*(0)] = zsolqa[3 + 5*(0)] + zrainacc; + zsolqa[0 + 5*(3)] = zsolqa[0 + 5*(3)] - zrainaut; + zsolqa[0 + 5*(3)] = zsolqa[0 + 5*(3)] - zrainacc; + } else { + zsolqa[2 + 5*(0)] = zsolqa[2 + 5*(0)] + zrainaut; + zsolqa[2 + 5*(0)] = zsolqa[2 + 5*(0)] + zrainacc; + zsolqa[0 + 5*(2)] = zsolqa[0 + 5*(2)] - zrainaut; + zsolqa[0 + 5*(2)] = zsolqa[0 + 5*(2)] - zrainacc; + } + + } + // on IWARMRAIN + + } + // on ZLIQCLD > ZEPSEC + + + //---------------------------------------------------------------------- + // RIMING - COLLECTION OF CLOUD LIQUID DROPS BY SNOW AND ICE + // only active if T<0degC and supercooled liquid water is present + // AND if not Sundquist autoconversion (as this includes riming) + //---------------------------------------------------------------------- + if (iwarmrain > 1) { + + if (ztp1[jk_i] <= rtt && zliqcld > zepsec) { + + // Fallspeed air density correction + zfallcorr = pow(((*yrecldp).rdensref / zrho), (double) 0.4); + + //------------------------------------------------------------------ + // Riming of snow by cloud water - implicit in lwc + //------------------------------------------------------------------ + if (zsnowcld > zepsec && zcovptot > (double) 0.01) { + + // Calculate riming term + // Factor of liq water taken out because implicit + zsnowrime = (double) 0.3*zcovptot*ptsphy*(*yrecldp) + .rcl_const7s*zfallcorr*(pow((zrho*zsnowcld*(*yrecldp).rcl_const1s), + (*yrecldp).rcl_const8s)); + + // Limit snow riming term + zsnowrime = fmin(zsnowrime, (double) 1.0); + + zsolqb[3 + 5*(0)] = zsolqb[3 + 5*(0)] + zsnowrime; + + } + + //------------------------------------------------------------------ + // Riming of ice by cloud water - implicit in lwc + // NOT YET ACTIVE + //------------------------------------------------------------------ + // IF (ZICECLD(JL)>ZEPSEC .AND. ZA(JL,JK)>0.01_JPRB) THEN + // + // ! Calculate riming term + // ! Factor of liq water taken out because implicit + // ZSNOWRIME(JL) = ZA(JL,JK)*PTSPHY*RCL_CONST7S*ZFALLCORR & + // & *(ZRHO(JL)*ZICECLD(JL)*RCL_CONST1S)**RCL_CONST8S + // + // ! Limit ice riming term + // ZSNOWRIME(JL)=MIN(ZSNOWRIME(JL),1.0_JPRB) + // + // ZSOLQB(JL,NCLDQI,NCLDQL) = ZSOLQB(JL,NCLDQI,NCLDQL) + ZSNOWRIME(JL) + // + // ENDIF + } + + } + // on IWARMRAIN > 1 + + + //---------------------------------------------------------------------- + // 4.4a MELTING OF SNOW and ICE + // with new implicit solver this also has to treat snow or ice + // precipitating from the level above... i.e. local ice AND flux. + // in situ ice and snow: could arise from LS advection or warming + // falling ice and snow: arrives by precipitation process + //---------------------------------------------------------------------- + + zicetot = zqxfg[1] + zqxfg[3]; + zmeltmax = (double) 0.0; + + // If there are frozen hydrometeors present and dry-bulb temperature > 0degC + if (zicetot > zepsec && ztp1[jk_i] > rtt) { + + // Calculate subsaturation + zsubsat = fmax(zqsice - zqx[4], (double) 0.0); + + // Calculate difference between dry-bulb (ZTP1) and the temperature + // at which the wet-bulb=0degC (rtt-ZSUBSAT*....) using an approx. + // Melting only occurs if the wet-bulb temperature >0 + // i.e. warming of ice particle due to melting > cooling + // due to evaporation. + ztdmtw0 = ztp1[jk_i] - rtt - zsubsat*(ztw1 + ztw2*(pap[jl + klon*(jk + + klev*ibl)] - ztw3) - ztw4*(ztp1[jk_i] - ztw5)); + // Not implicit yet... + // Ensure ZCONS1 is positive so that ZMELTMAX=0 if ZTDMTW0<0 + zcons1 = + fabs(ptsphy*((double) 1.0 + (double) 0.5*ztdmtw0) / (*yrecldp).rtaumel); + zmeltmax = fmax(ztdmtw0*zcons1*zrldcp, (double) 0.0); + } + + // Loop over frozen hydrometeors (ice, snow) + for (jm = 0; jm <= 5 + -1; jm += 1) { + if (iphase[jm] == 2) { + jn = imelt[jm]; + if (zmeltmax > zepsec && zicetot > zepsec) { + // Apply melting in same proportion as frozen hydrometeor fractions + zalfa = zqxfg[jm] / zicetot; + zmelt = fmin(zqxfg[jm], zalfa*zmeltmax); + // needed in first guess + // This implies that zqpretot has to be recalculated below + // since is not conserved here if ice falls and liquid doesn't + zqxfg[jm] = zqxfg[jm] - zmelt; + zqxfg[-1 + jn] = zqxfg[-1 + jn] + zmelt; + zsolqa[-1 + jn + 5*jm] = zsolqa[-1 + jn + 5*jm] + zmelt; + zsolqa[jm + 5*(-1 + jn)] = zsolqa[jm + 5*(-1 + jn)] - zmelt; + } + } + } + + //---------------------------------------------------------------------- + // 4.4b FREEZING of RAIN + //---------------------------------------------------------------------- + + // If rain present + if (zqx[2] > zepsec) { + + if (ztp1[jk_i] <= rtt && ztp1[jk_im1] > rtt) { + // Base of melting layer/top of refreezing layer so + // store rain/snow fraction for precip type diagnosis + // If mostly rain, then supercooled rain slow to freeze + // otherwise faster to freeze (snow or ice pellets) + zqpretot = fmax(zqx[3] + zqx[2], zepsec); + prainfrac_toprfz[jl + klon*ibl] = zqx[2] / zqpretot; + if (prainfrac_toprfz[jl + klon*ibl] > 0.8) { + llrainliq = true; + } else { + llrainliq = false; + } + } + + // If temperature less than zero + if (ztp1[jk_i] < rtt) { + + if (prainfrac_toprfz[jl + klon*ibl] > 0.8) { + + // Majority of raindrops completely melted + // Refreezing is by slow heterogeneous freezing + + // Slope of rain particle size distribution + zlambda = + pow(((*yrecldp).rcl_fac1 / (zrho*zqx[2])), (*yrecldp).rcl_fac2); + + // Calculate freezing rate based on Bigg(1953) and Wisner(1972) + ztemp = (*yrecldp).rcl_fzrab*(ztp1[jk_i] - rtt); + zfrz = ptsphy*((*yrecldp).rcl_const5r / zrho)*(exp(ztemp) - (double) 1.) + *(pow(zlambda, (*yrecldp).rcl_const6r)); + zfrzmax = fmax(zfrz, (double) 0.0); + + } else { + + // Majority of raindrops only partially melted + // Refreeze with a shorter timescale (reverse of melting...for now) + + zcons1 = fabs(ptsphy*((double) 1.0 + (double) 0.5*(rtt - ztp1[jk_i]) + ) / (*yrecldp).rtaumel); + zfrzmax = fmax((rtt - ztp1[jk_i])*zcons1*zrldcp, (double) 0.0); + + } + + if (zfrzmax > zepsec) { + zfrz = fmin(zqx[2], zfrzmax); + zsolqa[3 + 5*(2)] = zsolqa[3 + 5*(2)] + zfrz; + zsolqa[2 + 5*(3)] = zsolqa[2 + 5*(3)] - zfrz; + } + } + + } + + + //---------------------------------------------------------------------- + // 4.4c FREEZING of LIQUID + //---------------------------------------------------------------------- + // not implicit yet... + zfrzmax = fmax(((*yrecldp).rthomo - ztp1[jk_i])*zrldcp, (double) 0.0); + + jm = 1; + jn = imelt[-1 + jm]; + if (zfrzmax > zepsec && zqxfg[-1 + jm] > zepsec) { + zfrz = fmin(zqxfg[-1 + jm], zfrzmax); + zsolqa[-1 + jn + 5*(-1 + jm)] = zsolqa[-1 + jn + 5*(-1 + jm)] + zfrz; + zsolqa[-1 + jm + 5*(-1 + jn)] = zsolqa[-1 + jm + 5*(-1 + jn)] - zfrz; + } + + //---------------------------------------------------------------------- + // 4.5 EVAPORATION OF RAIN/SNOW + //---------------------------------------------------------------------- + + //---------------------------------------- + // Rain evaporation scheme from Sundquist + //---------------------------------------- + if (ievaprain == 1) { + + // Rain + + + zzrh = (*yrecldp).rprecrhmax + ((double) 1.0 - (*yrecldp).rprecrhmax) + *zcovpmax / fmax(zepsec, (double) 1.0 - za[jk_i]); + zzrh = fmin(fmax(zzrh, (*yrecldp).rprecrhmax), (double) 1.0); + + zqe = (zqx[4] - za[jk_i]*zqsliq) / fmax(zepsec, (double) 1.0 - + za[jk_i]); + //--------------------------------------------- + // humidity in moistest ZCOVPCLR part of domain + //--------------------------------------------- + zqe = fmax((double) 0.0, fmin(zqe, zqsliq)); + llo1 = zcovpclr > zepsec && zqxfg[2] > zepsec && zqe < zzrh*zqsliq; + + if (llo1) { + // note: zpreclr is a rain flux + zpreclr = zqxfg[2]*zcovpclr / copysign(fmax(fabs(zcovptot*zdtgdp), + zepsilon), zcovptot*zdtgdp); + + //-------------------------------------- + // actual microphysics formula in zbeta + //-------------------------------------- + + zbeta1 = sqrt(pap[jl + klon*(jk + klev*ibl)] / paph[jl + klon*(klev + (klev + + 1)*ibl)]) / (*yrecldp).rvrfactor*zpreclr / fmax(zcovpclr, zepsec); + + zbeta = rg*(*yrecldp).rpecons*(double) 0.5*(pow(zbeta1, (double) 0.5777)); + + zdenom = (double) 1.0 + zbeta*ptsphy*zcorqsliq; + zdpr = zcovpclr*zbeta*(zqsliq - zqe) / zdenom*zdp*zrg_r; + zdpevap = zdpr*zdtgdp; + + //--------------------------------------------------------- + // add evaporation term to explicit sink. + // this has to be explicit since if treated in the implicit + // term evaporation can not reduce rain to zero and model + // produces small amounts of rainfall everywhere. + //--------------------------------------------------------- + + // Evaporate rain + zevap = fmin(zdpevap, zqxfg[2]); + + zsolqa[4 + 5*(2)] = zsolqa[4 + 5*(2)] + zevap; + zsolqa[2 + 5*(4)] = zsolqa[2 + 5*(4)] - zevap; + + //------------------------------------------------------------- + // Reduce the total precip coverage proportional to evaporation + // to mimic the previous scheme which had a diagnostic + // 2-flux treatment, abandoned due to the new prognostic precip + //------------------------------------------------------------- + zcovptot = fmax((*yrecldp).rcovpmin, zcovptot - fmax((double) 0.0, + (zcovptot - za[jk_i])*zevap / zqxfg[2])); + + // Update fg field + zqxfg[2] = zqxfg[2] - zevap; + + } + + + //--------------------------------------------------------- + // Rain evaporation scheme based on Abel and Boutle (2013) + //--------------------------------------------------------- + } else if (ievaprain == 2) { + + + //----------------------------------------------------------------------- + // Calculate relative humidity limit for rain evaporation + // to avoid cloud formation and saturation of the grid box + //----------------------------------------------------------------------- + // Limit RH for rain evaporation dependent on precipitation fraction + zzrh = (*yrecldp).rprecrhmax + ((double) 1.0 - (*yrecldp).rprecrhmax) + *zcovpmax / fmax(zepsec, (double) 1.0 - za[jk_i]); + zzrh = fmin(fmax(zzrh, (*yrecldp).rprecrhmax), (double) 1.0); + + // Critical relative humidity + //ZRHC=RAMID + //ZSIGK=PAP(JL,JK)/PAPH(JL,KLEV+1) + // Increase RHcrit to 1.0 towards the surface (eta>0.8) + //IF(ZSIGK > 0.8_JPRB) THEN + // ZRHC=RAMID+(1.0_JPRB-RAMID)*((ZSIGK-0.8_JPRB)/0.2_JPRB)**2 + //ENDIF + //ZZRH = MIN(ZRHC,ZZRH) + + // Further limit RH for rain evaporation to 80% (RHcrit in free troposphere) + zzrh = fmin((double) 0.8, zzrh); + + zqe = fmax((double) 0.0, fmin(zqx[4], zqsliq)); + + llo1 = zcovpclr > zepsec && zqxfg[2] > zepsec && zqe < zzrh*zqsliq; + + if (llo1) { + + //------------------------------------------- + // Abel and Boutle (2012) evaporation + //------------------------------------------- + // Calculate local precipitation (kg/kg) + zpreclr = zqxfg[2] / zcovptot; + + // Fallspeed air density correction + zfallcorr = pow(((*yrecldp).rdensref / zrho), 0.4); + + // Saturation vapour pressure with respect to liquid phase + zesatliq = rv / rd*((double)(r2es*exp((r3les*(ztp1[jk_i] - rtt))/(ztp1[jk_i] - r4les)))); + + // Slope of particle size distribution + zlambda = pow(((*yrecldp).rcl_fac1 / (zrho*zpreclr)), (*yrecldp).rcl_fac2); // ZPRECLR=kg/kg + + zevap_denom = (*yrecldp).rcl_cdenom1*zesatliq - (*yrecldp) + .rcl_cdenom2*ztp1[jk_i]*zesatliq + (*yrecldp) + .rcl_cdenom3*(pow(ztp1[jk_i], (double) 3.))*pap[jl + klon*(jk + + klev*ibl)]; + + // Temperature dependent conductivity + zcorr2 = (pow((ztp1[jk_i] / (double) 273.), (double) 1.5))*(double) + 393. / (ztp1[jk_i] + (double) 120.); + zka = (*yrecldp).rcl_ka273*zcorr2; + + zsubsat = fmax(zzrh*zqsliq - zqe, (double) 0.0); + + zbeta = ((double) 0.5 / zqsliq)*(pow(ztp1[jk_i], (double) 2.)) + *zesatliq*(*yrecldp).rcl_const1r*(zcorr2 / zevap_denom)*((double) 0.78 / + (pow(zlambda, (*yrecldp).rcl_const4r)) + (*yrecldp) + .rcl_const2r*(pow((zrho*zfallcorr), (double) 0.5)) / ((pow(zcorr2, + (double) 0.5))*(pow(zlambda, (*yrecldp).rcl_const3r)))); + + zdenom = (double) 1.0 + zbeta*ptsphy; //*ZCORQSLIQ(JL) + zdpevap = zcovpclr*zbeta*ptsphy*zsubsat / zdenom; + + //--------------------------------------------------------- + // Add evaporation term to explicit sink. + // this has to be explicit since if treated in the implicit + // term evaporation can not reduce rain to zero and model + // produces small amounts of rainfall everywhere. + //--------------------------------------------------------- + + // Limit rain evaporation + zevap = fmin(zdpevap, zqxfg[2]); + + zsolqa[4 + 5*(2)] = zsolqa[4 + 5*(2)] + zevap; + zsolqa[2 + 5*(4)] = zsolqa[2 + 5*(4)] - zevap; + + //------------------------------------------------------------- + // Reduce the total precip coverage proportional to evaporation + // to mimic the previous scheme which had a diagnostic + // 2-flux treatment, abandoned due to the new prognostic precip + //------------------------------------------------------------- + zcovptot = fmax((*yrecldp).rcovpmin, zcovptot - fmax((double) 0.0, + (zcovptot - za[jk_i])*zevap / zqxfg[2])); + + // Update fg field + zqxfg[2] = zqxfg[2] - zevap; + + } + + } + // on IEVAPRAIN + + //---------------------------------------------------------------------- + // 4.5 EVAPORATION OF SNOW + //---------------------------------------------------------------------- + // Snow + if (ievapsnow == 1) { + + zzrh = (*yrecldp).rprecrhmax + ((double) 1.0 - (*yrecldp).rprecrhmax) + *zcovpmax / fmax(zepsec, (double) 1.0 - za[jk_i]); + zzrh = fmin(fmax(zzrh, (*yrecldp).rprecrhmax), (double) 1.0); + zqe = (zqx[4] - za[jk_i]*zqsice) / fmax(zepsec, (double) 1.0 - + za[jk_i]); + + //--------------------------------------------- + // humidity in moistest ZCOVPCLR part of domain + //--------------------------------------------- + zqe = fmax((double) 0.0, fmin(zqe, zqsice)); + llo1 = zcovpclr > zepsec && zqxfg[3] > zepsec && zqe < zzrh*zqsice; + + if (llo1) { + // note: zpreclr is a rain flux a + zpreclr = zqxfg[3]*zcovpclr / copysign(fmax(fabs(zcovptot*zdtgdp), + zepsilon), zcovptot*zdtgdp); + + //-------------------------------------- + // actual microphysics formula in zbeta + //-------------------------------------- + + zbeta1 = sqrt(pap[jl + klon*(jk + klev*ibl)] / paph[jl + klon*(klev + (klev + + 1)*ibl)]) / (*yrecldp).rvrfactor*zpreclr / fmax(zcovpclr, zepsec); + + zbeta = rg*(*yrecldp).rpecons*(pow(zbeta1, (double) 0.5777)); + + zdenom = (double) 1.0 + zbeta*ptsphy*zcorqsice; + zdpr = zcovpclr*zbeta*(zqsice - zqe) / zdenom*zdp*zrg_r; + zdpevap = zdpr*zdtgdp; + + //--------------------------------------------------------- + // add evaporation term to explicit sink. + // this has to be explicit since if treated in the implicit + // term evaporation can not reduce snow to zero and model + // produces small amounts of snowfall everywhere. + //--------------------------------------------------------- + + // Evaporate snow + zevap = fmin(zdpevap, zqxfg[3]); + + zsolqa[4 + 5*(3)] = zsolqa[4 + 5*(3)] + zevap; + zsolqa[3 + 5*(4)] = zsolqa[3 + 5*(4)] - zevap; + + //------------------------------------------------------------- + // Reduce the total precip coverage proportional to evaporation + // to mimic the previous scheme which had a diagnostic + // 2-flux treatment, abandoned due to the new prognostic precip + //------------------------------------------------------------- + zcovptot = fmax((*yrecldp).rcovpmin, zcovptot - fmax((double) 0.0, + (zcovptot - za[jk_i])*zevap / zqxfg[3])); + + //Update first guess field + zqxfg[3] = zqxfg[3] - zevap; + + } + //--------------------------------------------------------- + } else if (ievapsnow == 2) { + + + + //----------------------------------------------------------------------- + // Calculate relative humidity limit for snow evaporation + //----------------------------------------------------------------------- + zzrh = (*yrecldp).rprecrhmax + ((double) 1.0 - (*yrecldp).rprecrhmax) + *zcovpmax / fmax(zepsec, (double) 1.0 - za[jk_i]); + zzrh = fmin(fmax(zzrh, (*yrecldp).rprecrhmax), (double) 1.0); + zqe = (zqx[4] - za[jk_i]*zqsice) / fmax(zepsec, (double) 1.0 - + za[jk_i]); + + //--------------------------------------------- + // humidity in moistest ZCOVPCLR part of domain + //--------------------------------------------- + zqe = fmax((double) 0.0, fmin(zqe, zqsice)); + llo1 = zcovpclr > zepsec && zqx[3] > zepsec && zqe < zzrh*zqsice; + + if (llo1) { + + // Calculate local precipitation (kg/kg) + zpreclr = zqx[3] / zcovptot; + zvpice = ((double)(r2es*exp((r3ies*(ztp1[jk_i] - rtt))/(ztp1[jk_i] - r4ies))))*rv / rd; + + // Particle size distribution + // ZTCG increases Ni with colder temperatures - essentially a + // Fletcher or Meyers scheme? + ztcg = (double) 1.0; //v1 EXP(RCL_X3I*(273.15_JPRB-ZTP1(JL,JK))/8.18_JPRB) + // ZFACX1I modification is based on Andrew Barrett's results + zfacx1s = (double) 1.0; //v1 (ZICE0/1.E-5_JPRB)**0.627_JPRB + + zaplusb = (*yrecldp).rcl_apb1*zvpice - (*yrecldp).rcl_apb2*zvpice*ztp1[jk_i] + + pap[jl + klon*(jk + klev*ibl)]*(*yrecldp).rcl_apb3*(pow(ztp1[jk_i], 3)); + zcorrfac = pow((1.0 / zrho), 0.5); + zcorrfac2 = + (pow((ztp1[jk_i] / 273.0), 1.5))*(393.0 / (ztp1[jk_i] + 120.0)) + ; + + zpr02 = zrho*zpreclr*(*yrecldp).rcl_const1s / (ztcg*zfacx1s); + + zterm1 = (zqsice - zqe)*(pow(ztp1[jk_i], 2)) + *zvpice*zcorrfac2*ztcg*(*yrecldp).rcl_const2s*zfacx1s / + (zrho*zaplusb*zqsice); + zterm2 = 0.65*(*yrecldp).rcl_const6s*(pow(zpr02, (*yrecldp).rcl_const4s)) + + (*yrecldp).rcl_const3s*(pow(zcorrfac, 0.5))*(pow(zrho, 0.5))*(pow(zpr02, + (*yrecldp).rcl_const5s)) / (pow(zcorrfac2, 0.5)); + + zdpevap = fmax(zcovpclr*zterm1*zterm2*ptsphy, (double) 0.0); + + //-------------------------------------------------------------------- + // Limit evaporation to snow amount + //-------------------------------------------------------------------- + zevap = fmin(zdpevap, zevaplimice); + zevap = fmin(zevap, zqx[3]); + + + zsolqa[4 + 5*(3)] = zsolqa[4 + 5*(3)] + zevap; + zsolqa[3 + 5*(4)] = zsolqa[3 + 5*(4)] - zevap; + + //------------------------------------------------------------- + // Reduce the total precip coverage proportional to evaporation + // to mimic the previous scheme which had a diagnostic + // 2-flux treatment, abandoned due to the new prognostic precip + //------------------------------------------------------------- + zcovptot = fmax((*yrecldp).rcovpmin, zcovptot - fmax((double) 0.0, + (zcovptot - za[jk_i])*zevap / zqx[3])); + + //Update first guess field + zqxfg[3] = zqxfg[3] - zevap; + + } + + } + // on IEVAPSNOW + + //-------------------------------------- + // Evaporate small precipitation amounts + //-------------------------------------- + for (jm = 0; jm <= 5 + -1; jm += 1) { + if (llfall[jm]) { + if (zqxfg[jm] < (*yrecldp).rlmin) { + zsolqa[4 + 5*jm] = zsolqa[4 + 5*jm] + zqxfg[jm]; + zsolqa[jm + 5*(4)] = zsolqa[jm + 5*(4)] - zqxfg[jm]; + } + } + } + + //###################################################################### + // 5.0 *** SOLVERS FOR A AND L *** + // now use an implicit solution rather than exact solution + // solver is forward in time, upstream difference for advection + //###################################################################### + + //--------------------------- + // 5.1 solver for cloud cover + //--------------------------- + zanew = (za[jk_i] + zsolac) / ((double) 1.0 + zsolab); + zanew = fmin(zanew, (double) 1.0); + if (zanew < (*yrecldp).ramin) { + zanew = (double) 0.0; + } + zda = zanew - zaorig; + //--------------------------------- + // variables needed for next level + //--------------------------------- + zanewm1 = zanew; + + //-------------------------------- + // 5.2 solver for the microphysics + //-------------------------------- + + //-------------------------------------------------------------- + // Truncate explicit sinks to avoid negatives + // Note: Species are treated in the order in which they run out + // since the clipping will alter the balance for the other vars + //-------------------------------------------------------------- + + for (jm = 0; jm <= 5 + -1; jm += 1) { + for (jn = 0; jn <= 5 + -1; jn += 1) { + llindex3[jn + 5*jm] = false; + } + zsinksum[jm] = (double) 0.0; + } + + //---------------------------- + // collect sink terms and mark + //---------------------------- + for (jm = 0; jm <= 5 + -1; jm += 1) { + for (jn = 0; jn <= 5 + -1; jn += 1) { + zsinksum[jm] = zsinksum[jm] - zsolqa[jm + 5*jn]; // +ve total is bad + } + } + + //--------------------------------------- + // calculate overshoot and scaling factor + //--------------------------------------- + for (jm = 0; jm <= 5 + -1; jm += 1) { + zmax = fmax(zqx[jm], zepsec); + zrat = fmax(zsinksum[jm], zmax); + zratio[jm] = zmax / zrat; + } + + //-------------------------------------------- + // scale the sink terms, in the correct order, + // recalculating the scale factor each time + //-------------------------------------------- + for (jm = 0; jm <= 5 + -1; jm += 1) { + zsinksum[jm] = (double) 0.0; + } + + //---------------- + // recalculate sum + //---------------- + for (jm = 0; jm <= 5 + -1; jm += 1) { + psum_solqa = 0.0; + for (jn = 0; jn <= 5 + -1; jn += 1) { + psum_solqa = psum_solqa + zsolqa[jm + 5*jn]; + } + // ZSINKSUM(JL,JM)=ZSINKSUM(JL,JM)-SUM(ZSOLQA(JL,JM,1:NCLV)) + zsinksum[jm] = zsinksum[jm] - psum_solqa; + //--------------------------- + // recalculate scaling factor + //--------------------------- + zmm = fmax(zqx[jm], zepsec); + zrr = fmax(zsinksum[jm], zmm); + zratio[jm] = zmm / zrr; + //------ + // scale + //------ + zzratio = zratio[jm]; + //DIR$ IVDEP + //DIR$ PREFERVECTOR + for (jn = 0; jn <= 5 + -1; jn += 1) { + if (zsolqa[jm + 5*jn] < (double) 0.0) { + zsolqa[jm + 5*jn] = zsolqa[jm + 5*jn]*zzratio; + zsolqa[jn + 5*jm] = zsolqa[jn + 5*jm]*zzratio; + } + } + } + + //-------------------------------------------------------------- + // 5.2.2 Solver + //------------------------ + + //------------------------ + // set the LHS of equation + //------------------------ + for (jm = 0; jm <= 5 + -1; jm += 1) { + for (jn = 0; jn <= 5 + -1; jn += 1) { + //---------------------------------------------- + // diagonals: microphysical sink terms+transport + //---------------------------------------------- + if (jn + 1 == jm + 1) { + zqlhs[jn + 5*jm] = (double) 1.0 + zfallsink[jm]; + for (jo = 0; jo <= 5 + -1; jo += 1) { + zqlhs[jn + 5*jm] = zqlhs[jn + 5*jm] + zsolqb[jo + 5*jn]; + } + //------------------------------------------ + // non-diagonals: microphysical source terms + //------------------------------------------ + } else { + zqlhs[jn + 5*jm] = -zsolqb[jn + 5*jm]; // here is the delta T - missing from doc. + } + } + } + + //------------------------ + // set the RHS of equation + //------------------------ + for (jm = 0; jm <= 5 + -1; jm += 1) { + //--------------------------------- + // sum the explicit source and sink + //--------------------------------- + zexplicit = (double) 0.0; + for (jn = 0; jn <= 5 + -1; jn += 1) { + zexplicit = zexplicit + zsolqa[jm + 5*jn]; // sum over middle index + } + zqxn[jm] = zqx[jm] + zexplicit; + } + + //----------------------------------- + // *** solve by LU decomposition: *** + //----------------------------------- + + // Note: This fast way of solving NCLVxNCLV system + // assumes a good behaviour (i.e. non-zero diagonal + // terms with comparable orders) of the matrix stored + // in ZQLHS. For the moment this is the case but + // be aware to preserve it when doing eventual + // modifications. + + // Non pivoting recursive factorization + for (jn = 0; jn <= 5 - 1 + -1; jn += 1) { + // number of steps + for (jm = jn + 1; jm <= 5 + -1; jm += 1) { + // row index + zqlhs[jm + 5*jn] = zqlhs[jm + 5*jn] / zqlhs[jn + 5*jn]; + for (ik = jn + 1; ik <= 5 + -1; ik += 1) { + // column index + zqlhs[jm + 5*ik] = zqlhs[jm + 5*ik] - zqlhs[jm + 5*jn]*zqlhs[jn + 5*ik]; + } + } + } + + // Backsubstitution + // step 1 + for (jn = 1; jn <= 5 + -1; jn += 1) { + for (jm = 0; jm <= jn + 1 - 1 + -1; jm += 1) { + zqxn[jn] = zqxn[jn] - zqlhs[jn + 5*jm]*zqxn[jm]; + } + } + // step 2 + zqxn[4] = zqxn[4] / zqlhs[4 + 5*(4)]; + for (jn = -2 + 5; jn >= 1 + -1; jn += -1) { + for (jm = jn + 1; jm <= 5 + -1; jm += 1) { + zqxn[jn] = zqxn[jn] - zqlhs[jn + 5*jm]*zqxn[jm]; + } + zqxn[jn] = zqxn[jn] / zqlhs[jn + 5*jn]; + } + + // Ensure no small values (including negatives) remain in cloud variables nor + // precipitation rates. + // Evaporate l,i,r,s to water vapour. Latent heating taken into account below + for (jn = 0; jn <= 5 - 1 + -1; jn += 1) { + if (zqxn[jn] < zepsec) { + zqxn[4] = zqxn[4] + zqxn[jn]; + zqxn[jn] = (double) 0.0; + } + } + + //-------------------------------- + // variables needed for next level + //-------------------------------- + for (jm = 0; jm <= 5 + -1; jm += 1) { + zqxnm1[jm] = zqxn[jm]; + zqxn2d[jm] = zqxn[jm]; + } + + //------------------------------------------------------------------------ + // 5.3 Precipitation/sedimentation fluxes to next level + // diagnostic precipitation fluxes + // It is this scaled flux that must be used for source to next layer + //------------------------------------------------------------------------ + + for (jm = 0; jm <= 5 + -1; jm += 1) { + zpfplsx[jk_ip1 + 2*jm] = zfallsink[jm]*zqxn[jm]*zrdtgdp; + } + + // Ensure precipitation fraction is zero if no precipitation + zqpretot = + zpfplsx[jk_ip1 + 2*(3)] + zpfplsx[jk_ip1 + 2*(2)]; + if (zqpretot < zepsec) { + zcovptot = (double) 0.0; + } + + //###################################################################### + // 6 *** UPDATE TENDANCIES *** + //###################################################################### + + //-------------------------------- + // 6.1 Temperature and CLV budgets + //-------------------------------- + + for (jm = 0; jm <= 5 - 1 + -1; jm += 1) { + + // calculate fluxes in and out of box for conservation of TL + zfluxq[jm] = zpsupsatsrce[jm] + zconvsrce[jm] + zfallsrce[jm] - + (zfallsink[jm] + zconvsink[jm])*zqxn[jm]; + + if (iphase[jm] == 1) { + tendency_loc_t[jl + klon*(jk + klev*ibl)] = tendency_loc_t[jl + + klon*(jk + klev*ibl)] + ralvdcp*(zqxn[jm] - zqx[jm] - + zfluxq[jm])*zqtmst; + } + + if (iphase[jm] == 2) { + tendency_loc_t[jl + klon*(jk + klev*ibl)] = tendency_loc_t[jl + + klon*(jk + klev*ibl)] + ralsdcp*(zqxn[jm] - zqx[jm] - + zfluxq[jm])*zqtmst; + } + + //---------------------------------------------------------------------- + // New prognostic tendencies - ice,liquid rain,snow + // Note: CLV arrays use PCLV in calculation of tendency while humidity + // uses ZQX. This is due to clipping at start of cloudsc which + // include the tendency already in TENDENCY_LOC_T and TENDENCY_LOC_q. ZQX was reset + //---------------------------------------------------------------------- + tendency_loc_cld[jl + klon*(jk + klev*(jm + 5*ibl))] = tendency_loc_cld[jl + klon*(jk + klev*(jm + 5*ibl))] + + (zqxn[jm] - zqx0[jm])*zqtmst; + + } + + //---------------------- + // 6.2 Humidity budget + //---------------------- + tendency_loc_q[jl + klon*(jk + klev*ibl)] = tendency_loc_q[jl + + klon*(jk + klev*ibl)] + (zqxn[4] - zqx[4])*zqtmst; + + //------------------- + // 6.3 cloud cover + //----------------------- + tendency_loc_a[jl + klon*(jk + klev*ibl)] = + tendency_loc_a[jl + klon*(jk + klev*ibl)] + zda*zqtmst; + + //-------------------------------------------------- + // Copy precipitation fraction into output variable + //------------------------------------------------- + pcovptot[jl + klon*(jk + klev*ibl)] = zcovptot; + + } + } + + // on vertical level JK + //---------------------------------------------------------------------- + // END OF VERTICAL LOOP + //---------------------------------------------------------------------- + + //###################################################################### + // 8 *** FLUX/DIAGNOSTICS COMPUTATIONS *** + //###################################################################### + + //-------------------------------------------------------------------- + // Copy general precip arrays back into PFP arrays for GRIB archiving + // Add rain and liquid fluxes, ice and snow fluxes + //-------------------------------------------------------------------- + pfplsl[jl + klon*(jk + (klev + 1)*ibl)] = + zpfplsx[jk_i + 2*(2)] + zpfplsx[jk_i + 2*(0)]; + pfplsn[jl + klon*(jk + (klev + 1)*ibl)] = + zpfplsx[jk_i + 2*(3)] + zpfplsx[jk_i + 2*(1)]; + + if (1 <= jk + 1 && jk + 1 <= klev) { + + zgdph_r = -zrg_r*(paph[jl + klon*(1 + jk + (klev + 1)*ibl)] - paph[jl + klon*(jk + + (klev + 1)*ibl)])*zqtmst; + pfsqlf[jl + klon*(1 + jk + (klev + 1)*ibl)] = + pfsqlf[jl + klon*(jk + (klev + 1)*ibl)]; + pfsqif[jl + klon*(1 + jk + (klev + 1)*ibl)] = + pfsqif[jl + klon*(jk + (klev + 1)*ibl)]; + pfsqrf[jl + klon*(1 + jk + (klev + 1)*ibl)] = + pfsqlf[jl + klon*(jk + (klev + 1)*ibl)]; + pfsqsf[jl + klon*(1 + jk + (klev + 1)*ibl)] = + pfsqif[jl + klon*(jk + (klev + 1)*ibl)]; + pfcqlng[jl + klon*(1 + jk + (klev + 1)*ibl)] = + pfcqlng[jl + klon*(jk + (klev + 1)*ibl)]; + pfcqnng[jl + klon*(1 + jk + (klev + 1)*ibl)] = + pfcqnng[jl + klon*(jk + (klev + 1)*ibl)]; + pfcqrng[jl + klon*(1 + jk + (klev + 1)*ibl)] = + pfcqlng[jl + klon*(jk + (klev + 1)*ibl)]; + pfcqsng[jl + klon*(1 + jk + (klev + 1)*ibl)] = + pfcqnng[jl + klon*(jk + (klev + 1)*ibl)]; + pfsqltur[jl + klon*(1 + jk + (klev + 1)*ibl)] = + pfsqltur[jl + klon*(jk + (klev + 1)*ibl)]; + pfsqitur[jl + klon*(1 + jk + (klev + 1)*ibl)] = + pfsqitur[jl + klon*(jk + (klev + 1)*ibl)]; + + zalfaw = zfoealfa; + + // Liquid , LS scheme minus detrainment + pfsqlf[jl + klon*(1 + jk + (klev + 1)*ibl)] = pfsqlf[jl + klon*(1 + jk + (klev + + 1)*ibl)] + (zqxn2d[0] - zqx0[0] + pvfl[jl + klon*(jk + klev*ibl) + ]*ptsphy - zalfaw*plude[jl + klon*(jk + klev*ibl)])*zgdph_r; + // liquid, negative numbers + pfcqlng[jl + klon*(1 + jk + (klev + 1)*ibl)] = + pfcqlng[jl + klon*(1 + jk + (klev + 1)*ibl)] + zlneg[0]*zgdph_r; + + // liquid, vertical diffusion + pfsqltur[jl + klon*(1 + jk + (klev + 1)*ibl)] = pfsqltur[jl + klon*(1 + jk + + (klev + 1)*ibl)] + pvfl[jl + klon*(jk + klev*ibl)]*ptsphy*zgdph_r; + + // Rain, LS scheme + pfsqrf[jl + klon*(1 + jk + (klev + 1)*ibl)] = pfsqrf[jl + klon*(1 + jk + (klev + + 1)*ibl)] + (zqxn2d[2] - zqx0[2])*zgdph_r; + // rain, negative numbers + pfcqrng[jl + klon*(1 + jk + (klev + 1)*ibl)] = + pfcqrng[jl + klon*(1 + jk + (klev + 1)*ibl)] + zlneg[2]*zgdph_r; + + // Ice , LS scheme minus detrainment + pfsqif[jl + klon*(1 + jk + (klev + 1)*ibl)] = pfsqif[jl + klon*(1 + jk + (klev + + 1)*ibl)] + (zqxn2d[1] - zqx0[1] + pvfi[jl + klon*(jk + klev*ibl) + ]*ptsphy - ((double) 1.0 - zalfaw)*plude[jl + klon*(jk + klev*ibl)])*zgdph_r; + // ice, negative numbers + pfcqnng[jl + klon*(1 + jk + (klev + 1)*ibl)] = + pfcqnng[jl + klon*(1 + jk + (klev + 1)*ibl)] + zlneg[1]*zgdph_r; + + // ice, vertical diffusion + pfsqitur[jl + klon*(1 + jk + (klev + 1)*ibl)] = pfsqitur[jl + klon*(1 + jk + + (klev + 1)*ibl)] + pvfi[jl + klon*(jk + klev*ibl)]*ptsphy*zgdph_r; + + // snow, LS scheme + pfsqsf[jl + klon*(1 + jk + (klev + 1)*ibl)] = pfsqsf[jl + klon*(1 + jk + (klev + + 1)*ibl)] + (zqxn2d[3] - zqx0[3])*zgdph_r; + // snow, negative numbers + pfcqsng[jl + klon*(1 + jk + (klev + 1)*ibl)] = + pfcqsng[jl + klon*(1 + jk + (klev + 1)*ibl)] + zlneg[3]*zgdph_r; + } + + //----------------------------------- + // enthalpy flux due to precipitation + //----------------------------------- + pfhpsl[jl + klon*(jk + (klev + 1)*ibl)] = + -rlvtt*pfplsl[jl + klon*(jk + (klev + 1)*ibl)]; + pfhpsn[jl + klon*(jk + (klev + 1)*ibl)] = + -rlstt*pfplsn[jl + klon*(jk + (klev + 1)*ibl)]; + } +} + diff --git a/src/cloudsc_hip/cloudsc/cloudsc_c_k_caching.h b/src/cloudsc_hip/cloudsc/cloudsc_c_k_caching.h new file mode 100644 index 00000000..e4d0364b --- /dev/null +++ b/src/cloudsc_hip/cloudsc/cloudsc_c_k_caching.h @@ -0,0 +1,44 @@ +#include "hip/hip_runtime.h" +/* + * (C) Copyright 1988- ECMWF. + * + * This software is licensed under the terms of the Apache Licence Version 2.0 + * which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. + * In applying this licence, ECMWF does not waive the privileges and immunities + * granted to it by virtue of its status as an intergovernmental organisation + * nor does it submit to any jurisdiction. + */ + +#include "hip/hip_runtime.h" +#include "yoecldp_c.h" +#include + +__global__ void __launch_bounds__(128, 1) cloudsc_c(int kidia, int kfdia, int klon, double ptsphy, + const double * __restrict__ pt, + const double * __restrict__ pq, const double * __restrict__ tendency_tmp_t, + const double * __restrict__ tendency_tmp_q, const double * __restrict__ tendency_tmp_a, + const double * __restrict__ tendency_tmp_cld, double * __restrict__ tendency_loc_t, + double * __restrict__ tendency_loc_q, double * __restrict__ tendency_loc_a, + double * __restrict__ tendency_loc_cld, const double * __restrict__ pvfa, + const double * __restrict__ pvfl, const double * __restrict__ pvfi, const double * __restrict__ pdyna, + const double * __restrict__ pdynl, const double * __restrict__ pdyni, const double * __restrict__ phrsw, + double * __restrict__ phrlw, const double * __restrict__ pvervel, const double * __restrict__ pap, + const double * __restrict__ paph, const double * __restrict__ plsm, + const int * ktype, const double * __restrict__ plu, double * __restrict__ plude, + const double * __restrict__ psnde, const double * __restrict__ pmfu, const double * __restrict__ pmfd, + const double * __restrict__ pa, const double * __restrict__ pclv, const double * __restrict__ psupsat, + const double * __restrict__ plcrit_aer, const double * __restrict__ picrit_aer, + const double * __restrict__ pre_ice, const double * __restrict__ pccn, const double * __restrict__ pnice, + double * __restrict__ pcovptot, double * __restrict__ prainfrac_toprfz, + double * __restrict__ pfsqlf, double * __restrict__ pfsqif, double * __restrict__ pfcqnng, + double * __restrict__ pfcqlng, double * __restrict__ pfsqrf, double * __restrict__ pfsqsf, + double * __restrict__ pfcqrng, double * __restrict__ pfcqsng, + double * __restrict__ pfsqltur, double * __restrict__ pfsqitur, + double * __restrict__ pfplsl, double * __restrict__ pfplsn, double * __restrict__ pfhpsl, + double * __restrict__ pfhpsn, struct TECLDP *yrecldp, int ngpblks, + double rg, double rd, double rcpd, double retv, double rlvtt, double rlstt, double rlmlt, double rtt, + double rv, double r2es, double r3les, double r3ies, double r4les, double r4ies, double r5les, + double r5ies, double r5alvcp, double r5alscp, double ralvdcp, double ralsdcp, double ralfdcp, + double rtwat, double rtice, double rticecu, double rtwat_rtice_r, double rtwat_rticecu_r, + double rkoop1, double rkoop2); + diff --git a/src/cloudsc_hip/cloudsc/cloudsc_driver.cpp b/src/cloudsc_hip/cloudsc/cloudsc_driver.cpp new file mode 100644 index 00000000..c03a877d --- /dev/null +++ b/src/cloudsc_hip/cloudsc/cloudsc_driver.cpp @@ -0,0 +1,607 @@ +/* + * (C) Copyright 1988- ECMWF. + * + * This software is licensed under the terms of the Apache Licence Version 2.0 + * which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. + * In applying this licence, ECMWF does not waive the privileges and immunities + * granted to it by virtue of its status as an intergovernmental organisation + * nor does it submit to any jurisdiction. + */ + +#include "cloudsc_driver.h" + +#include +#include "mycpu.h" + +#define gpuErrchk(ans) { gpuAssert((ans), __FILE__, __LINE__); } +inline void gpuAssert(hipError_t code, const char *file, int line, bool abort=true) +{ + if (code != hipSuccess) + { + fprintf(stderr,"GPUassert: %s %s %d\n", hipGetErrorString(code), file, line); + if (abort) exit(code); + } +} + +#define min(a, b) (((a) < (b)) ? (a) : (b)) +#define max(a, b) (((a) > (b)) ? (a) : (b)) + +void cloudsc_driver(int numthreads, int numcols, int nproma) { + + double *tend_tmp_u; + double *tend_tmp_v; + double *tend_tmp_t; + double *tend_tmp_q; + double *tend_tmp_o3; + double *tend_tmp_a; + double *tend_tmp_cld; + + double *tend_loc_u; + double *tend_loc_v; + double *tend_loc_t; + double *tend_loc_q; + double *tend_loc_o3; + double *tend_loc_a; + double *tend_loc_cld; + + double *tend_cml_u; + double *tend_cml_v; + double *tend_cml_t; + double *tend_cml_q; + double *tend_cml_o3; + double *tend_cml_a; + double *tend_cml_cld; + + double ptsphy; //! Physics timestep + + double *plcrit_aer; + double *picrit_aer; + double *pre_ice; + double *pccn; //! liquid cloud condensation nuclei + double *pnice; //! ice number concentration (cf. CCN) + double *pt; //! T at start of callpar + double *pq; //! Q at start of callpar + double *pvfa; //! CC from VDF scheme + double *pvfl; //! Liq from VDF scheme + double *pvfi; //! Ice from VDF scheme + double *pdyna; //! CC from Dynamics + double *pdynl; //! Liq from Dynamics + double *pdyni; //! Liq from Dynamics + double *phrsw; //! Short-wave heating rate + double *phrlw; //! Long-wave heating rate + double *pvervel; //! Vertical velocity + double *pap; //! Pressure on full levels + double *paph; //! Pressure on half levels + double *plsm; //! Land fraction (0-1) + int *ldcum; + int *ktype; //! Convection type 0,1,2 + double *plu; //! Conv. condensate + double *plude; //! Conv. detrained water + double *plude_tmp; + double *psnde; //! Conv. detrained snow + double *pmfu; //! Conv. mass flux up + double *pmfd; //! Conv. mass flux down + double *pa; //! Original Cloud fraction (t) + + double *pclv; + double *psupsat; + + double *pcovptot; //! Precip fraction + double *prainfrac_toprfz; + double *pfsqlf; //! Flux of liquid + double *pfsqif; //! Flux of ice + double *pfcqlng; //! -ve corr for liq + double *pfcqnng; //! -ve corr for ice + double *pfsqrf; //! Flux diagnostics + double *pfsqsf; //! for DDH, generic + double *pfcqrng; //! rain + double *pfcqsng; //! snow + double *pfsqltur; //! liquid flux due to VDF + double *pfsqitur; //! ice flux due to VDF + double *pfplsl; //! liq+rain sedim flux + double *pfplsn; //! ice+snow sedim flux + double *pfhpsl; //! Enthalpy flux for liq + double *pfhpsn; //! Enthalpy flux for ice + + /* Define or query data dimensions from input file */ + int klon, nlev; + int nblocks = (numcols / nproma) + min(numcols % nproma, 1); + + double zinfo[4][numthreads]; + const double zhpm = 12482329.0; // IBM P7 HPM flop count for 100 points at L137 + + int nclv; // number of microphysics variables + int ncldql; // liquid cloud water + int ncldqi; // ice cloud water + int ncldqr; // rain water + int ncldqs; // snow + int ncldqv; // vapour + + nclv = 5; // number of microphysics variables + ncldql = 1; // liquid cloud water + ncldqi = 2; // ice cloud water + ncldqr = 3; // rain water + ncldqs = 4; // snow + ncldqv = 5; // vapour + + struct TECLDP *yrecldp = (struct TECLDP*)malloc(sizeof(struct TECLDP)); + + query_state(&klon, &nlev); + + tend_loc_t = (double*) malloc( sizeof(double) * nblocks*nlev*nproma ); + tend_loc_q = (double*) malloc( sizeof(double) * nblocks*nlev*nproma ); + tend_loc_a = (double*) malloc( sizeof(double) * nblocks*nlev*nproma ); + tend_loc_cld = (double*) malloc( sizeof(double) * nblocks*nlev*nproma*nclv ); + tend_cml_t = (double*) malloc( sizeof(double) * nblocks*nlev*nproma ); + tend_cml_q = (double*) malloc( sizeof(double) * nblocks*nlev*nproma ); + tend_cml_a = (double*) malloc( sizeof(double) * nblocks*nlev*nproma ); + tend_cml_cld = (double*) malloc( sizeof(double) * nblocks*nlev*nproma*nclv ); + tend_tmp_t = (double*) malloc( sizeof(double) * nblocks*nlev*nproma ); + tend_tmp_q = (double*) malloc( sizeof(double) * nblocks*nlev*nproma ); + tend_tmp_a = (double*) malloc( sizeof(double) * nblocks*nlev*nproma ); + tend_tmp_cld = (double*) malloc( sizeof(double) * nblocks*nlev*nproma*nclv ); + + plcrit_aer = (double*) malloc( sizeof(double) * nblocks*nlev*nproma ); + picrit_aer = (double*) malloc( sizeof(double) * nblocks*nlev*nproma ); + pre_ice = (double*) malloc( sizeof(double) * nblocks*nlev*nproma ); + pccn = (double*) malloc( sizeof(double) * nblocks*nlev*nproma ); + pnice = (double*) malloc( sizeof(double) * nblocks*nlev*nproma ); + pt = (double*) malloc( sizeof(double) * nblocks*nlev*nproma ); + pq = (double*) malloc( sizeof(double) * nblocks*nlev*nproma ); + pvfa = (double*) malloc( sizeof(double) * nblocks*nlev*nproma ); + pvfl = (double*) malloc( sizeof(double) * nblocks*nlev*nproma ); + pvfi = (double*) malloc( sizeof(double) * nblocks*nlev*nproma ); + pdyna = (double*) malloc( sizeof(double) * nblocks*nlev*nproma ); + pdynl = (double*) malloc( sizeof(double) * nblocks*nlev*nproma ); + pdyni = (double*) malloc( sizeof(double) * nblocks*nlev*nproma ); + phrsw = (double*) malloc( sizeof(double) * nblocks*nlev*nproma ); + phrlw = (double*) malloc( sizeof(double) * nblocks*nlev*nproma ); + pvervel = (double*) malloc( sizeof(double) * nblocks*nlev*nproma ); + pap = (double*) malloc( sizeof(double) * nblocks*nlev*nproma ); + paph = (double*) malloc( sizeof(double) * nblocks*(nlev+1)*nproma ); + plsm = (double*) malloc( sizeof(double) * nblocks*nproma ); + ldcum = (int*) malloc( sizeof(int) * nblocks*nproma ); + ktype = (int*) malloc( sizeof(int) * nblocks*nproma ); + plu = (double*) malloc( sizeof(double) * nblocks*nlev*nproma ); + plude = (double*) malloc( sizeof(double) * nblocks*nlev*nproma ); + psnde = (double*) malloc( sizeof(double) * nblocks*nlev*nproma ); + pmfu = (double*) malloc( sizeof(double) * nblocks*nlev*nproma ); + pmfd = (double*) malloc( sizeof(double) * nblocks*nlev*nproma ); + pa = (double*) malloc( sizeof(double) * nblocks*nlev*nproma ); + pclv = (double*) malloc( sizeof(double) * nblocks*nlev*nproma*nclv ); + psupsat = (double*) malloc( sizeof(double) * nblocks*nlev*nproma ); + pcovptot = (double*) malloc( sizeof(double) * nblocks*nlev*nproma ); + prainfrac_toprfz = (double*) malloc( sizeof(double) * nblocks*nproma ); + pfsqlf = (double*) malloc( sizeof(double) * nblocks*(nlev+1)*nproma ); + pfsqif = (double*) malloc( sizeof(double) * nblocks*(nlev+1)*nproma ); + pfcqnng = (double*) malloc( sizeof(double) * nblocks*(nlev+1)*nproma ); + pfcqlng = (double*) malloc( sizeof(double) * nblocks*(nlev+1)*nproma ); + pfsqrf = (double*) malloc( sizeof(double) * nblocks*(nlev+1)*nproma ); + pfsqsf = (double*) malloc( sizeof(double) * nblocks*(nlev+1)*nproma ); + pfcqrng = (double*) malloc( sizeof(double) * nblocks*(nlev+1)*nproma ); + pfcqsng = (double*) malloc( sizeof(double) * nblocks*(nlev+1)*nproma ); + pfsqltur = (double*) malloc( sizeof(double) * nblocks*(nlev+1)*nproma ); + pfsqitur = (double*) malloc( sizeof(double) * nblocks*(nlev+1)*nproma ); + pfplsl = (double*) malloc( sizeof(double) * nblocks*(nlev+1)*nproma ); + pfplsn = (double*) malloc( sizeof(double) * nblocks*(nlev+1)*nproma ); + pfhpsl = (double*) malloc( sizeof(double) * nblocks*(nlev+1)*nproma ); + pfhpsn = (double*) malloc( sizeof(double) * nblocks*(nlev+1)*nproma ); + + + double rg; + double rd; + double rcpd; + double retv; + double rlvtt; + double rlstt; + double rlmlt; + double rtt; + double rv; + double r2es; + double r3les; + double r3ies; + double r4les; + double r4ies; + double r5les; + double r5ies; + double r5alvcp; + double r5alscp; + double ralvdcp; + double ralsdcp; + double ralfdcp; + double rtwat; + double rtice; + double rticecu; + double rtwat_rtice_r; + double rtwat_rticecu_r; + double rkoop1; + double rkoop2; + + // device declarations + double *d_plcrit_aer; + double *d_picrit_aer; + double *d_pre_ice; + double *d_pccn; + double *d_pnice; + double *d_pt; + double *d_pq; + double *d_tend_loc_t; + double *d_tend_loc_q; + double *d_tend_loc_a; + double *d_tend_loc_cld; + double *d_tend_tmp_t; + double *d_tend_tmp_q; + double *d_tend_tmp_a; + double *d_tend_tmp_cld; + double *d_pvfa; + double *d_pvfl; + double *d_pvfi; + double *d_pdyna; + double *d_pdynl; + double *d_pdyni; + double *d_phrsw; + double *d_phrlw; + double *d_pvervel; + double *d_pap; + double *d_paph; + double *d_plsm; + int *d_ktype; + double *d_plu; + double *d_plude; + double *d_psnde; + double *d_pmfu; + double *d_pmfd; + double *d_pa; + double *d_pclv; + double *d_psupsat; + struct TECLDP *d_yrecldp; + double *d_pcovptot; + double *d_prainfrac_toprfz; + double *d_pfsqlf; + double *d_pfsqif; + double *d_pfcqnng; + double *d_pfcqlng; + double *d_pfsqrf; + double *d_pfsqsf; + double *d_pfcqrng; + double *d_pfcqsng; + double *d_pfsqltur; + double *d_pfsqitur; + double *d_pfplsl; + double *d_pfplsn; + double *d_pfhpsl; + double *d_pfhpsn; + // end device declarations + + hipMalloc(&d_plcrit_aer, sizeof(double) * nblocks*nlev*nproma); + hipMalloc(&d_picrit_aer, sizeof(double) * nblocks*nlev*nproma); + hipMalloc(&d_pre_ice, sizeof(double) * nblocks*nlev*nproma); + hipMalloc(&d_pccn, sizeof(double) * nblocks*nlev*nproma); + hipMalloc(&d_pnice, sizeof(double) * nblocks*nlev*nproma); + hipMalloc(&d_pt, sizeof(double) * nblocks*nlev*nproma); + hipMalloc(&d_pq, sizeof(double) * nblocks*nlev*nproma); + hipMalloc(&d_tend_loc_t, sizeof(double) * nblocks*nlev*nproma); + hipMalloc(&d_tend_loc_q, sizeof(double) * nblocks*nlev*nproma); + hipMalloc(&d_tend_loc_a, sizeof(double) * nblocks*nlev*nproma); + hipMalloc(&d_tend_loc_cld, sizeof(double) * nblocks*nlev*nproma*nclv); + hipMalloc(&d_tend_tmp_t, sizeof(double) * nblocks*nlev*nproma); + hipMalloc(&d_tend_tmp_q, sizeof(double) * nblocks*nlev*nproma); + hipMalloc(&d_tend_tmp_a, sizeof(double) * nblocks*nlev*nproma); + hipMalloc(&d_tend_tmp_cld, sizeof(double) * nblocks*nlev*nproma*nclv); + hipMalloc(&d_pvfa, sizeof(double) * nblocks*nlev*nproma); + hipMalloc(&d_pvfl, sizeof(double) * nblocks*nlev*nproma); + hipMalloc(&d_pvfi, sizeof(double) * nblocks*nlev*nproma); + hipMalloc(&d_pdyna, sizeof(double) * nblocks*nlev*nproma); + hipMalloc(&d_pdynl, sizeof(double) * nblocks*nlev*nproma); + hipMalloc(&d_pdyni, sizeof(double) * nblocks*nlev*nproma); + hipMalloc(&d_phrsw, sizeof(double) * nblocks*nlev*nproma); + hipMalloc(&d_phrlw, sizeof(double) * nblocks*nlev*nproma); + hipMalloc(&d_pvervel, sizeof(double) * nblocks*nlev*nproma); + hipMalloc(&d_pap, sizeof(double) * nblocks*nlev*nproma); + hipMalloc(&d_paph, sizeof(double) * nblocks*(nlev+1)*nproma); + hipMalloc(&d_plsm, sizeof(double) * nblocks*nproma); + hipMalloc(&d_ktype, sizeof(int) * nblocks*nproma); + hipMalloc(&d_plu, sizeof(double) * nblocks*nlev*nproma); + hipMalloc(&d_plude, sizeof(double) * nblocks*nlev*nproma); + hipMalloc(&d_psnde, sizeof(double) * nblocks*nlev*nproma); + hipMalloc(&d_pmfu, sizeof(double) * nblocks*nlev*nproma); + hipMalloc(&d_pmfd, sizeof(double) * nblocks*nlev*nproma); + hipMalloc(&d_pa, sizeof(double) * nblocks*nlev*nproma); + hipMalloc(&d_pclv, sizeof(double) * nblocks*nlev*nproma*nclv); + hipMalloc(&d_psupsat, sizeof(double) * nblocks*nlev*nproma); + hipMalloc(&d_yrecldp, sizeof(struct TECLDP)); + hipMalloc(&d_pcovptot, sizeof(double) * nblocks*nlev*nproma); + hipMalloc(&d_prainfrac_toprfz, sizeof(double) * nblocks*nproma); + hipMalloc(&d_pfsqlf, sizeof(double) * nblocks*(nlev+1)*nproma); + hipMalloc(&d_pfsqif, sizeof(double) * nblocks*(nlev+1)*nproma); + hipMalloc(&d_pfcqnng, sizeof(double) * nblocks*(nlev+1)*nproma); + hipMalloc(&d_pfcqlng, sizeof(double) * nblocks*(nlev+1)*nproma); + hipMalloc(&d_pfsqrf, sizeof(double) * nblocks*(nlev+1)*nproma); + hipMalloc(&d_pfsqsf, sizeof(double) * nblocks*(nlev+1)*nproma); + hipMalloc(&d_pfcqrng, sizeof(double) * nblocks*(nlev+1)*nproma); + hipMalloc(&d_pfcqsng, sizeof(double) * nblocks*(nlev+1)*nproma); + hipMalloc(&d_pfsqltur, sizeof(double) * nblocks*(nlev+1)*nproma); + hipMalloc(&d_pfsqitur, sizeof(double) * nblocks*(nlev+1)*nproma); + hipMalloc(&d_pfplsl, sizeof(double) * nblocks*(nlev+1)*nproma); + hipMalloc(&d_pfplsn, sizeof(double) * nblocks*(nlev+1)*nproma); + hipMalloc(&d_pfhpsl, sizeof(double) * nblocks*(nlev+1)*nproma); + hipMalloc(&d_pfhpsn, sizeof(double) * nblocks*(nlev+1)*nproma); + + load_state(klon, nlev, nclv, numcols, nproma, &ptsphy, plcrit_aer, picrit_aer, + pre_ice, pccn, pnice, pt, pq, + tend_cml_t, tend_cml_q, tend_cml_a, tend_cml_cld, + tend_tmp_t, tend_tmp_q, tend_tmp_a, tend_tmp_cld, + pvfa, pvfl, pvfi, pdyna, pdynl, pdyni, + phrsw, phrlw, pvervel, pap, paph, plsm, ktype, plu, + plude, psnde, pmfu, pmfd, pa, pclv, psupsat, yrecldp, + &rg, &rd, &rcpd, &retv, &rlvtt, &rlstt, + &rlmlt, &rtt, &rv, &r2es, &r3les, &r3ies, + &r4les, &r4ies, &r5les, &r5ies, &r5alvcp, &r5alscp, + &ralvdcp, &ralsdcp, &ralfdcp, &rtwat, + &rtice, &rticecu, &rtwat_rtice_r, &rtwat_rticecu_r, + &rkoop1, &rkoop2 ); + + // host to device + hipMemcpy(d_plcrit_aer, plcrit_aer, sizeof(double) * nblocks*nlev*nproma, hipMemcpyHostToDevice); + hipMemcpy(d_picrit_aer, picrit_aer, sizeof(double) * nblocks*nlev*nproma, hipMemcpyHostToDevice); + hipMemcpy(d_pre_ice, pre_ice, sizeof(double) * nblocks*nlev*nproma, hipMemcpyHostToDevice); + hipMemcpy(d_pccn, pccn, sizeof(double) * nblocks*nlev*nproma, hipMemcpyHostToDevice); + hipMemcpy(d_pnice, pnice, sizeof(double) * nblocks*nlev*nproma, hipMemcpyHostToDevice); + hipMemcpy(d_pt, pt, sizeof(double) * nblocks*nlev*nproma, hipMemcpyHostToDevice); + hipMemcpy(d_pq, pq, sizeof(double) * nblocks*nlev*nproma, hipMemcpyHostToDevice); + hipMemcpy(d_tend_loc_t, tend_loc_t, sizeof(double) * nblocks*nlev*nproma, hipMemcpyHostToDevice); + hipMemcpy(d_tend_loc_q, tend_loc_q, sizeof(double) * nblocks*nlev*nproma, hipMemcpyHostToDevice); + hipMemcpy(d_tend_loc_a, tend_loc_a, sizeof(double) * nblocks*nlev*nproma, hipMemcpyHostToDevice); + hipMemcpy(d_tend_loc_cld, tend_loc_cld, sizeof(double) * nblocks*nlev*nproma*nclv, hipMemcpyHostToDevice); + hipMemcpy(d_tend_tmp_t, tend_tmp_t, sizeof(double) * nblocks*nlev*nproma, hipMemcpyHostToDevice); + hipMemcpy(d_tend_tmp_q, tend_tmp_q, sizeof(double) * nblocks*nlev*nproma, hipMemcpyHostToDevice); + hipMemcpy(d_tend_tmp_a, tend_tmp_a, sizeof(double) * nblocks*nlev*nproma, hipMemcpyHostToDevice); + hipMemcpy(d_tend_tmp_cld, tend_tmp_cld, sizeof(double) * nblocks*nlev*nproma*nclv, hipMemcpyHostToDevice); + hipMemcpy(d_pvfa, pvfa, sizeof(double) * nblocks*nlev*nproma, hipMemcpyHostToDevice); + hipMemcpy(d_pvfl, pvfl, sizeof(double) * nblocks*nlev*nproma, hipMemcpyHostToDevice); + hipMemcpy(d_pvfi, pvfi, sizeof(double) * nblocks*nlev*nproma, hipMemcpyHostToDevice); + hipMemcpy(d_pdyna, pdyna, sizeof(double) * nblocks*nlev*nproma, hipMemcpyHostToDevice); + hipMemcpy(d_pdynl, pdynl, sizeof(double) * nblocks*nlev*nproma, hipMemcpyHostToDevice); + hipMemcpy(d_pdyni, pdyni, sizeof(double) * nblocks*nlev*nproma, hipMemcpyHostToDevice); + hipMemcpy(d_phrsw, phrsw, sizeof(double) * nblocks*nlev*nproma, hipMemcpyHostToDevice); + hipMemcpy(d_phrlw, phrlw, sizeof(double) * nblocks*nlev*nproma, hipMemcpyHostToDevice); + hipMemcpy(d_pvervel, pvervel, sizeof(double) * nblocks*nlev*nproma, hipMemcpyHostToDevice); + hipMemcpy(d_pap, pap, sizeof(double) * nblocks*nlev*nproma, hipMemcpyHostToDevice); + hipMemcpy(d_paph, paph, sizeof(double) * nblocks*(nlev+1)*nproma, hipMemcpyHostToDevice); + hipMemcpy(d_plsm, plsm, sizeof(double) * nblocks*nproma, hipMemcpyHostToDevice); + hipMemcpy(d_ktype, ktype, sizeof(int) * nblocks*nproma, hipMemcpyHostToDevice); + hipMemcpy(d_plu, plu, sizeof(double) * nblocks*nlev*nproma, hipMemcpyHostToDevice); + hipMemcpy(d_plude, plude, sizeof(double) * nblocks*nlev*nproma, hipMemcpyHostToDevice); + hipMemcpy(d_psnde, psnde, sizeof(double) * nblocks*nlev*nproma, hipMemcpyHostToDevice); + hipMemcpy(d_pmfu, pmfu, sizeof(double) * nblocks*nlev*nproma, hipMemcpyHostToDevice); + hipMemcpy(d_pmfd, pmfd, sizeof(double) * nblocks*nlev*nproma, hipMemcpyHostToDevice); + hipMemcpy(d_pa, pa, sizeof(double) * nblocks*nlev*nproma, hipMemcpyHostToDevice); + hipMemcpy(d_pclv, pclv, sizeof(double) * nblocks*nlev*nproma*nclv, hipMemcpyHostToDevice); + hipMemcpy(d_psupsat, psupsat, sizeof(double) * nblocks*nlev*nproma, hipMemcpyHostToDevice); + hipMemcpy(d_yrecldp, yrecldp, sizeof(TECLDP), hipMemcpyHostToDevice); + // end host to device + + double t1 = omp_get_wtime(); + + int b, bsize, icalls=0, igpc=numcols; + int coreid = mycpu(); + int tid = omp_get_thread_num(); + double start = omp_get_wtime(); + + dim3 blockdim(nproma, 1, 1); + //dim3 griddim(1, 1, ceil(((double)numcols) / ((double)nproma))); + dim3 griddim(ceil(((double)numcols) / ((double)nproma)), 1, 1); + int jkglo = 0; + int ibl = (jkglo - 1) / nproma + 1; + int icend = min(nproma, numcols - jkglo + 1); + + cloudsc_c<<>>(1, icend/*bsize*/, nproma/*, nlev*/, ptsphy, d_pt, d_pq, + d_tend_tmp_t, d_tend_tmp_q, d_tend_tmp_a, d_tend_tmp_cld, + d_tend_loc_t, d_tend_loc_q, d_tend_loc_a, d_tend_loc_cld, + d_pvfa, d_pvfl, d_pvfi, + d_pdyna, d_pdynl, d_pdyni, + d_phrsw, d_phrlw, d_pvervel, + d_pap, d_paph, d_plsm, d_ktype, + d_plu, d_plude, d_psnde, d_pmfu, d_pmfd, + d_pa, d_pclv, d_psupsat, + d_plcrit_aer, d_picrit_aer, d_pre_ice, d_pccn, d_pnice, + d_pcovptot, d_prainfrac_toprfz, d_pfsqlf, + d_pfsqif, d_pfcqnng, d_pfcqlng, + d_pfsqrf, d_pfsqsf, d_pfcqrng, + d_pfcqsng, d_pfsqltur, d_pfsqitur, + d_pfplsl, d_pfplsn, d_pfhpsl, d_pfhpsn, d_yrecldp, + nblocks, rg, rd, rcpd, retv, rlvtt, rlstt, rlmlt, rtt, + rv, r2es, r3les, r3ies, r4les, r4ies, r5les, + r5ies, r5alvcp, r5alscp, ralvdcp, ralsdcp, ralfdcp, + rtwat, rtice, rticecu, rtwat_rtice_r, rtwat_rticecu_r, + rkoop1, rkoop2); + + + gpuErrchk( hipPeekAtLastError() ); + gpuErrchk( hipDeviceSynchronize() ); + + double end = omp_get_wtime(); + + // device to host + hipMemcpy(tend_loc_t, d_tend_loc_t, sizeof(double) * nblocks*nlev*nproma, hipMemcpyDeviceToHost); + hipMemcpy(tend_loc_q, d_tend_loc_q, sizeof(double) * nblocks*nlev*nproma, hipMemcpyDeviceToHost); + hipMemcpy(tend_loc_a, d_tend_loc_a, sizeof(double) * nblocks*nlev*nproma, hipMemcpyDeviceToHost); + hipMemcpy(tend_loc_cld, d_tend_loc_cld, sizeof(double) * nblocks*nlev*nproma*nclv, hipMemcpyDeviceToHost); + hipMemcpy(phrlw, d_phrlw, sizeof(double) * nblocks*nlev*nproma, hipMemcpyDeviceToHost); + hipMemcpy(plude, d_plude, sizeof(double) * nblocks*nlev*nproma, hipMemcpyDeviceToHost); + hipMemcpy(yrecldp, d_yrecldp, sizeof(TECLDP), hipMemcpyDeviceToHost); + hipMemcpy(pcovptot, d_pcovptot, sizeof(double) * nblocks*nlev*nproma, hipMemcpyDeviceToHost); + hipMemcpy(prainfrac_toprfz, d_prainfrac_toprfz, sizeof(double) * nblocks*nproma, hipMemcpyDeviceToHost); + hipMemcpy(pfsqlf, d_pfsqlf, sizeof(double) * nblocks*(nlev+1)*nproma, hipMemcpyDeviceToHost); + hipMemcpy(pfsqif, d_pfsqif, sizeof(double) * nblocks*(nlev+1)*nproma, hipMemcpyDeviceToHost); + hipMemcpy(pfcqnng, d_pfcqnng, sizeof(double) * nblocks*(nlev+1)*nproma, hipMemcpyDeviceToHost); + hipMemcpy(pfcqlng, d_pfcqlng, sizeof(double) * nblocks*(nlev+1)*nproma, hipMemcpyDeviceToHost); + hipMemcpy(pfsqrf, d_pfsqrf, sizeof(double) * nblocks*(nlev+1)*nproma, hipMemcpyDeviceToHost); + hipMemcpy(pfsqsf, d_pfsqsf, sizeof(double) * nblocks*(nlev+1)*nproma, hipMemcpyDeviceToHost); + hipMemcpy(pfcqrng, d_pfcqrng, sizeof(double) * nblocks*(nlev+1)*nproma, hipMemcpyDeviceToHost); + hipMemcpy(pfcqsng, d_pfcqsng, sizeof(double) * nblocks*(nlev+1)*nproma, hipMemcpyDeviceToHost); + hipMemcpy(pfsqltur, d_pfsqltur, sizeof(double) * nblocks*(nlev+1)*nproma, hipMemcpyDeviceToHost); + hipMemcpy(pfsqitur, d_pfsqitur, sizeof(double) * nblocks*(nlev+1)*nproma, hipMemcpyDeviceToHost); + hipMemcpy(pfplsl, d_pfplsl, sizeof(double) * nblocks*(nlev+1)*nproma, hipMemcpyDeviceToHost); + hipMemcpy(pfplsn, d_pfplsn, sizeof(double) * nblocks*(nlev+1)*nproma, hipMemcpyDeviceToHost); + hipMemcpy(pfhpsl, d_pfhpsl, sizeof(double) * nblocks*(nlev+1)*nproma, hipMemcpyDeviceToHost); + hipMemcpy(pfhpsn, d_pfhpsn, sizeof(double) * nblocks*(nlev+1)*nproma, hipMemcpyDeviceToHost); + // end device to host + + /* int msec = diff * 1000 / CLOCKS_PER_SEC; */ + zinfo[0][tid] = end - start; + zinfo[1][tid] = (double) coreid; + zinfo[2][tid] = (double) icalls; + zinfo[3][tid] = (double) igpc; + + double t2 = omp_get_wtime(); + + printf(" NUMOMP=%d, NGPTOT=%d, NPROMA=%d, NGPBLKS=%d\n", numthreads, numcols, nproma, nblocks); + printf(" %+10s%+10s%+10s%+10s%+10s %+4s : %+10s%+10s\n", + "NUMOMP", "NGPTOT", "#GP-cols", "#BLKS", "NPROMA", "tid#", "Time(msec)", "MFlops/s"); + double zfrac, zmflops; + for (int t = 0; t < numthreads; t++) { + const double tloc = zinfo[0][t]; + const int coreid = (int) zinfo[1][t]; + const int icalls = (int) zinfo[2][t]; + const int igpc = (int) zinfo[3][t]; + zfrac = (double)igpc / (double)numcols; + if (tloc > 0.0) { + zmflops = 1.0e-06 * zfrac * zhpm * ((double)numcols / 100.) / tloc; + } else { + zmflops = 0.; + } + printf(" %10d%10d%10d%10d%10d %4d : %10d%10d @ core#\n", + numthreads, numcols, igpc, icalls, nproma, t, (int)(tloc * 1000.), (int)zmflops); + } + double tdiff = t2 - t1; + zfrac = 1.0; + if (tdiff > 0.0) { + zmflops = 1.0e-06 * zfrac * zhpm * ((double)numcols / 100.) / tdiff; + } else { + zmflops = 0.0; + } + printf(" %10d%10d%10d%10d%10d %4d : %10d%10d TOTAL\n", + numthreads, numcols, numcols, nblocks, nproma, -1, (int)(tdiff * 1000.), (int)zmflops); + + cloudsc_validate(klon, nlev, nclv, numcols, nproma, + plude, pcovptot, prainfrac_toprfz, pfsqlf, pfsqif, + pfcqlng, pfcqnng, pfsqrf, pfsqsf, pfcqrng, pfcqsng, + pfsqltur, pfsqitur, pfplsl, pfplsn, pfhpsl, pfhpsn, + tend_loc_a, tend_loc_q, tend_loc_t, tend_loc_cld); + + free(plcrit_aer); // ALLOCATE(PLCRIT_AER(KLON,KLEV)) + free(picrit_aer); // ALLOCATE(PICRIT_AER(KLON,KLEV)) + free(pre_ice); // ALLOCATE(PRE_ICE(KLON,KLEV)) + free(pccn); + free(pnice); + free(pt); + free(pq); + free(pvfa); + free(pvfl); + free(pvfi); + free(pdyna); + free(pdynl); + free(pdyni); + free(phrsw); + free(phrlw); + free(pvervel); + free(pap); + free(paph); // ALLOCATE(PAPH(KLON,KLEV+1)) + free(plsm); + free(ktype); + free(plu); + free(plude); + free(psnde); + free(pmfu); + free(pmfd); + free(pa); + free(pclv); + free(psupsat); + free(pcovptot); + free(tend_loc_t); + free(tend_loc_q); + free(tend_loc_a); + free(tend_loc_cld); + free(tend_tmp_t); + free(tend_tmp_q); + free(tend_tmp_a); + free(tend_tmp_cld); + free(tend_cml_t); + free(tend_cml_q); + free(tend_cml_a); + free(tend_cml_cld); + free(prainfrac_toprfz); + free(pfsqlf); + free(pfsqif); + free(pfcqnng); + free(pfcqlng); + free(pfsqrf); + free(pfsqsf); + free(pfcqrng); + free(pfcqsng); + free(pfsqltur); + free(pfsqitur); + free(pfplsl); + free(pfplsn); + free(pfhpsl); + free(pfhpsn); + free(yrecldp); + + // free device + hipFree(d_plcrit_aer); + hipFree(d_picrit_aer); + hipFree(d_pre_ice); + hipFree(d_pccn); + hipFree(d_pnice); + hipFree(d_pt); + hipFree(d_pq); + hipFree(d_tend_loc_t); + hipFree(d_tend_loc_q); + hipFree(d_tend_loc_a); + hipFree(d_tend_loc_cld); + hipFree(d_tend_tmp_t); + hipFree(d_tend_tmp_q); + hipFree(d_tend_tmp_a); + hipFree(d_tend_tmp_cld); + hipFree(d_pvfa); + hipFree(d_pvfl); + hipFree(d_pvfi); + hipFree(d_pdyna); + hipFree(d_pdynl); + hipFree(d_pdyni); + hipFree(d_phrsw); + hipFree(d_phrlw); + hipFree(d_pvervel); + hipFree(d_pap); + hipFree(d_paph); + hipFree(d_plsm); + hipFree(d_ktype); + hipFree(d_plu); + hipFree(d_plude); + hipFree(d_psnde); + hipFree(d_pmfu); + hipFree(d_pmfd); + hipFree(d_pa); + hipFree(d_pclv); + hipFree(d_psupsat); + hipFree(d_yrecldp); + hipFree(d_pcovptot); + hipFree(d_prainfrac_toprfz); + hipFree(d_pfsqlf); + hipFree(d_pfsqif); + hipFree(d_pfcqnng); + hipFree(d_pfcqlng); + hipFree(d_pfsqrf); + hipFree(d_pfsqsf); + hipFree(d_pfcqrng); + hipFree(d_pfcqsng); + hipFree(d_pfsqltur); + hipFree(d_pfsqitur); + hipFree(d_pfplsl); + hipFree(d_pfplsn); + hipFree(d_pfhpsl); + hipFree(d_pfhpsn); + // end free device +} + diff --git a/src/cloudsc_hip/cloudsc/cloudsc_driver.h b/src/cloudsc_hip/cloudsc/cloudsc_driver.h new file mode 100644 index 00000000..6892a4cc --- /dev/null +++ b/src/cloudsc_hip/cloudsc/cloudsc_driver.h @@ -0,0 +1,23 @@ +/* + * (C) Copyright 1988- ECMWF. + * + * This software is licensed under the terms of the Apache Licence Version 2.0 + * which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. + * In applying this licence, ECMWF does not waive the privileges and immunities + * granted to it by virtue of its status as an intergovernmental organisation + * nor does it submit to any jurisdiction. + */ + +#include +#include +#include +#include +#include "hip/hip_runtime_api.h" +#include "hip/hip_runtime.h" + +#include "yoecldp_c.h" +#include "load_state.h" +#include "cloudsc_c.h" +#include "cloudsc_validate.h" + +void cloudsc_driver(int numthreads, int numcols, int nproma); diff --git a/src/cloudsc_hip/cloudsc/cloudsc_driver_hoist.cpp b/src/cloudsc_hip/cloudsc/cloudsc_driver_hoist.cpp new file mode 100644 index 00000000..657bed97 --- /dev/null +++ b/src/cloudsc_hip/cloudsc/cloudsc_driver_hoist.cpp @@ -0,0 +1,666 @@ +/* + * (C) Copyright 1988- ECMWF. + * + * This software is licensed under the terms of the Apache Licence Version 2.0 + * which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. + * In applying this licence, ECMWF does not waive the privileges and immunities + * granted to it by virtue of its status as an intergovernmental organisation + * nor does it submit to any jurisdiction. + */ + +#include "cloudsc_driver_hoist.h" + +#include +#include "mycpu.h" + +#define gpuErrchk(ans) { gpuAssert((ans), __FILE__, __LINE__); } +inline void gpuAssert(hipError_t code, const char *file, int line, bool abort=true) +{ + if (code != hipSuccess) + { + fprintf(stderr,"GPUassert: %s %s %d\n", hipGetErrorString(code), file, line); + if (abort) exit(code); + } +} + +#define min(a, b) (((a) < (b)) ? (a) : (b)) +#define max(a, b) (((a) > (b)) ? (a) : (b)) + +void cloudsc_driver(int numthreads, int numcols, int nproma) { + + double *tend_tmp_u; + double *tend_tmp_v; + double *tend_tmp_t; + double *tend_tmp_q; + double *tend_tmp_o3; + double *tend_tmp_a; + double *tend_tmp_cld; + + double *tend_loc_u; + double *tend_loc_v; + double *tend_loc_t; + double *tend_loc_q; + double *tend_loc_o3; + double *tend_loc_a; + double *tend_loc_cld; + + double *tend_cml_u; + double *tend_cml_v; + double *tend_cml_t; + double *tend_cml_q; + double *tend_cml_o3; + double *tend_cml_a; + double *tend_cml_cld; + + double ptsphy; //! Physics timestep + + double *plcrit_aer; + double *picrit_aer; + double *pre_ice; + double *pccn; //! liquid cloud condensation nuclei + double *pnice; //! ice number concentration (cf. CCN) + double *pt; //! T at start of callpar + double *pq; //! Q at start of callpar + double *pvfa; //! CC from VDF scheme + double *pvfl; //! Liq from VDF scheme + double *pvfi; //! Ice from VDF scheme + double *pdyna; //! CC from Dynamics + double *pdynl; //! Liq from Dynamics + double *pdyni; //! Liq from Dynamics + double *phrsw; //! Short-wave heating rate + double *phrlw; //! Long-wave heating rate + double *pvervel; //! Vertical velocity + double *pap; //! Pressure on full levels + double *paph; //! Pressure on half levels + double *plsm; //! Land fraction (0-1) + int *ldcum; + int *ktype; //! Convection type 0,1,2 + double *plu; //! Conv. condensate + double *plude; //! Conv. detrained water + double *plude_tmp; + double *psnde; //! Conv. detrained snow + double *pmfu; //! Conv. mass flux up + double *pmfd; //! Conv. mass flux down + double *pa; //! Original Cloud fraction (t) + + double *pclv; + double *psupsat; + + double *pcovptot; //! Precip fraction + double *prainfrac_toprfz; + double *pfsqlf; //! Flux of liquid + double *pfsqif; //! Flux of ice + double *pfcqlng; //! -ve corr for liq + double *pfcqnng; //! -ve corr for ice + double *pfsqrf; //! Flux diagnostics + double *pfsqsf; //! for DDH, generic + double *pfcqrng; //! rain + double *pfcqsng; //! snow + double *pfsqltur; //! liquid flux due to VDF + double *pfsqitur; //! ice flux due to VDF + double *pfplsl; //! liq+rain sedim flux + double *pfplsn; //! ice+snow sedim flux + double *pfhpsl; //! Enthalpy flux for liq + double *pfhpsn; //! Enthalpy flux for ice + + /* Define or query data dimensions from input file */ + int klon, nlev; + int nblocks = (numcols / nproma) + min(numcols % nproma, 1); + + double zinfo[4][numthreads]; + const double zhpm = 12482329.0; // IBM P7 HPM flop count for 100 points at L137 + + int nclv; // number of microphysics variables + int ncldql; // liquid cloud water + int ncldqi; // ice cloud water + int ncldqr; // rain water + int ncldqs; // snow + int ncldqv; // vapour + + nclv = 5; // number of microphysics variables + ncldql = 1; // liquid cloud water + ncldqi = 2; // ice cloud water + ncldqr = 3; // rain water + ncldqs = 4; // snow + ncldqv = 5; // vapour + + struct TECLDP *yrecldp = (struct TECLDP*)malloc(sizeof(struct TECLDP)); + + query_state(&klon, &nlev); + + tend_loc_t = (double*) malloc( sizeof(double) * nblocks*nlev*nproma ); + tend_loc_q = (double*) malloc( sizeof(double) * nblocks*nlev*nproma ); + tend_loc_a = (double*) malloc( sizeof(double) * nblocks*nlev*nproma ); + tend_loc_cld = (double*) malloc( sizeof(double) * nblocks*nlev*nproma*nclv ); + tend_cml_t = (double*) malloc( sizeof(double) * nblocks*nlev*nproma ); + tend_cml_q = (double*) malloc( sizeof(double) * nblocks*nlev*nproma ); + tend_cml_a = (double*) malloc( sizeof(double) * nblocks*nlev*nproma ); + tend_cml_cld = (double*) malloc( sizeof(double) * nblocks*nlev*nproma*nclv ); + tend_tmp_t = (double*) malloc( sizeof(double) * nblocks*nlev*nproma ); + tend_tmp_q = (double*) malloc( sizeof(double) * nblocks*nlev*nproma ); + tend_tmp_a = (double*) malloc( sizeof(double) * nblocks*nlev*nproma ); + tend_tmp_cld = (double*) malloc( sizeof(double) * nblocks*nlev*nproma*nclv ); + plcrit_aer = (double*) malloc( sizeof(double) * nblocks*nlev*nproma ); + picrit_aer = (double*) malloc( sizeof(double) * nblocks*nlev*nproma ); + pre_ice = (double*) malloc( sizeof(double) * nblocks*nlev*nproma ); + pccn = (double*) malloc( sizeof(double) * nblocks*nlev*nproma ); + pnice = (double*) malloc( sizeof(double) * nblocks*nlev*nproma ); + pt = (double*) malloc( sizeof(double) * nblocks*nlev*nproma ); + pq = (double*) malloc( sizeof(double) * nblocks*nlev*nproma ); + pvfa = (double*) malloc( sizeof(double) * nblocks*nlev*nproma ); + pvfl = (double*) malloc( sizeof(double) * nblocks*nlev*nproma ); + pvfi = (double*) malloc( sizeof(double) * nblocks*nlev*nproma ); + pdyna = (double*) malloc( sizeof(double) * nblocks*nlev*nproma ); + pdynl = (double*) malloc( sizeof(double) * nblocks*nlev*nproma ); + pdyni = (double*) malloc( sizeof(double) * nblocks*nlev*nproma ); + phrsw = (double*) malloc( sizeof(double) * nblocks*nlev*nproma ); + phrlw = (double*) malloc( sizeof(double) * nblocks*nlev*nproma ); + pvervel = (double*) malloc( sizeof(double) * nblocks*nlev*nproma ); + pap = (double*) malloc( sizeof(double) * nblocks*nlev*nproma ); + paph = (double*) malloc( sizeof(double) * nblocks*(nlev+1)*nproma ); + plsm = (double*) malloc( sizeof(double) * nblocks*nproma ); + ldcum = (int*) malloc( sizeof(int) * nblocks*nproma ); + ktype = (int*) malloc( sizeof(int) * nblocks*nproma ); + plu = (double*) malloc( sizeof(double) * nblocks*nlev*nproma ); + plude = (double*) malloc( sizeof(double) * nblocks*nlev*nproma ); + psnde = (double*) malloc( sizeof(double) * nblocks*nlev*nproma ); + pmfu = (double*) malloc( sizeof(double) * nblocks*nlev*nproma ); + pmfd = (double*) malloc( sizeof(double) * nblocks*nlev*nproma ); + pa = (double*) malloc( sizeof(double) * nblocks*nlev*nproma ); + pclv = (double*) malloc( sizeof(double) * nblocks*nlev*nproma*nclv ); + psupsat = (double*) malloc( sizeof(double) * nblocks*nlev*nproma ); + pcovptot = (double*) malloc( sizeof(double) * nblocks*nlev*nproma ); + prainfrac_toprfz = (double*) malloc( sizeof(double) * nblocks*nproma ); + pfsqlf = (double*) malloc( sizeof(double) * nblocks*(nlev+1)*nproma ); + pfsqif = (double*) malloc( sizeof(double) * nblocks*(nlev+1)*nproma ); + pfcqnng = (double*) malloc( sizeof(double) * nblocks*(nlev+1)*nproma ); + pfcqlng = (double*) malloc( sizeof(double) * nblocks*(nlev+1)*nproma ); + pfsqrf = (double*) malloc( sizeof(double) * nblocks*(nlev+1)*nproma ); + pfsqsf = (double*) malloc( sizeof(double) * nblocks*(nlev+1)*nproma ); + pfcqrng = (double*) malloc( sizeof(double) * nblocks*(nlev+1)*nproma ); + pfcqsng = (double*) malloc( sizeof(double) * nblocks*(nlev+1)*nproma ); + pfsqltur = (double*) malloc( sizeof(double) * nblocks*(nlev+1)*nproma ); + pfsqitur = (double*) malloc( sizeof(double) * nblocks*(nlev+1)*nproma ); + pfplsl = (double*) malloc( sizeof(double) * nblocks*(nlev+1)*nproma ); + pfplsn = (double*) malloc( sizeof(double) * nblocks*(nlev+1)*nproma ); + pfhpsl = (double*) malloc( sizeof(double) * nblocks*(nlev+1)*nproma ); + pfhpsn = (double*) malloc( sizeof(double) * nblocks*(nlev+1)*nproma ); + + + double rg; + double rd; + double rcpd; + double retv; + double rlvtt; + double rlstt; + double rlmlt; + double rtt; + double rv; + double r2es; + double r3les; + double r3ies; + double r4les; + double r4ies; + double r5les; + double r5ies; + double r5alvcp; + double r5alscp; + double ralvdcp; + double ralsdcp; + double ralfdcp; + double rtwat; + double rtice; + double rticecu; + double rtwat_rtice_r; + double rtwat_rticecu_r; + double rkoop1; + double rkoop2; + + // device declarations + double *d_plcrit_aer; + double *d_picrit_aer; + double *d_pre_ice; + double *d_pccn; + double *d_pnice; + double *d_pt; + double *d_pq; + double *d_tend_loc_t; + double *d_tend_loc_q; + double *d_tend_loc_a; + double *d_tend_loc_cld; + double *d_tend_tmp_t; + double *d_tend_tmp_q; + double *d_tend_tmp_a; + double *d_tend_tmp_cld; + double *d_pvfa; + double *d_pvfl; + double *d_pvfi; + double *d_pdyna; + double *d_pdynl; + double *d_pdyni; + double *d_phrsw; + double *d_phrlw; + double *d_pvervel; + double *d_pap; + double *d_paph; + double *d_plsm; + int *d_ktype; + double *d_plu; + double *d_plude; + double *d_psnde; + double *d_pmfu; + double *d_pmfd; + double *d_pa; + double *d_pclv; + double *d_psupsat; + struct TECLDP *d_yrecldp; + double *d_pcovptot; + double *d_prainfrac_toprfz; + double *d_pfsqlf; + double *d_pfsqif; + double *d_pfcqnng; + double *d_pfcqlng; + double *d_pfsqrf; + double *d_pfsqsf; + double *d_pfcqrng; + double *d_pfcqsng; + double *d_pfsqltur; + double *d_pfsqitur; + double *d_pfplsl; + double *d_pfplsn; + double *d_pfhpsl; + double *d_pfhpsn; + double *d_zfoealfa; + double *d_ztp1; + double *d_zli; + double *d_za; + double *d_zaorig; + double *d_zliqfrac; + double *d_zicefrac; + double *d_zqx; + double *d_zqx0; + double *d_zpfplsx; + double *d_zlneg; + double *d_zqxn2d; + double *d_zqsmix; + double *d_zqsliq; + double *d_zqsice; + double *d_zfoeewmt; + double *d_zfoeew; + double *d_zfoeeliqt; + // end device declarations + + // + hipMalloc(&d_plcrit_aer, sizeof(double) * nblocks*nlev*nproma); + hipMalloc(&d_picrit_aer, sizeof(double) * nblocks*nlev*nproma); + hipMalloc(&d_pre_ice, sizeof(double) * nblocks*nlev*nproma); + hipMalloc(&d_pccn, sizeof(double) * nblocks*nlev*nproma); + hipMalloc(&d_pnice, sizeof(double) * nblocks*nlev*nproma); + hipMalloc(&d_pt, sizeof(double) * nblocks*nlev*nproma); + hipMalloc(&d_pq, sizeof(double) * nblocks*nlev*nproma); + hipMalloc(&d_tend_loc_t, sizeof(double) * nblocks*nlev*nproma); + hipMalloc(&d_tend_loc_q, sizeof(double) * nblocks*nlev*nproma); + hipMalloc(&d_tend_loc_a, sizeof(double) * nblocks*nlev*nproma); + hipMalloc(&d_tend_loc_cld, sizeof(double) * nblocks*nlev*nproma*nclv); + hipMalloc(&d_tend_tmp_t, sizeof(double) * nblocks*nlev*nproma); + hipMalloc(&d_tend_tmp_q, sizeof(double) * nblocks*nlev*nproma); + hipMalloc(&d_tend_tmp_a, sizeof(double) * nblocks*nlev*nproma); + hipMalloc(&d_tend_tmp_cld, sizeof(double) * nblocks*nlev*nproma*nclv); + hipMalloc(&d_pvfa, sizeof(double) * nblocks*nlev*nproma); + hipMalloc(&d_pvfl, sizeof(double) * nblocks*nlev*nproma); + hipMalloc(&d_pvfi, sizeof(double) * nblocks*nlev*nproma); + hipMalloc(&d_pdyna, sizeof(double) * nblocks*nlev*nproma); + hipMalloc(&d_pdynl, sizeof(double) * nblocks*nlev*nproma); + hipMalloc(&d_pdyni, sizeof(double) * nblocks*nlev*nproma); + hipMalloc(&d_phrsw, sizeof(double) * nblocks*nlev*nproma); + hipMalloc(&d_phrlw, sizeof(double) * nblocks*nlev*nproma); + hipMalloc(&d_pvervel, sizeof(double) * nblocks*nlev*nproma); + hipMalloc(&d_pap, sizeof(double) * nblocks*nlev*nproma); + hipMalloc(&d_paph, sizeof(double) * nblocks*(nlev+1)*nproma); + hipMalloc(&d_plsm, sizeof(double) * nblocks*nproma); + hipMalloc(&d_ktype, sizeof(int) * nblocks*nproma); + hipMalloc(&d_plu, sizeof(double) * nblocks*nlev*nproma); + hipMalloc(&d_plude, sizeof(double) * nblocks*nlev*nproma); + hipMalloc(&d_psnde, sizeof(double) * nblocks*nlev*nproma); + hipMalloc(&d_pmfu, sizeof(double) * nblocks*nlev*nproma); + hipMalloc(&d_pmfd, sizeof(double) * nblocks*nlev*nproma); + hipMalloc(&d_pa, sizeof(double) * nblocks*nlev*nproma); + hipMalloc(&d_pclv, sizeof(double) * nblocks*nlev*nproma*nclv); + hipMalloc(&d_psupsat, sizeof(double) * nblocks*nlev*nproma); + hipMalloc(&d_yrecldp, sizeof(struct TECLDP)); + hipMalloc(&d_pcovptot, sizeof(double) * nblocks*nlev*nproma); + hipMalloc(&d_prainfrac_toprfz, sizeof(double) * nblocks*nproma); + hipMalloc(&d_pfsqlf, sizeof(double) * nblocks*(nlev+1)*nproma); + hipMalloc(&d_pfsqif, sizeof(double) * nblocks*(nlev+1)*nproma); + hipMalloc(&d_pfcqnng, sizeof(double) * nblocks*(nlev+1)*nproma); + hipMalloc(&d_pfcqlng, sizeof(double) * nblocks*(nlev+1)*nproma); + hipMalloc(&d_pfsqrf, sizeof(double) * nblocks*(nlev+1)*nproma); + hipMalloc(&d_pfsqsf, sizeof(double) * nblocks*(nlev+1)*nproma); + hipMalloc(&d_pfcqrng, sizeof(double) * nblocks*(nlev+1)*nproma); + hipMalloc(&d_pfcqsng, sizeof(double) * nblocks*(nlev+1)*nproma); + hipMalloc(&d_pfsqltur, sizeof(double) * nblocks*(nlev+1)*nproma); + hipMalloc(&d_pfsqitur, sizeof(double) * nblocks*(nlev+1)*nproma); + hipMalloc(&d_pfplsl, sizeof(double) * nblocks*(nlev+1)*nproma); + hipMalloc(&d_pfplsn, sizeof(double) * nblocks*(nlev+1)*nproma); + hipMalloc(&d_pfhpsl, sizeof(double) * nblocks*(nlev+1)*nproma); + hipMalloc(&d_pfhpsn, sizeof(double) * nblocks*(nlev+1)*nproma); + hipMalloc(&d_zfoealfa, sizeof(double) * nblocks*(nlev+1)*nproma); + hipMalloc(&d_ztp1, sizeof(double) * nblocks*(nlev+1)*nproma); + hipMalloc(&d_zli, sizeof(double) * nblocks*(nlev+1)*nproma); + hipMalloc(&d_za, sizeof(double) * nblocks*(nlev+1)*nproma); + hipMalloc(&d_zaorig, sizeof(double) * nblocks*(nlev+1)*nproma); + hipMalloc(&d_zliqfrac, sizeof(double) * nblocks*(nlev+1)*nproma); + hipMalloc(&d_zicefrac, sizeof(double) * nblocks*(nlev+1)*nproma); + hipMalloc(&d_zqx, sizeof(double) * nblocks*(nlev+1)*nproma*nclv); + hipMalloc(&d_zqx0, sizeof(double) * nblocks*(nlev+1)*nproma*nclv); + hipMalloc(&d_zpfplsx, sizeof(double) * nblocks*(nlev+1)*nproma*nclv); + hipMalloc(&d_zlneg, sizeof(double) * nblocks*(nlev+1)*nproma*nclv); + hipMalloc(&d_zqxn2d, sizeof(double) * nblocks*(nlev+1)*nproma*nclv); + hipMalloc(&d_zqsmix, sizeof(double) * nblocks*(nlev+1)*nproma); + hipMalloc(&d_zqsliq, sizeof(double) * nblocks*(nlev+1)*nproma); + hipMalloc(&d_zqsice, sizeof(double) * nblocks*(nlev+1)*nproma); + hipMalloc(&d_zfoeewmt, sizeof(double) * nblocks*(nlev+1)*nproma); + hipMalloc(&d_zfoeew, sizeof(double) * nblocks*(nlev+1)*nproma); + hipMalloc(&d_zfoeeliqt, sizeof(double) * nblocks*(nlev+1)*nproma); + // + + load_state(klon, nlev, nclv, numcols, nproma, &ptsphy, plcrit_aer, picrit_aer, + pre_ice, pccn, pnice, pt, pq, + tend_cml_t, tend_cml_q, tend_cml_a, tend_cml_cld, + tend_tmp_t, tend_tmp_q, tend_tmp_a, tend_tmp_cld, + pvfa, pvfl, pvfi, pdyna, pdynl, pdyni, + phrsw, phrlw, pvervel, pap, paph, plsm, ktype, plu, + plude, psnde, pmfu, pmfd, pa, pclv, psupsat, yrecldp, + &rg, &rd, &rcpd, &retv, &rlvtt, &rlstt, + &rlmlt, &rtt, &rv, &r2es, &r3les, &r3ies, + &r4les, &r4ies, &r5les, &r5ies, &r5alvcp, &r5alscp, + &ralvdcp, &ralsdcp, &ralfdcp, &rtwat, + &rtice, &rticecu, &rtwat_rtice_r, &rtwat_rticecu_r, + &rkoop1, &rkoop2 ); + + // host to device + hipMemcpy(d_plcrit_aer, plcrit_aer, sizeof(double) * nblocks*nlev*nproma, hipMemcpyHostToDevice); + hipMemcpy(d_picrit_aer, picrit_aer, sizeof(double) * nblocks*nlev*nproma, hipMemcpyHostToDevice); + hipMemcpy(d_pre_ice, pre_ice, sizeof(double) * nblocks*nlev*nproma, hipMemcpyHostToDevice); + hipMemcpy(d_pccn, pccn, sizeof(double) * nblocks*nlev*nproma, hipMemcpyHostToDevice); + hipMemcpy(d_pnice, pnice, sizeof(double) * nblocks*nlev*nproma, hipMemcpyHostToDevice); + hipMemcpy(d_pt, pt, sizeof(double) * nblocks*nlev*nproma, hipMemcpyHostToDevice); + hipMemcpy(d_pq, pq, sizeof(double) * nblocks*nlev*nproma, hipMemcpyHostToDevice); + hipMemcpy(d_tend_loc_t, tend_loc_t, sizeof(double) * nblocks*nlev*nproma, hipMemcpyHostToDevice); + hipMemcpy(d_tend_loc_q, tend_loc_q, sizeof(double) * nblocks*nlev*nproma, hipMemcpyHostToDevice); + hipMemcpy(d_tend_loc_a, tend_loc_a, sizeof(double) * nblocks*nlev*nproma, hipMemcpyHostToDevice); + hipMemcpy(d_tend_loc_cld, tend_loc_cld, sizeof(double) * nblocks*nlev*nproma*nclv, hipMemcpyHostToDevice); + hipMemcpy(d_tend_tmp_t, tend_tmp_t, sizeof(double) * nblocks*nlev*nproma, hipMemcpyHostToDevice); + hipMemcpy(d_tend_tmp_q, tend_tmp_q, sizeof(double) * nblocks*nlev*nproma, hipMemcpyHostToDevice); + hipMemcpy(d_tend_tmp_a, tend_tmp_a, sizeof(double) * nblocks*nlev*nproma, hipMemcpyHostToDevice); + hipMemcpy(d_tend_tmp_cld, tend_tmp_cld, sizeof(double) * nblocks*nlev*nproma*nclv, hipMemcpyHostToDevice); + hipMemcpy(d_pvfa, pvfa, sizeof(double) * nblocks*nlev*nproma, hipMemcpyHostToDevice); + hipMemcpy(d_pvfl, pvfl, sizeof(double) * nblocks*nlev*nproma, hipMemcpyHostToDevice); + hipMemcpy(d_pvfi, pvfi, sizeof(double) * nblocks*nlev*nproma, hipMemcpyHostToDevice); + hipMemcpy(d_pdyna, pdyna, sizeof(double) * nblocks*nlev*nproma, hipMemcpyHostToDevice); + hipMemcpy(d_pdynl, pdynl, sizeof(double) * nblocks*nlev*nproma, hipMemcpyHostToDevice); + hipMemcpy(d_pdyni, pdyni, sizeof(double) * nblocks*nlev*nproma, hipMemcpyHostToDevice); + hipMemcpy(d_phrsw, phrsw, sizeof(double) * nblocks*nlev*nproma, hipMemcpyHostToDevice); + hipMemcpy(d_phrlw, phrlw, sizeof(double) * nblocks*nlev*nproma, hipMemcpyHostToDevice); + hipMemcpy(d_pvervel, pvervel, sizeof(double) * nblocks*nlev*nproma, hipMemcpyHostToDevice); + hipMemcpy(d_pap, pap, sizeof(double) * nblocks*nlev*nproma, hipMemcpyHostToDevice); + hipMemcpy(d_paph, paph, sizeof(double) * nblocks*(nlev+1)*nproma, hipMemcpyHostToDevice); + hipMemcpy(d_plsm, plsm, sizeof(double) * nblocks*nproma, hipMemcpyHostToDevice); + hipMemcpy(d_ktype, ktype, sizeof(int) * nblocks*nproma, hipMemcpyHostToDevice); + hipMemcpy(d_plu, plu, sizeof(double) * nblocks*nlev*nproma, hipMemcpyHostToDevice); + hipMemcpy(d_plude, plude, sizeof(double) * nblocks*nlev*nproma, hipMemcpyHostToDevice); + hipMemcpy(d_psnde, psnde, sizeof(double) * nblocks*nlev*nproma, hipMemcpyHostToDevice); + hipMemcpy(d_pmfu, pmfu, sizeof(double) * nblocks*nlev*nproma, hipMemcpyHostToDevice); + hipMemcpy(d_pmfd, pmfd, sizeof(double) * nblocks*nlev*nproma, hipMemcpyHostToDevice); + hipMemcpy(d_pa, pa, sizeof(double) * nblocks*nlev*nproma, hipMemcpyHostToDevice); + hipMemcpy(d_pclv, pclv, sizeof(double) * nblocks*nlev*nproma*nclv, hipMemcpyHostToDevice); + hipMemcpy(d_psupsat, psupsat, sizeof(double) * nblocks*nlev*nproma, hipMemcpyHostToDevice); + hipMemcpy(d_yrecldp, yrecldp, sizeof(TECLDP), hipMemcpyHostToDevice); + // end host to device + + double t1 = omp_get_wtime(); + + int b, bsize, icalls=0, igpc=numcols; + int coreid = mycpu(); + int tid = omp_get_thread_num(); + double start = omp_get_wtime(); + + dim3 blockdim(nproma, 1, 1); + //dim3 griddim(1, 1, ceil(((double)numcols) / ((double)nproma))); + dim3 griddim(ceil(((double)numcols) / ((double)nproma)), 1, 1); + int jkglo = 0; + int ibl = (jkglo - 1) / nproma + 1; + int icend = min(nproma, numcols - jkglo + 1); + + cloudsc_c<<>>(1, icend/*bsize*/, nproma/*, nlev*/, ptsphy, d_pt, d_pq, + d_tend_tmp_t, d_tend_tmp_q, d_tend_tmp_a, d_tend_tmp_cld, + d_tend_loc_t, d_tend_loc_q, d_tend_loc_a, d_tend_loc_cld, + d_pvfa, d_pvfl, d_pvfi, + d_pdyna, d_pdynl, d_pdyni, + d_phrsw, d_phrlw, d_pvervel, + d_pap, d_paph, d_plsm, d_ktype, + d_plu, d_plude, d_psnde, d_pmfu, d_pmfd, + d_pa, d_pclv, d_psupsat, + d_plcrit_aer, d_picrit_aer, d_pre_ice, d_pccn, d_pnice, + d_pcovptot, d_prainfrac_toprfz, d_pfsqlf, + d_pfsqif, d_pfcqnng, d_pfcqlng, + d_pfsqrf, d_pfsqsf, d_pfcqrng, + d_pfcqsng, d_pfsqltur, d_pfsqitur, + d_pfplsl, d_pfplsn, d_pfhpsl, d_pfhpsn, d_yrecldp, + nblocks, rg, rd, rcpd, retv, rlvtt, rlstt, rlmlt, rtt, + rv, r2es, r3les, r3ies, r4les, r4ies, r5les, + r5ies, r5alvcp, r5alscp, ralvdcp, ralsdcp, ralfdcp, + rtwat, rtice, rticecu, rtwat_rtice_r, rtwat_rticecu_r, + rkoop1, rkoop2, + d_zfoealfa, d_ztp1, d_zli, + d_za, d_zaorig, d_zliqfrac, + d_zicefrac, d_zqx, d_zqx0, + d_zpfplsx, d_zlneg, d_zqxn2d, + d_zqsmix, d_zqsliq, d_zqsice, + d_zfoeewmt, d_zfoeew, d_zfoeeliqt); + + gpuErrchk( hipPeekAtLastError() ); + gpuErrchk( hipDeviceSynchronize() ); + + double end = omp_get_wtime(); + + // device to host + hipMemcpy(tend_loc_t, d_tend_loc_t, sizeof(double) * nblocks*nlev*nproma, hipMemcpyDeviceToHost); + hipMemcpy(tend_loc_q, d_tend_loc_q, sizeof(double) * nblocks*nlev*nproma, hipMemcpyDeviceToHost); + hipMemcpy(tend_loc_a, d_tend_loc_a, sizeof(double) * nblocks*nlev*nproma, hipMemcpyDeviceToHost); + hipMemcpy(tend_loc_cld, d_tend_loc_cld, sizeof(double) * nblocks*nlev*nproma*nclv, hipMemcpyDeviceToHost); + hipMemcpy(phrlw, d_phrlw, sizeof(double) * nblocks*nlev*nproma, hipMemcpyDeviceToHost); + hipMemcpy(plude, d_plude, sizeof(double) * nblocks*nlev*nproma, hipMemcpyDeviceToHost); + hipMemcpy(yrecldp, d_yrecldp, sizeof(TECLDP), hipMemcpyDeviceToHost); + hipMemcpy(pcovptot, d_pcovptot, sizeof(double) * nblocks*nlev*nproma, hipMemcpyDeviceToHost); + hipMemcpy(prainfrac_toprfz, d_prainfrac_toprfz, sizeof(double) * nblocks*nproma, hipMemcpyDeviceToHost); + hipMemcpy(pfsqlf, d_pfsqlf, sizeof(double) * nblocks*(nlev+1)*nproma, hipMemcpyDeviceToHost); + hipMemcpy(pfsqif, d_pfsqif, sizeof(double) * nblocks*(nlev+1)*nproma, hipMemcpyDeviceToHost); + hipMemcpy(pfcqnng, d_pfcqnng, sizeof(double) * nblocks*(nlev+1)*nproma, hipMemcpyDeviceToHost); + hipMemcpy(pfcqlng, d_pfcqlng, sizeof(double) * nblocks*(nlev+1)*nproma, hipMemcpyDeviceToHost); + hipMemcpy(pfsqrf, d_pfsqrf, sizeof(double) * nblocks*(nlev+1)*nproma, hipMemcpyDeviceToHost); + hipMemcpy(pfsqsf, d_pfsqsf, sizeof(double) * nblocks*(nlev+1)*nproma, hipMemcpyDeviceToHost); + hipMemcpy(pfcqrng, d_pfcqrng, sizeof(double) * nblocks*(nlev+1)*nproma, hipMemcpyDeviceToHost); + hipMemcpy(pfcqsng, d_pfcqsng, sizeof(double) * nblocks*(nlev+1)*nproma, hipMemcpyDeviceToHost); + hipMemcpy(pfsqltur, d_pfsqltur, sizeof(double) * nblocks*(nlev+1)*nproma, hipMemcpyDeviceToHost); + hipMemcpy(pfsqitur, d_pfsqitur, sizeof(double) * nblocks*(nlev+1)*nproma, hipMemcpyDeviceToHost); + hipMemcpy(pfplsl, d_pfplsl, sizeof(double) * nblocks*(nlev+1)*nproma, hipMemcpyDeviceToHost); + hipMemcpy(pfplsn, d_pfplsn, sizeof(double) * nblocks*(nlev+1)*nproma, hipMemcpyDeviceToHost); + hipMemcpy(pfhpsl, d_pfhpsl, sizeof(double) * nblocks*(nlev+1)*nproma, hipMemcpyDeviceToHost); + hipMemcpy(pfhpsn, d_pfhpsn, sizeof(double) * nblocks*(nlev+1)*nproma, hipMemcpyDeviceToHost); + + /* int msec = diff * 1000 / CLOCKS_PER_SEC; */ + zinfo[0][tid] = end - start; + zinfo[1][tid] = (double) coreid; + zinfo[2][tid] = (double) icalls; + zinfo[3][tid] = (double) igpc; + + double t2 = omp_get_wtime(); + + printf(" NUMOMP=%d, NGPTOT=%d, NPROMA=%d, NGPBLKS=%d\n", numthreads, numcols, nproma, nblocks); + printf(" %+10s%+10s%+10s%+10s%+10s %+4s : %+10s%+10s\n", + "NUMOMP", "NGPTOT", "#GP-cols", "#BLKS", "NPROMA", "tid#", "Time(msec)", "MFlops/s"); + double zfrac, zmflops; + for (int t = 0; t < numthreads; t++) { + const double tloc = zinfo[0][t]; + const int coreid = (int) zinfo[1][t]; + const int icalls = (int) zinfo[2][t]; + const int igpc = (int) zinfo[3][t]; + zfrac = (double)igpc / (double)numcols; + if (tloc > 0.0) { + zmflops = 1.0e-06 * zfrac * zhpm * ((double)numcols / 100.) / tloc; + } else { + zmflops = 0.; + } + printf(" %10d%10d%10d%10d%10d %4d : %10d%10d @ core#\n", + numthreads, numcols, igpc, icalls, nproma, t, (int)(tloc * 1000.), (int)zmflops); + } + double tdiff = t2 - t1; + zfrac = 1.0; + if (tdiff > 0.0) { + zmflops = 1.0e-06 * zfrac * zhpm * ((double)numcols / 100.) / tdiff; + } else { + zmflops = 0.0; + } + printf(" %10d%10d%10d%10d%10d %4d : %10d%10d TOTAL\n", + numthreads, numcols, numcols, nblocks, nproma, -1, (int)(tdiff * 1000.), (int)zmflops); + + cloudsc_validate(klon, nlev, nclv, numcols, nproma, + plude, pcovptot, prainfrac_toprfz, pfsqlf, pfsqif, + pfcqlng, pfcqnng, pfsqrf, pfsqsf, pfcqrng, pfcqsng, + pfsqltur, pfsqitur, pfplsl, pfplsn, pfhpsl, pfhpsn, + tend_loc_a, tend_loc_q, tend_loc_t, tend_loc_cld); + + free(plcrit_aer); + free(picrit_aer); + free(pre_ice); + free(pccn); + free(pnice); + free(pt); + free(pq); + free(pvfa); + free(pvfl); + free(pvfi); + free(pdyna); + free(pdynl); + free(pdyni); + free(phrsw); + free(phrlw); + free(pvervel); + free(pap); + free(paph); + free(plsm); + free(ktype); + free(plu); + free(plude); + free(psnde); + free(pmfu); + free(pmfd); + free(pa); + free(pclv); + free(psupsat); + free(pcovptot); + free(tend_loc_t); + free(tend_loc_q); + free(tend_loc_a); + free(tend_loc_cld); + free(tend_tmp_t); + free(tend_tmp_q); + free(tend_tmp_a); + free(tend_tmp_cld); + free(tend_cml_t); + free(tend_cml_q); + free(tend_cml_a); + free(tend_cml_cld); + free(prainfrac_toprfz); + free(pfsqlf); + free(pfsqif); + free(pfcqnng); + free(pfcqlng); + free(pfsqrf); + free(pfsqsf); + free(pfcqrng); + free(pfcqsng); + free(pfsqltur); + free(pfsqitur); + free(pfplsl); + free(pfplsn); + free(pfhpsl); + free(pfhpsn); + free(yrecldp); + + // free device + hipFree(d_plcrit_aer); + hipFree(d_picrit_aer); + hipFree(d_pre_ice); + hipFree(d_pccn); + hipFree(d_pnice); + hipFree(d_pt); + hipFree(d_pq); + hipFree(d_tend_loc_t); + hipFree(d_tend_loc_q); + hipFree(d_tend_loc_a); + hipFree(d_tend_loc_cld); + hipFree(d_tend_tmp_t); + hipFree(d_tend_tmp_q); + hipFree(d_tend_tmp_a); + hipFree(d_tend_tmp_cld); + hipFree(d_pvfa); + hipFree(d_pvfl); + hipFree(d_pvfi); + hipFree(d_pdyna); + hipFree(d_pdynl); + hipFree(d_pdyni); + hipFree(d_phrsw); + hipFree(d_phrlw); + hipFree(d_pvervel); + hipFree(d_pap); + hipFree(d_paph); + hipFree(d_plsm); + hipFree(d_ktype); + hipFree(d_plu); + hipFree(d_plude); + hipFree(d_psnde); + hipFree(d_pmfu); + hipFree(d_pmfd); + hipFree(d_pa); + hipFree(d_pclv); + hipFree(d_psupsat); + hipFree(d_yrecldp); + hipFree(d_pcovptot); + hipFree(d_prainfrac_toprfz); + hipFree(d_pfsqlf); + hipFree(d_pfsqif); + hipFree(d_pfcqnng); + hipFree(d_pfcqlng); + hipFree(d_pfsqrf); + hipFree(d_pfsqsf); + hipFree(d_pfcqrng); + hipFree(d_pfcqsng); + hipFree(d_pfsqltur); + hipFree(d_pfsqitur); + hipFree(d_pfplsl); + hipFree(d_pfplsn); + hipFree(d_pfhpsl); + hipFree(d_pfhpsn); + hipFree(d_zfoealfa); + hipFree(d_ztp1); + hipFree(d_zli); + hipFree(d_za); + hipFree(d_zaorig); + hipFree(d_zliqfrac); + hipFree(d_zicefrac); + hipFree(d_zqx); + hipFree(d_zqx0); + hipFree(d_zpfplsx); + hipFree(d_zlneg); + hipFree(d_zqxn2d); + hipFree(d_zqsmix); + hipFree(d_zqsliq); + hipFree(d_zqsice); + hipFree(d_zfoeewmt); + hipFree(d_zfoeew); + hipFree(d_zfoeeliqt); + // end free device +} + diff --git a/src/cloudsc_hip/cloudsc/cloudsc_driver_hoist.h b/src/cloudsc_hip/cloudsc/cloudsc_driver_hoist.h new file mode 100644 index 00000000..aca23ab7 --- /dev/null +++ b/src/cloudsc_hip/cloudsc/cloudsc_driver_hoist.h @@ -0,0 +1,23 @@ +/* + * (C) Copyright 1988- ECMWF. + * + * This software is licensed under the terms of the Apache Licence Version 2.0 + * which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. + * In applying this licence, ECMWF does not waive the privileges and immunities + * granted to it by virtue of its status as an intergovernmental organisation + * nor does it submit to any jurisdiction. + */ + +#include +#include +#include +#include +#include "hip/hip_runtime.h" +#include "hip/hip_runtime.h" + +#include "yoecldp_c.h" +#include "load_state.h" +#include "cloudsc_c_hoist.h" +#include "cloudsc_validate.h" + +void cloudsc_driver(int numthreads, int numcols, int nproma); diff --git a/src/cloudsc_hip/cloudsc/cloudsc_validate.cpp b/src/cloudsc_hip/cloudsc/cloudsc_validate.cpp new file mode 100644 index 00000000..79566e43 --- /dev/null +++ b/src/cloudsc_hip/cloudsc/cloudsc_validate.cpp @@ -0,0 +1,244 @@ +/* + * (C) Copyright 1988- ECMWF. + * + * This software is licensed under the terms of the Apache Licence Version 2.0 + * which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. + * In applying this licence, ECMWF does not waive the privileges and immunities + * granted to it by virtue of its status as an intergovernmental organisation + * nor does it submit to any jurisdiction. + */ + +#include "cloudsc_validate.h" + +#include +#include + +#define min(a, b) (((a) < (b)) ? (a) : (b)) +#define max(a, b) (((a) > (b)) ? (a) : (b)) + + +void print_error(const char *name, double zminval, double zmaxval, double zmaxerr, + double zerrsum, double zsum, double zavgpgp, int ndim) +{ + double zrelerr, zeps = DBL_EPSILON; + int iopt = 0; + if (zerrsum < zeps) { + zrelerr = 0.0; + iopt = 1; + } else if (zsum < zeps) { + zrelerr = zerrsum / (1.0 + zsum); + iopt = 2; + } else { + zrelerr = zerrsum / zsum; + iopt = 3; + } + + //-- If you get 4 exclamation marks next to your error output, + // then it is likely that some uninitialized variables exists or + // some other screw-up -- watch out this !!!! + //char *clwarn; + const char* clwarn = (zrelerr > 10.0 * zeps) ? " !!!!" : " "; + zrelerr = 100.0 * zrelerr; + + printf(" %+20s %dD%d %20.13le %20.13le %20.13le %20.13le %20.13le %s\n", + name, ndim, iopt, zminval, zmaxval, zmaxerr, zavgpgp, zrelerr, clwarn); +} + + +void validate_1d(const char *name, double * v_ref, double * v_field, int nlon, int ngptot, int nblocks) +{ + /* Computes and prints errors in the "L2 norm sense" */ + int b, bsize, jk; + double zminval, zmaxval, zdiff, zmaxerr, zerrsum, zsum, zrelerr, zavgpgp; + //double (*field)[nlon] = (double (*)[nlon]) v_field; + //double (*reference)[nlon] = (double (*)[nlon]) v_ref; + + zminval = +DBL_MAX; + zmaxval = -DBL_MAX; + zmaxerr = 0.0; + zerrsum = 0.0; + zsum = 0.0; + +// #pragma omp parallel for default(shared) private(b, bsize, jk) \ +// reduction(min:zminval) reduction(max:zmaxval,zmaxerr) reduction(+:zerrsum,zsum) + for (b = 0; b < nblocks; b++) { + bsize = min(nlon, ngptot - b*nlon); // field block size + for (jk = 0; jk < bsize; jk++) { + zminval = fmin(zminval, v_field[b*nlon+jk]); + zmaxval = fmax(zmaxval, v_field[b*nlon+jk]); + + // Difference against reference result in one-norm sense + zdiff = fabs(v_field[b*nlon+jk] - v_ref[b*nlon+jk]); + zmaxerr = fmax(zmaxerr, zdiff); + zerrsum = zerrsum + zdiff; + zsum = zsum + abs(v_ref[b*nlon+jk]); + } + } + zavgpgp = zerrsum / (double) ngptot; + print_error(name, zminval, zmaxval, zmaxerr, zerrsum, zsum, zavgpgp, 2); +} + + +void validate_2d(const char *name, double *v_ref, double *v_field, int nlon, int nlev, int ngptot, int nblocks) +{ + /* Computes and prints errors in the "L2 norm sense" */ + int b, bsize, jl, jk; + double zminval, zmaxval, zdiff, zmaxerr, zerrsum, zsum, zrelerr, zavgpgp; +// double (*field)[nlev][nlon] = (double (*)[nlev][nlon]) v_field; +// double (*reference)[nlev][nlon] = (double (*)[nlev][nlon]) v_ref; + + zminval = +DBL_MAX; + zmaxval = -DBL_MAX; + zmaxerr = 0.0; + zerrsum = 0.0; + zsum = 0.0; + +// #pragma omp parallel for default(shared) private(b, bsize, jl, jk) \ +// reduction(min:zminval) reduction(max:zmaxval,zmaxerr) reduction(+:zerrsum,zsum) + + for (b = 0; b < nblocks; b++) { + bsize = min(nlon, ngptot - b*nlon); // field block size + for (jl = 0; jl < nlev; jl++) { + for (jk = 0; jk < bsize; jk++) { + zminval = fmin(zminval, v_field[b*nlev*nlon+jl*nlon+jk]); + zmaxval = fmax(zmaxval, v_field[b*nlev*nlon+jl*nlon+jk]); + + // Difference against reference result in one-norm sense + zdiff = fabs(v_field[b*nlev*nlon+jl*nlon+jk] - v_ref[b*nlev*nlon+jl*nlon+jk]); + zmaxerr = fmax(zmaxerr, zdiff); + zerrsum = zerrsum + zdiff; + zsum = zsum + abs(v_ref[b*nlev*nlon+jl*nlon+jk]); + } + } + } + + zavgpgp = zerrsum / (double) ngptot; + print_error(name, zminval, zmaxval, zmaxerr, zerrsum, zsum, zavgpgp, 2); +} + + +void validate_3d(const char *name, double *v_ref, double *v_field, int nlon, + int nlev, int nclv, int ngptot, int nblocks) +{ + /* Computes and prints errors in the "L2 norm sense" */ + int b, bsize, jl, jk, jm; + double zminval, zmaxval, zdiff, zmaxerr, zerrsum, zsum, zrelerr, zavgpgp; +// double (*field)[nclv][nlev][nlon] = (double (*)[nclv][nlev][nlon]) v_field; +// double (*reference)[nclv][nlev][nlon] = (double (*)[nclv][nlev][nlon]) v_ref; + + zminval = +DBL_MAX; + zmaxval = -DBL_MAX; + zmaxerr = 0.0; + zerrsum = 0.0; + zsum = 0.0; + +// #pragma omp parallel for default(shared) private(b, bsize, jl, jk, jm) \ +// reduction(min:zminval) reduction(max:zmaxval,zmaxerr) reduction(+:zerrsum,zsum) + for (b = 0; b < nblocks; b++) { + bsize = min(nlon, ngptot - b*nlon); // field block size + for (jm = 0; jm < nclv; jm++) { + for (jl = 0; jl < nlev; jl++) { + for (jk = 0; jk < bsize; jk++) { + zminval = fmin(zminval, v_field[b*nclv*nlev*nlon+jm*nlev*nlon+jl*nlon+jk]); + zmaxval = fmax(zmaxval, v_field[b*nclv*nlev*nlon+jm*nlev*nlon+jl*nlon+jk]); + + // Difference against reference result in one-norm sense + zdiff = fabs(v_field[b*nclv*nlev*nlon+jm*nlev*nlon+jl*nlon+jk] - v_ref[b*nclv*nlev*nlon+jm*nlev*nlon+jl*nlon+jk]); + zmaxerr = fmax(zmaxerr, zdiff); + zerrsum = zerrsum + zdiff; + zsum = zsum + abs(v_ref[b*nclv*nlev*nlon+jm*nlev*nlon+jl*nlon+jk]); + } + } + } + } + zavgpgp = zerrsum / (double) ngptot; + print_error(name, zminval, zmaxval, zmaxerr, zerrsum, zsum, zavgpgp, 2); +} + + +int cloudsc_validate(const int nlon, const int nlev, const int nclv, const int ngptot, const int nproma, + double *plude, double *pcovptot, double *prainfrac_toprfz, double *pfsqlf, double *pfsqif, + double *pfcqlng, double *pfcqnng, double *pfsqrf, double *pfsqsf, double *pfcqrng, double *pfcqsng, + double *pfsqltur, double *pfsqitur, double *pfplsl, double *pfplsn, double *pfhpsl, double *pfhpsn, + double *tend_loc_a, double *tend_loc_q, double *tend_loc_t, double *tend_loc_cld) +{ + const int nblocks = (ngptot / nproma) + min(ngptot % nproma, 1); + double *ref_plude = (double*) malloc( sizeof(double) * nblocks*nlev*nproma ); + double *ref_pcovptot = (double*) malloc( sizeof(double) * nblocks*nlev*nproma ); + double *ref_prainfrac_toprfz = (double*) malloc( sizeof(double) * nblocks*nproma ); + double *ref_pfsqlf = (double*) malloc( sizeof(double) * nblocks*(nlev+1)*nproma ); + double *ref_pfsqif = (double*) malloc( sizeof(double) * nblocks*(nlev+1)*nproma ); + double *ref_pfcqlng = (double*) malloc( sizeof(double) * nblocks*(nlev+1)*nproma ); + double *ref_pfcqnng = (double*) malloc( sizeof(double) * nblocks*(nlev+1)*nproma ); + double *ref_pfsqrf = (double*) malloc( sizeof(double) * nblocks*(nlev+1)*nproma ); + double *ref_pfsqsf = (double*) malloc( sizeof(double) * nblocks*(nlev+1)*nproma ); + double *ref_pfcqrng = (double*) malloc( sizeof(double) * nblocks*(nlev+1)*nproma ); + double *ref_pfcqsng = (double*) malloc( sizeof(double) * nblocks*(nlev+1)*nproma ); + double *ref_pfsqltur = (double*) malloc( sizeof(double) * nblocks*(nlev+1)*nproma ); + double *ref_pfsqitur = (double*) malloc( sizeof(double) * nblocks*(nlev+1)*nproma ); + double *ref_pfplsl = (double*) malloc( sizeof(double) * nblocks*(nlev+1)*nproma ); + double *ref_pfplsn = (double*) malloc( sizeof(double) * nblocks*(nlev+1)*nproma ); + double *ref_pfhpsl = (double*) malloc( sizeof(double) * nblocks*(nlev+1)*nproma ); + double *ref_pfhpsn = (double*) malloc( sizeof(double) * nblocks*(nlev+1)*nproma ); + double *ref_tend_loc_a = (double*) malloc( sizeof(double) * nblocks*nlev*nproma ); + double *ref_tend_loc_q = (double*) malloc( sizeof(double) * nblocks*nlev*nproma ); + double *ref_tend_loc_t = (double*) malloc( sizeof(double) * nblocks*nlev*nproma ); + double *ref_tend_loc_cld = (double*) malloc( sizeof(double) * nblocks*nclv*nlev*nproma ); + + load_reference(nlon, nlev, nclv, ngptot, nproma, + ref_plude, ref_pcovptot, ref_prainfrac_toprfz, ref_pfsqlf, ref_pfsqif, + ref_pfcqlng, ref_pfcqnng, ref_pfsqrf, ref_pfsqsf, ref_pfcqrng, ref_pfcqsng, + ref_pfsqltur, ref_pfsqitur, ref_pfplsl, ref_pfplsn, ref_pfhpsl, ref_pfhpsn, + ref_tend_loc_a, ref_tend_loc_q, ref_tend_loc_t, ref_tend_loc_cld); + + + printf(" %+20s %s %+20s %+20s %+20s %+20s %+20s\n", + "Variable", "Dim", "MinValue", "MaxValue", "AbsMaxErr", "AvgAbsErr/GP", "MaxRelErr-%"); + + validate_2d("PLUDE", ref_plude, plude, nproma, nlev, ngptot, nblocks); + validate_2d("PCOVPTOT", ref_pcovptot, pcovptot, nproma, nlev, ngptot, nblocks); + validate_1d("PRAINFRAC_TOPRFZ", ref_prainfrac_toprfz, prainfrac_toprfz, nproma, ngptot, nblocks); + validate_2d("PFSQLF", ref_pfsqlf, pfsqlf, nproma, nlev+1, ngptot, nblocks); + validate_2d("PFSQIF", ref_pfsqif, pfsqif, nproma, nlev+1, ngptot, nblocks); + validate_2d("PFCQLNG", ref_pfcqlng, pfcqlng, nproma, nlev+1, ngptot, nblocks); + validate_2d("PFCQNNG", ref_pfcqnng, pfcqnng, nproma, nlev+1, ngptot, nblocks); + validate_2d("PFSQRF", ref_pfsqrf, pfsqrf, nproma, nlev+1, ngptot, nblocks); + validate_2d("PFSQSF", ref_pfsqsf, pfsqsf, nproma, nlev+1, ngptot, nblocks); + validate_2d("PFCQRNG", ref_pfcqrng, pfcqrng, nproma, nlev+1, ngptot, nblocks); + validate_2d("PFCQSNG", ref_pfcqsng, pfcqsng, nproma, nlev+1, ngptot, nblocks); + validate_2d("PFSQLTUR", ref_pfsqltur, pfsqltur, nproma, nlev+1, ngptot, nblocks); + validate_2d("PFSQITUR", ref_pfsqitur, pfsqitur, nproma, nlev+1, ngptot, nblocks); + validate_2d("PFPLSL", ref_pfplsl, pfplsl, nproma, nlev+1, ngptot, nblocks); + validate_2d("PFPLSN", ref_pfplsn, pfplsn, nproma, nlev+1, ngptot, nblocks); + validate_2d("PFHPSL", ref_pfhpsl, pfhpsl, nproma, nlev+1, ngptot, nblocks); + validate_2d("PFHPSN", ref_pfhpsn, pfhpsn, nproma, nlev+1, ngptot, nblocks); + validate_2d("TENDENCY_LOC%A", ref_tend_loc_a, tend_loc_a, nproma, nlev, ngptot, nblocks); + validate_2d("TENDENCY_LOC%Q", ref_tend_loc_q, tend_loc_q, nproma, nlev, ngptot, nblocks); + validate_2d("TENDENCY_LOC%T", ref_tend_loc_t, tend_loc_t, nproma, nlev, ngptot, nblocks); + validate_3d("TENDENCY_LOC%CLD", ref_tend_loc_cld, tend_loc_cld, nproma, nlev, nclv, ngptot, nblocks); + + free(ref_plude); + free(ref_pcovptot); + free(ref_prainfrac_toprfz); + free(ref_pfsqlf); + free(ref_pfsqif); + free(ref_pfcqlng); + free(ref_pfcqnng); + free(ref_pfsqrf); + free(ref_pfsqsf); + free(ref_pfcqrng); + free(ref_pfcqsng); + free(ref_pfsqltur); + free(ref_pfsqitur); + free(ref_pfplsl); + free(ref_pfplsn); + free(ref_pfhpsl); + free(ref_pfhpsn); + free(ref_tend_loc_a); + free(ref_tend_loc_q); + free(ref_tend_loc_t); + free(ref_tend_loc_cld); + + return 0; + +} diff --git a/src/cloudsc_hip/cloudsc/cloudsc_validate.h b/src/cloudsc_hip/cloudsc/cloudsc_validate.h new file mode 100644 index 00000000..155b4274 --- /dev/null +++ b/src/cloudsc_hip/cloudsc/cloudsc_validate.h @@ -0,0 +1,17 @@ +/* + * (C) Copyright 1988- ECMWF. + * + * This software is licensed under the terms of the Apache Licence Version 2.0 + * which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. + * In applying this licence, ECMWF does not waive the privileges and immunities + * granted to it by virtue of its status as an intergovernmental organisation + * nor does it submit to any jurisdiction. + */ + +#include "load_state.h" + +int cloudsc_validate(const int nlon, const int nlev, const int nclv, const int ngptot, const int nproma, + double *plude, double *pcovptot, double *prainfrac_toprfz, double *pfsqlf, double *pfsqif, + double *pfcqlng, double *pfcqnng, double *pfsqrf, double *pfsqsf, double *pfcqrng, double *pfcqsng, + double *pfsqltur, double *pfsqitur, double *pfplsl, double *pfplsn, double *pfhpsl, double *pfhpsn, + double *tend_loc_a, double *tend_loc_q, double *tend_loc_t, double *tend_loc_cld); diff --git a/src/cloudsc_hip/cloudsc/load_state.cpp b/src/cloudsc_hip/cloudsc/load_state.cpp new file mode 100644 index 00000000..38fc148f --- /dev/null +++ b/src/cloudsc_hip/cloudsc/load_state.cpp @@ -0,0 +1,447 @@ +#include "load_state.h" +//#include "yomcst_c.hpp" +#include + +#include +#include "serialbox-c/Serialbox.h" + +#define min(a, b) (((a) < (b)) ? (a) : (b)) +#define max(a, b) (((a) > (b)) ? (a) : (b)) + +/* Query sizes and dimensions of state arrays */ +void query_state(int *klon, int *klev) +{ + serialboxSerializer_t* serializer = serialboxSerializerCreate(Read, "./data", "input", "Binary"); + serialboxMetainfo_t* globalMetainfo = serialboxSerializerGetGlobalMetainfo(serializer); + + *klon = serialboxMetainfoGetInt32(globalMetainfo, "KLON"); + *klev = serialboxMetainfoGetInt32(globalMetainfo, "KLEV"); + + serialboxMetainfoDestroy(globalMetainfo); + serialboxSerializerDestroy(serializer); +} + +void expand_1d(double *buffer, double *field_in, int nlon, int nproma, int ngptot, int nblocks) +{ + int gidx, bsize, bidx, bend, fsize, b, l, i; + + #pragma omp parallel for default(shared) private(gidx, bsize, bidx, bend, fsize, b, l, i) + for (b = 0; b < nblocks; b++) { + gidx = b*nproma; // Global starting index of the block in the general domain + bsize = min(nproma, ngptot - gidx); // Size of the field block + bidx = gidx % nlon; // Rolling index into the input buffer + bend = min(bidx+bsize, nlon); // Idealised final index in the input buffer + + if (bend-bidx < bsize) { + // The input buffer does not hold enough data to fill field block; + // we need to fill the rest of the block with data from front of buffer. + fsize = nlon - bidx; + for (i = 0; i < fsize; i++) { field_in[b*nproma+i] = buffer[bidx + i]; } + for (i = 0; i < bsize-fsize; i++) { field_in[b*nproma+fsize+i] = buffer[i]; } + } else { + // Simply copy a block of data from the rolling buffer index + for (i = 0; i < bsize; i++) { field_in[b*nproma+i] = buffer[bidx+i]; } + } + // Zero out the remainder of last block + for (i=bsize; iramid = serialboxMetainfoGetFloat64(metainfo, "YRECLDP_RAMID"); + yrecldp->rcldiff = serialboxMetainfoGetFloat64(metainfo, "YRECLDP_RCLDIFF"); + yrecldp->rcldiff_convi = serialboxMetainfoGetFloat64(metainfo, "YRECLDP_RCLDIFF_CONVI"); + yrecldp->rclcrit = serialboxMetainfoGetFloat64(metainfo, "YRECLDP_RCLCRIT"); + yrecldp->rclcrit_sea = serialboxMetainfoGetFloat64(metainfo, "YRECLDP_RCLCRIT_SEA"); + yrecldp->rclcrit_land = serialboxMetainfoGetFloat64(metainfo, "YRECLDP_RCLCRIT_LAND"); + yrecldp->rkconv = serialboxMetainfoGetFloat64(metainfo, "YRECLDP_RKCONV"); + yrecldp->rprc1 = serialboxMetainfoGetFloat64(metainfo, "YRECLDP_RPRC1"); + yrecldp->rprc2 = serialboxMetainfoGetFloat64(metainfo, "YRECLDP_RPRC2"); + yrecldp->rcldmax = serialboxMetainfoGetFloat64(metainfo, "YRECLDP_RCLDMAX"); + yrecldp->rpecons = serialboxMetainfoGetFloat64(metainfo, "YRECLDP_RPECONS"); + yrecldp->rvrfactor = serialboxMetainfoGetFloat64(metainfo, "YRECLDP_RVRFACTOR"); + yrecldp->rprecrhmax = serialboxMetainfoGetFloat64(metainfo, "YRECLDP_RPRECRHMAX"); + yrecldp->rtaumel = serialboxMetainfoGetFloat64(metainfo, "YRECLDP_RTAUMEL"); + yrecldp->ramin = serialboxMetainfoGetFloat64(metainfo, "YRECLDP_RAMIN"); + yrecldp->rlmin = serialboxMetainfoGetFloat64(metainfo, "YRECLDP_RLMIN"); + yrecldp->rkooptau = serialboxMetainfoGetFloat64(metainfo, "YRECLDP_RKOOPTAU"); + + yrecldp->rcldtopp = serialboxMetainfoGetFloat64(metainfo, "YRECLDP_RCLDTOPP"); + yrecldp->rlcritsnow = serialboxMetainfoGetFloat64(metainfo, "YRECLDP_RLCRITSNOW"); + yrecldp->rsnowlin1 = serialboxMetainfoGetFloat64(metainfo, "YRECLDP_RSNOWLIN1"); + yrecldp->rsnowlin2 = serialboxMetainfoGetFloat64(metainfo, "YRECLDP_RSNOWLIN2"); + yrecldp->ricehi1 = serialboxMetainfoGetFloat64(metainfo, "YRECLDP_RICEHI1"); + yrecldp->ricehi2 = serialboxMetainfoGetFloat64(metainfo, "YRECLDP_RICEHI2"); + yrecldp->riceinit = serialboxMetainfoGetFloat64(metainfo, "YRECLDP_RICEINIT"); + yrecldp->rvice = serialboxMetainfoGetFloat64(metainfo, "YRECLDP_RVICE"); + yrecldp->rvrain = serialboxMetainfoGetFloat64(metainfo, "YRECLDP_RVRAIN"); + yrecldp->rvsnow = serialboxMetainfoGetFloat64(metainfo, "YRECLDP_RVSNOW"); + yrecldp->rthomo = serialboxMetainfoGetFloat64(metainfo, "YRECLDP_RTHOMO"); + yrecldp->rcovpmin = serialboxMetainfoGetFloat64(metainfo, "YRECLDP_RCOVPMIN"); + yrecldp->rccn = serialboxMetainfoGetFloat64(metainfo, "YRECLDP_RCCN"); + yrecldp->rnice = serialboxMetainfoGetFloat64(metainfo, "YRECLDP_RNICE"); + yrecldp->rccnom = serialboxMetainfoGetFloat64(metainfo, "YRECLDP_RCCNOM"); + yrecldp->rccnss = serialboxMetainfoGetFloat64(metainfo, "YRECLDP_RCCNSS"); + yrecldp->rccnsu = serialboxMetainfoGetFloat64(metainfo, "YRECLDP_RCCNSU"); + yrecldp->rcldtopcf = serialboxMetainfoGetFloat64(metainfo, "YRECLDP_RCLDTOPCF"); + yrecldp->rdepliqrefrate = serialboxMetainfoGetFloat64(metainfo, "YRECLDP_RDEPLIQREFRATE"); + yrecldp->rdepliqrefdepth = serialboxMetainfoGetFloat64(metainfo, "YRECLDP_RDEPLIQREFDEPTH"); + yrecldp->rcl_kkaac = serialboxMetainfoGetFloat64(metainfo, "YRECLDP_RCL_KKAac"); + yrecldp->rcl_kkbac = serialboxMetainfoGetFloat64(metainfo, "YRECLDP_RCL_KKBac"); + yrecldp->rcl_kkaau = serialboxMetainfoGetFloat64(metainfo, "YRECLDP_RCL_KKAau"); + yrecldp->rcl_kkbauq = serialboxMetainfoGetFloat64(metainfo, "YRECLDP_RCL_KKBauq"); + yrecldp->rcl_kkbaun = serialboxMetainfoGetFloat64(metainfo, "YRECLDP_RCL_KKBaun"); + yrecldp->rcl_kk_cloud_num_sea = serialboxMetainfoGetFloat64(metainfo, "YRECLDP_RCL_KK_cloud_num_sea"); + yrecldp->rcl_kk_cloud_num_land = serialboxMetainfoGetFloat64(metainfo, "YRECLDP_RCL_KK_cloud_num_land"); + yrecldp->rcl_ai = serialboxMetainfoGetFloat64(metainfo, "YRECLDP_RCL_AI"); + yrecldp->rcl_bi = serialboxMetainfoGetFloat64(metainfo, "YRECLDP_RCL_BI"); + yrecldp->rcl_ci = serialboxMetainfoGetFloat64(metainfo, "YRECLDP_RCL_CI"); + yrecldp->rcl_di = serialboxMetainfoGetFloat64(metainfo, "YRECLDP_RCL_DI"); + yrecldp->rcl_x1i = serialboxMetainfoGetFloat64(metainfo, "YRECLDP_RCL_X1I"); + yrecldp->rcl_x2i = serialboxMetainfoGetFloat64(metainfo, "YRECLDP_RCL_X2I"); + yrecldp->rcl_x3i = serialboxMetainfoGetFloat64(metainfo, "YRECLDP_RCL_X3I"); + yrecldp->rcl_x4i = serialboxMetainfoGetFloat64(metainfo, "YRECLDP_RCL_X4I"); + yrecldp->rcl_const1i = serialboxMetainfoGetFloat64(metainfo, "YRECLDP_RCL_CONST1I"); + yrecldp->rcl_const2i = serialboxMetainfoGetFloat64(metainfo, "YRECLDP_RCL_CONST2I"); + yrecldp->rcl_const3i = serialboxMetainfoGetFloat64(metainfo, "YRECLDP_RCL_CONST3I"); + yrecldp->rcl_const4i = serialboxMetainfoGetFloat64(metainfo, "YRECLDP_RCL_CONST4I"); + yrecldp->rcl_const5i = serialboxMetainfoGetFloat64(metainfo, "YRECLDP_RCL_CONST5I"); + yrecldp->rcl_const6i = serialboxMetainfoGetFloat64(metainfo, "YRECLDP_RCL_CONST6I"); + yrecldp->rcl_apb1 = serialboxMetainfoGetFloat64(metainfo, "YRECLDP_RCL_APB1"); + yrecldp->rcl_apb2 = serialboxMetainfoGetFloat64(metainfo, "YRECLDP_RCL_APB2"); + yrecldp->rcl_apb3 = serialboxMetainfoGetFloat64(metainfo, "YRECLDP_RCL_APB3"); + yrecldp->rcl_as = serialboxMetainfoGetFloat64(metainfo, "YRECLDP_RCL_AS"); + yrecldp->rcl_bs = serialboxMetainfoGetFloat64(metainfo, "YRECLDP_RCL_BS"); + yrecldp->rcl_cs = serialboxMetainfoGetFloat64(metainfo, "YRECLDP_RCL_CS"); + yrecldp->rcl_ds = serialboxMetainfoGetFloat64(metainfo, "YRECLDP_RCL_DS"); + yrecldp->rcl_x1s = serialboxMetainfoGetFloat64(metainfo, "YRECLDP_RCL_X1S"); + yrecldp->rcl_x2s = serialboxMetainfoGetFloat64(metainfo, "YRECLDP_RCL_X2S"); + yrecldp->rcl_x3s = serialboxMetainfoGetFloat64(metainfo, "YRECLDP_RCL_X3S"); + yrecldp->rcl_x4s = serialboxMetainfoGetFloat64(metainfo, "YRECLDP_RCL_X4S"); + yrecldp->rcl_const1s = serialboxMetainfoGetFloat64(metainfo, "YRECLDP_RCL_CONST1S"); + yrecldp->rcl_const2s = serialboxMetainfoGetFloat64(metainfo, "YRECLDP_RCL_CONST2S"); + yrecldp->rcl_const3s = serialboxMetainfoGetFloat64(metainfo, "YRECLDP_RCL_CONST3S"); + yrecldp->rcl_const4s = serialboxMetainfoGetFloat64(metainfo, "YRECLDP_RCL_CONST4S"); + yrecldp->rcl_const5s = serialboxMetainfoGetFloat64(metainfo, "YRECLDP_RCL_CONST5S"); + yrecldp->rcl_const6s = serialboxMetainfoGetFloat64(metainfo, "YRECLDP_RCL_CONST6S"); + yrecldp->rcl_const7s = serialboxMetainfoGetFloat64(metainfo, "YRECLDP_RCL_CONST7S"); + yrecldp->rcl_const8s = serialboxMetainfoGetFloat64(metainfo, "YRECLDP_RCL_CONST8S"); + yrecldp->rdenswat = serialboxMetainfoGetFloat64(metainfo, "YRECLDP_RDENSWAT"); + yrecldp->rdensref = serialboxMetainfoGetFloat64(metainfo, "YRECLDP_RDENSREF"); + yrecldp->rcl_ar = serialboxMetainfoGetFloat64(metainfo, "YRECLDP_RCL_AR"); + yrecldp->rcl_br = serialboxMetainfoGetFloat64(metainfo, "YRECLDP_RCL_BR"); + yrecldp->rcl_cr = serialboxMetainfoGetFloat64(metainfo, "YRECLDP_RCL_CR"); + yrecldp->rcl_dr = serialboxMetainfoGetFloat64(metainfo, "YRECLDP_RCL_DR"); + yrecldp->rcl_x1r = serialboxMetainfoGetFloat64(metainfo, "YRECLDP_RCL_X1R"); + yrecldp->rcl_x2r = serialboxMetainfoGetFloat64(metainfo, "YRECLDP_RCL_X2R"); + yrecldp->rcl_x4r = serialboxMetainfoGetFloat64(metainfo, "YRECLDP_RCL_X4R"); + yrecldp->rcl_ka273 = serialboxMetainfoGetFloat64(metainfo, "YRECLDP_RCL_KA273"); + yrecldp->rcl_cdenom1 = serialboxMetainfoGetFloat64(metainfo, "YRECLDP_RCL_CDENOM1"); + yrecldp->rcl_cdenom2 = serialboxMetainfoGetFloat64(metainfo, "YRECLDP_RCL_CDENOM2"); + yrecldp->rcl_cdenom3 = serialboxMetainfoGetFloat64(metainfo, "YRECLDP_RCL_CDENOM3"); + yrecldp->rcl_schmidt = serialboxMetainfoGetFloat64(metainfo, "YRECLDP_RCL_SCHMIDT"); + yrecldp->rcl_dynvisc = serialboxMetainfoGetFloat64(metainfo, "YRECLDP_RCL_DYNVISC"); + yrecldp->rcl_const1r = serialboxMetainfoGetFloat64(metainfo, "YRECLDP_RCL_CONST1R"); + yrecldp->rcl_const2r = serialboxMetainfoGetFloat64(metainfo, "YRECLDP_RCL_CONST2R"); + yrecldp->rcl_const3r = serialboxMetainfoGetFloat64(metainfo, "YRECLDP_RCL_CONST3R"); + yrecldp->rcl_const4r = serialboxMetainfoGetFloat64(metainfo, "YRECLDP_RCL_CONST4R"); + yrecldp->rcl_fac1 = serialboxMetainfoGetFloat64(metainfo, "YRECLDP_RCL_FAC1"); + yrecldp->rcl_fac2 = serialboxMetainfoGetFloat64(metainfo, "YRECLDP_RCL_FAC2"); + yrecldp->rcl_const5r = serialboxMetainfoGetFloat64(metainfo, "YRECLDP_RCL_CONST5R"); + yrecldp->rcl_const6r = serialboxMetainfoGetFloat64(metainfo, "YRECLDP_RCL_CONST6R"); + yrecldp->rcl_fzrab = serialboxMetainfoGetFloat64(metainfo, "YRECLDP_RCL_FZRAB"); + yrecldp->rcl_fzrbb = serialboxMetainfoGetFloat64(metainfo, "YRECLDP_RCL_FZRBB"); + yrecldp->lcldextra = serialboxMetainfoGetFloat64(metainfo, "YRECLDP_LCLDEXTRA"); + yrecldp->lcldbudget = serialboxMetainfoGetFloat64(metainfo, "YRECLDP_LCLDBUDGET"); + yrecldp->nssopt = serialboxMetainfoGetFloat64(metainfo, "YRECLDP_NSSOPT"); + yrecldp->ncldtop = serialboxMetainfoGetFloat64(metainfo, "YRECLDP_NCLDTOP"); + yrecldp->naeclbc = serialboxMetainfoGetFloat64(metainfo, "YRECLDP_NAECLBC"); + yrecldp->naecldu = serialboxMetainfoGetFloat64(metainfo, "YRECLDP_NAECLDU"); + yrecldp->naeclom = serialboxMetainfoGetFloat64(metainfo, "YRECLDP_NAECLOM"); + yrecldp->naeclss = serialboxMetainfoGetFloat64(metainfo, "YRECLDP_NAECLSS"); + yrecldp->naeclsu = serialboxMetainfoGetFloat64(metainfo, "YRECLDP_NAECLSU"); + yrecldp->nclddiag = serialboxMetainfoGetFloat64(metainfo, "YRECLDP_NCLDDIAG"); + yrecldp->naercld = serialboxMetainfoGetFloat64(metainfo, "YRECLDP_NAERCLD"); + yrecldp->laerliqautolsp = serialboxMetainfoGetFloat64(metainfo, "YRECLDP_LAERLIQAUTOLSP"); + yrecldp->laerliqautocp = serialboxMetainfoGetFloat64(metainfo, "YRECLDP_LAERLIQAUTOCP"); + yrecldp->laerliqautocpb = serialboxMetainfoGetFloat64(metainfo, "YRECLDP_LAERLIQAUTOCPB"); + yrecldp->laerliqcoll = serialboxMetainfoGetFloat64(metainfo, "YRECLDP_LAERLIQCOLL"); + yrecldp->laericesed = serialboxMetainfoGetFloat64(metainfo, "YRECLDP_LAERICESED"); + yrecldp->laericeauto = serialboxMetainfoGetFloat64(metainfo, "YRECLDP_LAERICEAUTO"); + yrecldp->nshapep = serialboxMetainfoGetFloat64(metainfo, "YRECLDP_NSHAPEP"); + yrecldp->nshapeq = serialboxMetainfoGetFloat64(metainfo, "YRECLDP_NSHAPEQ"); + yrecldp->nbeta = serialboxMetainfoGetFloat64(metainfo, "YRECLDP_NBETA"); + + serialboxSerializerDestroySavepointVector(savepoints, 1); + serialboxSerializerDestroy(serializer); +} + +/* Read reference result into memory */ +void load_reference(const int nlon, const int nlev, const int nclv, const int ngptot, const int nproma, + double *plude, double *pcovptot, double *prainfrac_toprfz, double *pfsqlf, double *pfsqif, + double *pfcqlng, double *pfcqnng, double *pfsqrf, double *pfsqsf, double *pfcqrng, double *pfcqsng, + double *pfsqltur, double *pfsqitur, double *pfplsl, double *pfplsn, double *pfhpsl, double *pfhpsn, + double *tend_loc_a, double *tend_loc_q, double *tend_loc_t, double *tend_loc_cld) +{ + serialboxSerializer_t* serializer = serialboxSerializerCreate(Read, "./data", "reference", "Binary"); + serialboxMetainfo_t* metainfo = serialboxSerializerGetGlobalMetainfo(serializer); + serialboxSavepoint_t** savepoints = serialboxSerializerGetSavepointVector(serializer); + serialboxSavepoint_t* savepoint = savepoints[0]; + + int nblocks = (ngptot / nproma) + min(ngptot % nproma, 1); + + load_and_expand_2d(serializer, savepoint, "PLUDE", nlon, nlev, nproma, ngptot, nblocks, plude); + load_and_expand_2d(serializer, savepoint, "PCOVPTOT", nlon, nlev, nproma, ngptot, nblocks, pcovptot); + load_and_expand_1d(serializer, savepoint, "PRAINFRAC_TOPRFZ", nlon, nproma, ngptot, nblocks, prainfrac_toprfz); + load_and_expand_2d(serializer, savepoint, "PFSQLF", nlon, nlev+1, nproma, ngptot, nblocks, pfsqlf); + load_and_expand_2d(serializer, savepoint, "PFSQIF", nlon, nlev+1, nproma, ngptot, nblocks, pfsqif); + load_and_expand_2d(serializer, savepoint, "PFCQLNG", nlon, nlev+1, nproma, ngptot, nblocks, pfcqlng); + load_and_expand_2d(serializer, savepoint, "PFCQNNG", nlon, nlev+1, nproma, ngptot, nblocks, pfcqnng); + load_and_expand_2d(serializer, savepoint, "PFSQRF", nlon, nlev+1, nproma, ngptot, nblocks, pfsqrf); + load_and_expand_2d(serializer, savepoint, "PFSQSF", nlon, nlev+1, nproma, ngptot, nblocks, pfsqsf); + load_and_expand_2d(serializer, savepoint, "PFCQRNG", nlon, nlev+1, nproma, ngptot, nblocks, pfcqrng); + load_and_expand_2d(serializer, savepoint, "PFCQSNG", nlon, nlev+1, nproma, ngptot, nblocks, pfcqsng); + load_and_expand_2d(serializer, savepoint, "PFSQLTUR", nlon, nlev+1, nproma, ngptot, nblocks, pfsqltur); + load_and_expand_2d(serializer, savepoint, "PFSQITUR", nlon, nlev+1, nproma, ngptot, nblocks, pfsqitur); + load_and_expand_2d(serializer, savepoint, "PFPLSL", nlon, nlev+1, nproma, ngptot, nblocks, pfplsl); + load_and_expand_2d(serializer, savepoint, "PFPLSN", nlon, nlev+1, nproma, ngptot, nblocks, pfplsn); + load_and_expand_2d(serializer, savepoint, "PFHPSL", nlon, nlev+1, nproma, ngptot, nblocks, pfhpsl); + load_and_expand_2d(serializer, savepoint, "PFHPSN", nlon, nlev+1, nproma, ngptot, nblocks, pfhpsn); + load_and_expand_2d(serializer, savepoint, "TENDENCY_LOC_T", nlon, nlev, nproma, ngptot, nblocks, tend_loc_t); + load_and_expand_2d(serializer, savepoint, "TENDENCY_LOC_Q", nlon, nlev, nproma, ngptot, nblocks, tend_loc_q); + load_and_expand_2d(serializer, savepoint, "TENDENCY_LOC_A", nlon, nlev, nproma, ngptot, nblocks, tend_loc_a); + load_and_expand_3d(serializer, savepoint, "TENDENCY_LOC_CLD", nlon, nlev, nclv, nproma, ngptot, nblocks, tend_loc_cld); + + serialboxSerializerDestroySavepointVector(savepoints, 1); + serialboxSerializerDestroy(serializer); +} diff --git a/src/cloudsc_hip/cloudsc/load_state.h b/src/cloudsc_hip/cloudsc/load_state.h new file mode 100644 index 00000000..65fbf8c2 --- /dev/null +++ b/src/cloudsc_hip/cloudsc/load_state.h @@ -0,0 +1,40 @@ +/* + * (C) Copyright 1988- ECMWF. + * + * This software is licensed under the terms of the Apache Licence Version 2.0 + * which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. + * In applying this licence, ECMWF does not waive the privileges and immunities + * granted to it by virtue of its status as an intergovernmental organisation + * nor does it submit to any jurisdiction. + */ + +#include +#include +#include "yoecldp_c.h" + +struct TECLDP ; + +void query_state(int *klon, int *klev); + +void load_state(const int nlon, const int nlev, const int nclv, const int ngptot, const int nproma, + double* ptsphy, double* plcrit_aer, double* picrit_aer, + double* pre_ice, double* pccn, double* pnice, double* pt, double* pq, + double* tend_cml_t, double* tend_cml_q, double* tend_cml_a, double* tend_cml_cld, + double* tend_tmp_t, double* tend_tmp_q, double* tend_tmp_a, double* tend_tmp_cld, + double* pvfa, double* pvfl, double* pvfi, double* pdyna, double* pdynl, double* pdyni, + double* phrsw, double* phrlw, double* pvervel, double* pap, double* paph, double* plsm, + int* ktype, double* plu, double* plude, double* psnde, double* pmfu, + double* pmfd, double* pa, double* pclv, double* psupsat, struct TECLDP* yrecldp, + double* rg, double* rd, double* rcpd, double* retv, double* rlvtt, double* rlstt, + double* rlmlt, double* rtt, double* rv, double* r2es, double* r3les, double* r3ies, + double* r4les, double* r4ies, double* r5les, double* r5ies, double* r5alvcp, double* r5alscp, + double* ralvdcp, double* ralsdcp, double* ralfdcp, double* rtwat, + double* rtice, double* rticecu, double* rtwat_rtice_r, double *rtwat_rticecu_r, + double* rkoop1, double* rkoop2); + + +void load_reference(const int nlon, const int nlev, const int nclv, const int ngptot, const int nproma, + double *plude, double *pcovptot, double *prainfrac_toprfz, double *pfsqlf, double *pfsqif, + double *pfcqlng, double *pfcqnng, double *pfsqrf, double *pfsqsf, double *pfcqrng, double *pfcqsng, + double *pfsqltur, double *pfsqitur, double *pfplsl, double *pfplsn, double *pfhpsl, double *pfhpsn, + double *tend_loc_a, double *tend_loc_q, double *tend_loc_t, double *tend_loc_cld); diff --git a/src/cloudsc_hip/cloudsc/mycpu.cpp b/src/cloudsc_hip/cloudsc/mycpu.cpp new file mode 100644 index 00000000..8c6e8506 --- /dev/null +++ b/src/cloudsc_hip/cloudsc/mycpu.cpp @@ -0,0 +1,31 @@ +/* + * (C) Copyright 1988- ECMWF. + * + * This software is licensed under the terms of the Apache Licence Version 2.0 + * which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. + * In applying this licence, ECMWF does not waive the privileges and immunities + * granted to it by virtue of its status as an intergovernmental organisation + * nor does it submit to any jurisdiction. + */ + +#if defined(__APPLE__) +static int sched_getcpu() { return 0; } +#else +#include +#endif + +/* + * Find the core the thread belongs to + */ + +int mycpu_ () +{ + /* int sched_getcpu(void); */ + int cpu; +#pragma clang diagnostic push +#pragma clang diagnostic ignored "-Wimplicit-function-declaration" + cpu = sched_getcpu(); +#pragma clang diagnostic pop + return cpu; +} +int mycpu() { return mycpu_(); } diff --git a/src/cloudsc_hip/cloudsc/mycpu.h b/src/cloudsc_hip/cloudsc/mycpu.h new file mode 100644 index 00000000..6b26848e --- /dev/null +++ b/src/cloudsc_hip/cloudsc/mycpu.h @@ -0,0 +1,11 @@ +/* + * (C) Copyright 1988- ECMWF. + * + * This software is licensed under the terms of the Apache Licence Version 2.0 + * which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. + * In applying this licence, ECMWF does not waive the privileges and immunities + * granted to it by virtue of its status as an intergovernmental organisation + * nor does it submit to any jurisdiction. + */ + +int mycpu (); diff --git a/src/cloudsc_hip/cloudsc/yoecldp_c.h b/src/cloudsc_hip/cloudsc/yoecldp_c.h new file mode 100644 index 00000000..7fcace99 --- /dev/null +++ b/src/cloudsc_hip/cloudsc/yoecldp_c.h @@ -0,0 +1,145 @@ +/* + * (C) Copyright 1988- ECMWF. + * + * This software is licensed under the terms of the Apache Licence Version 2.0 + * which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. + * In applying this licence, ECMWF does not waive the privileges and immunities + * granted to it by virtue of its status as an intergovernmental organisation + * nor does it submit to any jurisdiction. + */ + +#ifndef YOECLDP_H +#define YOECLDP_H + +//int nclv; // number of microphysics variables +//int ncldql; // liquid cloud water +//int ncldqi; // ice cloud water +//int ncldqr; // rain water +//int ncldqs; // snow +//int ncldqv; // vapour + +struct TECLDP { + double ramid; + double rcldiff; + double rcldiff_convi; + double rclcrit; + double rclcrit_sea; + double rclcrit_land; + double rkconv; + double rprc1; + double rprc2; + double rcldmax; + double rpecons; + double rvrfactor; + double rprecrhmax; + double rtaumel; + double ramin; + double rlmin; + double rkooptau; + double rcldtopp; + double rlcritsnow; + double rsnowlin1; + double rsnowlin2; + double ricehi1; + double ricehi2; + double riceinit; + double rvice; + double rvrain; + double rvsnow; + double rthomo; + double rcovpmin; + double rccn; + double rnice; + double rccnom; + double rccnss; + double rccnsu; + double rcldtopcf; + double rdepliqrefrate; + double rdepliqrefdepth; + double rcl_kkaac; + double rcl_kkbac; + double rcl_kkaau; + double rcl_kkbauq; + double rcl_kkbaun; + double rcl_kk_cloud_num_sea; + double rcl_kk_cloud_num_land; + double rcl_ai; + double rcl_bi; + double rcl_ci; + double rcl_di; + double rcl_x1i; + double rcl_x2i; + double rcl_x3i; + double rcl_x4i; + double rcl_const1i; + double rcl_const2i; + double rcl_const3i; + double rcl_const4i; + double rcl_const5i; + double rcl_const6i; + double rcl_apb1; + double rcl_apb2; + double rcl_apb3; + double rcl_as; + double rcl_bs; + double rcl_cs; + double rcl_ds; + double rcl_x1s; + double rcl_x2s; + double rcl_x3s; + double rcl_x4s; + double rcl_const1s; + double rcl_const2s; + double rcl_const3s; + double rcl_const4s; + double rcl_const5s; + double rcl_const6s; + double rcl_const7s; + double rcl_const8s; + double rdenswat; + double rdensref; + double rcl_ar; + double rcl_br; + double rcl_cr; + double rcl_dr; + double rcl_x1r; + double rcl_x2r; + double rcl_x4r; + double rcl_ka273; + double rcl_cdenom1; + double rcl_cdenom2; + double rcl_cdenom3; + double rcl_schmidt; + double rcl_dynvisc; + double rcl_const1r; + double rcl_const2r; + double rcl_const3r; + double rcl_const4r; + double rcl_fac1; + double rcl_fac2; + double rcl_const5r; + double rcl_const6r; + double rcl_fzrab; + double rcl_fzrbb; + int lcldextra, lcldbudget; + int nssopt; + int ncldtop; + int naeclbc, naecldu, naeclom, naeclss, naeclsu; + int nclddiag; + int naercld; + int laerliqautolsp; + int laerliqautocp; + int laerliqautocpb; + int laerliqcoll; + int laericesed; + int laericeauto; + double nshapep; + double nshapeq; + int nbeta; + //double rbeta[0][100]; + //double rbetap1[0][100]; +} ; + +//struct TECLDP *yrecldp; + +#endif diff --git a/src/cloudsc_hip/dwarf_cloudsc.cpp b/src/cloudsc_hip/dwarf_cloudsc.cpp new file mode 100644 index 00000000..43b91b84 --- /dev/null +++ b/src/cloudsc_hip/dwarf_cloudsc.cpp @@ -0,0 +1,44 @@ +/* + * (C) Copyright 1988- ECMWF. + * + * This software is licensed under the terms of the Apache Licence Version 2.0 + * which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. + * In applying this licence, ECMWF does not waive the privileges and immunities + * granted to it by virtue of its status as an intergovernmental organisation + * nor does it submit to any jurisdiction. + */ + +#include +#include + +#include "cloudsc_driver.h" + + +int main( int argc, char *argv[] ) { + + int omp_threads, ngptot, nproma; + int return_code; + + return_code = 0; + + // default values + omp_threads = 1; + ngptot = 100; + nproma = 4; + + if (argc == 1) { + cloudsc_driver(omp_threads, ngptot, nproma); + } + else if (argc == 4) { + omp_threads = atoi( argv[1] ); + ngptot = atoi( argv[2] ); + nproma = atoi( argv[3] ); + cloudsc_driver(omp_threads, ngptot, nproma); + } + else { + printf("Calling c-cloudsc with the right number of arguments will work better ;-) \n",argc); + return_code = EXIT_FAILURE; + } + + return return_code; +} From 7c397fe4cbf60ec5660d31c2dd7f58387024f15c Mon Sep 17 00:00:00 2001 From: Michael Staneker Date: Mon, 4 Sep 2023 16:52:55 +0200 Subject: [PATCH 2/4] Change in load state in order to allow correct validation for nproma = 128 --- src/cloudsc_hip/cloudsc/load_state.cpp | 122 +++++++------------------ 1 file changed, 34 insertions(+), 88 deletions(-) diff --git a/src/cloudsc_hip/cloudsc/load_state.cpp b/src/cloudsc_hip/cloudsc/load_state.cpp index 38fc148f..d8e7e03d 100644 --- a/src/cloudsc_hip/cloudsc/load_state.cpp +++ b/src/cloudsc_hip/cloudsc/load_state.cpp @@ -23,124 +23,70 @@ void query_state(int *klon, int *klev) void expand_1d(double *buffer, double *field_in, int nlon, int nproma, int ngptot, int nblocks) { - int gidx, bsize, bidx, bend, fsize, b, l, i; + int b, l, i, buf_start_idx, buf_idx; - #pragma omp parallel for default(shared) private(gidx, bsize, bidx, bend, fsize, b, l, i) +#pragma omp parallel for default(shared) private(b, l, i, buf_start_idx, buf_idx) for (b = 0; b < nblocks; b++) { - gidx = b*nproma; // Global starting index of the block in the general domain - bsize = min(nproma, ngptot - gidx); // Size of the field block - bidx = gidx % nlon; // Rolling index into the input buffer - bend = min(bidx+bsize, nlon); // Idealised final index in the input buffer - - if (bend-bidx < bsize) { - // The input buffer does not hold enough data to fill field block; - // we need to fill the rest of the block with data from front of buffer. - fsize = nlon - bidx; - for (i = 0; i < fsize; i++) { field_in[b*nproma+i] = buffer[bidx + i]; } - for (i = 0; i < bsize-fsize; i++) { field_in[b*nproma+fsize+i] = buffer[i]; } - } else { - // Simply copy a block of data from the rolling buffer index - for (i = 0; i < bsize; i++) { field_in[b*nproma+i] = buffer[bidx+i]; } + buf_start_idx = ((b)*nproma) % nlon; + for (i = 0; i < nproma; i++) { + buf_idx = (buf_start_idx + i) % nlon; + // field[b][i] = buffer[buf_idx]; + field_in[b*nproma+i] = buffer[buf_idx]; } - // Zero out the remainder of last block - for (i=bsize; i Date: Mon, 4 Dec 2023 17:39:12 +0200 Subject: [PATCH 3/4] improving cmake usage for HIP version, minor changes and refactoring --- CMakeLists.txt | 16 +++++++- .../lumi/cray-gpu/15.0.1/toolchain.cmake | 19 +++++++++- bundle.yml | 3 +- src/cloudsc_hip/CMakeLists.txt | 38 +++++++++---------- src/cloudsc_hip/cloudsc/load_state.cpp | 32 +++++++--------- 5 files changed, 67 insertions(+), 41 deletions(-) diff --git a/CMakeLists.txt b/CMakeLists.txt index 9a454395..2e5726ab 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -56,6 +56,20 @@ if( HAVE_CUDA ) enable_language( CUDA ) endif() +ecbuild_add_option( FEATURE HIP + DESCRIPTION "HIP" DEFAULT OFF + REQUIRED_PACKAGES "hip" ) +if ( HAVE_HIP ) + if(NOT DEFINED ROCM_PATH) + if(DEFINED ENV{ROCM_PATH}) + set(ROCM_PATH $ENV{ROCM_PATH} CACHE PATH "Path to which ROCM has been installed") + else() + set(ROCM_PATH "/opt/rocm" CACHE PATH "Path to which ROCM has been installed") + endif() + endif() + find_package(hip REQUIRED) +endif() + ### OpenMP ecbuild_add_option( FEATURE OMP DESCRIPTION "OpenMP" DEFAULT ON @@ -83,7 +97,7 @@ endif() ecbuild_add_option( FEATURE SERIALBOX DESCRIPTION "Use Serialbox to read input and reference data" REQUIRED_PACKAGES "Serialbox" - CONDITION NOT HAVE_HDF5 OR HAVE_SERIALBOX + CONDITION NOT HAVE_HDF5 DEFAULT OFF ) if( HAVE_SERIALBOX ) list(APPEND CLOUDSC_DEFINITIONS HAVE_SERIALBOX) diff --git a/arch/eurohpc/lumi/cray-gpu/15.0.1/toolchain.cmake b/arch/eurohpc/lumi/cray-gpu/15.0.1/toolchain.cmake index 4aed4cdc..e7e382b2 100644 --- a/arch/eurohpc/lumi/cray-gpu/15.0.1/toolchain.cmake +++ b/arch/eurohpc/lumi/cray-gpu/15.0.1/toolchain.cmake @@ -18,8 +18,14 @@ set( ENABLE_USE_STMT_FUNC ON CACHE STRING "" ) #################################################################### set( ENABLE_OMP ON CACHE STRING "" ) -set( OpenMP_C_FLAGS "-homp" CACHE STRING "" ) -set( OpenMP_Fortran_FLAGS "-homp -hnoacc -hlist=aimd -maxrregcount 64" CACHE STRING "" ) +set( OpenMP_C_FLAGS "-fopenmp" CACHE STRING "" ) +set( OpenMP_CXX_FLAGS "-fopenmp" CACHE STRING "" ) +set( OpenMP_Fortran_FLAGS "-fopenmp -hnoacc -hlist=aimd" CACHE STRING "" ) + +set( OpenMP_C_LIB_NAMES "craymp" ) +set( OpenMP_CXX_LIB_NAMES "craymp" ) +set( OpenMP_Fortran_LIB_NAMES "craymp" ) +set( OpenMP_craymp_LIBRARY "/opt/cray/pe/cce/15.0.1/cce/x86_64/lib/libcraymp.so" ) #################################################################### # OpenACC FLAGS @@ -30,6 +36,15 @@ set( OpenACC_C_FLAGS "-hacc" ) set( OpenACC_CXX_FLAGS "-hacc" ) set( OpenACC_Fortran_FLAGS "-hacc -h acc_model=deep_copy" ) +#################################################################### +# OpenACC FLAGS +#################################################################### + +set(CMAKE_HIP_FLAGS "${CMAKE_HIP_FLAGS} -03 -ffast-math") +if(NOT DEFINED CMAKE_CUDA_ARCHITECTURES) + set(CMAKE_HIP_ARCHITECTURES gfx90a) +endif() + #################################################################### # Compiler FLAGS #################################################################### diff --git a/bundle.yml b/bundle.yml index 77c26c63..5663c0db 100644 --- a/bundle.yml +++ b/bundle.yml @@ -78,10 +78,11 @@ options : ENABLE_CLOUDSC_GPU_SCC_CUF=ON ENABLE_CLOUDSC_GPU_SCC_CUF_K_CACHING=ON BUILD_field_api=ON + - with-hip : help: Enable GPU kernel variant based on HIP cmake: > - ENABLE_CLOUDSC_HIP=ON + ENABLE_HIP=ON - with-mpi : help : Enable MPI-parallel kernel diff --git a/src/cloudsc_hip/CMakeLists.txt b/src/cloudsc_hip/CMakeLists.txt index 768bee1a..0a034585 100644 --- a/src/cloudsc_hip/CMakeLists.txt +++ b/src/cloudsc_hip/CMakeLists.txt @@ -8,26 +8,14 @@ # Define this dwarf variant as an ECBuild feature ecbuild_add_option( FEATURE CLOUDSC_HIP - DESCRIPTION "Build the HIP version CLOUDSC using Serialbox" DEFAULT OFF - CONDITION Serialbox_FOUND + DESCRIPTION "Build the HIP version CLOUDSC using Serialbox" DEFAULT ON + CONDITION Serialbox_FOUND AND HAVE_HIP ) if( HAVE_CLOUDSC_HIP ) - - if(NOT DEFINED ROCM_PATH) - if(DEFINED ENV{ROCM_PATH}) - set(ROCM_PATH $ENV{ROCM_PATH} CACHE PATH "Path to which ROCM has been installed") - else() - set(ROCM_PATH "/opt/rocm" CACHE PATH "Path to which ROCM has been installed") - endif() - endif() - - find_package(hip REQUIRED) - set(CMAKE_C_COMPILER "${ROCM_PATH}/bin/hipcc") set(CMAKE_CXX_COMPILER "${ROCM_PATH}/bin/hipcc") - # set(CMAKE_HIP_FLAGS "${CMAKE_HIP_FLAGS} -03 -ffast-math") ###### SCC-HIP #### ecbuild_add_library( @@ -57,7 +45,11 @@ if( HAVE_CLOUDSC_HIP ) target_include_directories(dwarf-cloudsc-hip-lib PUBLIC $ $) target_link_libraries(dwarf-cloudsc-hip-lib PUBLIC hip::device Serialbox::Serialbox_C $<${HAVE_OMP}:OpenMP::OpenMP_C>) - target_compile_options(dwarf-cloudsc-hip-lib PRIVATE --offload-arch=gfx90a) + if (NOT DEFINED CMAKE_HIP_ARCHITECTURES) + message(WARNING "No HIP architecture is set! ('CMAKE_HIP_ARCHITECTURES' is not defined)") + else() + target_compile_options(dwarf-cloudsc-hip-lib PRIVATE --offload-arch=${CMAKE_HIP_ARCHITECTURES}) + endif() ecbuild_add_executable( TARGET dwarf-cloudsc-hip @@ -95,8 +87,12 @@ if( HAVE_CLOUDSC_HIP ) target_include_directories(dwarf-cloudsc-hip-hoist-lib PUBLIC $ $) target_link_libraries(dwarf-cloudsc-hip-hoist-lib PUBLIC hip::device Serialbox::Serialbox_C $<${HAVE_OMP}:OpenMP::OpenMP_C>) - target_compile_options(dwarf-cloudsc-hip-hoist-lib PRIVATE --offload-arch=gfx90a) - + if (NOT DEFINED CMAKE_HIP_ARCHITECTURES) + message(WARNING "No HIP architecture is set! ('CMAKE_HIP_ARCHITECTURES' is not defined)") + else() + target_compile_options(dwarf-cloudsc-hip-hoist-lib PRIVATE --offload-arch=${CMAKE_HIP_ARCHITECTURES}) + endif() + ecbuild_add_executable( TARGET dwarf-cloudsc-hip-hoist SOURCES dwarf_cloudsc.cpp @@ -133,8 +129,12 @@ if( HAVE_CLOUDSC_HIP ) target_include_directories(dwarf-cloudsc-hip-k-caching-lib PUBLIC $ $) target_link_libraries(dwarf-cloudsc-hip-k-caching-lib PUBLIC hip::device Serialbox::Serialbox_C $<${HAVE_OMP}:OpenMP::OpenMP_C>) - target_compile_options(dwarf-cloudsc-hip-k-caching-lib PRIVATE --offload-arch=gfx90a) - + if (NOT DEFINED CMAKE_HIP_ARCHITECTURES) + message(WARNING "No HIP architecture is set! ('CMAKE_HIP_ARCHITECTURES' is not defined)") + else() + target_compile_options(dwarf-cloudsc-hip-k-caching-lib PRIVATE --offload-arch=${CMAKE_HIP_ARCHITECTURES}) + endif() + ecbuild_add_executable( TARGET dwarf-cloudsc-hip-k-caching SOURCES dwarf_cloudsc.cpp diff --git a/src/cloudsc_hip/cloudsc/load_state.cpp b/src/cloudsc_hip/cloudsc/load_state.cpp index d8e7e03d..5ba60abf 100644 --- a/src/cloudsc_hip/cloudsc/load_state.cpp +++ b/src/cloudsc_hip/cloudsc/load_state.cpp @@ -23,14 +23,13 @@ void query_state(int *klon, int *klev) void expand_1d(double *buffer, double *field_in, int nlon, int nproma, int ngptot, int nblocks) { - int b, l, i, buf_start_idx, buf_idx; + int b, i, buf_start_idx, buf_idx; -#pragma omp parallel for default(shared) private(b, l, i, buf_start_idx, buf_idx) +#pragma omp parallel for default(shared) private(b, i, buf_start_idx, buf_idx) for (b = 0; b < nblocks; b++) { buf_start_idx = ((b)*nproma) % nlon; for (i = 0; i < nproma; i++) { buf_idx = (buf_start_idx + i) % nlon; - // field[b][i] = buffer[buf_idx]; field_in[b*nproma+i] = buffer[buf_idx]; } } @@ -39,9 +38,9 @@ void expand_1d(double *buffer, double *field_in, int nlon, int nproma, int ngpto void expand_1d_int(int *buffer, int *field_in, int nlon, int nproma, int ngptot, int nblocks) { - int b, l, i, buf_start_idx, buf_idx; + int b, i, buf_start_idx, buf_idx; - #pragma omp parallel for default(shared) private(b, l, i, buf_start_idx, buf_idx) + #pragma omp parallel for default(shared) private(b, i, buf_start_idx, buf_idx) for (b = 0; b < nblocks; b++) { buf_start_idx = ((b)*nproma) % nlon; for (i = 0; i < nproma; i++) { @@ -49,7 +48,6 @@ void expand_1d_int(int *buffer, int *field_in, int nlon, int nproma, int ngptot, field_in[b*nproma+i] = buffer[buf_idx]; } } - } @@ -61,13 +59,12 @@ void expand_2d(double *buffer_in, double *field_in, int nlon, int nlev, int npro for (b = 0; b < nblocks; b++) { buf_start_idx = ((b)*nproma) % nlon; for (i = 0; i < nproma; i++) { - for (l = 0; l < nlev; l++) { - buf_idx = (buf_start_idx + i) % nlon; - field_in[b*nlev*nproma+l*nproma+i] = buffer_in[l*nlon+buf_idx]; - } + for (l = 0; l < nlev; l++) { + buf_idx = (buf_start_idx + i) % nlon; + field_in[b*nlev*nproma+l*nproma+i] = buffer_in[l*nlon+buf_idx]; + } } } - } void expand_3d(double *buffer_in, double *field_in, int nlon, int nlev, int nclv, int nproma, int ngptot, int nblocks) @@ -78,15 +75,14 @@ void expand_3d(double *buffer_in, double *field_in, int nlon, int nlev, int nclv for (b = 0; b < nblocks; b++) { buf_start_idx = ((b)*nproma) % nlon; for (i = 0; i < nproma; i++) { - for (c = 0; c < nclv; c++) { - for (l = 0; l < nlev; l++) { - buf_idx = (buf_start_idx + i) % nlon; - field_in[b*nclv*nlev*nproma+c*nlev*nproma+l*nproma+i] = buffer_in[c*nlev*nlon+l*nlon+buf_idx]; - } - } + for (c = 0; c < nclv; c++) { + for (l = 0; l < nlev; l++) { + buf_idx = (buf_start_idx + i) % nlon; + field_in[b*nclv*nlev*nproma+c*nlev*nproma+l*nproma+i] = buffer_in[c*nlev*nlon+l*nlon+buf_idx]; + } + } } } - } From 7a617c779f84c9323c8a4ab4737755463e9da5cd Mon Sep 17 00:00:00 2001 From: MichaelSt98 Date: Tue, 5 Dec 2023 10:54:11 +0200 Subject: [PATCH 4/4] removing multi-threaded HIP test and adding relevant HIP ctests for all variants --- src/cloudsc_hip/CMakeLists.txt | 39 ++++++++++++++++++---------------- 1 file changed, 21 insertions(+), 18 deletions(-) diff --git a/src/cloudsc_hip/CMakeLists.txt b/src/cloudsc_hip/CMakeLists.txt index 0a034585..0f04960e 100644 --- a/src/cloudsc_hip/CMakeLists.txt +++ b/src/cloudsc_hip/CMakeLists.txt @@ -57,6 +57,13 @@ if( HAVE_CLOUDSC_HIP ) LIBS dwarf-cloudsc-hip-lib ) + ecbuild_add_test( + TARGET dwarf-cloudsc-hip-serial + COMMAND bin/dwarf-cloudsc-hip + ARGS 1 1000 64 + WORKING_DIRECTORY ${CMAKE_CURRENT_BINARY_DIR}/../../.. + OMP 1 + ) ## ###### SCC-HOIST-HIP #### @@ -99,6 +106,13 @@ if( HAVE_CLOUDSC_HIP ) LIBS dwarf-cloudsc-hip-hoist-lib ) + ecbuild_add_test( + TARGET dwarf-cloudsc-hip-hoist-serial + COMMAND bin/dwarf-cloudsc-hip-hoist + ARGS 1 1000 64 + WORKING_DIRECTORY ${CMAKE_CURRENT_BINARY_DIR}/../../.. + OMP 1 + ) ## ###### SCC-K-CACHING-HIP #### @@ -141,28 +155,17 @@ if( HAVE_CLOUDSC_HIP ) LIBS dwarf-cloudsc-hip-k-caching-lib ) + ecbuild_add_test( + TARGET dwarf-cloudsc-hip-k-caching-serial + COMMAND bin/dwarf-cloudsc-hip-k-caching + ARGS 1 1000 64 + WORKING_DIRECTORY ${CMAKE_CURRENT_BINARY_DIR}/../../.. + OMP 1 + ) ## - - # Create symlink for the input data execute_process(COMMAND ${CMAKE_COMMAND} -E create_symlink ${CMAKE_CURRENT_SOURCE_DIR}/../../data ${CMAKE_CURRENT_BINARY_DIR}/../../../data ) - ecbuild_add_test( - TARGET dwarf-cloudsc-hip-serial - COMMAND bin/dwarf-cloudsc-hip - ARGS 1 100 16 - WORKING_DIRECTORY ${CMAKE_CURRENT_BINARY_DIR}/../../.. - OMP 1 - ) - ecbuild_add_test( - TARGET dwarf-cloudsc-hip-omp - COMMAND bin/dwarf-cloudsc-hip - ARGS 4 100 16 - WORKING_DIRECTORY ${CMAKE_CURRENT_BINARY_DIR}/../../.. - OMP 4 - CONDITION HAVE_OMP - ) - endif()