Index: LMDZ6/trunk/DefLists/namelist_ecrad =================================================================== --- LMDZ6/trunk/DefLists/namelist_ecrad (revision 4487) +++ LMDZ6/trunk/DefLists/namelist_ecrad (revision 4489) @@ -66,5 +66,6 @@ iverbose = 1, use_aerosols = false, ! Include aerosols in radiation calculations? -n_aerosol_types = 12, +n_aerosol_types = 13, +aerosol_optics_override_file_name = "aerosol_optics_lmdz.nc" do_save_spectral_flux = false, ! Save spectral fluxes in output file? do_save_gpoint_flux = false, ! Save fluxes per g-point in output file? Index: LMDZ6/trunk/arch/arch-ES_MOON.path =================================================================== --- LMDZ6/trunk/arch/arch-ES_MOON.path (revision 4487) +++ LMDZ6/trunk/arch/arch-ES_MOON.path (revision 4489) @@ -1,4 +1,6 @@ NETCDF_LIBDIR="-L/S/home010/c0010/ES/lib -lnetcdf" NETCDF_INCDIR=-I/S/home010/c0010/ES/include +NETCDF95_INCDIR=-I$LMDGCM/../../include +NETCDF95_LIBDIR=-L$LMDGCM/../../lib IOIPSL_INCDIR=$LMDGCM/../../lib IOIPSL_LIBDIR=$LMDGCM/../../lib Index: LMDZ6/trunk/arch/arch-IA64_PLATINE.path =================================================================== --- LMDZ6/trunk/arch/arch-IA64_PLATINE.path (revision 4487) +++ LMDZ6/trunk/arch/arch-IA64_PLATINE.path (revision 4489) @@ -1,4 +1,6 @@ NETCDF_LIBDIR="-L/usr/lib -lnetcdff -lnetcdf" NETCDF_INCDIR=-I/usr/include +NETCDF95_INCDIR=$LMDGCM/../../include +NETCDF95_LIBDIR=$LMDGCM/../../lib IOIPSL_INCDIR=$LMDGCM/../../lib IOIPSL_LIBDIR=$LMDGCM/../../lib Index: LMDZ6/trunk/arch/arch-PW6_VARGAS.path =================================================================== --- LMDZ6/trunk/arch/arch-PW6_VARGAS.path (revision 4487) +++ LMDZ6/trunk/arch/arch-PW6_VARGAS.path (revision 4489) @@ -1,4 +1,6 @@ NETCDF_LIBDIR="${NETCDF_LDFLAGS:--L/usr/local/pub/NetCDF/3.6.2/lib -lnetcdf}" NETCDF_INCDIR="${NETCDF_FFLAGS:--I/usr/local/pub/NetCDF/3.6.2/include}" +NETCDF95_INCDIR=$LMDGCM/../../include +NETCDF95_LIBDIR=$LMDGCM/../../lib IOIPSL_INCDIR=$LMDGCM/../../lib IOIPSL_LIBDIR=$LMDGCM/../../lib Index: LMDZ6/trunk/arch/arch-SX8_BRODIE.path =================================================================== --- LMDZ6/trunk/arch/arch-SX8_BRODIE.path (revision 4487) +++ LMDZ6/trunk/arch/arch-SX8_BRODIE.path (revision 4489) @@ -1,4 +1,6 @@ NETCDF_LIBDIR="-L/SXlocal/pub/netCDF/3.6.1-openmp/lib -lnetcdf" NETCDF_INCDIR=-I/SXlocal/pub/netCDF/3.6.1-openmp/include +NETCDF95_INCDIR=$LMDGCM/../../include +NETCDF95_LIBDIR=$LMDGCM/../../lib IOIPSL_INCDIR=$LMDGCM/../../lib IOIPSL_LIBDIR=$LMDGCM/../../lib Index: LMDZ6/trunk/arch/arch-SX8_MERCURE.path =================================================================== --- LMDZ6/trunk/arch/arch-SX8_MERCURE.path (revision 4487) +++ LMDZ6/trunk/arch/arch-SX8_MERCURE.path (revision 4489) @@ -1,4 +1,6 @@ NETCDF_LIBDIR="-L ${NETCDF_SX_LIBDIR:-/usr/local/SX8/soft/netcdf/lib} -lnetcdf" NETCDF_INCDIR=-I${NETCDF_SX_INCLUDEDIR:-/usr/local/SX8/soft/netcdf/include} +NETCDF95_INCDIR=$LMDGCM/../../include +NETCDF95_LIBDIR=$LMDGCM/../../lib IOIPSL_INCDIR=$LMDGCM/../../lib IOIPSL_LIBDIR=$LMDGCM/../../lib Index: LMDZ6/trunk/arch/arch-SX9_MERCURE.path =================================================================== --- LMDZ6/trunk/arch/arch-SX9_MERCURE.path (revision 4487) +++ LMDZ6/trunk/arch/arch-SX9_MERCURE.path (revision 4489) @@ -1,4 +1,6 @@ NETCDF_LIBDIR="-L${NETCDF_SX_LIBDIR:-/ccc/applications/sx9/netcdf-3.6.1/lib} -lnetcdf" NETCDF_INCDIR=-I${NETCDF_SX_INCLUDEDIR:-/ccc/applications/sx9/netcdf-3.6.1/include} +NETCDF95_INCDIR=$LMDGCM/../../include +NETCDF95_LIBDIR=$LMDGCM/../../lib IOIPSL_INCDIR=$LMDGCM/../../lib IOIPSL_LIBDIR=$LMDGCM/../../lib Index: LMDZ6/trunk/arch/arch-X64_ADA.path =================================================================== --- LMDZ6/trunk/arch/arch-X64_ADA.path (revision 4487) +++ LMDZ6/trunk/arch/arch-X64_ADA.path (revision 4489) @@ -1,4 +1,6 @@ NETCDF_LIBDIR="${NETCDF_LDFLAGS:--L/smplocal/pub/NetCDF/4.1.3/mpi/lib -lnetcdff -lnetcdf -L/smplocal/pub/HDF5/1.8.9/par/lib -Bstatic -lhdf5hl_fortran -lhdf5_hl -lhdf5_fortran -lhdf5 -Bdynamic -lz}" NETCDF_INCDIR="${NETCDF_FFLAGS:--I/smplocal/pub/HDF5/1.8.9/par/include -I/smplocal/pub/NetCDF/4.1.3/mpi/include}" +NETCDF95_INCDIR=$LMDGCM/../../include/NetCDF95 +NETCDF95_LIBDIR=$LMDGCM/../../lib IOIPSL_INCDIR="$LMDGCM/../../lib -I$LMDGCM/../IOIPSL/inc" IOIPSL_LIBDIR="$LMDGCM/../../lib -lioipsl -L$LMDGCM/../IOIPSL/lib" Index: LMDZ6/trunk/arch/arch-X64_CURIE.path =================================================================== --- LMDZ6/trunk/arch/arch-X64_CURIE.path (revision 4487) +++ LMDZ6/trunk/arch/arch-X64_CURIE.path (revision 4489) @@ -1,4 +1,6 @@ NETCDF_LIBDIR="-L$NETCDF_LIB_DIR -lnetcdff -lnetcdf" NETCDF_INCDIR=-I$NETCDF_INC_DIR +NETCDF95_INCDIR=$LMDGCM/../../include/NetCDF95 +NETCDF95_LIBDIR=$LMDGCM/../../lib IOIPSL_INCDIR=$LMDGCM/../../lib IOIPSL_LIBDIR=$LMDGCM/../../lib Index: LMDZ6/trunk/arch/arch-X64_IRENE-AMD.path =================================================================== --- LMDZ6/trunk/arch/arch-X64_IRENE-AMD.path (revision 4487) +++ LMDZ6/trunk/arch/arch-X64_IRENE-AMD.path (revision 4489) @@ -2,4 +2,8 @@ NETCDF_LIBDIR="-L$NETCDFFORTRAN_LIBDIR -L$NETCDF_LIBDIR" NETCDF_LIB="-lnetcdff -lnetcdf" + +NETCDF95_INCDIR=-I$LMDGCM/../../include/NetCDF95 +NETCDF95_LIBDIR=-L$LMDGCM/../../lib +NETCDF95_LIB=-lnetcdf95 IOIPSL_INCDIR="-I$LMDGCM/../../lib -I$LMDGCM/../IOIPSL/inc" Index: LMDZ6/trunk/arch/arch-X64_IRENE.path =================================================================== --- LMDZ6/trunk/arch/arch-X64_IRENE.path (revision 4487) +++ LMDZ6/trunk/arch/arch-X64_IRENE.path (revision 4489) @@ -3,4 +3,8 @@ NETCDF_LIBDIR="-L$NETCDFFORTRAN_LIBDIR -L$NETCDF_LIBDIR" NETCDF_LIB="-lnetcdff -lnetcdf" + +NETCDF95_INCDIR=-I$LMDGCM/../../include/NetCDF95 +NETCDF95_LIBDIR=-L$LMDGCM/../../lib +NETCDF95_LIB=-lnetcdf95 IOIPSL_INCDIR="-I$LMDGCM/../../lib -I$LMDGCM/../IOIPSL/inc" Index: LMDZ6/trunk/arch/arch-X64_JEANZAY.path =================================================================== --- LMDZ6/trunk/arch/arch-X64_JEANZAY.path (revision 4487) +++ LMDZ6/trunk/arch/arch-X64_JEANZAY.path (revision 4489) @@ -5,4 +5,8 @@ NETCDF_LIBDIR="" NETCDF_LIB="-lnetcdff -lnetcdf" + +NETCDF95_INCDIR=-I$LMDGCM/../../include/NetCDF95 +NETCDF95_LIBDIR=-L$LMDGCM/../../lib +NETCDF95_LIB=-lnetcdf95 IOIPSL_INCDIR="-I$LMDGCM/../../lib -I$LMDGCM/../IOIPSL/inc" Index: LMDZ6/trunk/arch/arch-X64_OCCIGEN.path =================================================================== --- LMDZ6/trunk/arch/arch-X64_OCCIGEN.path (revision 4487) +++ LMDZ6/trunk/arch/arch-X64_OCCIGEN.path (revision 4489) @@ -1,4 +1,6 @@ NETCDF_LIBDIR="-L/opt/software/libraries/netcdf/bullxmpi/netcdf-fortran-4.4.1-4.3.3-rc2/lib -lnetcdff -L/opt/software/libraries/netcdf/bullxmpi/netcdf-4.3.3-rc2/lib -lnetcdf -L/opt/software/libraries/hdf5/hdf5_with_bullxmpi/1.8.14/lib -lhdf5_hl -lhdf5 -lz" NETCDF_INCDIR="-I/opt/software/libraries/hdf5/hdf5_with_bullxmpi/1.8.14/include -I/opt/software/libraries/netcdf/bullxmpi/netcdf-fortran-4.4.1-4.3.3-rc2/include" +NETCDF95_INCDIR=$LMDGCM/../../include/NetCDF95 +NETCDF95_LIBDIR=$LMDGCM/../../lib IOIPSL_INCDIR=$LMDGCM/../../lib IOIPSL_LIBDIR=$LMDGCM/../../lib Index: LMDZ6/trunk/arch/arch-X64_TITANE.path =================================================================== --- LMDZ6/trunk/arch/arch-X64_TITANE.path (revision 4487) +++ LMDZ6/trunk/arch/arch-X64_TITANE.path (revision 4489) @@ -1,4 +1,6 @@ NETCDF_LIBDIR="-L$NETCDF_LIB_DIR -lnetcdff -lnetcdf" NETCDF_INCDIR=-I$NETCDF_INC_DIR +NETCDF95_INCDIR=$LMDGCM/../../include +NETCDF95_LIBDIR=$LMDGCM/../../lib IOIPSL_INCDIR=$LMDGCM/../../lib IOIPSL_LIBDIR=$LMDGCM/../../lib Index: LMDZ6/trunk/arch/arch-g95.path =================================================================== --- LMDZ6/trunk/arch/arch-g95.path (revision 4487) +++ LMDZ6/trunk/arch/arch-g95.path (revision 4489) @@ -1,4 +1,6 @@ NETCDF_LIBDIR=... NETCDF_INCDIR=... +NETCDF95_LIBDIR=... +NETCDF95_INCDIR=... IOIPSL_INCDIR=... IOIPSL_LIBDIR=... Index: LMDZ6/trunk/arch/arch-gfortran.path =================================================================== --- LMDZ6/trunk/arch/arch-gfortran.path (revision 4487) +++ LMDZ6/trunk/arch/arch-gfortran.path (revision 4489) @@ -2,4 +2,8 @@ NETCDF_LIBDIR="" NETCDF_LIB="-lnetcdff -lnetcdf" + +NETCDF95_INCDIR=-I$LMDGCM/../../include/NetCDF95 +NETCDF95_LIBDIR=-L$LMDGCM/../../lib +NETCDF95_LIB=-lnetcdf95 IOIPSL_INCDIR="-I$LMDGCM/../../lib -I$LMDGCM/../IOIPSL/inc" Index: LMDZ6/trunk/arch/arch-gfortran_CICLAD.path =================================================================== --- LMDZ6/trunk/arch/arch-gfortran_CICLAD.path (revision 4487) +++ LMDZ6/trunk/arch/arch-gfortran_CICLAD.path (revision 4489) @@ -1,4 +1,6 @@ NETCDF_LIBDIR="-L${NETCDF_HOME}/lib -lnetcdf -lnetcdff" NETCDF_INCDIR=-I${NETCDF_HOME}/include +NETCDF95_INCDIR=$LMDGCM/../../include +NETCDF95_LIBDIR=$LMDGCM/../../lib IOIPSL_INCDIR=$LMDGCM/../../lib IOIPSL_LIBDIR=$LMDGCM/../../lib Index: LMDZ6/trunk/arch/arch-ifort_CICLAD.path =================================================================== --- LMDZ6/trunk/arch/arch-ifort_CICLAD.path (revision 4487) +++ LMDZ6/trunk/arch/arch-ifort_CICLAD.path (revision 4489) @@ -1,4 +1,6 @@ NETCDF_LIBDIR="-L${NETCDF_HOME}/lib -lnetcdf -lnetcdff" NETCDF_INCDIR=-I${NETCDF_HOME}/include +NETCDF95_INCDIR=$LMDGCM/../../include/NetCDF95 +NETCDF95_LIBDIR=$LMDGCM/../../lib IOIPSL_INCDIR="$LMDGCM/../../lib -I$LMDGCM/../IOIPSL/inc" IOIPSL_LIBDIR="$LMDGCM/../../lib -lioipsl -L$LMDGCM/../IOIPSL/lib" Index: LMDZ6/trunk/arch/arch-ifort_LSCE.path =================================================================== --- LMDZ6/trunk/arch/arch-ifort_LSCE.path (revision 4487) +++ LMDZ6/trunk/arch/arch-ifort_LSCE.path (revision 4489) @@ -1,4 +1,6 @@ NETCDF_LIBDIR="-L/usr/local/install/netcdf-4.3.2p/lib -lnetcdff -lnetcdf -L/usr/local/install/hdf5-1.8.9p/lib -lhdf5_hl -lhdf5 -lhdf5 -lz -lcurl" NETCDF_INCDIR=-I/usr/local/install/netcdf-4.3.2p/include +NETCDF95_INCDIR=$LMDGCM/../../include +NETCDF95_LIBDIR=$LMDGCM/../../lib IOIPSL_INCDIR="$LMDGCM/../../lib -I$LMDGCM/../IOIPSL/inc" IOIPSL_LIBDIR="$LMDGCM/../../lib -lioipsl -L$LMDGCM/../IOIPSL/lib" Index: LMDZ6/trunk/arch/arch-linux-32bit.path =================================================================== --- LMDZ6/trunk/arch/arch-linux-32bit.path (revision 4487) +++ LMDZ6/trunk/arch/arch-linux-32bit.path (revision 4489) @@ -1,4 +1,6 @@ NETCDF_LIBDIR="-L/usr/local/netcdf-pgi/lib -lnetcdf" NETCDF_INCDIR=-I/usr/local/netcdf-pgi/include +NETCDF95_INCDIR=... +NETCDF95_LIBDIR=... IOIPSL_INCDIR=... IOIPSL_LIBDIR=... Index: LMDZ6/trunk/arch/arch-pgf_CICLAD.path =================================================================== --- LMDZ6/trunk/arch/arch-pgf_CICLAD.path (revision 4487) +++ LMDZ6/trunk/arch/arch-pgf_CICLAD.path (revision 4489) @@ -1,4 +1,6 @@ NETCDF_LIBDIR="-L${NETCDF_HOME}/lib -lnetcdf -lnetcdff" NETCDF_INCDIR=-I${NETCDF_HOME}/include +NETCDF95_INCDIR=$LMDGCM/../../include/NetCDF95 +NETCDF95_LIBDIR=$LMDGCM/../../lib IOIPSL_INCDIR=$LMDGCM/../../lib IOIPSL_LIBDIR=$LMDGCM/../../lib Index: LMDZ6/trunk/bld.cfg =================================================================== --- LMDZ6/trunk/bld.cfg (revision 4487) +++ LMDZ6/trunk/bld.cfg (revision 4489) @@ -100,4 +100,5 @@ bld::excl_dep use::ifile_attr bld::excl_dep use::ixml_tree +bld::excl_dep use::netcdf95 # The following for INCA used with CPL bld::excl_dep use::incaoasis Index: LMDZ6/trunk/libf/misc/handle_err_m.F90 =================================================================== --- LMDZ6/trunk/libf/misc/handle_err_m.F90 (revision 4487) +++ (revision ) @@ -1,47 +1,0 @@ -! $Id$ -module handle_err_m - - implicit none - -contains - - subroutine handle_err(message, ncerr, ncid, varid) - - use netcdf, only: nf90_strerror, nf90_noerr, nf90_close - - character(len=*), intent(in):: message - ! (should include name of calling procedure) - - integer, intent(in):: ncerr - - integer, intent(in), optional :: ncid - ! (Provide this argument if you want "handle_err" to try to close - ! the file.) - - integer, intent(in), optional :: varid - - ! Variable local to the procedure: - integer ncerr_close - - !------------------- - - if (ncerr /= nf90_noerr) then - print *, "NetCDF95 handle_err:" - print *, message, ":" - if (present(varid)) print *, "varid = ", varid - print *, trim(nf90_strerror(ncerr)) - if (present(ncid)) then - ! Try to close, to leave the file in a consistent state: - ncerr_close = nf90_close(ncid) - ! (do not call "nf95_close", we do not want to recurse) - if (ncerr_close /= nf90_noerr) then - print *, "nf90_close:" - print *, trim(nf90_strerror(ncerr_close)) - end if - end if - call abort_physic("NetCDF95 handle_err", "see above", 1) - end if - - end subroutine handle_err - -end module handle_err_m Index: LMDZ6/trunk/libf/misc/netcdf95.F90 =================================================================== --- LMDZ6/trunk/libf/misc/netcdf95.F90 (revision 4487) +++ (revision ) @@ -1,17 +1,0 @@ -! $Id$ -module netcdf95 - - ! Author: Lionel GUEZ - ! See: - ! http://www.lmd.jussieu.fr/~lglmd/NetCDF95 - - use nf95_def_var_m - use nf95_put_var_m - use nf95_get_var_m - use nf95_gw_var_m - use nf95_put_att_m - use nf95_get_att_m - use simple - use handle_err_m - -end module netcdf95 Index: LMDZ6/trunk/libf/misc/nf95_def_var_m.F90 =================================================================== --- LMDZ6/trunk/libf/misc/nf95_def_var_m.F90 (revision 4487) +++ (revision ) @@ -1,102 +1,0 @@ -! $Id$ -module nf95_def_var_m - - ! The generic procedure name "nf90_def_var" applies to - ! "nf90_def_var_Scalar" but we cannot apply the generic procedure name - ! "nf95_def_var" to "nf95_def_var_scalar" because of the additional - ! optional argument. - ! "nf95_def_var_scalar" cannot be distinguished from "nf95_def_var_oneDim". - - implicit none - - interface nf95_def_var - module procedure nf95_def_var_oneDim, nf95_def_var_ManyDims - end interface - - private - public nf95_def_var, nf95_def_var_scalar - -contains - - subroutine nf95_def_var_scalar(ncid, name, xtype, varid, ncerr) - - use netcdf, only: nf90_def_var - use handle_err_m, only: handle_err - - integer, intent( in) :: ncid - character (len = *), intent( in) :: name - integer, intent( in) :: xtype - integer, intent(out) :: varid - integer, intent(out), optional:: ncerr - - ! Variable local to the procedure: - integer ncerr_not_opt - - !------------------- - - ncerr_not_opt = nf90_def_var(ncid, name, xtype, varid) - if (present(ncerr)) then - ncerr = ncerr_not_opt - else - call handle_err("nf95_def_var_scalar " // name, ncerr_not_opt, ncid) - end if - - end subroutine nf95_def_var_scalar - - !*********************** - - subroutine nf95_def_var_oneDim(ncid, name, xtype, dimids, varid, ncerr) - - use netcdf, only: nf90_def_var - use handle_err_m, only: handle_err - - integer, intent( in) :: ncid - character (len = *), intent( in) :: name - integer, intent( in) :: xtype - integer, intent( in) :: dimids - integer, intent(out) :: varid - integer, intent(out), optional:: ncerr - - ! Variable local to the procedure: - integer ncerr_not_opt - - !------------------- - - ncerr_not_opt = nf90_def_var(ncid, name, xtype, dimids, varid) - if (present(ncerr)) then - ncerr = ncerr_not_opt - else - call handle_err("nf95_def_var_oneDim " // name, ncerr_not_opt, ncid) - end if - - end subroutine nf95_def_var_oneDim - - !*********************** - - subroutine nf95_def_var_ManyDims(ncid, name, xtype, dimids, varid, ncerr) - - use netcdf, only: nf90_def_var - use handle_err_m, only: handle_err - - integer, intent( in) :: ncid - character (len = *), intent( in) :: name - integer, intent( in) :: xtype - integer, dimension(:), intent( in) :: dimids - integer, intent(out) :: varid - integer, intent(out), optional:: ncerr - - ! Variable local to the procedure: - integer ncerr_not_opt - - !------------------- - - ncerr_not_opt = nf90_def_var(ncid, name, xtype, dimids, varid) - if (present(ncerr)) then - ncerr = ncerr_not_opt - else - call handle_err("nf95_def_var_ManyDims " // name, ncerr_not_opt, ncid) - end if - - end subroutine nf95_def_var_ManyDims - -end module nf95_def_var_m Index: LMDZ6/trunk/libf/misc/nf95_get_att_m.F90 =================================================================== --- LMDZ6/trunk/libf/misc/nf95_get_att_m.F90 (revision 4487) +++ (revision ) @@ -1,105 +1,0 @@ -! $Id$ -module nf95_get_att_m - - use handle_err_m, only: handle_err - use netcdf, only: nf90_get_att, nf90_noerr - use simple, only: nf95_inquire_attribute - - implicit none - - interface nf95_get_att - module procedure nf95_get_att_text, nf95_get_att_one_FourByteInt - - ! The difference between the specific procedures is the type of - ! argument "values". - end interface - - private - public nf95_get_att - -contains - - subroutine nf95_get_att_text(ncid, varid, name, values, ncerr) - - integer, intent( in) :: ncid, varid - character(len = *), intent( in) :: name - character(len = *), intent(out) :: values - integer, intent(out), optional:: ncerr - - ! Variables local to the procedure: - integer ncerr_not_opt - integer att_len - - !------------------- - - ! Check that the length of "values" is large enough: - call nf95_inquire_attribute(ncid, varid, name, nclen=att_len, & - ncerr=ncerr_not_opt) - if (ncerr_not_opt == nf90_noerr) then - if (len(values) < att_len) then - print *, "nf95_get_att_text" - print *, "varid = ", varid - print *, "attribute name: ", name - print *, 'length of "values" is not large enough' - print *, "len(values) = ", len(values) - print *, "number of characters in attribute: ", att_len - stop 1 - end if - end if - - values = "" ! useless in NetCDF version 3.6.2 or better - ncerr_not_opt = nf90_get_att(ncid, varid, name, values) - if (present(ncerr)) then - ncerr = ncerr_not_opt - else - call handle_err("nf95_get_att_text " // trim(name), ncerr_not_opt, & - ncid, varid) - end if - - if (att_len >= 1 .and. ncerr_not_opt == nf90_noerr) then - ! Remove null terminator, if any: - if (iachar(values(att_len:att_len)) == 0) values(att_len:att_len) = " " - end if - - end subroutine nf95_get_att_text - - !*********************** - - subroutine nf95_get_att_one_FourByteInt(ncid, varid, name, values, ncerr) - - integer, intent( in) :: ncid, varid - character(len = *), intent( in) :: name - integer , intent(out) :: values - integer, intent(out), optional:: ncerr - - ! Variables local to the procedure: - integer ncerr_not_opt - integer att_len - - !------------------- - - ! Check that the attribute contains a single value: - call nf95_inquire_attribute(ncid, varid, name, nclen=att_len, & - ncerr=ncerr_not_opt) - if (ncerr_not_opt == nf90_noerr) then - if (att_len /= 1) then - print *, "nf95_get_att_one_FourByteInt" - print *, "varid = ", varid - print *, "attribute name: ", name - print *, 'the attribute does not contain a single value' - print *, "number of values in attribute: ", att_len - stop 1 - end if - end if - - ncerr_not_opt = nf90_get_att(ncid, varid, name, values) - if (present(ncerr)) then - ncerr = ncerr_not_opt - else - call handle_err("nf95_get_att_one_FourByteInt " // trim(name), & - ncerr_not_opt, ncid, varid) - end if - - end subroutine nf95_get_att_one_FourByteInt - -end module nf95_get_att_m Index: LMDZ6/trunk/libf/misc/nf95_get_var_m.F90 =================================================================== --- LMDZ6/trunk/libf/misc/nf95_get_var_m.F90 (revision 4487) +++ (revision ) @@ -1,391 +1,0 @@ -module nf95_get_var_m - - use netcdf, only: nf90_get_var - use handle_err_m, only: handle_err - - implicit none - - interface nf95_get_var - module procedure nf95_get_var_FourByteReal, nf95_get_var_FourByteInt, & - nf95_get_var_1D_FourByteReal, nf95_get_var_1D_FourByteInt, & - nf95_get_var_2D_FourByteReal, & - nf95_get_var_3D_FourByteInt, & - nf95_get_var_3D_FourByteReal, & - nf95_get_var_4D_FourByteReal, & - nf95_get_var_5D_FourByteReal - end interface - - private - public nf95_get_var - -contains - - subroutine nf95_get_var_FourByteReal(ncid, varid, values, start, ncerr) - - integer, intent(in) :: ncid, varid - real, intent(out) :: values - integer, dimension(:), optional, intent(in) :: start - integer, intent(out), optional:: ncerr - - ! Variable local to the procedure: - integer ncerr_not_opt - - !------------------- - - ncerr_not_opt = nf90_get_var(ncid, varid, values, start) - if (present(ncerr)) then - ncerr = ncerr_not_opt - else - call handle_err("nf95_get_var_FourByteReal", ncerr_not_opt, ncid, & - varid) - end if - - end subroutine nf95_get_var_FourByteReal - - !*********************** - - subroutine nf95_get_var_FourByteInt(ncid, varid, values, start, ncerr) - - integer, intent(in) :: ncid, varid - integer, intent(out) :: values - integer, dimension(:), optional, intent(in) :: start - integer, intent(out), optional:: ncerr - - ! Variable local to the procedure: - integer ncerr_not_opt - - !------------------- - - ncerr_not_opt = nf90_get_var(ncid, varid, values, start) - if (present(ncerr)) then - ncerr = ncerr_not_opt - else - call handle_err("nf95_get_var_FourByteInt", ncerr_not_opt, ncid, & - varid) - end if - - end subroutine nf95_get_var_FourByteInt - - !*********************** - - subroutine nf95_get_var_1D_FourByteReal(ncid, varid, values, start, & - count_nc, stride, map, ncerr) - - integer, intent(in) :: ncid, varid - real, intent(out) :: values(:) - integer, dimension(:), optional, intent(in) :: start, count_nc, stride, map - integer, intent(out), optional:: ncerr - - ! Variable local to the procedure: - integer ncerr_not_opt - - !------------------- - - ncerr_not_opt = nf90_get_var(ncid, varid, values, start, count_nc, & - stride, map) - if (present(ncerr)) then - ncerr = ncerr_not_opt - else - call handle_err("nf95_get_var_1D_FourByteReal", ncerr_not_opt, ncid, & - varid) - end if - - end subroutine nf95_get_var_1D_FourByteReal - - !*********************** - - subroutine nf95_get_var_1D_FourByteInt(ncid, varid, values, start, & - count_nc, stride, map, ncerr) - - integer, intent(in) :: ncid, varid - integer, intent(out) :: values(:) - integer, dimension(:), optional, intent(in) :: start, count_nc, stride, map - integer, intent(out), optional:: ncerr - - ! Variable local to the procedure: - integer ncerr_not_opt - - !------------------- - - ncerr_not_opt = nf90_get_var(ncid, varid, values, start, count_nc, & - stride, map) - if (present(ncerr)) then - ncerr = ncerr_not_opt - else - call handle_err("nf95_get_var_1D_FourByteInt", ncerr_not_opt, ncid, & - varid) - end if - - end subroutine nf95_get_var_1D_FourByteInt - - !*********************** - - subroutine nf95_get_var_1D_EightByteReal(ncid, varid, values, start, & - count_nc, stride, map, ncerr) - - use typesizes, only: eightByteReal - - integer, intent(in) :: ncid, varid - real (kind = EightByteReal), intent(out) :: values(:) - integer, dimension(:), optional, intent(in):: start, count_nc, stride, map - integer, intent(out), optional:: ncerr - - ! Variable local to the procedure: - integer ncerr_not_opt - - !------------------- - - ncerr_not_opt = nf90_get_var(ncid, varid, values, start, count_nc, & - stride, map) - if (present(ncerr)) then - ncerr = ncerr_not_opt - else - call handle_err("nf95_get_var_1D_eightByteReal", ncerr_not_opt, ncid, & - varid) - end if - - end subroutine nf95_get_var_1D_EightByteReal - - !*********************** - - subroutine nf95_get_var_2D_FourByteReal(ncid, varid, values, start, & - count_nc, stride, map, ncerr) - - integer, intent(in) :: ncid, varid - real , intent(out) :: values(:, :) - integer, dimension(:), optional, intent(in) :: start, count_nc, stride, map - integer, intent(out), optional:: ncerr - - ! Variable local to the procedure: - integer ncerr_not_opt - - !------------------- - - ncerr_not_opt = nf90_get_var(ncid, varid, values, start, count_nc, & - stride, map) - if (present(ncerr)) then - ncerr = ncerr_not_opt - else - call handle_err("nf95_get_var_2D_FourByteReal", ncerr_not_opt, ncid, & - varid) - end if - - end subroutine nf95_get_var_2D_FourByteReal - - !*********************** - - subroutine nf95_get_var_2D_EightByteReal(ncid, varid, values, start, & - count_nc, stride, map, ncerr) - - use typesizes, only: EightByteReal - - integer, intent(in) :: ncid, varid - real (kind = EightByteReal), intent(out) :: values(:, :) - integer, dimension(:), optional, intent(in) :: start, count_nc, stride, map - integer, intent(out), optional:: ncerr - - ! Variable local to the procedure: - integer ncerr_not_opt - - !------------------- - - ncerr_not_opt = nf90_get_var(ncid, varid, values, start, count_nc, & - stride, map) - if (present(ncerr)) then - ncerr = ncerr_not_opt - else - call handle_err("nf95_get_var_2D_EightByteReal", ncerr_not_opt, ncid, & - varid) - end if - - end subroutine nf95_get_var_2D_EightByteReal - - !*********************** - - subroutine nf95_get_var_3D_FourByteInt(ncid, varid, values, start, & - count_nc, stride, map, ncerr) - - integer, intent(in):: ncid, varid - integer, intent(out):: values(:, :, :) - integer, dimension(:), optional, intent(in):: start, count_nc, stride, map - integer, intent(out), optional:: ncerr - - ! Variable local to the procedure: - integer ncerr_not_opt - - !------------------- - - ncerr_not_opt = nf90_get_var(ncid, varid, values, start, count_nc, & - stride, map) - if (present(ncerr)) then - ncerr = ncerr_not_opt - else - call handle_err("nf95_get_var_3D_FourByteInt", ncerr_not_opt, ncid, & - varid) - end if - - end subroutine nf95_get_var_3D_FourByteInt - - !*********************** - - subroutine nf95_get_var_3D_FourByteReal(ncid, varid, values, start, & - count_nc, stride, map, ncerr) - - integer, intent(in) :: ncid, varid - real , intent(out) :: values(:, :, :) - integer, dimension(:), optional, intent(in) :: start, count_nc, stride, map - integer, intent(out), optional:: ncerr - - ! Variable local to the procedure: - integer ncerr_not_opt - - !------------------- - - ncerr_not_opt = nf90_get_var(ncid, varid, values, start, count_nc, & - stride, map) - if (present(ncerr)) then - ncerr = ncerr_not_opt - else - call handle_err("nf95_get_var_3D_FourByteReal", ncerr_not_opt, ncid, & - varid) - end if - - end subroutine nf95_get_var_3D_FourByteReal - - !*********************** - - subroutine nf95_get_var_3D_EightByteReal(ncid, varid, values, start, & - count_nc, stride, map, ncerr) - - use typesizes, only: eightByteReal - - integer, intent(in) :: ncid, varid - real (kind = EightByteReal), intent(out) :: values(:, :, :) - integer, dimension(:), optional, intent(in) :: start, count_nc, stride, map - integer, intent(out), optional:: ncerr - - ! Variable local to the procedure: - integer ncerr_not_opt - - !------------------- - - ncerr_not_opt = nf90_get_var(ncid, varid, values, start, count_nc, & - stride, map) - if (present(ncerr)) then - ncerr = ncerr_not_opt - else - call handle_err("nf95_get_var_3D_eightByteReal", ncerr_not_opt, ncid, & - varid) - end if - - end subroutine nf95_get_var_3D_EightByteReal - - !*********************** - - subroutine nf95_get_var_4D_FourByteReal(ncid, varid, values, start, & - count_nc, stride, map, ncerr) - - integer, intent(in) :: ncid, varid - real , intent(out) :: values(:, :, :, :) - integer, dimension(:), optional, intent(in) :: start, count_nc, stride, map - integer, intent(out), optional:: ncerr - - ! Variable local to the procedure: - integer ncerr_not_opt - - !------------------- - - ncerr_not_opt = nf90_get_var(ncid, varid, values, start, count_nc, & - stride, map) - if (present(ncerr)) then - ncerr = ncerr_not_opt - else - call handle_err("nf95_get_var_4D_FourByteReal", ncerr_not_opt, ncid, & - varid) - end if - - end subroutine nf95_get_var_4D_FourByteReal - - !*********************** - - subroutine nf95_get_var_4D_EightByteReal(ncid, varid, values, start, & - count_nc, stride, map, ncerr) - - use typesizes, only: EightByteReal - - integer, intent(in):: ncid, varid - real(kind = EightByteReal), intent(out):: values(:, :, :, :) - integer, dimension(:), optional, intent(in):: start, count_nc, stride, map - integer, intent(out), optional:: ncerr - - ! Variable local to the procedure: - integer ncerr_not_opt - - !------------------- - - ncerr_not_opt = nf90_get_var(ncid, varid, values, start, count_nc, & - stride, map) - if (present(ncerr)) then - ncerr = ncerr_not_opt - else - call handle_err("nf95_get_var_4D_EightByteReal", ncerr_not_opt, ncid, & - varid) - end if - - end subroutine nf95_get_var_4D_EightByteReal - - !*********************** - - subroutine nf95_get_var_5D_FourByteReal(ncid, varid, values, start, & - count_nc, stride, map, ncerr) - - integer, intent(in):: ncid, varid - real, intent(out):: values(:, :, :, :, :) - integer, dimension(:), optional, intent(in):: start, count_nc, stride, map - integer, intent(out), optional:: ncerr - - ! Variable local to the procedure: - integer ncerr_not_opt - - !------------------- - - ncerr_not_opt = nf90_get_var(ncid, varid, values, start, count_nc, & - stride, map) - if (present(ncerr)) then - ncerr = ncerr_not_opt - else - call handle_err("nf95_get_var_5D_FourByteReal", ncerr_not_opt, ncid, & - varid) - end if - - end subroutine nf95_get_var_5D_FourByteReal - - !*********************** - - subroutine nf95_get_var_5D_EightByteReal(ncid, varid, values, start, & - count_nc, stride, map, ncerr) - - use typesizes, only: EightByteReal - - integer, intent(in):: ncid, varid - real(kind = EightByteReal), intent(out):: values(:, :, :, :, :) - integer, dimension(:), optional, intent(in):: start, count_nc, stride, map - integer, intent(out), optional:: ncerr - - ! Variable local to the procedure: - integer ncerr_not_opt - - !------------------- - - ncerr_not_opt = nf90_get_var(ncid, varid, values, start, count_nc, & - stride, map) - if (present(ncerr)) then - ncerr = ncerr_not_opt - else - call handle_err("nf95_get_var_5D_EightByteReal", ncerr_not_opt, ncid, & - varid) - end if - - end subroutine nf95_get_var_5D_EightByteReal - -end module nf95_get_var_m Index: LMDZ6/trunk/libf/misc/nf95_gw_var_m.F90 =================================================================== --- LMDZ6/trunk/libf/misc/nf95_gw_var_m.F90 (revision 4487) +++ (revision ) @@ -1,336 +1,0 @@ -! $Id$ -module nf95_gw_var_m - - use nf95_get_var_m, only: NF95_GET_VAR - use simple, only: nf95_inquire_variable, nf95_inquire_dimension - - implicit none - - interface nf95_gw_var - ! "nf95_gw_var" stands for "NetCDF 1995 get whole variable". - ! These procedures read a whole NetCDF variable (coordinate or - ! primary) into an array. - ! The difference between the procedures is the rank and type of - ! argument "values". - ! The procedures do not check the type of the NetCDF variable. - - ! Not including double precision procedures in the generic - ! interface because we use a compilation option that changes default - ! real precision. - module procedure nf95_gw_var_real_1d, nf95_gw_var_real_2d, & - nf95_gw_var_real_3d, nf95_gw_var_real_4d, nf95_gw_var_real_5d, & - nf95_gw_var_int_1d, nf95_gw_var_int_3d - end interface - - private - public nf95_gw_var - -contains - - subroutine nf95_gw_var_real_1d(ncid, varid, values) - - ! Real type, the array has rank 1. - - integer, intent(in):: ncid - integer, intent(in):: varid - real, pointer:: values(:) - - ! Variables local to the procedure: - integer nclen - integer, pointer:: dimids(:) - - !--------------------- - - call nf95_inquire_variable(ncid, varid, dimids=dimids) - - if (size(dimids) /= 1) then - print *, "nf95_gw_var_real_1d:" - print *, "varid = ", varid - print *, "rank of NetCDF variable is ", size(dimids), ", not 1" - stop 1 - end if - - call nf95_inquire_dimension(ncid, dimids(1), nclen=nclen) - deallocate(dimids) ! pointer - - allocate(values(nclen)) - if (nclen /= 0) call NF95_GET_VAR(ncid, varid, values) - - end subroutine nf95_gw_var_real_1d - - !************************************ - - subroutine nf95_gw_var_real_2d(ncid, varid, values) - - ! Real type, the array has rank 2. - - integer, intent(in):: ncid - integer, intent(in):: varid - real, pointer:: values(:, :) - - ! Variables local to the procedure: - integer nclen1, nclen2 - integer, pointer:: dimids(:) - - !--------------------- - - call nf95_inquire_variable(ncid, varid, dimids=dimids) - - if (size(dimids) /= 2) then - print *, "nf95_gw_var_real_2d:" - print *, "varid = ", varid - print *, "rank of NetCDF variable is ", size(dimids), ", not 2" - stop 1 - end if - - call nf95_inquire_dimension(ncid, dimids(1), nclen=nclen1) - call nf95_inquire_dimension(ncid, dimids(2), nclen=nclen2) - deallocate(dimids) ! pointer - - allocate(values(nclen1, nclen2)) - if (nclen1 /= 0 .and. nclen2 /= 0) call NF95_GET_VAR(ncid, varid, values) - - end subroutine nf95_gw_var_real_2d - - !************************************ - - subroutine nf95_gw_var_real_3d(ncid, varid, values) - - ! Real type, the array has rank 3. - - integer, intent(in):: ncid - integer, intent(in):: varid - real, pointer:: values(:, :, :) - - ! Variables local to the procedure: - integer nclen1, nclen2, nclen3 - integer, pointer:: dimids(:) - - !--------------------- - - call nf95_inquire_variable(ncid, varid, dimids=dimids) - - if (size(dimids) /= 3) then - print *, "nf95_gw_var_real_3d:" - print *, "varid = ", varid - print *, "rank of NetCDF variable is ", size(dimids), ", not 3" - stop 1 - end if - - call nf95_inquire_dimension(ncid, dimids(1), nclen=nclen1) - call nf95_inquire_dimension(ncid, dimids(2), nclen=nclen2) - call nf95_inquire_dimension(ncid, dimids(3), nclen=nclen3) - deallocate(dimids) ! pointer - - allocate(values(nclen1, nclen2, nclen3)) - if (nclen1 * nclen2 * nclen3 /= 0) call NF95_GET_VAR(ncid, varid, values) - - end subroutine nf95_gw_var_real_3d - - !************************************ - - subroutine nf95_gw_var_real_4d(ncid, varid, values) - - ! Real type, the array has rank 4. - - integer, intent(in):: ncid - integer, intent(in):: varid - real, pointer:: values(:, :, :, :) - - ! Variables local to the procedure: - integer len_dim(4), i - integer, pointer:: dimids(:) - - !--------------------- - - call nf95_inquire_variable(ncid, varid, dimids=dimids) - - if (size(dimids) /= 4) then - print *, "nf95_gw_var_real_4d:" - print *, "varid = ", varid - print *, "rank of NetCDF variable is ", size(dimids), ", not 4" - stop 1 - end if - - do i = 1, 4 - call nf95_inquire_dimension(ncid, dimids(i), nclen=len_dim(i)) - end do - deallocate(dimids) ! pointer - - allocate(values(len_dim(1), len_dim(2), len_dim(3), len_dim(4))) - if (all(len_dim /= 0)) call NF95_GET_VAR(ncid, varid, values) - - end subroutine nf95_gw_var_real_4d - - !************************************ - - subroutine nf95_gw_var_real_5d(ncid, varid, values) - - ! Real type, the array has rank 5. - - integer, intent(in):: ncid - integer, intent(in):: varid - real, pointer:: values(:, :, :, :, :) - - ! Variables local to the procedure: - integer len_dim(5), i - integer, pointer:: dimids(:) - - !--------------------- - - call nf95_inquire_variable(ncid, varid, dimids=dimids) - - if (size(dimids) /= 5) then - print *, "nf95_gw_var_real_5d:" - print *, "varid = ", varid - print *, "rank of NetCDF variable is ", size(dimids), ", not 5" - stop 1 - end if - - do i = 1, 5 - call nf95_inquire_dimension(ncid, dimids(i), nclen=len_dim(i)) - end do - deallocate(dimids) ! pointer - - allocate(values(len_dim(1), len_dim(2), len_dim(3), len_dim(4), len_dim(5))) - if (all(len_dim /= 0)) call NF95_GET_VAR(ncid, varid, values) - - end subroutine nf95_gw_var_real_5d - - !************************************ - -!!$ subroutine nf95_gw_var_dble_1d(ncid, varid, values) -!!$ -!!$ ! Double precision, the array has rank 1. -!!$ -!!$ integer, intent(in):: ncid -!!$ integer, intent(in):: varid -!!$ double precision, pointer:: values(:) -!!$ -!!$ ! Variables local to the procedure: -!!$ integer nclen -!!$ integer, pointer:: dimids(:) -!!$ -!!$ !--------------------- -!!$ -!!$ call nf95_inquire_variable(ncid, varid, dimids=dimids) -!!$ -!!$ if (size(dimids) /= 1) then -!!$ print *, "nf95_gw_var_dble_1d:" -!!$ print *, "varid = ", varid -!!$ print *, "rank of NetCDF variable is ", size(dimids), ", not 1" -!!$ stop 1 -!!$ end if -!!$ -!!$ call nf95_inquire_dimension(ncid, dimids(1), nclen=nclen) -!!$ deallocate(dimids) ! pointer -!!$ -!!$ allocate(values(nclen)) -!!$ if (nclen /= 0) call NF95_GET_VAR(ncid, varid, values) -!!$ -!!$ end subroutine nf95_gw_var_dble_1d -!!$ -!!$ !************************************ -!!$ -!!$ subroutine nf95_gw_var_dble_3d(ncid, varid, values) -!!$ -!!$ ! Double precision, the array has rank 3. -!!$ -!!$ integer, intent(in):: ncid -!!$ integer, intent(in):: varid -!!$ double precision, pointer:: values(:, :, :) -!!$ -!!$ ! Variables local to the procedure: -!!$ integer nclen1, nclen2, nclen3 -!!$ integer, pointer:: dimids(:) -!!$ -!!$ !--------------------- -!!$ -!!$ call nf95_inquire_variable(ncid, varid, dimids=dimids) -!!$ -!!$ if (size(dimids) /= 3) then -!!$ print *, "nf95_gw_var_dble_3d:" -!!$ print *, "varid = ", varid -!!$ print *, "rank of NetCDF variable is ", size(dimids), ", not 3" -!!$ stop 1 -!!$ end if -!!$ -!!$ call nf95_inquire_dimension(ncid, dimids(1), nclen=nclen1) -!!$ call nf95_inquire_dimension(ncid, dimids(2), nclen=nclen2) -!!$ call nf95_inquire_dimension(ncid, dimids(3), nclen=nclen3) -!!$ deallocate(dimids) ! pointer -!!$ -!!$ allocate(values(nclen1, nclen2, nclen3)) -!!$ if (nclen1 * nclen2 * nclen3 /= 0) call NF95_GET_VAR(ncid, varid, values) -!!$ -!!$ end subroutine nf95_gw_var_dble_3d -!!$ - !************************************ - - subroutine nf95_gw_var_int_1d(ncid, varid, values) - - ! Integer type, the array has rank 1. - - integer, intent(in):: ncid - integer, intent(in):: varid - integer, pointer:: values(:) - - ! Variables local to the procedure: - integer nclen - integer, pointer:: dimids(:) - - !--------------------- - - call nf95_inquire_variable(ncid, varid, dimids=dimids) - - if (size(dimids) /= 1) then - print *, "nf95_gw_var_int_1d:" - print *, "varid = ", varid - print *, "rank of NetCDF variable is ", size(dimids), ", not 1" - stop 1 - end if - - call nf95_inquire_dimension(ncid, dimids(1), nclen=nclen) - deallocate(dimids) ! pointer - - allocate(values(nclen)) - if (nclen /= 0) call NF95_GET_VAR(ncid, varid, values) - - end subroutine nf95_gw_var_int_1d - - !************************************ - - subroutine nf95_gw_var_int_3d(ncid, varid, values) - - ! Integer type, the array has rank 3. - - integer, intent(in):: ncid - integer, intent(in):: varid - integer, pointer:: values(:, :, :) - - ! Variables local to the procedure: - integer nclen1, nclen2, nclen3 - integer, pointer:: dimids(:) - - !--------------------- - - call nf95_inquire_variable(ncid, varid, dimids=dimids) - - if (size(dimids) /= 3) then - print *, "nf95_gw_var_int_3d:" - print *, "varid = ", varid - print *, "rank of NetCDF variable is ", size(dimids), ", not 3" - stop 1 - end if - - call nf95_inquire_dimension(ncid, dimids(1), nclen=nclen1) - call nf95_inquire_dimension(ncid, dimids(2), nclen=nclen2) - call nf95_inquire_dimension(ncid, dimids(3), nclen=nclen3) - deallocate(dimids) ! pointer - - allocate(values(nclen1, nclen2, nclen3)) - if (nclen1 * nclen2 * nclen3 /= 0) call NF95_GET_VAR(ncid, varid, values) - - end subroutine nf95_gw_var_int_3d - -end module nf95_gw_var_m Index: LMDZ6/trunk/libf/misc/nf95_put_att_m.F90 =================================================================== --- LMDZ6/trunk/libf/misc/nf95_put_att_m.F90 (revision 4487) +++ (revision ) @@ -1,67 +1,0 @@ -! $Id$ -module nf95_put_att_m - - implicit none - - interface nf95_put_att - module procedure nf95_put_att_text, nf95_put_att_one_FourByteInt - end interface - - private - public nf95_put_att - -contains - - subroutine nf95_put_att_text(ncid, varid, name, values, ncerr) - - use netcdf, only: nf90_put_att - use handle_err_m, only: handle_err - - integer, intent(in) :: ncid, varid - character(len = *), intent(in) :: name - character(len = *), intent(in) :: values - integer, intent(out), optional:: ncerr - - ! Variable local to the procedure: - integer ncerr_not_opt - - !------------------- - - ncerr_not_opt = nf90_put_att(ncid, varid, name, values) - if (present(ncerr)) then - ncerr = ncerr_not_opt - else - call handle_err("nf95_put_att_text", ncerr_not_opt, ncid, varid) - end if - - end subroutine nf95_put_att_text - - !************************************ - - subroutine nf95_put_att_one_FourByteInt(ncid, varid, name, values, ncerr) - - use netcdf, only: nf90_put_att - use handle_err_m, only: handle_err - use typesizes, only: FourByteInt - - integer, intent(in) :: ncid, varid - character(len = *), intent(in) :: name - integer(kind = FourByteInt), intent(in) :: values - integer, intent(out), optional:: ncerr - - ! Variable local to the procedure: - integer ncerr_not_opt - - !------------------- - - ncerr_not_opt = nf90_put_att(ncid, varid, name, values) - if (present(ncerr)) then - ncerr = ncerr_not_opt - else - call handle_err("nf95_put_att_one_FourByteInt", ncerr_not_opt, ncid, & - varid) - end if - - end subroutine nf95_put_att_one_FourByteInt - -end module nf95_put_att_m Index: LMDZ6/trunk/libf/misc/nf95_put_var_m.F90 =================================================================== --- LMDZ6/trunk/libf/misc/nf95_put_var_m.F90 (revision 4487) +++ (revision ) @@ -1,335 +1,0 @@ -! $Id$ -module nf95_put_var_m - - implicit none - - interface nf95_put_var - module procedure nf95_put_var_FourByteReal, nf95_put_var_FourByteInt, & - nf95_put_var_1D_FourByteReal, nf95_put_var_1D_FourByteInt, & - nf95_put_var_2D_FourByteReal, nf95_put_var_3D_FourByteReal, & - nf95_put_var_4D_FourByteReal - end interface - - private - public nf95_put_var - -contains - - subroutine nf95_put_var_FourByteReal(ncid, varid, values, start, ncerr) - - use netcdf, only: nf90_put_var - use handle_err_m, only: handle_err - - integer, intent(in) :: ncid, varid - real, intent(in) :: values - integer, dimension(:), optional, intent(in) :: start - integer, intent(out), optional:: ncerr - - ! Variable local to the procedure: - integer ncerr_not_opt - - !------------------- - - ncerr_not_opt = nf90_put_var(ncid, varid, values, start) - if (present(ncerr)) then - ncerr = ncerr_not_opt - else - call handle_err("nf95_put_var_FourByteReal", ncerr_not_opt, ncid, & - varid) - end if - - end subroutine nf95_put_var_FourByteReal - - !*********************** - - subroutine nf95_put_var_FourByteInt(ncid, varid, values, start, ncerr) - - use netcdf, only: nf90_put_var - use handle_err_m, only: handle_err - - integer, intent(in) :: ncid, varid - integer, intent(in) :: values - integer, dimension(:), optional, intent(in) :: start - integer, intent(out), optional:: ncerr - - ! Variable local to the procedure: - integer ncerr_not_opt - - !------------------- - - ncerr_not_opt = nf90_put_var(ncid, varid, values, start) - if (present(ncerr)) then - ncerr = ncerr_not_opt - else - call handle_err("nf95_put_var_FourByteInt", ncerr_not_opt, ncid, & - varid) - end if - - end subroutine nf95_put_var_FourByteInt - - !*********************** - - subroutine nf95_put_var_1D_FourByteReal(ncid, varid, values, start, & - count_nc, stride, map, ncerr) - - use netcdf, only: nf90_put_var - use handle_err_m, only: handle_err - - integer, intent(in) :: ncid, varid - real, intent(in) :: values(:) - integer, dimension(:), optional, intent(in) :: start, count_nc, stride, map - integer, intent(out), optional:: ncerr - - ! Variable local to the procedure: - integer ncerr_not_opt - - !------------------- - - ncerr_not_opt = nf90_put_var(ncid, varid, values, start, count_nc, & - stride, map) - if (present(ncerr)) then - ncerr = ncerr_not_opt - else - call handle_err("nf95_put_var_1D_FourByteReal", ncerr_not_opt, ncid, & - varid) - end if - - end subroutine nf95_put_var_1D_FourByteReal - - !*********************** - - subroutine nf95_put_var_1D_FourByteInt(ncid, varid, values, start, & - count_nc, stride, map, ncerr) - - use netcdf, only: nf90_put_var - use handle_err_m, only: handle_err - - integer, intent(in) :: ncid, varid - integer, intent(in) :: values(:) - integer, dimension(:), optional, intent(in) :: start, count_nc, stride, map - integer, intent(out), optional:: ncerr - - ! Variable local to the procedure: - integer ncerr_not_opt - - !------------------- - - ncerr_not_opt = nf90_put_var(ncid, varid, values, start, count_nc, & - stride, map) - if (present(ncerr)) then - ncerr = ncerr_not_opt - else - call handle_err("nf95_put_var_1D_FourByteInt", ncerr_not_opt, ncid, & - varid) - end if - - end subroutine nf95_put_var_1D_FourByteInt - - !*********************** - - subroutine nf95_put_var_1D_EightByteReal(ncid, varid, values, start, & - count_nc, stride, map, ncerr) - - use typesizes, only: eightByteReal - use netcdf, only: nf90_put_var - use handle_err_m, only: handle_err - - integer, intent(in) :: ncid, varid - real (kind = EightByteReal), intent(in) :: values(:) - integer, dimension(:), optional, intent(in):: start, count_nc, stride, map - integer, intent(out), optional:: ncerr - - ! Variable local to the procedure: - integer ncerr_not_opt - - !------------------- - - ncerr_not_opt = nf90_put_var(ncid, varid, values, start, count_nc, & - stride, map) - if (present(ncerr)) then - ncerr = ncerr_not_opt - else - call handle_err("nf95_put_var_1D_eightByteReal", ncerr_not_opt, ncid, & - varid) - end if - - end subroutine nf95_put_var_1D_EightByteReal - - !*********************** - - subroutine nf95_put_var_2D_FourByteReal(ncid, varid, values, start, & - count_nc, stride, map, ncerr) - - use netcdf, only: nf90_put_var - use handle_err_m, only: handle_err - - integer, intent(in) :: ncid, varid - real, intent(in) :: values(:, :) - integer, dimension(:), optional, intent(in) :: start, count_nc, stride, map - integer, intent(out), optional:: ncerr - - ! Variable local to the procedure: - integer ncerr_not_opt - - !------------------- - - ncerr_not_opt = nf90_put_var(ncid, varid, values, start, count_nc, & - stride, map) - if (present(ncerr)) then - ncerr = ncerr_not_opt - else - call handle_err("nf95_put_var_2D_FourByteReal", ncerr_not_opt, ncid, & - varid) - end if - - end subroutine nf95_put_var_2D_FourByteReal - - !*********************** - - subroutine nf95_put_var_2D_EightByteReal(ncid, varid, values, start, & - count_nc, stride, map, ncerr) - - use typesizes, only: EightByteReal - use netcdf, only: nf90_put_var - use handle_err_m, only: handle_err - - integer, intent(in) :: ncid, varid - real (kind = EightByteReal), intent(in) :: values(:, :) - integer, dimension(:), optional, intent(in) :: start, count_nc, stride, map - integer, intent(out), optional:: ncerr - - ! Variable local to the procedure: - integer ncerr_not_opt - - !------------------- - - ncerr_not_opt = nf90_put_var(ncid, varid, values, start, count_nc, & - stride, map) - if (present(ncerr)) then - ncerr = ncerr_not_opt - else - call handle_err("nf95_put_var_2D_EightByteReal", ncerr_not_opt, ncid, & - varid) - end if - - end subroutine nf95_put_var_2D_EightByteReal - - !*********************** - - subroutine nf95_put_var_3D_FourByteReal(ncid, varid, values, start, & - count_nc, stride, map, ncerr) - - use netcdf, only: nf90_put_var - use handle_err_m, only: handle_err - - integer, intent(in) :: ncid, varid - real, intent(in) :: values(:, :, :) - integer, dimension(:), optional, intent(in) :: start, count_nc, stride, map - integer, intent(out), optional:: ncerr - - ! Variable local to the procedure: - integer ncerr_not_opt - - !------------------- - - ncerr_not_opt = nf90_put_var(ncid, varid, values, start, count_nc, & - stride, map) - if (present(ncerr)) then - ncerr = ncerr_not_opt - else - call handle_err("nf95_put_var_3D_FourByteReal", ncerr_not_opt, ncid, & - varid) - end if - - end subroutine nf95_put_var_3D_FourByteReal - - !*********************** - - subroutine nf95_put_var_3D_EightByteReal(ncid, varid, values, start, & - count_nc, stride, map, ncerr) - - use typesizes, only: eightByteReal - use netcdf, only: nf90_put_var - use handle_err_m, only: handle_err - - integer, intent(in) :: ncid, varid - real (kind = EightByteReal), intent(in) :: values(:, :, :) - integer, dimension(:), optional, intent(in) :: start, count_nc, stride, map - integer, intent(out), optional:: ncerr - - ! Variable local to the procedure: - integer ncerr_not_opt - - !------------------- - - ncerr_not_opt = nf90_put_var(ncid, varid, values, start, count_nc, & - stride, map) - if (present(ncerr)) then - ncerr = ncerr_not_opt - else - call handle_err("nf95_put_var_3D_eightByteReal", ncerr_not_opt, ncid, & - varid) - end if - - end subroutine nf95_put_var_3D_EightByteReal - - !*********************** - - subroutine nf95_put_var_4D_FourByteReal(ncid, varid, values, start, & - count_nc, stride, map, ncerr) - - use netcdf, only: nf90_put_var - use handle_err_m, only: handle_err - - integer, intent(in) :: ncid, varid - real, intent(in) :: values(:, :, :, :) - integer, dimension(:), optional, intent(in) :: start, count_nc, stride, map - integer, intent(out), optional:: ncerr - - ! Variable local to the procedure: - integer ncerr_not_opt - - !------------------- - - ncerr_not_opt = nf90_put_var(ncid, varid, values, start, count_nc, & - stride, map) - if (present(ncerr)) then - ncerr = ncerr_not_opt - else - call handle_err("nf95_put_var_4D_FourByteReal", ncerr_not_opt, ncid, & - varid) - end if - - end subroutine nf95_put_var_4D_FourByteReal - - !*********************** - - subroutine nf95_put_var_4D_EightByteReal(ncid, varid, values, start, & - count_nc, stride, map, ncerr) - - use typesizes, only: EightByteReal - use netcdf, only: nf90_put_var - use handle_err_m, only: handle_err - - integer, intent(in):: ncid, varid - real(kind = EightByteReal), intent(in):: values(:, :, :, :) - integer, dimension(:), optional, intent(in):: start, count_nc, stride, map - integer, intent(out), optional:: ncerr - - ! Variable local to the procedure: - integer ncerr_not_opt - - !------------------- - - ncerr_not_opt = nf90_put_var(ncid, varid, values, start, count_nc, & - stride, map) - if (present(ncerr)) then - ncerr = ncerr_not_opt - else - call handle_err("nf95_put_var_4D_EightByteReal", ncerr_not_opt, ncid, & - varid) - end if - - end subroutine nf95_put_var_4D_EightByteReal - -end module nf95_put_var_m Index: LMDZ6/trunk/libf/misc/simple.F90 =================================================================== --- LMDZ6/trunk/libf/misc/simple.F90 (revision 4487) +++ (revision ) @@ -1,361 +1,0 @@ -! $Id$ -module simple - - use handle_err_m, only: handle_err - - implicit none - - private handle_err - -contains - - subroutine nf95_open(path, mode, ncid, chunksize, ncerr) - - use netcdf, only: nf90_open - - character(len=*), intent(in):: path - integer, intent(in):: mode - integer, intent(out):: ncid - integer, intent(inout), optional:: chunksize - integer, intent(out), optional:: ncerr - - ! Variable local to the procedure: - integer ncerr_not_opt - - !------------------- - - ncerr_not_opt = nf90_open(path, mode, ncid, chunksize) - if (present(ncerr)) then - ncerr = ncerr_not_opt - else - call handle_err("nf95_open " // path, ncerr_not_opt) - end if - - end subroutine nf95_open - - !************************ - - subroutine nf95_inq_dimid(ncid, name, dimid, ncerr) - - use netcdf, only: nf90_inq_dimid - - integer, intent(in) :: ncid - character (len = *), intent(in) :: name - integer, intent(out) :: dimid - integer, intent(out), optional:: ncerr - - ! Variable local to the procedure: - integer ncerr_not_opt - - !------------------- - - ncerr_not_opt = nf90_inq_dimid(ncid, name, dimid) - if (present(ncerr)) then - ncerr = ncerr_not_opt - else - call handle_err("nf95_inq_dimid " // name, ncerr_not_opt, ncid) - end if - - end subroutine nf95_inq_dimid - - !************************ - - subroutine nf95_inquire_dimension(ncid, dimid, name, nclen, ncerr) - - use netcdf, only: nf90_inquire_dimension - - integer, intent( in) :: ncid, dimid - character (len = *), optional, intent(out) :: name - integer, optional, intent(out) :: nclen - integer, intent(out), optional:: ncerr - - ! Variable local to the procedure: - integer ncerr_not_opt - - !------------------- - - ncerr_not_opt = nf90_inquire_dimension(ncid, dimid, name, nclen) - if (present(ncerr)) then - ncerr = ncerr_not_opt - else - call handle_err("nf95_inquire_dimension", ncerr_not_opt, ncid) - end if - - end subroutine nf95_inquire_dimension - - !************************ - - subroutine nf95_inq_varid(ncid, name, varid, ncerr) - - use netcdf, only: nf90_inq_varid - - integer, intent(in) :: ncid - character(len=*), intent(in):: name - integer, intent(out) :: varid - integer, intent(out), optional:: ncerr - - ! Variable local to the procedure: - integer ncerr_not_opt - - !------------------- - - ncerr_not_opt = nf90_inq_varid(ncid, name, varid) - if (present(ncerr)) then - ncerr = ncerr_not_opt - else - call handle_err("nf95_inq_varid, name = " // name, ncerr_not_opt, ncid) - end if - - end subroutine nf95_inq_varid - - !************************ - - subroutine nf95_inquire_variable(ncid, varid, name, xtype, ndims, dimids, & - nAtts, ncerr) - - ! In "nf90_inquire_variable", "dimids" is an assumed-size array. - ! This is not optimal. - ! We are in the classical case of an array the size of which is - ! unknown in the calling procedure, before the call. - ! Here we use a better solution: a pointer argument array. - ! This procedure associates and defines "dimids" if it is present. - - use netcdf, only: nf90_inquire_variable, nf90_max_var_dims - - integer, intent(in):: ncid, varid - character(len = *), optional, intent(out):: name - integer, optional, intent(out) :: xtype, ndims - integer, dimension(:), optional, pointer :: dimids - integer, optional, intent(out) :: nAtts - integer, intent(out), optional :: ncerr - - ! Variable local to the procedure: - integer ncerr_not_opt - integer dimids_local(nf90_max_var_dims) - integer ndims_not_opt - - !------------------- - - if (present(dimids)) then - ncerr_not_opt = nf90_inquire_variable(ncid, varid, name, xtype, & - ndims_not_opt, dimids_local, nAtts) - allocate(dimids(ndims_not_opt)) ! also works if ndims_not_opt == 0 - dimids = dimids_local(:ndims_not_opt) - if (present(ndims)) ndims = ndims_not_opt - else - ncerr_not_opt = nf90_inquire_variable(ncid, varid, name, xtype, ndims, & - nAtts=nAtts) - end if - - if (present(ncerr)) then - ncerr = ncerr_not_opt - else - call handle_err("nf95_inquire_variable", ncerr_not_opt, ncid, varid) - end if - - end subroutine nf95_inquire_variable - - !************************ - - subroutine nf95_create(path, cmode, ncid, initialsize, chunksize, ncerr) - - use netcdf, only: nf90_create - - character (len = *), intent(in ) :: path - integer, intent(in ) :: cmode - integer, intent( out) :: ncid - integer, optional, intent(in ) :: initialsize - integer, optional, intent(inout) :: chunksize - integer, intent(out), optional :: ncerr - - ! Variable local to the procedure: - integer ncerr_not_opt - - !------------------- - - ncerr_not_opt = nf90_create(path, cmode, ncid, initialsize, chunksize) - if (present(ncerr)) then - ncerr = ncerr_not_opt - else - call handle_err("nf95_create " // path, ncerr_not_opt) - end if - - end subroutine nf95_create - - !************************ - - subroutine nf95_def_dim(ncid, name, nclen, dimid, ncerr) - - use netcdf, only: nf90_def_dim - - integer, intent( in) :: ncid - character (len = *), intent( in) :: name - integer, intent( in) :: nclen - integer, intent(out) :: dimid - integer, intent(out), optional :: ncerr - - ! Variable local to the procedure: - integer ncerr_not_opt - - !------------------- - - ncerr_not_opt = nf90_def_dim(ncid, name, nclen, dimid) - if (present(ncerr)) then - ncerr = ncerr_not_opt - else - call handle_err("nf95_def_dim " // name, ncerr_not_opt, ncid) - end if - - end subroutine nf95_def_dim - - !*********************** - - subroutine nf95_redef(ncid, ncerr) - - use netcdf, only: nf90_redef - - integer, intent( in) :: ncid - integer, intent(out), optional :: ncerr - - ! Variable local to the procedure: - integer ncerr_not_opt - - !------------------- - - ncerr_not_opt = nf90_redef(ncid) - if (present(ncerr)) then - ncerr = ncerr_not_opt - else - call handle_err("nf95_redef", ncerr_not_opt, ncid) - end if - - end subroutine nf95_redef - - !*********************** - - subroutine nf95_enddef(ncid, h_minfree, v_align, v_minfree, r_align, ncerr) - - use netcdf, only: nf90_enddef - - integer, intent( in) :: ncid - integer, optional, intent( in) :: h_minfree, v_align, v_minfree, r_align - integer, intent(out), optional :: ncerr - - ! Variable local to the procedure: - integer ncerr_not_opt - - !------------------- - - ncerr_not_opt = nf90_enddef(ncid, h_minfree, v_align, v_minfree, r_align) - if (present(ncerr)) then - ncerr = ncerr_not_opt - else - call handle_err("nf95_enddef", ncerr_not_opt, ncid) - end if - - end subroutine nf95_enddef - - !*********************** - - subroutine nf95_close(ncid, ncerr) - - use netcdf, only: nf90_close - - integer, intent( in) :: ncid - integer, intent(out), optional :: ncerr - - ! Variable local to the procedure: - integer ncerr_not_opt - - !------------------- - - ncerr_not_opt = nf90_close(ncid) - if (present(ncerr)) then - ncerr = ncerr_not_opt - else - call handle_err("nf95_close", ncerr_not_opt) - end if - - end subroutine nf95_close - - !*********************** - - subroutine nf95_copy_att(ncid_in, varid_in, name, ncid_out, varid_out, ncerr) - - use netcdf, only: nf90_copy_att - - integer, intent( in):: ncid_in, varid_in - character(len=*), intent( in):: name - integer, intent( in):: ncid_out, varid_out - integer, intent(out), optional:: ncerr - - ! Variable local to the procedure: - integer ncerr_not_opt - - !------------------- - - ncerr_not_opt = nf90_copy_att(ncid_in, varid_in, name, ncid_out, varid_out) - if (present(ncerr)) then - ncerr = ncerr_not_opt - else - call handle_err("nf95_copy_att " // name, ncerr_not_opt, ncid_out) - end if - - end subroutine nf95_copy_att - - !*********************** - - subroutine nf95_inquire_attribute(ncid, varid, name, xtype, nclen, attnum, & - ncerr) - - use netcdf, only: nf90_inquire_attribute - - integer, intent( in) :: ncid, varid - character (len = *), intent( in) :: name - integer, intent(out), optional :: xtype, nclen, attnum - integer, intent(out), optional:: ncerr - - ! Variable local to the procedure: - integer ncerr_not_opt - - !------------------- - - ncerr_not_opt = nf90_inquire_attribute(ncid, varid, name, xtype, nclen, & - attnum) - if (present(ncerr)) then - ncerr = ncerr_not_opt - else - call handle_err("nf95_inquire_attribute " // name, ncerr_not_opt, & - ncid, varid) - end if - - end subroutine nf95_inquire_attribute - - !*********************** - - subroutine nf95_inquire(ncid, nDimensions, nVariables, nAttributes, & - unlimitedDimId, formatNum, ncerr) - - use netcdf, only: nf90_inquire - - integer, intent( in) :: ncid - integer, optional, intent(out) :: nDimensions, nVariables, nAttributes - integer, optional, intent(out) :: unlimitedDimId, formatNum - integer, intent(out), optional:: ncerr - - ! Variable local to the procedure: - integer ncerr_not_opt - - !------------------- - - ncerr_not_opt = nf90_inquire(ncid, nDimensions, nVariables, nAttributes, & - unlimitedDimId, formatNum) - if (present(ncerr)) then - ncerr = ncerr_not_opt - else - call handle_err("nf95_inquire", ncerr_not_opt, ncid) - end if - - end subroutine nf95_inquire - -end module simple Index: LMDZ6/trunk/libf/phylmd/ecrad/easy_netcdf.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad/easy_netcdf.F90 (revision 4487) +++ LMDZ6/trunk/libf/phylmd/ecrad/easy_netcdf.F90 (revision 4489) @@ -35,5 +35,5 @@ ! a NetCDF file type netcdf_file - integer :: ncid ! NetCDF file ID + integer :: ncid = -1! NetCDF file ID integer :: iverbose ! Verbosity: 0 = report only fatal errors, ! 1 = ...and warnings, @@ -55,7 +55,9 @@ procedure :: create => create_netcdf_file procedure :: close => close_netcdf_file + procedure :: is_open procedure :: get_real_scalar + procedure :: get_int_scalar procedure :: get_real_vector - procedure :: get_integer_vector + procedure :: get_int_vector procedure :: get_real_matrix procedure :: get_real_array3 @@ -65,9 +67,13 @@ procedure :: get_real_array3_indexed procedure :: get_real_array4 - generic :: get => get_real_scalar, get_real_vector, & + procedure :: get_char_vector + procedure :: get_char_matrix + generic :: get => get_real_scalar, get_int_scalar, & + & get_real_vector, get_int_vector, & & get_real_matrix, get_real_array3, & - & get_real_array4, get_integer_vector, & + & get_real_array4, & & get_real_scalar_indexed, get_real_vector_indexed, & - & get_real_matrix_indexed, get_real_array3_indexed + & get_real_matrix_indexed, get_real_array3_indexed, & + & get_char_vector, get_char_matrix procedure :: get_real_scalar_attribute procedure :: get_string_attribute @@ -83,4 +89,5 @@ procedure :: put_real_scalar procedure :: put_real_vector + procedure :: put_int_vector procedure :: put_real_matrix procedure :: put_real_array3 @@ -91,5 +98,5 @@ & put_real_matrix, put_real_array3, & & put_real_scalar_indexed, put_real_vector_indexed, & - & put_real_matrix_indexed + & put_real_matrix_indexed, put_int_vector procedure :: set_verbose procedure :: transpose_matrices @@ -101,4 +108,9 @@ procedure :: attribute_exists procedure :: global_attribute_exists +#ifdef NC_NETCDF4 + procedure :: copy_dimensions +#endif + procedure :: copy_variable_definition + procedure :: copy_variable procedure, private :: get_array_dimensions procedure, private :: get_variable_id @@ -257,4 +269,6 @@ end if + this%ncid = -1 + end subroutine close_netcdf_file @@ -367,8 +381,8 @@ integer :: j, istatus - integer :: dimids(NF90_MAX_VAR_DIMS) + integer :: idimids(NF90_MAX_VAR_DIMS) istatus = nf90_inquire_variable(this%ncid, ivarid, & - & ndims=ndims, dimids=dimids) + & ndims=ndims, dimids=idimids) if (istatus /= NF90_NOERR) then write(nulerr,'(a,i0,a,a)') '*** Error inquiring about NetCDF variable with id ', & @@ -379,5 +393,5 @@ ndimlens(:) = 0 do j = 1,ndims - istatus = nf90_inquire_dimension(this%ncid, dimids(j), len=ndimlens(j)) + istatus = nf90_inquire_dimension(this%ncid, idimids(j), len=ndimlens(j)) if (istatus /= NF90_NOERR) then write(nulerr,'(a,i0,a,i0,a,a)') '*** Error reading length of dimension ', & @@ -420,4 +434,12 @@ !--------------------------------------------------------------------- + ! Return true if file is open, false otherwise + function is_open(this) + class(netcdf_file) :: this + logical :: is_open + is_open = (this%ncid >= 0) + end function is_open + + !--------------------------------------------------------------------- ! Return the number of dimensions of variable with name var_name, or ! -1 if the variable is not found @@ -619,7 +641,52 @@ !--------------------------------------------------------------------- + ! Read an integer scalar + subroutine get_int_scalar(this, var_name, scalar) + class(netcdf_file) :: this + character(len=*), intent(in) :: var_name + integer, intent(out):: scalar + + integer :: istatus + integer :: ivarid, ndims + integer :: ndimlens(NF90_MAX_VAR_DIMS) + integer :: j, ntotal + + ! Inquire the ID, shape & size of the variable + call this%get_variable_id(var_name, ivarid) + call this%get_array_dimensions(ivarid, ndims, ndimlens) + + ! Compute number of elements of the variable in the file + ntotal = 1 + do j = 1, ndims + ntotal = ntotal * ndimlens(j) + end do + + if (this%iverbose >= 3) then + write(nulout,'(a,a)',advance='no') ' Reading ', var_name + call this%print_variable_attributes(ivarid,nulout) + end if + + ! Abort if the number of elements is anything other than 1 + if (ntotal /= 1) then + write(nulerr,'(a,a,a,i0,a)') '*** Error reading NetCDF variable ', & + & var_name, ' with total length ', ntotal, ' as a scalar' + call my_abort('Error reading NetCDF file') + end if + + ! Read variable + istatus = nf90_get_var(this%ncid, ivarid, scalar) + if (istatus /= NF90_NOERR) then + write(nulerr,'(a,a,a,a)') '*** Error reading NetCDF variable ', & + & var_name, ' as a scalar: ', trim(nf90_strerror(istatus)) + call my_abort('Error reading NetCDF file') + end if + + end subroutine get_int_scalar + + + !--------------------------------------------------------------------- ! Read a scalar from a larger array, where "index" indexes the most ! slowly varying dimension - subroutine get_real_scalar_indexed(this, var_name, index, scalar) + subroutine get_real_scalar_indexed(this, var_name, scalar, index) class(netcdf_file) :: this character(len=*), intent(in) :: var_name @@ -676,6 +743,6 @@ !--------------------------------------------------------------------- - ! Read a 1D array into "vector", which must be allocatable and will - ! be reallocated if necessary + ! Read a 1D real array into "vector", which must be allocatable and + ! will be reallocated if necessary subroutine get_real_vector(this, var_name, vector) class(netcdf_file) :: this @@ -734,10 +801,10 @@ !--------------------------------------------------------------------- - ! Read a 1D integer array into "vector", which must be allocatable + ! Read a 1D character array into "vector", which must be allocatable ! and will be reallocated if necessary - subroutine get_integer_vector(this, var_name, vector) + subroutine get_char_vector(this, var_name, vector) class(netcdf_file) :: this character(len=*), intent(in) :: var_name - integer, allocatable, intent(out) :: vector(:) + character(len=1), allocatable, intent(out) :: vector(:) integer :: n ! Length of vector @@ -784,15 +851,73 @@ if (istatus /= NF90_NOERR) then write(nulerr,'(a,a,a,a)') '*** Error reading NetCDF variable ', & + & var_name, ' as a vector of chars: ', trim(nf90_strerror(istatus)) + call my_abort('Error reading NetCDF file') + end if + + end subroutine get_char_vector + + + !--------------------------------------------------------------------- + ! Read a 1D integer array into "vector", which must be allocatable + ! and will be reallocated if necessary + subroutine get_int_vector(this, var_name, vector) + + class(netcdf_file) :: this + character(len=*), intent(in) :: var_name + integer, allocatable, intent(out) :: vector(:) + + integer :: n ! Length of vector + integer :: istatus + integer :: ivarid, ndims + integer :: ndimlens(NF90_MAX_VAR_DIMS) + integer :: j + + call this%get_variable_id(var_name, ivarid) + call this%get_array_dimensions(ivarid, ndims, ndimlens) + + ! Ensure variable has only one dimension in the file + n = 1 + do j = 1, ndims + n = n * ndimlens(j) + if (j > 1 .and. ndimlens(j) > 1) then + write(nulerr,'(a,a,a)') '*** Error reading NetCDF variable ', & + & var_name, & + & ' as a vector: all dimensions above the first must be singletons' + call my_abort('Error reading NetCDF file') + end if + end do + + ! Reallocate if necessary + if (allocated(vector)) then + if (size(vector) /= n) then + if (this%iverbose >= 1) then + write(nulout,'(a,a)') ' Warning: resizing vector to read ', var_name + end if + deallocate(vector) + allocate(vector(n)) + end if + else + allocate(vector(n)) + end if + + if (this%iverbose >= 3) then + write(nulout,'(a,a,a,i0,a)',advance='no') ' Reading ', var_name, '(', n, ')' + call this%print_variable_attributes(ivarid,nulout) + end if + + ! Read variable + istatus = nf90_get_var(this%ncid, ivarid, vector) + if (istatus /= NF90_NOERR) then + write(nulerr,'(a,a,a,a)') '*** Error reading NetCDF variable ', & & var_name, ' as an integer vector: ', trim(nf90_strerror(istatus)) call my_abort('Error reading NetCDF file') end if - end subroutine get_integer_vector - + end subroutine get_int_vector !--------------------------------------------------------------------- ! Read a vector of data from a larger array; the vector must be ! allocatable and will be reallocated if necessary - subroutine get_real_vector_indexed(this, var_name, index, vector) + subroutine get_real_vector_indexed(this, var_name, vector, index) class(netcdf_file) :: this character(len=*), intent(in) :: var_name @@ -975,9 +1100,127 @@ !--------------------------------------------------------------------- + ! Read 2D array of characters into "matrix", which must be + ! allocatable and will be reallocated if necessary. Whether to + ! transpose is specifed by the final optional argument, but can also + ! be specified by the do_transpose_2d class data member. + subroutine get_char_matrix(this, var_name, matrix, do_transp) + class(netcdf_file) :: this + character(len=*), intent(in) :: var_name + character(len=1), allocatable, intent(inout) :: matrix(:,:) + logical, optional, intent(in):: do_transp ! Transpose data? + + character(len=1), allocatable:: tmp_matrix(:,:) + integer :: ndimlen1, ndimlen2 + integer :: istatus + integer :: ivarid, ndims + integer :: ndimlens(NF90_MAX_VAR_DIMS) + integer :: vstart(NF90_MAX_VAR_DIMS) + integer :: vcount(NF90_MAX_VAR_DIMS) + integer :: j, ntotal + logical :: do_transpose + + ! Decide whether to transpose the array + if (present(do_transp)) then + do_transpose = do_transp + else + do_transpose = this%do_transpose_2d + end if + + call this%get_variable_id(var_name, ivarid) + call this%get_array_dimensions(ivarid, ndims, ndimlens) + + ! Ensure the variable has no more than two non-singleton + ! dimensions + ntotal = 1 + do j = 1, ndims + ntotal = ntotal * ndimlens(j) + if (j > 2 .and. ndimlens(j) > 1) then + write(nulerr,'(a,a,a)') '*** Error reading NetCDF variable ', & + & var_name, & + & ' as a matrix: all dimensions above the second must be singletons' + call my_abort('Error reading NetCDF file') + end if + end do + + ! Work out dimension lengths + if (ndims >= 2) then + ndimlen1 = ndimlens(1) + ndimlen2 = ntotal/ndimlen1 + else + ndimlen1 = ntotal + ndimlen2 = 1 + end if + + if (do_transpose) then + ! Read and transpose + allocate(tmp_matrix(ndimlen1, ndimlen2)) + + ! Reallocate if necessary + if (allocated(matrix)) then + if (size(matrix,1) /= ndimlen2 .or. size(matrix,2) /= ndimlen1) then + if (this%iverbose >= 1) then + write(nulout,'(a,a)') ' Warning: resizing matrix to read ', var_name + end if + deallocate(matrix) + allocate(matrix(ndimlen2, ndimlen1)) + end if + else + allocate(matrix(ndimlen2, ndimlen1)) + end if + + if (this%iverbose >= 3) then + write(nulout,'(a,a,a,i0,a,i0,a)',advance='no') ' Reading ', var_name, '(', & + & ndimlen2, ',', ndimlen1, ')' + call this%print_variable_attributes(ivarid,nulout) + end if + + istatus = nf90_get_var(this%ncid, ivarid, tmp_matrix) + matrix = transpose(tmp_matrix) + deallocate(tmp_matrix) + else + ! Read data without transposition + + ! Reallocate if necessary + if (allocated(matrix)) then + if (size(matrix,1) /= ndimlen1 .or. size(matrix,2) /= ndimlen2) then + if (this%iverbose >= 1) then + write(nulout,'(a,a)') ' Warning: resizing matrix to read ', var_name + end if + allocate(matrix(ndimlen1, ndimlen2)) + end if + else + allocate(matrix(ndimlen1, ndimlen2)) + end if + + if (this%iverbose >= 3) then + write(nulout,'(a,a,a,i0,a,i0,a)',advance='no') ' Reading ', var_name, '(', & + & ndimlen1, ',', ndimlen2, ')' + call this%print_variable_attributes(ivarid,nulout) + end if + + vstart = 1 + vcount(1:2) = [ndimlen1,1] + + do j = 1,ndimlen2 + vstart(2) = j + istatus = nf90_get_var(this%ncid, ivarid, matrix(:,j), start=vstart, count=vcount) + end do + end if + + if (istatus /= NF90_NOERR) then + write(nulerr,'(a,a,a,a)') '*** Error reading NetCDF variable ', & + & var_name, ' as a matrix of characters: ', trim(nf90_strerror(istatus)) + call my_abort('Error reading NetCDF file') + end if + + end subroutine get_char_matrix + + + !--------------------------------------------------------------------- ! Read matrix of data from a larger array, which must be allocatable ! and will be reallocated if necessary. Whether to transpose is ! specifed by the final optional argument, but can also be specified ! by the do_transpose_2d class data member. - subroutine get_real_matrix_indexed(this, var_name, index, matrix, do_transp) + subroutine get_real_matrix_indexed(this, var_name, matrix, index, do_transp) class(netcdf_file) :: this character(len=*), intent(in) :: var_name @@ -1187,5 +1430,5 @@ if (this%iverbose >= 3) then write(nulout,'(a,a,a,i0,i0,i0,a)',advance='no') ' Reading ', var_name, & - & ' (permuted dimensions ', i_permute_3d, ')' + & ' (permuting dimensions ', i_permute_3d, ')' call this%print_variable_attributes(ivarid,nulout) end if @@ -1235,5 +1478,5 @@ ! be allocatable and will be reallocated if necessary. Whether to ! pemute is specifed by the final optional argument - subroutine get_real_array3_indexed(this, var_name, index, var, ipermute) + subroutine get_real_array3_indexed(this, var_name, var, index, ipermute) class(netcdf_file) :: this character(len=*), intent(in) :: var_name @@ -1331,5 +1574,5 @@ write(nulout,'(a,i0,a,a,a,i0,i0,i0,a)') ' Reading slice ', index, & & ' of ', var_name, & - & ' (permuted dimensions ', i_permute_3d, ')' + & ' (permuting dimensions ', i_permute_3d, ')' end if @@ -1471,5 +1714,5 @@ if (this%iverbose >= 3) then write(nulout,'(a,a,a,i0,i0,i0,a)',advance='no') ' Reading ', var_name, & - & ' (permuted dimensions ', i_permute_4d, ')' + & ' (permuting dimensions ', i_permute_4d, ')' call this%print_variable_attributes(ivarid,nulout) end if @@ -1549,5 +1792,5 @@ ! allocate(character(len=i_attr_len) :: attr_str) if (len(attr_str) < i_attr_len) then - write(nulerr,'(a,a)') '*** Error: not enough space to read attribute ', attr_name + write(nulerr,'(a,a)') '*** Not enough space to read attribute ', attr_name call my_abort('Error reading NetCDF file') end if @@ -1577,7 +1820,6 @@ real(jprb), intent(out) :: attr - integer :: i_attr_len, ivarid + integer :: ivarid integer :: istatus - integer :: j istatus = nf90_inq_varid(this%ncid, var_name, ivarid) @@ -1624,5 +1866,5 @@ ! allocate(character(len=i_attr_len) :: attr_str) if (len(attr_str) < i_attr_len) then - write(nulerr,'(a,a)') '*** Error: not enough space to read global attribute ', attr_name + write(nulerr,'(a,a)') '*** Not enough space to read global attribute ', attr_name call my_abort('Error reading NetCDF file') end if @@ -1652,13 +1894,10 @@ character(len=4000) :: attr_str - integer :: i_attr_len integer :: istatus - integer :: j if (this%iverbose >= 4) then istatus = nf90_get_att(this%ncid, ivarid, 'long_name', attr_str) if (istatus == NF90_NOERR) then - write(iunit, '(a)') ':' - write(iunit, '(a,a)', advance='no') ' ', trim(attr_str) + write(iunit, '(a,a,a)', advance='no') ': "', trim(attr_str), '"' istatus = nf90_get_att(this%ncid, ivarid, 'units', attr_str) if (istatus == NF90_NOERR) then @@ -1721,10 +1960,11 @@ ! names. subroutine define_variable(this, var_name, dim1_name, dim2_name, dim3_name, & - & long_name, units_str, comment_str, standard_name, is_double, & - & data_type_name, fill_value, deflate_level, shuffle, chunksizes) + & dim4_name, long_name, units_str, comment_str, & + & standard_name, is_double, data_type_name, fill_value, & + & deflate_level, shuffle, chunksizes, ndims) class(netcdf_file) :: this character(len=*), intent(in) :: var_name character(len=*), intent(in), optional :: long_name, units_str, comment_str, standard_name - character(len=*), intent(in), optional :: dim1_name, dim2_name, dim3_name + character(len=*), intent(in), optional :: dim1_name, dim2_name, dim3_name, dim4_name logical, intent(in), optional :: is_double character(len=*), intent(in), optional :: data_type_name @@ -1733,12 +1973,21 @@ logical, intent(in), optional :: shuffle ! Shuffle bytes before compression integer, dimension(:), intent(in), optional :: chunksizes - - integer :: istatus, ndims, ivarid + integer, intent(in), optional :: ndims + + integer :: istatus, ndims_local, ndims_input, ivarid integer, dimension(NF90_MAX_VAR_DIMS) :: idimids integer :: data_type - if (present(dim1_name)) then + ! Sometimes a program may not know at compile time the exact + ! dimensions of a variable - if ndims is present then only up to + ! that many dimensions will be defined + ndims_input = 4 + if (present(ndims)) then + ndims_input = ndims + end if + + if (present(dim1_name) .and. ndims_input >= 1) then ! Variable is at least one dimensional - ndims = 1 + ndims_local = 1 istatus = nf90_inq_dimid(this%ncid, dim1_name, idimids(1)) if (istatus /= NF90_NOERR) then @@ -1747,7 +1996,7 @@ call my_abort('Error writing NetCDF file') end if - if (present(dim2_name)) then + if (present(dim2_name) .and. ndims_input >= 2) then ! Variable is at least two dimensional - ndims = 2 + ndims_local = 2 istatus = nf90_inq_dimid(this%ncid, dim2_name, idimids(2)) if (istatus /= NF90_NOERR) then @@ -1756,7 +2005,7 @@ call my_abort('Error writing NetCDF file') end if - if (present(dim3_name)) then + if (present(dim3_name) .and. ndims_input >= 3) then ! Variable is at least three dimensional - ndims = 3 + ndims_local = 3 istatus = nf90_inq_dimid(this%ncid, dim3_name, idimids(3)) if (istatus /= NF90_NOERR) then @@ -1765,14 +2014,23 @@ call my_abort('Error writing NetCDF file') end if + if (present(dim4_name) .and. ndims_input >= 4) then + ! Variable is at least three dimensional + ndims_local = 4 + istatus = nf90_inq_dimid(this%ncid, dim4_name, idimids(4)) + if (istatus /= NF90_NOERR) then + write(nulerr,'(a,a,a,a)') '*** Error inquiring ID of dimension ', & + & dim4_name, ': ', trim(nf90_strerror(istatus)) + call my_abort('Error writing NetCDF file') + end if + end if end if end if else ! Variable is a scalar - ndims = 0 + ndims_local = 0 end if ! Read output precision from optional argument "is_double" if ! present, otherwise from default output precision for this file - data_type = NF90_FLOAT ! Default if (present(data_type_name)) then if (data_type_name == 'double') then @@ -1787,17 +2045,25 @@ data_type = NF90_FLOAT else - write(nulerr,'(a,a,a)') '*** Error: netCDF data type "', data_type_name, '" not supported' + write(nulerr,'(a,a,a)') '*** NetCDF data type "', data_type_name, '" not supported' call my_abort('Error writing NetCDF file') end if else if (present(is_double)) then + if (is_double) then + data_type = NF90_DOUBLE + else + data_type = NF90_FLOAT + end if + else if (this%is_double_precision) then data_type = NF90_DOUBLE + else + data_type = NF90_FLOAT end if ! Define variable #ifdef NC_NETCDF4 - istatus = nf90_def_var(this%ncid, var_name, data_type, idimids(1:ndims), & + istatus = nf90_def_var(this%ncid, var_name, data_type, idimids(1:ndims_local), & & ivarid, deflate_level=deflate_level, shuffle=shuffle, chunksizes=chunksizes) #else - istatus = nf90_def_var(this%ncid, var_name, data_type, idimids(1:ndims), ivarid) + istatus = nf90_def_var(this%ncid, var_name, data_type, idimids(1:ndims_local), ivarid) #endif if (istatus /= NF90_NOERR) then @@ -1811,14 +2077,28 @@ istatus = nf90_put_att(this%ncid, ivarid, "long_name", long_name) if (this%iverbose >= 4) then - write(nulout,'(a,a,a,a)') ' Defining ',trim(var_name),': ',long_name + write(nulout,'(a,a,a,a,a)', advance='no') ' Defining ',trim(var_name), & + & ': "', long_name, '"' end if else if (this%iverbose >= 4) then - write(nulout,'(a,a)') ' Defining ',trim(var_name) - end if - end if + write(nulout,'(a,a)', advance='no') ' Defining ',trim(var_name) + end if + end if + if (present(units_str)) then istatus = nf90_put_att(this%ncid, ivarid, "units", units_str) - end if + if (this%iverbose >= 4) then + if (trim(units_str) == '1') then + write(nulout, '(a)') ' (dimensionless)' + else + write(nulout, '(a,a,a)') ' (', trim(units_str), ')' + end if + end if + else + if (this%iverbose >= 4) then + write(nulout, '(1x)') + end if + end if + if (present(standard_name)) then istatus = nf90_put_att(this%ncid, ivarid, "standard_name", standard_name) @@ -1863,5 +2143,5 @@ subroutine put_global_attributes(this, title_str, inst_str, source_str, & & comment_str, references_str, creator_name, creator_email_str, & - & contributor_name, project_str, conventions_str) + & contributor_name, project_str, conventions_str, prior_history_str) class(netcdf_file) :: this @@ -1872,5 +2152,5 @@ character(len=*), intent(in), optional :: contributor_name, project_str character(len=*), intent(in), optional :: comment_str, conventions_str - character(len=*), intent(in), optional :: references_str + character(len=*), intent(in), optional :: references_str, prior_history_str character(len=32) :: date_time_str @@ -1887,5 +2167,10 @@ & time_vals(1), time_vals(2), time_vals(3), time_vals(5), time_vals(6), time_vals(7) - history_str = trim(date_time_str) // ': ' // trim(command_line_str) + if (present(prior_history_str)) then + history_str = trim(prior_history_str) // new_line('a') & + & // trim(date_time_str) // ': ' // trim(command_line_str) + else + history_str = trim(date_time_str) // ': ' // trim(command_line_str) + end if if (present(title_str)) i=nf90_put_att(this%ncid, NF90_GLOBAL, "title", title_str) @@ -2057,10 +2342,44 @@ !--------------------------------------------------------------------- + ! Save an integer vector with name var_name in the file + subroutine put_int_vector(this, var_name, var) + class(netcdf_file) :: this + character(len=*), intent(in) :: var_name + integer, intent(in) :: var(:) + + integer :: ivarid, ndims, istatus + integer(kind=jpib) :: ntotal + integer :: ndimlens(NF90_MAX_VAR_DIMS) + + call this%end_define_mode() + + ! Check the vector is of the right length + call this%get_variable_id(var_name, ivarid) + call this%get_array_dimensions(ivarid, ndims, ndimlens, ntotal) + if (ntotal /= size(var,kind=jpib)) then + write(nulerr,'(a,i0,a,a,a,i0)') '*** Error: attempt to write vector of length ', & + & size(var), ' to ', var_name, ' which has total length ', ntotal + call my_abort('Error writing NetCDF file') + end if + + ! Save the vector + istatus = nf90_put_var(this%ncid, ivarid, var) + if (istatus /= NF90_NOERR) then + write(nulerr,'(a,a,a,a)') '*** Error writing vector ', var_name, ': ', & + & trim(nf90_strerror(istatus)) + call my_abort('Error writing NetCDF file') + end if + + end subroutine put_int_vector + + + !--------------------------------------------------------------------- ! Save a vector slice with name var_name in the file - subroutine put_real_vector_indexed(this, var_name, index, var) + subroutine put_real_vector_indexed(this, var_name, var, index2, index3) class(netcdf_file) :: this character(len=*), intent(in) :: var_name real(jprb), intent(in) :: var(:) - integer, intent(in) :: index + integer, intent(in) :: index2 + integer, intent(in), optional :: index3 integer :: ivarid, ndims, istatus @@ -2070,4 +2389,7 @@ integer :: vcount(NF90_MAX_VAR_DIMS) + character(len=512) :: var_slice_name + integer :: index_last + call this%end_define_mode() @@ -2076,12 +2398,21 @@ call this%get_array_dimensions(ivarid, ndims, ndimlens, ntotal) ntotal = ntotal / ndimlens(ndims) + if (present(index3)) then + ntotal = ntotal / ndimlens(ndims-1) + index_last = index3 + write(var_slice_name,'(a,a,i0,a,i0,a)') var_name, '(:,', index2, ',', index3, ')' + else + index_last = index2 + write(var_slice_name,'(a,a,i0,a)') var_name, '(:,', index2, ')' + end if + if (ntotal /= size(var,kind=jpib)) then - write(nulerr,'(a,i0,a,a,a,i0)') '*** Error: attempt to write vector of length ', & - & size(var), ' to slice of ', var_name, ' which has length ', ntotal + write(nulerr,'(a,i0,a,a,i0)') '*** Error: attempt to write vector of length ', & + & size(var), ' to ', trim(var_slice_name), ' which has length ', ntotal call my_abort('Error writing NetCDF file') end if - if (index < 1 .or. index > ndimlens(ndims)) then - write(nulerr,'(a,i0,a,a,a,i0)') '*** Error: attempt to write vector to slice ', & - & index, ' of ', var_name, ' which has outer dimension ', ndimlens(ndims) + if (index_last < 1 .or. index_last > ndimlens(ndims)) then + write(nulerr,'(a,a,a,i0)') '*** Error: attempt to write vector to ', & + & trim(var_slice_name), ' which has outer dimension ', ndimlens(ndims) call my_abort('Error writing NetCDF file') end if @@ -2089,11 +2420,18 @@ ! Save the vector vstart(1:ndims-1) = 1 - vstart(ndims) = index vcount(1:ndims-1) = ndimlens(1:ndims-1) vcount(ndims) = 1 + if (present(index3)) then + vstart(ndims) = index3 + vstart(ndims-1) = index2 + vcount(ndims-1) = 1 + else + vstart(ndims) = index2 + end if + istatus = nf90_put_var(this%ncid, ivarid, var, start=vstart, count=vcount) if (istatus /= NF90_NOERR) then - write(nulerr,'(a,a,a,a)') '*** Error writing vector to ', var_name, ': ', & - & trim(nf90_strerror(istatus)) + write(nulerr,'(a,a,a,a)') '*** Error writing vector to ', trim(var_slice_name), & + & ': ', trim(nf90_strerror(istatus)) call my_abort('Error writing NetCDF file') end if @@ -2171,12 +2509,13 @@ ! dimensions if either optional argument transp is .true., or the ! transpose_matrices method has already been called. - subroutine put_real_matrix_indexed(this, var_name, index, var, do_transp) + subroutine put_real_matrix_indexed(this, var_name, var, index3, index4, do_transp) class(netcdf_file) :: this character(len=*), intent(in) :: var_name real(jprb), intent(in) :: var(:,:) - integer, intent(in) :: index + integer, intent(in) :: index3 + integer, intent(in), optional :: index4 real(jprb), allocatable :: var_transpose(:,:) - logical, optional, intent(in):: do_transp + logical, optional, intent(in) :: do_transp integer :: ivarid, ndims, nvarlen, istatus @@ -2186,4 +2525,6 @@ integer :: vcount(NF90_MAX_VAR_DIMS) + character(len=512) :: var_slice_name + logical :: do_transpose @@ -2204,19 +2545,31 @@ ! ntotal is zero then there must be an unlimited dimension) ntotal = ntotal / ndimlens(ndims) + if (present(index4)) then + ntotal = ntotal / ndimlens(ndims-1) + write(var_slice_name,'(a,a,i0,a,i0,a)') var_name, '(:,:,', index3, ',', index4, ')' + else + write(var_slice_name,'(a,a,i0,a)') var_name, '(:,:,', index3, ')' + end if if (ntotal /= size(var,kind=jpib) .and. ntotal /= 0) then write(nulerr,'(a,i0,a,a,a,i0)') '*** Error: attempt to write matrix of total size ', & - & nvarlen, ' to ', var_name, ' which has total size ', ntotal + & nvarlen, ' to ', trim(var_slice_name), ' which has total size ', ntotal call my_abort('Error writing NetCDF file') end if vstart(1:ndims-1) = 1 - vstart(ndims) = index vcount(1:ndims-1) = ndimlens(1:ndims-1) vcount(ndims) = 1 + if (present(index4)) then + vstart(ndims) = index4 + vstart(ndims-1) = index3 + vcount(ndims-1) = 1 + else + vstart(ndims) = index3 + end if if (do_transpose) then ! Save the matrix with transposition if (this%iverbose >= 3) then - write(nulout,'(a,i0,a,a,a)') ' Writing slice ', index, ' of ', var_name, & + write(nulout,'(a,a,a)') ' Writing ', trim(var_slice_name), & & ' (transposing dimensions)' end if @@ -2228,5 +2581,5 @@ ! Save the matrix without transposition if (this%iverbose >= 3) then - write(nulout,'(a,i0,a,a)') ' Writing slice ', index, ' of ', var_name + write(nulout,'(a,a)') ' Writing ', trim(var_slice_name) end if istatus = nf90_put_var(this%ncid, ivarid, var, start=vstart, count=vcount) @@ -2234,5 +2587,5 @@ if (istatus /= NF90_NOERR) then - write(nulerr,'(a,a,a,a)') '*** Error writing matrix ', var_name, & + write(nulerr,'(a,a,a)') '*** Error writing ', trim(var_slice_name), & & ': ', trim(nf90_strerror(istatus)) call my_abort('Error writing NetCDF file') @@ -2291,15 +2644,16 @@ if (this%iverbose >= 3) then write(nulout,'(a,a,a,i0,i0,i0,a)') ' Writing ', var_name, & - & ' (permuted dimensions: ', i_permute_3d, ')' + & ' (permuting dimensions: ', i_permute_3d, ')' end if n_dimlens_permuted = (/ size(var,i_permute_3d(1)), & & size(var,i_permute_3d(2)), & & size(var,i_permute_3d(3)) /) - if (this%iverbose >= 4) then - write(nulout,'(a,i0,a,i0,a,i0,a,i0,a,i0,a,i0,a)') ' (', & - & n_dimlens_permuted(1), ',', n_dimlens_permuted(2), & - & ',', n_dimlens_permuted(3), ') -> (', ndimlens(1), & - & ',', ndimlens(2), ',', ndimlens(3), ')' - end if + !! FIX: This makes it look like the dimensions have stayed the same + ! if (this%iverbose >= 4) then + ! write(nulout,'(a,i0,a,i0,a,i0,a,i0,a,i0,a,i0,a)') ' (', & + ! & n_dimlens_permuted(1), ',', n_dimlens_permuted(2), & + ! & ',', n_dimlens_permuted(3), ') -> (', ndimlens(1), & + ! & ',', ndimlens(2), ',', ndimlens(3), ')' + ! end if allocate(var_permute(n_dimlens_permuted(1), & & n_dimlens_permuted(2), n_dimlens_permuted(3))) @@ -2326,3 +2680,222 @@ end subroutine put_real_array3 + +#ifdef NC_NETCDF4 + !--------------------------------------------------------------------- + ! Copy dimensions from "infile" to "this" + subroutine copy_dimensions(this, infile) + class(netcdf_file) :: this + type(netcdf_file), intent(in) :: infile + + integer :: jdim + integer :: ndims + integer :: idimids(1024) + integer :: dimlen + character(len=512) :: dimname + integer :: istatus + integer :: include_parents + + include_parents = 0 + + istatus = nf90_inq_dimids(infile%ncid, ndims, idimids, include_parents) + if (istatus /= NF90_NOERR) then + write(nulerr,'(a,a)') '*** Error reading dimensions of NetCDF file: ', & + trim(nf90_strerror(istatus)) + call my_abort('Error reading NetCDF file') + end if + + do jdim = 1,ndims + istatus = nf90_inquire_dimension(infile%ncid, idimids(jdim), & + & name=dimname, len=dimlen) + if (istatus /= NF90_NOERR) then + write(nulerr,'(a,a)') '*** Error reading NetCDF dimension properties: ', & + trim(nf90_strerror(istatus)) + call my_abort('Error reading NetCDF file') + end if + call this%define_dimension(trim(dimname), dimlen) + end do + + end subroutine copy_dimensions +#endif + + !--------------------------------------------------------------------- + ! Copy variable definition and attributes from "infile" to "this" + subroutine copy_variable_definition(this, infile, var_name) + class(netcdf_file) :: this + type(netcdf_file), intent(in) :: infile + character(len=*), intent(in) :: var_name + +#ifdef NC_NETCDF4 + integer :: deflate_level ! Compression: 0 (none) to 9 (most) + logical :: shuffle ! Shuffle bytes before compression + integer :: chunksizes(NF90_MAX_VAR_DIMS) +#endif + integer :: data_type + integer :: ndims + integer :: idimids_in(NF90_MAX_VAR_DIMS) + integer :: idimids_out(NF90_MAX_VAR_DIMS) + integer :: nattr + character(len=512) :: attr_name + character(len=512) :: dim_name + + integer :: istatus + integer :: ivarid_in, ivarid_out + integer :: jattr, jdim + + if (this%iverbose >= 4) then + write(nulout,'(a,a)') ' Copying definition of ', trim(var_name) + end if + + ! Get variable ID from name + istatus = nf90_inq_varid(infile%ncid, var_name, ivarid_in) + if (istatus /= NF90_NOERR) then + write(nulerr,'(a,i0,a)') '*** Error inquiring about NetCDF variable "', & + & var_name, '": ', trim(nf90_strerror(istatus)) + call my_abort('Error reading NetCDF file') + end if + + ! Get variable properties +#ifdef NC_NETCDF4 + istatus = nf90_inquire_variable(infile%ncid, ivarid_in, xtype=data_type, ndims=ndims, & + & dimids=idimids_in, chunksizes=chunksizes, deflate_level=deflate_level, & + & shuffle=shuffle, natts=nattr) +#else + istatus = nf90_inquire_variable(infile%ncid, ivarid_in, xtype=data_type, ndims=ndims, & + & dimids=idimids_in, natts=nattr) +#endif + if (istatus /= NF90_NOERR) then + write(nulerr,'(a,a)') '*** Error reading NetCDF variable properties: ', & + trim(nf90_strerror(istatus)) + call my_abort('Error reading NetCDF file') + end if + + ! Map dimension IDs + do jdim = 1,ndims + istatus = nf90_inquire_dimension(infile%ncid, idimids_in(jdim), name=dim_name) + if (istatus /= NF90_NOERR) then + write(nulerr,'(a,a)') '*** Error reading NetCDF dimension name: ', & + trim(nf90_strerror(istatus)) + call my_abort('Error reading NetCDF file') + end if + + istatus = nf90_inq_dimid(this%ncid, trim(dim_name), idimids_out(jdim)) + if (istatus /= NF90_NOERR) then + write(nulerr,'(a,a)') '*** Error reading NetCDF dimension ID: ', & + trim(nf90_strerror(istatus)) + call my_abort('Error reading NetCDF file') + end if + end do + + ! Create variable +#ifdef NC_NETCDF4 + istatus = nf90_def_var(this%ncid, var_name, data_type, idimids_out(1:ndims), & + & ivarid_out, deflate_level=deflate_level, shuffle=shuffle, chunksizes=chunksizes(1:ndims)) +#else + istatus = nf90_def_var(this%ncid, var_name, data_type, idimids_out(1:ndims), ivarid_out) +#endif + if (istatus /= NF90_NOERR) then + write(nulerr,'(a,a,a,a)') '*** Error defining variable "', var_name, & + & '": ', trim(nf90_strerror(istatus)) + call my_abort('Error writing NetCDF file') + end if + + ! Copy attributes + do jattr = 1,nattr + istatus = nf90_inq_attname(infile%ncid, ivarid_in, jattr, attr_name) + if (istatus /= NF90_NOERR) then + write(nulerr,'(a,a)') '*** Error reading attribute: ', & + & trim(nf90_strerror(istatus)) + call my_abort('Error reading NetCDF file') + end if + istatus = nf90_copy_att(infile%ncid, ivarid_in, trim(attr_name), & + & this%ncid, ivarid_out) + + end do + + end subroutine copy_variable_definition + + + !--------------------------------------------------------------------- + ! Copy variable from "infile" to "this" + subroutine copy_variable(this, infile, var_name) + class(netcdf_file) :: this + class(netcdf_file), intent(in) :: infile + character(len=*), intent(in) :: var_name + + integer :: ivarid_in, ivarid_out + integer :: ndims + integer :: ndimlens(NF90_MAX_VAR_DIMS) + integer(kind=jpib) :: ntotal + integer :: data_type + integer :: istatus + + ! We use the Fortran-77 functions because they don't check that + ! the rank of the arguments is correct + integer, external :: nf_get_var_double, nf_put_var_double + integer, external :: nf_get_var_int, nf_put_var_int + + real(kind=jprd), allocatable :: data_real(:) + integer, allocatable :: data_int(:) + + ! If we are in define mode, exit define mode + call this%end_define_mode() + + if (this%iverbose >= 4) then + write(nulout,'(a,a)') ' Copying ', trim(var_name) + end if + + call infile%get_variable_id(var_name, ivarid_in) + call infile%get_array_dimensions(ivarid_in, ndims, ndimlens, ntotal) + istatus = nf90_inquire_variable(infile%ncid, ivarid_in, xtype=data_type) + if (istatus /= NF90_NOERR) then + write(nulerr,'(a,a,a,a)') '*** Error reading variable "', var_name, '": ', & + & trim(nf90_strerror(istatus)) + call my_abort('Error reading NetCDF file') + end if + + call infile%get_variable_id(var_name, ivarid_out) + if (data_type == NF90_DOUBLE .or. data_type == NF90_FLOAT) then + allocate(data_real(ntotal)) + !istatus = nf90_get_var(infile%ncid, ivarid_in, data_real(1)) + istatus = nf_get_var_double(infile%ncid, ivarid_in, data_real) + if (istatus /= NF90_NOERR) then + deallocate(data_real) + write(nulerr,'(a,a,a,a)') '*** Error reading variable "', var_name, '": ', & + & trim(nf90_strerror(istatus)) + call my_abort('Error reading NetCDF file') + end if + + !istatus = nf90_put_var(this%ncid, ivarid_out, data_real) + istatus = nf_put_var_double(this%ncid, ivarid_out, data_real) + deallocate(data_real) + if (istatus /= NF90_NOERR) then + write(nulerr,'(a,a,a,a)') '*** Error writing variable "', var_name, '": ', & + & trim(nf90_strerror(istatus)) + call my_abort('Error writing NetCDF file') + end if + + else + allocate(data_int(ntotal)) + !istatus = nf90_get_var(infile%ncid, ivarid_in, data_int) + istatus = nf_get_var_int(infile%ncid, ivarid_in, data_int) + if (istatus /= NF90_NOERR) then + deallocate(data_int) + + write(nulerr,'(a,a,a,a)') '*** Error reading variable "', var_name, '": ', & + & trim(nf90_strerror(istatus)) + call my_abort('Error reading NetCDF file') + end if + + !istatus = nf90_put_var(this%ncid, ivarid_out, data_int) + istatus = nf_put_var_int(this%ncid, ivarid_out, data_int) + deallocate(data_int) + if (istatus /= NF90_NOERR) then + write(nulerr,'(a,a,a,a)') '*** Error writing variable "', var_name, '": ', & + & trim(nf90_strerror(istatus)) + call my_abort('Error writing NetCDF file') + end if + end if + + end subroutine copy_variable + end module easy_netcdf Index: LMDZ6/trunk/libf/phylmd/ecrad/radiation_adding_ica_lw.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad/radiation_adding_ica_lw.F90 (revision 4487) +++ LMDZ6/trunk/libf/phylmd/ecrad/radiation_adding_ica_lw.F90 (revision 4489) @@ -296,5 +296,5 @@ ! Loop index for model level - integer :: jlev + integer :: jlev, jcol real(jprb) :: hook_handle @@ -307,6 +307,10 @@ ! Work down through the atmosphere computing the downward fluxes ! at each half-level +! Added for DWD (2020) +!NEC$ outerloop_unroll(8) do jlev = 1,nlev - flux_dn(:,jlev+1) = transmittance(:,jlev)*flux_dn(:,jlev) + source_dn(:,jlev) + do jcol = 1,ncol + flux_dn(jcol,jlev+1) = transmittance(jcol,jlev)*flux_dn(jcol,jlev) + source_dn(jcol,jlev) + end do end do @@ -316,6 +320,10 @@ ! Work back up through the atmosphere computing the upward fluxes ! at each half-level +! Added for DWD (2020) +!NEC$ outerloop_unroll(8) do jlev = nlev,1,-1 - flux_up(:,jlev) = transmittance(:,jlev)*flux_up(:,jlev+1) + source_up(:,jlev) + do jcol = 1,ncol + flux_up(jcol,jlev) = transmittance(jcol,jlev)*flux_up(jcol,jlev+1) + source_up(jcol,jlev) + end do end do Index: LMDZ6/trunk/libf/phylmd/ecrad/radiation_adding_ica_sw.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad/radiation_adding_ica_sw.F90 (revision 4487) +++ LMDZ6/trunk/libf/phylmd/ecrad/radiation_adding_ica_sw.F90 (revision 4489) @@ -98,4 +98,6 @@ ! also the "source", which is the upwelling flux due to direct ! radiation that is scattered below that level +! Added for DWD (2020) +!NEC$ outerloop_unroll(8) do jlev = nlev,1,-1 ! Next loop over columns. We could do this by indexing the @@ -128,4 +130,6 @@ ! Work back down through the atmosphere computing the fluxes at ! each half-level +! Added for DWD (2020) +!NEC$ outerloop_unroll(8) do jlev = 1,nlev do jcol = 1,ncol Index: LMDZ6/trunk/libf/phylmd/ecrad/radiation_aerosol.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad/radiation_aerosol.F90 (revision 4487) +++ LMDZ6/trunk/libf/phylmd/ecrad/radiation_aerosol.F90 (revision 4489) @@ -115,6 +115,6 @@ allocate(this%g_lw (config%n_bands_lw,istartlev:iendlev,ncol)) ! If longwave scattering by aerosol is not to be represented, - ! then the user may wish to just provide absorption optical deth - ! in od_lw, in which case we must set the following two + ! then the user may wish to just provide absorption optical + ! depth in od_lw, in which case we must set the following two ! variables to zero this%ssa_lw = 0.0_jprb @@ -128,5 +128,5 @@ !--------------------------------------------------------------------- - ! Deallocate array + ! Deallocate arrays subroutine deallocate_aerosol_arrays(this) @@ -158,5 +158,5 @@ use yomhook, only : lhook, dr_hook - use radiation_config, only : out_of_bounds_3d + use radiation_check, only : out_of_bounds_3d class(aerosol_type), intent(inout) :: this Index: LMDZ6/trunk/libf/phylmd/ecrad/radiation_aerosol_optics.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad/radiation_aerosol_optics.F90 (revision 4487) +++ LMDZ6/trunk/libf/phylmd/ecrad/radiation_aerosol_optics.F90 (revision 4489) @@ -14,5 +14,7 @@ ! ! Modifications -! 2018-04-15 R Hogan Add "direct" option +! 2018-04-15 R. Hogan Add "direct" option +! 2020-11-14 R. Hogan Add setup_general_aerosol_optics for ecCKD compatibility +! 2022-03-27 R. Hogan Add setup_general_aerosol_optics_legacy to use RRTM aerosol files with ecCKD module radiation_aerosol_optics @@ -36,4 +38,5 @@ use radiation_aerosol_optics_data, only : aerosol_optics_type use radiation_io, only : nulerr, radiation_abort + use setup_aerosol_optics_lmdz_m, only: setup_aerosol_optics_lmdz type(config_type), intent(inout) :: config @@ -46,10 +49,26 @@ ! Load data from file and prepare to map config%n_aerosol_types ! aerosol types - call config%aerosol_optics%setup(trim(config%aerosol_optics_file_name), & - & config%n_aerosol_types, iverbose=config%iverbosesetup) + if (config%use_general_aerosol_optics) then + ! Read file containing high spectral resolution optical + ! properties and average to the spectral intervals of the + ! current gas-optics scheme +! call setup_general_aerosol_optics(config) + call setup_general_aerosol_optics_lmdz(config,trim(config%aerosol_optics_file_name)) + else + ! Read file containing optical properties already in the bands + ! of the gas-optics scheme +! call config%aerosol_optics%setup(trim(config%aerosol_optics_file_name), & +! & iverbose=config%iverbosesetup) + call setup_aerosol_optics_lmdz(config%aerosol_optics, & + trim(config%aerosol_optics_file_name)) + end if + + call config%aerosol_optics%initialize_types(config%n_aerosol_types) ! Check agreement in number of bands if (config%n_bands_lw /= config%aerosol_optics%n_bands_lw) then - write(nulerr,'(a)') '*** Error: number of longwave bands does not match aerosol optics look-up table' + write(nulerr,'(a,i0,a,i0,a)') '*** Error: number of longwave bands (', & + & config%n_bands_lw, ') does not match aerosol optics look-up table (', & + & config%aerosol_optics%n_bands_lw, ')' call radiation_abort() end if @@ -63,9 +82,699 @@ end if - call config%aerosol_optics%print_description(config%i_aerosol_type_map(1:config%n_aerosol_types)) + if (config%iverbosesetup >= 1) then + call config%aerosol_optics%print_description(config%i_aerosol_type_map(1:config%n_aerosol_types)) + end if if (lhook) call dr_hook('radiation_aerosol_optics:setup_aerosol_optics',1,hook_handle) end subroutine setup_aerosol_optics + + + !--------------------------------------------------------------------- + ! Read file containing high spectral resolution optical properties + ! and average to the spectral intervals of the current gas-optics + ! scheme + subroutine setup_general_aerosol_optics(config) + + use parkind1, only : jprb + use yomhook, only : lhook, dr_hook + use easy_netcdf, only : netcdf_file + use radiation_config, only : config_type + use radiation_aerosol_optics_data, only : aerosol_optics_type + use radiation_spectral_definition, only : SolarReferenceTemperature, & + & TerrestrialReferenceTemperature + use radiation_io, only : nulout + + type(config_type), intent(inout), target :: config + + ! The NetCDF file containing the aerosol optics data + type(netcdf_file) :: file + + ! Wavenumber points in NetCDF file + real(jprb), allocatable :: wavenumber(:) ! cm-1 + + ! Hydrophilic aerosol properties + real(jprb), allocatable :: mass_ext_philic(:,:,:) ! Mass-ext coefficient (m2 kg-1) + real(jprb), allocatable :: ssa_philic(:,:,:) ! Single-scattering albedo + real(jprb), allocatable :: g_philic(:,:,:) ! Asymmetry factor + real(jprb), allocatable :: lidar_ratio_philic(:,:,:) ! Lidar ratio (sr) + + ! Hydrophobic aerosol properties + real(jprb), allocatable :: mass_ext_phobic(:,:) ! Mass-ext coefficient (m2 kg-1) + real(jprb), allocatable :: ssa_phobic(:,:) ! Single-scattering albedo + real(jprb), allocatable :: g_phobic(:,:) ! Asymmetry factor + real(jprb), allocatable :: lidar_ratio_phobic(:,:) ! Lidar ratio (sr) + + ! Mapping matrix between optical properties at the wavenumbers in + ! the file, and spectral intervals used by the gas-optics scheme + real(jprb), allocatable :: mapping(:,:) + + ! Pointer to the aerosol optics coefficients for brevity of access + type(aerosol_optics_type), pointer :: ao + + ! Target monochromatic wavenumber for interpolation (cm-1) + real(jprb) :: wavenumber_target + + ! Number of spectral points describing aerosol properties in the + ! shortwave and longwave + integer :: nspecsw, nspeclw + + ! Number of monochromatic wavelengths required + integer :: nmono + + integer :: n_type_philic, n_type_phobic, nrh, nwn + integer :: jtype, jwl, iwn + + ! Weight of first point in interpolation + real(jprb) :: weight1 + + real(jprb) :: hook_handle + + if (lhook) call dr_hook('radiation_aerosol_optics:setup_general_aerosol_optics',0,hook_handle) + + ao => config%aerosol_optics + + call file%open(trim(config%aerosol_optics_file_name), iverbose=config%iverbosesetup) + + if (.not. file%exists('wavenumber')) then + ! Assume we have an old-style aerosol optics file with optical + ! properties provided per pre-defined band + call file%close() + if (config%iverbosesetup >= 2) then + write(nulout,'(a)') 'Legacy aerosol optics file: mapping between bands' + end if + call setup_general_aerosol_optics_legacy(config, trim(config%aerosol_optics_file_name)) + return + end if + + if (file%exists('mass_ext_hydrophilic')) then + ao%use_hydrophilic = .true. + else + ao%use_hydrophilic = .false. + end if + + call file%get('wavenumber', wavenumber) + nwn = size(wavenumber) + + ! Read the raw scattering data + call file%get('mass_ext_hydrophobic', mass_ext_phobic) + call file%get('ssa_hydrophobic', ssa_phobic) + call file%get('asymmetry_hydrophobic', g_phobic) + call file%get('lidar_ratio_hydrophobic', lidar_ratio_phobic) + + call file%get_global_attribute('description_hydrophobic', & + & ao%description_phobic_str) + + if (ao%use_hydrophilic) then + call file%get('mass_ext_hydrophilic', mass_ext_philic) + call file%get('ssa_hydrophilic', ssa_philic) + call file%get('asymmetry_hydrophilic', g_philic) + call file%get('lidar_ratio_hydrophilic', lidar_ratio_philic) + + call file%get('relative_humidity1', ao%rh_lower) + + call file%get_global_attribute('description_hydrophilic', & + & ao%description_philic_str) + end if + + ! Close aerosol scattering file + call file%close() + + n_type_phobic = size(mass_ext_phobic, 2) + if (ao%use_hydrophilic) then + n_type_philic = size(mass_ext_philic, 3) + nrh = size(ao%rh_lower) + else + n_type_philic = 0 + nrh = 0 + end if + + if (config%do_cloud_aerosol_per_sw_g_point) then + nspecsw = config%gas_optics_sw%spectral_def%ng + else + nspecsw = config%gas_optics_sw%spectral_def%nband + end if + + if (config%do_cloud_aerosol_per_lw_g_point) then + nspeclw = config%gas_optics_lw%spectral_def%ng + else + nspeclw = config%gas_optics_lw%spectral_def%nband + end if + + if (allocated(ao%wavelength_mono)) then + ! Monochromatic wavelengths also required + nmono = size(ao%wavelength_mono) + else + nmono = 0 + end if + + call ao%allocate(n_type_phobic, n_type_philic, nrh, nspeclw, nspecsw, nmono) + + if (config%do_sw) then + call config%gas_optics_sw%spectral_def%calc_mapping(SolarReferenceTemperature, & + & wavenumber, mapping, use_bands=(.not. config%do_cloud_aerosol_per_sw_g_point)) + + ao%mass_ext_sw_phobic = matmul(mapping, mass_ext_phobic) + ao%ssa_sw_phobic = matmul(mapping, mass_ext_phobic*ssa_phobic) & + & / ao%mass_ext_sw_phobic + ao%g_sw_phobic = matmul(mapping, mass_ext_phobic*ssa_phobic*g_phobic) & + & / (ao%mass_ext_sw_phobic*ao%ssa_sw_phobic) + + if (ao%use_hydrophilic) then + do jtype = 1,n_type_philic + ao%mass_ext_sw_philic(:,:,jtype) = matmul(mapping, mass_ext_philic(:,:,jtype)) + ao%ssa_sw_philic(:,:,jtype) = matmul(mapping, mass_ext_philic(:,:,jtype) & + & *ssa_philic(:,:,jtype)) & + & / ao%mass_ext_sw_philic(:,:,jtype) + ao%g_sw_philic(:,:,jtype) = matmul(mapping, mass_ext_philic(:,:,jtype) & + & *ssa_philic(:,:,jtype)*g_philic(:,:,jtype)) & + & / (ao%mass_ext_sw_philic(:,:,jtype)*ao%ssa_sw_philic(:,:,jtype)) + end do + end if + end if + + if (config%do_lw) then + call config%gas_optics_lw%spectral_def%calc_mapping(TerrestrialReferenceTemperature, & + & wavenumber, mapping, use_bands=(.not. config%do_cloud_aerosol_per_lw_g_point)) + + ao%mass_ext_lw_phobic = matmul(mapping, mass_ext_phobic) + ao%ssa_lw_phobic = matmul(mapping, mass_ext_phobic*ssa_phobic) & + & / ao%mass_ext_lw_phobic + ao%g_lw_phobic = matmul(mapping, mass_ext_phobic*ssa_phobic*g_phobic) & + & / (ao%mass_ext_lw_phobic*ao%ssa_lw_phobic) + + if (ao%use_hydrophilic) then + do jtype = 1,n_type_philic + ao%mass_ext_lw_philic(:,:,jtype) = matmul(mapping, mass_ext_philic(:,:,jtype)) + ao%ssa_lw_philic(:,:,jtype) = matmul(mapping, mass_ext_philic(:,:,jtype) & + & *ssa_philic(:,:,jtype)) & + & / ao%mass_ext_lw_philic(:,:,jtype) + ao%g_lw_philic(:,:,jtype) = matmul(mapping, mass_ext_philic(:,:,jtype) & + & *ssa_philic(:,:,jtype)*g_philic(:,:,jtype)) & + & / (ao%mass_ext_lw_philic(:,:,jtype)*ao%ssa_lw_philic(:,:,jtype)) + end do + end if + end if + + if (allocated(ao%wavelength_mono)) then + ! Monochromatic wavelengths also required + do jwl = 1,nmono + ! Wavelength (m) to wavenumber (cm-1) + wavenumber_target = 0.01_jprb / ao%wavelength_mono(jwl) + ! Find index to first interpolation point, and its weight + if (wavenumber_target <= wavenumber(1)) then + weight1 = 1.0_jprb + iwn = 1 + else if (wavenumber_target >= wavenumber(nwn)) then + iwn = nwn-1 + weight1 = 0.0_jprb + else + iwn = 1 + do while (wavenumber(iwn+1) < wavenumber_target .and. iwn < nwn-1) + iwn = iwn + 1 + end do + weight1 = (wavenumber(iwn+1)-wavenumber_target) & + & / (wavenumber(iwn+1)-wavenumber(iwn)) + end if + ! Linear interpolation + ao%mass_ext_mono_phobic(jwl,:) = weight1 * mass_ext_phobic(iwn,:) & + & + (1.0_jprb - weight1)* mass_ext_phobic(iwn+1,:) + ao%ssa_mono_phobic(jwl,:) = weight1 * ssa_phobic(iwn,:) & + & + (1.0_jprb - weight1)* ssa_phobic(iwn+1,:) + ao%g_mono_phobic(jwl,:) = weight1 * g_phobic(iwn,:) & + & + (1.0_jprb - weight1)* g_phobic(iwn+1,:) + ao%lidar_ratio_mono_phobic(jwl,:) = weight1 * lidar_ratio_phobic(iwn,:) & + & + (1.0_jprb - weight1)* lidar_ratio_phobic(iwn+1,:) + if (ao%use_hydrophilic) then + ao%mass_ext_mono_philic(jwl,:,:) = weight1 * mass_ext_philic(iwn,:,:) & + & + (1.0_jprb - weight1)* mass_ext_philic(iwn+1,:,:) + ao%ssa_mono_philic(jwl,:,:) = weight1 * ssa_philic(iwn,:,:) & + & + (1.0_jprb - weight1)* ssa_philic(iwn+1,:,:) + ao%g_mono_philic(jwl,:,:) = weight1 * g_philic(iwn,:,:) & + & + (1.0_jprb - weight1)* g_philic(iwn+1,:,:) + ao%lidar_ratio_mono_philic(jwl,:,:) = weight1 * lidar_ratio_philic(iwn,:,:) & + & + (1.0_jprb - weight1)* lidar_ratio_philic(iwn+1,:,:) + end if + end do + end if + + ! Deallocate memory local to this routine + deallocate(mass_ext_phobic) + deallocate(ssa_phobic) + deallocate(g_phobic) + deallocate(lidar_ratio_phobic) + if (ao%use_hydrophilic) then + deallocate(mass_ext_philic) + deallocate(ssa_philic) + deallocate(g_philic) + deallocate(lidar_ratio_philic) + end if + + if (lhook) call dr_hook('radiation_aerosol_optics:setup_general_aerosol_optics',1,hook_handle) + + end subroutine setup_general_aerosol_optics + + !--------------------------------------------------------------------- + ! Read LMDZ file containing high spectral resolution optical properties + ! and average to the spectral intervals of the current gas-optics + ! scheme + subroutine setup_general_aerosol_optics_lmdz(config,file_name) + + use parkind1, only : jprb + use yomhook, only : lhook, dr_hook +! use easy_netcdf, only : netcdf_file + use radiation_config, only : config_type + use radiation_aerosol_optics_data, only : aerosol_optics_type + use radiation_spectral_definition, only : SolarReferenceTemperature, & + & TerrestrialReferenceTemperature + use radiation_io, only : nulout + use netcdf95, only: nf95_open, nf95_inq_grp_full_ncid, nf95_close, & + nf95_inq_dimid, nf95_inq_varid, nf95_inquire_dimension, & + nf95_get_var, nf95_gw_var + use netcdf, only: nf90_nowrite + + + type(config_type), intent(inout), target :: config + +! ! The NetCDF file containing the aerosol optics data +! type(netcdf_file) :: file + + character(len=*), intent(in):: file_name + ! NetCDF file containing the aerosol optics data + + ! Wavenumber points in NetCDF file + real(jprb), allocatable :: wavenumber(:) ! cm-1 + + ! Hydrophilic aerosol properties + real(jprb), allocatable :: mass_ext_philic(:,:,:) ! Mass-ext coefficient (m2 kg-1) + real(jprb), allocatable :: ssa_philic(:,:,:) ! Single-scattering albedo + real(jprb), allocatable :: g_philic(:,:,:) ! Asymmetry factor + real(jprb), allocatable :: lidar_ratio_philic(:,:,:) ! Lidar ratio (sr) + + ! Hydrophobic aerosol properties + real(jprb), allocatable :: mass_ext_phobic(:,:) ! Mass-ext coefficient (m2 kg-1) + real(jprb), allocatable :: ssa_phobic(:,:) ! Single-scattering albedo + real(jprb), allocatable :: g_phobic(:,:) ! Asymmetry factor + real(jprb), allocatable :: lidar_ratio_phobic(:,:) ! Lidar ratio (sr) + + ! Mapping matrix between optical properties at the wavenumbers in + ! the file, and spectral intervals used by the gas-optics scheme + real(jprb), allocatable :: mapping(:,:) + + ! Pointer to the aerosol optics coefficients for brevity of access + type(aerosol_optics_type), pointer :: ao + + ! Target monochromatic wavenumber for interpolation (cm-1) + real(jprb) :: wavenumber_target + + ! Number of spectral points describing aerosol properties in the + ! shortwave and longwave + integer :: nspecsw, nspeclw + + ! Number of monochromatic wavelengths required + integer :: nmono + + integer :: n_type_philic, n_type_phobic, nrh, nwn + integer :: jtype, jwl, iwn + + ! Weight of first point in interpolation + real(jprb) :: weight1 + + real(jprb) :: hook_handle + + ! Local: + integer ncid, grpid, dimid, varid + + if (lhook) call dr_hook('radiation_aerosol_optics:setup_general_aerosol_optics',0,hook_handle) + + ao => config%aerosol_optics + + ao%use_hydrophilic = .true. + ao%use_monochromatic = .true. + print*,'file_name= ',file_name + call nf95_open(file_name, nf90_nowrite, ncid) + call nf95_inq_grp_full_ncid(ncid, "Hydrophilic", grpid) + call nf95_inq_dimid(grpid, "hur", dimid) + call nf95_inquire_dimension(grpid, dimid, nclen = ao%nrh) +! allocate(ao%rh_lower(ao%nrh)) + call nf95_inq_varid(grpid, "hur_bounds", varid) + call nf95_get_var(grpid, varid, ao%rh_lower, count_nc = [1, ao%nrh]) + + ! Hydrophilic/LW_bands: + call nf95_inq_grp_full_ncid(ncid, "Hydrophilic/LW_bands", grpid) + call nf95_inq_varid(grpid, "asymmetry", varid) + call nf95_gw_var(grpid, varid, ao%g_lw_philic) + call nf95_inq_varid(grpid, "single_scat_alb", varid) + call nf95_gw_var(grpid, varid, ao%ssa_lw_philic) + call nf95_inq_varid(grpid, "mass_ext", varid) + call nf95_gw_var(grpid, varid, ao%mass_ext_lw_philic) + + ! Hydrophilic/SW_bands: + call nf95_inq_grp_full_ncid(ncid, "Hydrophilic/SW_bands", grpid) + call nf95_inq_varid(grpid, "asymmetry", varid) + call nf95_gw_var(grpid, varid, ao%g_sw_philic) + ao%g_sw_philic = cshift(ao%g_sw_philic, 1) + call nf95_inq_varid(grpid, "single_scat_alb", varid) + call nf95_gw_var(grpid, varid, ao%ssa_sw_philic) + ao%g_sw_philic = cshift(ao%ssa_sw_philic, 1) + call nf95_inq_varid(grpid, "mass_ext", varid) + call nf95_gw_var(grpid, varid, ao%mass_ext_sw_philic) + ao%g_sw_philic = cshift(ao%mass_ext_sw_philic, 1) + + ! Hydrophilic/Monochromatic: + call nf95_inq_grp_full_ncid(ncid, "Hydrophilic/Monochromatic", grpid) + call nf95_inq_varid(grpid, "mass_ext", varid) + call nf95_gw_var(grpid, varid, ao%mass_ext_mono_philic) + + ! Hydrophobic/LW_bands: + call nf95_inq_grp_full_ncid(ncid, "Hydrophobic/LW_bands", grpid) + call nf95_inq_varid(grpid, "asymmetry", varid) + call nf95_gw_var(grpid, varid, ao%g_lw_phobic) + call nf95_inq_varid(grpid, "single_scat_alb", varid) + call nf95_gw_var(grpid, varid, ao%ssa_lw_phobic) + call nf95_inq_varid(grpid, "mass_ext", varid) + call nf95_gw_var(grpid, varid, ao%mass_ext_lw_phobic) + + ! Hydrophobic/SW_bands: + call nf95_inq_grp_full_ncid(ncid, "Hydrophobic/SW_bands", grpid) + call nf95_inq_varid(grpid, "asymmetry", varid) + call nf95_gw_var(grpid, varid, ao%g_sw_phobic) + ao%g_sw_phobic = cshift(ao%g_sw_phobic, 1) + call nf95_inq_varid(grpid, "single_scat_alb", varid) + call nf95_gw_var(grpid, varid, ao%ssa_sw_phobic) + ao%g_sw_phobic = cshift(ao%ssa_sw_phobic, 1) + call nf95_inq_varid(grpid, "mass_ext", varid) + call nf95_gw_var(grpid, varid, ao%mass_ext_sw_phobic) + ao%g_sw_phobic = cshift(ao%mass_ext_sw_phobic, 1) +! AI ATTENTION + call nf95_inq_varid(grpid, "wavenumber", varid) + call nf95_gw_var(grpid, varid, wavenumber) + + ! Hydrophobic/Monochromatic: + call nf95_inq_grp_full_ncid(ncid, "Hydrophobic/Monochromatic", grpid) + call nf95_inq_varid(grpid, "mass_ext", varid) + call nf95_gw_var(grpid, varid, ao%mass_ext_mono_phobic) + +! call file%get('wavenumber', wavenumber) +! nwn = size(wavenumber) + +! call file%get_global_attribute('description_hydrophobic', & +! & ao%description_phobic_str) + + +! call file%get('relative_humidity1', ao%rh_lower) + +! call file%get_global_attribute('description_hydrophilic', & +! & ao%description_philic_str) + + ! Close aerosol scattering file +! call file%close() + + call nf95_close(ncid) + + ! Get array sizes +! ao%n_bands_lw = size(ao%mass_ext_lw_phobic, 1) +! ao%n_bands_sw = size(ao%mass_ext_sw_phobic, 1) +! ao%n_mono_wl = size(ao%mass_ext_mono_phobic, 1) +! ao%n_type_phobic = size(ao%mass_ext_lw_phobic, 2) +! ao%n_type_philic = size(ao%mass_ext_lw_philic, 3) + + ! Allocate memory for mapping arrays +! ao%ntype = ao%n_type_phobic + ao%n_type_philic +! allocate(ao%iclass(ao%ntype)) +! allocate(ao%itype(ao%ntype)) + +! ao%iclass = IAerosolClassUndefined +! ao%itype = 0 + + n_type_phobic = size(mass_ext_phobic, 2) + if (ao%use_hydrophilic) then + n_type_philic = size(mass_ext_philic, 3) + nrh = size(ao%rh_lower) + else + n_type_philic = 0 + nrh = 0 + end if + + if (config%do_cloud_aerosol_per_sw_g_point) then + nspecsw = config%gas_optics_sw%spectral_def%ng + else + nspecsw = config%gas_optics_sw%spectral_def%nband + end if + + if (config%do_cloud_aerosol_per_lw_g_point) then + nspeclw = config%gas_optics_lw%spectral_def%ng + else + nspeclw = config%gas_optics_lw%spectral_def%nband + end if + + if (allocated(ao%wavelength_mono)) then + ! Monochromatic wavelengths also required + nmono = size(ao%wavelength_mono) + else + nmono = 0 + end if + + call ao%allocate(n_type_phobic, n_type_philic, nrh, nspeclw, nspecsw, nmono) + + if (config%do_sw) then + call config%gas_optics_sw%spectral_def%calc_mapping(SolarReferenceTemperature, & + & wavenumber, mapping, use_bands=(.not. config%do_cloud_aerosol_per_sw_g_point)) + + ao%mass_ext_sw_phobic = matmul(mapping, mass_ext_phobic) + ao%ssa_sw_phobic = matmul(mapping, mass_ext_phobic*ssa_phobic) & + & / ao%mass_ext_sw_phobic + ao%g_sw_phobic = matmul(mapping, mass_ext_phobic*ssa_phobic*g_phobic) & + & / (ao%mass_ext_sw_phobic*ao%ssa_sw_phobic) + + if (ao%use_hydrophilic) then + do jtype = 1,n_type_philic + ao%mass_ext_sw_philic(:,:,jtype) = matmul(mapping, mass_ext_philic(:,:,jtype)) + ao%ssa_sw_philic(:,:,jtype) = matmul(mapping, mass_ext_philic(:,:,jtype) & + & *ssa_philic(:,:,jtype)) & + & / ao%mass_ext_sw_philic(:,:,jtype) + ao%g_sw_philic(:,:,jtype) = matmul(mapping, mass_ext_philic(:,:,jtype) & + & *ssa_philic(:,:,jtype)*g_philic(:,:,jtype)) & + & / (ao%mass_ext_sw_philic(:,:,jtype)*ao%ssa_sw_philic(:,:,jtype)) + end do + end if + end if + if (config%do_lw) then + call config%gas_optics_lw%spectral_def%calc_mapping(TerrestrialReferenceTemperature, & + & wavenumber, mapping, use_bands=(.not. config%do_cloud_aerosol_per_lw_g_point)) + + ao%mass_ext_lw_phobic = matmul(mapping, mass_ext_phobic) + ao%ssa_lw_phobic = matmul(mapping, mass_ext_phobic*ssa_phobic) & + & / ao%mass_ext_lw_phobic + ao%g_lw_phobic = matmul(mapping, mass_ext_phobic*ssa_phobic*g_phobic) & + & / (ao%mass_ext_lw_phobic*ao%ssa_lw_phobic) + + if (ao%use_hydrophilic) then + do jtype = 1,n_type_philic + ao%mass_ext_lw_philic(:,:,jtype) = matmul(mapping, mass_ext_philic(:,:,jtype)) + ao%ssa_lw_philic(:,:,jtype) = matmul(mapping, mass_ext_philic(:,:,jtype) & + & *ssa_philic(:,:,jtype)) & + & / ao%mass_ext_lw_philic(:,:,jtype) + ao%g_lw_philic(:,:,jtype) = matmul(mapping, mass_ext_philic(:,:,jtype) & + & *ssa_philic(:,:,jtype)*g_philic(:,:,jtype)) & + & / (ao%mass_ext_lw_philic(:,:,jtype)*ao%ssa_lw_philic(:,:,jtype)) + end do + end if + end if + + if (allocated(ao%wavelength_mono)) then + ! Monochromatic wavelengths also required + do jwl = 1,nmono + ! Wavelength (m) to wavenumber (cm-1) + wavenumber_target = 0.01_jprb / ao%wavelength_mono(jwl) + ! Find index to first interpolation point, and its weight + if (wavenumber_target <= wavenumber(1)) then + weight1 = 1.0_jprb + iwn = 1 + else if (wavenumber_target >= wavenumber(nwn)) then + iwn = nwn-1 + weight1 = 0.0_jprb + else + iwn = 1 + do while (wavenumber(iwn+1) < wavenumber_target .and. iwn < nwn-1) + iwn = iwn + 1 + end do + weight1 = (wavenumber(iwn+1)-wavenumber_target) & + & / (wavenumber(iwn+1)-wavenumber(iwn)) + end if + ! Linear interpolation + ao%mass_ext_mono_phobic(jwl,:) = weight1 * mass_ext_phobic(iwn,:) & + & + (1.0_jprb - weight1)* mass_ext_phobic(iwn+1,:) + ao%ssa_mono_phobic(jwl,:) = weight1 * ssa_phobic(iwn,:) & + & + (1.0_jprb - weight1)* ssa_phobic(iwn+1,:) + ao%g_mono_phobic(jwl,:) = weight1 * g_phobic(iwn,:) & + & + (1.0_jprb - weight1)* g_phobic(iwn+1,:) + ao%lidar_ratio_mono_phobic(jwl,:) = weight1 * lidar_ratio_phobic(iwn,:) & + & + (1.0_jprb - weight1)* lidar_ratio_phobic(iwn+1,:) + if (ao%use_hydrophilic) then + ao%mass_ext_mono_philic(jwl,:,:) = weight1 * mass_ext_philic(iwn,:,:) & + & + (1.0_jprb - weight1)* mass_ext_philic(iwn+1,:,:) + ao%ssa_mono_philic(jwl,:,:) = weight1 * ssa_philic(iwn,:,:) & + & + (1.0_jprb - weight1)* ssa_philic(iwn+1,:,:) + ao%g_mono_philic(jwl,:,:) = weight1 * g_philic(iwn,:,:) & + & + (1.0_jprb - weight1)* g_philic(iwn+1,:,:) + ao%lidar_ratio_mono_philic(jwl,:,:) = weight1 * lidar_ratio_philic(iwn,:,:) & + & + (1.0_jprb - weight1)* lidar_ratio_philic(iwn+1,:,:) + end if + end do + end if + + ! Deallocate memory local to this routine + deallocate(mass_ext_phobic) + deallocate(ssa_phobic) + deallocate(g_phobic) + deallocate(lidar_ratio_phobic) + if (ao%use_hydrophilic) then + deallocate(mass_ext_philic) + deallocate(ssa_philic) + deallocate(g_philic) + deallocate(lidar_ratio_philic) + end if + + if (lhook) call dr_hook('radiation_aerosol_optics:setup_general_aerosol_optics',1,hook_handle) + + end subroutine setup_general_aerosol_optics_lmdz + + + !--------------------------------------------------------------------- + ! Read file containing legacy-style band-wise aerosol optical + ! properties and average to the spectral intervals of the current + ! gas-optics scheme + subroutine setup_general_aerosol_optics_legacy(config, file_name) + + use parkind1, only : jprb + use yomhook, only : lhook, dr_hook + use easy_netcdf, only : netcdf_file + use radiation_config, only : config_type + use radiation_aerosol_optics_data, only : aerosol_optics_type + use radiation_spectral_definition, only : SolarReferenceTemperature, & + & TerrestrialReferenceTemperature + + type(config_type), intent(inout), target :: config + + ! The NetCDF file containing the aerosol optics data + character(len=*), intent(in) :: file_name + + ! Mapping matrix between optical properties at the wavenumbers in + ! the file, and spectral intervals used by the gas-optics scheme + real(jprb), allocatable :: mapping(:,:), mapping_transp(:,:) + + ! Pointer to the aerosol optics coefficients for brevity of access + type(aerosol_optics_type), pointer :: ao + + ! Local copy of aerosol optical properties in the spectral + ! intervals of the file, which is deallocated when it goes out of + ! scope + type(aerosol_optics_type) :: ao_legacy + + integer :: jtype + + real(jprb) :: hook_handle + + if (lhook) call dr_hook('radiation_aerosol_optics:setup_general_aerosol_optics_legacy',0,hook_handle) + ao => config%aerosol_optics + + ! Load file into a local structure + call ao_legacy%setup(file_name, iverbose=config%iverbosesetup) + + ! Copy over scalars and coordinate variables + call ao%allocate(ao_legacy%n_type_phobic, ao_legacy%n_type_philic, ao_legacy%nrh, & + & config%n_bands_lw, config%n_bands_sw, ao_legacy%n_mono_wl) + ao%description_phobic_str = ao_legacy%description_phobic_str + ao%description_philic_str = ao_legacy%description_philic_str + ao%rh_lower = ao_legacy%rh_lower + + ! use_hydrophilic = ao_legacy%use_hydrophilic + ! ao%iclass = ao_legacy%iclass + ! ao%itype = ao_legacy%itype + ! ao%ntype = ao_legacy%ntype + ! ao%n_type_phobic = ao_legacy%n_type_phobic + ! ao%n_type_philic = ao_legacy%n_type_philic + ! ao%n_mono_wl = ao_legacy%n_mono_wl + ! ao%use_monochromatic = ao_legacy%use_monochromatic + + if (config%do_sw) then + call config%gas_optics_sw%spectral_def%calc_mapping_from_wavenumber_bands(SolarReferenceTemperature, & + & ao_legacy%wavenumber1_sw, ao_legacy%wavenumber2_sw, mapping_transp, & + & use_bands=(.not. config%do_cloud_aerosol_per_sw_g_point)) + if (allocated(mapping)) then + deallocate(mapping) + end if + allocate(mapping(config%n_bands_sw,ao_legacy%n_bands_sw)) + mapping = transpose(mapping_transp) + ao%mass_ext_sw_phobic = matmul(mapping, ao_legacy%mass_ext_sw_phobic) + ao%ssa_sw_phobic = matmul(mapping, ao_legacy%mass_ext_sw_phobic*ao_legacy%ssa_sw_phobic) & + & / ao%mass_ext_sw_phobic + ao%g_sw_phobic = matmul(mapping, ao_legacy%mass_ext_sw_phobic*ao_legacy%ssa_sw_phobic & + & *ao_legacy%g_sw_phobic) & + & / (ao%mass_ext_sw_phobic*ao%ssa_sw_phobic) + + if (ao%use_hydrophilic) then + do jtype = 1,ao%n_type_philic + ao%mass_ext_sw_philic(:,:,jtype) = matmul(mapping, ao_legacy%mass_ext_sw_philic(:,:,jtype)) + ao%ssa_sw_philic(:,:,jtype) = matmul(mapping, ao_legacy%mass_ext_sw_philic(:,:,jtype) & + & *ao_legacy%ssa_sw_philic(:,:,jtype)) & + & / ao%mass_ext_sw_philic(:,:,jtype) + ao%g_sw_philic(:,:,jtype) = matmul(mapping, ao_legacy%mass_ext_sw_philic(:,:,jtype) & + & *ao_legacy%ssa_sw_philic(:,:,jtype)*ao_legacy%g_sw_philic(:,:,jtype)) & + & / (ao%mass_ext_sw_philic(:,:,jtype)*ao%ssa_sw_philic(:,:,jtype)) + end do + end if + end if + + if (config%do_lw) then + if (allocated(mapping_transp)) then + deallocate(mapping_transp) + end if + call config%gas_optics_lw%spectral_def%calc_mapping_from_wavenumber_bands(TerrestrialReferenceTemperature, & + & ao_legacy%wavenumber1_lw, ao_legacy%wavenumber2_lw, mapping_transp, & + & use_bands=(.not. config%do_cloud_aerosol_per_lw_g_point)) + if (allocated(mapping)) then + deallocate(mapping) + end if + allocate(mapping(config%n_bands_lw,ao_legacy%n_bands_lw)) + mapping = transpose(mapping_transp) + ao%mass_ext_lw_phobic = matmul(mapping, ao_legacy%mass_ext_lw_phobic) + ao%ssa_lw_phobic = matmul(mapping, ao_legacy%mass_ext_lw_phobic*ao_legacy%ssa_lw_phobic) & + & / ao%mass_ext_lw_phobic + ao%g_lw_phobic = matmul(mapping, ao_legacy%mass_ext_lw_phobic*ao_legacy%ssa_lw_phobic & + & *ao_legacy%g_lw_phobic) & + & / (ao%mass_ext_lw_phobic*ao%ssa_lw_phobic) + + if (ao%use_hydrophilic) then + do jtype = 1,ao%n_type_philic + ao%mass_ext_lw_philic(:,:,jtype) = matmul(mapping, ao_legacy%mass_ext_lw_philic(:,:,jtype)) + ao%ssa_lw_philic(:,:,jtype) = matmul(mapping, ao_legacy%mass_ext_lw_philic(:,:,jtype) & + & *ao_legacy%ssa_lw_philic(:,:,jtype)) & + & / ao%mass_ext_lw_philic(:,:,jtype) + ao%g_lw_philic(:,:,jtype) = matmul(mapping, ao_legacy%mass_ext_lw_philic(:,:,jtype) & + & *ao_legacy%ssa_lw_philic(:,:,jtype)*ao_legacy%g_lw_philic(:,:,jtype)) & + & / (ao%mass_ext_lw_philic(:,:,jtype)*ao%ssa_lw_philic(:,:,jtype)) + end do + end if + end if + + if (allocated(ao_legacy%wavelength_mono)) then + ao%wavelength_mono = ao_legacy%wavelength_mono + ao%mass_ext_mono_phobic = ao_legacy%mass_ext_mono_phobic + ao%ssa_mono_phobic = ao_legacy%ssa_mono_phobic + ao%g_mono_phobic = ao_legacy%g_mono_phobic + ao%lidar_ratio_mono_phobic = ao_legacy%lidar_ratio_mono_phobic + if (ao%use_hydrophilic) then + ao%mass_ext_mono_philic = ao_legacy%mass_ext_mono_philic + ao%ssa_mono_philic = ao_legacy%ssa_mono_philic + ao%g_mono_philic = ao_legacy%g_mono_philic + ao%lidar_ratio_mono_philic = ao_legacy%lidar_ratio_mono_philic + end if + end if + + if (lhook) call dr_hook('radiation_aerosol_optics:setup_general_aerosol_optics_legacy',1,hook_handle) + + end subroutine setup_general_aerosol_optics_legacy @@ -132,5 +841,5 @@ ! Loop indices for column, level, g point, band and aerosol type - integer :: jcol, jlev, jg, jtype + integer :: jcol, jlev, jg, jtype, jband ! Range of levels over which aerosols are present @@ -139,4 +848,7 @@ ! Indices to spectral band and relative humidity look-up table integer :: iband, irh + + ! Short cut for ao%itype(jtype) + integer :: itype ! Pointer to the aerosol optics coefficients for brevity of access @@ -180,8 +892,8 @@ ! Set variables to zero that may not have been previously - g_sw = 0.0_jprb + g_sw(:,:,istartcol:iendcol) = 0.0_jprb if (config%do_lw_aerosol_scattering) then - ssa_lw = 0.0_jprb - g_lw = 0.0_jprb + ssa_lw(:,:,istartcol:iendcol) = 0.0_jprb + g_lw(:,:,istartcol:iendcol) = 0.0_jprb end if @@ -210,4 +922,7 @@ do jtype = 1,config%n_aerosol_types + + itype = ao%itype(jtype) + ! Add the optical depth, scattering optical depth and ! scattering optical depth-weighted asymmetry factor for @@ -216,21 +931,23 @@ ! dimension being spectral band. if (ao%iclass(jtype) == IAerosolClassHydrophobic) then - local_od_sw = factor * aerosol%mixing_ratio(jcol,jlev,jtype) & - & * ao%mass_ext_sw_phobic(:,ao%itype(jtype)) - od_sw_aerosol = od_sw_aerosol + local_od_sw - scat_sw_aerosol = scat_sw_aerosol & - & + local_od_sw * ao%ssa_sw_phobic(:,ao%itype(jtype)) - scat_g_sw_aerosol = scat_g_sw_aerosol & - & + local_od_sw * ao%ssa_sw_phobic(:,ao%itype(jtype)) & - & * ao%g_sw_phobic(:,ao%itype(jtype)) + do jband = 1,config%n_bands_sw + local_od_sw(jband) = factor * aerosol%mixing_ratio(jcol,jlev,jtype) & + & * ao%mass_ext_sw_phobic(jband,itype) + od_sw_aerosol(jband) = od_sw_aerosol(jband) + local_od_sw(jband) + scat_sw_aerosol(jband) = scat_sw_aerosol(jband) & + & + local_od_sw(jband) * ao%ssa_sw_phobic(jband,itype) + scat_g_sw_aerosol(jband) = scat_g_sw_aerosol(jband) & + & + local_od_sw(jband) * ao%ssa_sw_phobic(jband,itype) & + & * ao%g_sw_phobic(jband,itype) + end do if (config%do_lw_aerosol_scattering) then local_od_lw = factor * aerosol%mixing_ratio(jcol,jlev,jtype) & - & * ao%mass_ext_lw_phobic(:,ao%itype(jtype)) + & * ao%mass_ext_lw_phobic(:,itype) od_lw_aerosol = od_lw_aerosol + local_od_lw scat_lw_aerosol = scat_lw_aerosol & - & + local_od_lw * ao%ssa_lw_phobic(:,ao%itype(jtype)) + & + local_od_lw * ao%ssa_lw_phobic(:,itype) scat_g_lw_aerosol = scat_g_lw_aerosol & - & + local_od_lw * ao%ssa_lw_phobic(:,ao%itype(jtype)) & - & * ao%g_lw_phobic(:,ao%itype(jtype)) + & + local_od_lw * ao%ssa_lw_phobic(:,itype) & + & * ao%g_lw_phobic(:,itype) else ! If aerosol longwave scattering is not included then we @@ -239,27 +956,29 @@ od_lw_aerosol = od_lw_aerosol & & + factor * aerosol%mixing_ratio(jcol,jlev,jtype) & - & * ao%mass_ext_lw_phobic(:,ao%itype(jtype)) & - & * (1.0_jprb - ao%ssa_lw_phobic(:,ao%itype(jtype))) + & * ao%mass_ext_lw_phobic(:,itype) & + & * (1.0_jprb - ao%ssa_lw_phobic(:,itype)) end if else if (ao%iclass(jtype) == IAerosolClassHydrophilic) then ! Hydrophilic aerosols require the look-up tables to ! be indexed with irh - local_od_sw = factor * aerosol%mixing_ratio(jcol,jlev,jtype) & - & * ao%mass_ext_sw_philic(:,irh,ao%itype(jtype)) - od_sw_aerosol = od_sw_aerosol + local_od_sw - scat_sw_aerosol = scat_sw_aerosol & - & + local_od_sw * ao%ssa_sw_philic(:,irh,ao%itype(jtype)) - scat_g_sw_aerosol = scat_g_sw_aerosol & - & + local_od_sw * ao%ssa_sw_philic(:,irh,ao%itype(jtype)) & - & * ao%g_sw_philic(:,irh,ao%itype(jtype)) + do jband = 1,config%n_bands_sw + local_od_sw(jband) = factor * aerosol%mixing_ratio(jcol,jlev,jtype) & + & * ao%mass_ext_sw_philic(jband,irh,itype) + od_sw_aerosol(jband) = od_sw_aerosol(jband) + local_od_sw(jband) + scat_sw_aerosol(jband) = scat_sw_aerosol(jband) & + & + local_od_sw(jband) * ao%ssa_sw_philic(jband,irh,itype) + scat_g_sw_aerosol(jband) = scat_g_sw_aerosol(jband) & + & + local_od_sw(jband) * ao%ssa_sw_philic(jband,irh,itype) & + & * ao%g_sw_philic(jband,irh,itype) + end do if (config%do_lw_aerosol_scattering) then local_od_lw = factor * aerosol%mixing_ratio(jcol,jlev,jtype) & - & * ao%mass_ext_lw_philic(:,irh,ao%itype(jtype)) + & * ao%mass_ext_lw_philic(:,irh,itype) od_lw_aerosol = od_lw_aerosol + local_od_lw scat_lw_aerosol = scat_lw_aerosol & - & + local_od_lw * ao%ssa_lw_philic(:,irh,ao%itype(jtype)) + & + local_od_lw * ao%ssa_lw_philic(:,irh,itype) scat_g_lw_aerosol = scat_g_lw_aerosol & - & + local_od_lw * ao%ssa_lw_philic(:,irh,ao%itype(jtype)) & - & * ao%g_lw_philic(:,irh,ao%itype(jtype)) + & + local_od_lw * ao%ssa_lw_philic(:,irh,itype) & + & * ao%g_lw_philic(:,irh,itype) else ! If aerosol longwave scattering is not included then we @@ -268,6 +987,6 @@ od_lw_aerosol = od_lw_aerosol & & + factor * aerosol%mixing_ratio(jcol,jlev,jtype) & - & * ao%mass_ext_lw_philic(:,irh,ao%itype(jtype)) & - & * (1.0_jprb - ao%ssa_lw_philic(:,irh,ao%itype(jtype))) + & * ao%mass_ext_lw_philic(:,irh,itype) & + & * (1.0_jprb - ao%ssa_lw_philic(:,irh,itype)) end if end if @@ -289,8 +1008,8 @@ ! properties (noting that any gas scattering will have an ! asymmetry factor of zero) - if (od_sw_aerosol(1) > 0.0_jprb) then - do jg = 1,config%n_g_sw - iband = config%i_band_from_reordered_g_sw(jg) - local_od = od_sw(jg,jlev,jcol) + od_sw_aerosol(iband) + do jg = 1,config%n_g_sw + iband = config%i_band_from_reordered_g_sw(jg) + local_od = od_sw(jg,jlev,jcol) + od_sw_aerosol(iband) + if (local_od > 0.0_jprb .and. od_sw_aerosol(iband) > 0.0_jprb) then local_scat = ssa_sw(jg,jlev,jcol) * od_sw(jg,jlev,jcol) & & + scat_sw_aerosol(iband) @@ -298,9 +1017,11 @@ ! simply weights the aerosol asymmetry by the scattering ! optical depth - g_sw(jg,jlev,jcol) = scat_g_sw_aerosol(iband) / local_scat + if (local_scat > 0.0_jprb) then + g_sw(jg,jlev,jcol) = scat_g_sw_aerosol(iband) / local_scat + end if ssa_sw(jg,jlev,jcol) = local_scat / local_od od_sw (jg,jlev,jcol) = local_od - end do - end if + end if + end do ! Combine aerosol longwave scattering properties with gas @@ -314,5 +1035,6 @@ do jg = 1,config%n_g_lw iband = config%i_band_from_reordered_g_lw(jg) - if (od_lw_aerosol(iband) > 0.0_jprb) then + local_od = od_lw(jg,jlev,jcol) + od_lw_aerosol(iband) + if (local_od > 0.0_jprb .and. od_lw_aerosol(iband) > 0.0_jprb) then ! All scattering is due to aerosols, therefore the ! asymmetry factor is equal to the value for aerosols @@ -320,8 +1042,5 @@ g_lw(jg,jlev,jcol) = scat_g_lw_aerosol(iband) & & / scat_lw_aerosol(iband) - else - g_lw(jg,jlev,jcol) = 0.0_jprb end if - local_od = od_lw(jg,jlev,jcol) + od_lw_aerosol(iband) ssa_lw(jg,jlev,jcol) = scat_lw_aerosol(iband) / local_od od_lw (jg,jlev,jcol) = local_od @@ -384,12 +1103,12 @@ ! a point in space for each spectral band of the shortwave and ! longwave spectrum - real(jprb), dimension(config%n_bands_sw) & + real(jprb), dimension(config%n_bands_sw,nlev) & & :: od_sw_aerosol, scat_sw_aerosol, scat_g_sw_aerosol - real(jprb), dimension(config%n_bands_lw) :: od_lw_aerosol - real(jprb), dimension(config%n_bands_lw_if_scattering) & + real(jprb), dimension(config%n_bands_lw,nlev) :: od_lw_aerosol + real(jprb), dimension(config%n_bands_lw_if_scattering,nlev) & & :: scat_lw_aerosol, scat_g_lw_aerosol ! Loop indices for column, level, g point and band - integer :: jcol, jlev, jg + integer :: jcol, jlev, jg, jb ! Range of levels over which aerosols are present @@ -416,35 +1135,41 @@ ! Set variables to zero that may not have been previously - g_sw = 0.0_jprb + g_sw(:,:,istartcol:iendcol) = 0.0_jprb ! Loop over position do jcol = istartcol,iendcol +! Added for DWD (2020) +!NEC$ forced_collapse do jlev = istartlev,iendlev - od_sw_aerosol = aerosol%od_sw(:,jlev,jcol) - scat_sw_aerosol = aerosol%ssa_sw(:,jlev,jcol) * od_sw_aerosol - scat_g_sw_aerosol = aerosol%g_sw(:,jlev,jcol) * scat_sw_aerosol - - if (.not. config%do_sw_delta_scaling_with_gases) then - ! Delta-Eddington scaling on aerosol only. Note that if - ! do_sw_delta_scaling_with_gases==.true. then the delta - ! scaling is done to the cloud-aerosol-gas mixture inside - ! the solver - call delta_eddington_extensive(od_sw_aerosol, scat_sw_aerosol, & - & scat_g_sw_aerosol) - end if - - ! Combine aerosol shortwave scattering properties with gas - ! properties (noting that any gas scattering will have an - ! asymmetry factor of zero) - if (od_sw_aerosol(1) > 0.0_jprb) then + do jb = 1,config%n_bands_sw + od_sw_aerosol(jb,jlev) = aerosol%od_sw(jb,jlev,jcol) + scat_sw_aerosol(jb,jlev) = aerosol%ssa_sw(jb,jlev,jcol) * od_sw_aerosol(jb,jlev) + scat_g_sw_aerosol(jb,jlev) = aerosol%g_sw(jb,jlev,jcol) * scat_sw_aerosol(jb,jlev) + + if (.not. config%do_sw_delta_scaling_with_gases) then + ! Delta-Eddington scaling on aerosol only. Note that if + ! do_sw_delta_scaling_with_gases==.true. then the delta + ! scaling is done to the cloud-aerosol-gas mixture + ! inside the solver + call delta_eddington_extensive(od_sw_aerosol(jb,jlev), scat_sw_aerosol(jb,jlev), & + & scat_g_sw_aerosol(jb,jlev)) + end if + end do + end do + ! Combine aerosol shortwave scattering properties with gas + ! properties (noting that any gas scattering will have an + ! asymmetry factor of zero) + do jlev = istartlev,iendlev + if (od_sw_aerosol(1,jlev) > 0.0_jprb) then do jg = 1,config%n_g_sw iband = config%i_band_from_reordered_g_sw(jg) - local_od = od_sw(jg,jlev,jcol) + od_sw_aerosol(iband) + local_od = od_sw(jg,jlev,jcol) + od_sw_aerosol(iband,jlev) local_scat = ssa_sw(jg,jlev,jcol) * od_sw(jg,jlev,jcol) & - & + scat_sw_aerosol(iband) + & + scat_sw_aerosol(iband,jlev) ! Note that asymmetry_sw of gases is zero so the following ! simply weights the aerosol asymmetry by the scattering ! optical depth - g_sw(jg,jlev,jcol) = scat_g_sw_aerosol(iband) / local_scat + g_sw(jg,jlev,jcol) = scat_g_sw_aerosol(iband,jlev) / local_scat + local_od = od_sw(jg,jlev,jcol) + od_sw_aerosol(iband,jlev) ssa_sw(jg,jlev,jcol) = local_scat / local_od od_sw (jg,jlev,jcol) = local_od @@ -469,30 +1194,33 @@ if (config%do_lw_aerosol_scattering) then - ssa_lw = 0.0_jprb - g_lw = 0.0_jprb + ssa_lw(:,:,istartcol:iendcol) = 0.0_jprb + g_lw(:,:,istartcol:iendcol) = 0.0_jprb ! Loop over position do jcol = istartcol,iendcol +! Added for DWD (2020) +!NEC$ forced_collapse do jlev = istartlev,iendlev - od_lw_aerosol = aerosol%od_lw(:,jlev,jcol) - scat_lw_aerosol = aerosol%ssa_lw(:,jlev,jcol) * od_lw_aerosol - scat_g_lw_aerosol = aerosol%g_lw(:,jlev,jcol) * scat_lw_aerosol + do jb = 1,config%n_bands_lw + od_lw_aerosol(jb,jlev) = aerosol%od_lw(jb,jlev,jcol) + scat_lw_aerosol(jb,jlev) = aerosol%ssa_lw(jb,jlev,jcol) * od_lw_aerosol(jb,jlev) + scat_g_lw_aerosol(jb,jlev) = aerosol%g_lw(jb,jlev,jcol) * scat_lw_aerosol(jb,jlev) - call delta_eddington_extensive(od_lw_aerosol, scat_lw_aerosol, & - & scat_g_lw_aerosol) - + call delta_eddington_extensive(od_lw_aerosol(jb,jlev), scat_lw_aerosol(jb,jlev), & + & scat_g_lw_aerosol(jb,jlev)) + end do + end do + do jlev = istartlev,iendlev do jg = 1,config%n_g_lw iband = config%i_band_from_reordered_g_lw(jg) - if (od_lw_aerosol(iband) > 0.0_jprb) then + if (od_lw_aerosol(iband,jlev) > 0.0_jprb) then ! All scattering is due to aerosols, therefore the ! asymmetry factor is equal to the value for aerosols - if (scat_lw_aerosol(iband) > 0.0_jprb) then - g_lw(jg,jlev,jcol) = scat_g_lw_aerosol(iband) & - & / scat_lw_aerosol(iband) - else - g_lw(jg,jlev,jcol) = 0.0_jprb + if (scat_lw_aerosol(iband,jlev) > 0.0_jprb) then + g_lw(jg,jlev,jcol) = scat_g_lw_aerosol(iband,jlev) & + & / scat_lw_aerosol(iband,jlev) end if - local_od = od_lw(jg,jlev,jcol) + od_lw_aerosol(iband) - ssa_lw(jg,jlev,jcol) = scat_lw_aerosol(iband) / local_od + local_od = od_lw(jg,jlev,jcol) + od_lw_aerosol(iband,jlev) + ssa_lw(jg,jlev,jcol) = scat_lw_aerosol(iband,jlev) / local_od od_lw (jg,jlev,jcol) = local_od end if @@ -505,13 +1233,19 @@ ! Loop over position do jcol = istartcol,iendcol +! Added for DWD (2020) +!NEC$ forced_collapse do jlev = istartlev,iendlev ! If aerosol longwave scattering is not included then we ! weight the optical depth by the single scattering ! co-albedo - od_lw_aerosol = aerosol%od_lw(:,jlev,jcol) & - & * (1.0_jprb - aerosol%ssa_lw(:,jlev,jcol)) + do jb = 1, config%n_bands_lw + od_lw_aerosol(jb,jlev) = aerosol%od_lw(jb,jlev,jcol) & + & * (1.0_jprb - aerosol%ssa_lw(jb,jlev,jcol)) + end do + end do + do jlev = istartlev,iendlev do jg = 1,config%n_g_lw od_lw(jg,jlev,jcol) = od_lw(jg,jlev,jcol) & - & + od_lw_aerosol(config%i_band_from_reordered_g_lw(jg)) + & + od_lw_aerosol(config%i_band_from_reordered_g_lw(jg),jlev) end do end do @@ -530,11 +1264,12 @@ ! Sometimes it is useful to specify aerosol in terms of its optical ! depth at a particular wavelength. This function returns the dry - ! shortwave mass-extinction coefficient, i.e. the extinction cross - ! section per unit mass, for aerosol of type "itype" at shortwave - ! band "iband". For hydrophilic types, the value at the first - ! relative humidity bin is taken. - function dry_aerosol_sw_mass_extinction(config, itype, iband) + ! mass-extinction coefficient, i.e. the extinction cross section per + ! unit mass, for aerosol of type "itype" at the specified wavelength + ! (m). For hydrophilic types, the value at the first relative + ! humidity bin is taken. + function dry_aerosol_mass_extinction(config, itype, wavelength) use parkind1, only : jprb + use radiation_io, only : nulerr, radiation_abort use radiation_config, only : config_type use radiation_aerosol_optics_data, only : aerosol_optics_type, & @@ -544,8 +1279,14 @@ type(config_type), intent(in), target :: config - ! Aerosol type and shortwave band as indices to the array - integer, intent(in) :: itype, iband + ! Aerosol type + integer, intent(in) :: itype + + ! Wavelength (m) + real(jprb), intent(in) :: wavelength - real(jprb) dry_aerosol_sw_mass_extinction + real(jprb) :: dry_aerosol_mass_extinction + + ! Index to the monochromatic wavelength requested + integer :: imono ! Pointer to the aerosol optics coefficients for brevity of access @@ -554,23 +1295,30 @@ ao => config%aerosol_optics + imono = minloc(abs(wavelength - ao%wavelength_mono), 1) + + if (abs(wavelength - ao%wavelength_mono(imono))/wavelength > 0.01_jprb) then + write(nulerr,'(a,e8.4,a)') '*** Error: requested wavelength ', & + & wavelength, ' not within 1% of stored wavelengths' + call radiation_abort() + end if + if (ao%iclass(itype) == IAerosolClassHydrophobic) then - dry_aerosol_sw_mass_extinction = ao%mass_ext_sw_phobic(iband,ao%itype(itype)) + dry_aerosol_mass_extinction = ao%mass_ext_mono_phobic(imono,ao%itype(itype)) else if (ao%iclass(itype) == IAerosolClassHydrophilic) then ! Take the value at the first relative-humidity bin for the ! "dry" aerosol value - dry_aerosol_sw_mass_extinction = ao%mass_ext_sw_philic(iband,1,ao%itype(itype)) + dry_aerosol_mass_extinction = ao%mass_ext_mono_philic(imono,1,ao%itype(itype)) else - dry_aerosol_sw_mass_extinction = 0.0_jprb - end if - - end function dry_aerosol_sw_mass_extinction + dry_aerosol_mass_extinction = 0.0_jprb + end if + + end function dry_aerosol_mass_extinction !--------------------------------------------------------------------- - ! Compute aerosol extinction coefficient at a particular shortwave - ! band and a single height - this is useful for visibility - ! diagnostics - subroutine aerosol_sw_extinction(ncol,istartcol,iendcol, & - & config, iband, mixing_ratio, relative_humidity, extinction) + ! Compute aerosol extinction coefficient at a particular wavelength + ! and a single height - this is useful for visibility diagnostics + subroutine aerosol_extinction(ncol,istartcol,iendcol, & + & config, wavelength, mixing_ratio, relative_humidity, extinction) use parkind1, only : jprb @@ -585,5 +1333,5 @@ integer, intent(in) :: istartcol, iendcol ! range of columns to process type(config_type), intent(in), target :: config - integer, intent(in) :: iband ! Index of required spectral band + real(jprb), intent(in) :: wavelength ! Requested wavelength (m) real(jprb), intent(in) :: mixing_ratio(ncol,config%n_aerosol_types) real(jprb), intent(in) :: relative_humidity(ncol) @@ -592,4 +1340,7 @@ ! Local aerosol extinction real(jprb) :: ext + + ! Index to the monochromatic wavelength requested + integer :: imono ! Pointer to the aerosol optics coefficients for brevity of access @@ -604,5 +1355,5 @@ real(jprb) :: hook_handle - if (lhook) call dr_hook('radiation_aerosol_optics:aerosol_sw_extinction',0,hook_handle) + if (lhook) call dr_hook('radiation_aerosol_optics:aerosol_extinction',0,hook_handle) do jtype = 1,config%n_aerosol_types @@ -614,4 +1365,12 @@ ao => config%aerosol_optics + + imono = minloc(abs(wavelength - ao%wavelength_mono), 1) + + if (abs(wavelength - ao%wavelength_mono(imono))/wavelength > 0.01_jprb) then + write(nulerr,'(a,e8.4,a)') '*** Error: requested wavelength ', & + & wavelength, ' not within 1% of stored wavelengths' + call radiation_abort() + end if ! Loop over position @@ -624,8 +1383,8 @@ if (ao%iclass(jtype) == IAerosolClassHydrophobic) then ext = ext + mixing_ratio(jcol,jtype) & - & * ao%mass_ext_sw_phobic(iband,ao%itype(jtype)) + & * ao%mass_ext_mono_phobic(imono,ao%itype(jtype)) else if (ao%iclass(jtype) == IAerosolClassHydrophilic) then ext = ext + mixing_ratio(jcol,jtype) & - & * ao%mass_ext_sw_philic(iband,irh,ao%itype(jtype)) + & * ao%mass_ext_mono_philic(imono,irh,ao%itype(jtype)) end if end do @@ -634,7 +1393,7 @@ end do - if (lhook) call dr_hook('radiation_aerosol_optics:aerosol_sw_extinction',1,hook_handle) - - end subroutine aerosol_sw_extinction + if (lhook) call dr_hook('radiation_aerosol_optics:aerosol_extinction',1,hook_handle) + + end subroutine aerosol_extinction end module radiation_aerosol_optics Index: LMDZ6/trunk/libf/phylmd/ecrad/radiation_aerosol_optics_data.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad/radiation_aerosol_optics_data.F90 (revision 4487) +++ LMDZ6/trunk/libf/phylmd/ecrad/radiation_aerosol_optics_data.F90 (revision 4489) @@ -57,4 +57,10 @@ integer, allocatable, dimension(:) :: itype + ! Wavenumber (cm-1) upper and lower bounds of each spectral + ! interval, which if used in the RRTMG gas optics scheme should + ! match its band bounds + real(jprb), allocatable, dimension(:) :: wavenumber1_sw, wavenumber2_sw + real(jprb), allocatable, dimension(:) :: wavenumber1_lw, wavenumber2_lw + ! Scattering properties are provided separately in the shortwave ! and longwave for hydrophobic and hydrophilic aerosols. @@ -64,19 +70,27 @@ & ssa_sw_phobic, & ! Single scattering albedo & g_sw_phobic, & ! Asymmetry factor +! & ssa_g_sw_phobic, & ! ssa*g & mass_ext_lw_phobic, & ! Mass-extinction coefficient (m2 kg-1) +! & mass_abs_lw_phobic, & ! Mass-absorption coefficient (m2 kg-1) & ssa_lw_phobic, & ! Single scattering albedo & g_lw_phobic ! Asymmetry factor - ! Hydrophilic aerosols are dimensioned (nband, nrh, n_type_philic): + ! Hydrophilic aerosols are dimensioned (nband,nrh,n_type_philic): real(jprb), allocatable, dimension(:,:,:) :: & & mass_ext_sw_philic, & ! Mass-extinction coefficient (m2 kg-1) & ssa_sw_philic, & ! Single scattering albedo & g_sw_philic, & ! Asymmetry factor + ! & ssa_g_sw_philic, & ! ssa*g & mass_ext_lw_philic, & ! Mass-extinction coefficient (m2 kg-1) + ! & mass_abs_lw_philic, & ! Mass-absorption coefficient (m2 kg-1) & ssa_lw_philic, & ! Single scattering albedo & g_lw_philic ! Asymmetry factor - ! Scattering properties at selected wavelengths - ! (n_mono_wl,n_type_phobic/philic) + ! Wavelengths at which monochromatic properties are stored, + ! dimensioned (n_mono_wl), units metres + real(jprb), allocatable :: wavelength_mono(:) + + ! Scattering properties at selected monochromatic wavelengths + ! (n_mono_wl,n_type_phobic) real(jprb), allocatable, dimension(:,:) :: & & mass_ext_mono_phobic, & ! Mass-extinction coefficient (m2 kg-1) @@ -84,4 +98,5 @@ & g_mono_phobic, & ! Asymmetry factor & lidar_ratio_mono_phobic ! Lidar Ratio + ! ...hydrophilic aerosols dimensioned (n_mono_wl,nrh,n_type_philic): real(jprb), allocatable, dimension(:,:,:) :: & & mass_ext_mono_philic, & ! Mass-extinction coefficient (m2 kg-1) @@ -104,8 +119,9 @@ ! The number of hydrophobic and hydrophilic types read from the ! aerosol optics file - integer :: n_type_phobic, n_type_philic + integer :: n_type_phobic = 0 + integer :: n_type_philic = 0 ! Number of relative humidity bins - integer :: nrh + integer :: nrh = 0 ! Number of longwave and shortwave bands of the data in the file, @@ -121,4 +137,7 @@ contains procedure :: setup => setup_aerosol_optics + procedure :: save => save_aerosol_optics + procedure :: allocate + procedure :: initialize_types procedure :: set_hydrophobic_type procedure :: set_hydrophilic_type @@ -135,5 +154,5 @@ !--------------------------------------------------------------------- ! Setup aerosol optics coefficients by reading them from a file - subroutine setup_aerosol_optics(this, file_name, ntype, iverbose) + subroutine setup_aerosol_optics(this, file_name, iverbose) use yomhook, only : lhook, dr_hook @@ -143,10 +162,12 @@ class(aerosol_optics_type), intent(inout) :: this character(len=*), intent(in) :: file_name - integer, intent(in) :: ntype integer, intent(in), optional :: iverbose ! The NetCDF file containing the aerosol optics data type(netcdf_file) :: file + + real(jprb), allocatable :: wavelength_tmp(:) integer :: iverb + real(jprb) :: hook_handle @@ -168,4 +189,10 @@ this%use_hydrophilic = .false. end if + + ! Read the wavenumber bounds + call file%get('wavenumber1_sw', this%wavenumber1_sw) + call file%get('wavenumber2_sw', this%wavenumber2_sw) + call file%get('wavenumber1_lw', this%wavenumber1_lw) + call file%get('wavenumber2_lw', this%wavenumber2_lw) ! Read the raw scattering data @@ -180,4 +207,8 @@ & this%description_phobic_str) + ! Precompute ssa*g for the shortwave and mass-absorption for the + ! longwave - TBD FIX + !allocate(this%ssa_g_sw_phobic(... + if (this%use_hydrophilic) then call file%get('mass_ext_sw_hydrophilic', this%mass_ext_sw_philic) @@ -194,8 +225,33 @@ end if - ! Read the raw scattering data at selected wavelengths if - ! available in the input file + ! Read the monochromatic scattering data at selected wavelengths + ! if available in the input file if (file%exists('mass_ext_mono_hydrophobic')) then this%use_monochromatic = .true. + + if (allocated(this%wavelength_mono)) then + ! User has provided required monochromatic wavelengths, which + ! must match those in the file (in the more recent "general" + ! aerosol optics, interpolation provides optical properties at + ! the requested wavelengths) + call file%get('wavelength_mono', wavelength_tmp) + if (size(wavelength_tmp) /= size(this%wavelength_mono)) then + write(nulerr,'(a,i0,a,i0,a)') '*** Error: ', size(this%wavelength_mono), & + & ' monochromatic wavelengths requested but ', & + & size(wavelength_tmp), ' in file' + call radiation_abort('Radiation configuration error') + end if + if (any(abs(this%wavelength_mono-wavelength_tmp) & + & / this%wavelength_mono > 0.01_jprb)) then + write(nulerr,'(a,a)') '*** Error: requested monochromatic wavelengths', & + & 'must all be within 1% of values in file' + call radiation_abort('Radiation configuration error') + end if + else + ! User has not provided required wavelengths, so we save the + ! monochromatic wavelengths in the file + call file%get('wavelength_mono', this%wavelength_mono) + end if + call file%get('mass_ext_mono_hydrophobic', this%mass_ext_mono_phobic) call file%get('ssa_mono_hydrophobic', this%ssa_mono_phobic) @@ -233,14 +289,14 @@ write(nulerr,'(a,a)') '*** Error: mass extinction for hydrophilic and hydrophobic ', & & 'aerosol have different numbers of longwave bands' - call radiation_abort() + call radiation_abort('Radiation configuration error') end if if (size(this%mass_ext_sw_philic,1) /= this%n_bands_sw) then write(nulerr,'(a,a)') '*** Error: mass extinction for hydrophilic and hydrophobic ', & & 'aerosol have different numbers of shortwave bands' - call radiation_abort() + call radiation_abort('Radiation configuration error') end if if (size(this%rh_lower) /= this%nrh) then write(nulerr,'(a)') '*** Error: size(relative_humidity1) /= size(mass_ext_sw_hydrophilic,2)' - call radiation_abort() + call radiation_abort('Radiation configuration error') end if @@ -250,4 +306,16 @@ end if + if (lhook) call dr_hook('radiation_aerosol_optics_data:setup',1,hook_handle) + + end subroutine setup_aerosol_optics + + + !--------------------------------------------------------------------- + ! Initialize the arrays describing the user's aerosol types + subroutine initialize_types(this, ntype) + + class(aerosol_optics_type), intent(inout) :: this + integer, intent(in) :: ntype + ! Allocate memory for mapping arrays this%ntype = ntype @@ -258,7 +326,174 @@ this%itype = 0 - if (lhook) call dr_hook('radiation_aerosol_optics_data:setup',1,hook_handle) - - end subroutine setup_aerosol_optics + end subroutine initialize_types + + !--------------------------------------------------------------------- + ! Allocate arrays for aerosol optics data type + subroutine allocate(this, n_type_phobic, n_type_philic, nrh, & + & n_bands_lw, n_bands_sw, n_mono_wl) + + use yomhook, only : lhook, dr_hook + + class(aerosol_optics_type), intent(inout) :: this + integer, intent(in) :: n_type_phobic, n_type_philic, nrh + integer, intent(in) :: n_bands_lw, n_bands_sw, n_mono_wl + + real(jprb) :: hook_handle + + if (lhook) call dr_hook('radiation_aerosol_optics_data:allocate',0,hook_handle) + + this%n_type_phobic = n_type_phobic + this%n_type_philic = n_type_philic + this%nrh = nrh + this%n_bands_lw = n_bands_lw + this%n_bands_sw = n_bands_sw + this%n_mono_wl = n_mono_wl + + if (n_type_philic > 0) then + this%use_hydrophilic = .true. + else + this%use_hydrophilic = .false. + end if + + if (n_bands_sw > 0) then + allocate(this%mass_ext_sw_phobic(n_bands_sw, n_type_phobic)) + allocate(this%ssa_sw_phobic(n_bands_sw, n_type_phobic)) + allocate(this%g_sw_phobic(n_bands_sw, n_type_phobic)) + end if + if (n_bands_lw > 0) then + allocate(this%mass_ext_lw_phobic(n_bands_lw, n_type_phobic)) + allocate(this%ssa_lw_phobic(n_bands_lw, n_type_phobic)) + allocate(this%g_lw_phobic(n_bands_lw, n_type_phobic)) + end if + if (n_mono_wl > 0) then + allocate(this%mass_ext_mono_phobic(n_mono_wl, n_type_phobic)) + allocate(this%ssa_mono_phobic(n_mono_wl, n_type_phobic)) + allocate(this%g_mono_phobic(n_mono_wl, n_type_phobic)) + allocate(this%lidar_ratio_mono_phobic(n_mono_wl, n_type_phobic)) + end if + + if (n_type_philic > 0 .and. nrh > 0) then + if (n_bands_sw > 0) then + allocate(this%mass_ext_sw_philic(n_bands_sw, nrh, n_type_philic)) + allocate(this%ssa_sw_philic(n_bands_sw, nrh, n_type_philic)) + allocate(this%g_sw_philic(n_bands_sw, nrh, n_type_philic)) + end if + if (n_bands_lw > 0) then + allocate(this%mass_ext_lw_philic(n_bands_lw, nrh, n_type_philic)) + allocate(this%ssa_lw_philic(n_bands_lw, nrh, n_type_philic)) + allocate(this%g_lw_philic(n_bands_lw, nrh, n_type_philic)) + end if + if (n_mono_wl > 0) then + allocate(this%mass_ext_mono_philic(n_mono_wl, nrh, n_type_philic)) + allocate(this%ssa_mono_philic(n_mono_wl, nrh, n_type_philic)) + allocate(this%g_mono_philic(n_mono_wl, nrh, n_type_philic)) + allocate(this%lidar_ratio_mono_philic(n_mono_wl, nrh, n_type_philic)) + end if + end if + + if (lhook) call dr_hook('radiation_aerosol_optics_data:allocate',1,hook_handle) + + end subroutine allocate + + + !--------------------------------------------------------------------- + subroutine save_aerosol_optics(this, file_name, iverbose) + + use yomhook, only : lhook, dr_hook + use easy_netcdf, only : netcdf_file + + class(aerosol_optics_type), intent(inout) :: this + character(len=*), intent(in) :: file_name + integer, optional, intent(in) :: iverbose + + ! Object for output NetCDF file + type(netcdf_file) :: out_file + + real(jprb) :: hook_handle + + if (lhook) call dr_hook('radiation_aerosol_optics_data:save',0,hook_handle) + + ! Create the file + call out_file%create(trim(file_name), iverbose=iverbose) + + ! Define dimensions + call out_file%define_dimension("band_lw", this%n_bands_lw) + call out_file%define_dimension("band_sw", this%n_bands_sw) + call out_file%define_dimension("hydrophilic", this%n_type_philic) + call out_file%define_dimension("hydrophobic", this%n_type_phobic) + call out_file%define_dimension("relative_humidity", this%nrh) + !if (this%use_monochromatic) then + ! call out_file%define_dimension("wavelength_mono", this%n_mono_wl) + !end if + + ! Put global attributes + call out_file%put_global_attributes( & + & title_str="Aerosol optical properties in the spectral intervals of the gas-optics scheme for ecRad", & + & source_str="ecRad offline radiation model") + call out_file%put_global_attribute( & + & "description_hydrophobic", this%description_phobic_str) + call out_file%put_global_attribute( & + & "description_hydrophilic", this%description_philic_str) + + ! Define variables + call out_file%define_variable("mass_ext_sw_hydrophobic", units_str="m2 kg-1", & + & long_name="Shortwave mass-extinction coefficient of hydrophobic aerosols", & + & dim2_name="hydrophobic", dim1_name="band_sw") + call out_file%define_variable("ssa_sw_hydrophobic", units_str="1", & + & long_name="Shortwave single scattering albedo of hydrophobic aerosols", & + & dim2_name="hydrophobic", dim1_name="band_sw") + call out_file%define_variable("asymmetry_sw_hydrophobic", units_str="1", & + & long_name="Shortwave asymmetry factor of hydrophobic aerosols", & + & dim2_name="hydrophobic", dim1_name="band_sw") + + call out_file%define_variable("mass_ext_lw_hydrophobic", units_str="m2 kg-1", & + & long_name="Longwave mass-extinction coefficient of hydrophobic aerosols", & + & dim2_name="hydrophobic", dim1_name="band_lw") + call out_file%define_variable("ssa_lw_hydrophobic", units_str="1", & + & long_name="Longwave single scattering albedo of hydrophobic aerosols", & + & dim2_name="hydrophobic", dim1_name="band_lw") + call out_file%define_variable("asymmetry_lw_hydrophobic", units_str="1", & + & long_name="Longwave asymmetry factor of hydrophobic aerosols", & + & dim2_name="hydrophobic", dim1_name="band_lw") + + call out_file%define_variable("mass_ext_sw_hydrophilic", units_str="m2 kg-1", & + & long_name="Shortwave mass-extinction coefficient of hydrophilic aerosols", & + & dim3_name="hydrophilic", dim2_name="relative_humidity", dim1_name="band_sw") + call out_file%define_variable("ssa_sw_hydrophilic", units_str="1", & + & long_name="Shortwave single scattering albedo of hydrophilic aerosols", & + & dim3_name="hydrophilic", dim2_name="relative_humidity", dim1_name="band_sw") + call out_file%define_variable("asymmetry_sw_hydrophilic", units_str="1", & + & long_name="Shortwave asymmetry factor of hydrophilic aerosols", & + & dim3_name="hydrophilic", dim2_name="relative_humidity", dim1_name="band_sw") + + call out_file%define_variable("mass_ext_lw_hydrophilic", units_str="m2 kg-1", & + & long_name="Longwave mass-extinction coefficient of hydrophilic aerosols", & + & dim3_name="hydrophilic", dim2_name="relative_humidity", dim1_name="band_lw") + call out_file%define_variable("ssa_lw_hydrophilic", units_str="1", & + & long_name="Longwave single scattering albedo of hydrophilic aerosols", & + & dim3_name="hydrophilic", dim2_name="relative_humidity", dim1_name="band_lw") + call out_file%define_variable("asymmetry_lw_hydrophilic", units_str="1", & + & long_name="Longwave asymmetry factor of hydrophilic aerosols", & + & dim3_name="hydrophilic", dim2_name="relative_humidity", dim1_name="band_lw") + + ! Write variables + call out_file%put("mass_ext_sw_hydrophobic", this%mass_ext_sw_phobic) + call out_file%put("ssa_sw_hydrophobic", this%ssa_sw_phobic) + call out_file%put("asymmetry_sw_hydrophobic", this%g_sw_phobic) + call out_file%put("mass_ext_lw_hydrophobic", this%mass_ext_lw_phobic) + call out_file%put("ssa_lw_hydrophobic", this%ssa_lw_phobic) + call out_file%put("asymmetry_lw_hydrophobic", this%g_lw_phobic) + call out_file%put("mass_ext_sw_hydrophilic", this%mass_ext_sw_philic) + call out_file%put("ssa_sw_hydrophilic", this%ssa_sw_philic) + call out_file%put("asymmetry_sw_hydrophilic", this%g_sw_philic) + call out_file%put("mass_ext_lw_hydrophilic", this%mass_ext_lw_philic) + call out_file%put("ssa_lw_hydrophilic", this%ssa_lw_philic) + call out_file%put("asymmetry_lw_hydrophilic", this%g_lw_philic) + + call out_file%close() + + if (lhook) call dr_hook('radiation_aerosol_optics_data:save',1,hook_handle) + + end subroutine save_aerosol_optics Index: LMDZ6/trunk/libf/phylmd/ecrad/radiation_aerosol_optics_description.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad/radiation_aerosol_optics_description.F90 (revision 4489) +++ LMDZ6/trunk/libf/phylmd/ecrad/radiation_aerosol_optics_description.F90 (revision 4489) @@ -0,0 +1,332 @@ +! radiation_aerosol_optics_description.F90 - Type to store aerosol optics metadata +! +! (C) Copyright 2022- 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. +! +! Author: Robin Hogan +! Email: r.j.hogan@ecmwf.int +! + +module radiation_aerosol_optics_description + + use parkind1, only : jprb + + implicit none + public + + !--------------------------------------------------------------------- + ! This type holds the metadata from an aerosol optical property + ! file, enabling the user to request the index to the aerosol type + ! with particular properties. Note that string information is held + ! in the form of 2D arrays of single characters, so comparison to + ! character strings requires the to_string helper function at the + ! end of this file. + type aerosol_optics_description_type + + ! Two-character code describing the aerosol family, dimensioned + ! (2,naer), e.g. + ! SS: Sea salt + ! OM: Organic matter + ! SU: Sulfate + ! OB: Secondary organic biogenic + ! OA: Secondary organic anthropogenic + ! AM: Fine-mode ammonium sulfate + ! NI: Nitrate + ! DD: Desert dust + ! BC: Black carbon + character(len=1), allocatable :: code_phobic(:,:) + character(len=1), allocatable :: code_philic(:,:) + + ! Size bin, typically 1-2 or 1-3 in order fine to coarse, or zero + ! if no division by size is used, dimensioned (naer) + integer, allocatable :: bin_phobic(:) + integer, allocatable :: bin_philic(:) + + ! Character string characterizing the optical model, e.g. OPAC, + ! GACP, GLOMAP, Dubovik2002 etc. + character(len=1), allocatable :: optical_model_phobic(:,:) + character(len=1), allocatable :: optical_model_philic(:,:) + + ! The user can call preferred_optical_model to specify that a + ! certain optical model for a certain aerosol family is to be + ! preferred when get_index is called + logical, allocatable :: is_preferred_phobic(:) + logical, allocatable :: is_preferred_philic(:) + + contains + procedure :: read + procedure :: preferred_optical_model + procedure :: get_index + + end type aerosol_optics_description_type + +contains + + !--------------------------------------------------------------------- + ! Read optical property file file_name into an + ! aerosol_optics_description_type object + subroutine read(this, file_name, iverbose) + + use yomhook, only : lhook, dr_hook + use easy_netcdf, only : netcdf_file + + class(aerosol_optics_description_type), intent(inout) :: this + character(len=*), intent(in) :: file_name + integer, intent(in), optional :: iverbose + + ! The NetCDF file containing the aerosol optics data + type(netcdf_file) :: file + + real(jprb) :: hook_handle + + if (lhook) call dr_hook('radiation_aerosol_optics_description:load',0,hook_handle) + + ! Open the aerosol scattering file and configure the way it is + ! read + call file%open(trim(file_name), iverbose=iverbose) + + ! Read metadata variables + call file%get('code_hydrophilic', this%code_philic) + call file%get('code_hydrophobic', this%code_phobic) + call file%get('bin_hydrophilic', this%bin_philic) + call file%get('bin_hydrophobic', this%bin_phobic) + call file%get('optical_model_hydrophilic', this%optical_model_philic) + call file%get('optical_model_hydrophobic', this%optical_model_phobic) + + ! Allocate logical arrays of the appropriate size and set to FALSE + allocate(this%is_preferred_philic(size(this%bin_philic))) + allocate(this%is_preferred_phobic(size(this%bin_phobic))) + this%is_preferred_philic = .false. + this%is_preferred_phobic = .false. + + call file%close() + + if (lhook) call dr_hook('radiation_aerosol_optics_description:load',1,hook_handle) + + end subroutine read + + !--------------------------------------------------------------------- + ! Specify the preferred optical model for a particular aerosol + ! family, e.g. "call + ! aer_desc%preferred_optical_model('DD','Woodward2001')" would mean + ! that subsequent calls to get_index in which the optical model is + ! not specified would return the Woodward model rather than the + ! first matching model in the file. The check is only done on the + ! first len(optical_model_str) characters, so "Woodward" and + ! "Woodward2001" would both match the Woodward2001 model. + subroutine preferred_optical_model(this, code_str, optical_model_str) + + use yomhook, only : lhook, dr_hook + + class(aerosol_optics_description_type), intent(inout) :: this + character(len=2), intent(in) :: code_str + character(len=*), intent(in) :: optical_model_str + + ! Aerosol loop counter + integer :: ja + + real(jprb) :: hook_handle + + if (lhook) call dr_hook('radiation_aerosol_optics_description:preferred_optical_model',0,hook_handle) + + ! Loop over hydrophilic types + do ja = 1,size(this%bin_philic) + ! Check if we have a match + if (to_string(this%code_philic(:,ja)) == code_str & + & .and. to_string(this%optical_model_philic(1:len(optical_model_str),ja)) & + & == optical_model_str) then + this%is_preferred_philic(ja) = .true. + end if + end do + ! Repeat for the hydrophobic types + do ja = 1,size(this%bin_phobic) + if (to_string(this%code_phobic(:,ja)) == code_str & + & .and. to_string(this%optical_model_phobic(1:len(optical_model_str),ja)) & + & == optical_model_str) then + this%is_preferred_phobic(ja) = .true. + end if + end do + + if (lhook) call dr_hook('radiation_aerosol_optics_description:preferred_optical_model',1,hook_handle) + + end subroutine preferred_optical_model + + !--------------------------------------------------------------------- + ! Return the index to the aerosol optical properties corresponding + ! to the aerosol family in code_str (e.g. SS, DD etc), whether or + ! not the requested aerosol is hydrophilic in the logical + ! lhydrophilic, and optionally the size bin ibin and optical model + ! in optical_model_str. The return value may be used to populate the + ! radiation_config%i_aerosol_map vector, where a positive number is + ! a hydrophobic index, a negative number is a hydrophilic index and + ! zero indicates that the aerosol type was not found in the file. + ! This is a valid entry in i_aerosol_map meaning the aerosol is + ! ignored, but the calling routine to get_index might wish to throw + ! a warning or error. This routine works by assigning a score based + ! on the closeness of the match. + function get_index(this, code_str, lhydrophilic, ibin, optical_model_str) + + use yomhook, only : lhook, dr_hook + use easy_netcdf, only : netcdf_file + use radiation_io, only : nulout + + class(aerosol_optics_description_type), intent(in) :: this + character(len=2), intent(in) :: code_str + logical, intent(in) :: lhydrophilic + integer, intent(in), optional :: ibin + character(len=*), intent(in), optional :: optical_model_str + + ! Score of the currently selected aerosol index, and the score of + ! the current one under consideration + integer :: score, current_score + + ! Loop index for aerosol type + integer :: ja + + ! Return value + integer :: get_index + + ! Issue a warning if there is more than one equal match + logical :: is_ambiguous + + real(jprb) :: hook_handle + + if (lhook) call dr_hook('radiation_aerosol_optics_description:get_index',0,hook_handle) + + ! Initial values + get_index = 0 + score = 0 + is_ambiguous = .false. + + if (lhydrophilic) then + ! Loop over hydrophilic aerosol types + do ja = 1,size(this%bin_philic) + current_score = 0 + if (to_string(this%code_philic(:,ja)) == code_str) then + ! Aerosol code matches + if (present(ibin) .and. this%bin_philic(ja) > 0) then + if (ibin > 0) then + if (ibin == this%bin_philic(ja)) then + ! Requested bin number matches + current_score = 4 + else + ! Requested bin number does not match + current_score = -1 + end if + else + ! Bin number is zero: no request + current_score = 2 + end if + else + ! No bin number present + current_score = 2 + end if + if (present(optical_model_str)) then + if (to_string(this%optical_model_philic(1:len(optical_model_str),ja)) & + & == optical_model_str) then + ! Requested optical model matches + if (current_score >= 0) then + current_score = current_score + 4 + end if + else + ! Requested optical model does not match + current_score = -1 + end if + else if (current_score >= 0) then + ! No requested optical model + current_score = current_score + 2 + end if + if (current_score > 0 .and. this%is_preferred_philic(ja)) then + current_score = current_score + 1 + end if + if (current_score > score) then + ! Better score than any existing aerosol type + get_index = -ja + score = current_score + is_ambiguous = .false. + else if (current_score > 0 .and. current_score == score) then + is_ambiguous = .true. + end if + end if + end do + else + ! Loop over hydrophobic aerosol types + do ja = 1,size(this%bin_phobic) + current_score = 0 + if (to_string(this%code_phobic(:,ja)) == code_str) then + ! Aerosol code matches + if (present(ibin) .and. this%bin_phobic(ja) > 0) then + if (ibin > 0) then + if (ibin == this%bin_phobic(ja)) then + ! Requested bin number matches + current_score = 4 + else + ! Requested bin number does not match + current_score = -1 + end if + else + ! Bin number is zero: no request + current_score = 2 + end if + else + ! No bin number requested or present + current_score = 2 + end if + if (present(optical_model_str)) then + if (to_string(this%optical_model_phobic(1:len(optical_model_str),ja)) & + & == optical_model_str) then + ! Requested optical model matches + if (current_score >= 0) then + current_score = current_score + 4 + end if + else + ! Requested optical model does not match + current_score = -1 + end if + else if (current_score >= 0) then + ! No requested optical model + current_score = current_score + 2 + end if + if (current_score > 0 .and. this%is_preferred_phobic(ja)) then + current_score = current_score + 1 + end if + if (current_score > score) then + ! Better score than any existing aerosol type + get_index = ja + score = current_score + is_ambiguous = .false. + else if (current_score > 0 .and. current_score == score) then + is_ambiguous = .true. + end if + end if + end do + end if + + if (is_ambiguous) then + write(nulout,'(a,a2,a,l1,a)') 'Warning: get_index("', code_str, '",', lhydrophilic, & + & ',...) does not unambiguously identify an aerosol optical property index' + end if + + if (lhook) call dr_hook('radiation_aerosol_optics_description:get_index',1,hook_handle) + + end function get_index + + !--------------------------------------------------------------------- + ! Utility function to convert an array of single characters to a + ! character string (yes Fortran's string handling is a bit rubbish) + pure function to_string(arr) result(str) + character, intent(in) :: arr(:) + character(len=size(arr)) :: str + integer :: jc + do jc = 1,size(arr) + str(jc:jc) = arr(jc) + end do + end function to_string + +end module radiation_aerosol_optics_description Index: LMDZ6/trunk/libf/phylmd/ecrad/radiation_check.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad/radiation_check.F90 (revision 4489) +++ LMDZ6/trunk/libf/phylmd/ecrad/radiation_check.F90 (revision 4489) @@ -0,0 +1,212 @@ +! radiation_check.F90 - Checking routines +! +! (C) Copyright 2020- 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. +! +! Author: Robin Hogan +! Email: r.j.hogan@ecmwf.int +! License: see the COPYING file for details +! + +module radiation_check + + use parkind1, only : jprb + + implicit none + public + +contains + + !--------------------------------------------------------------------- + ! Return .true. if 1D allocatable array "var" is out of physical + ! range specified by boundmin and boundmax, and issue a warning. + ! "do_fix" determines whether erroneous values are fixed to lie + ! within the physical range. To check only a subset of the array, + ! specify i1 and i2 for the range. + function out_of_bounds_1d(var, var_name, boundmin, boundmax, do_fix, i1, i2) result (is_bad) + + use radiation_io, only : nulout + + real(jprb), allocatable, intent(inout) :: var(:) + character(len=*), intent(in) :: var_name + real(jprb), intent(in) :: boundmin, boundmax + logical, intent(in) :: do_fix + integer, optional, intent(in) :: i1, i2 + + logical :: is_bad + + real(jprb) :: varmin, varmax + + is_bad = .false. + + if (allocated(var)) then + + if (present(i1) .and. present(i2)) then + varmin = minval(var(i1:i2)) + varmax = maxval(var(i1:i2)) + else + varmin = minval(var) + varmax = maxval(var) + end if + + if (varmin < boundmin .or. varmax > boundmax) then + write(nulout,'(a,a,a,g12.4,a,g12.4,a,g12.4,a,g12.4)',advance='no') & + & '*** Warning: ', var_name, ' range', varmin, ' to', varmax, & + & ' is out of physical range', boundmin, 'to', boundmax + is_bad = .true. + if (do_fix) then + if (present(i1) .and. present(i2)) then + var(i1:i2) = max(boundmin, min(boundmax, var(i1:i2))) + else + var = max(boundmin, min(boundmax, var)) + end if + write(nulout,'(a)') ': corrected' + else + write(nulout,'(1x)') + end if + end if + + end if + + end function out_of_bounds_1d + + + !--------------------------------------------------------------------- + ! Return .true. if 2D allocatable array "var" is out of physical + ! range specified by boundmin and boundmax, and issue a warning. To + ! check only a subset of the array, specify i1 and i2 for the range + ! of the first dimension and j1 and j2 for the range of the second. + function out_of_bounds_2d(var, var_name, boundmin, boundmax, do_fix, & + & i1, i2, j1, j2) result (is_bad) + + use radiation_io, only : nulout + + real(jprb), allocatable, intent(inout) :: var(:,:) + character(len=*), intent(in) :: var_name + real(jprb), intent(in) :: boundmin, boundmax + logical, intent(in) :: do_fix + integer, optional, intent(in) :: i1, i2, j1, j2 + + ! Local copies of indices + integer :: ii1, ii2, jj1, jj2 + + logical :: is_bad + + real(jprb) :: varmin, varmax + + is_bad = .false. + + if (allocated(var)) then + + if (present(i1) .and. present(i2)) then + ii1 = i1 + ii2 = i2 + else + ii1 = lbound(var,1) + ii2 = ubound(var,1) + end if + if (present(j1) .and. present(j2)) then + jj1 = j1 + jj2 = j2 + else + jj1 = lbound(var,2) + jj2 = ubound(var,2) + end if + varmin = minval(var(ii1:ii2,jj1:jj2)) + varmax = maxval(var(ii1:ii2,jj1:jj2)) + + if (varmin < boundmin .or. varmax > boundmax) then + write(nulout,'(a,a,a,g12.4,a,g12.4,a,g12.4,a,g12.4)',advance='no') & + & '*** Warning: ', var_name, ' range', varmin, ' to', varmax,& + & ' is out of physical range', boundmin, 'to', boundmax + is_bad = .true. + if (do_fix) then + var(ii1:ii2,jj1:jj2) = max(boundmin, min(boundmax, var(ii1:ii2,jj1:jj2))) + write(nulout,'(a)') ': corrected' + else + write(nulout,'(1x)') + end if + end if + + end if + + end function out_of_bounds_2d + + + !--------------------------------------------------------------------- + ! Return .true. if 3D allocatable array "var" is out of physical + ! range specified by boundmin and boundmax, and issue a warning. To + ! check only a subset of the array, specify i1 and i2 for the range + ! of the first dimension, j1 and j2 for the second and k1 and k2 for + ! the third. + function out_of_bounds_3d(var, var_name, boundmin, boundmax, do_fix, & + & i1, i2, j1, j2, k1, k2) result (is_bad) + + use radiation_io, only : nulout + + real(jprb), allocatable, intent(inout) :: var(:,:,:) + character(len=*), intent(in) :: var_name + real(jprb), intent(in) :: boundmin, boundmax + logical, intent(in) :: do_fix + integer, optional, intent(in) :: i1, i2, j1, j2, k1, k2 + + ! Local copies of indices + integer :: ii1, ii2, jj1, jj2, kk1, kk2 + + logical :: is_bad + + real(jprb) :: varmin, varmax + + is_bad = .false. + + if (allocated(var)) then + + if (present(i1) .and. present(i2)) then + ii1 = i1 + ii2 = i2 + else + ii1 = lbound(var,1) + ii2 = ubound(var,1) + end if + if (present(j1) .and. present(j2)) then + jj1 = j1 + jj2 = j2 + else + jj1 = lbound(var,2) + jj2 = ubound(var,2) + end if + if (present(k1) .and. present(k2)) then + kk1 = k1 + kk2 = k2 + else + kk1 = lbound(var,3) + kk2 = ubound(var,3) + end if + varmin = minval(var(ii1:ii2,jj1:jj2,kk1:kk2)) + varmax = maxval(var(ii1:ii2,jj1:jj2,kk1:kk2)) + + if (varmin < boundmin .or. varmax > boundmax) then + write(nulout,'(a,a,a,g12.4,a,g12.4,a,g12.4,a,g12.4)',advance='no') & + & '*** Warning: ', var_name, ' range', varmin, ' to', varmax,& + & ' is out of physical range', boundmin, 'to', boundmax + is_bad = .true. + if (do_fix) then + var(ii1:ii2,jj1:jj2,kk1:kk2) = max(boundmin, min(boundmax, & + & var(ii1:ii2,jj1:jj2,kk1:kk2))) + write(nulout,'(a)') ': corrected' + else + write(nulout,'(1x)') + end if + end if + + end if + + end function out_of_bounds_3d + +end module radiation_check Index: LMDZ6/trunk/libf/phylmd/ecrad/radiation_cloud.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad/radiation_cloud.F90 (revision 4487) +++ LMDZ6/trunk/libf/phylmd/ecrad/radiation_cloud.F90 (revision 4489) @@ -16,4 +16,5 @@ ! 2019-01-14 R. Hogan Added inv_inhom_effective_size variable ! 2019-01-14 R. Hogan Added out_of_physical_bounds routine +! 2019-06-14 R. Hogan Added capability to store any number of cloud/precip types module radiation_cloud @@ -32,18 +33,21 @@ type cloud_type ! For maximum flexibility, an arbitrary number "ntype" of - ! cloud types could be stored, as follows: - ! integer :: ntype ! number of cloud types - ! integer :: nfraction ! number of cloud fractions - ! real(jprb), allocatable, dimension(:,:,:) :: & - ! mixing_ratio, & ! (ncol,nwetlev,ntype) mass mixing ratio (kg/kg) - ! particle_size,& ! (ncol,nwetlev,ntype) effective radius/size (m) - ! fraction ! (ncol,nwetlev,nfraction) areal (i.e. cloud) fraction - ! However, for practical purposes at the moment we consider two - ! cloud types, liquid cloud droplets and ice cloud - ! particles. The following variables are dimensioned (ncol,nlev) - real(jprb), allocatable, dimension(:,:) :: & + ! hydrometeor types can be stored, dimensioned (ncol,nlev,ntype) + integer :: ntype = 0 + real(jprb), allocatable, dimension(:,:,:) :: & + & mixing_ratio, & ! mass mixing ratio (kg/kg) + & effective_radius ! (m) + + ! For backwards compatibility, we also allow for the two + ! traditional cloud types, liquid cloud droplets and ice cloud + ! particles, dimensioned (ncol,nlev) + real(jprb), pointer, dimension(:,:) :: & & q_liq, q_ice, & ! mass mixing ratio (kg/kg) - & re_liq, re_ice, & ! effective radius (m) - & fraction ! (0-1) Assume liq & ice completely mixed + & re_liq, re_ice ! effective radius (m) + + ! For the moment, the different types of hydrometeor are assumed + ! to be mixed with each other, so there is just one cloud fraction + ! variable varying from 0 to 1 + real(jprb), allocatable, dimension(:,:) :: fraction ! The fractional standard deviation of cloud optical depth in the @@ -95,11 +99,16 @@ ! in the offline code these are allocated when they are read from ! the NetCDF file - subroutine allocate_cloud_arrays(this, ncol, nlev, use_inhom_effective_size) + subroutine allocate_cloud_arrays(this, ncol, nlev, ntype, use_inhom_effective_size) use yomhook, only : lhook, dr_hook - class(cloud_type), intent(inout) :: this - integer, intent(in) :: ncol ! Number of columns - integer, intent(in) :: nlev ! Number of levels + class(cloud_type), intent(inout), target :: this + integer, intent(in) :: ncol ! Number of columns + integer, intent(in) :: nlev ! Number of levels + ! Number of cloud/precip particle types. If not present then the + ! older cloud behaviour is assumed: two types are present, (1) + ! liquid and (2) ice, and they can be accessed via q_liq, q_ice, + ! re_liq and re_ice. + integer, intent(in), optional :: ntype logical, intent(in), optional :: use_inhom_effective_size @@ -108,8 +117,23 @@ if (lhook) call dr_hook('radiation_cloud:allocate',0,hook_handle) - allocate(this%q_liq(ncol,nlev)) - allocate(this%re_liq(ncol,nlev)) - allocate(this%q_ice(ncol,nlev)) - allocate(this%re_ice(ncol,nlev)) + if (present(ntype)) then + this%ntype = ntype + else + this%ntype = 2 + end if + allocate(this%mixing_ratio(ncol,nlev,this%ntype)) + allocate(this%effective_radius(ncol,nlev,this%ntype)) + nullify(this%q_liq) + nullify(this%q_ice) + nullify(this%re_liq) + nullify(this%re_ice) + if (.not. present(ntype)) then + ! Older interface in which only liquid and ice are supported + this%q_liq => this%mixing_ratio(:,:,1) + this%q_ice => this%mixing_ratio(:,:,2) + this%re_liq => this%effective_radius(:,:,1) + this%re_ice => this%effective_radius(:,:,2) + end if + allocate(this%fraction(ncol,nlev)) allocate(this%overlap_param(ncol,nlev-1)) @@ -140,11 +164,14 @@ if (lhook) call dr_hook('radiation_cloud:deallocate',0,hook_handle) - if (allocated(this%q_liq)) deallocate(this%q_liq) - if (allocated(this%re_liq)) deallocate(this%re_liq) - if (allocated(this%q_ice)) deallocate(this%q_ice) - if (allocated(this%re_ice)) deallocate(this%re_ice) - if (allocated(this%fraction)) deallocate(this%fraction) - if (allocated(this%overlap_param)) deallocate(this%overlap_param) - if (allocated(this%fractional_std)) deallocate(this%fractional_std) + nullify(this%q_liq) + nullify(this%q_ice) + nullify(this%re_liq) + nullify(this%re_ice) + + if (allocated(this%mixing_ratio)) deallocate(this%mixing_ratio) + if (allocated(this%effective_radius)) deallocate(this%effective_radius) + if (allocated(this%fraction)) deallocate(this%fraction) + if (allocated(this%overlap_param)) deallocate(this%overlap_param) + if (allocated(this%fractional_std)) deallocate(this%fractional_std) if (allocated(this%inv_cloud_effective_size)) & & deallocate(this%inv_cloud_effective_size) @@ -185,5 +212,5 @@ integer :: ncol, nlev - integer :: jlev + integer :: jcol, jlev real(jprb) :: hook_handle @@ -220,14 +247,18 @@ ! top-of-atmosphere to surface). In case pressure_hl(:,1)=0, we ! don't take the logarithm of the first pressure in each column. - this%overlap_param(i1:i2,1) = exp(-(R_over_g/decorrelation_length) & - & * thermodynamics%temperature_hl(i1:i2,2) & - & *log(thermodynamics%pressure_hl(i1:i2,3) & - & /thermodynamics%pressure_hl(i1:i2,2))) + do jcol = i1,i2 + this%overlap_param(jcol,1) = exp(-(R_over_g/decorrelation_length) & + & * thermodynamics%temperature_hl(jcol,2) & + & *log(thermodynamics%pressure_hl(jcol,3) & + & /thermodynamics%pressure_hl(jcol,2))) + end do do jlev = 2,nlev-1 - this%overlap_param(i1:i2,jlev) = exp(-(0.5_jprb*R_over_g/decorrelation_length) & - & * thermodynamics%temperature_hl(i1:i2,jlev+1) & - & *log(thermodynamics%pressure_hl(i1:i2,jlev+2) & - & /thermodynamics%pressure_hl(i1:i2,jlev))) + do jcol = i1,i2 + this%overlap_param(jcol,jlev) = exp(-(0.5_jprb*R_over_g/decorrelation_length) & + & * thermodynamics%temperature_hl(jcol,jlev+1) & + & *log(thermodynamics%pressure_hl(jcol,jlev+2) & + & /thermodynamics%pressure_hl(jcol,jlev))) + end do end do @@ -237,14 +268,18 @@ ! don't take the logarithm of the last pressure in each column. do jlev = 1,nlev-2 - this%overlap_param(i1:i2,jlev) = exp(-(0.5_jprb*R_over_g/decorrelation_length) & - & * thermodynamics%temperature_hl(i1:i2,jlev+1) & - & *log(thermodynamics%pressure_hl(i1:i2,jlev) & - & /thermodynamics%pressure_hl(i1:i2,jlev+2))) + do jcol = i1,i2 + this%overlap_param(jcol,jlev) = exp(-(0.5_jprb*R_over_g/decorrelation_length) & + & * thermodynamics%temperature_hl(jcol,jlev+1) & + & *log(thermodynamics%pressure_hl(jcol,jlev) & + & /thermodynamics%pressure_hl(jcol,jlev+2))) + end do end do - this%overlap_param(i1:i2,nlev-1) = exp(-(R_over_g/decorrelation_length) & - & * thermodynamics%temperature_hl(i1:i2,nlev) & - & *log(thermodynamics%pressure_hl(i1:i2,nlev-1) & - & /thermodynamics%pressure_hl(i1:i2,nlev))) - + + do jcol = i1,i2 + this%overlap_param(jcol,nlev-1) = exp(-(R_over_g/decorrelation_length) & + & * thermodynamics%temperature_hl(jcol,nlev) & + & *log(thermodynamics%pressure_hl(jcol,nlev-1) & + & /thermodynamics%pressure_hl(jcol,nlev))) + end do end if @@ -580,8 +615,9 @@ integer, intent(in) :: istartcol, iendcol - integer :: nlev - integer :: jcol, jlev + integer :: nlev, ntype + integer :: jcol, jlev, jh real(jprb) :: cloud_fraction_threshold, cloud_mixing_ratio_threshold + real(jprb) :: sum_mixing_ratio(istartcol:iendcol) real(jprb) :: hook_handle @@ -589,11 +625,19 @@ if (lhook) call dr_hook('radiation_cloud:crop_cloud_fraction',0,hook_handle) - nlev = size(this%fraction,2) - + nlev = size(this%fraction,2) + ntype = size(this%mixing_ratio,3) + do jlev = 1,nlev do jcol = istartcol,iendcol - if (this%fraction(jcol,jlev) < cloud_fraction_threshold & - & .or. this%q_liq(jcol,jlev)+this%q_ice(jcol,jlev) & - & < cloud_mixing_ratio_threshold) then + sum_mixing_ratio(jcol) = 0.0_jprb + end do + do jh = 1, ntype + do jcol = istartcol,iendcol + sum_mixing_ratio(jcol) = sum_mixing_ratio(jcol) + this%mixing_ratio(jcol,jlev,jh) + end do + end do + do jcol = istartcol,iendcol + if (this%fraction(jcol,jlev) < cloud_fraction_threshold & + & .or. sum_mixing_ratio(jcol) < cloud_mixing_ratio_threshold) then this%fraction(jcol,jlev) = 0.0_jprb end if @@ -612,5 +656,5 @@ use yomhook, only : lhook, dr_hook - use radiation_config, only : out_of_bounds_2d + use radiation_check, only : out_of_bounds_2d, out_of_bounds_3d class(cloud_type), intent(inout) :: this @@ -631,11 +675,7 @@ end if - is_bad = out_of_bounds_2d(this%q_liq, 'q_liq', 0.0_jprb, 1.0_jprb, & + is_bad = out_of_bounds_3d(this%mixing_ratio, 'cloud%mixing_ratio', 0.0_jprb, 1.0_jprb, & & do_fix_local, i1=istartcol, i2=iendcol) & - & .or. out_of_bounds_2d(this%q_ice, 'q_ice', 0.0_jprb, 1.0_jprb, & - & do_fix_local, i1=istartcol, i2=iendcol) & - & .or. out_of_bounds_2d(this%re_liq, 're_liq', 0.0_jprb, 0.01_jprb, & - & do_fix_local, i1=istartcol, i2=iendcol) & - & .or. out_of_bounds_2d(this%re_ice, 're_ice', 0.0_jprb, 0.1_jprb, & + & .or. out_of_bounds_3d(this%effective_radius, 'cloud%effective_radius', 0.0_jprb, 0.1_jprb, & & do_fix_local, i1=istartcol, i2=iendcol) & & .or. out_of_bounds_2d(this%fraction, 'cloud%fraction', 0.0_jprb, 1.0_jprb, & Index: LMDZ6/trunk/libf/phylmd/ecrad/radiation_cloud_cover.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad/radiation_cloud_cover.F90 (revision 4487) +++ LMDZ6/trunk/libf/phylmd/ecrad/radiation_cloud_cover.F90 (revision 4489) @@ -253,5 +253,9 @@ & + (1.0_jprb - overlap_alpha) & & * (frac(jlev)+frac(jlev+1)-frac(jlev)*frac(jlev+1)) - +! Added for DWD (2020) +#ifdef __SX__ + end do + do jlev = 1,nlev-1 +#endif if (frac(jlev) >= MaxCloudFrac) then ! Cloud cover has reached one Index: LMDZ6/trunk/libf/phylmd/ecrad/radiation_cloud_generator.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad/radiation_cloud_generator.F90 (revision 4487) +++ LMDZ6/trunk/libf/phylmd/ecrad/radiation_cloud_generator.F90 (revision 4489) @@ -18,4 +18,5 @@ ! Modifications ! 2018-02-22 R. Hogan Call masked version of PDF sampler for speed +! 2020-03-31 R. Hogan More vectorizable version of Exp-Ran module radiation_cloud_generator @@ -39,5 +40,5 @@ & fractional_std, pdf_sampler, & & od_scaling, total_cloud_cover, & - & is_beta_overlap) + & use_beta_overlap, use_vectorizable_generator) use parkind1, only : jprb @@ -86,5 +87,9 @@ ! overlap parameter of Shonk et al. (2010), and needs to be ! converted to alpha. - logical, intent(in), optional :: is_beta_overlap + logical, intent(in), optional :: use_beta_overlap + + ! Do we use the more vectorizable cloud generator, at the expense + ! of more random numbers being needed? + logical, intent(in), optional :: use_vectorizable_generator ! Outputs @@ -126,4 +131,6 @@ real(jprb), dimension(nlev-1) :: pair_cloud_cover, overhang + logical :: use_vec_gen + real(jprb) :: hook_handle @@ -132,5 +139,5 @@ if (i_overlap_scheme == IOverlapExponentialRandom) then call cum_cloud_cover_exp_ran(nlev, frac, overlap_param, & - & cum_cloud_cover, pair_cloud_cover, is_beta_overlap) + & cum_cloud_cover, pair_cloud_cover, use_beta_overlap) else if (i_overlap_scheme == IOverlapMaximumRandom) then call cum_cloud_cover_max_ran(nlev, frac, & @@ -138,5 +145,5 @@ else if (i_overlap_scheme == IOverlapExponential) then call cum_cloud_cover_exp_exp(nlev, frac, overlap_param, & - & cum_cloud_cover, pair_cloud_cover, is_beta_overlap) + & cum_cloud_cover, pair_cloud_cover, use_beta_overlap) else write(nulerr,'(a)') '*** Error: cloud overlap scheme not recognised' @@ -183,38 +190,64 @@ od_scaling = 0.0_jprb - ! Expensive operation: initialize random number generator for - ! this column - call initialize_random_numbers(iseed, random_stream) - - ! Compute ng random numbers to use to locate cloud top - call uniform_distribution(rand_top, random_stream) - - ! Loop over ng columns - do jg = 1,ng - ! Find the cloud top height corresponding to the current - ! random number, and store in itrigger - trigger = rand_top(jg) * total_cloud_cover - jlev = ibegin - do while (trigger > cum_cloud_cover(jlev) .and. jlev < iend) - jlev = jlev + 1 + if (present(use_vectorizable_generator)) then + use_vec_gen = use_vectorizable_generator + else + use_vec_gen = .false. + end if + + if (.not. use_vec_gen) then + ! Original generator that minimizes the number of random + ! numbers used, but is not vectorizable + + ! Expensive operation: initialize random number generator for + ! this column + call initialize_random_numbers(iseed, random_stream) + + ! Compute ng random numbers to use to locate cloud top + call uniform_distribution(rand_top, random_stream) + + ! Loop over ng columns + do jg = 1,ng + ! Find the cloud top height corresponding to the current + ! random number, and store in itrigger + trigger = rand_top(jg) * total_cloud_cover + jlev = ibegin + do while (trigger > cum_cloud_cover(jlev) .and. jlev < iend) + jlev = jlev + 1 + end do + itrigger = jlev + + if (i_overlap_scheme /= IOverlapExponential) then + call generate_column_exp_ran(ng, nlev, jg, random_stream, pdf_sampler, & + & frac, pair_cloud_cover, & + & cum_cloud_cover, overhang, fractional_std, overlap_param_inhom, & + & itrigger, iend, od_scaling) + else + call generate_column_exp_exp(ng, nlev, jg, random_stream, pdf_sampler, & + & frac, pair_cloud_cover, & + & cum_cloud_cover, overhang, fractional_std, overlap_param_inhom, & + & itrigger, iend, od_scaling) + end if + end do - itrigger = jlev - - if (i_overlap_scheme /= IOverlapExponential) then - call generate_column_exp_ran(ng, nlev, jg, random_stream, pdf_sampler, & - & frac, pair_cloud_cover, & - & cum_cloud_cover, overhang, fractional_std, overlap_param_inhom, & - & itrigger, iend, od_scaling) - else - call generate_column_exp_exp(ng, nlev, jg, random_stream, pdf_sampler, & - & frac, pair_cloud_cover, & - & cum_cloud_cover, overhang, fractional_std, overlap_param_inhom, & - & itrigger, iend, od_scaling) + + else + ! Alternative generator (only for Exp-Ran overlap so far) that + ! should be vectorizable but generates more random numbers, + ! some of which are not used + + if (i_overlap_scheme == IOverlapExponential) then + write(nulerr,'(a)') '*** Error: vectorizable cloud generator is not available with Exp-Exp overlap' + call radiation_abort() end if - - end do + + call generate_columns_exp_ran(ng, nlev, iseed, pdf_sampler, & + & total_cloud_cover, frac_threshold, frac, pair_cloud_cover, & + & cum_cloud_cover, overhang, fractional_std, overlap_param_inhom, & + & ibegin, iend, od_scaling) + + end if end if - if (lhook) call dr_hook('radiation_cloud_generator:cloud_generator',1,hook_handle) @@ -474,6 +507,8 @@ ! Sample from a lognormal or gamma distribution to obtain the - ! optical depth scalings, calling the faster masked version and - ! assuming values outside the range itrigger:iend are already zero + ! optical depth scalings + + ! Masked version assuming values outside the range itrigger:iend + ! are already zero: call pdf_sampler%masked_sample(n_layers_to_scale, & & fractional_std(itrigger:iend), & @@ -481,5 +516,223 @@ & is_cloudy(itrigger:iend)) + ! ! IFS version: + ! !$omp simd + ! do jlev=itrigger,iend + ! if (.not. is_cloudy(jlev)) then + ! od_scaling(ig,jlev) = 0.0_jprb + ! else + ! call sample_from_pdf_simd(& + ! pdf_sampler,fractional_std(jlev),& + ! rand_inhom1(jlev-itrigger+1), & + ! od_scaling(ig,jlev)) + ! end if + ! end do + end subroutine generate_column_exp_exp + + !--------------------------------------------------------------------- + ! Extract the value of a lognormal distribution with fractional + ! standard deviation "fsd" corresponding to the cumulative + ! distribution function value "cdf", and return it in x. Since this + ! is an elemental subroutine, fsd, cdf and x may be arrays. SIMD version. + subroutine sample_from_pdf_simd(this, fsd, cdf, x) + use parkind1, only : jprb + use radiation_pdf_sampler, only : pdf_sampler_type + implicit none +#if defined(__GFORTRAN__) || defined(__PGI) || defined(__NEC__) +#else + !$omp declare simd(sample_from_pdf_simd) uniform(this) & + !$omp linear(ref(fsd)) linear(ref(cdf)) +#endif + type(pdf_sampler_type), intent(in) :: this + + ! Fractional standard deviation (0 to 4) and cumulative + ! distribution function (0 to 1) + real(jprb), intent(in) :: fsd, cdf + + ! Sample from distribution + real(jprb), intent(out) :: x + + ! Index to look-up table + integer :: ifsd, icdf + + ! Weights in bilinear interpolation + real(jprb) :: wfsd, wcdf + + ! Bilinear interpolation with bounds + wcdf = cdf * (this%ncdf-1) + 1.0_jprb + icdf = max(1, min(int(wcdf), this%ncdf-1)) + wcdf = max(0.0_jprb, min(wcdf - icdf, 1.0_jprb)) + + wfsd = (fsd-this%fsd1) * this%inv_fsd_interval + 1.0_jprb + ifsd = max(1, min(int(wfsd), this%nfsd-1)) + wfsd = max(0.0_jprb, min(wfsd - ifsd, 1.0_jprb)) + + x = (1.0_jprb-wcdf)*(1.0_jprb-wfsd) * this%val(icdf ,ifsd) & + & + (1.0_jprb-wcdf)* wfsd * this%val(icdf ,ifsd+1) & + & + wcdf *(1.0_jprb-wfsd) * this%val(icdf+1,ifsd) & + & + wcdf * wfsd * this%val(icdf+1,ifsd+1) + + end subroutine sample_from_pdf_simd + + + !--------------------------------------------------------------------- + ! Generate columns of optical depth scalings using + ! exponential-random overlap (which includes maximum-random overlap + ! as a limiting case). This version is intended to work better on + ! hardware with long vector lengths. As with all calculations in + ! this file, we zoom into the fraction of the column with cloud at + ! any height, so that all spectral intervals see a cloud somewhere. + ! In the McICA solver, this is combined appropriately with the + ! clear-sky calculation. + subroutine generate_columns_exp_ran(ng, nlev, iseed, pdf_sampler, & + & total_cloud_cover, frac_threshold, frac, pair_cloud_cover, & + & cum_cloud_cover, overhang, fractional_std, overlap_param_inhom, & + & ibegin, iend, od_scaling) + + use parkind1, only : jprb + use radiation_pdf_sampler, only : pdf_sampler_type + use radiation_random_numbers, only : rng_type, IRngMinstdVector, IRngNative + + implicit none + + ! Number of g points / columns + integer, intent(in) :: ng + + ! Number of levels + integer, intent(in) :: nlev + + integer, intent(in) :: iseed ! seed for random number generator + + ! Stream for producing random numbers + !type(randomnumberstream) :: random_stream + type(rng_type) :: random_number_generator + + ! Object for sampling from a lognormal or gamma distribution + type(pdf_sampler_type), intent(in) :: pdf_sampler + + ! Total cloud cover using cloud fraction and overlap parameter + real(jprb), intent(in) :: total_cloud_cover + + real(jprb), intent(in) :: frac_threshold + + ! Cloud fraction, cumulative cloud cover and fractional standard + ! deviation in each layer + real(jprb), intent(in), dimension(nlev) :: frac, cum_cloud_cover, fractional_std + + ! Cloud cover of a pair of layers, and amount by which cloud at + ! next level increases total cloud cover as seen from above + real(jprb), intent(in), dimension(nlev-1) :: pair_cloud_cover, overhang + + ! Overlap parameter of inhomogeneities + real(jprb), intent(in), dimension(nlev-1) :: overlap_param_inhom + + ! Top of highest cloudy layer and base of lowest + integer, intent(inout) :: ibegin, iend + + ! Optical depth scaling to output + real(jprb), intent(inout), dimension(ng,nlev) :: od_scaling + + ! Loop indices + integer :: jlev, jg + + real(jprb) :: rand_cloud(ng,ibegin:iend) + real(jprb) :: rand_inhom(ng,ibegin-1:iend), rand_inhom2(ng,ibegin:iend) + + ! Is the cloud fraction above the minimum threshold at each level + logical :: is_any_cloud(ibegin:iend) + + ! Scaled random number for finding cloud + real(jprb) :: trigger(ng) + + logical :: is_cloud(ng) ! Is there cloud at this level and spectral interval? + logical :: prev_cloud(ng) ! Was there cloud at level above? + logical :: first_cloud(ng) ! At level of first cloud counting down from top? + logical :: found_cloud(ng) ! Cloud found in this column counting down from top? + + is_any_cloud = (frac(ibegin:iend) >= frac_threshold) + + ! Initialize random number generator for this column, and state + ! that random numbers will be requested in blocks of length the + ! number of spectral intervals ng. + call random_number_generator%initialize(IRngMinstdVector, iseed=iseed, & + & nmaxstreams=ng) + + ! Random numbers to use to locate cloud top + call random_number_generator%uniform_distribution(trigger) + + ! Random numbers to work out whether to transition vertically from + ! clear to cloudy, cloudy to clear, clear to clear or cloudy to + ! cloudy + call random_number_generator%uniform_distribution(rand_cloud, is_any_cloud) + + ! Random numbers to generate sub-grid cloud structure + call random_number_generator%uniform_distribution(rand_inhom) + call random_number_generator%uniform_distribution(rand_inhom2, is_any_cloud) + + trigger = trigger * total_cloud_cover + + ! Initialize logicals for clear-sky above first cloudy layer + found_cloud = .false. + is_cloud = .false. + first_cloud = .false. + + ! Loop down through layers starting at the first cloudy layer + do jlev = ibegin,iend + + if (is_any_cloud(jlev)) then + +! Added for DWD (2020) +!NEC$ shortloop + do jg = 1,ng + ! The intention is that all these operations are vectorizable, + ! since all are vector operations on vectors of length ng... + + ! Copy the cloud mask between levels + prev_cloud(jg) = is_cloud(jg) + + ! For each spectral interval, has the first cloud appeared at this level? + first_cloud(jg) = (trigger(jg) <= cum_cloud_cover(jlev) .and. .not. found_cloud(jg)) + + ! ...if so, add to found_cloud + found_cloud(jg) = found_cloud(jg) .or. first_cloud(jg) + + ! There is cloud at this level either if a first cloud has + ! appeared, or using separate probability calculations + ! depending on whether there is a cloud above (given by + ! prev_cloud) + is_cloud(jg) = first_cloud(jg) & + & .or. found_cloud(jg) .and. merge(rand_cloud(jg,jlev)*frac(jlev-1) & + & < frac(jlev)+frac(jlev-1)-pair_cloud_cover(jlev-1), & + & rand_cloud(jg,jlev)*(cum_cloud_cover(jlev-1) - frac(jlev-1)) & + & < pair_cloud_cover(jlev-1) - overhang(jlev-1) - frac(jlev-1), & + & prev_cloud(jg)) + ! The random number determining cloud structure decorrelates + ! with the one above it according to the overlap parameter, + ! but always decorrelates if there is clear-sky above. If + ! there is clear-sky in the present level, the random number + ! is set to zero to ensure that the optical depth scaling is + ! also zero. + rand_inhom(jg,jlev) = merge(merge(rand_inhom(jg,jlev-1), rand_inhom(jg,jlev), & + & rand_inhom2(jg,jlev) < overlap_param_inhom(jlev-1) & + & .and. prev_cloud(jg)), & + & 0.0_jprb, is_cloud(jg)) + end do + else + ! No cloud at this level + is_cloud = .false. + end if + end do + + ! Sample from a lognormal or gamma distribution to obtain the + ! optical depth scalings, calling the faster masked version and + ! assuming values outside the range ibegin:iend are already zero + call pdf_sampler%masked_block_sample(iend-ibegin+1, ng, & + & fractional_std(ibegin:iend), & + & rand_inhom(:,ibegin:iend), od_scaling(:,ibegin:iend), & + & is_any_cloud) + + end subroutine generate_columns_exp_ran + end module radiation_cloud_generator Index: LMDZ6/trunk/libf/phylmd/ecrad/radiation_cloud_optics.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad/radiation_cloud_optics.F90 (revision 4487) +++ LMDZ6/trunk/libf/phylmd/ecrad/radiation_cloud_optics.F90 (revision 4489) @@ -19,4 +19,5 @@ implicit none + public @@ -271,5 +272,5 @@ type(cloud_optics_type), pointer :: ho - integer :: jcol, jlev + integer :: jcol, jlev, jb real(jprb) :: hook_handle @@ -345,8 +346,10 @@ end if + ! Delta-Eddington scaling in the shortwave only if (.not. config%do_sw_delta_scaling_with_gases) then - ! Delta-Eddington scaling in the shortwave only call delta_eddington_scat_od(od_sw_liq, scat_od_sw_liq, g_sw_liq) end if + !call delta_eddington_scat_od(od_lw_liq, scat_od_lw_liq, g_lw_liq) + else ! Liquid not present: set properties to zero @@ -437,12 +440,12 @@ end if + ! Delta-Eddington scaling in both longwave and shortwave + ! (assume that particles are larger than wavelength even + ! in longwave) if (.not. config%do_sw_delta_scaling_with_gases) then - ! Delta-Eddington scaling in both longwave and shortwave - ! (assume that particles are larger than wavelength even - ! in longwave) call delta_eddington_scat_od(od_sw_ice, scat_od_sw_ice, g_sw_ice) end if - call delta_eddington_scat_od(od_lw_ice, scat_od_lw_ice, g_lw_ice) + else ! Ice not present: set properties to zero @@ -458,27 +461,39 @@ ! Combine liquid and ice if (config%do_lw_cloud_scattering) then - od_lw_cloud(:,jlev,jcol) = od_lw_liq + od_lw_ice - where (scat_od_lw_liq+scat_od_lw_ice > 0.0_jprb) - g_lw_cloud(:,jlev,jcol) = (g_lw_liq * scat_od_lw_liq & - & + g_lw_ice * scat_od_lw_ice) & - & / (scat_od_lw_liq+scat_od_lw_ice) - elsewhere - g_lw_cloud(:,jlev,jcol) = 0.0_jprb - end where - ssa_lw_cloud(:,jlev,jcol) = (scat_od_lw_liq + scat_od_lw_ice) & - & / (od_lw_liq + od_lw_ice) +! Added for DWD (2020) +!NEC$ shortloop + do jb = 1, config%n_bands_lw + od_lw_cloud(jb,jlev,jcol) = od_lw_liq(jb) + od_lw_ice(jb) + if (scat_od_lw_liq(jb)+scat_od_lw_ice(jb) > 0.0_jprb) then + g_lw_cloud(jb,jlev,jcol) = (g_lw_liq(jb) * scat_od_lw_liq(jb) & + & + g_lw_ice(jb) * scat_od_lw_ice(jb)) & + & / (scat_od_lw_liq(jb)+scat_od_lw_ice(jb)) + else + g_lw_cloud(jb,jlev,jcol) = 0.0_jprb + end if + ssa_lw_cloud(jb,jlev,jcol) = (scat_od_lw_liq(jb) + scat_od_lw_ice(jb)) & + & / (od_lw_liq(jb) + od_lw_ice(jb)) + end do else ! If longwave scattering is to be neglected then the ! best approximation is to set the optical depth equal ! to the absorption optical depth - od_lw_cloud(:,jlev,jcol) = od_lw_liq - scat_od_lw_liq & - & + od_lw_ice - scat_od_lw_ice +! Added for DWD (2020) +!NEC$ shortloop + do jb = 1, config%n_bands_lw + od_lw_cloud(jb,jlev,jcol) = od_lw_liq(jb) - scat_od_lw_liq(jb) & + & + od_lw_ice(jb) - scat_od_lw_ice(jb) + end do end if - od_sw_cloud(:,jlev,jcol) = od_sw_liq + od_sw_ice - g_sw_cloud(:,jlev,jcol) = (g_sw_liq * scat_od_sw_liq & - & + g_sw_ice * scat_od_sw_ice) & - & / (scat_od_sw_liq + scat_od_sw_ice) - ssa_sw_cloud(:,jlev,jcol) & - & = (scat_od_sw_liq + scat_od_sw_ice) / (od_sw_liq + od_sw_ice) +! Added for DWD (2020) +!NEC$ shortloop + do jb = 1, config%n_bands_sw + od_sw_cloud(jb,jlev,jcol) = od_sw_liq(jb) + od_sw_ice(jb) + g_sw_cloud(jb,jlev,jcol) = (g_sw_liq(jb) * scat_od_sw_liq(jb) & + & + g_sw_ice(jb) * scat_od_sw_ice(jb)) & + & / (scat_od_sw_liq(jb) + scat_od_sw_ice(jb)) + ssa_sw_cloud(jb,jlev,jcol) & + & = (scat_od_sw_liq(jb) + scat_od_sw_ice(jb)) / (od_sw_liq(jb) + od_sw_ice(jb)) + end do end if ! Cloud present end do ! Loop over column Index: LMDZ6/trunk/libf/phylmd/ecrad/radiation_config.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad/radiation_config.F90 (revision 4487) +++ LMDZ6/trunk/libf/phylmd/ecrad/radiation_config.F90 (revision 4489) @@ -26,4 +26,6 @@ ! 2019-02-03 R. Hogan Added ability to fix out-of-physical-bounds inputs ! 2019-02-10 R. Hogan Renamed "encroachment" to "entrapment" +! 2020-05-18 R. Hogan Moved out_of_bounds_* to radiation_check.F90 +! 2021-07-04 R. Hogan Numerous changes for ecCKD and general cloud/aerosol optics ! ! Note: The aim is for ecRad in the IFS to be as similar as possible @@ -37,8 +39,10 @@ use radiation_cloud_optics_data, only : cloud_optics_type + use radiation_general_cloud_optics_data, only : general_cloud_optics_type use radiation_aerosol_optics_data, only : aerosol_optics_type use radiation_pdf_sampler, only : pdf_sampler_type use radiation_cloud_cover, only : OverlapName, & & IOverlapMaximumRandom, IOverlapExponentialRandom, IOverlapExponential + use radiation_ecckd, only : ckd_model_type implicit none @@ -70,5 +74,4 @@ & IEntrapmentExplicitNonFractal, & ! As above but ignore fractal nature of clouds & IEntrapmentMaximum ! Complete horizontal homogenization within regions (old SPARTACUS assumption) - end enum @@ -94,8 +97,9 @@ ! Gas models enum, bind(c) - enumerator IGasModelMonochromatic, IGasModelIFSRRTMG + enumerator IGasModelMonochromatic, IGasModelIFSRRTMG, IGasModelECCKD end enum - character(len=*), parameter :: GasModelName(0:1) = (/ 'Monochromatic', & - & 'RRTMG-IFS ' /) + character(len=*), parameter :: GasModelName(0:2) = (/ 'Monochromatic', & + & 'RRTMG-IFS ', & + & 'ECCKD '/) ! Hydrometeor scattering models @@ -130,4 +134,7 @@ integer, parameter :: NMaxAerosolTypes = 256 + ! Maximum number of different cloud types that can be provided + integer, parameter :: NMaxCloudTypes = 12 + ! Maximum number of shortwave albedo and longwave emissivity ! intervals @@ -155,4 +162,16 @@ character(len=511) :: directory_name = '.' + ! If this is true then support arbitrary hydrometeor types (not + ! just ice and liquid) and arbitrary spectral discretization (not + ! just RRTMG). It is required that this is true if the ecCKD gas + ! optics model is selected. General cloud optics has only been + ! available from ecRad version 1.5. + logical :: use_general_cloud_optics = .true. + + ! If this is true then support aerosol properties at an arbitrary + ! spectral discretization (not just RRTMG). It is required that + ! this is true if the ecCKD gas optics model is selected. + logical :: use_general_aerosol_optics = .true. + ! Cloud is deemed to be present in a layer if cloud fraction ! exceeds this value @@ -168,4 +187,13 @@ ! (2000)? logical :: use_beta_overlap = .false. + + ! Use a more vectorizable McICA cloud generator, at the expense of + ! more random numbers being generated? This is the default on NEC + ! SX. +#ifdef __SX__ + logical :: use_vectorizable_generator = .true. +#else + logical :: use_vectorizable_generator = .false. +#endif ! Shape of sub-grid cloud water PDF @@ -236,8 +264,6 @@ logical :: do_sw_delta_scaling_with_gases = .false. - ! Codes describing the gas and cloud scattering models to use, the - ! latter of which is currently not used + ! Codes describing the gas model integer :: i_gas_model = IGasModelIFSRRTMG - ! integer :: i_cloud_model ! Optics if i_gas_model==IGasModelMonochromatic. @@ -270,12 +296,14 @@ ! according to the spectral overlap of each interval with each ! band - logical :: do_nearest_spectral_sw_albedo = .true. - logical :: do_nearest_spectral_lw_emiss = .true. + logical :: do_nearest_spectral_sw_albedo = .false. + logical :: do_nearest_spectral_lw_emiss = .false. ! User-defined monotonically increasing wavelength bounds (m) ! between input surface albedo/emissivity intervals. Implicitly - ! the first interval starts at zero and the last ends at infinity. + ! the first interval starts at zero and the last ends at + ! infinity. These must be set with define_sw_albedo_intervals and + ! define_lw_emiss_intervals. real(jprb) :: sw_albedo_wavelength_bound(NMaxAlbedoIntervals-1) = -1.0_jprb - real(jprb) :: lw_emiss_wavelength_bound( NMaxAlbedoIntervals-1) = -1.0_jprb + real(jprb) :: lw_emiss_wavelength_bound( NMaxAlbedoIntervals-1) = -1.0_jprb ! The index to the surface albedo/emissivity intervals for each of @@ -296,4 +324,17 @@ logical :: do_3d_effects = .true. + character(len=511) :: cloud_type_name(NMaxCloudTypes) = ["","","","","","","","","","","",""] +! & +! & = ["mie_droplet ", & +! & "baum-general-habit-mixture_ice"] + + ! Spectral averaging method to use with generalized cloud optics; + ! see Edwards & Slingo (1996) for definition. Experimentation + ! with ecRad suggests that "thick" averaging is more accurate for + ! both liquid and ice clouds. + logical :: use_thick_cloud_spectral_averaging(NMaxCloudTypes) & + & = [.true.,.true.,.true.,.true.,.true.,.true., & + & .true.,.true.,.true.,.true.,.true.,.true.] + ! To what extent do we include "entrapment" effects in the ! SPARTACUS solver? This essentially means that in a situation @@ -420,7 +461,9 @@ ! doesn't start with a '/' character then it will be prepended by ! the contents of directory_name. - character(len=511) :: ice_optics_override_file_name = '' - character(len=511) :: liq_optics_override_file_name = '' + character(len=511) :: ice_optics_override_file_name = '' + character(len=511) :: liq_optics_override_file_name = '' character(len=511) :: aerosol_optics_override_file_name = '' + character(len=511) :: gas_optics_sw_override_file_name = '' + character(len=511) :: gas_optics_lw_override_file_name = '' ! Optionally override the look-up table file for the cloud-water @@ -428,17 +471,26 @@ character(len=511) :: cloud_pdf_override_file_name = '' + ! Do we compute cloud, aerosol and surface optical properties per + ! g point? Not available with RRTMG gas optics model. + logical :: do_cloud_aerosol_per_sw_g_point = .true. + logical :: do_cloud_aerosol_per_lw_g_point = .true. + + ! Do we weight the mapping from surface emissivity/albedo to + ! g-point/band weighting by a reference Planck function (more + ! accurate) or weighting each wavenumber equally (less accurate + ! but consistent with IFS Cycle 48r1 and earlier)? + logical :: do_weighted_surface_mapping = .true. + + ! COMPUTED PARAMETERS + + ! Users of this library should not edit these parameters directly; + ! they are set by the "consolidate" routine + ! Has "consolidate" been called? logical :: is_consolidated = .false. - ! COMPUTED PARAMETERS - ! Users of this library should not edit these parameters directly; - ! they are set by the "consolidate" routine - - ! Wavenumber range for each band, in cm-1, which will be allocated - ! to be of length n_bands_sw or n_bands_lw - real(jprb), allocatable, dimension(:) :: wavenumber1_sw - real(jprb), allocatable, dimension(:) :: wavenumber2_sw - real(jprb), allocatable, dimension(:) :: wavenumber1_lw - real(jprb), allocatable, dimension(:) :: wavenumber2_lw + ! Fraction of each g point in each wavenumber interval, + ! dimensioned (n_wav_frac_[l|s]w, n_g_[l|s]w) + real(jprb), allocatable, dimension(:,:) :: g_frac_sw, g_frac_lw ! If the nearest surface albedo/emissivity interval is to be used @@ -490,6 +542,18 @@ integer :: n_canopy_bands_lw = 1 + ! Data structures containing gas optics description in the case of + ! ecCKD + type(ckd_model_type) :: gas_optics_sw, gas_optics_lw + ! Data structure containing cloud scattering data type(cloud_optics_type) :: cloud_optics + + ! Number of general cloud types, default liquid and ice + integer :: n_cloud_types = 2 + + ! List of data structures (one per cloud type) containing cloud + ! scattering data + type(general_cloud_optics_type), allocatable :: cloud_optics_sw(:) + type(general_cloud_optics_type), allocatable :: cloud_optics_lw(:) ! Data structure containing aerosol scattering data @@ -502,5 +566,7 @@ character(len=511) :: ice_optics_file_name, & & liq_optics_file_name, & - & aerosol_optics_file_name + & aerosol_optics_file_name, & + & gas_optics_sw_file_name, & + & gas_optics_lw_file_name ! McICA PDF look-up table file name @@ -515,4 +581,8 @@ ! g points or the number of bands integer :: n_spec_sw = 0, n_spec_lw = 0 + + ! Number of wavenumber intervals used to describe the mapping from + ! g-points to wavenumber space + integer :: n_wav_frac_sw = 0, n_wav_frac_lw = 0 ! Dimensions to store variables that are only needed if longwave @@ -539,5 +609,7 @@ procedure :: define_sw_albedo_intervals procedure :: define_lw_emiss_intervals - procedure :: consolidate_intervals + procedure :: set_aerosol_wavelength_mono + procedure :: consolidate_sw_albedo_intervals + procedure :: consolidate_lw_emiss_intervals end type config_type @@ -574,4 +646,5 @@ logical :: do_sw, do_lw, do_clear, do_sw_direct logical :: do_3d_effects, use_expm_everywhere, use_aerosols + logical :: use_general_cloud_optics, use_general_aerosol_optics logical :: do_lw_side_emissivity logical :: do_3d_lw_multilayer_effects, do_fu_lw_ice_optics_bug @@ -579,9 +652,11 @@ logical :: do_save_radiative_properties, do_save_spectral_flux logical :: do_save_gpoint_flux, do_surface_sw_spectral_flux - logical :: use_beta_overlap, do_lw_derivatives + logical :: use_beta_overlap, do_lw_derivatives, use_vectorizable_generator logical :: do_sw_delta_scaling_with_gases logical :: do_canopy_fluxes_sw, do_canopy_fluxes_lw logical :: use_canopy_full_spectrum_sw, use_canopy_full_spectrum_lw logical :: do_canopy_gases_sw, do_canopy_gases_lw + logical :: do_cloud_aerosol_per_sw_g_point, do_cloud_aerosol_per_lw_g_point + logical :: do_weighted_surface_mapping integer :: n_regions, iverbose, iverbosesetup, n_aerosol_types real(jprb):: mono_lw_wavelength, mono_lw_total_od, mono_sw_total_od @@ -596,11 +671,16 @@ character(511) :: liq_optics_override_file_name, ice_optics_override_file_name character(511) :: cloud_pdf_override_file_name + character(511) :: gas_optics_sw_override_file_name, gas_optics_lw_override_file_name character(63) :: liquid_model_name, ice_model_name, gas_model_name character(63) :: sw_solver_name, lw_solver_name, overlap_scheme_name character(63) :: sw_entrapment_name, sw_encroachment_name, cloud_pdf_shape_name + character(len=511) :: cloud_type_name(NMaxCloudTypes) = ["","","","","","","","","","","",""] + logical :: use_thick_cloud_spectral_averaging(NMaxCloudTypes) & + & = [.false.,.false.,.false.,.false.,.false.,.false., & + & .false.,.false.,.false.,.false.,.false.,.false.] integer :: i_aerosol_type_map(NMaxAerosolTypes) ! More than 256 is an error - logical :: do_nearest_spectral_sw_albedo = .true. - logical :: do_nearest_spectral_lw_emiss = .true. + logical :: do_nearest_spectral_sw_albedo + logical :: do_nearest_spectral_lw_emiss real(jprb) :: sw_albedo_wavelength_bound(NMaxAlbedoIntervals-1) real(jprb) :: lw_emiss_wavelength_bound( NMaxAlbedoIntervals-1) @@ -609,6 +689,4 @@ integer :: iunit ! Unit number of namelist file - - logical :: lldeb_conf = .false. namelist /radiation/ do_sw, do_lw, do_sw_direct, & @@ -622,4 +700,5 @@ & ice_optics_override_file_name, liq_optics_override_file_name, & & aerosol_optics_override_file_name, cloud_pdf_override_file_name, & + & gas_optics_sw_override_file_name, gas_optics_lw_override_file_name, & & liquid_model_name, ice_model_name, max_3d_transfer_rate, & & min_cloud_effective_size, overhang_factor, encroachment_scaling, & @@ -627,6 +706,7 @@ & do_canopy_fluxes_sw, do_canopy_fluxes_lw, & & do_canopy_gases_sw, do_canopy_gases_lw, & + & use_general_cloud_optics, use_general_aerosol_optics, & & do_sw_delta_scaling_with_gases, overlap_scheme_name, & - & sw_solver_name, lw_solver_name, use_beta_overlap, & + & sw_solver_name, lw_solver_name, use_beta_overlap, use_vectorizable_generator, & & use_expm_everywhere, iverbose, iverbosesetup, & & cloud_inhom_decorr_scaling, cloud_fraction_threshold, & @@ -637,9 +717,11 @@ & mono_lw_single_scattering_albedo, mono_sw_single_scattering_albedo, & & mono_lw_asymmetry_factor, mono_sw_asymmetry_factor, & - & cloud_pdf_shape_name, & + & cloud_pdf_shape_name, cloud_type_name, use_thick_cloud_spectral_averaging, & & do_nearest_spectral_sw_albedo, do_nearest_spectral_lw_emiss, & & sw_albedo_wavelength_bound, lw_emiss_wavelength_bound, & - & i_sw_albedo_index, i_lw_emiss_index - + & i_sw_albedo_index, i_lw_emiss_index, & + & do_cloud_aerosol_per_lw_g_point, & + & do_cloud_aerosol_per_sw_g_point, do_weighted_surface_mapping + real(jprb) :: hook_handle @@ -670,4 +752,6 @@ ice_optics_override_file_name = this%ice_optics_override_file_name aerosol_optics_override_file_name = this%aerosol_optics_override_file_name + gas_optics_sw_override_file_name = this%gas_optics_sw_override_file_name + gas_optics_lw_override_file_name = this%gas_optics_lw_override_file_name use_expm_everywhere = this%use_expm_everywhere use_aerosols = this%use_aerosols @@ -679,7 +763,10 @@ iverbose = this%iverbose iverbosesetup = this%iverbosesetup + use_general_cloud_optics = this%use_general_cloud_optics + use_general_aerosol_optics = this%use_general_aerosol_optics cloud_fraction_threshold = this%cloud_fraction_threshold cloud_mixing_ratio_threshold = this%cloud_mixing_ratio_threshold use_beta_overlap = this%use_beta_overlap + use_vectorizable_generator = this%use_vectorizable_generator cloud_inhom_decorr_scaling = this%cloud_inhom_decorr_scaling clear_to_thick_fraction = this%clear_to_thick_fraction @@ -689,4 +776,7 @@ max_3d_transfer_rate = this%max_3d_transfer_rate min_cloud_effective_size = this%min_cloud_effective_size + cloud_type_name = this%cloud_type_name + use_thick_cloud_spectral_averaging = this%use_thick_cloud_spectral_averaging + overhang_factor = this%overhang_factor encroachment_scaling = -1.0_jprb @@ -715,4 +805,7 @@ i_sw_albedo_index = this%i_sw_albedo_index i_lw_emiss_index = this%i_lw_emiss_index + do_cloud_aerosol_per_lw_g_point = this%do_cloud_aerosol_per_lw_g_point + do_cloud_aerosol_per_sw_g_point = this%do_cloud_aerosol_per_sw_g_point + do_weighted_surface_mapping = this%do_weighted_surface_mapping if (present(file_name) .and. present(unit)) then @@ -746,5 +839,13 @@ end if else + + ! This version exits correctly, but provides less information + ! about how the namelist was incorrect read(unit=iunit, iostat=iosread, nml=radiation) + + ! Depending on compiler this version provides more information + ! about the error in the namelist + !read(unit=iunit, nml=radiation) + if (iosread /= 0) then ! An error occurred reading the file @@ -812,4 +913,5 @@ this%mono_sw_asymmetry_factor = mono_sw_asymmetry_factor this%use_beta_overlap = use_beta_overlap + this%use_vectorizable_generator = use_vectorizable_generator this%cloud_inhom_decorr_scaling = cloud_inhom_decorr_scaling this%clear_to_thick_fraction = clear_to_thick_fraction @@ -819,4 +921,6 @@ this%max_3d_transfer_rate = max_3d_transfer_rate this%min_cloud_effective_size = max(1.0e-6_jprb, min_cloud_effective_size) + this%cloud_type_name = cloud_type_name + this%use_thick_cloud_spectral_averaging = use_thick_cloud_spectral_averaging if (encroachment_scaling >= 0.0_jprb) then this%overhang_factor = encroachment_scaling @@ -832,4 +936,8 @@ this%ice_optics_override_file_name = ice_optics_override_file_name this%aerosol_optics_override_file_name = aerosol_optics_override_file_name + this%gas_optics_sw_override_file_name = gas_optics_sw_override_file_name + this%gas_optics_lw_override_file_name = gas_optics_lw_override_file_name + this%use_general_cloud_optics = use_general_cloud_optics + this%use_general_aerosol_optics = use_general_aerosol_optics this%cloud_fraction_threshold = cloud_fraction_threshold this%cloud_mixing_ratio_threshold = cloud_mixing_ratio_threshold @@ -845,72 +953,8 @@ this%i_sw_albedo_index = i_sw_albedo_index this%i_lw_emiss_index = i_lw_emiss_index - -! AI mars 2022 -if (lldeb_conf) then -print*,'**************PARAMETRES DE CONFIGURATION OFFLINE*******************' -print*,'config%iverbosesetup = ', iverbosesetup -print*,'config%do_lw = ', do_lw -print*,'config%do_sw = ', do_sw -print*,'config%do_clear = ', do_clear -print*,'config%do_sw_direct = ', do_sw_direct -print*,'config%do_3d_effects = ', do_3d_effects -print*,'config%do_3d_lw_multilayer_effects = ', do_3d_lw_multilayer_effects -print*,'config%do_lw_side_emissivity = ', do_lw_side_emissivity -print*,'config%use_expm_everywhere = ', use_expm_everywhere -print*,'config%use_aerosols = ', use_aerosols -print*,'config%do_lw_cloud_scattering = ', do_lw_cloud_scattering -print*,'config%do_lw_aerosol_scattering = ', do_lw_aerosol_scattering -print*,'config%nregions = ', n_regions -print*,'config%do_surface_sw_spectral_flux = ', do_surface_sw_spectral_flux -print*,'config%do_sw_delta_scaling_with_gases = ', & -do_sw_delta_scaling_with_gases -print*,'config%do_fu_lw_ice_optics_bug = ', do_fu_lw_ice_optics_bug -print*,'config%do_canopy_fluxes_sw = ', do_canopy_fluxes_sw -print*,'config%do_canopy_fluxes_lw = ', do_canopy_fluxes_lw -print*,'config%use_canopy_full_spectrum_sw = ', use_canopy_full_spectrum_sw -print*,'config%use_canopy_full_spectrum_lw = ', use_canopy_full_spectrum_lw -print*,'config%do_canopy_gases_sw = ', do_canopy_gases_sw -print*,'config%do_canopy_gases_lw = ', do_canopy_gases_lw -print*,'config%mono_lw_wavelength = ', mono_lw_wavelength -print*,'config%mono_lw_total_od = ', mono_lw_total_od -print*,'config%mono_sw_total_od = ', mono_sw_total_od -print*,'config%mono_lw_single_scattering_albedo = ', & -mono_lw_single_scattering_albedo -print*,'config%mono_sw_single_scattering_albedo = ', & -mono_sw_single_scattering_albedo -print*,'config%mono_lw_asymmetry_factor = ', mono_lw_asymmetry_factor -print*,'config%mono_sw_asymmetry_factor = ', mono_sw_asymmetry_factor -print*,'config%use_beta_overlap = ', use_beta_overlap -print*,'config%cloud_inhom_decorr_scaling = ', cloud_inhom_decorr_scaling -print*,'config%clear_to_thick_fraction = ', clear_to_thick_fraction -print*,'config%overhead_sun_factor = ', overhead_sun_factor -print*,'config%max_gas_od_3d = ', max_gas_od_3d -print*,'config%max_cloud_od = ', max_cloud_od -print*,'config%max_3d_transfer_rate = ', max_3d_transfer_rate -print*,'config%min_cloud_effective_size = ', & -max(1.0e-6_jprb,min_cloud_effective_size) -print*,'config%overhang_factor = ', encroachment_scaling - -print*,'config%directory_name = ',directory_name -print*,'config%cloud_pdf_override_file_name = ',cloud_pdf_override_file_name -print*,'config%liq_optics_override_file_name = ',liq_optics_override_file_name -print*,'config%ice_optics_override_file_name = ',ice_optics_override_file_name -print*,'config%aerosol_optics_override_file_name = ', & -aerosol_optics_override_file_name -print*,'config%cloud_fraction_threshold = ',cloud_fraction_threshold -print*,'config%cloud_mixing_ratio_threshold = ',cloud_mixing_ratio_threshold -print*,'config%n_aerosol_types = ',n_aerosol_types -print*,'config%do_save_radiative_properties = ',do_save_radiative_properties -print*,'config%do_lw_derivatives = ',do_lw_derivatives -print*,'config%do_save_spectral_flux = ',do_save_spectral_flux -print*,'config%do_save_gpoint_flux = ',do_save_gpoint_flux -print*,'config%do_nearest_spectral_sw_albedo = ',do_nearest_spectral_sw_albedo -print*,'config%do_nearest_spectral_lw_emiss = ',do_nearest_spectral_lw_emiss -print*,'config%sw_albedo_wavelength_bound = ',sw_albedo_wavelength_bound -print*,'config%lw_emiss_wavelength_bound = ',lw_emiss_wavelength_bound -print*,'config%i_sw_albedo_index = ',i_sw_albedo_index -print*,'config%i_lw_emiss_index = ',i_lw_emiss_index -print*,'************************************************************************' -endif + this%do_cloud_aerosol_per_lw_g_point = do_cloud_aerosol_per_lw_g_point + this%do_cloud_aerosol_per_sw_g_point = do_cloud_aerosol_per_sw_g_point + this%do_weighted_surface_mapping = do_weighted_surface_mapping + if (do_save_gpoint_flux) then ! Saving the fluxes every g-point overrides saving as averaged @@ -919,5 +963,4 @@ ! save anything this%do_save_spectral_flux = .true. - print*,'config%do_save_spectral_flux = .true.' end if @@ -925,22 +968,19 @@ call get_enum_code(liquid_model_name, LiquidModelName, & & 'liquid_model_name', this%i_liq_model) - print*,'config%i_liq_model =', this%i_liq_model ! Determine ice optics model call get_enum_code(ice_model_name, IceModelName, & & 'ice_model_name', this%i_ice_model) - print*,'config%i_ice_model =', this%i_ice_model + ! Determine gas optics model call get_enum_code(gas_model_name, GasModelName, & & 'gas_model_name', this%i_gas_model) - print*,'config%%i_gas_model = ', this%i_gas_model ! Determine solvers call get_enum_code(sw_solver_name, SolverName, & & 'sw_solver_name', this%i_solver_sw) - print*,'config%i_solver_sw = ', this%i_solver_sw call get_enum_code(lw_solver_name, SolverName, & & 'lw_solver_name', this%i_solver_lw) - print*,'config%i_solver_lw = ', this%i_solver_lw + if (len_trim(sw_encroachment_name) > 1) then call get_enum_code(sw_encroachment_name, EncroachmentName, & @@ -950,5 +990,4 @@ call get_enum_code(sw_entrapment_name, EntrapmentName, & & 'sw_entrapment_name', this%i_3d_sw_entrapment) - print*,'config%i_3d_sw_entrapment = ', this%i_3d_sw_entrapment end if @@ -956,14 +995,13 @@ call get_enum_code(overlap_scheme_name, OverlapName, & & 'overlap_scheme_name', this%i_overlap_scheme) - print*,'config%i_overlap_scheme = ', this%i_overlap_scheme + ! Determine cloud PDF shape call get_enum_code(cloud_pdf_shape_name, PdfShapeName, & & 'cloud_pdf_shape_name', this%i_cloud_pdf_shape) - print*,'config%i_cloud_pdf_shape = ', this%i_cloud_pdf_shape + this%i_aerosol_type_map = 0 if (this%use_aerosols) then this%i_aerosol_type_map(1:n_aerosol_types) & & = i_aerosol_type_map(1:n_aerosol_types) - print*,'config%i_aerosol_type_map = ', this%i_aerosol_type_map end if @@ -975,5 +1013,18 @@ this%do_clouds = .false. end if - print*,'config%do_clouds = ', this%do_clouds + + if (this%i_gas_model == IGasModelIFSRRTMG & + & .and. (this%use_general_cloud_optics & + & .or. this%use_general_aerosol_optics)) then + if (this%do_sw .and. this%do_cloud_aerosol_per_sw_g_point) then + write(nulout,'(a)') 'Warning: RRTMG SW only supports cloud/aerosol/surface optical properties per band, not per g-point' + this%do_cloud_aerosol_per_sw_g_point = .false. + end if + if (this%do_lw .and. this%do_cloud_aerosol_per_lw_g_point) then + write(nulout,'(a)') 'Warning: RRTMG LW only supports cloud/aerosol/surface optical properties per band, not per g-point' + this%do_cloud_aerosol_per_lw_g_point = .false. + end if + end if + ! Normal subroutine exit @@ -993,4 +1044,5 @@ subroutine consolidate_config(this) + use parkind1, only : jprd use yomhook, only : lhook, dr_hook use radiation_io, only : nulout, nulerr, radiation_abort @@ -1026,4 +1078,53 @@ write(nulerr,'(a)') '*** Error: SPARTACUS/Tripleclouds solvers can only do Exponential-Random overlap' call radiation_abort('Radiation configuration error') + end if + + if (jprb < jprd .and. this%iverbosesetup >= 1 & + & .and. (this%i_solver_sw == ISolverSPARTACUS & + & .or. this%i_solver_lw == ISolverSPARTACUS)) then + write(nulout,'(a)') 'Warning: the SPARTACUS solver may be unstable in single precision' + end if + + ! If ecCKD gas optics model is being used set relevant file names + if (this%i_gas_model == IGasModelECCKD) then + + ! This gas optics model requires the general cloud and + ! aerosol optics settings + if (.not. this%use_general_cloud_optics) then + write(nulerr,'(a)') '*** Error: ecCKD gas optics model requires general cloud optics' + call radiation_abort('Radiation configuration error') + end if + if (.not. this%use_general_aerosol_optics) then + write(nulerr,'(a)') '*** Error: ecCKD gas optics model requires general aerosol optics' + call radiation_abort('Radiation configuration error') + end if + + if (len_trim(this%gas_optics_sw_override_file_name) > 0) then + if (this%gas_optics_sw_override_file_name(1:1) == '/') then + this%gas_optics_sw_file_name = trim(this%gas_optics_sw_override_file_name) + else + this%gas_optics_sw_file_name = trim(this%directory_name) & + & // '/' // trim(this%gas_optics_sw_override_file_name) + end if + else + ! In the IFS, the gas optics files should be specified in + ! ifs/module/radiation_setup.F90, not here + this%gas_optics_sw_file_name = trim(this%directory_name) & + & // "/ecckd-1.0_sw_climate_rgb-32b_ckd-definition.nc" + end if + + if (len_trim(this%gas_optics_lw_override_file_name) > 0) then + if (this%gas_optics_lw_override_file_name(1:1) == '/') then + this%gas_optics_lw_file_name = trim(this%gas_optics_lw_override_file_name) + else + this%gas_optics_lw_file_name = trim(this%directory_name) & + & // '/' // trim(this%gas_optics_lw_override_file_name) + end if + else + ! In the IFS, the gas optics files should be specified in + ! ifs/module/radiation_setup.F90, not here + this%gas_optics_lw_file_name = trim(this%directory_name) & + & // "/ecckd-1.0_lw_climate_fsck-32b_ckd-definition.nc" + end if end if @@ -1040,6 +1141,11 @@ ! In the IFS, the aerosol optics file should be specified in ! ifs/module/radiation_setup.F90, not here - this%aerosol_optics_file_name & - & = trim(this%directory_name) // "/aerosol_ifs_rrtm_45R2.nc" + if (this%use_general_aerosol_optics) then + this%aerosol_optics_file_name & + & = trim(this%directory_name) // "/aerosol_ifs_48R1.nc" + else + this%aerosol_optics_file_name & + & = trim(this%directory_name) // "/aerosol_ifs_rrtm_46R1_with_NI_AM.nc" + end if end if @@ -1229,5 +1335,21 @@ & this%i_gas_model) call print_logical(' Aerosols are', 'use_aerosols', this%use_aerosols) - call print_logical(' Clouds are', 'do_clouds', this%do_clouds) + if (this%use_aerosols) then + call print_logical(' General aerosol optics', & + & 'use_general_aerosol_optics', this%use_general_aerosol_optics) + end if + if (this%do_clouds) then + write(nulout,'(a)') ' Clouds are ON' + else + write(nulout,'(a)') ' Clouds are OFF' + end if + if (this%do_sw) then + call print_logical(' Do cloud/aerosol/surface SW properties per g-point', & + & 'do_cloud_aerosol_per_sw_g_point', this%do_cloud_aerosol_per_sw_g_point) + end if + if (this%do_lw) then + call print_logical(' Do cloud/aerosol/surface LW properties per g-point', & + & 'do_cloud_aerosol_per_lw_g_point', this%do_cloud_aerosol_per_lw_g_point) + end if !--------------------------------------------------------------------- @@ -1253,4 +1375,7 @@ & 'do_nearest_spectral_lw_emiss', this%do_nearest_spectral_lw_emiss) end if + call print_logical(' Planck-weighted surface albedo/emiss mapping', & + & 'do_weighted_surface_mapping', this%do_weighted_surface_mapping) + !--------------------------------------------------------------------- if (this%do_clouds) then @@ -1260,11 +1385,15 @@ call print_real(' Cloud mixing-ratio threshold', & & 'cloud_mixing_ratio_threshold', this%cloud_mixing_ratio_threshold) - call print_enum(' Liquid optics scheme is', LiquidModelName, & - & 'i_liq_model',this%i_liq_model) - call print_enum(' Ice optics scheme is', IceModelName, & - & 'i_ice_model',this%i_ice_model) - if (this%i_ice_model == IIceModelFu) then - call print_logical(' Longwave ice optics bug in Fu scheme is', & - & 'do_fu_lw_ice_optics_bug',this%do_fu_lw_ice_optics_bug) + call print_logical(' General cloud optics', & + & 'use_general_cloud_optics', this%use_general_cloud_optics) + if (.not. this%use_general_cloud_optics) then + call print_enum(' Liquid optics scheme is', LiquidModelName, & + & 'i_liq_model',this%i_liq_model) + call print_enum(' Ice optics scheme is', IceModelName, & + & 'i_ice_model',this%i_ice_model) + if (this%i_ice_model == IIceModelFu) then + call print_logical(' Longwave ice optics bug in Fu scheme is', & + & 'do_fu_lw_ice_optics_bug',this%do_fu_lw_ice_optics_bug) + end if end if call print_enum(' Cloud overlap scheme is', OverlapName, & @@ -1360,4 +1489,9 @@ & 'overhang_factor', this%overhang_factor) end if + + else if (this%i_solver_sw == ISolverMcICA & + & .or. this%i_solver_lw == ISolverMcICA) then + call print_logical(' Use vectorizable McICA cloud generator', & + & 'use_vectorizable_generator', this%use_vectorizable_generator) end if @@ -1383,4 +1517,5 @@ use parkind1, only : jprb use radiation_io, only : nulout, nulerr, radiation_abort + use radiation_spectral_definition, only : SolarReferenceTemperature class(config_type), intent(in) :: this @@ -1396,12 +1531,16 @@ character(len=*), optional, intent(in) :: weighting_name + real(jprb), allocatable :: mapping(:,:) + ! Internally we deal with wavenumber real(jprb) :: wavenumber1, wavenumber2 ! cm-1 + real(jprb) :: wavenumber1_band, wavenumber2_band ! cm-1 + integer :: jband ! Loop index for spectral band if (this%n_bands_sw <= 0) then write(nulerr,'(a)') '*** Error: get_sw_weights called before number of shortwave bands set' - call radiation_abort() + call radiation_abort('Radiation configuration error') end if @@ -1410,14 +1549,16 @@ wavenumber2 = 0.01_jprb / wavelength1 + call this%gas_optics_sw%spectral_def%calc_mapping_from_bands(SolarReferenceTemperature, & + & [wavelength1, wavelength2], [1, 2, 3], mapping, & + & use_bands=(.not. this%do_cloud_aerosol_per_sw_g_point), use_fluxes=.true.) + + ! "mapping" now contains a 3*nband matrix, where mapping(2,:) + ! contains the weights of interest. We now find the non-zero weights nweights = 0 - - do jband = 1,this%n_bands_sw - if (wavenumber1 < this%wavenumber2_sw(jband) & - & .and. wavenumber2 > this%wavenumber1_sw(jband)) then + do jband = 1,size(mapping,2) + if (mapping(2,jband) > 0.0_jprb) then nweights = nweights+1 - iband(nweights) = jband - weight(nweights) = (min(wavenumber2,this%wavenumber2_sw(jband)) & - & - max(wavenumber1,this%wavenumber1_sw(jband))) & - & / (this%wavenumber2_sw(jband) - this%wavenumber1_sw(jband)) + iband(nweights) = jband; + weight(nweights) = mapping(2,jband) end if end do @@ -1426,14 +1567,22 @@ write(nulerr,'(a,e8.4,a,e8.4,a)') '*** Error: wavelength range ', & & wavelength1, ' to ', wavelength2, ' m is outside shortwave band' - call radiation_abort() + call radiation_abort('Radiation configuration error') else if (this%iverbosesetup >= 2 .and. present(weighting_name)) then write(nulout,'(a,a,a,f6.0,a,f6.0,a)') 'Spectral weights for ', & & weighting_name, ' (', wavenumber1, ' to ', & & wavenumber2, ' cm-1):' - do jband = 1, nweights - write(nulout, '(a,i0,a,f6.0,a,f6.0,a,f8.4)') ' Shortwave band ', & - & iband(jband), ' (', this%wavenumber1_sw(iband(jband)), ' to ', & - & this%wavenumber2_sw(iband(jband)), ' cm-1): ', weight(jband) - end do + if (this%do_cloud_aerosol_per_sw_g_point) then + do jband = 1, nweights + write(nulout, '(a,i0,a,f8.4)') ' Shortwave g point ', iband(jband), ': ', weight(jband) + end do + else + do jband = 1, nweights + wavenumber1_band = this%gas_optics_sw%spectral_def%wavenumber1_band(iband(jband)) + wavenumber2_band = this%gas_optics_sw%spectral_def%wavenumber2_band(iband(jband)) + write(nulout, '(a,i0,a,f6.0,a,f6.0,a,f8.4)') ' Shortwave band ', & + & iband(jband), ' (', wavenumber1_band, ' to ', & + & wavenumber2_band, ' cm-1): ', weight(jband) + end do + end if end if @@ -1452,4 +1601,5 @@ use radiation_io, only : nulerr, radiation_abort + use radiation_spectral_definition, only : SolarReferenceTemperature class(config_type), intent(inout) :: this @@ -1467,5 +1617,5 @@ write(nulerr,'(a,i0,a,i0)') '*** Error: ', ninterval, & & ' albedo intervals exceeds maximum of ', NMaxAlbedoIntervals - call radiation_abort(); + call radiation_abort('Radiation configuration error') end if @@ -1480,10 +1630,10 @@ this%i_sw_albedo_index(ninterval+1:) = 0 + ! If this routine is called before setup_radiation then the + ! spectral intervals are not yet known + ! consolidate_sw_albedo_intervals is called later. Otherwise it + ! is called immediately and overwrites any existing mapping. if (this%is_consolidated) then - call this%consolidate_intervals(.true., & - & this%do_nearest_spectral_sw_albedo, & - & this%sw_albedo_wavelength_bound, this%i_sw_albedo_index, & - & this%wavenumber1_sw, this%wavenumber2_sw, & - & this%i_albedo_from_band_sw, this%sw_albedo_weights) + call this%consolidate_sw_albedo_intervals end if @@ -1497,4 +1647,5 @@ use radiation_io, only : nulerr, radiation_abort + use radiation_spectral_definition, only : TerrestrialReferenceTemperature class(config_type), intent(inout) :: this @@ -1512,5 +1663,5 @@ write(nulerr,'(a,i0,a,i0)') '*** Error: ', ninterval, & & ' emissivity intervals exceeds maximum of ', NMaxAlbedoIntervals - call radiation_abort(); + call radiation_abort('Radiation configuration error') end if @@ -1526,9 +1677,5 @@ if (this%is_consolidated) then - call this%consolidate_intervals(.false., & - & this%do_nearest_spectral_lw_emiss, & - & this%lw_emiss_wavelength_bound, this%i_lw_emiss_index, & - & this%wavenumber1_lw, this%wavenumber2_lw, & - & this%i_emiss_from_band_lw, this%lw_emiss_weights) + call this%consolidate_lw_emiss_intervals end if @@ -1537,62 +1684,45 @@ !--------------------------------------------------------------------- - ! This routine consolidates either the input shortwave albedo - ! intervals with the shortwave bands, or the input longwave - ! emissivity intervals with the longwave bands, depending on the - ! arguments provided. - subroutine consolidate_intervals(this, is_sw, do_nearest, & - & wavelength_bound, i_intervals, wavenumber1, wavenumber2, & - & i_mapping, weights) - - use radiation_io, only : nulout, nulerr, radiation_abort + ! Set the wavelengths (m) at which monochromatic aerosol properties + ! are required. This routine must be called before consolidation of + ! settings. + subroutine set_aerosol_wavelength_mono(this, wavelength_mono) + + use radiation_io, only : nulerr, radiation_abort + + class(config_type), intent(inout) :: this + real(jprb), intent(in) :: wavelength_mono(:) + + if (this%is_consolidated) then + write(nulerr,'(a)') '*** Errror: set_aerosol_wavelength_mono must be called before setup_radiation' + call radiation_abort('Radiation configuration error') + end if + + if (allocated(this%aerosol_optics%wavelength_mono)) then + deallocate(this%aerosol_optics%wavelength_mono) + end if + allocate(this%aerosol_optics%wavelength_mono(size(wavelength_mono))) + this%aerosol_optics%wavelength_mono = wavelength_mono + + end subroutine set_aerosol_wavelength_mono + + + !--------------------------------------------------------------------- + ! Consolidate the surface shortwave albedo intervals with the + ! band/g-point intervals + subroutine consolidate_sw_albedo_intervals(this) + + use radiation_io, only : nulout + use radiation_spectral_definition, only : SolarReferenceTemperature class(config_type), intent(inout) :: this - ! Is this the shortwave? Otherwise longwave - logical, intent(in) :: is_sw - ! Do we find the nearest albedo interval to the centre of each - ! band, or properly weight the contributions? This can be modified - ! if there is only one albedo intervals. - logical, intent(inout) :: do_nearest - ! Monotonically increasing wavelength bounds between intervals, - ! not including the outer bounds (which are assumed to be zero and - ! infinity) - real(jprb), intent(in) :: wavelength_bound(NMaxAlbedoIntervals-1) - ! The albedo band indices corresponding to each interval - integer, intent(in) :: i_intervals(NMaxAlbedoIntervals) - ! Start and end wavenumber bounds for the ecRad bands (cm-1) - real(jprb), intent(in) :: wavenumber1(:), wavenumber2(:) - - ! if do_nearest is TRUE then the result is expressed in i_mapping, - ! which will be allocated to have the same length as wavenumber1, - ! and contain the index of the albedo interval corresponding to - ! that band - integer, allocatable, intent(inout) :: i_mapping(:) - ! ...otherwise the result is expressed in "weights", of - ! size(n_intervals, n_bands) containing how much of each interval - ! contributes to each band. - real(jprb), allocatable, intent(inout) :: weights(:,:) - - ! Number and loop index of ecRad bands - integer :: nband, jband - ! Number and index of albedo/emissivity intervals - integer :: ninterval, iinterval - ! Sometimes an albedo or emissivity value will be used in more - ! than one interval, so nvalue indicates how many values will - ! actually be provided - integer :: nvalue - ! Wavenumber bounds of the albedo/emissivity interval - real(jprb) :: wavenumber1_albedo, wavenumber2_albedo - ! Reciprocal of the wavenumber range of the ecRad band - real(jprb) :: recip_dwavenumber ! cm - ! Midpoint/bound of wavenumber band - real(jprb) :: wavenumber_mid, wavenumber_bound ! cm-1 - - nband = size(wavenumber1) + + integer :: ninterval, jint, jband ! Count the number of albedo/emissivity intervals ninterval = 0 - do iinterval = 1,NMaxAlbedoIntervals - if (i_intervals(iinterval) > 0) then - ninterval = iinterval + do jint = 1,NMaxAlbedoIntervals + if (this%i_sw_albedo_index(jint) > 0) then + ninterval = jint else exit @@ -1600,120 +1730,92 @@ end do - if (ninterval < 2) then - ! Zero or one albedo/emissivity intervals found, so we index all - ! bands to one interval - if (allocated(i_mapping)) then - deallocate(i_mapping) - end if - allocate(i_mapping(nband)) - i_mapping(:) = 1 - do_nearest = .true. + if (ninterval < 1) then + ! The user has not specified shortwave albedo bands - assume + ! only one ninterval = 1 - nvalue = 1 - else - ! Check wavelength is monotonically increasing - do jband = 2,ninterval-1 - if (wavelength_bound(jband) <= wavelength_bound(jband-1)) then - if (is_sw) then - write(nulerr, '(a,a)') '*** Error: wavelength bounds for shortwave albedo intervals ', & - & 'must be monotonically increasing' - else - write(nulerr, '(a,a)') '*** Error: wavelength bounds for longwave emissivity intervals ', & - & 'must be monotonically increasing' - end if - call radiation_abort() - end if - end do - - ! What is the maximum index, indicating the number of - ! albedo/emissivity values to expect? - nvalue = maxval(i_intervals(1:ninterval)) - - if (do_nearest) then - ! Simpler nearest-neighbour mapping from band to - ! albedo/emissivity interval - if (allocated(i_mapping)) then - deallocate(i_mapping) - end if - allocate(i_mapping(nband)) - - ! Loop over bands - do jband = 1,nband - ! Compute mid-point of band in wavenumber space (cm-1) - wavenumber_mid = 0.5_jprb * (wavenumber1(jband) & - & + wavenumber2(jband)) - iinterval = 1 - ! Convert wavelength (m) into wavenumber (cm-1) at the lower - ! bound of the albedo interval - wavenumber_bound = 0.01_jprb / wavelength_bound(iinterval) - ! Find the albedo interval that has the largest overlap with - ! the band; this approach assumes that the albedo intervals - ! are larger than the spectral bands - do while (wavenumber_bound >= wavenumber_mid & - & .and. iinterval < ninterval) - iinterval = iinterval + 1 - if (iinterval < ninterval) then - wavenumber_bound = 0.01_jprb / wavelength_bound(iinterval) - else - ! For the last interval there is no lower bound - wavenumber_bound = 0.0_jprb - end if - end do - ! Save the index of the band corresponding to the albedo - ! interval and move onto the next band - i_mapping(jband) = i_intervals(iinterval) - end do - else - ! More accurate weighting - if (allocated(weights)) then - deallocate(weights) - end if - allocate(weights(nvalue,nband)) - weights(:,:) = 0.0_jprb - - ! Loop over bands - do jband = 1,nband - recip_dwavenumber = 1.0_jprb / (wavenumber2(jband) & - & - wavenumber1(jband)) - ! Find the first overlapping albedo band - iinterval = 1 - ! Convert wavelength (m) into wavenumber (cm-1) at the lower - ! bound (in wavenumber space) of the albedo/emissivty interval - wavenumber1_albedo = 0.01_jprb / wavelength_bound(iinterval) - do while (wavenumber1_albedo >= wavenumber2(jband) & - & .and. iinterval < ninterval) - iinterval = iinterval + 1 - wavenumber1_albedo = 0.01_jprb / wavelength_bound(iinterval) - end do - - wavenumber2_albedo = wavenumber2(jband) - - ! Add all overlapping bands - do while (wavenumber2_albedo > wavenumber1(jband) & - & .and. iinterval <= ninterval) - weights(i_intervals(iinterval),jband) & - & = weights(i_intervals(iinterval),jband) & - & + recip_dwavenumber & - & * (min(wavenumber2_albedo,wavenumber2(jband)) & - & - max(wavenumber1_albedo,wavenumber1(jband))) - wavenumber2_albedo = wavenumber1_albedo - iinterval = iinterval + 1 - if (iinterval < ninterval) then - wavenumber1_albedo = 0.01_jprb / wavelength_bound(iinterval) - else - wavenumber1_albedo = 0.0_jprb - end if - end do - end do - end if - end if - - ! Define how many bands to use for reporting surface downwelling - ! fluxes for canopy radiation scheme - if (is_sw) then + this%i_sw_albedo_index(1) = 1 + this%i_sw_albedo_index(2:) = 0 if (this%use_canopy_full_spectrum_sw) then this%n_canopy_bands_sw = this%n_g_sw else - this%n_canopy_bands_sw = nvalue + this%n_canopy_bands_sw = 1 + end if + else + if (this%use_canopy_full_spectrum_sw) then + this%n_canopy_bands_sw = this%n_g_sw + else + this%n_canopy_bands_sw = maxval(this%i_sw_albedo_index(1:ninterval)) + end if + end if + + if (this%do_weighted_surface_mapping) then + call this%gas_optics_sw%spectral_def%calc_mapping_from_bands(SolarReferenceTemperature, & + & this%sw_albedo_wavelength_bound(1:ninterval-1), this%i_sw_albedo_index(1:ninterval), & + & this%sw_albedo_weights, use_bands=(.not. this%do_cloud_aerosol_per_sw_g_point)) + else + ! Weight each wavenumber equally as in IFS Cycles 48 and earlier + call this%gas_optics_sw%spectral_def%calc_mapping_from_bands(-1.0_jprb, & + & this%sw_albedo_wavelength_bound(1:ninterval-1), this%i_sw_albedo_index(1:ninterval), & + & this%sw_albedo_weights, use_bands=(.not. this%do_cloud_aerosol_per_sw_g_point)) + end if + + ! Legacy method uses input band with largest weight + if (this%do_nearest_spectral_sw_albedo) then + allocate(this%i_albedo_from_band_sw(this%n_bands_sw)) + this%i_albedo_from_band_sw = maxloc(this%sw_albedo_weights, dim=1) + end if + + if (this%iverbosesetup >= 2) then + write(nulout, '(a)') 'Surface shortwave albedo' + if (.not. this%do_nearest_spectral_sw_albedo) then + call this%gas_optics_sw%spectral_def%print_mapping_from_bands(this%sw_albedo_weights, & + & use_bands=(.not. this%do_cloud_aerosol_per_sw_g_point)) + else if (ninterval <= 1) then + write(nulout, '(a)') 'All shortwave bands will use the same albedo' + else + write(nulout, '(a,i0,a)',advance='no') 'Mapping from ', size(this%i_albedo_from_band_sw), & + & ' shortwave intervals to albedo intervals:' + do jband = 1,size(this%i_albedo_from_band_sw) + write(nulout,'(a,i0)',advance='no') ' ', this%i_albedo_from_band_sw(jband) + end do + write(nulout, '()') + end if + end if + + end subroutine consolidate_sw_albedo_intervals + + + !--------------------------------------------------------------------- + ! Consolidate the surface longwave emissivity intervals with the + ! band/g-point intervals + subroutine consolidate_lw_emiss_intervals(this) + + use radiation_io, only : nulout + use radiation_spectral_definition, only : TerrestrialReferenceTemperature + + class(config_type), intent(inout) :: this + + integer :: ninterval, jint, jband + + ! Count the number of albedo/emissivity intervals + ninterval = 0 + do jint = 1,NMaxAlbedoIntervals + if (this%i_lw_emiss_index(jint) > 0) then + ninterval = jint + else + exit + end if + end do + + if (ninterval < 1) then + ! The user has not specified longwave emissivity bands - assume + ! only one + ninterval = 1 + this%i_lw_emiss_index(1) = 1 + this%i_lw_emiss_index(2:) = 0 + if (this%use_canopy_full_spectrum_sw) then + this%n_canopy_bands_lw = this%n_g_lw + else + this%n_canopy_bands_lw = 1 end if else @@ -1721,41 +1823,37 @@ this%n_canopy_bands_lw = this%n_g_lw else - this%n_canopy_bands_lw = nvalue - end if + this%n_canopy_bands_lw = maxval(this%i_lw_emiss_index(1:ninterval)) + end if + end if + + if (this%do_weighted_surface_mapping) then + call this%gas_optics_lw%spectral_def%calc_mapping_from_bands(TerrestrialReferenceTemperature, & + & this%lw_emiss_wavelength_bound(1:ninterval-1), this%i_lw_emiss_index(1:ninterval), & + & this%lw_emiss_weights, use_bands=(.not. this%do_cloud_aerosol_per_lw_g_point)) + else + ! Weight each wavenumber equally as in IFS Cycles 48 and earlier + call this%gas_optics_lw%spectral_def%calc_mapping_from_bands(-1.0_jprb, & + & this%lw_emiss_wavelength_bound(1:ninterval-1), this%i_lw_emiss_index(1:ninterval), & + & this%lw_emiss_weights, use_bands=(.not. this%do_cloud_aerosol_per_lw_g_point)) + end if + + ! Legacy method uses input band with largest weight + if (this%do_nearest_spectral_lw_emiss) then + allocate(this%i_emiss_from_band_lw(this%n_bands_lw)) + this%i_emiss_from_band_lw = maxloc(this%lw_emiss_weights, dim=1) end if if (this%iverbosesetup >= 2) then - if (.not. do_nearest) then - if (is_sw) then - write(nulout, '(a,i0,a,i0,a)') 'Weighting of ', nvalue, ' albedo values in ', & - & nband, ' shortwave bands (wavenumber ranges in cm-1):' - else - write(nulout, '(a,i0,a,i0,a)') 'Weighting of ', nvalue, ' emissivity values in ', & - & nband, ' longwave bands (wavenumber ranges in cm-1):' - end if - do jband = 1,nband - write(nulout,'(i6,a,i6,a)',advance='no') nint(wavenumber1(jband)), ' to', & - & nint(wavenumber2(jband)), ':' - do iinterval = 1,nvalue - write(nulout,'(f5.2)',advance='no') weights(iinterval,jband) - end do - write(nulout, '()') - end do + write(nulout, '(a)') 'Surface longwave emissivity' + if (.not. this%do_nearest_spectral_lw_emiss) then + call this%gas_optics_lw%spectral_def%print_mapping_from_bands(this%lw_emiss_weights, & + & use_bands=(.not. this%do_cloud_aerosol_per_lw_g_point)) else if (ninterval <= 1) then - if (is_sw) then - write(nulout, '(a)') 'All shortwave bands will use the same albedo' - else - write(nulout, '(a)') 'All longwave bands will use the same emissivty' - end if + write(nulout, '(a)') 'All longwave bands will use the same emissivty' else - if (is_sw) then - write(nulout, '(a,i0,a)',advance='no') 'Mapping from ', nband, & - & ' shortwave bands to albedo intervals:' - else - write(nulout, '(a,i0,a)',advance='no') 'Mapping from ', nband, & - & ' longwave bands to emissivity intervals:' - end if - do jband = 1,nband - write(nulout,'(a,i0)',advance='no') ' ', i_mapping(jband) + write(nulout, '(a,i0,a)',advance='no') 'Mapping from ', size(this%i_emiss_from_band_lw), & + & ' longwave intervals to emissivity intervals:' + do jband = 1,size(this%i_emiss_from_band_lw) + write(nulout,'(a,i0)',advance='no') ' ', this%i_emiss_from_band_lw(jband) end do write(nulout, '()') @@ -1763,5 +1861,5 @@ end if - end subroutine consolidate_intervals + end subroutine consolidate_lw_emiss_intervals @@ -1866,191 +1964,3 @@ end subroutine print_enum - - !--------------------------------------------------------------------- - ! Return .true. if 1D allocatable array "var" is out of physical - ! range specified by boundmin and boundmax, and issue a warning. - ! "do_fix" determines whether erroneous values are fixed to lie - ! within the physical range. To check only a subset of the array, - ! specify i1 and i2 for the range. - function out_of_bounds_1d(var, var_name, boundmin, boundmax, do_fix, i1, i2) result (is_bad) - - use radiation_io, only : nulout - - real(jprb), allocatable, intent(inout) :: var(:) - character(len=*), intent(in) :: var_name - real(jprb), intent(in) :: boundmin, boundmax - logical, intent(in) :: do_fix - integer, optional, intent(in) :: i1, i2 - - logical :: is_bad - - real(jprb) :: varmin, varmax - - is_bad = .false. - - if (allocated(var)) then - - if (present(i1) .and. present(i2)) then - varmin = minval(var(i1:i2)) - varmax = maxval(var(i1:i2)) - else - varmin = minval(var) - varmax = maxval(var) - end if - - if (varmin < boundmin .or. varmax > boundmax) then - write(nulout,'(a,a,a,g12.4,a,g12.4,a,g12.4,a,g12.4)',advance='no') & - & '*** Warning: ', var_name, ' range', varmin, ' to', varmax, & - & ' is out of physical range', boundmin, 'to', boundmax - is_bad = .true. - if (do_fix) then - if (present(i1) .and. present(i2)) then - var(i1:i2) = max(boundmin, min(boundmax, var(i1:i2))) - else - var = max(boundmin, min(boundmax, var)) - end if - write(nulout,'(a)') ': corrected' - else - write(nulout,'(1x)') - end if - end if - - end if - - end function out_of_bounds_1d - - - !--------------------------------------------------------------------- - ! Return .true. if 2D allocatable array "var" is out of physical - ! range specified by boundmin and boundmax, and issue a warning. To - ! check only a subset of the array, specify i1 and i2 for the range - ! of the first dimension and j1 and j2 for the range of the second. - function out_of_bounds_2d(var, var_name, boundmin, boundmax, do_fix, & - & i1, i2, j1, j2) result (is_bad) - - use radiation_io, only : nulout - - real(jprb), allocatable, intent(inout) :: var(:,:) - character(len=*), intent(in) :: var_name - real(jprb), intent(in) :: boundmin, boundmax - logical, intent(in) :: do_fix - integer, optional, intent(in) :: i1, i2, j1, j2 - - ! Local copies of indices - integer :: ii1, ii2, jj1, jj2 - - logical :: is_bad - - real(jprb) :: varmin, varmax - - is_bad = .false. - - if (allocated(var)) then - - if (present(i1) .and. present(i2)) then - ii1 = i1 - ii2 = i2 - else - ii1 = lbound(var,1) - ii2 = ubound(var,1) - end if - if (present(j1) .and. present(j2)) then - jj1 = j1 - jj2 = j2 - else - jj1 = lbound(var,2) - jj2 = ubound(var,2) - end if - varmin = minval(var(ii1:ii2,jj1:jj2)) - varmax = maxval(var(ii1:ii2,jj1:jj2)) - - if (varmin < boundmin .or. varmax > boundmax) then - write(nulout,'(a,a,a,g12.4,a,g12.4,a,g12.4,a,g12.4)',advance='no') & - & '*** Warning: ', var_name, ' range', varmin, ' to', varmax,& - & ' is out of physical range', boundmin, 'to', boundmax - is_bad = .true. - if (do_fix) then - var(ii1:ii2,jj1:jj2) = max(boundmin, min(boundmax, var(ii1:ii2,jj1:jj2))) - write(nulout,'(a)') ': corrected' - else - write(nulout,'(1x)') - end if - end if - - end if - - end function out_of_bounds_2d - - - !--------------------------------------------------------------------- - ! Return .true. if 3D allocatable array "var" is out of physical - ! range specified by boundmin and boundmax, and issue a warning. To - ! check only a subset of the array, specify i1 and i2 for the range - ! of the first dimension, j1 and j2 for the second and k1 and k2 for - ! the third. - function out_of_bounds_3d(var, var_name, boundmin, boundmax, do_fix, & - & i1, i2, j1, j2, k1, k2) result (is_bad) - - use radiation_io, only : nulout - - real(jprb), allocatable, intent(inout) :: var(:,:,:) - character(len=*), intent(in) :: var_name - real(jprb), intent(in) :: boundmin, boundmax - logical, intent(in) :: do_fix - integer, optional, intent(in) :: i1, i2, j1, j2, k1, k2 - - ! Local copies of indices - integer :: ii1, ii2, jj1, jj2, kk1, kk2 - - logical :: is_bad - - real(jprb) :: varmin, varmax - - is_bad = .false. - - if (allocated(var)) then - - if (present(i1) .and. present(i2)) then - ii1 = i1 - ii2 = i2 - else - ii1 = lbound(var,1) - ii2 = ubound(var,1) - end if - if (present(j1) .and. present(j2)) then - jj1 = j1 - jj2 = j2 - else - jj1 = lbound(var,2) - jj2 = ubound(var,2) - end if - if (present(k1) .and. present(k2)) then - kk1 = k1 - kk2 = k2 - else - kk1 = lbound(var,3) - kk2 = ubound(var,3) - end if - varmin = minval(var(ii1:ii2,jj1:jj2,kk1:kk2)) - varmax = maxval(var(ii1:ii2,jj1:jj2,kk1:kk2)) - - if (varmin < boundmin .or. varmax > boundmax) then - write(nulout,'(a,a,a,g12.4,a,g12.4,a,g12.4,a,g12.4)',advance='no') & - & '*** Warning: ', var_name, ' range', varmin, ' to', varmax,& - & ' is out of physical range', boundmin, 'to', boundmax - is_bad = .true. - if (do_fix) then - var(ii1:ii2,jj1:jj2,kk1:kk2) = max(boundmin, min(boundmax, & - & var(ii1:ii2,jj1:jj2,kk1:kk2))) - write(nulout,'(a)') ': corrected' - else - write(nulout,'(1x)') - end if - end if - - end if - - end function out_of_bounds_3d - - end module radiation_config Index: LMDZ6/trunk/libf/phylmd/ecrad/radiation_delta_eddington.h =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad/radiation_delta_eddington.h (revision 4487) +++ LMDZ6/trunk/libf/phylmd/ecrad/radiation_delta_eddington.h (revision 4489) @@ -1,3 +1,3 @@ -! radiation_delta_eddington.h - Delta-Eddington scaling +! radiation_delta_eddington.h - Delta-Eddington scaling -*- f90 -*- ! ! (C) Copyright 2015- ECMWF. @@ -92,2 +92,24 @@ end subroutine delta_eddington_scat_od + +!--------------------------------------------------------------------- +! Revert delta-Eddington-scaled quantities in-place, back to their +! original state +elemental subroutine revert_delta_eddington(od, ssa, g) + + use parkind1, only : jprb + + ! Total optical depth, single scattering albedo and asymmetry + ! factor + real(jprb), intent(inout) :: od, ssa, g + + ! Fraction of the phase function deemed to be in the forward lobe + ! and therefore treated as if it is not scattered at all + real(jprb) :: f + + g = g / (1.0_jprb - g) + f = g*g + ssa = ssa / (1.0_jprb - f + f*ssa); + od = od / (1.0_jprb - ssa*f) + +end subroutine revert_delta_eddington Index: LMDZ6/trunk/libf/phylmd/ecrad/radiation_ecckd.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad/radiation_ecckd.F90 (revision 4489) +++ LMDZ6/trunk/libf/phylmd/ecrad/radiation_ecckd.F90 (revision 4489) @@ -0,0 +1,507 @@ +! radiation_ecckd.F90 - ecCKD generalized gas optics model +! +! (C) Copyright 2020- 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. +! +! Author: Robin Hogan +! Email: r.j.hogan@ecmwf.int +! License: see the COPYING file for details +! + +module radiation_ecckd + + use parkind1, only : jprb + use radiation_gas_constants + use radiation_ecckd_gas + use radiation_spectral_definition, only : spectral_definition_type + + implicit none + + public + + !--------------------------------------------------------------------- + ! This derived type contains all the data needed to describe a + ! correlated k-distribution gas optics model created using the ecCKD + ! tool + type ckd_model_type + + ! Gas information + + ! Number of gases + integer :: ngas = 0 + ! Array of individual-gas data objects + type(ckd_gas_type), allocatable :: single_gas(:) + ! Mapping from the "gas codes" in the radiation_gas_constants + ! module to an index to the single_gas array, where zero means gas + ! not present (or part of a composite gas) + integer :: i_gas_mapping(0:NMaxGases) + + ! Coordinates of main look-up table for absorption coeffts + + ! Number of pressure and temperature points + integer :: npress = 0 + integer :: ntemp = 0 + ! Natural logarithm of first (lowest) pressure (Pa) and increment + real(jprb) :: log_pressure1, d_log_pressure + ! First temperature profile (K), dimensioned (npress) + real(jprb), allocatable :: temperature1(:) + ! Temperature increment (K) + real(jprb) :: d_temperature + + ! Look-up table for Planck function + + ! Number of entries + integer :: nplanck = 0 + ! Temperature of first element of look-up table and increment (K) + real(jprb), allocatable :: temperature1_planck + real(jprb), allocatable :: d_temperature_planck + ! Planck function (black body flux into a horizontal plane) in W + ! m-2, dimensioned (ng,nplanck) + real(jprb), allocatable :: planck_function(:,:) + + ! Normalized solar irradiance in each g point dimensioned (ng) + real(jprb), allocatable :: norm_solar_irradiance(:) + + ! Rayleigh molar scattering coefficient in m2 mol-1 in each g + ! point + real(jprb), allocatable :: rayleigh_molar_scat(:) + + ! ! Spectral mapping of g points + + ! ! Number of wavenumber intervals + ! integer :: nwav = 0 + + ! Number of k terms / g points + integer :: ng = 0 + + ! Spectral definition describing bands and g points + type(spectral_definition_type) :: spectral_def + + ! Shortwave: true, longwave: false + logical :: is_sw + + contains + + procedure :: read => read_ckd_model + procedure :: calc_optical_depth => calc_optical_depth_ckd_model + procedure :: print => print_ckd_model + procedure :: calc_planck_function + procedure :: calc_incoming_sw +! procedure :: deallocate => deallocate_ckd_model + + end type ckd_model_type + + +contains + + !--------------------------------------------------------------------- + ! Read a complete ecCKD gas optics model from a NetCDF file + ! "filename" + subroutine read_ckd_model(this, filename, iverbose) + + use easy_netcdf, only : netcdf_file + !use radiation_io, only : nulerr, radiation_abort + use yomhook, only : lhook, dr_hook + + class(ckd_model_type), intent(inout) :: this + character(len=*), intent(in) :: filename + integer, optional, intent(in) :: iverbose + + type(netcdf_file) :: file + + real(jprb), allocatable :: pressure_lut(:) + real(jprb), allocatable :: temperature_full(:,:) + real(jprb), allocatable :: temperature_planck(:) + + character(len=512) :: constituent_id + + integer :: iverbose_local + + ! Loop counters + integer :: jgas, jjgas + + integer :: istart, inext, nchar, i_gas_code + + real(jprb) :: hook_handle + + if (lhook) call dr_hook('radiation_ecckd:read_ckd_model',0,hook_handle) + + if (present(iverbose)) then + iverbose_local = iverbose + else + iverbose_local = 3 + end if + + call file%open(trim(filename), iverbose=iverbose_local) + + ! Read temperature and pressure coordinate variables + call file%get('pressure', pressure_lut) + this%log_pressure1 = log(pressure_lut(1)) + this%npress = size(pressure_lut) + this%d_log_pressure = log(pressure_lut(2)) - this%log_pressure1 + call file%get('temperature', temperature_full) + allocate(this%temperature1(this%npress)); + this%temperature1 = temperature_full(:,1) + this%d_temperature = temperature_full(1,2)-temperature_full(1,1) + this%ntemp = size(temperature_full,2) + deallocate(temperature_full) + + ! Read Planck function, or solar irradiance and Rayleigh + ! scattering coefficient + if (file%exists('solar_irradiance')) then + this%is_sw = .true. + call file%get('solar_irradiance', this%norm_solar_irradiance) + this%norm_solar_irradiance = this%norm_solar_irradiance & + & / sum(this%norm_solar_irradiance) + call file%get('rayleigh_molar_scattering_coeff', & + & this%rayleigh_molar_scat) + else + this%is_sw = .false. + call file%get('temperature_planck', temperature_planck) + this%nplanck = size(temperature_planck) + this%temperature1_planck = temperature_planck(1) + this%d_temperature_planck = temperature_planck(2) - temperature_planck(1) + deallocate(temperature_planck) + call file%get('planck_function', this%planck_function) + end if + + ! Read the spectral definition information into a separate + ! derived type + call this%spectral_def%read(file); + this%ng = this%spectral_def%ng + + ! Read gases + call file%get('n_gases', this%ngas) + allocate(this%single_gas(this%ngas)) + call file%get_global_attribute('constituent_id', constituent_id) + nchar = len(trim(constituent_id)) + istart = 1 + this%i_gas_mapping = 0 + do jgas = 1, this%ngas + if (jgas < this%ngas) then + inext = istart + scan(constituent_id(istart:nchar), ' ') + else + inext = nchar+2 + end if + ! Find gas code + i_gas_code = 0 + do jjgas = 1, NMaxGases + if (constituent_id(istart:inext-2) == trim(GasLowerCaseName(jjgas))) then + i_gas_code = jjgas + exit + end if + end do + ! if (i_gas_code == 0) then + ! write(nulerr,'(a,a,a)') '*** Error: Gas "', constituent_id(istart:inext-2), & + ! & '" not understood' + ! call radiation_abort('Radiation configuration error') + ! end if + this%i_gas_mapping(i_gas_code) = jgas; + call this%single_gas(jgas)%read(file, constituent_id(istart:inext-2), i_gas_code) + istart = inext + end do + + if (lhook) call dr_hook('radiation_ecckd:read_ckd_model',1,hook_handle) + + end subroutine read_ckd_model + + !--------------------------------------------------------------------- + ! Print a description of the correlated k-distribution model to the + ! "nulout" unit + subroutine print_ckd_model(this) + + use radiation_io, only : nulout + use radiation_gas_constants + + class(ckd_model_type), intent(in) :: this + + integer :: jgas + + if (this%is_sw) then + write(nulout,'(a)',advance='no') 'ecCKD shortwave gas optics model: ' + else + write(nulout,'(a)',advance='no') 'ecCKD longwave gas optics model: ' + end if + + write(nulout,'(i0,a,i0,a,i0,a,i0,a)') & + & nint(this%spectral_def%wavenumber1(1)), '-', & + & nint(this%spectral_def%wavenumber2(size(this%spectral_def%wavenumber2))), & + & ' cm-1, ', this%ng, ' g-points in ', this%spectral_def%nband, ' bands' + write(nulout,'(a,i0,a,i0,a,i0,a)') ' Look-up table sizes: ', this%npress, ' pressures, ', & + & this%ntemp, ' temperatures, ', this%nplanck, ' planck-function entries' + write(nulout, '(a)') ' Gases:' + do jgas = 1,this%ngas + if (this%single_gas(jgas)%i_gas_code > 0) then + write(nulout, '(a,a,a)', advance='no') ' ', & + & trim(GasName(this%single_gas(jgas)%i_gas_code)), ': ' + else + write(nulout, '(a)', advance='no') ' Composite of well-mixed background gases: ' + end if + select case (this%single_gas(jgas)%i_conc_dependence) + case (IConcDependenceNone) + write(nulout, '(a)') 'no concentration dependence' + case (IConcDependenceLinear) + write(nulout, '(a)') 'linear concentration dependence' + case (IConcDependenceRelativeLinear) + write(nulout, '(a,e14.6)') 'linear concentration dependence relative to a mole fraction of ', & + & this%single_gas(jgas)%reference_mole_frac + case (IConcDependenceLUT) + write(nulout, '(a,i0,a,e14.6,a,e13.6)') 'look-up table with ', this%single_gas(jgas)%n_mole_frac, & + & ' log-spaced mole fractions in range ', exp(this%single_gas(jgas)%log_mole_frac1), & + & ' to ', exp(this%single_gas(jgas)%log_mole_frac1 & + & + this%single_gas(jgas)%n_mole_frac*this%single_gas(jgas)%d_log_mole_frac) + end select + end do + + end subroutine print_ckd_model + + + !--------------------------------------------------------------------- + ! Compute layerwise optical depth for each g point for ncol columns + ! at nlev layers + subroutine calc_optical_depth_ckd_model(this, ncol, nlev, istartcol, iendcol, nmaxgas, & + & pressure_hl, temperature_fl, mole_fraction_fl, & + & optical_depth_fl, rayleigh_od_fl) + + use yomhook, only : lhook, dr_hook + use radiation_constants, only : AccelDueToGravity + + ! Input variables + + class(ckd_model_type), intent(in), target :: this + ! Number of columns, levels and input gases + integer, intent(in) :: ncol, nlev, nmaxgas, istartcol, iendcol + ! Pressure at half levels (Pa), dimensioned (ncol,nlev+1) + real(jprb), intent(in) :: pressure_hl(ncol,nlev+1) + ! Temperature at full levels (K), dimensioned (ncol,nlev) + real(jprb), intent(in) :: temperature_fl(istartcol:iendcol,nlev) + ! Gas mole fractions at full levels (mol mol-1), dimensioned (ncol,nlev,nmaxgas) + real(jprb), intent(in) :: mole_fraction_fl(ncol,nlev,nmaxgas) + + ! Output variables + + ! Layer absorption optical depth for each g point + real(jprb), intent(out) :: optical_depth_fl(this%ng,nlev,istartcol:iendcol) + ! In the shortwave only, the Rayleigh scattering optical depth + real(jprb), optional, intent(out) :: rayleigh_od_fl(this%ng,nlev,istartcol:iendcol) + + ! Local variables + + real(jprb), pointer :: molar_abs(:,:,:), molar_abs_conc(:,:,:,:) + + ! Natural logarithm of pressure at full levels + real(jprb) :: log_pressure_fl(nlev) + + ! Optical depth of single gas at one point in space versus + ! spectral interval + !real(jprb) :: od_single_gas(this%ng) + + real(jprb) :: multiplier(nlev), simple_multiplier(nlev), global_multiplier, temperature1 + + ! Indices and weights in temperature, pressure and concentration interpolation + real(jprb) :: pindex1, tindex1, cindex1 + real(jprb) :: pw1(nlev), pw2(nlev), tw1(nlev), tw2(nlev), cw1(nlev), cw2(nlev) + integer :: ip1(nlev), it1(nlev), ic1(nlev) + + ! Natural logarithm of mole fraction at one point + real(jprb) :: log_conc + + ! Minimum mole fraction in look-up-table + real(jprb) :: mole_frac1 + + integer :: jcol, jlev, jgas, igascode + + real(jprb) :: hook_handle + + if (lhook) call dr_hook('radiation_ecckd:calc_optical_depth',0,hook_handle) + + global_multiplier = 1.0_jprb / (AccelDueToGravity * 0.001_jprb * AirMolarMass) + + do jcol = istartcol,iendcol + + log_pressure_fl = log(0.5_jprb * (pressure_hl(jcol,1:nlev)+pressure_hl(jcol,2:nlev+1))) + + do jlev = 1,nlev + ! Find interpolation points in pressure + pindex1 = (log_pressure_fl(jlev)-this%log_pressure1) & + & / this%d_log_pressure + pindex1 = 1.0_jprb + max(0.0_jprb, min(pindex1, this%npress-1.0001_jprb)) + ip1(jlev) = int(pindex1) + pw2(jlev) = pindex1 - ip1(jlev) + pw1(jlev) = 1.0_jprb - pw2(jlev) + + ! Find interpolation points in temperature + temperature1 = pw1(jlev)*this%temperature1(ip1(jlev)) & + & + pw2(jlev)*this%temperature1(ip1(jlev)+1) + tindex1 = (temperature_fl(jcol,jlev) - temperature1) & + & / this%d_temperature + tindex1 = 1.0_jprb + max(0.0_jprb, min(tindex1, this%ntemp-1.0001_jprb)) + it1(jlev) = int(tindex1) + tw2(jlev) = tindex1 - it1(jlev) + tw1(jlev) = 1.0_jprb - tw2(jlev) + + ! Concentration multiplier + simple_multiplier(jlev) = global_multiplier & + & * (pressure_hl(jcol,jlev+1) - pressure_hl(jcol,jlev)) + end do + + optical_depth_fl(:,:,jcol) = 0.0_jprb + + do jgas = 1,this%ngas + + associate (single_gas => this%single_gas(jgas)) + igascode = this%single_gas(jgas)%i_gas_code + + select case (single_gas%i_conc_dependence) + + case (IConcDependenceLinear) + molar_abs => this%single_gas(jgas)%molar_abs + multiplier = simple_multiplier * mole_fraction_fl(jcol,:,igascode) + + do jlev = 1,nlev + optical_depth_fl(:,jlev,jcol) = optical_depth_fl(:,jlev,jcol) & + & + (multiplier(jlev)*tw1(jlev)) * (pw1(jlev) * molar_abs(:,ip1(jlev),it1(jlev)) & + & +pw2(jlev) * molar_abs(:,ip1(jlev)+1,it1(jlev))) & + & + (multiplier(jlev)*tw2(jlev)) * (pw1(jlev) * molar_abs(:,ip1(jlev),it1(jlev)+1) & + & +pw2(jlev) * molar_abs(:,ip1(jlev)+1,it1(jlev)+1)) + end do + + case (IConcDependenceRelativeLinear) + molar_abs => this%single_gas(jgas)%molar_abs + multiplier = simple_multiplier * (mole_fraction_fl(jcol,:,igascode) & + & - single_gas%reference_mole_frac) + do jlev = 1,nlev + optical_depth_fl(:,jlev,jcol) = optical_depth_fl(:,jlev,jcol) & + & + (multiplier(jlev)*tw1(jlev)) * (pw1(jlev) * molar_abs(:,ip1(jlev),it1(jlev)) & + & +pw2(jlev) * molar_abs(:,ip1(jlev)+1,it1(jlev))) & + & + (multiplier(jlev)*tw2(jlev)) * (pw1(jlev) * molar_abs(:,ip1(jlev),it1(jlev)+1) & + & +pw2(jlev) * molar_abs(:,ip1(jlev)+1,it1(jlev)+1)) + end do + + case (IConcDependenceNone) + ! Composite gases + molar_abs => this%single_gas(jgas)%molar_abs + do jlev = 1,nlev + optical_depth_fl(:,jlev,jcol) = optical_depth_fl(:,jlev,jcol) & + & + (simple_multiplier(jlev)*tw1(jlev)) * (pw1(jlev) * molar_abs(:,ip1(jlev),it1(jlev)) & + & +pw2(jlev) * molar_abs(:,ip1(jlev)+1,it1(jlev))) & + & + (simple_multiplier(jlev)*tw2(jlev)) * (pw1(jlev) * molar_abs(:,ip1(jlev),it1(jlev)+1) & + & +pw2(jlev) * molar_abs(:,ip1(jlev)+1,it1(jlev)+1)) + end do + + case (IConcDependenceLUT) + ! Logarithmic interpolation in concentration space + molar_abs_conc => this%single_gas(jgas)%molar_abs_conc + mole_frac1 = exp(single_gas%log_mole_frac1) + do jlev = 1,nlev + ! Take care of mole_fraction == 0 + log_conc = log(max(mole_fraction_fl(jcol,jlev,igascode), mole_frac1)) + cindex1 = (log_conc - single_gas%log_mole_frac1) / single_gas%d_log_mole_frac + cindex1 = 1.0_jprb + max(0.0_jprb, min(cindex1, single_gas%n_mole_frac-1.0001_jprb)) + ic1(jlev) = int(cindex1) + cw2(jlev) = cindex1 - ic1(jlev) + cw1(jlev) = 1.0_jprb - cw2(jlev) + end do + ! od_single_gas = cw1 * (tw1 * (pw1 * molar_abs_conc(:,ip1,it1,ic1) & + ! & +pw2 * molar_abs_conc(:,ip1+1,it1,ic1)) & + ! & +tw2 * (pw1 * molar_abs_conc(:,ip1,it1+1,ic1) & + ! & +pw2 * molar_abs_conc(:,ip1+1,it1+1,ic1))) & + ! & +cw2 * (tw1 * (pw1 * molar_abs_conc(:,ip1,it1,ic1+1) & + ! & +pw2 * molar_abs_conc(:,ip1+1,it1,ic1+1)) & + ! & +tw2 * (pw1 * molar_abs_conc(:,ip1,it1+1,ic1+1) & + ! & +pw2 * molar_abs_conc(:,ip1+1,it1+1,ic1+1))) + do jlev = 1,nlev + optical_depth_fl(:,jlev,jcol) = optical_depth_fl(:,jlev,jcol) & + & + (simple_multiplier(jlev) * mole_fraction_fl(jcol,jlev,igascode)) * ( & + & (cw1(jlev) * tw1(jlev) * pw1(jlev)) * molar_abs_conc(:,ip1(jlev),it1(jlev),ic1(jlev)) & + & +(cw1(jlev) * tw1(jlev) * pw2(jlev)) * molar_abs_conc(:,ip1(jlev)+1,it1(jlev),ic1(jlev)) & + & +(cw1(jlev) * tw2(jlev) * pw1(jlev)) * molar_abs_conc(:,ip1(jlev),it1(jlev)+1,ic1(jlev)) & + & +(cw1(jlev) * tw2(jlev) * pw2(jlev)) * molar_abs_conc(:,ip1(jlev)+1,it1(jlev)+1,ic1(jlev)) & + & +(cw2(jlev) * tw1(jlev) * pw1(jlev)) * molar_abs_conc(:,ip1(jlev),it1(jlev),ic1(jlev)+1) & + & +(cw2(jlev) * tw1(jlev) * pw2(jlev)) * molar_abs_conc(:,ip1(jlev)+1,it1(jlev),ic1(jlev)+1) & + & +(cw2(jlev) * tw2(jlev) * pw1(jlev)) * molar_abs_conc(:,ip1(jlev),it1(jlev)+1,ic1(jlev)+1) & + & +(cw2(jlev) * tw2(jlev) * pw2(jlev)) * molar_abs_conc(:,ip1(jlev)+1,it1(jlev)+1,ic1(jlev)+1)) + end do + end select + + end associate + + end do + + ! Ensure the optical depth is not negative + optical_depth_fl(:,:,jcol) = max(0.0_jprb, optical_depth_fl(:,:,jcol)) + + ! Rayleigh scattering + if (this%is_sw .and. present(rayleigh_od_fl)) then + do jlev = 1,nlev + rayleigh_od_fl(:,jlev,jcol) = global_multiplier & + & * (pressure_hl(jcol,jlev+1) - pressure_hl(jcol,jlev)) * this%rayleigh_molar_scat + end do + end if + + end do + + if (lhook) call dr_hook('radiation_ecckd:calc_optical_depth',1,hook_handle) + + end subroutine calc_optical_depth_ckd_model + + !--------------------------------------------------------------------- + ! Calculate the Planck function integrated across each of the g + ! points of this correlated k-distribution model, for a given + ! temperature, where Planck function is defined as the flux emitted + ! by a black body (rather than radiance) + subroutine calc_planck_function(this, nt, temperature, planck) + + class(ckd_model_type), intent(in) :: this + integer, intent(in) :: nt + real(jprb), intent(in) :: temperature(:) ! K + real(jprb), intent(out) :: planck(this%ng,nt) ! W m-2 + + real(jprb) :: tindex1, tw1, tw2 + integer :: it1, jt + + do jt = 1,nt + tindex1 = (temperature(jt) - this%temperature1_planck) & + & * (1.0_jprb / this%d_temperature_planck) + if (tindex1 >= 0) then + ! Normal interpolation, and extrapolation for high temperatures + tindex1 = 1.0_jprb + tindex1 + it1 = min(int(tindex1), this%nplanck-1) + tw2 = tindex1 - it1 + tw1 = 1.0_jprb - tw2 + planck(:,jt) = tw1 * this%planck_function(:,it1) & + & + tw2 * this%planck_function(:,it1+1) + else + ! Interpolate linearly to zero + planck(:,jt) = this%planck_function(:,1) & + & * (temperature(jt)/this%temperature1_planck) + end if + end do + + end subroutine calc_planck_function + + + !--------------------------------------------------------------------- + ! Return the spectral solar irradiance integrated over each g point + ! of a solar correlated k-distribution model, given the + ! total_solar_irradiance + subroutine calc_incoming_sw(this, total_solar_irradiance, & + & spectral_solar_irradiance) + + class(ckd_model_type), intent(in) :: this + real(jprb), intent(in) :: total_solar_irradiance ! W m-2 + real(jprb), intent(inout) :: spectral_solar_irradiance(:,:) ! W m-2 + + spectral_solar_irradiance & + & = spread(total_solar_irradiance * this%norm_solar_irradiance, & + & 2, size(spectral_solar_irradiance,2)) + + end subroutine calc_incoming_sw + +end module radiation_ecckd Index: LMDZ6/trunk/libf/phylmd/ecrad/radiation_ecckd_gas.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad/radiation_ecckd_gas.F90 (revision 4489) +++ LMDZ6/trunk/libf/phylmd/ecrad/radiation_ecckd_gas.F90 (revision 4489) @@ -0,0 +1,118 @@ +! radiation_ecckd_gas.F90 - type representing a single ecCKD gas +! +! (C) Copyright 2020- 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. +! +! Author: Robin Hogan +! Email: r.j.hogan@ecmwf.int +! License: see the COPYING file for details +! + +module radiation_ecckd_gas + + use parkind1, only : jprb + use radiation_gas_constants + + implicit none + + public + + ! Concentration dependence of individual gases + enum, bind(c) + enumerator :: IConcDependenceNone = 0, & + & IConcDependenceLinear, & + & IConcDependenceLUT, & + & IConcDependenceRelativeLinear + end enum + + !--------------------------------------------------------------------- + ! This derived type describes a correlated k-distribution + ! representation of an individual gas (including composite gases) + type ckd_gas_type + + ! Code identifying the gas, from the codes in the + ! radiation_gas_constants module + integer :: i_gas_code = -1 + + ! One of the IConcDependence* enumerators + integer :: i_conc_dependence + + ! Molar absorption coefficient in m2 mol-1. If + ! i_conc_dependence==IConcDependenceNone then it is the absorption + ! cross section per mole of dry air. If + ! conc_dependence==IConcDependenceLinear|IConcDependenceRelativeLinear, + ! it is the absorption cross section per mole of the gas in + ! question. It is dimensioned (g_point,pressure,temperature). + real(jprb), allocatable :: molar_abs(:,:,:) + + ! If i_conc_dependence==IConcDependenceLUT then we have an + ! additional dimension for concentration. It is dimensioned + ! (g_point,pressure,temperature,conc) + real(jprb), allocatable :: molar_abs_conc(:,:,:,:) + + ! If i_conc_dependence==IConcDependenceRelativeLinear then the + ! following reference concentration is subtracted from the actual + ! concentration before the result is multiplied by the mass + ! absorption coefficient + real(jprb) :: reference_mole_frac = 0.0_jprb + + ! Mole fraction coordinate variable if + ! i_conc_dependence==IConcDependenceLUT + real(jprb) :: log_mole_frac1 = 0.0_jprb, d_log_mole_frac = 1.0_jprb + integer :: n_mole_frac = 0 + + contains + + procedure :: read => read_ckd_gas +! procedure :: deallocate => deallocate_ckd_gas + + end type ckd_gas_type + +contains + + !--------------------------------------------------------------------- + ! Read information about the representation of a single gas from a + ! NetCDF file, identifying it with code i_gas_code + subroutine read_ckd_gas(this, file, gas_name, i_gas_code) + + use easy_netcdf, only : netcdf_file + + class(ckd_gas_type), intent(inout) :: this + type(netcdf_file), intent(inout) :: file + character(len=*), intent(in) :: gas_name + integer, intent(in) :: i_gas_code + + ! Local storage for mole fraction coordinate variable + real(jprb), allocatable :: mole_fraction(:) + + this%i_gas_code = i_gas_code + + call file%get(gas_name // "_conc_dependence_code", this%i_conc_dependence) + if (this%i_conc_dependence == IConcDependenceLut) then + call file%get(gas_name // "_molar_absorption_coeff", & + & this%molar_abs_conc) + call file%get(gas_name // "_mole_fraction", mole_fraction) + this%log_mole_frac1 = log(mole_fraction(1)) + this%n_mole_frac = size(mole_fraction) + this%d_log_mole_frac = (log(mole_fraction(size(mole_fraction))) & + & - this%log_mole_frac1) / (this%n_mole_frac-1) + deallocate(mole_fraction) + else + call file%get(gas_name // "_molar_absorption_coeff", & + & this%molar_abs) + end if + + if (this%i_conc_dependence == IConcDependenceRelativeLinear) then + call file%get(gas_name // "_reference_mole_fraction", & + & this%reference_mole_frac) + end if + + end subroutine read_ckd_gas + +end module radiation_ecckd_gas Index: LMDZ6/trunk/libf/phylmd/ecrad/radiation_ecckd_interface.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad/radiation_ecckd_interface.F90 (revision 4489) +++ LMDZ6/trunk/libf/phylmd/ecrad/radiation_ecckd_interface.F90 (revision 4489) @@ -0,0 +1,278 @@ +! radiation_ecckd_interface.F90 - Interface to ecCKD gas optics model +! +! (C) Copyright 2020- 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. +! +! Author: Robin Hogan +! Email: r.j.hogan@ecmwf.int +! License: see the COPYING file for details +! + +module radiation_ecckd_interface + + implicit none + + public :: setup_gas_optics, set_gas_units, gas_optics !, planck_function + +contains + + !--------------------------------------------------------------------- + ! Setup the ecCKD generalized gas optics model + subroutine setup_gas_optics(config) + + use parkind1, only : jprb + use radiation_config + + type(config_type), intent(inout), target :: config + + integer :: jj + + if (config%do_sw) then + + ! Read shortwave ecCKD gas optics NetCDF file + call config%gas_optics_sw%read(trim(config%gas_optics_sw_file_name), & + & config%iverbosesetup) + + ! Copy over relevant properties + config%n_g_sw = config%gas_optics_sw%ng + + if (config%do_cloud_aerosol_per_sw_g_point) then + ! Bands and g points are the same + config%n_bands_sw = config%n_g_sw + else + ! Bands are groups of g points and span a continuous region of + ! wavenumber space + config%n_bands_sw = config%gas_optics_sw%spectral_def%nband + end if + + allocate(config%i_band_from_g_sw (config%n_g_sw)) + allocate(config%i_band_from_reordered_g_sw(config%n_g_sw)) + allocate(config%i_g_from_reordered_g_sw (config%n_g_sw)) + + if (config%do_cloud_aerosol_per_sw_g_point) then + config%i_band_from_g_sw = [ (jj, jj = 1,config%n_g_sw) ] + config%i_band_from_reordered_g_sw = [ (jj, jj = 1,config%n_g_sw) ] + else + config%i_band_from_g_sw & + & = config%gas_optics_sw%spectral_def%i_band_number + config%i_band_from_reordered_g_sw & + & = config%gas_optics_sw%spectral_def%i_band_number + end if + config%i_g_from_reordered_g_sw = [ (jj, jj = 1,config%n_g_sw) ] + + if (config%iverbosesetup >= 2) then + call config%gas_optics_sw%print() + end if + + end if + + if (config%do_lw) then + + ! Read longwave ecCKD gas optics NetCDF file + call config%gas_optics_lw%read(trim(config%gas_optics_lw_file_name), & + & config%iverbosesetup) + + ! Copy over relevant properties + config%n_g_lw = config%gas_optics_lw%ng + + if (config%do_cloud_aerosol_per_lw_g_point) then + ! Bands and g points are the same + config%n_bands_lw = config%n_g_lw + else + ! Bands are groups of g points and span a continuous region of + ! wavenumber space + config%n_bands_lw = config%gas_optics_lw%spectral_def%nband + end if + + allocate(config%i_band_from_g_lw (config%n_g_lw)) + allocate(config%i_band_from_reordered_g_lw(config%n_g_lw)) + allocate(config%i_g_from_reordered_g_lw (config%n_g_lw)) + + if (config%do_cloud_aerosol_per_lw_g_point) then + config%i_band_from_g_lw = [ (jj, jj = 1,config%n_g_lw) ] + config%i_band_from_reordered_g_lw = [ (jj, jj = 1,config%n_g_lw) ] + else + config%i_band_from_g_lw & + & = config%gas_optics_lw%spectral_def%i_band_number + config%i_band_from_reordered_g_lw & + & = config%gas_optics_lw%spectral_def%i_band_number + end if + config%i_g_from_reordered_g_lw = [ (jj, jj = 1,config%n_g_lw) ] + + if (config%iverbosesetup >= 2) then + call config%gas_optics_lw%print() + end if + + end if + + ! The i_spec_* variables are used solely for storing spectral + ! data, and this can either be by band or by g-point + if (config%do_save_spectral_flux) then + if (config%do_save_gpoint_flux) then + config%n_spec_sw = config%n_g_sw + config%n_spec_lw = config%n_g_lw + config%i_spec_from_reordered_g_sw => config%i_g_from_reordered_g_sw + config%i_spec_from_reordered_g_lw => config%i_g_from_reordered_g_lw + else + config%n_spec_sw = config%n_bands_sw + config%n_spec_lw = config%n_bands_lw + config%i_spec_from_reordered_g_sw => config%i_band_from_reordered_g_sw + config%i_spec_from_reordered_g_lw => config%i_band_from_reordered_g_lw + end if + else + config%n_spec_sw = 0 + config%n_spec_lw = 0 + nullify(config%i_spec_from_reordered_g_sw) + nullify(config%i_spec_from_reordered_g_lw) + end if + + end subroutine setup_gas_optics + + + !--------------------------------------------------------------------- + ! Scale gas mixing ratios according to required units + subroutine set_gas_units(gas) + + use radiation_gas, only : gas_type, IVolumeMixingRatio + type(gas_type), intent(inout) :: gas + + call gas%set_units(IVolumeMixingRatio) + + end subroutine set_gas_units + + + !--------------------------------------------------------------------- + ! Compute gas optical depths, shortwave scattering, Planck function + ! and incoming shortwave radiation at top-of-atmosphere + subroutine gas_optics(ncol,nlev,istartcol,iendcol, & + & config, single_level, thermodynamics, gas, & + & od_lw, od_sw, ssa_sw, lw_albedo, planck_hl, lw_emission, & + & incoming_sw) + + use parkind1, only : jprb + use radiation_config, only : config_type + use radiation_thermodynamics, only : thermodynamics_type + use radiation_single_level, only : single_level_type + use radiation_gas_constants, only : NMaxGases + use radiation_gas + + integer, intent(in) :: ncol ! number of columns + integer, intent(in) :: nlev ! number of levels + integer, intent(in) :: istartcol, iendcol ! range of cols to process + type(config_type), intent(in) :: config + type(single_level_type), intent(in) :: single_level + type(thermodynamics_type),intent(in) :: thermodynamics + type(gas_type), intent(in) :: gas + + ! Longwave albedo of the surface + real(jprb), dimension(config%n_g_lw,istartcol:iendcol), & + & intent(in), optional :: lw_albedo + + ! Gaseous layer optical depth in longwave and shortwave, and + ! shortwave single scattering albedo (i.e. fraction of extinction + ! due to Rayleigh scattering) at each g-point + real(jprb), dimension(config%n_g_lw,nlev,istartcol:iendcol), intent(out) :: & + & od_lw + real(jprb), dimension(config%n_g_sw,nlev,istartcol:iendcol), intent(out) :: & + & od_sw, ssa_sw + + ! The Planck function (emitted flux from a black body) at half + ! levels at each longwave g-point + real(jprb), dimension(config%n_g_lw,nlev+1,istartcol:iendcol), & + & intent(out), optional :: planck_hl + ! Planck function for the surface (W m-2) + real(jprb), dimension(config%n_g_lw,istartcol:iendcol), & + & intent(out), optional :: lw_emission + + ! The incoming shortwave flux into a plane perpendicular to the + ! incoming radiation at top-of-atmosphere in each of the shortwave + ! g-points + real(jprb), dimension(config%n_g_sw,istartcol:iendcol), & + & intent(out), optional :: incoming_sw + + ! Temperature at full levels (K) + real(jprb) :: temperature_fl(istartcol:iendcol,nlev) + + integer :: jcol + + !temperature_fl(istartcol:iendcol,:) & + ! & = 0.5_jprb * (thermodynamics%temperature_hl(istartcol:iendcol,1:nlev) & + ! & +thermodynamics%temperature_hl(istartcol:iendcol,2:nlev+1)) + + temperature_fl(istartcol:iendcol,:) & + & = (thermodynamics%temperature_hl(istartcol:iendcol,1:nlev) & + & *thermodynamics%pressure_hl(istartcol:iendcol,1:nlev) & + & +thermodynamics%temperature_hl(istartcol:iendcol,2:nlev+1) & + & *thermodynamics%pressure_hl(istartcol:iendcol,2:nlev+1)) & + & / (thermodynamics%pressure_hl(istartcol:iendcol,1:nlev) & + & +thermodynamics%pressure_hl(istartcol:iendcol,2:nlev+1)) + + if (config%do_sw) then + + call config%gas_optics_sw%calc_optical_depth(ncol,nlev,istartcol,iendcol, & + & NMaxGases, thermodynamics%pressure_hl, & + & temperature_fl, & + & gas%mixing_ratio, & +! & reshape(gas%mixing_ratio(istartcol:iendcol,:,:), & +! & [nlev,iendcol-istartcol+1,NMaxGases],order=[2,1,3]), & + & od_sw, rayleigh_od_fl=ssa_sw) + ! At this point od_sw = absorption optical depth and ssa_sw = + ! rayleigh optical depth: convert to total optical depth and + ! single-scattering albedo + od_sw = od_sw + ssa_sw + ssa_sw = ssa_sw / od_sw + + if (present(incoming_sw)) then + call config%gas_optics_sw%calc_incoming_sw(single_level%solar_irradiance, incoming_sw) + end if + + end if + + if (config%do_lw) then + + call config%gas_optics_lw%calc_optical_depth(ncol,nlev,istartcol,iendcol, & + & NMaxGases, thermodynamics%pressure_hl, & + & temperature_fl, & + & gas%mixing_ratio, & +! & reshape(gas%mixing_ratio(istartcol:iendcol,:,:), & +! & [nlev,iendcol-istartcol+1,NMaxGases],order=[2,1,3]), & + & od_lw) + + ! Calculate the Planck function for each g point + do jcol = istartcol,iendcol + call config%gas_optics_lw%calc_planck_function(nlev+1, & + & thermodynamics%temperature_hl(jcol,:), planck_hl(:,:,jcol)) + end do + call config%gas_optics_lw%calc_planck_function(iendcol+1-istartcol, & + & single_level%skin_temperature(istartcol:iendcol), & + & lw_emission(:,:)) + lw_emission = lw_emission * (1.0_jprb - lw_albedo) + + end if + + end subroutine gas_optics + + ! !--------------------------------------------------------------------- + ! ! Externally facing function for computing the Planck function + ! ! without reference to any gas profile; typically this would be used + ! ! for computing the emission by a surface. + ! subroutine planck_function(config, temperature, planck_surf) + + ! use parkind1, only : jprb + ! use radiation_config, only : config_type + + ! type(config_type), intent(in) :: config + ! real(jprb), intent(in) :: temperature + + ! ! Planck function of the surface (W m-2) + ! real(jprb), dimension(config%n_g_lw), intent(out) :: planck_surf + + ! end subroutine planck_function + +end module radiation_ecckd_interface Index: LMDZ6/trunk/libf/phylmd/ecrad/radiation_flux.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad/radiation_flux.F90 (revision 4487) +++ LMDZ6/trunk/libf/phylmd/ecrad/radiation_flux.F90 (revision 4489) @@ -100,4 +100,11 @@ end type flux_type +! Added for DWD (2020) +#ifdef __SX__ + logical, parameter :: use_indexed_sum_vec = .true. +#else + logical, parameter :: use_indexed_sum_vec = .false. +#endif + contains @@ -132,5 +139,5 @@ if (config%n_spec_lw == 0) then write(nulerr,'(a)') '*** Error: number of LW spectral points to save not yet defined ' & - & // 'so cannot allocated spectral flux arrays' + & // 'so cannot allocate spectral flux arrays' call radiation_abort() end if @@ -321,4 +328,11 @@ end if + if (allocated(this%lw_dn_surf_g)) deallocate(this%lw_dn_surf_g) + if (allocated(this%lw_dn_surf_clear_g)) deallocate(this%lw_dn_surf_clear_g) + if (allocated(this%sw_dn_diffuse_surf_g)) deallocate(this%sw_dn_diffuse_surf_g) + if (allocated(this%sw_dn_direct_surf_g)) deallocate(this%sw_dn_direct_surf_g) + if (allocated(this%sw_dn_diffuse_surf_clear_g)) deallocate(this%sw_dn_diffuse_surf_clear_g) + if (allocated(this%sw_dn_direct_surf_clear_g)) deallocate(this%sw_dn_direct_surf_clear_g) + if (lhook) call dr_hook('radiation_flux:deallocate',1,hook_handle) @@ -349,28 +363,56 @@ if (config%do_sw .and. config%do_surface_sw_spectral_flux) then - do jcol = istartcol,iendcol - call indexed_sum(this%sw_dn_direct_surf_g(:,jcol), & - & config%i_band_from_reordered_g_sw, & - & this%sw_dn_direct_surf_band(:,jcol)) - call indexed_sum(this%sw_dn_diffuse_surf_g(:,jcol), & - & config%i_band_from_reordered_g_sw, & - & this%sw_dn_surf_band(:,jcol)) - this%sw_dn_surf_band(:,jcol) & - & = this%sw_dn_surf_band(:,jcol) & - & + this%sw_dn_direct_surf_band(:,jcol) - end do + if (use_indexed_sum_vec) then + call indexed_sum_vec(this%sw_dn_direct_surf_g, & + & config%i_band_from_reordered_g_sw, & + & this%sw_dn_direct_surf_band, istartcol, iendcol) + call indexed_sum_vec(this%sw_dn_diffuse_surf_g, & + & config%i_band_from_reordered_g_sw, & + & this%sw_dn_surf_band, istartcol, iendcol) + do jcol = istartcol,iendcol + this%sw_dn_surf_band(:,jcol) & + & = this%sw_dn_surf_band(:,jcol) & + & + this%sw_dn_direct_surf_band(:,jcol) + end do + else + do jcol = istartcol,iendcol + call indexed_sum(this%sw_dn_direct_surf_g(:,jcol), & + & config%i_band_from_reordered_g_sw, & + & this%sw_dn_direct_surf_band(:,jcol)) + call indexed_sum(this%sw_dn_diffuse_surf_g(:,jcol), & + & config%i_band_from_reordered_g_sw, & + & this%sw_dn_surf_band(:,jcol)) + this%sw_dn_surf_band(:,jcol) & + & = this%sw_dn_surf_band(:,jcol) & + & + this%sw_dn_direct_surf_band(:,jcol) + end do + end if if (config%do_clear) then - do jcol = istartcol,iendcol - call indexed_sum(this%sw_dn_direct_surf_clear_g(:,jcol), & - & config%i_band_from_reordered_g_sw, & - & this%sw_dn_direct_surf_clear_band(:,jcol)) - call indexed_sum(this%sw_dn_diffuse_surf_clear_g(:,jcol), & - & config%i_band_from_reordered_g_sw, & - & this%sw_dn_surf_clear_band(:,jcol)) - this%sw_dn_surf_clear_band(:,jcol) & - & = this%sw_dn_surf_clear_band(:,jcol) & - & + this%sw_dn_direct_surf_clear_band(:,jcol) - end do + if (use_indexed_sum_vec) then + call indexed_sum_vec(this%sw_dn_direct_surf_clear_g, & + & config%i_band_from_reordered_g_sw, & + & this%sw_dn_direct_surf_clear_band, istartcol, iendcol) + call indexed_sum_vec(this%sw_dn_diffuse_surf_clear_g, & + & config%i_band_from_reordered_g_sw, & + & this%sw_dn_surf_clear_band, istartcol, iendcol) + do jcol = istartcol,iendcol + this%sw_dn_surf_clear_band(:,jcol) & + & = this%sw_dn_surf_clear_band(:,jcol) & + & + this%sw_dn_direct_surf_clear_band(:,jcol) + end do + else + do jcol = istartcol,iendcol + call indexed_sum(this%sw_dn_direct_surf_clear_g(:,jcol), & + & config%i_band_from_reordered_g_sw, & + & this%sw_dn_direct_surf_clear_band(:,jcol)) + call indexed_sum(this%sw_dn_diffuse_surf_clear_g(:,jcol), & + & config%i_band_from_reordered_g_sw, & + & this%sw_dn_surf_clear_band(:,jcol)) + this%sw_dn_surf_clear_band(:,jcol) & + & = this%sw_dn_surf_clear_band(:,jcol) & + & + this%sw_dn_direct_surf_clear_band(:,jcol) + end do + end if end if @@ -383,12 +425,21 @@ this%sw_dn_direct_surf_canopy (:,istartcol:iendcol) = this%sw_dn_direct_surf_g (:,istartcol:iendcol) else if (config%do_nearest_spectral_sw_albedo) then - do jcol = istartcol,iendcol - call indexed_sum(this%sw_dn_direct_surf_g(:,jcol), & - & config%i_albedo_from_band_sw(config%i_band_from_reordered_g_sw), & - & this%sw_dn_direct_surf_canopy(:,jcol)) - call indexed_sum(this%sw_dn_diffuse_surf_g(:,jcol), & - & config%i_albedo_from_band_sw(config%i_band_from_reordered_g_sw), & - & this%sw_dn_diffuse_surf_canopy(:,jcol)) - end do + if (use_indexed_sum_vec) then + call indexed_sum_vec(this%sw_dn_direct_surf_g, & + & config%i_albedo_from_band_sw(config%i_band_from_reordered_g_sw), & + & this%sw_dn_direct_surf_canopy, istartcol, iendcol) + call indexed_sum_vec(this%sw_dn_diffuse_surf_g, & + & config%i_albedo_from_band_sw(config%i_band_from_reordered_g_sw), & + & this%sw_dn_diffuse_surf_canopy, istartcol, iendcol) + else + do jcol = istartcol,iendcol + call indexed_sum(this%sw_dn_direct_surf_g(:,jcol), & + & config%i_albedo_from_band_sw(config%i_band_from_reordered_g_sw), & + & this%sw_dn_direct_surf_canopy(:,jcol)) + call indexed_sum(this%sw_dn_diffuse_surf_g(:,jcol), & + & config%i_albedo_from_band_sw(config%i_band_from_reordered_g_sw), & + & this%sw_dn_diffuse_surf_canopy(:,jcol)) + end do + end if else ! More accurate calculations using weights, but requires @@ -425,17 +476,29 @@ this%lw_dn_surf_canopy(:,istartcol:iendcol) = this%lw_dn_surf_g(:,istartcol:iendcol) else if (config%do_nearest_spectral_lw_emiss) then - do jcol = istartcol,iendcol - call indexed_sum(this%lw_dn_surf_g(:,jcol), & - & config%i_emiss_from_band_lw(config%i_band_from_reordered_g_lw), & - & this%lw_dn_surf_canopy(:,jcol)) - end do + if (use_indexed_sum_vec) then + call indexed_sum_vec(this%lw_dn_surf_g, & + & config%i_emiss_from_band_lw(config%i_band_from_reordered_g_lw), & + & this%lw_dn_surf_canopy, istartcol, iendcol) + else + do jcol = istartcol,iendcol + call indexed_sum(this%lw_dn_surf_g(:,jcol), & + & config%i_emiss_from_band_lw(config%i_band_from_reordered_g_lw), & + & this%lw_dn_surf_canopy(:,jcol)) + end do + end if else ! Compute fluxes in each longwave emissivity interval using ! weights; first sum over g points to get the values in bands - do jcol = istartcol,iendcol - call indexed_sum(this%lw_dn_surf_g(:,jcol), & - & config%i_band_from_reordered_g_lw, & - & lw_dn_surf_band(:,jcol)) - end do + if (use_indexed_sum_vec) then + call indexed_sum_vec(this%lw_dn_surf_g, & + & config%i_band_from_reordered_g_lw, & + & lw_dn_surf_band, istartcol, iendcol) + else + do jcol = istartcol,iendcol + call indexed_sum(this%lw_dn_surf_g(:,jcol), & + & config%i_band_from_reordered_g_lw, & + & lw_dn_surf_band(:,jcol)) + end do + end if nalbedoband = size(config%lw_emiss_weights,1) this%lw_dn_surf_canopy(:,istartcol:iendcol) = 0.0_jprb @@ -465,5 +528,5 @@ use yomhook, only : lhook, dr_hook - use radiation_config, only : out_of_bounds_2d + use radiation_check, only : out_of_bounds_2d class(flux_type), intent(inout) :: this @@ -497,5 +560,5 @@ function heating_rate_out_of_physical_bounds(this, nlev, istartcol, iendcol, pressure_hl) result(is_bad) - use radiation_config, only : out_of_bounds_2d + use radiation_check, only : out_of_bounds_2d use radiation_constants, only : AccelDueToGravity @@ -581,4 +644,25 @@ end subroutine indexed_sum + !--------------------------------------------------------------------- + ! Vectorized version of "add_indexed_sum" + subroutine indexed_sum_vec(source, ind, dest, ist, iend) + + real(jprb), intent(in) :: source(:,:) + integer, intent(in) :: ind(:) + real(jprb), intent(out) :: dest(:,:) + integer, intent(in) :: ist, iend + + integer :: ig, jg, jc + + dest = 0.0 + + do jg = lbound(source,1), ubound(source,1) + ig = ind(jg) + do jc = ist, iend + dest(ig,jc) = dest(ig,jc) + source(jg,jc) + end do + end do + + end subroutine indexed_sum_vec !--------------------------------------------------------------------- Index: LMDZ6/trunk/libf/phylmd/ecrad/radiation_gas.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad/radiation_gas.F90 (revision 4487) +++ LMDZ6/trunk/libf/phylmd/ecrad/radiation_gas.F90 (revision 4489) @@ -19,49 +19,8 @@ use parkind1, only : jprb + use radiation_gas_constants implicit none public - - ! Gas codes; these indices match those of RRTM-LW up to 7 - integer, parameter :: IGasNotPresent = 0 - integer, parameter :: IH2O = 1 - integer, parameter :: ICO2 = 2 - integer, parameter :: IO3 = 3 - integer, parameter :: IN2O = 4 - integer, parameter :: ICO = 5 - integer, parameter :: ICH4 = 6 - integer, parameter :: IO2 = 7 - integer, parameter :: ICFC11 = 8 - integer, parameter :: ICFC12 = 9 - integer, parameter :: IHCFC22= 10 - integer, parameter :: ICCl4 = 11 - integer, parameter :: INO2 = 12 - integer, parameter :: NMaxGases = 12 - - ! Molar masses (g mol-1) of dry air and the various gases above - real(jprb), parameter :: IAirMolarMass = 28.970 - real(jprb), parameter, dimension(0:NMaxGases) :: IGasMolarMass = (/ & - & 0.0_jprb, & ! Gas not present - & 18.0152833_jprb, & ! H2O - & 44.011_jprb, & ! CO2 - & 47.9982_jprb, & ! O3 - & 44.013_jprb, & ! N2O - & 28.0101_jprb, & ! CO - & 16.043_jprb, & ! CH4 - & 31.9988_jprb, & ! O2 - & 137.3686_jprb, & ! CFC11 - & 120.914_jprb, & ! CFC12 - & 86.469_jprb, & ! HCFC22 - & 153.823_jprb, & ! CCl4 - & 46.0055_jprb /) ! NO2 - - ! The corresponding names of the gases in upper and lower case, used - ! for reading variables from the input file - character*6, dimension(NMaxGases), parameter :: GasName & - & = (/'H2O ','CO2 ','O3 ','N2O ','CO ','CH4 ', & - & 'O2 ','CFC11 ','CFC12 ','HCFC22','CCl4 ','NO2 '/) - character*6, dimension(NMaxGases), parameter :: GasLowerCaseName & - & = (/'h2o ','co2 ','o3 ','n2o ','co ','ch4 ', & - & 'o2 ','cfc11 ','cfc12 ','hcfc22','ccl4 ','no2 '/) ! Available units @@ -121,4 +80,6 @@ !--------------------------------------------------------------------- + ! Allocate a derived type for holding gas mixing ratios given the + ! number of columns and levels subroutine allocate_gas(this, ncol, nlev) @@ -191,5 +152,6 @@ integer, optional, intent(in) :: istartcol - integer :: i1, i2 + integer :: i1, i2, jc, jk + real(jprb) :: hook_handle @@ -245,6 +207,10 @@ this%iunits(igas) = iunits this%is_well_mixed(igas) = .false. - this%mixing_ratio(i1:i2,:,igas) = mixing_ratio - + + do jk = 1,this%nlev + do jc = i1,i2 + this%mixing_ratio(jc,jk,igas) = mixing_ratio(jc-i1+1,jk) + end do + end do if (present(scale_factor)) then this%scale_factor(igas) = scale_factor @@ -276,5 +242,5 @@ real(jprb) :: hook_handle - integer :: i1, i2 + integer :: i1, i2, jc, jk if (lhook) call dr_hook('radiation_gas:put_well_mixed',0,hook_handle) @@ -326,6 +292,10 @@ this%iunits(igas) = iunits this%is_well_mixed(igas) = .true. - this%mixing_ratio(i1:i2,:,igas) = mixing_ratio - + + do jk = 1,this%nlev + do jc = i1,i2 + this%mixing_ratio(jc,jk,igas) = mixing_ratio + end do + end do if (present(scale_factor)) then this%scale_factor(igas) = scale_factor @@ -344,5 +314,4 @@ ! immediately, but changes the scale factor for the specified gas, ! ready to be used in set_units_gas. - subroutine scale_gas(this, igas, scale_factor, lverbose) @@ -411,8 +380,8 @@ if (iunits == IMassMixingRatio & & .and. this%iunits(igas) == IVolumeMixingRatio) then - sf = sf * IGasMolarMass(igas) / IAirMolarMass + sf = sf * GasMolarMass(igas) / AirMolarMass else if (iunits == IVolumeMixingRatio & & .and. this%iunits(igas) == IMassMixingRatio) then - sf = sf * IAirMolarMass / IGasMolarMass(igas) + sf = sf * AirMolarMass / GasMolarMass(igas) end if sf = sf * this%scale_factor(igas) @@ -538,8 +507,8 @@ if (iunits == IMassMixingRatio & & .and. this%iunits(igas) == IVolumeMixingRatio) then - sf = sf * IGasMolarMass(igas) / IAirMolarMass + sf = sf * GasMolarMass(igas) / AirMolarMass else if (iunits == IVolumeMixingRatio & & .and. this%iunits(igas) == IMassMixingRatio) then - sf = sf * IAirMolarMass / IGasMolarMass(igas) + sf = sf * AirMolarMass / GasMolarMass(igas) end if sf = sf * this%scale_factor(igas) @@ -591,5 +560,5 @@ use yomhook, only : lhook, dr_hook - use radiation_config, only : out_of_bounds_3d + use radiation_check, only : out_of_bounds_3d class(gas_type), intent(inout) :: this Index: LMDZ6/trunk/libf/phylmd/ecrad/radiation_gas_constants.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad/radiation_gas_constants.F90 (revision 4489) +++ LMDZ6/trunk/libf/phylmd/ecrad/radiation_gas_constants.F90 (revision 4489) @@ -0,0 +1,67 @@ +! radiation_gas_constants.F90 - Molar mases and ID codes of the various gases +! +! (C) Copyright 2014- 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. +! +! Author: Robin Hogan +! Email: r.j.hogan@ecmwf.int +! License: see the COPYING file for details +! + +module radiation_gas_constants + + use parkind1, only : jprb + + implicit none + + public + + ! Gas codes; these indices match those of RRTM-LW up to 7 + integer, parameter :: IGasNotPresent = 0 + integer, parameter :: IH2O = 1 + integer, parameter :: ICO2 = 2 + integer, parameter :: IO3 = 3 + integer, parameter :: IN2O = 4 + integer, parameter :: ICO = 5 + integer, parameter :: ICH4 = 6 + integer, parameter :: IO2 = 7 + integer, parameter :: ICFC11 = 8 + integer, parameter :: ICFC12 = 9 + integer, parameter :: IHCFC22= 10 + integer, parameter :: ICCl4 = 11 + integer, parameter :: INO2 = 12 + integer, parameter :: NMaxGases = 12 + + ! Molar masses (g mol-1) of dry air and the various gases above + real(jprb), parameter :: AirMolarMass = 28.970_jprb + real(jprb), parameter, dimension(0:NMaxGases) :: GasMolarMass = (/ & + & 0.0_jprb, & ! Gas not present + & 18.0152833_jprb, & ! H2O + & 44.011_jprb, & ! CO2 + & 47.9982_jprb, & ! O3 + & 44.013_jprb, & ! N2O + & 28.0101_jprb, & ! CO + & 16.043_jprb, & ! CH4 + & 31.9988_jprb, & ! O2 + & 137.3686_jprb, & ! CFC11 + & 120.914_jprb, & ! CFC12 + & 86.469_jprb, & ! HCFC22 + & 153.823_jprb, & ! CCl4 + & 46.0055_jprb /) ! NO2 + + ! The corresponding names of the gases in upper and lower case, used + ! for reading variables from the input file + character*6, dimension(NMaxGases), parameter :: GasName & + & = (/'H2O ','CO2 ','O3 ','N2O ','CO ','CH4 ', & + & 'O2 ','CFC11 ','CFC12 ','HCFC22','CCl4 ','NO2 '/) + character*6, dimension(NMaxGases), parameter :: GasLowerCaseName & + & = (/'h2o ','co2 ','o3 ','n2o ','co ','ch4 ', & + & 'o2 ','cfc11 ','cfc12 ','hcfc22','ccl4 ','no2 '/) + +end module radiation_gas_constants Index: LMDZ6/trunk/libf/phylmd/ecrad/radiation_general_cloud_optics.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad/radiation_general_cloud_optics.F90 (revision 4489) +++ LMDZ6/trunk/libf/phylmd/ecrad/radiation_general_cloud_optics.F90 (revision 4489) @@ -0,0 +1,286 @@ +! radiation_general_cloud_optics.F90 - Computing generalized cloud optical properties +! +! (C) Copyright 2020- 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. +! +! Author: Robin Hogan +! Email: r.j.hogan@ecmwf.int +! License: see the COPYING file for details +! + +module radiation_general_cloud_optics + + implicit none + + public + +contains + + ! Provides elemental function "delta_eddington_scat_od" +#include "radiation_delta_eddington.h" + + + !--------------------------------------------------------------------- + ! Load cloud scattering data; this subroutine delegates to one + ! in radiation_general_cloud_optics_data.F90 + subroutine setup_general_cloud_optics(config) + + use parkind1, only : jprb + use yomhook, only : lhook, dr_hook + + use radiation_io, only : nulout + use radiation_config, only : config_type, NMaxCloudTypes + use radiation_spectral_definition, only : SolarReferenceTemperature, & + & TerrestrialReferenceTemperature + + type(config_type), intent(inout) :: config + + character(len=511) :: file_name + + integer :: jtype ! loop index + integer :: strlen + + real(jprb) :: hook_handle + + if (lhook) call dr_hook('radiation_general_cloud_optics:setup_general_cloud_optics',0,hook_handle) + + ! Count number of cloud types + config%n_cloud_types = 0 + do jtype = 1,NMaxCloudTypes + if (len_trim(config%cloud_type_name(jtype)) > 0) then + config%n_cloud_types = jtype + else + exit + end if + end do + + ! If cloud_type_name has not been provided then assume liquid,ice + ! noting that the default spectral averaging (defined in + ! radiation_config.F90) is "thick" + if (config%n_cloud_types == 0) then + config%cloud_type_name(1) = "mie_droplet" + config%cloud_type_name(2) = "baum-general-habit-mixture_ice" + ! Optionally override spectral averaging method + !config%use_thick_cloud_spectral_averaging(1) = .false. + !config%use_thick_cloud_spectral_averaging(2) = .false. + config%n_cloud_types = 2 + end if + + ! Allocate structures + if (config%do_sw) then + allocate(config%cloud_optics_sw(config%n_cloud_types)) + end if + + if (config%do_lw) then + allocate(config%cloud_optics_lw(config%n_cloud_types)) + end if + + ! Load cloud optics data + do jtype = 1,config%n_cloud_types + if (config%cloud_type_name(jtype)(1:1) == '/') then + file_name = trim(config%cloud_type_name(jtype)) + else + strlen = len_trim(config%cloud_type_name(jtype)) + if (config%cloud_type_name(jtype)(strlen-2:strlen) == ".nc") then + file_name = trim(config%directory_name) & + & // '/' // trim(config%cloud_type_name(jtype)) + else + file_name = trim(config%directory_name) & + & // '/' // trim(config%cloud_type_name(jtype)) & + & // '_scattering.nc' + end if + end if + + if (config%do_sw) then + if (config%iverbosesetup >= 2) then + write(nulout,'(a,i0,a)') 'Shortwave cloud type ', jtype, ':' + end if + call config%cloud_optics_sw(jtype)%setup(file_name, & + & config%gas_optics_sw%spectral_def, & + & use_bands=(.not. config%do_cloud_aerosol_per_sw_g_point), & + & use_thick_averaging=config%use_thick_cloud_spectral_averaging(jtype), & + & weighting_temperature=SolarReferenceTemperature, & + & iverbose=config%iverbosesetup) + end if + + if (config%do_lw) then + if (config%iverbosesetup >= 2) then + write(nulout,'(a,i0,a)') 'Longwave cloud type ', jtype, ':' + end if + call config%cloud_optics_lw(jtype)%setup(file_name, & + & config%gas_optics_lw%spectral_def, & + & use_bands=(.not. config%do_cloud_aerosol_per_lw_g_point), & + & use_thick_averaging=config%use_thick_cloud_spectral_averaging(jtype), & + & weighting_temperature=TerrestrialReferenceTemperature, & + & iverbose=config%iverbosesetup) + end if + + end do + + if (lhook) call dr_hook('radiation_general_cloud_optics:setup_general_cloud_optics',1,hook_handle) + + end subroutine setup_general_cloud_optics + + !--------------------------------------------------------------------- + ! Compute cloud optical properties + subroutine general_cloud_optics(nlev,istartcol,iendcol, & + & config, thermodynamics, cloud, & + & od_lw_cloud, ssa_lw_cloud, g_lw_cloud, & + & od_sw_cloud, ssa_sw_cloud, g_sw_cloud) + + use parkind1, only : jprb + use yomhook, only : lhook, dr_hook + + use radiation_io, only : nulout + use radiation_config, only : config_type + use radiation_thermodynamics, only : thermodynamics_type + use radiation_cloud, only : cloud_type + use radiation_constants, only : AccelDueToGravity + !use radiation_general_cloud_optics_data, only : general_cloud_optics_type + + integer, intent(in) :: nlev ! number of model levels + integer, intent(in) :: istartcol, iendcol ! range of columns to process + type(config_type), intent(in), target :: config + type(thermodynamics_type),intent(in) :: thermodynamics + type(cloud_type), intent(in) :: cloud + + ! Layer optical depth, single scattering albedo and g factor of + ! clouds in each longwave band, where the latter two + ! variables are only defined if cloud longwave scattering is + ! enabled (otherwise both are treated as zero). + real(jprb), dimension(config%n_bands_lw,nlev,istartcol:iendcol), intent(out) :: & + & od_lw_cloud + real(jprb), dimension(config%n_bands_lw_if_scattering,nlev,istartcol:iendcol), & + & intent(out) :: ssa_lw_cloud, g_lw_cloud + + ! Layer optical depth, single scattering albedo and g factor of + ! clouds in each shortwave band + real(jprb), dimension(config%n_bands_sw,nlev,istartcol:iendcol), intent(out) :: & + & od_sw_cloud, ssa_sw_cloud, g_sw_cloud + + ! In-cloud water path of one cloud type (kg m-2) + real(jprb), dimension(istartcol:iendcol,nlev) :: water_path + + integer :: jtype, jcol, jlev + + real(jprb) :: hook_handle + + if (lhook) call dr_hook('radiation_general_cloud_optics:general_cloud_optics',0,hook_handle) + + if (config%iverbose >= 2) then + write(nulout,'(a)') 'Computing cloud absorption/scattering properties' + end if + + ! Array-wise assignment + od_lw_cloud = 0.0_jprb + od_sw_cloud = 0.0_jprb + ssa_sw_cloud = 0.0_jprb + g_sw_cloud = 0.0_jprb + if (config%do_lw_cloud_scattering) then + ssa_lw_cloud = 0.0_jprb + g_lw_cloud = 0.0_jprb + end if + + ! Loop over cloud types + do jtype = 1,config%n_cloud_types + ! Compute in-cloud water path + if (config%is_homogeneous) then + water_path = cloud%mixing_ratio(istartcol:iendcol,:,jtype) & + & * (thermodynamics%pressure_hl(istartcol:iendcol, 2:nlev+1) & + & -thermodynamics%pressure_hl(istartcol:iendcol, 1:nlev)) & + & * (1.0_jprb / AccelDueToGravity) + else + water_path = cloud%mixing_ratio(istartcol:iendcol,:,jtype) & + & * (thermodynamics%pressure_hl(istartcol:iendcol, 2:nlev+1) & + & -thermodynamics%pressure_hl(istartcol:iendcol, 1:nlev)) & + & * (1.0_jprb / (AccelDueToGravity & + & * max(config%cloud_fraction_threshold, & + & cloud%fraction(istartcol:iendcol,:)))) + end if + + ! Add optical properties to the cumulative total for the + ! longwave and shortwave + if (config%do_lw) then + ! For the moment, we use ssa_lw_cloud and g_lw_cloud as + ! containers for scattering optical depth and scattering + ! coefficient x asymmetry factor, then scale after + if (config%do_lw_cloud_scattering) then + call config%cloud_optics_lw(jtype)%add_optical_properties(config%n_bands_lw, nlev, & + & iendcol+1-istartcol, cloud%fraction(istartcol:iendcol,:), & + & water_path, cloud%effective_radius(istartcol:iendcol,:,jtype), & + & od_lw_cloud, ssa_lw_cloud, g_lw_cloud) + else + call config%cloud_optics_lw(jtype)%add_optical_properties(config%n_bands_lw, nlev, & + & iendcol+1-istartcol, cloud%fraction(istartcol:iendcol,:), & + & water_path, cloud%effective_radius(istartcol:iendcol,:,jtype), od_lw_cloud) + end if + end if + + if (config%do_sw) then + ! For the moment, we use ssa_sw_cloud and g_sw_cloud as + ! containers for scattering optical depth and scattering + ! coefficient x asymmetry factor, then scale after + call config%cloud_optics_sw(jtype)%add_optical_properties(config%n_bands_sw, nlev, & + & iendcol+1-istartcol, cloud%fraction(istartcol:iendcol,:), & + & water_path, cloud%effective_radius(istartcol:iendcol,:,jtype), & + & od_sw_cloud, ssa_sw_cloud, g_sw_cloud) + end if + end do + + ! Scale the combined longwave optical properties + if (config%do_lw_cloud_scattering) then + do jcol = istartcol, iendcol + do jlev = 1,nlev + if (cloud%fraction(jcol,jlev) > 0.0_jprb) then + ! Note that original cloud optics does not do + ! delta-Eddington scaling for liquid clouds in longwave + call delta_eddington_extensive(od_lw_cloud(:,jlev,jcol), & + & ssa_lw_cloud(:,jlev,jcol), g_lw_cloud(:,jlev,jcol)) + + ! Scale to get asymmetry factor and single scattering albedo + g_lw_cloud(:,jlev,jcol) = g_lw_cloud(:,jlev,jcol) & + & / max(ssa_lw_cloud(:,jlev,jcol), 1.0e-15_jprb) + ssa_lw_cloud(:,jlev,jcol) = ssa_lw_cloud(:,jlev,jcol) & + & / max(od_lw_cloud(:,jlev,jcol), 1.0e-15_jprb) + end if + end do + end do + end if + + ! Scale the combined shortwave optical properties + if (config%do_sw) then + if (.not. config%do_sw_delta_scaling_with_gases) then + do jcol = istartcol, iendcol + do jlev = 1,nlev + if (cloud%fraction(jcol,jlev) > 0.0_jprb) then + call delta_eddington_extensive(od_sw_cloud(:,jlev,jcol), & + & ssa_sw_cloud(:,jlev,jcol), g_sw_cloud(:,jlev,jcol)) + end if + end do + end do + end if + + do jcol = istartcol, iendcol + do jlev = 1,nlev + if (cloud%fraction(jcol,jlev) > 0.0_jprb) then + ! Scale to get asymmetry factor and single scattering albedo + g_sw_cloud(:,jlev,jcol) = g_sw_cloud(:,jlev,jcol) & + & / max(ssa_sw_cloud(:,jlev,jcol), 1.0e-15_jprb) + ssa_sw_cloud(:,jlev,jcol) = ssa_sw_cloud(:,jlev,jcol) & + & / max(od_sw_cloud(:,jlev,jcol), 1.0e-15_jprb) + end if + end do + end do + end if + + if (lhook) call dr_hook('radiation_general_cloud_optics:general_cloud_optics',1,hook_handle) + + end subroutine general_cloud_optics + +end module radiation_general_cloud_optics Index: LMDZ6/trunk/libf/phylmd/ecrad/radiation_general_cloud_optics_data.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad/radiation_general_cloud_optics_data.F90 (revision 4489) +++ LMDZ6/trunk/libf/phylmd/ecrad/radiation_general_cloud_optics_data.F90 (revision 4489) @@ -0,0 +1,346 @@ +! radiation_general_cloud_optics_data.F90 - Type to store generalized cloud optical properties +! +! (C) Copyright 2019- 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. +! +! Author: Robin Hogan +! Email: r.j.hogan@ecmwf.int +! License: see the COPYING file for details +! + +module radiation_general_cloud_optics_data + + use parkind1, only : jprb + + implicit none + + public + + !--------------------------------------------------------------------- + ! This type holds the configuration information to compute optical + ! properties for a particular type of cloud or hydrometeor in one of + ! the shortwave or longwave + type general_cloud_optics_type + ! Band-specific (or g-point-specific) values as a look-up table + ! versus effective radius dimensioned (nband,n_effective_radius) + + ! Extinction coefficient per unit mass (m2 kg-1) + real(jprb), allocatable, dimension(:,:) :: & + & mass_ext + + ! Single-scattering albedo and asymmetry factor (dimensionless) + real(jprb), allocatable, dimension(:,:) :: & + & ssa, asymmetry + + ! Number of effective radius coefficients, start value and + ! interval in look-up table + integer :: n_effective_radius = 0 + real(jprb) :: effective_radius_0, d_effective_radius + + ! Name of cloud/precip type (e.g. "liquid", "ice", "rain", "snow") + ! and the name of the optics scheme. These two are used to + ! generate the name of the data file from which the coefficients + ! are read. + character(len=511) :: type_name, scheme_name + + ! Do we use bands or g-points? + logical :: use_bands = .false. + + contains + procedure :: setup => setup_general_cloud_optics + procedure :: add_optical_properties + + end type general_cloud_optics_type + +contains + + ! Provides elemental function "delta_eddington" +#include "radiation_delta_eddington.h" + + !--------------------------------------------------------------------- + ! Setup cloud optics coefficients by reading them from a file + subroutine setup_general_cloud_optics(this, file_name, specdef, & + & use_bands, use_thick_averaging, & + & weighting_temperature, & + & iverbose) + + use yomhook, only : lhook, dr_hook + use easy_netcdf, only : netcdf_file + use radiation_spectral_definition, only : spectral_definition_type + use radiation_io, only : nulout, nulerr, radiation_abort + + class(general_cloud_optics_type), intent(inout) :: this + character(len=*), intent(in) :: file_name + type(spectral_definition_type), intent(in) :: specdef + logical, intent(in), optional :: use_bands, use_thick_averaging + real(jprb), intent(in), optional :: weighting_temperature ! K + integer, intent(in), optional :: iverbose + + ! Spectral properties read from file, dimensioned (wavenumber, + ! n_effective_radius) + real(jprb), dimension(:,:), allocatable :: mass_ext, & ! m2 kg-1 + & ssa, asymmetry + + ! Reflectance of an infinitely thick cloud, needed for thick + ! averaging + real(jprb), dimension(:,:), allocatable :: ref_inf + + ! Coordinate variables from file + real(jprb), dimension(:), allocatable :: wavenumber ! cm-1 + real(jprb), dimension(:), allocatable :: effective_radius ! m + + ! Matrix mapping optical properties in the file to values per + ! g-point or band, such that in the thin-averaging case, + ! this%mass_ext=matmul(mapping,file%mass_ext), so mapping is + ! dimensioned (ngpoint,nwav) + real(jprb), dimension(:,:), allocatable :: mapping + + ! The NetCDF file containing the coefficients + type(netcdf_file) :: file + + real(jprb) :: diff_spread + integer :: iverb + integer :: nre ! Number of effective radii + integer :: nwav ! Number of wavenumbers describing cloud + + logical :: use_bands_local, use_thick_averaging_local + + real(jprb) :: hook_handle + + if (lhook) call dr_hook('radiation_general_cloud_optics_data:setup',0,hook_handle) + + ! Set local values of optional inputs + if (present(iverbose)) then + iverb = iverbose + else + iverb = 2 + end if + + if (present(use_bands)) then + use_bands_local = use_bands + else + use_bands_local = .false. + end if + + if (present(use_thick_averaging)) then + use_thick_averaging_local = use_thick_averaging + else + use_thick_averaging_local = .false. + end if + + ! Open the scattering file and configure the way it is read + call file%open(trim(file_name), iverbose=iverb) + !call file%transpose_matrices() + + ! Read coordinate variables + call file%get('wavenumber', wavenumber) + call file%get('effective_radius', effective_radius) + + ! Read the band-specific coefficients + call file%get('mass_extinction_coefficient', mass_ext) + call file%get('single_scattering_albedo', ssa) + call file%get('asymmetry_factor', asymmetry) + + ! Close scattering file + call file%close() + + ! Check effective radius is evenly spaced + nre = size(effective_radius) + ! Fractional range of differences, should be near zero for evenly + ! spaced data + diff_spread = (maxval(effective_radius(2:nre)-effective_radius(1:nre-1)) & + & -minval(effective_radius(2:nre)-effective_radius(1:nre-1))) & + & / minval(abs(effective_radius(2:nre)-effective_radius(1:nre-1))) + if (diff_spread > 0.01_jprb) then + write(nulerr, '(a,a,a)') '*** Error: effective_radius in ', & + & trim(file_name), ', is not evenly spaced to 1%' + call radiation_abort('Radiation configuration error') + end if + + ! Set up effective radius coordinate variable + this%n_effective_radius = nre + this%effective_radius_0 = effective_radius(1) + this%d_effective_radius = effective_radius(2) - effective_radius(1) + + ! Set up weighting + if (.not. present(weighting_temperature)) then + write(nulerr, '(a)') '*** Error: weighting_temperature not provided' + call radiation_abort('Radiation configuration error') + end if + + nwav = size(wavenumber) + + ! Define the mapping matrix + call specdef%calc_mapping(weighting_temperature, & + & wavenumber, mapping, use_bands=use_bands) + + ! Thick averaging should be performed on delta-Eddington scaled + ! quantities (it makes no difference to thin averaging) + call delta_eddington(mass_ext, ssa, asymmetry) + + ! Thin averaging + this%mass_ext = matmul(mapping, mass_ext) + this%ssa = matmul(mapping, mass_ext*ssa) / this%mass_ext + this%asymmetry = matmul(mapping, mass_ext*ssa*asymmetry) / (this%mass_ext*this%ssa) + + if (use_thick_averaging_local) then + ! Thick averaging as described by Edwards and Slingo (1996), + ! modifying only the single-scattering albedo + allocate(ref_inf(nwav, nre)) + + ! Eqs. 18 and 17 of Edwards & Slingo (1996) + ref_inf = sqrt((1.0_jprb - ssa) / (1.0_jprb - ssa*asymmetry)) + ref_inf = (1.0_jprb - ref_inf) / (1.0_jprb + ref_inf) + ! Here the left-hand side is actually the averaged ref_inf + this%ssa = matmul(mapping, ref_inf) + ! Eq. 19 of Edwards and Slingo (1996) + this%ssa = 4.0_jprb * this%ssa / ((1.0_jprb + this%ssa)**2 & + & - this%asymmetry * (1.0_jprb - this%ssa)**2) + + deallocate(ref_inf) + end if + + deallocate(mapping) + + ! Revert back to unscaled quantities + call revert_delta_eddington(this%mass_ext, this%ssa, this%asymmetry) + + if (iverb >= 2) then + write(nulout,'(a,a)') ' File: ', trim(file_name) + write(nulout,'(a,f7.1,a)') ' Weighting temperature: ', weighting_temperature, ' K' + if (use_thick_averaging_local) then + write(nulout,'(a)') ' SSA averaging: optically thick limit' + else + write(nulout,'(a)') ' SSA averaging: optically thin limit' + end if + if (use_bands_local) then + write(nulout,'(a,i0,a)') ' Spectral discretization: ', specdef%nband, ' bands' + else + write(nulout,'(a,i0,a)') ' Spectral discretization: ', specdef%ng, ' g-points' + end if + write(nulout,'(a,i0,a,f6.1,a,f6.1,a)') ' Effective radius look-up: ', nre, ' points in range ', & + & effective_radius(1)*1.0e6_jprb, '-', effective_radius(nre)*1.0e6_jprb, ' um' + write(nulout,'(a,i0,a,i0,a)') ' Wavenumber range: ', int(specdef%min_wavenumber()), '-', & + & int(specdef%max_wavenumber()), ' cm-1' + end if + + if (lhook) call dr_hook('radiation_general_cloud_optics_data:setup',1,hook_handle) + + end subroutine setup_general_cloud_optics + + + !--------------------------------------------------------------------- + ! Add the optical properties of a particular cloud type to the + ! accumulated optical properties of all cloud types + subroutine add_optical_properties(this, ng, nlev, ncol, & + & cloud_fraction, & + & water_path, effective_radius, & + & od, scat_od, scat_asymmetry) + + use yomhook, only : lhook, dr_hook + + class(general_cloud_optics_type), intent(in) :: this + + ! Number of g points, levels and columns + integer, intent(in) :: ng, nlev, ncol + + ! Properties of present cloud type, dimensioned (ncol,nlev) + real(jprb), intent(in) :: cloud_fraction(:,:) + real(jprb), intent(in) :: water_path(:,:) ! kg m-2 + real(jprb), intent(in) :: effective_radius(:,:) ! m + + ! Optical properties which are additive per cloud type, + ! dimensioned (ng,nlev,ncol) + real(jprb), intent(inout), dimension(ng,nlev,ncol) & + & :: od ! Optical depth of layer + real(jprb), intent(inout), dimension(ng,nlev,ncol), optional & + & :: scat_od, & ! Scattering optical depth of layer + & scat_asymmetry ! Scattering optical depth x asymmetry factor + + real(jprb) :: od_local(ng) + + real(jprb) :: re_index, weight1, weight2 + integer :: ire + + integer :: jcol, jlev + + real(jprb) :: hook_handle + + if (lhook) call dr_hook('radiation_general_cloud_optics_data:add_optical_properties',0,hook_handle) + + if (present(scat_od)) then + do jcol = 1,ncol + do jlev = 1,nlev + if (cloud_fraction(jcol, jlev) > 0.0_jprb) then + re_index = max(1.0_jprb, min(1.0_jprb + (effective_radius(jcol,jlev)-this%effective_radius_0) & + & / this%d_effective_radius, this%n_effective_radius-0.0001_jprb)) + ire = int(re_index) + weight2 = re_index - ire + weight1 = 1.0_jprb - weight2 + od_local = water_path(jcol, jlev) * (weight1*this%mass_ext(:,ire) & + & +weight2*this%mass_ext(:,ire+1)) + od(:,jlev,jcol) = od(:,jlev,jcol) + od_local + od_local = od_local * (weight1*this%ssa(:,ire) & + & +weight2*this%ssa(:,ire+1)) + scat_od(:,jlev,jcol) = scat_od(:,jlev,jcol) + od_local + scat_asymmetry(:,jlev,jcol) = scat_asymmetry(:,jlev,jcol) & + & + od_local * (weight1*this%asymmetry(:,ire) & + & +weight2*this%asymmetry(:,ire+1)) + end if + end do + end do + else + ! No scattering: return the absorption optical depth + do jcol = 1,ncol + do jlev = 1,nlev + if (water_path(jcol, jlev) > 0.0_jprb) then + re_index = max(1.0, min(1.0_jprb + (effective_radius(jcol,jlev)-this%effective_radius_0) & + & / this%d_effective_radius, this%n_effective_radius-0.0001_jprb)) + ire = int(re_index) + weight2 = re_index - ire + weight1 = 1.0_jprb - weight2 + od(:,jlev,jcol) = od(:,jlev,jcol) & + & + water_path(jcol, jlev) * (weight1*this%mass_ext(:,ire) & + & +weight2*this%mass_ext(:,ire+1)) & + & * (1.0_jprb - (weight1*this%ssa(:,ire)+weight2*this%ssa(:,ire+1))) + end if + end do + end do + end if + + if (lhook) call dr_hook('radiation_general_cloud_optics_data:add_optical_properties',1,hook_handle) + + end subroutine add_optical_properties + + + !--------------------------------------------------------------------- + ! Return the Planck function (in W m-2 (cm-1)-1) for a given + ! wavenumber (cm-1) and temperature (K), ensuring double precision + ! for internal calculation + elemental function calc_planck_function_wavenumber(wavenumber, temperature) + + use parkind1, only : jprb, jprd + use radiation_constants, only : SpeedOfLight, BoltzmannConstant, PlanckConstant + + real(jprb), intent(in) :: wavenumber ! cm-1 + real(jprb), intent(in) :: temperature ! K + real(jprb) :: calc_planck_function_wavenumber + + real(jprd) :: freq ! Hz + real(jprd) :: planck_fn_freq ! W m-2 Hz-1 + + freq = 100.0_jprd * real(SpeedOfLight,jprd) * real(wavenumber,jprd) + planck_fn_freq = 2.0_jprd * real(PlanckConstant,jprd) * freq**3 & + & / (real(SpeedOfLight,jprd)**2 * (exp(real(PlanckConstant,jprd)*freq & + & /(real(BoltzmannConstant,jprd)*real(temperature,jprd))) - 1.0_jprd)) + calc_planck_function_wavenumber = real(planck_fn_freq * 100.0_jprd * real(SpeedOfLight,jprd), jprb) + + end function calc_planck_function_wavenumber + +end module radiation_general_cloud_optics_data Index: LMDZ6/trunk/libf/phylmd/ecrad/radiation_ice_optics_fu.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad/radiation_ice_optics_fu.F90 (revision 4487) +++ LMDZ6/trunk/libf/phylmd/ecrad/radiation_ice_optics_fu.F90 (revision 4489) @@ -61,4 +61,5 @@ real (jprb) :: iwp_gm_2 + integer :: jb !real(jprb) :: hook_handle @@ -70,10 +71,14 @@ iwp_gm_2 = ice_wp * 1000.0_jprb - od = iwp_gm_2 * (coeff(1:nb,1) + coeff(1:nb,2) * inv_de_um) - scat_od = od * (1.0_jprb - (coeff(1:nb,3) + de_um*(coeff(1:nb,4) & - & + de_um*(coeff(1:nb,5) + de_um*coeff(1:nb,6))))) - g = min(coeff(1:nb,7) + de_um*(coeff(1:nb,8) & - & + de_um*(coeff(1:nb,9) + de_um*coeff(1:nb,10))), & +! Added for DWD (2020) +!NEC$ shortloop + do jb = 1, nb + od(jb) = iwp_gm_2 * (coeff(jb,1) + coeff(jb,2) * inv_de_um) + scat_od(jb) = od(jb) * (1.0_jprb - (coeff(jb,3) + de_um*(coeff(jb,4) & + & + de_um*(coeff(jb,5) + de_um*coeff(jb,6))))) + g(jb) = min(coeff(jb,7) + de_um*(coeff(jb,8) & + & + de_um*(coeff(jb,9) + de_um*coeff(jb,10))), & & MaxAsymmetryFactor) + end do !if (lhook) call dr_hook('radiation_ice_optics:calc_ice_optics_fu_sw',1,hook_handle) @@ -106,4 +111,5 @@ real (jprb) :: iwp_gm_2 + integer :: jb !real(jprb) :: hook_handle @@ -116,11 +122,15 @@ iwp_gm_2 = ice_wp * 1000.0_jprb - od = iwp_gm_2 * (coeff(1:nb,1) + inv_de_um*(coeff(1:nb,2) & - & + inv_de_um*coeff(1:nb,3))) - scat_od = od - iwp_gm_2*inv_de_um*(coeff(1:nb,4) + de_um*(coeff(1:nb,5) & - & + de_um*(coeff(1:nb,6) + de_um*coeff(1:nb,7)))) - g = min(coeff(1:nb,8) + de_um*(coeff(1:nb,9) & - & + de_um*(coeff(1:nb,10) + de_um*coeff(1:nb,11))), & +! Added for DWD (2020) +!NEC$ shortloop + do jb = 1, nb + od(jb) = iwp_gm_2 * (coeff(jb,1) + inv_de_um*(coeff(jb,2) & + & + inv_de_um*coeff(jb,3))) + scat_od(jb) = od(jb) - iwp_gm_2*inv_de_um*(coeff(jb,4) + de_um*(coeff(jb,5) & + & + de_um*(coeff(jb,6) + de_um*coeff(jb,7)))) + g(jb) = min(coeff(jb,8) + de_um*(coeff(jb,9) & + & + de_um*(coeff(jb,10) + de_um*coeff(jb,11))), & & MaxAsymmetryFactor) + end do !if (lhook) call dr_hook('radiation_ice_optics:calc_ice_optics_fu_lw',1,hook_handle) Index: LMDZ6/trunk/libf/phylmd/ecrad/radiation_ifs_rrtm.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad/radiation_ifs_rrtm.F90 (revision 4487) +++ LMDZ6/trunk/libf/phylmd/ecrad/radiation_ifs_rrtm.F90 (revision 4489) @@ -68,5 +68,5 @@ real(jprb) :: hook_handle -#include "surdi.intfb.h" +!#include "surdi.intfb.h" #include "surrtab.intfb.h" #include "surrtpk.intfb.h" @@ -81,5 +81,5 @@ ! up now. if (config%do_setup_ifsrrtm) then - call SURDI + !call SURDI call SURRTAB call SURRTPK @@ -89,4 +89,8 @@ end if + ! Cloud and aerosol properties can only be defined per band + config%do_cloud_aerosol_per_sw_g_point = .false. + config%do_cloud_aerosol_per_lw_g_point = .false. + config%n_g_sw = jpgsw config%n_g_lw = jpglw @@ -97,17 +101,15 @@ ! can compute UV and photosynthetically active radiation for a ! particular wavelength range - allocate(config%wavenumber1_sw(config%n_bands_sw)) - allocate(config%wavenumber2_sw(config%n_bands_sw)) - allocate(config%wavenumber1_lw(config%n_bands_lw)) - allocate(config%wavenumber2_lw(config%n_bands_lw)) - config%wavenumber1_lw = (/ 10, 350, 500, 630, 700, 820, 980, 1080, 1180, 1390, 1480, & - & 1800, 2080, 2250, 2380, 2600 /) - config%wavenumber2_lw = (/ 350, 500, 630, 700, 820, 980, 1080, 1180, 1390, 1480, 1800, & - & 2080, 2250, 2380, 2600, 3250 /) - config%wavenumber1_sw = (/ 2600, 3250, 4000, 4650, 5150, 6150, 7700, 8050, 12850, & - & 16000 , 22650, 29000, 38000, 820 /) - config%wavenumber2_sw = (/ 3250, 4000, 4650, 5150, 6150, 7700, 8050, 12850, 16000, & - & 22650, 29000, 38000, 50000, 2600 /) - print*,'allocate dans ifs_rrtm' + call config%gas_optics_sw%spectral_def%allocate_bands_only( & + & [2600.0_jprb, 3250.0_jprb, 4000.0_jprb, 4650.0_jprb, 5150.0_jprb, 6150.0_jprb, 7700.0_jprb, & + & 8050.0_jprb, 12850.0_jprb, 16000.0_jprb, 22650.0_jprb, 29000.0_jprb, 38000.0_jprb, 820.0_jprb], & + & [3250.0_jprb, 4000.0_jprb, 4650.0_jprb, 5150.0_jprb, 6150.0_jprb, 7700.0_jprb, 8050.0_jprb, & + & 12850.0_jprb, 16000.0_jprb, 22650.0_jprb, 29000.0_jprb, 38000.0_jprb, 50000.0_jprb, 2600.0_jprb]) + call config%gas_optics_lw%spectral_def%allocate_bands_only( & + & [10.0_jprb, 350.0_jprb, 500.0_jprb, 630.0_jprb, 700.0_jprb, 820.0_jprb, 980.0_jprb, 1080.0_jprb, & + & 1180.0_jprb, 1390.0_jprb, 1480.0_jprb, 1800.0_jprb, 2080.0_jprb, 2250.0_jprb, 2380.0_jprb, 2600.0_jprb], & + & [350.0_jprb, 500.0_jprb, 630.0_jprb, 700.0_jprb, 820.0_jprb, 980.0_jprb, 1080.0_jprb, 1180.0_jprb, & + & 1390.0_jprb, 1480.0_jprb, 1800.0_jprb, 2080.0_jprb, 2250.0_jprb, 2380.0_jprb, 2600.0_jprb, 3250.0_jprb]) + allocate(config%i_band_from_g_sw (config%n_g_sw)) allocate(config%i_band_from_g_lw (config%n_g_lw)) @@ -360,10 +362,14 @@ ! end if - pressure_fl(istartcol:iendcol,:) & - & = 0.5_jprb * (thermodynamics%pressure_hl(istartcol:iendcol,istartlev:iendlev) & - & +thermodynamics%pressure_hl(istartcol:iendcol,istartlev+1:iendlev+1)) - temperature_fl(istartcol:iendcol,:) & - & = 0.5_jprb * (thermodynamics%temperature_hl(istartcol:iendcol,istartlev:iendlev) & - & +thermodynamics%temperature_hl(istartcol:iendcol,istartlev+1:iendlev+1)) + do jlev=1,nlev + do jcol= istartcol,iendcol + pressure_fl(jcol,jlev) & + & = 0.5_jprb * (thermodynamics%pressure_hl(jcol,jlev+istartlev-1) & + & +thermodynamics%pressure_hl(jcol,jlev+istartlev)) + temperature_fl(jcol,jlev) & + & = 0.5_jprb * (thermodynamics%temperature_hl(jcol,jlev+istartlev-1) & + & +thermodynamics%temperature_hl(jcol,jlev+istartlev)) + end do + end do ! Check we have gas mixing ratios in the right units @@ -402,5 +408,5 @@ & ZRAT_N2OCO2, ZRAT_N2OCO2_1, ZRAT_O3CO2, ZRAT_O3CO2_1) - ZTAUAERL = 0.0_jprb + ZTAUAERL(istartcol:iendcol,:,:) = 0.0_jprb CALL RRTM_GAS_OPTICAL_DEPTH & @@ -434,5 +440,5 @@ lw_emission = lw_emission * (1.0_jprb - lw_albedo) else - ! Longwave emission has already been computed + ! Longwave emission has already been computed if (config%use_canopy_full_spectrum_lw) then lw_emission = transpose(single_level%lw_emission(istartcol:iendcol,:)) @@ -509,7 +515,10 @@ ! Scale the incoming solar per band, if requested if (config%use_spectral_solar_scaling) then - ZINCSOL(istartcol:iendcol,:) = ZINCSOL(istartcol:iendcol,:) & - & * spread(single_level%spectral_solar_scaling(config%i_band_from_reordered_g_sw), & - & 1,iendcol-istartcol+1) + do jg = 1,JPGPT_SW + do jcol = istartcol,iendcol + ZINCSOL(jcol,jg) = ZINCSOL(jcol,jg) * & + & single_level%spectral_solar_scaling(config%i_band_from_reordered_g_sw(jg)) + end do + end do end if @@ -518,8 +527,11 @@ ! ZINCSOL will be zero. if (present(incoming_sw)) then - incoming_sw_scale = 1.0_jprb do jcol = istartcol,iendcol if (single_level%cos_sza(jcol) > 0.0_jprb) then +! Added for DWD (2020) +!NEC$ nounroll incoming_sw_scale(jcol) = single_level%solar_irradiance / sum(ZINCSOL(jcol,:)) + else + incoming_sw_scale(jcol) = 1.0_jprb end if end do @@ -546,7 +558,7 @@ else ! G points have not been reordered - do jg = 1,config%n_g_sw + do jcol = istartcol,iendcol do jlev = 1,nlev - do jcol = istartcol,iendcol + do jg = 1,config%n_g_sw ! Check for negative optical depth od_sw (jg,nlev+1-jlev,jcol) = max(config%min_gas_od_sw, ZOD_SW(jcol,jlev,jg)) @@ -555,6 +567,7 @@ end do if (present(incoming_sw)) then - incoming_sw(jg,:) & - & = incoming_sw_scale(:) * ZINCSOL(:,jg) + do jg = 1,config%n_g_sw + incoming_sw(jg,jcol) = incoming_sw_scale(jcol) * ZINCSOL(jcol,jg) + end do end if end do @@ -604,5 +617,5 @@ real(jprb) :: temperature - real(jprb) :: factor + real(jprb) :: factor, planck_tmp(istartcol:iendcol,config%n_g_lw) real(jprb) :: ZFLUXFAC @@ -689,5 +702,8 @@ do jg = 1,config%n_g_lw iband = config%i_band_from_g_lw(jg) - planck_hl(jg,jlev,:) = planck_store(:,iband) * PFRAC(:,jg,nlev+2-jlev) + planck_tmp(:,jg) = planck_store(:,iband) * PFRAC(:,jg,nlev+2-jlev) + end do + do jcol = istartcol,iendcol + planck_hl(:,jlev,jcol) = planck_tmp(jcol,:) end do end if Index: LMDZ6/trunk/libf/phylmd/ecrad/radiation_interface.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad/radiation_interface.F90 (revision 4487) +++ LMDZ6/trunk/libf/phylmd/ecrad/radiation_interface.F90 (revision 4489) @@ -40,5 +40,7 @@ use yomhook, only : lhook, dr_hook use radiation_config, only : config_type, ISolverMcICA, & - & IGasModelMonochromatic, IGasModelIFSRRTMG + & IGasModelMonochromatic, IGasModelIFSRRTMG, IGasModelECCKD + use radiation_spectral_definition, only & + & : SolarReferenceTemperature, TerrestrialReferenceTemperature ! Currently there are two gas absorption models: RRTMG (default) @@ -48,6 +50,8 @@ & setup_cloud_optics_mono => setup_cloud_optics, & & setup_aerosol_optics_mono => setup_aerosol_optics - use radiation_ifs_rrtm, only : setup_gas_optics + use radiation_ifs_rrtm, only : setup_gas_optics_rrtmg => setup_gas_optics + use radiation_ecckd_interface,only : setup_gas_optics_ecckd => setup_gas_optics use radiation_cloud_optics, only : setup_cloud_optics + use radiation_general_cloud_optics, only : setup_general_cloud_optics use radiation_aerosol_optics, only : setup_aerosol_optics @@ -66,5 +70,7 @@ call setup_gas_optics_mono(config, trim(config%directory_name)) else if (config%i_gas_model == IGasModelIFSRRTMG) then - call setup_gas_optics(config, trim(config%directory_name)) + call setup_gas_optics_rrtmg(config, trim(config%directory_name)) + else if (config%i_gas_model == IGasModelECCKD) then + call setup_gas_optics_ecckd(config) end if @@ -100,18 +106,16 @@ ! Consolidate the albedo/emissivity intervals with the shortwave ! and longwave spectral bands - call config%consolidate_intervals(.true., & - & config%do_nearest_spectral_sw_albedo, & - & config%sw_albedo_wavelength_bound, config%i_sw_albedo_index, & - & config%wavenumber1_sw, config%wavenumber2_sw, & - & config%i_albedo_from_band_sw, config%sw_albedo_weights) - call config%consolidate_intervals(.false., & - & config%do_nearest_spectral_lw_emiss, & - & config%lw_emiss_wavelength_bound, config%i_lw_emiss_index, & - & config%wavenumber1_lw, config%wavenumber2_lw, & - & config%i_emiss_from_band_lw, config%lw_emiss_weights) + if (config%do_sw) then + call config%consolidate_sw_albedo_intervals + end if + if (config%do_lw) then + call config%consolidate_lw_emiss_intervals + end if if (config%do_clouds) then if (config%i_gas_model == IGasModelMonochromatic) then ! call setup_cloud_optics_mono(config) + elseif (config%use_general_cloud_optics) then + call setup_general_cloud_optics(config) else call setup_cloud_optics(config) @@ -147,7 +151,8 @@ use radiation_config - use radiation_gas, only : gas_type - use radiation_monochromatic, only : set_gas_units_mono => set_gas_units - use radiation_ifs_rrtm, only : set_gas_units_ifs => set_gas_units + use radiation_gas, only : gas_type + use radiation_monochromatic, only : set_gas_units_mono => set_gas_units + use radiation_ifs_rrtm, only : set_gas_units_ifs => set_gas_units + use radiation_ecckd_interface, only : set_gas_units_ecckd => set_gas_units type(config_type), intent(in) :: config @@ -156,4 +161,6 @@ if (config%i_gas_model == IGasModelMonochromatic) then call set_gas_units_mono(gas) + elseif (config%i_gas_model == IGasModelECCKD) then + call set_gas_units_ecckd(gas) else call set_gas_units_ifs(gas) @@ -207,6 +214,8 @@ & cloud_optics_mono => cloud_optics, & & add_aerosol_optics_mono => add_aerosol_optics - use radiation_ifs_rrtm, only : gas_optics + use radiation_ifs_rrtm, only : gas_optics_rrtmg => gas_optics + use radiation_ecckd_interface,only : gas_optics_ecckd => gas_optics use radiation_cloud_optics, only : cloud_optics + use radiation_general_cloud_optics, only : general_cloud_optics use radiation_aerosol_optics, only : add_aerosol_optics @@ -309,6 +318,12 @@ & od_lw, od_sw, ssa_sw, & & planck_hl, lw_emission, incoming_sw) + else if (config%i_gas_model == IGasModelIFSRRTMG) then + call gas_optics_rrtmg(ncol,nlev,istartcol,iendcol, config, & + & single_level, thermodynamics, gas, & + & od_lw, od_sw, ssa_sw, lw_albedo=lw_albedo, & + & planck_hl=planck_hl, lw_emission=lw_emission, & + & incoming_sw=incoming_sw) else - call gas_optics(ncol,nlev,istartcol,iendcol, config, & + call gas_optics_ecckd(ncol,nlev,istartcol,iendcol, config, & & single_level, thermodynamics, gas, & & od_lw, od_sw, ssa_sw, lw_albedo=lw_albedo, & @@ -330,4 +345,9 @@ call cloud_optics_mono(nlev, istartcol, iendcol, & & config, thermodynamics, cloud, & + & od_lw_cloud, ssa_lw_cloud, g_lw_cloud, & + & od_sw_cloud, ssa_sw_cloud, g_sw_cloud) + elseif (config%use_general_cloud_optics) then + call general_cloud_optics(nlev, istartcol, iendcol, & + & config, thermodynamics, cloud, & & od_lw_cloud, ssa_lw_cloud, g_lw_cloud, & & od_sw_cloud, ssa_sw_cloud, g_sw_cloud) @@ -351,8 +371,8 @@ end if else - g_sw = 0.0_jprb + g_sw(:,:,istartcol:iendcol) = 0.0_jprb if (config%do_lw_aerosol_scattering) then - ssa_lw = 0.0_jprb - g_lw = 0.0_jprb + ssa_lw(:,:,istartcol:iendcol) = 0.0_jprb + g_lw(:,:,istartcol:iendcol) = 0.0_jprb end if end if Index: LMDZ6/trunk/libf/phylmd/ecrad/radiation_liquid_optics_socrates.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad/radiation_liquid_optics_socrates.F90 (revision 4487) +++ LMDZ6/trunk/libf/phylmd/ecrad/radiation_liquid_optics_socrates.F90 (revision 4489) @@ -52,4 +52,5 @@ real(jprb), intent(out) :: od(nb), scat_od(nb), g(nb) + integer :: jb ! Local effective radius (m), after applying bounds real(jprb) :: re @@ -62,12 +63,16 @@ re = max(MinEffectiveRadius, min(re_in, MaxEffectiveRadius)) - od = lwp * (coeff(1:nb,1) + re*(coeff(1:nb,2) + re*coeff(1:nb,3))) & - & / (1.0_jprb + re*(coeff(1:nb,4) + re*(coeff(1:nb,5) & - & + re*coeff(1:nb,6)))) - scat_od = od * (1.0_jprb & - & - (coeff(1:nb,7) + re*(coeff(1:nb,8) + re*coeff(1:nb,9))) & - & / (1.0_jprb + re*(coeff(1:nb,10) + re*coeff(1:nb,11)))) - g = (coeff(1:nb,12) + re*(coeff(1:nb,13) + re*coeff(1:nb,14))) & - & / (1.0_jprb + re*(coeff(1:nb,15) + re*coeff(1:nb,16))) +! Added for DWD (2020) +!NEC$ shortloop + do jb = 1, nb + od(jb) = lwp * (coeff(jb,1) + re*(coeff(jb,2) + re*coeff(jb,3))) & + & / (1.0_jprb + re*(coeff(jb,4) + re*(coeff(jb,5) & + & + re*coeff(jb,6)))) + scat_od(jb) = od(jb) * (1.0_jprb & + & - (coeff(jb,7) + re*(coeff(jb,8) + re*coeff(jb,9))) & + & / (1.0_jprb + re*(coeff(jb,10) + re*coeff(jb,11)))) + g(jb) = (coeff(jb,12) + re*(coeff(jb,13) + re*coeff(jb,14))) & + & / (1.0_jprb + re*(coeff(jb,15) + re*coeff(jb,16))) + end do !if (lhook) call dr_hook('radiation_liquid_optics_socrates:calc_liq_optics_socrates',1,hook_handle) Index: LMDZ6/trunk/libf/phylmd/ecrad/radiation_matrix.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad/radiation_matrix.F90 (revision 4487) +++ LMDZ6/trunk/libf/phylmd/ecrad/radiation_matrix.F90 (revision 4489) @@ -550,6 +550,4 @@ real(jprb), dimension(iend) :: y2, y3 - integer :: j - ! associate (U11 => A(:,1,1), U12 => A(:,1,2), U13 => A(1,3)) ! LU decomposition of the *transpose* of A: Index: LMDZ6/trunk/libf/phylmd/ecrad/radiation_mcica_lw.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad/radiation_mcica_lw.F90 (revision 4487) +++ LMDZ6/trunk/libf/phylmd/ecrad/radiation_mcica_lw.F90 (revision 4489) @@ -157,7 +157,5 @@ ! transmittance etc at each model level do jlev = 1,nlev - ssa_total = ssa(:,jlev,jcol) - g_total = g(:,jlev,jcol) - call calc_two_stream_gammas_lw(ng, ssa_total, g_total, & + call calc_two_stream_gammas_lw(ng, ssa(:,jlev,jcol), g(:,jlev,jcol), & & gamma1, gamma2) call calc_reflectance_transmittance_lw(ng, & @@ -206,5 +204,6 @@ & config%cloud_inhom_decorr_scaling, cloud%fractional_std(jcol,:), & & config%pdf_sampler, od_scaling, total_cloud_cover, & - & is_beta_overlap=config%use_beta_overlap) + & use_beta_overlap=config%use_beta_overlap, & + & use_vectorizable_generator=config%use_vectorizable_generator) ! Store total cloud cover @@ -225,9 +224,11 @@ end if - od_cloud_new = od_scaling(:,jlev) & - & * od_cloud(config%i_band_from_reordered_g_lw,jlev,jcol) - od_total = od(:,jlev,jcol) + od_cloud_new - ssa_total = 0.0_jprb - g_total = 0.0_jprb + do jg = 1,ng + od_cloud_new(jg) = od_scaling(jg,jlev) & + & * od_cloud(config%i_band_from_reordered_g_lw(jg),jlev,jcol) + od_total(jg) = od(jg,jlev,jcol) + od_cloud_new(jg) + ssa_total(jg) = 0.0_jprb + g_total(jg) = 0.0_jprb + end do if (config%do_lw_cloud_scattering) then @@ -239,18 +240,23 @@ ! case that od_total > 0.0 and ssa_total > 0.0 but ! od_total*ssa_total == 0 due to underflow - scat_od_total = ssa(:,jlev,jcol)*od(:,jlev,jcol) & - & + ssa_cloud(config%i_band_from_reordered_g_lw,jlev,jcol) & - & * od_cloud_new - where (scat_od_total > 0.0_jprb) - g_total = (g(:,jlev,jcol)*ssa(:,jlev,jcol)*od(:,jlev,jcol) & - & + g_cloud(config%i_band_from_reordered_g_lw,jlev,jcol) & - & * ssa_cloud(config%i_band_from_reordered_g_lw,jlev,jcol) & - & * od_cloud_new) & - & / scat_od_total - end where - where (od_total > 0.0_jprb) - ssa_total = scat_od_total / od_total - end where + do jg = 1,ng + if (od_total(jg) > 0.0_jprb) then + scat_od_total(jg) = ssa(jg,jlev,jcol)*od(jg,jlev,jcol) & + & + ssa_cloud(config%i_band_from_reordered_g_lw(jg),jlev,jcol) & + & * od_cloud_new(jg) + ssa_total(jg) = scat_od_total(jg) / od_total(jg) + + if (scat_od_total(jg) > 0.0_jprb) then + g_total(jg) = (g(jg,jlev,jcol)*ssa(jg,jlev,jcol)*od(jg,jlev,jcol) & + & + g_cloud(config%i_band_from_reordered_g_lw(jg),jlev,jcol) & + & * ssa_cloud(config%i_band_from_reordered_g_lw(jg),jlev,jcol) & + & * od_cloud_new(jg)) & + & / scat_od_total(jg) + end if + end if + end do + else + do jg = 1,ng if (od_total(jg) > 0.0_jprb) then @@ -265,4 +271,5 @@ end if end do + end if @@ -301,7 +308,4 @@ ! Use adding method to compute fluxes but optimize for the ! presence of clear-sky layers -! call adding_ica_lw(ng, nlev, reflectance, transmittance, source_up, source_dn, & -! & emission(:,jcol), albedo(:,jcol), & -! & flux_up, flux_dn) call fast_adding_ica_lw(ng, nlev, reflectance, transmittance, source_up, source_dn, & & emission(:,jcol), albedo(:,jcol), & Index: LMDZ6/trunk/libf/phylmd/ecrad/radiation_mcica_sw.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad/radiation_mcica_sw.F90 (revision 4487) +++ LMDZ6/trunk/libf/phylmd/ecrad/radiation_mcica_sw.F90 (revision 4489) @@ -211,5 +211,6 @@ & config%cloud_inhom_decorr_scaling, cloud%fractional_std(jcol,:), & & config%pdf_sampler, od_scaling, total_cloud_cover, & - & is_beta_overlap=config%use_beta_overlap) + & use_beta_overlap=config%use_beta_overlap, & + & use_vectorizable_generator=config%use_vectorizable_generator) ! Store total cloud cover @@ -221,13 +222,14 @@ ! Compute combined gas+aerosol+cloud optical properties if (cloud%fraction(jcol,jlev) >= config%cloud_fraction_threshold) then - od_cloud_new = od_scaling(:,jlev) & - & * od_cloud(config%i_band_from_reordered_g_sw,jlev,jcol) - od_total = od(:,jlev,jcol) + od_cloud_new - ssa_total = 0.0_jprb - g_total = 0.0_jprb - ! In single precision we need to protect against the - ! case that od_total > 0.0 and ssa_total > 0.0 but - ! od_total*ssa_total == 0 due to underflow do jg = 1,ng + od_cloud_new(jg) = od_scaling(jg,jlev) & + & * od_cloud(config%i_band_from_reordered_g_sw(jg),jlev,jcol) + od_total(jg) = od(jg,jlev,jcol) + od_cloud_new(jg) + ssa_total(jg) = 0.0_jprb + g_total(jg) = 0.0_jprb + + ! In single precision we need to protect against the + ! case that od_total > 0.0 and ssa_total > 0.0 but + ! od_total*ssa_total == 0 due to underflow if (od_total(jg) > 0.0_jprb) then scat_od = ssa(jg,jlev,jcol)*od(jg,jlev,jcol) & Index: LMDZ6/trunk/libf/phylmd/ecrad/radiation_monochromatic.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad/radiation_monochromatic.F90 (revision 4487) +++ LMDZ6/trunk/libf/phylmd/ecrad/radiation_monochromatic.F90 (revision 4489) @@ -345,9 +345,9 @@ real(jprb), dimension(config%n_g_sw,nlev,istartcol:iendcol), intent(out) :: g_sw - g_sw = 0.0_jprb + g_sw(:,:,istartcol:iendcol) = 0.0_jprb if (config%do_lw_aerosol_scattering) then - ssa_lw = 0.0_jprb - g_lw = 0.0_jprb + ssa_lw(:,:,istartcol:iendcol) = 0.0_jprb + g_lw(:,:,istartcol:iendcol) = 0.0_jprb end if Index: LMDZ6/trunk/libf/phylmd/ecrad/radiation_pdf_sampler.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad/radiation_pdf_sampler.F90 (revision 4487) +++ LMDZ6/trunk/libf/phylmd/ecrad/radiation_pdf_sampler.F90 (revision 4489) @@ -1,3 +1,3 @@ -! radiation_pdf_sampler.F90 - Get samples from a lognormal distribution for McICA +! radiation_pdf_sampler.F90 - Get samples from a PDF for McICA ! ! (C) Copyright 2015- ECMWF. @@ -22,7 +22,8 @@ !--------------------------------------------------------------------- - ! Derived type for sampling from a lognormal distribution, used to - ! generate water content or optical depth scalings for use in the - ! Monte Carlo Independent Column Approximation (McICA) + ! Derived type for sampling from a lognormal or gamma distribution, + ! or other PDF, used to generate water content or optical depth + ! scalings for use in the Monte Carlo Independent Column + ! Approximation (McICA) type pdf_sampler_type ! Number of points in look-up table for cumulative distribution @@ -43,4 +44,6 @@ procedure :: sample => sample_from_pdf procedure :: masked_sample => sample_from_pdf_masked + procedure :: block_sample => sample_from_pdf_block + procedure :: masked_block_sample => sample_from_pdf_masked_block procedure :: deallocate => deallocate_pdf_sampler @@ -117,8 +120,8 @@ !--------------------------------------------------------------------- - ! Extract the value of a lognormal distribution with fractional - ! standard deviation "fsd" corresponding to the cumulative - ! distribution function value "cdf", and return it in val. Since this - ! is an elemental subroutine, fsd, cdf and val may be arrays. + ! Extract the value from a PDF with fractional standard deviation + ! "fsd" corresponding to the cumulative distribution function value + ! "cdf", and return it in val. Since this is an elemental + ! subroutine, fsd, cdf and val may be arrays. elemental subroutine sample_from_pdf(this, fsd, cdf, val) @@ -156,9 +159,8 @@ !--------------------------------------------------------------------- - ! For true elements of mask, extract the values of a lognormal - ! distribution with fractional standard deviation "fsd" - ! corresponding to the cumulative distribution function values - ! "cdf", and return in val. For false elements of mask, return zero - ! in val. + ! For true elements of mask, extract the values of a PDF with + ! fractional standard deviation "fsd" corresponding to the + ! cumulative distribution function values "cdf", and return in + ! val. For false elements of mask, return zero in val. subroutine sample_from_pdf_masked(this, nsamp, fsd, cdf, val, mask) @@ -208,3 +210,114 @@ end subroutine sample_from_pdf_masked + !--------------------------------------------------------------------- + ! Extract the values of a PDF with fractional standard deviation + ! "fsd" corresponding to the cumulative distribution function values + ! "cdf", and return in val. This version works on 2D blocks of data. + subroutine sample_from_pdf_block(this, nz, ng, fsd, cdf, val) + + class(pdf_sampler_type), intent(in) :: this + + ! Number of samples + integer, intent(in) :: nz, ng + + ! Fractional standard deviation (0 to 4) and cumulative + ! distribution function (0 to 1) + real(jprb), intent(in) :: fsd(nz), cdf(ng, nz) + + ! Sample from distribution + real(jprb), intent(out) :: val(:,:) + + ! Loop index + integer :: jz, jg + + ! Index to look-up table + integer :: ifsd, icdf + + ! Weights in bilinear interpolation + real(jprb) :: wfsd, wcdf + + do jz = 1,nz + do jg = 1,ng + if (cdf(jg, jz) > 0.0_jprb) then + ! Bilinear interpolation with bounds + wcdf = cdf(jg,jz) * (this%ncdf-1) + 1.0_jprb + icdf = max(1, min(int(wcdf), this%ncdf-1)) + wcdf = max(0.0_jprb, min(wcdf - icdf, 1.0_jprb)) + + wfsd = (fsd(jz)-this%fsd1) * this%inv_fsd_interval + 1.0_jprb + ifsd = max(1, min(int(wfsd), this%nfsd-1)) + wfsd = max(0.0_jprb, min(wfsd - ifsd, 1.0_jprb)) + + val(jg,jz)=(1.0_jprb-wcdf)*(1.0_jprb-wfsd) * this%val(icdf ,ifsd) & + & +(1.0_jprb-wcdf)* wfsd * this%val(icdf ,ifsd+1) & + & + wcdf *(1.0_jprb-wfsd) * this%val(icdf+1,ifsd) & + & + wcdf * wfsd * this%val(icdf+1,ifsd+1) + else + val(jg,jz) = 0.0_jprb + end if + end do + end do + + end subroutine sample_from_pdf_block + + !--------------------------------------------------------------------- + ! Extract the values of a PDF with fractional standard deviation + ! "fsd" corresponding to the cumulative distribution function values + ! "cdf", and return in val. This version works on 2D blocks of data. + subroutine sample_from_pdf_masked_block(this, nz, ng, fsd, cdf, val, mask) + + class(pdf_sampler_type), intent(in) :: this + + ! Number of samples + integer, intent(in) :: nz, ng + + ! Fractional standard deviation (0 to 4) and cumulative + ! distribution function (0 to 1) + real(jprb), intent(in) :: fsd(nz), cdf(ng, nz) + + ! Sample from distribution + real(jprb), intent(out) :: val(:,:) + + ! Mask + logical, intent(in), optional :: mask(nz) + + ! Loop index + integer :: jz, jg + + ! Index to look-up table + integer :: ifsd, icdf + + ! Weights in bilinear interpolation + real(jprb) :: wfsd, wcdf + + do jz = 1,nz + + if (mask(jz)) then + + do jg = 1,ng + if (cdf(jg, jz) > 0.0_jprb) then + ! Bilinear interpolation with bounds + wcdf = cdf(jg,jz) * (this%ncdf-1) + 1.0_jprb + icdf = max(1, min(int(wcdf), this%ncdf-1)) + wcdf = max(0.0_jprb, min(wcdf - icdf, 1.0_jprb)) + + wfsd = (fsd(jz)-this%fsd1) * this%inv_fsd_interval + 1.0_jprb + ifsd = max(1, min(int(wfsd), this%nfsd-1)) + wfsd = max(0.0_jprb, min(wfsd - ifsd, 1.0_jprb)) + + val(jg,jz)=(1.0_jprb-wcdf)*(1.0_jprb-wfsd) * this%val(icdf ,ifsd) & + & +(1.0_jprb-wcdf)* wfsd * this%val(icdf ,ifsd+1) & + & + wcdf *(1.0_jprb-wfsd) * this%val(icdf+1,ifsd) & + & + wcdf * wfsd * this%val(icdf+1,ifsd+1) + else + val(jg,jz) = 0.0_jprb + end if + end do + + end if + + end do + + end subroutine sample_from_pdf_masked_block + end module radiation_pdf_sampler Index: LMDZ6/trunk/libf/phylmd/ecrad/radiation_random_numbers.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad/radiation_random_numbers.F90 (revision 4489) +++ LMDZ6/trunk/libf/phylmd/ecrad/radiation_random_numbers.F90 (revision 4489) @@ -0,0 +1,304 @@ +! radiation_random_numbers.F90 - Generate random numbers for McICA solver +! +! (C) Copyright 2020- 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. +! +! Author: Robin Hogan +! Email: r.j.hogan@ecmwf.int +! +! The derived type "rng_type" is a random number generator that uses +! either (1) Fortran's built-in random_number function, or (2) a +! vectorized version of the MINSTD linear congruential generator. In +! the case of (2), an rng_type object is initialized with a seed that +! is used to fill up a state of "nmaxstreams" elements using the C++ +! minstd_rand0 version of the MINSTD linear congruential generator +! (LNG), which has the form istate[i+1] = mod(istate[i]*A0, M) from +! i=1 to i=nmaxstreams. Subsequent requests for blocks of nmaxstreams +! of random numbers use the C++ minstd_ran algorithm in a vectorizable +! form, which modifies the state elements via istate[i] <- +! mod(istate[i]*A, M). Uniform deviates are returned that normalize +! the state elements to the range 0-1. +! +! The MINSTD generator was coded because the random_numbers_mix +! generator in the IFS was found not to vectorize well on some +! hardware. I am no expert on random number generators, so my +! implementation should really be looked at and improved by someone +! who knows what they are doing. +! +! Reference for MINSTD: Park, Stephen K.; Miller, Keith +! W. (1988). "Random Number Generators: Good Ones Are Hard To Find" +! (PDF). Communications of the ACM. 31 (10): +! 1192–1201. doi:10.1145/63039.63042 +! +! Modifications +! 2022-12-01 R. Hogan Fixed zeroed state in single precision + +module radiation_random_numbers + + use parkind1, only : jprb, jprd, jpim, jpib + + implicit none + + public :: rng_type, IRngMinstdVector, IRngNative + + enum, bind(c) + enumerator IRngNative, & ! Built-in Fortran-90 RNG + & IRngMinstdVector ! Vector MINSTD algorithm + end enum + + ! Maximum number of random numbers that can be computed in one call + ! - this can be increased + integer(kind=jpim), parameter :: NMaxStreams = 512 + + ! A requirement of the generator is that the operation mod(A*X,M) is + ! performed with no loss of precision, so type used for A and X must + ! be able to hold the largest possible value of A*X without + ! overflowing, going negative or losing precision. The largest + ! possible value is 48271*2147483647 = 103661183124337. This number + ! can be held in either a double-precision real number, or an 8-byte + ! integer. Either may be used, but on some hardwares it has been + ! found that operations on double-precision reals are faster. Select + ! which you prefer by defining USE_REAL_RNG_STATE for double + ! precision, or undefining it for an 8-byte integer. +#define USE_REAL_RNG_STATE 1 + + ! Define RNG_STATE_TYPE based on USE_REAL_RNG_STATE, where jprd + ! refers to a double-precision number regardless of the working + ! precision described by jprb, while jpib describes an 8-byte + ! integer +#ifdef USE_REAL_RNG_STATE +#define RNG_STATE_TYPE real(kind=jprd) +#else +#define RNG_STATE_TYPE integer(kind=jpib) +#endif + + ! The constants used in the main random number generator + RNG_STATE_TYPE , parameter :: IMinstdA = 48271 + RNG_STATE_TYPE , parameter :: IMinstdM = 2147483647 + + ! An alternative value of A that can be used to initialize the + ! members of the state from a single seed + RNG_STATE_TYPE , parameter :: IMinstdA0 = 16807 + + ! Scaling to convert the state to a uniform deviate in the range 0 + ! to 1 in working precision + real(kind=jprb), parameter :: IMinstdScale = 1.0_jprb / real(IMinstdM,jprb) + + !--------------------------------------------------------------------- + ! A random number generator type: after being initialized with a + ! seed, type and optionally a number of vector streams, subsequent + ! calls to "uniform_distribution" are used to fill 1D or 2D arrays + ! with random numbers in a way that ought to be fast. + type rng_type + + integer(kind=jpim) :: itype = IRngNative + RNG_STATE_TYPE :: istate(NMaxStreams) + integer(kind=jpim) :: nmaxstreams = NMaxStreams + integer(kind=jpim) :: iseed + + contains + procedure :: initialize + procedure :: uniform_distribution_1d, & + & uniform_distribution_2d, & + & uniform_distribution_2d_masked + generic :: uniform_distribution => uniform_distribution_1d, & + & uniform_distribution_2d, & + & uniform_distribution_2d_masked + + end type rng_type + +contains + + !--------------------------------------------------------------------- + ! Initialize a random number generator, where "itype" may be either + ! IRngNative, indicating to use Fortran's native random_number + ! subroutine, or IRngMinstdVector, indicating to use the MINSTD + ! linear congruential generator (LCG). In the latter case + ! "nmaxstreams" should be provided indicating that random numbers + ! will be requested in blocks of this length. The generator is + ! seeded with "iseed". + subroutine initialize(this, itype, iseed, nmaxstreams) + + class(rng_type), intent(inout) :: this + integer(kind=jpim), intent(in), optional :: itype + integer(kind=jpim), intent(in), optional :: iseed + integer(kind=jpim), intent(in), optional :: nmaxstreams + + integer, allocatable :: iseednative(:) + integer :: nseed, jseed, jstr + real(jprd) :: rseed ! Note this must be in double precision + + if (present(itype)) then + this%itype = itype + else + this%itype = IRngNative + end if + + if (present(iseed)) then + this%iseed = iseed + else + this%iseed = 1 + end if + + if (present(nmaxstreams)) then + this%nmaxstreams = nmaxstreams + else + this%nmaxstreams = NMaxStreams + end if + + if (this%itype == IRngMinstdVector) then + ! ! OPTION 1: Use the C++ minstd_rand0 algorithm to populate the + ! ! state: this loop is not vectorizable because the state in + ! ! one stream depends on the one in the previous stream. + ! this%istate(1) = this%iseed + ! do jseed = 2,this%nmaxstreams + ! this%istate(jseed) = mod(IMinstdA0 * this%istate(jseed-1), IMinstdM) + ! end do + + ! OPTION 2: Use a modified (and vectorized) C++ minstd_rand0 algorithm to + ! populate the state + rseed = real(abs(this%iseed),jprd) + do jstr = 1,this%nmaxstreams + ! Note that nint returns an integer of type jpib (8-byte) + ! which may be converted to double if that is the type of + ! istate + this%istate(jstr) = nint(mod(rseed*jstr*(1.0_jprd-0.05_jprd*jstr & + & +0.005_jprd*jstr**2)*IMinstdA0, real(IMinstdM,jprd)),kind=jpib) + end do + + ! One warmup of the C++ minstd_rand algorithm + do jstr = 1,this%nmaxstreams + this%istate(jstr) = mod(IMinstdA * this%istate(jstr), IMinstdM) + end do + + else + ! Native generator by default + call random_seed(size=nseed) + allocate(iseednative(nseed)) + do jseed = 1,nseed + iseednative(jseed) = this%iseed + jseed - 1 + end do + call random_seed(put=iseednative) + deallocate(iseednative) + end if + + end subroutine initialize + + !--------------------------------------------------------------------- + ! Populate vector "randnum" with pseudo-random numbers; if rannum is + ! of length greater than nmaxstreams (specified when the generator + ! was initialized) then only the first nmaxstreams elements will be + ! assigned. + subroutine uniform_distribution_1d(this, randnum) + + class(rng_type), intent(inout) :: this + real(kind=jprb), intent(out) :: randnum(:) + + integer :: imax, i + + if (this%itype == IRngMinstdVector) then + + imax = min(this%nmaxstreams, size(randnum)) + + ! C++ minstd_rand algorithm + do i = 1, imax + ! The following calculation is computed entirely with 8-byte + ! numbers (whether real or integer) + this%istate(i) = mod(IMinstdA * this%istate(i), IMinstdM) + ! Scale the current state to a number in working precision + ! (jprb) between 0 and 1 + randnum(i) = IMinstdScale * this%istate(i) + end do + + else + + call random_number(randnum) + + end if + + end subroutine uniform_distribution_1d + + + !--------------------------------------------------------------------- + ! Populate matrix "randnum" with pseudo-random numbers; if the inner + ! dimension of rannum is of length greater than nmaxstreams + ! (specified when the generator was initialized) then only the first + ! nmaxstreams elements along this dimension will be assigned. + subroutine uniform_distribution_2d(this, randnum) + + class(rng_type), intent(inout) :: this + real(kind=jprb), intent(out) :: randnum(:,:) + + integer :: imax, jblock, i + + if (this%itype == IRngMinstdVector) then + + imax = min(this%nmaxstreams, size(randnum,1)) + + ! C++ minstd_ran algorithm + do jblock = 1,size(randnum,2) + ! These lines should be vectorizable + do i = 1, imax + this%istate(i) = mod(IMinstdA * this%istate(i), IMinstdM) + randnum(i,jblock) = IMinstdScale * this%istate(i) + end do + end do + + else + + call random_number(randnum) + + end if + + end subroutine uniform_distribution_2d + + !--------------------------------------------------------------------- + ! Populate matrix "randnum" with pseudo-random numbers; if the inner + ! dimension of rannum is of length greater than nmaxstreams + ! (specified when the generator was initialized) then only the first + ! nmaxstreams elements along this dimension will be assigned. This + ! version only operates on outer dimensions for which "mask" is true. + subroutine uniform_distribution_2d_masked(this, randnum, mask) + + class(rng_type), intent(inout) :: this + real(kind=jprb), intent(inout) :: randnum(:,:) + logical, intent(in) :: mask(:) + + integer :: imax, jblock, i + + if (this%itype == IRngMinstdVector) then + + imax = min(this%nmaxstreams, size(randnum,1)) + + ! C++ minstd_ran algorithm + do jblock = 1,size(randnum,2) + if (mask(jblock)) then + ! These lines should be vectorizable + do i = 1, imax + this%istate(i) = mod(IMinstdA * this%istate(i), IMinstdM) + randnum(i,jblock) = IMinstdScale * this%istate(i) + end do + end if + end do + + else + + do jblock = 1,size(randnum,2) + if (mask(jblock)) then + call random_number(randnum(:,jblock)) + end if + end do + + end if + + end subroutine uniform_distribution_2d_masked + + +end module radiation_random_numbers + Index: LMDZ6/trunk/libf/phylmd/ecrad/radiation_save.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad/radiation_save.F90 (revision 4487) +++ LMDZ6/trunk/libf/phylmd/ecrad/radiation_save.F90 (revision 4489) @@ -33,5 +33,6 @@ ! thermodynamics object subroutine save_fluxes(file_name, config, thermodynamics, flux, & - & iverbose, is_hdf5_file, experiment_name) + & iverbose, is_hdf5_file, experiment_name, & + & is_double_precision) use yomhook, only : lhook, dr_hook @@ -50,4 +51,5 @@ integer, optional, intent(in) :: iverbose logical, optional, intent(in) :: is_hdf5_file + logical, optional, intent(in) :: is_double_precision character(len=*), optional, intent(in) :: experiment_name @@ -96,4 +98,9 @@ ! output file column varies most slowly so need to transpose call out_file%transpose_matrices(.true.) + + ! Set default precision for file, if specified + if (present(is_double_precision)) then + call out_file%double_precision(is_double_precision) + end if ! Spectral fluxes in memory are dimensioned (nband,ncol,nlev), but @@ -885,5 +892,5 @@ & dim2_name="column", dim1_name="level", & & units_str="m", long_name="Ice effective radius") - if (allocated(cloud%re_ice)) then + if (associated(cloud%re_ice)) then call out_file%define_variable("re_ice", & & dim2_name="column", dim1_name="level", & @@ -966,5 +973,5 @@ call out_file%put("q_ice", cloud%q_ice) call out_file%put("re_liquid", cloud%re_liq) - if (allocated(cloud%re_ice)) then + if (associated(cloud%re_ice)) then call out_file%put("re_ice", cloud%re_ice) end if Index: LMDZ6/trunk/libf/phylmd/ecrad/radiation_scheme.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad/radiation_scheme.F90 (revision 4487) +++ LMDZ6/trunk/libf/phylmd/ecrad/radiation_scheme.F90 (revision 4489) @@ -13,16 +13,15 @@ SUBROUTINE RADIATION_SCHEME & ! Inputs - & (KIDIA, KFDIA, KLON, KLEV, KAEROLMDZ, NSW, & + & (KIDIA, KFDIA, KLON, KLEV, KAEROSOL, NSW, & & IDAY, TIME, & & PSOLAR_IRRADIANCE, & - & PMU0, PTEMPERATURE_SKIN, PALBEDO_DIF, PALBEDO_DIR, & + & PMU0, PTEMPERATURE_SKIN, & + & PALBEDO_DIF, PALBEDO_DIR, & & PEMIS, PEMIS_WINDOW, & - & PCCN_LAND, PCCN_SEA, & - & PGELAM, PGEMU, PLAND_SEA_MASK, & - & PPRESSURE, PTEMPERATURE, & + & PGELAM, PGEMU, & & PPRESSURE_H, PTEMPERATURE_H, PQ, PQSAT, & & PCO2, PCH4, PN2O, PNO2, PCFC11, PCFC12, PHCFC22, & & PCCL4, PO3, PO2, & - & PCLOUD_FRAC, PQ_LIQUID, PQ_ICE, PQ_RAIN, PQ_SNOW, & + & PCLOUD_FRAC, PQ_LIQUID, PQ_ICE, PQ_SNOW, & & ZRE_LIQUID_UM, ZRE_ICE_UM, & & PAEROSOL_OLD, PAEROSOL, & @@ -117,9 +116,10 @@ INTEGER(KIND=JPIM),INTENT(IN) :: KLEV ! Number of levels !INTEGER, INTENT(IN) :: KLON, KLEV -INTEGER(KIND=JPIM),INTENT(IN) :: KAEROLMDZ ! Number of aerosol types +!INTEGER(KIND=JPIM),INTENT(IN) :: KAEROLMDZ ! Number of aerosol types +INTEGER(KIND=JPIM),INTENT(IN) :: KAEROSOL INTEGER(KIND=JPIM),INTENT(IN) :: NSW ! Numbe of bands ! AI ATTENTION -INTEGER, PARAMETER :: KAEROSOL = 12 +!INTEGER, PARAMETER :: KAEROSOL = 12 ! *** Single-level fields @@ -139,9 +139,9 @@ REAL(KIND=JPRB), INTENT(IN) :: PGEMU(KLON) ! Land-sea mask -REAL(KIND=JPRB), INTENT(IN) :: PLAND_SEA_MASK(KLON) +!REAL(KIND=JPRB), INTENT(IN) :: PLAND_SEA_MASK(KLON) ! *** Variables on full levels -REAL(KIND=JPRB), INTENT(IN) :: PPRESSURE(KLON,KLEV) ! (Pa) -REAL(KIND=JPRB), INTENT(IN) :: PTEMPERATURE(KLON,KLEV) ! (K) +!REAL(KIND=JPRB), INTENT(IN) :: PPRESSURE(KLON,KLEV) ! (Pa) +!REAL(KIND=JPRB), INTENT(IN) :: PTEMPERATURE(KLON,KLEV) ! (K) ! *** Variables on half levels REAL(KIND=JPRB), INTENT(IN) :: PPRESSURE_H(KLON,KLEV+1) ! (Pa) @@ -167,5 +167,5 @@ REAL(KIND=JPRB), INTENT(IN) :: PQ_LIQUID(KLON,KLEV) REAL(KIND=JPRB), INTENT(IN) :: PQ_ICE(KLON,KLEV) -REAL(KIND=JPRB), INTENT(IN) :: PQ_RAIN(KLON,KLEV) +!REAL(KIND=JPRB), INTENT(IN) :: PQ_RAIN(KLON,KLEV) REAL(KIND=JPRB), INTENT(IN) :: PQ_SNOW(KLON,KLEV) @@ -174,6 +174,6 @@ REAL(KIND=JPRB), INTENT(IN) :: PAEROSOL(KLON,KLEV,KAEROSOL) -REAL(KIND=JPRB), INTENT(IN) :: PCCN_LAND(KLON) -REAL(KIND=JPRB), INTENT(IN) :: PCCN_SEA(KLON) +!REAL(KIND=JPRB), INTENT(IN) :: PCCN_LAND(KLON) +!REAL(KIND=JPRB), INTENT(IN) :: PCCN_SEA(KLON) !AI mars 2021 @@ -313,6 +313,6 @@ if (lprint_input) then print*,'********** Verification des entrees *************' - print*,'KIDIA, KFDIA, KLON, KLEV, KAEROLMDZ, NSW =', & - KIDIA, KFDIA, KLON, KLEV, KAEROLMDZ, NSW + print*,'KIDIA, KFDIA, KLON, KLEV, KAEROSOL, NSW =', & + KIDIA, KFDIA, KLON, KLEV, KAEROSOL, NSW print*,'IDAY, TIME =', IDAY, TIME print*,'PSOLAR_IRRADIANCE =', PSOLAR_IRRADIANCE @@ -320,8 +320,5 @@ print*,'PTEMPERATURE_SKIN =',PTEMPERATURE_SKIN print*,'PEMIS, PEMIS_WINDOW =', PEMIS, PEMIS_WINDOW - print*,'PCCN_LAND, PCCN_SEA =', PCCN_LAND, PCCN_SEA print*,'PGELAM, PGEMU =', PGELAM, PGEMU - print*,'PPRESSURE =', PPRESSURE - print*,'PTEMPERATURE =', PTEMPERATURE print*,'PPRESSURE_H =', PPRESSURE_H print*,'PTEMPERATURE_H =', PTEMPERATURE_H @@ -331,6 +328,6 @@ PCO2, PCH4, PN2O, PNO2, PCFC11, PCFC12, PHCFC22, PCCL4 print*,'PO3 =',PO3 - print*,'PCLOUD_FRAC, PQ_LIQUID, PQ_ICE, PQ_RAIN, PQ_SNOW =', & - PCLOUD_FRAC, PQ_LIQUID, PQ_ICE, PQ_RAIN, PQ_SNOW + print*,'PCLOUD_FRAC, PQ_LIQUID, PQ_ICE, PQ_SNOW =', & + PCLOUD_FRAC, PQ_LIQUID, PQ_ICE, PQ_SNOW print*,'ZRE_LIQUID_UM, ZRE_ICE_UM =', & ZRE_LIQUID_UM, ZRE_ICE_UM @@ -407,9 +404,10 @@ ! Alternative approximate version using temperature and pressure from ! the thermodynamics structure -CALL thermodynamics%calc_saturation_wrt_liquid(KIDIA, KFDIA) +!CALL thermodynamics%calc_saturation_wrt_liquid(KIDIA, KFDIA) +!AI ATTENTION +thermodynamics%h2o_sat_liq = PQSAT print*,'********** SINGLE LEVEL VARS **********************************' !AI ATTENTION -!thermodynamics%h2o_sat_liq = PQSAT ! Set single-level fileds single_level%solar_irradiance = PSOLAR_IRRADIANCE @@ -510,9 +508,9 @@ print*,'******** AEROSOLS (allocate + input) **************************************' -IF (NAERMACC > 0) THEN +!IF (NAERMACC > 0) THEN CALL aerosol%allocate(KLON, 1, KLEV, KAEROSOL) ! MACC climatology -ELSE - CALL aerosol%allocate(KLON, 1, KLEV, 6) ! Tegen climatology -ENDIF +!ELSE +! CALL aerosol%allocate(KLON, 1, KLEV, 6) ! Tegen climatology +!ENDIF ! Compute the dry mass of each layer neglecting humidity effects, in ! kg m-2, needed to scale some of the aerosol inputs @@ -644,4 +642,6 @@ ! Compute UV fluxes as weighted sum of appropriate shortwave bands +!AI ATTENTION +if (0.eq.1) then PFLUX_UV (KIDIA:KFDIA) = 0.0_JPRB DO JBAND = 1,NWEIGHT_UV @@ -660,5 +660,5 @@ & * flux%sw_dn_surf_clear_band(IBAND_PAR(JBAND),KIDIA:KFDIA) ENDDO - +endif ! Compute effective broadband emissivity ZBLACK_BODY_NET_LW = flux%lw_dn(KIDIA:KFDIA,KLEV+1) & @@ -679,4 +679,5 @@ !AI ATTENTION !IF (YRERAD%LAPPROXSWUPDATE) THEN +if (0.eq.1) then IF (rad_config%do_surface_sw_spectral_flux) THEN PSWDIFFUSEBAND(KIDIA:KFDIA,:) = 0.0_JPRB @@ -693,5 +694,5 @@ ENDDO ENDIF - +endif CALL single_level%deallocate CALL thermodynamics%deallocate Index: LMDZ6/trunk/libf/phylmd/ecrad/radiation_setup.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad/radiation_setup.F90 (revision 4487) +++ LMDZ6/trunk/libf/phylmd/ecrad/radiation_setup.F90 (revision 4489) @@ -69,5 +69,5 @@ CONTAINS - ! This routine copies information between the IFS radiation + ! This routine copies information between the LMDZ radiation ! configuration (stored in global variables) and the radiation ! configuration of the modular radiation scheme (stored in @@ -75,16 +75,20 @@ ! to print lots of information during the setup stage (default is ! no). +! AI At the end of the routine, the parameters are read in namelist +! SUBROUTINE SETUP_RADIATION_SCHEME(LOUTPUT) USE YOMHOOK, ONLY : LHOOK, DR_HOOK +! AI (propre a IFS) ! USE YOMLUN, ONLY : NULNAM, NULOUT, NULERR USE YOMLUN, ONLY : NULOUT, NULERR USE YOESRTWN, ONLY : NMPSRTM -! AI ATTENTION +! AI ATTENTION (propre a IFS) ! USE YOERAD, ONLY : YRERAD USE radiation_interface, ONLY : setup_radiation - USE radiation_aerosol_optics, ONLY : dry_aerosol_sw_mass_extinction - +! USE radiation_aerosol_optics, ONLY : dry_aerosol_sw_mass_extinction + +! AI (propre a IFS) !#include "posname.intfb.h" @@ -143,4 +147,5 @@ ! Do we do Hogan and Bozzo (2014) approximate longwave updates? ! AI ATTENTION (ifs : ) + ! AI (propre a IFS) ! rad_config%do_lw_derivatives = YRERAD%LAPPROXLWUPDATE rad_config%do_lw_derivatives = .false. @@ -161,6 +166,5 @@ ! *** SETUP GAS OPTICS *** - ! Assume IFS has already set-up RRTM, so the setup_radiation - ! routine below does not have to (ifs : F) +! routine below does not have to (ifs : F) print*,'i_gas_model =',rad_config%i_gas_model rad_config%do_setup_ifsrrtm = .TRUE. @@ -174,7 +178,4 @@ ! AI ATTENTION ! Choix offline : liquid_model_name = "SOCRATES" -! IF (YRERAD%NLIQOPT == 2) THEN -! rad_config%i_liq_model = ILiquidModelSlingo -! ELSEIF (YRERAD%NLIQOPT == 3) THEN rad_config%i_liq_model = ILiquidModelSOCRATES if (lprint_setp) then @@ -182,25 +183,12 @@ endif -! ELSE -! WRITE(NULERR,'(a,i0)') 'Unavailable liquid optics model in modular radiation scheme: NLIQOPT=', & -! & YRERAD%NLIQOPT -! CALL ABOR1('RADIATION_SETUP: error interpreting NLIQOPT') -! ENDIF - ! Setup ice optics ! Choix offline : ice_model_name = "Fu-IFS" -! IF (YRERAD%NICEOPT == 3) THEN rad_config%i_ice_model = IIceModelFu if (lprint_setp) then print*,'rad_config%i_ice_model =', rad_config%i_ice_model endif -! ELSEIF (YRERAD%NICEOPT == 4) THEN -! rad_config%i_ice_model = IIceModelBaran -! ELSE -! WRITE(NULERR,'(a,i0)') 'Unavailable ice optics model in modular radiation scheme: NICEOPT=', & -! & YRERAD%NICEOPT -! CALL ABOR1('RADIATION_SETUP: error interpreting NICEOPT') -! ENDIF - + +! AI (propre a IFS) ! For consistency with earlier versions of the IFS radiation ! scheme, we perform shortwave delta-Eddington scaling *after* the @@ -215,4 +203,5 @@ endif +! AI (propre a IFS) ! Use Exponential-Exponential cloud overlap to match original IFS ! implementation of Raisanen cloud generator @@ -230,64 +219,4 @@ endif -! IF (YRERAD%NAERMACC > 0) THEN - ! Using MACC climatology - in this case the aerosol optics file - ! will be chosen automatically - - ! 12 IFS aerosol classes: 1-3 Sea salt, 4-6 Boucher desert dust, - ! 7 hydrophilic organics, 8 hydrophobic organics, 9&10 - ! hydrophobic black carbon, 11 ammonium sulphate, 12 inactive - ! SO2 - rad_config%n_aerosol_types = 12 - if (lprint_setp) then - print*,'rad_config%n_aerosol_types =', rad_config%n_aerosol_types - endif - - ! Indices to the aerosol optical properties in - ! aerosol_ifs_rrtm_*.nc, for each class, where negative numbers - ! index hydrophilic aerosol types and positive numbers index - ! hydrophobic aerosol types - rad_config%i_aerosol_type_map = 0 ! There can be up to 256 types -! if (lprint_setp) then -! print*,'rad_config%i_aerosol_type_map =', rad_config%i_aerosol_type_map -! endif - - rad_config%i_aerosol_type_map(1:12) = (/ & - & -1, & ! Sea salt, size bin 1 (OPAC) - & -2, & ! Sea salt, size bin 2 (OPAC) - & -3, & ! Sea salt, size bin 3 (OPAC) - & 7, & ! Desert dust, size bin 1 (Woodward 2001) - & 8, & ! Desert dust, size bin 2 (Woodward 2001) - & 9, & ! Desert dust, size bin 3 (Woodward 2001) - & -4, & ! Hydrophilic organic matter (OPAC) - & 10, & ! Hydrophobic organic matter (OPAC) - & 11, & ! Black carbon (Boucher) - & 11, & ! Black carbon (Boucher) - & -5, & ! Ammonium sulphate (OPAC) - & 14 /) ! Stratospheric sulphate (hand edited from OPAC) -! if (lprint_setp) then -! print*,'rad_config%i_aerosol_type_map =', rad_config%i_aerosol_type_map -! endif - - ! Background aerosol mass-extinction coefficients are obtained - ! after the configuration files have been read - see later in - ! this routine. - -! ELSE - ! Using Tegen climatology -! rad_config%n_aerosol_types = 6 -! rad_config%i_aerosol_type_map = 0 ! There can be up to 256 types -! rad_config%i_aerosol_type_map(1:6) = (/ & -! & 1, & ! Continental background -! & 2, & ! Maritime -! & 3, & ! Desert -! & 4, & ! Urban - ! & 5, & ! Volcanic active -! & 6 /) ! Stratospheric background - - ! Manually set the aerosol optics file name (the directory will - ! be added automatically) -! rad_config%aerosol_optics_override_file_name = 'aerosol_ifs_rrtm_tegen.nc' -! ENDIF - ! *** SETUP SOLVER *** @@ -300,8 +229,4 @@ ! Select longwave solver ! AI ATTENTION -! SELECT CASE (YRERAD%NLWSOLVER) -! CASE(0) -! rad_config%i_solver_lw = ISolverMcICA -! CASE(1) rad_config%i_solver_lw = ISolverSpartacus if (lprint_setp) then @@ -309,36 +234,8 @@ endif -! CASE(2) -! rad_config%i_solver_lw = ISolverSpartacus -! rad_config%do_3d_effects = .TRUE. -! CASE DEFAULT -! WRITE(NULERR,'(a,i0)') 'Unknown value for NLWSOLVER: ', YRERAD%NLWSOLVER -! CALL ABOR1('RADIATION_SETUP: error interpreting NLWSOLVER') -! END SELECT - - ! Select shortwave solver -! SELECT CASE (YRERAD%NSWSOLVER) -! CASE(0) -! rad_config%i_solver_sw = ISolverMcICA -! CASE(1) rad_config%i_solver_sw = ISolverSpartacus if (lprint_setp) then print*,'rad_config%i_solver_sw =', rad_config%i_solver_sw endif - -! rad_config%do_3d_effects = .FALSE. -! IF (YRERAD%NLWSOLVER == 2) THEN -! CALL ABOR1('RADIATION_SETUP: cannot represent 3D effects in LW but not SW') -! ENDIF -! CASE(2) -! rad_config%i_solver_sw = ISolverSpartacus -! rad_config%do_3d_effects = .TRUE. -! IF (YRERAD%NLWSOLVER == 1) THEN -! CALL ABOR1('RADIATION_SETUP: cannot represent 3D effects in SW but not LW') -! ENDIF -! CASE DEFAULT -! WRITE(NULERR,'(a,i0)') 'Unknown value for NSWSOLVER: ', YRERAD%NSWSOLVER -! CALL ABOR1('RADIATION_SETUP: error interpreting NSWSOLVER') -! END SELECT ! SPARTACUS solver requires delta scaling to be done separately @@ -357,17 +254,4 @@ rad_config%do_lw_aerosol_scattering endif - -! SELECT CASE (YRERAD%NLWSCATTERING) -! CASE(1) -! rad_config%do_lw_cloud_scattering = .TRUE. -! CASE(2) -! rad_config%do_lw_cloud_scattering = .TRUE. -! IF (YRERAD%NAERMACC > 0) THEN - ! Tegen climatology omits data required to do longwave - ! scattering by aerosols, so only turn this on with a more - ! recent scattering database -! ENDIF -! END SELECT - ! *** IMPLEMENT SETTINGS *** @@ -379,23 +263,8 @@ ! variables in the NAERAD namelist available in the YRERAD ! structure. -! CALL POSNAME(NULNAM, 'RADIATION', ISTAT) -! SELECT CASE (ISTAT) -! CASE(0) -! CALL rad_config%read(unit=NULNAM) -! CASE(1) -! WRITE(NULOUT,'(a)') 'Namelist RADIATION not found, using settings from NAERAD only' -! CASE DEFAULT -! CALL ABOR1('RADIATION_SETUP: error reading RADIATION section of namelist file') -! END SELECT - -! AI ATTENTION test + +! AI ATTENTION (parameters read in namelist file) file_name="namelist_ecrad" call rad_config%read(file_name=file_name) - - ! Print configuration -! IF (IVERBOSESETUP > 1) THEN -! WRITE(NULOUT,'(a)') 'Radiation scheme settings:' -! CALL rad_config%print(IVERBOSE=IVERBOSESETUP) -! ENDIF ! Use configuration data to set-up radiation scheme, including @@ -409,10 +278,5 @@ ! results... ! Note that NMPSRTM(:)=(/ 6, 6, 5, 5, 5, 5, 5, 4, 4, 3, 2, 2, 1, 6 /) -! AI -!! NMPSRTM(:)=(/ 6, 6, 5, 5, 5, 5, 5, 4, 4, 3, 2, 2, 1, 6 /) -!! rad_config%i_albedo_from_band_sw = NMPSRTM -! call rad_config%define_sw_albedo_intervals(6, & -! & (/ 0.25e-6_jprb, 0.44e-6_jprb, 1.19e-6_jprb, & -! & 2.38e-6_jprb, 4.00e-6_jprb /), (/ 1,2,3,4,5,6 /)) +! AI (6 albedo SW bands) call rad_config%define_sw_albedo_intervals(6, & & [0.25e-6_jprb, 0.44e-6_jprb, 0.69e-6_jprb, & @@ -422,5 +286,5 @@ ! outside and inside the window region of the spectrum ! rad_config%i_emiss_from_band_lw = (/ 1,1,1,1,1,2,2,2,1,1,1,1,1,1,1,1 /) -! AI +! AI ATTENTION ????? !! call rad_config%define_lw_emiss_intervals(3, & !! & (/ 8.0e-6_jprb,13.0e-6_jprb /), (/ 1,2,1 /)) @@ -432,4 +296,20 @@ & NWEIGHT_PAR, IBAND_PAR, WEIGHT_PAR, & & 'photosynthetically active radiation, PAR') + + rad_config%i_aerosol_type_map(1:13) = (/ & + & -1, & ! Sea salt, size bin 1 (OPAC) + & -2, & ! Sea salt, size bin 2 (OPAC) + & -3, & ! Sea salt, size bin 3 (OPAC) + & -4, & ! Hydrophilic organic matter (OPAC) + & -5, & ! Ammonium sulphate (OPAC) + & -6, & + & -7, & + & 1, & + & 2, & + & 3, & + & -8, & + & -9, & + & 4 /) ! Stratospheric sulphate (hand edited from OPAC) + rad_config%aerosol_optics_override_file_name = 'aerosol_optics_lmdz.nc' ! IF (YRERAD%NAERMACC > 0) THEN Index: LMDZ6/trunk/libf/phylmd/ecrad/radiation_single_level.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad/radiation_single_level.F90 (revision 4487) +++ LMDZ6/trunk/libf/phylmd/ecrad/radiation_single_level.F90 (revision 4489) @@ -95,4 +95,5 @@ !--------------------------------------------------------------------- + ! Allocate the arrays of a single-level type subroutine allocate_single_level(this, ncol, nalbedobands, nemisbands, & & use_sw_albedo_direct, is_simple_surface) @@ -142,4 +143,5 @@ !--------------------------------------------------------------------- + ! Deallocate the arrays of a single-level type subroutine deallocate_single_level(this) @@ -227,5 +229,5 @@ ! Temporary storage of albedo in ecRad bands real(jprb) :: sw_albedo_band(istartcol:iendcol, config%n_bands_sw) - real(jprb) :: lw_albedo_band (istartcol:iendcol, config%n_bands_lw) + real(jprb) :: lw_albedo_band(istartcol:iendcol, config%n_bands_lw) ! Number of albedo bands @@ -233,5 +235,5 @@ ! Loop indices for ecRad bands and albedo bands - integer :: jband, jalbedoband + integer :: jband, jalbedoband, jcol real(jprb) :: hook_handle @@ -239,63 +241,79 @@ if (lhook) call dr_hook('radiation_single_level:get_albedos',0,hook_handle) - ! Albedos/emissivities are stored in single_level in their own - ! spectral intervals and with column as the first dimension - if (config%use_canopy_full_spectrum_sw) then - ! Albedos provided in each g point - sw_albedo_diffuse = transpose(this%sw_albedo(istartcol:iendcol,:)) - if (allocated(this%sw_albedo_direct)) then - sw_albedo_direct = transpose(this%sw_albedo_direct(istartcol:iendcol,:)) - end if - elseif (.not. config%do_nearest_spectral_sw_albedo) then - ! Albedos averaged accurately to ecRad spectral bands - nalbedoband = size(config%sw_albedo_weights,1) - sw_albedo_band = 0.0_jprb - do jband = 1,config%n_bands_sw - do jalbedoband = 1,nalbedoband - if (config%sw_albedo_weights(jalbedoband,jband) /= 0.0_jprb) then - sw_albedo_band(istartcol:iendcol,jband) & - & = sw_albedo_band(istartcol:iendcol,jband) & - & + config%sw_albedo_weights(jalbedoband,jband) & - & * this%sw_albedo(istartcol:iendcol, jalbedoband) - end if - end do - end do - - sw_albedo_diffuse = transpose(sw_albedo_band(istartcol:iendcol, & - & config%i_band_from_reordered_g_sw)) - if (allocated(this%sw_albedo_direct)) then + if (config%do_sw) then + ! Albedos/emissivities are stored in single_level in their own + ! spectral intervals and with column as the first dimension + if (config%use_canopy_full_spectrum_sw) then + ! Albedos provided in each g point + if (size(this%sw_albedo,2) /= config%n_g_sw) then + write(nulerr,'(a,i0,a)') '*** Error: single_level%sw_albedo does not have the expected ', & + & config%n_g_sw, ' spectral intervals' + call radiation_abort() + end if + sw_albedo_diffuse = transpose(this%sw_albedo(istartcol:iendcol,:)) + if (allocated(this%sw_albedo_direct)) then + sw_albedo_direct = transpose(this%sw_albedo_direct(istartcol:iendcol,:)) + end if + else if (.not. config%do_nearest_spectral_sw_albedo) then + ! Albedos averaged accurately to ecRad spectral bands + nalbedoband = size(config%sw_albedo_weights,1) + if (size(this%sw_albedo,2) /= nalbedoband) then + write(nulerr,'(a,i0,a)') '*** Error: single_level%sw_albedo does not have the expected ', & + & nalbedoband, ' bands' + call radiation_abort() + end if + sw_albedo_band = 0.0_jprb do jband = 1,config%n_bands_sw do jalbedoband = 1,nalbedoband if (config%sw_albedo_weights(jalbedoband,jband) /= 0.0_jprb) then - sw_albedo_band(istartcol:iendcol,jband) & - & = sw_albedo_band(istartcol:iendcol,jband) & - & + config%sw_albedo_weights(jalbedoband,jband) & - & * this%sw_albedo_direct(istartcol:iendcol, jalbedoband) + do jcol = istartcol,iendcol + sw_albedo_band(jcol,jband) & + & = sw_albedo_band(jcol,jband) & + & + config%sw_albedo_weights(jalbedoband,jband) & + & * this%sw_albedo(jcol, jalbedoband) + end do end if end do end do - sw_albedo_direct = transpose(sw_albedo_band(istartcol:iendcol, & - & config%i_band_from_reordered_g_sw)) + + sw_albedo_diffuse = transpose(sw_albedo_band(istartcol:iendcol, & + & config%i_band_from_reordered_g_sw)) + if (allocated(this%sw_albedo_direct)) then + sw_albedo_band = 0.0_jprb + do jband = 1,config%n_bands_sw + do jalbedoband = 1,nalbedoband + if (config%sw_albedo_weights(jalbedoband,jband) /= 0.0_jprb) then + sw_albedo_band(istartcol:iendcol,jband) & + & = sw_albedo_band(istartcol:iendcol,jband) & + & + config%sw_albedo_weights(jalbedoband,jband) & + & * this%sw_albedo_direct(istartcol:iendcol, jalbedoband) + end if + end do + end do + sw_albedo_direct = transpose(sw_albedo_band(istartcol:iendcol, & + & config%i_band_from_reordered_g_sw)) + else + sw_albedo_direct = sw_albedo_diffuse + end if else - sw_albedo_direct = sw_albedo_diffuse + ! Albedos mapped less accurately to ecRad spectral bands + sw_albedo_diffuse = transpose(this%sw_albedo(istartcol:iendcol, & + & config%i_albedo_from_band_sw(config%i_band_from_reordered_g_sw))) + if (allocated(this%sw_albedo_direct)) then + sw_albedo_direct = transpose(this%sw_albedo_direct(istartcol:iendcol, & + & config%i_albedo_from_band_sw(config%i_band_from_reordered_g_sw))) + else + sw_albedo_direct = sw_albedo_diffuse + end if end if - else - ! Albedos mapped less accurately to ecRad spectral bands - sw_albedo_diffuse = transpose(this%sw_albedo(istartcol:iendcol, & - & config%i_albedo_from_band_sw(config%i_band_from_reordered_g_sw))) - if (allocated(this%sw_albedo_direct)) then - sw_albedo_direct = transpose(this%sw_albedo_direct(istartcol:iendcol, & - & config%i_albedo_from_band_sw(config%i_band_from_reordered_g_sw))) - else - sw_albedo_direct = sw_albedo_diffuse - end if - end if - - if (present(lw_albedo)) then + end if + + if (config%do_lw .and. present(lw_albedo)) then if (config%use_canopy_full_spectrum_lw) then if (config%n_g_lw /= size(this%lw_emissivity,2)) then - write(nulerr,'(a)') '*** Error: single_level%lw_emissivity has the wrong number of spectral intervals' - call radiation_abort() + write(nulerr,'(a,i0,a)') '*** Error: single_level%lw_emissivity does not have the expected ', & + & config%n_g_lw, ' spectral intervals' + call radiation_abort() end if lw_albedo = 1.0_jprb - transpose(this%lw_emissivity(istartcol:iendcol,:)) @@ -303,12 +321,19 @@ ! Albedos averaged accurately to ecRad spectral bands nalbedoband = size(config%lw_emiss_weights,1) + if (nalbedoband /= size(this%lw_emissivity,2)) then + write(nulerr,'(a,i0,a)') '*** Error: single_level%lw_emissivity does not have the expected ', & + & nalbedoband, ' bands' + call radiation_abort() + end if lw_albedo_band = 0.0_jprb do jband = 1,config%n_bands_lw do jalbedoband = 1,nalbedoband if (config%lw_emiss_weights(jalbedoband,jband) /= 0.0_jprb) then - lw_albedo_band(istartcol:iendcol,jband) & - & = lw_albedo_band(istartcol:iendcol,jband) & - & + config%lw_emiss_weights(jalbedoband,jband) & - & * (1.0_jprb-this%lw_emissivity(istartcol:iendcol, jalbedoband)) + do jcol = istartcol,iendcol + lw_albedo_band(jcol,jband) & + & = lw_albedo_band(jcol,jband) & + & + config%lw_emiss_weights(jalbedoband,jband) & + & * (1.0_jprb-this%lw_emissivity(jcol, jalbedoband)) + end do end if end do @@ -335,5 +360,5 @@ use yomhook, only : lhook, dr_hook - use radiation_config, only : out_of_bounds_1d, out_of_bounds_2d + use radiation_check, only : out_of_bounds_1d, out_of_bounds_2d class(single_level_type), intent(inout) :: this Index: LMDZ6/trunk/libf/phylmd/ecrad/radiation_spartacus_lw.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad/radiation_spartacus_lw.F90 (revision 4487) +++ LMDZ6/trunk/libf/phylmd/ecrad/radiation_spartacus_lw.F90 (revision 4489) @@ -66,5 +66,5 @@ use radiation_matrix use radiation_two_stream, only : calc_two_stream_gammas_lw, & - calc_reflectance_transmittance_lw, LwDiffusivity + calc_reflectance_transmittance_lw, LwDiffusivityWP use radiation_lw_derivatives, only : calc_lw_derivatives_matrix use radiation_constants, only : Pi, GasConstantDryAir, & @@ -615,10 +615,10 @@ planck_top(1:ng3D,nreg+jreg) = od_region(1:ng3D,jreg) & & *(1.0_jprb-ssa_region(1:ng3D,jreg))*region_fracs(jreg,jlev,jcol) & - & *planck_hl(1:ng3D,jlev,jcol)*LwDiffusivity + & *planck_hl(1:ng3D,jlev,jcol)*LwDiffusivityWP planck_top(1:ng3D,jreg) = -planck_top(1:ng3D,nreg+jreg) planck_diff(1:ng3D,nreg+jreg) = od_region(1:ng3D,jreg) & & * (1.0_jprb-ssa_region(1:ng3D,jreg))*region_fracs(jreg,jlev,jcol) & & * (planck_hl(1:ng3D,jlev+1,jcol) & - & -planck_hl(1:ng3D,jlev,jcol))*LwDiffusivity + & -planck_hl(1:ng3D,jlev,jcol))*LwDiffusivityWP planck_diff(1:ng3D,jreg) = -planck_diff(1:ng3D,nreg+jreg) end do Index: LMDZ6/trunk/libf/phylmd/ecrad/radiation_spartacus_sw.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad/radiation_spartacus_sw.F90 (revision 4487) +++ LMDZ6/trunk/libf/phylmd/ecrad/radiation_spartacus_sw.F90 (revision 4489) @@ -1303,5 +1303,5 @@ transfer_scaling = 1.0_jprb - (1.0_jprb - config%overhang_factor) & & * cloud%overlap_param(jcol,jlev-1) & - & * min(region_fracs(jreg,jlev,jcol), region_fracs(jreg,jlev-1,jcol)) + & * min(region_fracs(jreg,jlev,jcol), region_fracs(jreg,jlev-1,jcol)) & & / max(config%cloud_fraction_threshold, region_fracs(jreg,jlev,jcol)) do jreg4 = 1,nreg Index: LMDZ6/trunk/libf/phylmd/ecrad/radiation_spectral_definition.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad/radiation_spectral_definition.F90 (revision 4489) +++ LMDZ6/trunk/libf/phylmd/ecrad/radiation_spectral_definition.F90 (revision 4489) @@ -0,0 +1,902 @@ +! radiation_spectral_definition.F90 - Derived type to describe a spectral definition +! +! (C) Copyright 2020- 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. +! +! Author: Robin Hogan +! Email: r.j.hogan@ecmwf.int +! License: see the COPYING file for details +! + +module radiation_spectral_definition + + use parkind1, only : jprb + + implicit none + + public + + real(jprb), parameter :: SolarReferenceTemperature = 5777.0_jprb ! K + real(jprb), parameter :: TerrestrialReferenceTemperature = 273.15_jprb ! K + + !--------------------------------------------------------------------- + ! A derived type describing the contribution of the g points of a + ! correlated k-distribution gas-optics model from each part of the + ! spectrum. This is used primarily to map the cloud and aerosol + ! optical properties on to the gas g points. + type spectral_definition_type + + ! Spectral mapping of g points + + ! Number of wavenumber intervals + integer :: nwav = 0 + ! Number of k terms / g points + integer :: ng = 0 + ! Start and end wavenumber (cm-1), dimensioned (nwav) + real(jprb), allocatable :: wavenumber1(:) + real(jprb), allocatable :: wavenumber2(:) + ! Fraction of each g point in each wavenumber interval, + ! dimensioned (nwav, ng) + real(jprb), allocatable :: gpoint_fraction(:,:) + + ! Band information + + ! Number of bands + integer :: nband = 0 + ! Lower and upper bounds of wavenumber bands (cm-1), dimensioned + ! (nband) + real(jprb), allocatable :: wavenumber1_band(:) + real(jprb), allocatable :: wavenumber2_band(:) + ! Band (one based) to which each g point belongs + integer, allocatable :: i_band_number(:) + + contains + procedure :: read => read_spectral_definition + procedure :: allocate_bands_only + procedure :: deallocate + procedure :: find => find_wavenumber + procedure :: calc_mapping + procedure :: calc_mapping_from_bands + procedure :: calc_mapping_from_wavenumber_bands + procedure :: print_mapping_from_bands + procedure :: min_wavenumber, max_wavenumber + + end type spectral_definition_type + +contains + + !--------------------------------------------------------------------- + ! Read the description of a spectral definition from a NetCDF + ! file of the type used to describe an ecCKD model + subroutine read_spectral_definition(this, file) + + use easy_netcdf, only : netcdf_file + use yomhook, only : lhook, dr_hook + + class(spectral_definition_type), intent(inout) :: this + type(netcdf_file), intent(inout) :: file + + real(jprb) :: hook_handle + + if (lhook) call dr_hook('radiation_spectral_definition:read',0,hook_handle) + + ! Read spectral mapping of g points + call file%get('wavenumber1', this%wavenumber1) + call file%get('wavenumber2', this%wavenumber2) + call file%get('gpoint_fraction', this%gpoint_fraction) + + ! Read band information + call file%get('wavenumber1_band', this%wavenumber1_band) + call file%get('wavenumber2_band', this%wavenumber2_band) + call file%get('band_number', this%i_band_number) + + ! Band number is 0-based: add 1 + this%i_band_number = this%i_band_number + 1 + + this%nwav = size(this%wavenumber1) + this%ng = size(this%gpoint_fraction, 2); + this%nband = size(this%wavenumber1_band) + + if (lhook) call dr_hook('radiation_spectral_definition:read',1,hook_handle) + + end subroutine read_spectral_definition + + + !--------------------------------------------------------------------- + ! Store a simple band description by copying over the lower and + ! upper wavenumbers of each band + subroutine allocate_bands_only(this, wavenumber1, wavenumber2) + + use yomhook, only : lhook, dr_hook + + class(spectral_definition_type), intent(inout) :: this + real(jprb), dimension(:), intent(in) :: wavenumber1, wavenumber2 + + real(jprb) :: hook_handle + + if (lhook) call dr_hook('radiation_spectral_definition:allocate_bands_only',0,hook_handle) + + call this%deallocate() + + this%nband = size(wavenumber1) + allocate(this%wavenumber1_band(this%nband)) + allocate(this%wavenumber2_band(this%nband)) + this%wavenumber1_band = wavenumber1 + this%wavenumber2_band = wavenumber2 + + if (lhook) call dr_hook('radiation_spectral_definition:allocate_bands_only',1,hook_handle) + + end subroutine allocate_bands_only + + + !--------------------------------------------------------------------- + ! Deallocate memory inside a spectral definition object + subroutine deallocate(this) + + class(spectral_definition_type), intent(inout) :: this + + this%nwav = 0 + this%ng = 0 + this%nband = 0 + + if (allocated(this%wavenumber1)) deallocate(this%wavenumber1) + if (allocated(this%wavenumber2)) deallocate(this%wavenumber2) + if (allocated(this%wavenumber1_band)) deallocate(this%wavenumber1_band) + if (allocated(this%wavenumber2_band)) deallocate(this%wavenumber2_band) + if (allocated(this%gpoint_fraction)) deallocate(this%gpoint_fraction) + if (allocated(this%i_band_number)) deallocate(this%i_band_number) + + end subroutine deallocate + + + !--------------------------------------------------------------------- + ! Find the index to the highest wavenumber in the spectral + ! definition that is lower than or equal to "wavenumber", used for + ! implementing look-up tables + pure function find_wavenumber(this, wavenumber) + class(spectral_definition_type), intent(in) :: this + real(jprb), intent(in) :: wavenumber ! cm-1 + integer :: find_wavenumber + + if (wavenumber < this%wavenumber1(1) .or. wavenumber > this%wavenumber2(this%nwav)) then + ! Wavenumber not present + find_wavenumber = 0 + else + find_wavenumber = 1 + do while (wavenumber > this%wavenumber2(find_wavenumber) & + & .and. find_wavenumber < this%nwav) + find_wavenumber = find_wavenumber + 1 + end do + end if + end function find_wavenumber + + + !--------------------------------------------------------------------- + ! Compute a mapping matrix "mapping" that can be used in an + ! expression y=matmul(mapping,x) where x is a variable containing + ! optical properties at each input "wavenumber", and y is this + ! variable mapped on to the spectral intervals in the spectral + ! definition "this". Temperature (K) is used to generate a Planck + ! function to weight each wavenumber appropriately. + subroutine calc_mapping(this, temperature, wavenumber, mapping, use_bands) + + use yomhook, only : lhook, dr_hook + use radiation_io, only : nulerr, radiation_abort + + class(spectral_definition_type), intent(in) :: this + real(jprb), intent(in) :: temperature ! K + real(jprb), intent(in) :: wavenumber(:) ! cm-1 + real(jprb), allocatable, intent(inout) :: mapping(:,:) + logical, optional, intent(in) :: use_bands + + ! Spectral weights to apply, same length as wavenumber above + real(jprb), dimension(:), allocatable :: weight, planck_weight + + ! Wavenumbers (cm-1) marking triangle of influence of a cloud + ! spectral point + real(jprb) :: wavenum0, wavenum1, wavenum2 + + integer :: nwav ! Number of wavenumbers describing cloud + + ! Indices to wavenumber intervals in spectral definition structure + integer :: isd, isd0, isd1, isd2 + + ! Wavenumber index + integer :: iwav + + ! Loop indices + integer :: jg, jwav, jband + + logical :: use_bands_local + + real(jprb) :: hook_handle + + if (lhook) call dr_hook('radiation_spectral_definition:calc_mapping',0,hook_handle) + + if (present(use_bands)) then + use_bands_local = use_bands + else + use_bands_local = .false. + end if + + nwav = size(wavenumber) + + if (allocated(mapping)) then + deallocate(mapping) + end if + + ! Define the mapping matrix + if (use_bands_local) then + ! Cloud properties per band + + allocate(mapping(this%nband, nwav)) + allocate(weight(nwav)) + + ! Planck weight uses the wavenumbers of the cloud points + allocate(planck_weight(nwav)) + planck_weight = calc_planck_function_wavenumber(wavenumber, & + & temperature) + + do jband = 1,this%nband + weight = 0.0_jprb + do jwav = 1,nwav + ! Work out wavenumber range for which this cloud wavenumber + ! will be applicable + if (wavenumber(jwav) >= this%wavenumber1_band(jband) & + & .and. wavenumber(jwav) <= this%wavenumber2_band(jband)) then + if (jwav > 1) then + wavenum1 = max(this%wavenumber1_band(jband), & + & 0.5_jprb*(wavenumber(jwav-1)+wavenumber(jwav))) + else + wavenum1 = this%wavenumber1_band(jband) + end if + if (jwav < nwav) then + wavenum2 = min(this%wavenumber2_band(jband), & + & 0.5_jprb*(wavenumber(jwav)+wavenumber(jwav+1))) + else + wavenum2 = this%wavenumber2_band(jband) + end if + ! This cloud wavenumber is weighted by the wavenumber + ! range of its applicability multiplied by the Planck + ! function at an appropriate temperature + weight(jwav) = (wavenum2-wavenum1) * planck_weight(jwav) + end if + end do + if (sum(weight) <= 0.0_jprb) then + ! No cloud wavenumbers lie in the band; interpolate to + ! central wavenumber of band instead + if (wavenumber(1) >= this%wavenumber2_band(jband)) then + ! Band is entirely below first cloudy wavenumber + weight(1) = 1.0_jprb + else if (wavenumber(nwav) <= this%wavenumber1_band(jband)) then + ! Band is entirely above last cloudy wavenumber + weight(nwav) = 1.0_jprb + else + ! Find interpolating points + iwav = 2 + do while (wavenumber(iwav) < this%wavenumber2_band(jband)) + iwav = iwav+1 + end do + weight(iwav-1) = planck_weight(iwav-1) * (wavenumber(iwav) & + & - 0.5_jprb*(this%wavenumber2_band(jband)+this%wavenumber1_band(jband))) + weight(iwav) = planck_weight(iwav) * (-wavenumber(iwav-1) & + & + 0.5_jprb*(this%wavenumber2_band(jband)+this%wavenumber1_band(jband))) + end if + end if + mapping(jband,:) = weight / sum(weight) + end do + + deallocate(weight) + deallocate(planck_weight) + + else + ! Cloud properties per g-point + + if (this%ng == 0) then + write(nulerr,'(a)') '*** Error: requested cloud/aerosol mapping per g-point but only available per band' + call radiation_abort('Radiation configuration error') + end if + + allocate(mapping(this%ng, nwav)) + allocate(weight(this%nwav)) + allocate(planck_weight(this%nwav)) + + planck_weight = calc_planck_function_wavenumber(0.5_jprb & + & * (this%wavenumber1 + this%wavenumber2), & + & temperature) + + mapping = 0.0_jprb + ! Loop over wavenumbers representing cloud + do jwav = 1,nwav + ! Clear the weights. The weight says for one wavenumber in the + ! cloud file, what is its fractional contribution to each of + ! the spectral-definition intervals + weight = 0.0_jprb + + ! Cloud properties are linearly interpolated between each of + ! the nwav cloud points; therefore, the influence of a + ! particular cloud point extends as a triangle between + ! wavenum0 and wavenum2, peaking at wavenum1 + wavenum1 = wavenumber(jwav) + isd1 = this%find(wavenum1) + if (isd1 < 1) then + cycle + end if + if (jwav > 1) then + wavenum0 = wavenumber(jwav-1) + + ! Map triangle under (wavenum0,0) to (wavenum1,1) to the + ! wavenumbers in this%gpoint_fraction + isd0 = this%find(wavenum0) + if (isd0 == isd1) then + ! Triangle completely within the range + ! this%wavenumber1(isd0)-this%wavenumber2(isd0) + weight(isd0) = 0.5_jprb*(wavenum1-wavenum0) & + & / (this%wavenumber2(isd0)-this%wavenumber1(isd0)) + else + if (isd0 >= 1) then + ! Left part of triangle + weight(isd0) = 0.5_jprb * (this%wavenumber2(isd0)-wavenum0)**2 & + & / ((this%wavenumber2(isd0)-this%wavenumber1(isd0)) & + & *(wavenum1-wavenum0)) + end if + ! Right part of triangle (trapezium) +! weight(isd1) = 0.5_jprb * (wavenum1-this%wavenumber1(isd1)) & +! & * (wavenum1 + this%wavenumber1(isd1) - 2.0_jprb*wavenum0) & +! & / (wavenum1-wavenum0) + weight(isd1) = 0.5_jprb * (1.0_jprb & + & + (this%wavenumber1(isd1)-wavenum1)/(wavenum1-wavenum0)) & + & * (wavenum1-this%wavenumber1(isd1)) & + & / (this%wavenumber2(isd1)-this%wavenumber1(isd1)) + if (isd1-isd0 > 1) then + do isd = isd0+1,isd1-1 + ! Intermediate trapezia + weight(isd) = 0.5_jprb * (this%wavenumber1(isd)+this%wavenumber2(isd) & + & - 2.0_jprb*wavenum0) & + & / (wavenum1-wavenum0) + end do + end if + end if + + else + ! First cloud wavenumber: all wavenumbers in the spectral + ! definition below this will use the first one + if (isd1 >= 1) then + weight(1:isd1-1) = 1.0_jprb + weight(isd1) = (wavenum1-this%wavenumber1(isd1)) & + & / (this%wavenumber2(isd1)-this%wavenumber1(isd1)) + end if + end if + + if (jwav < nwav) then + wavenum2 = wavenumber(jwav+1) + + ! Map triangle under (wavenum1,1) to (wavenum2,0) to the + ! wavenumbers in this%gpoint_fraction + isd2 = this%find(wavenum2) + + if (isd1 == isd2) then + ! Triangle completely within the range + ! this%wavenumber1(isd1)-this%wavenumber2(isd1) + weight(isd1) = weight(isd1) + 0.5_jprb*(wavenum2-wavenum1) & + & / (this%wavenumber2(isd1)-this%wavenumber1(isd1)) + else + if (isd2 >= 1 .and. isd2 <= this%nwav) then + ! Right part of triangle + weight(isd2) = weight(isd2) + 0.5_jprb * (wavenum2-this%wavenumber1(isd2))**2 & + & / ((this%wavenumber2(isd2)-this%wavenumber1(isd2)) & + & *(wavenum2-wavenum1)) + end if + ! Left part of triangle (trapezium) +! weight(isd1) = weight(isd1) + 0.5_jprb * (this%wavenumber2(isd1)-wavenum1) & +! & * (wavenum1 + this%wavenumber2(isd1) - 2.0_jprb*wavenum2) & +! & / (wavenum2-wavenum1) + weight(isd1) = weight(isd1) + 0.5_jprb * (1.0_jprb & + & + (wavenum2-this%wavenumber2(isd1)) / (wavenum2-wavenum1)) & + & * (this%wavenumber2(isd1)-wavenum1) & + & / (this%wavenumber2(isd1)-this%wavenumber1(isd1)) + if (isd2-isd1 > 1) then + do isd = isd1+1,isd2-1 + ! Intermediate trapezia + weight(isd) = weight(isd) + 0.5_jprb * (2.0_jprb*wavenum2 & + & - this%wavenumber1(isd) - this%wavenumber2(isd)) & + & / (wavenum2-wavenum1) + end do + end if + end if + + else + ! Last cloud wavenumber: all wavenumbers in the spectral + ! definition above this will use the last one + if (isd1 <= this%nwav) then + weight(isd1+1:this%nwav) = 1.0_jprb + weight(isd1) = (this%wavenumber2(isd1)-wavenum1) & + & / (this%wavenumber2(isd1)-this%wavenumber1(isd1)) + end if + end if + + weight = weight * planck_weight + + do jg = 1,this%ng + mapping(jg, jwav) = sum(weight * this%gpoint_fraction(:,jg)) + end do + + end do + + deallocate(weight) + deallocate(planck_weight) + + ! Normalize mapping matrix + do jg = 1,this%ng + mapping(jg,:) = mapping(jg,:) * (1.0_jprb/sum(mapping(jg,:))) + end do + + end if + + if (lhook) call dr_hook('radiation_spectral_definition:calc_mapping',1,hook_handle) + + end subroutine calc_mapping + + + !--------------------------------------------------------------------- + ! Under normal operation (if use_fluxes is .false. or not present), + ! compute a mapping matrix "mapping" that can be used in an + ! expression y=matmul(mapping^T,x) where x is a variable containing + ! optical properties in input bands (e.g. albedo in shortwave albedo + ! bands), and y is this variable mapped on to the spectral intervals + ! in the spectral definition "this". Temperature (K) is used to + ! generate a Planck function to weight each input band + ! appropriately. Note that "mapping" is here transposed from the + ! convention in the calc_mapping routine. Under the alternative + ! operation (if use_fluxes is present and .true.), the mapping works + ! in the reverse sense: if y contains fluxes in each ecRad band or + ! g-point, then x=matmul(mapping,y) would return fluxes in x + ! averaged to user-supplied "input" bands. In this version, the + ! bands are described by their wavelength bounds (wavelength_bound, + ! which must be increasing and exclude the end points) and the index + ! of the mapping matrix that each band corresponds to (i_intervals, + ! which has one more element than wavelength_bound and can have + ! duplicated values if an albedo/emissivity value is to be + ! associated with more than one discontinuous ranges of the + ! spectrum). + subroutine calc_mapping_from_bands(this, temperature, & + & wavelength_bound, i_intervals, mapping, use_bands, use_fluxes) + + use yomhook, only : lhook, dr_hook + use radiation_io, only : nulerr, radiation_abort + + class(spectral_definition_type), intent(in) :: this + real(jprb), intent(in) :: temperature ! K + ! Monotonically increasing wavelength bounds (m) between + ! intervals, not including the outer bounds (which are assumed to + ! be zero and infinity) + real(jprb), intent(in) :: wavelength_bound(:) + ! The albedo band indices corresponding to each interval + integer, intent(in) :: i_intervals(:) + real(jprb), allocatable, intent(inout) :: mapping(:,:) + logical, optional, intent(in) :: use_bands + logical, optional, intent(in) :: use_fluxes + + ! Planck function and central wavenumber of each wavenumber + ! interval of the spectral definition + real(jprb) :: planck(this%nwav) ! W m-2 (cm-1)-1 + real(jprb) :: wavenumber_mid(this%nwav) ! cm-1 + + real(jprb), allocatable :: mapping_denom(:,:) + + real(jprb) :: wavenumber1_bound, wavenumber2_bound + + ! To work out weights we sample the Planck function at five points + ! in the interception between an input interval and a band, and + ! use the Trapezium Rule + integer, parameter :: nsample = 5 + integer :: isamp + real(jprb), dimension(nsample) :: wavenumber_sample, planck_sample + real(jprb), parameter :: weight_sample(nsample) & + & = [0.5_jprb, 1.0_jprb, 1.0_jprb, 1.0_jprb, 0.5_jprb] + + ! Index of input value corresponding to each wavenumber interval + integer :: i_input(this%nwav) + + ! Number of albedo/emissivity values that will be provided, some + ! of which may span discontinuous intervals in wavelength space + integer :: ninput + + ! Number of albedo/emissivity intervals represented, where some + ! may be grouped to have the same value of albedo/emissivity (an + ! example is in the thermal infrared where classically the IFS has + ! ninput=2 and ninterval=3, since only two emissivities are + ! provided representing (1) the infrared window, and (2) the + ! intervals to each side of the infrared window. + integer :: ninterval + + logical :: use_bands_local, use_fluxes_local + + ! Loop indices + integer :: jg, jband, jin, jint + + real(jprb) :: hook_handle + + if (lhook) call dr_hook('radiation_spectral_definition:calc_mapping_from_bands',0,hook_handle) + + if (present(use_bands)) then + use_bands_local = use_bands + else + use_bands_local = .false. + end if + + if (present(use_fluxes)) then + use_fluxes_local = use_fluxes + else + use_fluxes_local = .false. + end if + + ! Count the number of input intervals + ninterval = size(i_intervals) + ninput = maxval(i_intervals) + + if (allocated(mapping)) then + deallocate(mapping) + end if + + ! Check wavelength is monotonically increasing + if (ninterval > 2) then + do jint = 2,ninterval-1 + if (wavelength_bound(jint) <= wavelength_bound(jint-1)) then + write(nulerr, '(a)') '*** Error: wavelength bounds must be monotonically increasing' + call radiation_abort() + end if + end do + end if + + ! Define the mapping matrix + if (use_bands_local) then + ! Require properties per band + + allocate(mapping(ninput, this%nband)) + mapping = 0.0_jprb + + if (use_fluxes_local) then + allocate(mapping_denom(ninput, this%nband)) + mapping_denom = 0.0_jprb + end if + + do jband = 1,this%nband + do jint = 1,ninterval + if (jint == 1) then + ! First input interval in wavelength space: lower + ! wavelength bound is 0 m, so infinity cm-1 + wavenumber2_bound = this%wavenumber2_band(jband) + else + wavenumber2_bound = min(this%wavenumber2_band(jband), & + & 0.01_jprb/wavelength_bound(jint-1)) + end if + + if (jint == ninterval) then + ! Final input interval in wavelength space: upper + ! wavelength bound is infinity m, so 0 cm-1 + wavenumber1_bound = this%wavenumber1_band(jband) + else + wavenumber1_bound = max(this%wavenumber1_band(jband), & + & 0.01_jprb/wavelength_bound(jint)) + + end if + + if (wavenumber2_bound > wavenumber1_bound) then + ! Current input interval contributes to current band; + ! compute the weight of the contribution in proportion to + ! an approximate calculation of the integral of the Planck + ! function over the relevant part of the spectrum + wavenumber_sample = wavenumber1_bound + [(isamp,isamp=0,nsample-1)] & + & * (wavenumber2_bound-wavenumber1_bound) / real(nsample-1,jprb) + planck_sample = calc_planck_function_wavenumber(wavenumber_sample, temperature) + mapping(i_intervals(jint),jband) = mapping(i_intervals(jint),jband) & + & + sum(planck_sample*weight_sample) * (wavenumber2_bound-wavenumber1_bound) + if (use_fluxes_local) then + ! Compute an equivalent sample containing the entire ecRad band + wavenumber_sample = this%wavenumber1_band(jband) + [(isamp,isamp=0,nsample-1)] & + & * (this%wavenumber2_band(jband)-this%wavenumber1_band(jband)) & + & / real(nsample-1,jprb) + planck_sample = calc_planck_function_wavenumber(wavenumber_sample, temperature) + mapping_denom(i_intervals(jint),jband) = mapping_denom(i_intervals(jint),jband) & + & + sum(planck_sample*weight_sample) * (this%wavenumber2_band(jband)-this%wavenumber1_band(jband)) + end if + end if + + end do + end do + + if (use_fluxes_local) then + mapping = mapping / max(1.0e-12_jprb, mapping_denom) + deallocate(mapping_denom) + end if + + else + ! Require properties per g-point + + if (this%ng == 0) then + write(nulerr,'(a)') '*** Error: requested surface mapping per g-point but only available per band' + call radiation_abort('Radiation configuration error') + end if + + allocate(mapping(ninput,this%ng)) + mapping = 0.0_jprb + + wavenumber_mid = 0.5_jprb * (this%wavenumber1 + this%wavenumber2) + planck = calc_planck_function_wavenumber(wavenumber_mid, temperature) + + ! In the processing that follows, we assume that the wavenumber + ! grid on which the g-points are defined in the spectral + ! definition is much finer than the albedo/emissivity intervals + ! that the user will provide. This means that each wavenumber + ! is assigned to only one of the albedo/emissivity intervals. + + ! By default set all wavenumbers to use first input + ! albedo/emissivity + i_input = 1 + + ! All bounded intervals + do jint = 2,ninterval-1 + wavenumber1_bound = 0.01_jprb / wavelength_bound(jint) + wavenumber2_bound = 0.01_jprb / wavelength_bound(jint-1) + where (wavenumber_mid > wavenumber1_bound & + & .and. wavenumber_mid <= wavenumber2_bound) + i_input = i_intervals(jint) + end where + end do + + ! Final interval in wavelength space goes up to wavenumber of + ! infinity + if (ninterval > 1) then + wavenumber2_bound = 0.01_jprb / wavelength_bound(ninterval-1) + where (wavenumber_mid <= wavenumber2_bound) + i_input = i_intervals(ninterval) + end where + end if + + do jg = 1,this%ng + do jin = 1,ninput + mapping(jin,jg) = sum(this%gpoint_fraction(:,jg) * planck, & + & mask=(i_input==jin)) + if (use_fluxes_local) then + mapping(jin,jg) = mapping(jin,jg) / sum(this%gpoint_fraction(:,jg) * planck) + end if + end do + end do + + end if + + if (.not. use_fluxes_local) then + ! Normalize mapping matrix + do jg = 1,size(mapping,dim=2) + mapping(:,jg) = mapping(:,jg) * (1.0_jprb/sum(mapping(:,jg))) + end do + end if + + if (lhook) call dr_hook('radiation_spectral_definition:calc_mapping_from_bands',1,hook_handle) + + end subroutine calc_mapping_from_bands + + + !--------------------------------------------------------------------- + ! As calc_mapping_from_bands but in terms of wavenumber bounds from + ! wavenumber1 to wavenumber2 + subroutine calc_mapping_from_wavenumber_bands(this, temperature, & + & wavenumber1, wavenumber2, mapping, use_bands, use_fluxes) + + use yomhook, only : lhook, dr_hook + use radiation_io, only : nulerr, radiation_abort + + class(spectral_definition_type), intent(in) :: this + real(jprb), intent(in) :: temperature ! K + real(jprb), intent(in) :: wavenumber1(:), wavenumber2(:) + real(jprb), allocatable, intent(inout) :: mapping(:,:) + logical, optional, intent(in) :: use_bands + logical, optional, intent(in) :: use_fluxes + + ! Monotonically increasing wavelength bounds (m) between + ! intervals, not including the outer bounds (which are assumed to + ! be zero and infinity) + real(jprb) :: wavelength_bound(size(wavenumber1)-1) + ! The albedo band indices corresponding to each interval + integer :: i_intervals(size(wavenumber1)) + + ! Lower wavelength bound (m) of each band + real(jprb) :: wavelength1(size(wavenumber1)) + + logical :: is_band_unassigned(size(wavenumber1)) + + ! Number of albedo/emissivity intervals represented, where some + ! may be grouped to have the same value of albedo/emissivity (an + ! example is in the thermal infrared where classically the IFS has + ! ninput=2 and ninterval=3, since only two emissivities are + ! provided representing (1) the infrared window, and (2) the + ! intervals to each side of the infrared window. + integer :: ninterval + + ! Index to next band in order of increasing wavelength + integer :: inext + + ! Loop indices + integer :: jint + + real(jprb) :: hook_handle + + if (lhook) call dr_hook('radiation_spectral_definition:calc_mapping_from_wavenumber_bands',0,hook_handle) + + wavelength1 = 0.01_jprb / wavenumber2 + ninterval = size(wavelength1) + + is_band_unassigned = .true. + + do jint = 1,ninterval + inext = minloc(wavelength1, dim=1, mask=is_band_unassigned) + if (jint > 1) then + wavelength_bound(jint-1) = wavelength1(inext) + end if + is_band_unassigned(inext) = .false. + i_intervals(jint) = inext + end do + + call calc_mapping_from_bands(this, temperature, & + & wavelength_bound, i_intervals, mapping, use_bands, use_fluxes) + + if (lhook) call dr_hook('radiation_spectral_definition:calc_mapping_from_wavenumber_bands',1,hook_handle) + + end subroutine calc_mapping_from_wavenumber_bands + + + !--------------------------------------------------------------------- + ! Print out the mapping computed by calc_mapping_from_bands + subroutine print_mapping_from_bands(this, mapping, use_bands) + + use radiation_io, only : nulout + + class(spectral_definition_type), intent(in) :: this + real(jprb), allocatable, intent(in) :: mapping(:,:) ! (ninput,nband/ng) + logical, optional, intent(in) :: use_bands + + logical :: use_bands_local + + integer :: nin, nout + integer :: jin, jout + + if (present(use_bands)) then + use_bands_local = use_bands + else + use_bands_local = .false. + end if + + nin = size(mapping,1) + nout = size(mapping,2) + + if (nin <= 1) then + write(nulout, '(a)') ' All spectral intervals will use the same albedo/emissivity' + else if (use_bands_local) then + write(nulout, '(a,i0,a,i0,a)') ' Mapping from ', nin, ' values to ', nout, ' bands (wavenumber ranges in cm-1)' + if (nout <= 40) then + do jout = 1,nout + write(nulout,'(i6,a,i6,a)',advance='no') nint(this%wavenumber1_band(jout)), ' to', & + & nint(this%wavenumber2_band(jout)), ':' + do jin = 1,nin + write(nulout,'(f5.2)',advance='no') mapping(jin,jout) + end do + write(nulout, '()') + end do + else + do jout = 1,30 + write(nulout,'(i6,a,i6,a)',advance='no') nint(this%wavenumber1_band(jout)), ' to', & + & nint(this%wavenumber2_band(jout)), ':' + do jin = 1,nin + write(nulout,'(f5.2)',advance='no') mapping(jin,jout) + end do + write(nulout, '()') + end do + write(nulout,'(a)') ' ...' + write(nulout,'(i6,a,i6,a)',advance='no') nint(this%wavenumber1_band(nout)), ' to', & + & nint(this%wavenumber2_band(nout)), ':' + do jin = 1,nin + write(nulout,'(f5.2)',advance='no') mapping(jin,nout) + end do + write(nulout, '()') + end if + else + write(nulout, '(a,i0,a,i0,a)') ' Mapping from ', nin, ' values to ', nout, ' g-points' + if (nout <= 40) then + do jout = 1,nout + write(nulout,'(i3,a)',advance='no') jout, ':' + do jin = 1,nin + write(nulout,'(f5.2)',advance='no') mapping(jin,jout) + end do + write(nulout, '()') + end do + else + do jout = 1,30 + write(nulout,'(i3,a)',advance='no') jout, ':' + do jin = 1,nin + write(nulout,'(f5.2)',advance='no') mapping(jin,jout) + end do + write(nulout, '()') + end do + write(nulout,'(a)') ' ...' + write(nulout,'(i3,a)',advance='no') nout, ':' + do jin = 1,nin + write(nulout,'(f5.2)',advance='no') mapping(jin,nout) + end do + write(nulout, '()') + end if + end if + + end subroutine print_mapping_from_bands + + + !--------------------------------------------------------------------- + ! Return the minimum wavenumber of this object in cm-1 + pure function min_wavenumber(this) + + class(spectral_definition_type), intent(in) :: this + real(jprb) :: min_wavenumber + + if (this%nwav > 0) then + min_wavenumber = this%wavenumber1(1) + else + min_wavenumber = minval(this%wavenumber1_band) + end if + + end function min_wavenumber + + + !--------------------------------------------------------------------- + ! Return the maximum wavenumber of this object in cm-1 + pure function max_wavenumber(this) + + class(spectral_definition_type), intent(in) :: this + real(jprb) :: max_wavenumber + + if (this%nwav > 0) then + max_wavenumber = this%wavenumber1(this%nwav) + else + max_wavenumber = maxval(this%wavenumber2_band) + end if + + end function max_wavenumber + + + !--------------------------------------------------------------------- + ! Return the Planck function (in W m-2 (cm-1)-1) for a given + ! wavenumber (cm-1) and temperature (K), ensuring double precision + ! for internal calculation. If temperature is 0 or less then unity + ! is returned; since this function is primarily used to weight an + ! integral by the Planck function, a temperature of 0 or less means + ! no weighting is to be applied. + elemental function calc_planck_function_wavenumber(wavenumber, temperature) + + use parkind1, only : jprb, jprd + use radiation_constants, only : SpeedOfLight, BoltzmannConstant, PlanckConstant + + real(jprb), intent(in) :: wavenumber ! cm-1 + real(jprb), intent(in) :: temperature ! K + real(jprb) :: calc_planck_function_wavenumber + + real(jprd) :: freq ! Hz + real(jprd) :: planck_fn_freq ! W m-2 Hz-1 + + if (temperature > 0.0_jprd) then + freq = 100.0_jprd * real(SpeedOfLight,jprd) * real(wavenumber,jprd) + planck_fn_freq = 2.0_jprd * real(PlanckConstant,jprd) * freq**3 & + & / (real(SpeedOfLight,jprd)**2 * (exp(real(PlanckConstant,jprd)*freq & + & /(real(BoltzmannConstant,jprd)*real(temperature,jprd))) - 1.0_jprd)) + calc_planck_function_wavenumber = real(planck_fn_freq * 100.0_jprd * real(SpeedOfLight,jprd), jprb) + else + calc_planck_function_wavenumber = 1.0_jprb + end if + + end function calc_planck_function_wavenumber + +end module radiation_spectral_definition Index: LMDZ6/trunk/libf/phylmd/ecrad/radiation_thermodynamics.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad/radiation_thermodynamics.F90 (revision 4487) +++ LMDZ6/trunk/libf/phylmd/ecrad/radiation_thermodynamics.F90 (revision 4489) @@ -297,5 +297,5 @@ use yomhook, only : lhook, dr_hook - use radiation_config, only : out_of_bounds_2d + use radiation_check, only : out_of_bounds_2d class(thermodynamics_type), intent(inout) :: this Index: LMDZ6/trunk/libf/phylmd/ecrad/radiation_tripleclouds_lw.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad/radiation_tripleclouds_lw.F90 (revision 4487) +++ LMDZ6/trunk/libf/phylmd/ecrad/radiation_tripleclouds_lw.F90 (revision 4489) @@ -18,4 +18,6 @@ ! 2017-10-23 R. Hogan Renamed single-character variables ! 2018-10-08 R. Hogan Call calc_region_properties +! 2020-09-18 R. Hogan Replaced some array expressions with loops +! 2020-09-19 R. Hogan Implement the cloud-only-scattering optimization module radiation_tripleclouds_lw @@ -28,4 +30,5 @@ #include "radiation_optical_depth_scaling.h" + !--------------------------------------------------------------------- ! This module contains just one subroutine, the longwave ! "Tripleclouds" solver in which cloud inhomogeneity is treated by @@ -33,5 +36,4 @@ ! cloudy (with differing optical depth). This approach was described ! by Shonk and Hogan (2008). - subroutine solver_tripleclouds_lw(nlev,istartcol,iendcol, & & config, cloud, & @@ -48,10 +50,10 @@ use radiation_regions, only : calc_region_properties use radiation_overlap, only : calc_overlap_matrices - use radiation_flux, only : flux_type, & - & indexed_sum, add_indexed_sum + use radiation_flux, only : flux_type, indexed_sum use radiation_matrix, only : singlemat_x_vec use radiation_two_stream, only : calc_two_stream_gammas_lw, & & calc_reflectance_transmittance_lw, & & calc_no_scattering_transmittance_lw + use radiation_adding_ica_lw, only : adding_ica_lw, calc_fluxes_no_scattering_lw use radiation_lw_derivatives, only : calc_lw_derivatives_region @@ -130,9 +132,13 @@ ! streams real(jprb), dimension(config%n_g_lw, nregions, nlev) & - & :: Sup, Sdn + & :: source_up, source_dn + + ! Clear-sky reflectance and transmittance + real(jprb), dimension(config%n_g_lw, nlev) & + & :: ref_clear, trans_clear ! ...clear-sky equivalent real(jprb), dimension(config%n_g_lw, nlev) & - & :: Sup_clear, Sdn_clear + & :: source_up_clear, source_dn_clear ! Total albedo of the atmosphere/surface just above a layer @@ -147,7 +153,4 @@ real(jprb), dimension(config%n_g_lw, nregions, nlev+1) :: total_source - ! ...equivalent values for clear-skies - real(jprb), dimension(config%n_g_lw, nlev+1) :: total_albedo_clear, total_source_clear - ! Total albedo and source of the atmosphere just below a layer interface real(jprb), dimension(config%n_g_lw, nregions) & @@ -160,5 +163,5 @@ ! ...clear-sky equivalent (no distinction between "above/below") - real(jprb), dimension(config%n_g_lw) & + real(jprb), dimension(config%n_g_lw, nlev+1) & & :: flux_dn_clear, flux_up_clear @@ -170,4 +173,7 @@ ! and below the ground, both treated as single-region clear skies logical :: is_clear_sky_layer(0:nlev+1) + + ! Index of the highest cloudy layer + integer :: i_cloud_top integer :: jcol, jlev, jg, jreg, jreg2, ng @@ -208,16 +214,96 @@ ! cloud%crop_cloud_fraction has already been called is_clear_sky_layer = .true. + i_cloud_top = nlev+1 do jlev = 1,nlev if (cloud%fraction(jcol,jlev) > 0.0_jprb) then is_clear_sky_layer(jlev) = .false. + ! Get index to the first cloudy layer from the top + if (i_cloud_top > jlev) then + i_cloud_top = jlev + end if end if end do - - ! -------------------------------------------------------- - ! Section 3: Loop over layers to compute reflectance and transmittance + if (config%do_lw_aerosol_scattering) then + ! This is actually the first layer in which we need to + ! consider scattering + i_cloud_top = 1 + end if + + ! -------------------------------------------------------- + ! Section 3: Clear-sky calculation + ! -------------------------------------------------------- + + if (.not. config%do_lw_aerosol_scattering) then + ! No scattering in clear-sky flux calculation + do jlev = 1,nlev + ! Array-wise assignments + gamma1 = 0.0_jprb + gamma2 = 0.0_jprb + call calc_no_scattering_transmittance_lw(ng, od(:,jlev,jcol), & + & planck_hl(:,jlev,jcol), planck_hl(:,jlev+1, jcol), & + & trans_clear(:,jlev), source_up_clear(:,jlev), source_dn_clear(:,jlev)) + ref_clear(:,jlev) = 0.0_jprb + end do + ! Simple down-then-up method to compute fluxes + call calc_fluxes_no_scattering_lw(ng, nlev, & + & trans_clear, source_up_clear, source_dn_clear, & + & emission(:,jcol), albedo(:,jcol), & + & flux_up_clear, flux_dn_clear) + else + ! Scattering in clear-sky flux calculation + do jlev = 1,nlev + ! Array-wise assignments + gamma1 = 0.0_jprb + gamma2 = 0.0_jprb + call calc_two_stream_gammas_lw(ng, & + & ssa(:,jlev,jcol), g(:,jlev,jcol), gamma1, gamma2) + call calc_reflectance_transmittance_lw(ng, & + & od(:,jlev,jcol), gamma1, gamma2, & + & planck_hl(:,jlev,jcol), planck_hl(:,jlev+1,jcol), & + & ref_clear(:,jlev), trans_clear(:,jlev), & + & source_up_clear(:,jlev), source_dn_clear(:,jlev)) + end do + ! Use adding method to compute fluxes + call adding_ica_lw(ng, nlev, & + & ref_clear, trans_clear, source_up_clear, source_dn_clear, & + & emission(:,jcol), albedo(:,jcol), & + & flux_up_clear, flux_dn_clear) + end if + + if (config%do_clear) then + ! Sum over g-points to compute broadband fluxes + flux%lw_up_clear(jcol,:) = sum(flux_up_clear,1) + flux%lw_dn_clear(jcol,:) = sum(flux_dn_clear,1) + ! Store surface spectral downwelling fluxes + flux%lw_dn_surf_clear_g(:,jcol) = flux_dn_clear(:,nlev+1) + ! Save the spectral fluxes if required + if (config%do_save_spectral_flux) then + do jlev = 1,nlev+1 + call indexed_sum(flux_up_clear(:,jlev), & + & config%i_spec_from_reordered_g_lw, & + & flux%lw_up_clear_band(:,jcol,jlev)) + call indexed_sum(flux_dn_clear(:,jlev), & + & config%i_spec_from_reordered_g_lw, & + & flux%lw_dn_clear_band(:,jcol,jlev)) + end do + end if + end if + + ! -------------------------------------------------------- + ! Section 4: Loop over cloudy layers to compute reflectance and transmittance ! -------------------------------------------------------- ! In this section the reflectance, transmittance and sources ! are computed for each layer - do jlev = 1,nlev ! Start at top-of-atmosphere + + ! Firstly, ensure clear-sky transmittance is valid for whole + ! depth of the atmosphere, because even above cloud it is used + ! by the LW derivatives + transmittance(:,1,:) = trans_clear(:,:) + ! Dummy values in cloudy regions above cloud top + if (i_cloud_top > 0) then + transmittance(:,2:,1:min(i_cloud_top,nlev)) = 1.0_jprb + end if + + do jlev = i_cloud_top,nlev ! Start at cloud top and work down ! Array-wise assignments @@ -225,30 +311,17 @@ gamma2 = 0.0_jprb + ! Copy over clear-sky properties + reflectance(:,1,jlev) = ref_clear(:,jlev) + source_up(:,1,jlev) = source_up_clear(:,jlev) ! Scaled later by region size + source_dn(:,1,jlev) = source_dn_clear(:,jlev) ! Scaled later by region size nreg = nregions if (is_clear_sky_layer(jlev)) then nreg = 1 reflectance(:,2:,jlev) = 0.0_jprb - transmittance(:,2:,jlev) = 0.0_jprb - Sup(:,2:,jlev) = 0.0_jprb - Sdn(:,2:,jlev) = 0.0_jprb - end if - do jreg = 1,nreg - if (jreg == 1) then - ! Clear-sky calculation - if (.not. config%do_lw_aerosol_scattering) then - call calc_no_scattering_transmittance_lw(ng, od(:,jlev,jcol), & - & planck_hl(:,jlev,jcol), planck_hl(:,jlev+1, jcol), & - & transmittance(:,1,jlev), Sup(:,1,jlev), Sdn(:,1,jlev)) - reflectance(:,1,jlev) = 0.0_jprb - else - call calc_two_stream_gammas_lw(ng, & - & ssa(:,jlev,jcol), g(:,jlev,jcol), gamma1, gamma2) - call calc_reflectance_transmittance_lw(ng, & - & od(:,jlev,jcol), gamma1, gamma2, & - & planck_hl(:,jlev,jcol), planck_hl(:,jlev+1,jcol), & - & reflectance(:,1,jlev), transmittance(:,1,jlev), & - & Sup(:,1,jlev), Sdn(:,1,jlev)) - end if - else + transmittance(:,2:,jlev) = 1.0_jprb + source_up(:,2:,jlev) = 0.0_jprb + source_dn(:,2:,jlev) = 0.0_jprb + else + do jreg = 2,nreg ! Cloudy sky ! Add scaled cloud optical depth to clear-sky value @@ -291,5 +364,5 @@ & planck_hl(:,jlev,jcol), planck_hl(:,jlev+1,jcol), & & reflectance(:,jreg,jlev), transmittance(:,jreg,jlev), & - & Sup(:,jreg,jlev), Sdn(:,jreg,jlev)) + & source_up(:,jreg,jlev), source_dn(:,jreg,jlev)) else ! No-scattering case: use simpler functions for @@ -297,18 +370,12 @@ call calc_no_scattering_transmittance_lw(ng, od_total, & & planck_hl(:,jlev,jcol), planck_hl(:,jlev+1, jcol), & - & transmittance(:,jreg,jlev), Sup(:,jreg,jlev), Sdn(:,jreg,jlev)) + & transmittance(:,jreg,jlev), source_up(:,jreg,jlev), source_dn(:,jreg,jlev)) reflectance(:,jreg,jlev) = 0.0_jprb end if - end if - end do - - ! Copy over the clear-sky emission - Sup_clear(:,jlev) = Sup(:,1,jlev) - Sdn_clear(:,jlev) = Sdn(:,1,jlev) - if (.not. is_clear_sky_layer(jlev)) then + end do ! Emission is scaled by the size of each region do jreg = 1,nregions - Sup(:,jreg,jlev) = region_fracs(jreg,jlev,jcol) * Sup(:,jreg,jlev) - Sdn(:,jreg,jlev) = region_fracs(jreg,jlev,jcol) * Sdn(:,jreg,jlev) + source_up(:,jreg,jlev) = region_fracs(jreg,jlev,jcol) * source_up(:,jreg,jlev) + source_dn(:,jreg,jlev) = region_fracs(jreg,jlev,jcol) * source_dn(:,jreg,jlev) end do end if @@ -317,5 +384,5 @@ ! -------------------------------------------------------- - ! Section 4: Compute total sources albedos + ! Section 5: Compute total sources and albedos at each half level ! -------------------------------------------------------- @@ -333,48 +400,26 @@ end do end do - ! Equivalent surface values for computing clear-sky fluxes - if (config%do_clear) then - do jg = 1,ng - total_source_clear(jg,nlev+1) = emission(jg,jcol) - end do - ! In the case of surface albedo there is no dependence on - ! cloud fraction so we can copy the all-sky value - total_albedo_clear(1:ng,nlev+1) = total_albedo(1:ng,1,nlev+1) - end if ! Work up from the surface computing the total albedo of the ! atmosphere and the total upwelling due to emission below each ! level below using the adding method - do jlev = nlev,1,-1 + do jlev = nlev,i_cloud_top,-1 total_albedo_below = 0.0_jprb - if (config%do_clear) then - ! For clear-skies there is no need to consider "above" and - ! "below" quantities since with no cloud overlap to worry - ! about, these are the same - inv_denom(:,1) = 1.0_jprb & - & / (1.0_jprb - total_albedo_clear(:,jlev+1)*reflectance(:,1,jlev)) - total_albedo_clear(:,jlev) = reflectance(:,1,jlev) & - & + transmittance(:,1,jlev)*transmittance(:,1,jlev)*total_albedo_clear(:,jlev+1) & - & * inv_denom(:,1) - total_source_clear(:,jlev) = Sup_clear(:,jlev) & - & + transmittance(:,1,jlev)*(total_source_clear(:,jlev+1) & - & + total_albedo_clear(:,jlev+1)*Sdn_clear(:,jlev)) & - & * inv_denom(:,1) - end if - if (is_clear_sky_layer(jlev)) then - inv_denom(:,1) = 1.0_jprb & - & / (1.0_jprb - total_albedo(:,1,jlev+1)*reflectance(:,1,jlev)) total_albedo_below = 0.0_jprb - total_albedo_below(:,1) = reflectance(:,1,jlev) & - & + transmittance(:,1,jlev)*transmittance(:,1,jlev)*total_albedo(:,1,jlev+1) & - & * inv_denom(:,1) total_source_below = 0.0_jprb - total_source_below(:,1) = Sup(:,1,jlev) & - & + transmittance(:,1,jlev)*(total_source(:,1,jlev+1) & - & + total_albedo(:,1,jlev+1)*Sdn(:,1,jlev)) & - & * inv_denom(:,1) + do jg = 1,ng + inv_denom(jg,1) = 1.0_jprb & + & / (1.0_jprb - total_albedo(jg,1,jlev+1)*reflectance(jg,1,jlev)) + total_albedo_below(jg,1) = reflectance(jg,1,jlev) & + & + transmittance(jg,1,jlev)*transmittance(jg,1,jlev)*total_albedo(jg,1,jlev+1) & + & * inv_denom(jg,1) + total_source_below(jg,1) = source_up(jg,1,jlev) & + & + transmittance(jg,1,jlev)*(total_source(jg,1,jlev+1) & + & + total_albedo(jg,1,jlev+1)*source_dn(jg,1,jlev)) & + & * inv_denom(jg,1) + end do else inv_denom = 1.0_jprb / (1.0_jprb - total_albedo(:,:,jlev+1)*reflectance(:,:,jlev)) @@ -382,7 +427,7 @@ & + transmittance(:,:,jlev)*transmittance(:,:,jlev)*total_albedo(:,:,jlev+1) & & * inv_denom - total_source_below = Sup(:,:,jlev) & + total_source_below = source_up(:,:,jlev) & & + transmittance(:,:,jlev)*(total_source(:,:,jlev+1) & - & + total_albedo(:,:,jlev+1)*Sdn(:,:,jlev)) & + & + total_albedo(:,:,jlev+1)*source_dn(:,:,jlev)) & & * inv_denom end if @@ -415,57 +460,73 @@ ! -------------------------------------------------------- - ! Section 5: Compute fluxes - ! -------------------------------------------------------- - - ! Top-of-atmosphere fluxes into the regions of the top-most - ! layer, zero since we assume no diffuse downwelling - flux_dn = 0.0_jprb - - if (config%do_clear) then - flux_dn_clear = 0.0_jprb + ! Section 6: Copy over downwelling fluxes above cloud top + ! -------------------------------------------------------- + do jlev = 1,i_cloud_top + if (config%do_clear) then + ! Clear-sky fluxes have already been averaged: use these + flux%lw_dn(jcol,jlev) = flux%lw_dn_clear(jcol,jlev) + if (config%do_save_spectral_flux) then + flux%lw_dn_band(:,jcol,jlev) = flux%lw_dn_clear_band(:,jcol,jlev) + end if + else + flux%lw_dn(jcol,:) = sum(flux_dn_clear(:,jlev)) + if (config%do_save_spectral_flux) then + call indexed_sum(flux_dn_clear(:,jlev), & + & config%i_spec_from_reordered_g_lw, & + & flux%lw_dn_band(:,jcol,jlev)) + end if + end if + end do + + ! -------------------------------------------------------- + ! Section 7: Compute fluxes up to top-of-atmosphere + ! -------------------------------------------------------- + + ! Compute the fluxes just above the highest cloud + flux_up(:,1) = total_source(:,1,i_cloud_top) & + & + total_albedo(:,1,i_cloud_top)*flux_dn_clear(:,i_cloud_top) + flux_up(:,2:) = 0.0_jprb + flux%lw_up(jcol,i_cloud_top) = sum(flux_up(:,1)) + if (config%do_save_spectral_flux) then + call indexed_sum(flux_up(:,1), & + & config%i_spec_from_reordered_g_lw, & + & flux%lw_up_band(:,jcol,i_cloud_top)) end if - - ! Store the TOA broadband fluxes - flux%lw_up(jcol,1) = sum(total_source(:,:,1)) - flux%lw_dn(jcol,1) = 0.0_jprb - if (config%do_clear) then - flux%lw_up_clear(jcol,1) = sum(total_source_clear(:,1)) - flux%lw_dn_clear(jcol,1) = 0.0_jprb - end if - - ! Save the spectral fluxes if required - if (config%do_save_spectral_flux) then - call indexed_sum(sum(total_source(:,:,1),2), & - & config%i_spec_from_reordered_g_lw, & - & flux%lw_up_band(:,jcol,1)) - flux%lw_dn_band(:,jcol,1) = 0.0_jprb - if (config%do_clear) then - call indexed_sum(total_source_clear(:,1), & + do jlev = i_cloud_top-1,1,-1 + flux_up(:,1) = trans_clear(:,jlev)*flux_up(:,1) + source_up_clear(:,jlev) + flux%lw_up(jcol,jlev) = sum(flux_up(:,1)) + if (config%do_save_spectral_flux) then + call indexed_sum(flux_up(:,1), & & config%i_spec_from_reordered_g_lw, & - & flux%lw_up_clear_band(:,jcol,1)) - flux%lw_dn_clear_band(:,jcol,1) = 0.0_jprb - end if - end if + & flux%lw_up_band(:,jcol,jlev)) + end if + end do + + ! -------------------------------------------------------- + ! Section 8: Compute fluxes down to surface + ! -------------------------------------------------------- + + ! Copy over downwelling spectral fluxes at top of first + ! scattering layer, using overlap matrix to translate to the + ! regions of the first layer of cloud + do jreg = 1,nregions + flux_dn(:,jreg) = v_matrix(jreg,1,i_cloud_top,jcol)*flux_dn_clear(:,i_cloud_top) + end do ! Final loop back down through the atmosphere to compute fluxes - do jlev = 1,nlev - if (config%do_clear) then - flux_dn_clear = (transmittance(:,1,jlev)*flux_dn_clear & - & + reflectance(:,1,jlev)*total_source_clear(:,jlev+1) + Sdn_clear(:,jlev) ) & - & / (1.0_jprb - reflectance(:,1,jlev)*total_albedo_clear(:,jlev+1)) - flux_up_clear = total_source_clear(:,jlev+1) & - & + flux_dn_clear*total_albedo_clear(:,jlev+1) - end if + do jlev = i_cloud_top,nlev if (is_clear_sky_layer(jlev)) then - flux_dn(:,1) = (transmittance(:,1,jlev)*flux_dn(:,1) & - & + reflectance(:,1,jlev)*total_source(:,1,jlev+1) + Sdn(:,1,jlev) ) & - & / (1.0_jprb - reflectance(:,1,jlev)*total_albedo(:,1,jlev+1)) + do jg = 1,ng + flux_dn(jg,1) = (transmittance(jg,1,jlev)*flux_dn(jg,1) & + & + reflectance(jg,1,jlev)*total_source(jg,1,jlev+1) + source_dn(jg,1,jlev) ) & + & / (1.0_jprb - reflectance(jg,1,jlev)*total_albedo(jg,1,jlev+1)) + flux_up(jg,1) = total_source(jg,1,jlev+1) + flux_dn(jg,1)*total_albedo(jg,1,jlev+1) + end do flux_dn(:,2:) = 0.0_jprb - flux_up(:,1) = total_source(:,1,jlev+1) + flux_dn(:,1)*total_albedo(:,1,jlev+1) flux_up(:,2:) = 0.0_jprb else flux_dn = (transmittance(:,:,jlev)*flux_dn & - & + reflectance(:,:,jlev)*total_source(:,:,jlev+1) + Sdn(:,:,jlev) ) & + & + reflectance(:,:,jlev)*total_source(:,:,jlev+1) + source_dn(:,:,jlev) ) & & / (1.0_jprb - reflectance(:,:,jlev)*total_albedo(:,:,jlev+1)) flux_up = total_source(:,:,jlev+1) + flux_dn*total_albedo(:,:,jlev+1) @@ -485,8 +546,4 @@ flux%lw_up(jcol,jlev+1) = sum(sum(flux_up,1)) flux%lw_dn(jcol,jlev+1) = sum(sum(flux_dn,1)) - if (config%do_clear) then - flux%lw_up_clear(jcol,jlev+1) = sum(flux_up_clear) - flux%lw_dn_clear(jcol,jlev+1) = sum(flux_dn_clear) - end if ! Save the spectral fluxes if required @@ -498,13 +555,5 @@ & config%i_spec_from_reordered_g_lw, & & flux%lw_dn_band(:,jcol,jlev+1)) - if (config%do_clear) then - call indexed_sum(flux_up_clear, & - & config%i_spec_from_reordered_g_lw, & - & flux%lw_up_clear_band(:,jcol,jlev+1)) - call indexed_sum(flux_dn_clear, & - & config%i_spec_from_reordered_g_lw, & - & flux%lw_dn_clear_band(:,jcol,jlev+1)) - end if - end if + end if end do ! Final loop over levels @@ -513,7 +562,4 @@ ! are at the surface flux%lw_dn_surf_g(:,jcol) = sum(flux_dn,2) - if (config%do_clear) then - flux%lw_dn_surf_clear_g(:,jcol) = flux_dn_clear - end if ! Compute the longwave derivatives needed by Hogan and Bozzo Index: LMDZ6/trunk/libf/phylmd/ecrad/radiation_tripleclouds_sw.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad/radiation_tripleclouds_sw.F90 (revision 4487) +++ LMDZ6/trunk/libf/phylmd/ecrad/radiation_tripleclouds_sw.F90 (revision 4489) @@ -19,4 +19,5 @@ ! 2018-10-08 R. Hogan Call calc_region_properties ! 2019-01-02 R. Hogan Fixed problem of do_save_spectral_flux .and. .not. do_sw_direct +! 2020-09-18 R. Hogan Replaced some array expressions with loops for speed module radiation_tripleclouds_sw @@ -32,4 +33,5 @@ #include "radiation_optical_depth_scaling.h" + !--------------------------------------------------------------------- ! This module contains just one subroutine, the shortwave ! "Tripleclouds" solver in which cloud inhomogeneity is treated by @@ -37,5 +39,4 @@ ! cloudy (with differing optical depth). This approach was described ! by Shonk and Hogan (2008). - subroutine solver_tripleclouds_sw(nlev,istartcol,iendcol, & & config, single_level, cloud, & @@ -356,25 +357,29 @@ ! "below" quantities since with no cloud overlap to worry ! about, these are the same - inv_denom(:,1) = 1.0_jprb & - & / (1.0_jprb - total_albedo_clear(:,jlev+1)*reflectance(:,1,jlev)) - total_albedo_clear(:,jlev) = reflectance(:,1,jlev) & - & + transmittance(:,1,jlev) * transmittance(:,1,jlev) & - & * total_albedo_clear(:,jlev+1) * inv_denom(:,1) - total_albedo_clear_direct(:,jlev) = ref_dir(:,1,jlev) & - & + (trans_dir_dir(:,1,jlev)*total_albedo_clear_direct(:,jlev+1) & - & +trans_dir_diff(:,1,jlev)*total_albedo_clear(:,jlev+1)) & - & * transmittance(:,1,jlev) * inv_denom(:,1) + do jg = 1,ng + inv_denom(jg,1) = 1.0_jprb & + & / (1.0_jprb - total_albedo_clear(jg,jlev+1)*reflectance(jg,1,jlev)) + total_albedo_clear(jg,jlev) = reflectance(jg,1,jlev) & + & + transmittance(jg,1,jlev) * transmittance(jg,1,jlev) & + & * total_albedo_clear(jg,jlev+1) * inv_denom(jg,1) + total_albedo_clear_direct(jg,jlev) = ref_dir(jg,1,jlev) & + & + (trans_dir_dir(jg,1,jlev)*total_albedo_clear_direct(jg,jlev+1) & + & +trans_dir_diff(jg,1,jlev)*total_albedo_clear(jg,jlev+1)) & + & * transmittance(jg,1,jlev) * inv_denom(jg,1) + end do end if if (is_clear_sky_layer(jlev)) then - inv_denom(:,1) = 1.0_jprb & - & / (1.0_jprb - total_albedo(:,1,jlev+1)*reflectance(:,1,jlev)) - total_albedo_below(:,1) = reflectance(:,1,jlev) & - & + transmittance(:,1,jlev) * transmittance(:,1,jlev) & - & * total_albedo(:,1,jlev+1) * inv_denom(:,1) - total_albedo_below_direct(:,1) = ref_dir(:,1,jlev) & - & + (trans_dir_dir(:,1,jlev)*total_albedo_direct(:,1,jlev+1) & - & +trans_dir_diff(:,1,jlev)*total_albedo(:,1,jlev+1)) & - & * transmittance(:,1,jlev) * inv_denom(:,1) + do jg = 1,ng + inv_denom(jg,1) = 1.0_jprb & + & / (1.0_jprb - total_albedo(jg,1,jlev+1)*reflectance(jg,1,jlev)) + total_albedo_below(jg,1) = reflectance(jg,1,jlev) & + & + transmittance(jg,1,jlev) * transmittance(jg,1,jlev) & + & * total_albedo(jg,1,jlev+1) * inv_denom(jg,1) + total_albedo_below_direct(jg,1) = ref_dir(jg,1,jlev) & + & + (trans_dir_dir(jg,1,jlev)*total_albedo_direct(jg,1,jlev+1) & + & +trans_dir_diff(jg,1,jlev)*total_albedo(jg,1,jlev+1)) & + & * transmittance(jg,1,jlev) * inv_denom(jg,1) + end do else inv_denom = 1.0_jprb / (1.0_jprb - total_albedo(:,:,jlev+1)*reflectance(:,:,jlev)) @@ -488,21 +493,26 @@ do jlev = 1,nlev if (config%do_clear) then - flux_dn_clear = (transmittance(:,1,jlev)*flux_dn_clear + direct_dn_clear & - & * (trans_dir_dir(:,1,jlev)*total_albedo_clear_direct(:,jlev+1)*reflectance(:,1,jlev) & - & + trans_dir_diff(:,1,jlev) )) & - & / (1.0_jprb - reflectance(:,1,jlev)*total_albedo_clear(:,jlev+1)) - direct_dn_clear = trans_dir_dir(:,1,jlev)*direct_dn_clear - flux_up_clear = direct_dn_clear*total_albedo_clear_direct(:,jlev+1) & - & + flux_dn_clear*total_albedo_clear(:,jlev+1) + do jg = 1,ng + flux_dn_clear(jg) = (transmittance(jg,1,jlev)*flux_dn_clear(jg) + direct_dn_clear(jg) & + & * (trans_dir_dir(jg,1,jlev)*total_albedo_clear_direct(jg,jlev+1)*reflectance(jg,1,jlev) & + & + trans_dir_diff(jg,1,jlev) )) & + & / (1.0_jprb - reflectance(jg,1,jlev)*total_albedo_clear(jg,jlev+1)) + direct_dn_clear(jg) = trans_dir_dir(jg,1,jlev)*direct_dn_clear(jg) + flux_up_clear(jg) = direct_dn_clear(jg)*total_albedo_clear_direct(jg,jlev+1) & + & + flux_dn_clear(jg)*total_albedo_clear(jg,jlev+1) + end do end if if (is_clear_sky_layer(jlev)) then - flux_dn(:,1) = (transmittance(:,1,jlev)*flux_dn(:,1) + direct_dn(:,1) & - & * (trans_dir_dir(:,1,jlev)*total_albedo_direct(:,1,jlev+1)*reflectance(:,1,jlev) & - & + trans_dir_diff(:,1,jlev) )) & - & / (1.0_jprb - reflectance(:,1,jlev)*total_albedo(:,1,jlev+1)) - direct_dn(:,1) = trans_dir_dir(:,1,jlev)*direct_dn(:,1) - flux_up(:,1) = direct_dn(:,1)*total_albedo_direct(:,1,jlev+1) & - & + flux_dn(:,1)*total_albedo(:,1,jlev+1) + do jg = 1,ng + flux_dn(jg,1) = (transmittance(jg,1,jlev)*flux_dn(jg,1) + direct_dn(jg,1) & + & * (trans_dir_dir(jg,1,jlev)*total_albedo_direct(jg,1,jlev+1)*reflectance(jg,1,jlev) & + & + trans_dir_diff(jg,1,jlev) )) & + & / (1.0_jprb - reflectance(jg,1,jlev)*total_albedo(jg,1,jlev+1)) + direct_dn(jg,1) = trans_dir_dir(jg,1,jlev)*direct_dn(jg,1) + flux_up(jg,1) = direct_dn(jg,1)*total_albedo_direct(jg,1,jlev+1) & + & + flux_dn(jg,1)*total_albedo(jg,1,jlev+1) + end do + flux_dn(:,2:) = 0.0_jprb flux_up(:,2:) = 0.0_jprb Index: LMDZ6/trunk/libf/phylmd/ecrad/radiation_two_stream.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad/radiation_two_stream.F90 (revision 4487) +++ LMDZ6/trunk/libf/phylmd/ecrad/radiation_two_stream.F90 (revision 4489) @@ -18,4 +18,5 @@ ! 2017-07-26 R Hogan Added calc_frac_scattered_diffuse_sw routine ! 2017-10-23 R Hogan Renamed single-character variables +! 2021-02-19 R Hogan Security for shortwave singularity module radiation_two_stream @@ -31,5 +32,6 @@ ! think of acos(1/lw_diffusivity) to be the effective zenith angle ! of longwave radiation. - real(jprd), parameter :: LwDiffusivity = 1.66_jprd + real(jprd), parameter :: LwDiffusivity = 1.66_jprd + real(jprb), parameter :: LwDiffusivityWP = 1.66_jprb ! Working precision version ! Shortwave diffusivity factor assumes hemispheric isotropy, assumed @@ -87,5 +89,6 @@ if (lhook) call dr_hook('radiation_two_stream:calc_two_stream_gammas_lw',0,hook_handle) #endif - +! Added for DWD (2020) +!NEC$ shortloop do jg = 1, ng ! Fu et al. (1997), Eq 2.9 and 2.10: @@ -136,4 +139,6 @@ ! Zdunkowski "PIFM" (Zdunkowski et al., 1980; Contributions to ! Atmospheric Physics 53, 147-66) +! Added for DWD (2020) +!NEC$ shortloop do jg = 1, ng ! gamma1(jg) = 2.0_jprb - ssa(jg) * (1.25_jprb + 0.75_jprb*g(jg)) @@ -205,4 +210,6 @@ #endif +! Added for DWD (2020) +!NEC$ shortloop do jg = 1, ng if (od(jg) > 1.0e-3_jprd) then @@ -293,4 +300,6 @@ #endif +! Added for DWD (2020) +!NEC$ shortloop do jg = 1, ng k_exponent = sqrt(max((gamma1(jg) - gamma2(jg)) * (gamma1(jg) + gamma2(jg)), & @@ -359,4 +368,6 @@ #endif +! Added for DWD (2020) +!NEC$ shortloop do jg = 1, ng ! Compute upward and downward emission assuming the Planck @@ -450,4 +461,9 @@ integer :: jg + ! Local value of cosine of solar zenith angle, in case it needs to be + ! tweaked to avoid near division by zero. This is intentionally in working + ! precision (jprb) rather than fixing at double precision (jprd). + real(jprb) :: mu0_local + #ifdef DO_DR_HOOK_TWO_STREAM real(jprb) :: hook_handle @@ -456,20 +472,31 @@ #endif +! Added for DWD (2020) +!NEC$ shortloop do jg = 1, ng - od_over_mu0 = max(od(jg) / mu0, 0.0_jprd) - ! In the IFS this appears to be faster without testing the value - ! of od_over_mu0: - if (.true.) then -! if (od_over_mu0 > 1.0e-6_jprd) then + gamma4 = 1.0_jprd - gamma3(jg) alpha1 = gamma1(jg)*gamma4 + gamma2(jg)*gamma3(jg) ! Eq. 16 alpha2 = gamma1(jg)*gamma3(jg) + gamma2(jg)*gamma4 ! Eq. 17 - + + k_exponent = sqrt(max((gamma1(jg) - gamma2(jg)) * (gamma1(jg) + gamma2(jg)), & + & 1.0e-12_jprd)) ! Eq 18 + + ! We had a rare crash where k*mu0 was within around 1e-13 of 1, + ! leading to ref_dir and trans_dir_diff being well outside the range + ! 0-1. The following approach is appropriate when k_exponent is double + ! precision and mu0_local is single precision, although work is needed + ! to make this entire routine secure in single precision. + mu0_local = mu0 + if (abs(1.0_jprd - k_exponent*mu0) < 1000.0_jprd * epsilon(1.0_jprd)) then + mu0_local = mu0 * (1.0_jprb - 10.0_jprb*epsilon(1.0_jprb)) + end if + + od_over_mu0 = max(od(jg) / mu0_local, 0.0_jprd) + ! Note that if the minimum value is reduced (e.g. to 1.0e-24) ! then noise starts to appear as a function of solar zenith ! angle - k_exponent = sqrt(max((gamma1(jg) - gamma2(jg)) * (gamma1(jg) + gamma2(jg)), & - & 1.0e-12_jprd)) ! Eq 18 - k_mu0 = k_exponent*mu0 + k_mu0 = k_exponent*mu0_local k_gamma3 = k_exponent*gamma3(jg) k_gamma4 = k_exponent*gamma4 @@ -482,8 +509,4 @@ k_2_exponential = 2.0_jprd * k_exponent * exponential - if (k_mu0 == 1.0_jprd) then - k_mu0 = 1.0_jprd - 10.0_jprd*epsilon(1.0_jprd) - end if - reftrans_factor = 1.0_jprd / (k_exponent + gamma1(jg) + (k_exponent - gamma1(jg))*exponential2) @@ -498,5 +521,5 @@ ! to be the flux into a plane perpendicular to the direction of ! the sun, not into a horizontal plane - reftrans_factor = mu0 * ssa(jg) * reftrans_factor / (1.0_jprd - k_mu0*k_mu0) + reftrans_factor = mu0_local * ssa(jg) * reftrans_factor / (1.0_jprd - k_mu0*k_mu0) ! Meador & Weaver (1980) Eq. 14, multiplying top & bottom by @@ -505,23 +528,18 @@ & * ( (1.0_jprd - k_mu0) * (alpha2 + k_gamma3) & & -(1.0_jprd + k_mu0) * (alpha2 - k_gamma3)*exponential2 & - & -k_2_exponential*(gamma3(jg) - alpha2*mu0)*exponential0) + & -k_2_exponential*(gamma3(jg) - alpha2*mu0_local)*exponential0) ! Meador & Weaver (1980) Eq. 15, multiplying top & bottom by ! exp(-k_exponent*od), minus the 1*exp(-od/mu0) term representing direct ! unscattered transmittance. - trans_dir_diff(jg) = reftrans_factor * ( k_2_exponential*(gamma4 + alpha1*mu0) & + trans_dir_diff(jg) = reftrans_factor * ( k_2_exponential*(gamma4 + alpha1*mu0_local) & & - exponential0 & & * ( (1.0_jprd + k_mu0) * (alpha1 + k_gamma4) & & -(1.0_jprd - k_mu0) * (alpha1 - k_gamma4) * exponential2) ) - else - ! Low optical-depth limit; see equations 19, 20 and 27 from - ! Meador & Weaver (1980) - trans_diff(jg) = 1.0_jprb - gamma1(jg) * od(jg) - ref_diff(jg) = gamma2(jg) * od(jg) - trans_dir_diff(jg) = (1.0_jprb - gamma3(jg)) * ssa(jg) * od(jg) - ref_dir(jg) = gamma3(jg) * ssa(jg) * od(jg) - trans_dir_dir(jg) = 1.0_jprd - od_over_mu0 - end if + ! Final check that ref_dir + trans_dir_diff <= 1 + ref_dir(jg) = max(0.0_jprb, min(ref_dir(jg), 1.0_jprb)) + trans_dir_diff(jg) = max(0.0_jprb, min(trans_dir_diff(jg), 1.0_jprb-ref_dir(jg))) + end do @@ -587,4 +605,6 @@ #endif +! Added for DWD (2020) +!NEC$ shortloop do jg = 1, ng od_over_mu0 = max(gamma0(jg) * depth, 0.0_jprd) @@ -699,4 +719,6 @@ #endif +! Added for DWD (2020) +!NEC$ shortloop do jg = 1, ng ! Note that if the minimum value is reduced (e.g. to 1.0e-24) Index: LMDZ6/trunk/libf/phylmd/ecrad/random_numbers_mix.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad/random_numbers_mix.F90 (revision 4487) +++ LMDZ6/trunk/libf/phylmd/ecrad/random_numbers_mix.F90 (revision 4489) @@ -239,9 +239,8 @@ ! Generate uniformly distributed random numbers in the range 0.0<= px < 1.0 !-------------------------------------------------------------------------------- -! INTEGER(KIND=JPIM), PARAMETER :: IVAR=Z"3FFFFFFF" - INTEGER(KIND=JPIM) :: IVAR - DATA IVAR /Z"3FFFFFFF"/ + INTEGER(KIND=JPIM), PARAMETER :: IVAR = INT(Z"3FFFFFFF",JPIM) TYPE(RANDOMNUMBERSTREAM), INTENT(INOUT) :: YD_STREAM REAL(KIND=JPRB), DIMENSION(:), INTENT( OUT) :: PX + INTEGER(KIND=JPIM) :: JJ, JK, IN, IFILLED @@ -253,5 +252,5 @@ IF(YD_STREAM%INITTEST /= INITVALUE) & & CALL ABOR1 ('uniform_distribution called before initialize_random_numbers') - + !-------------------------------------------------------------------------------- ! Copy numbers that were generated during the last call, but not used. Index: LMDZ6/trunk/libf/phylmd/ecrad/readaerosol_optic_ecrad.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad/readaerosol_optic_ecrad.F90 (revision 4489) +++ LMDZ6/trunk/libf/phylmd/ecrad/readaerosol_optic_ecrad.F90 (revision 4489) @@ -0,0 +1,311 @@ +! $Id: readaerosol_optic_ecrad.F90 +! +SUBROUTINE readaerosol_optic_ecrad(debut, aerosol_couple, ok_alw, ok_volcan, & + flag_aerosol, flag_bc_internal_mixture, itap, rjourvrai, & + pdtphys, pplay, paprs, t_seri, rhcl, presnivs, & + tr_seri, mass_solu_aero, mass_solu_aero_pi, & + tau_aero, piz_aero, cg_aero, & + tausum_aero, drytausum_aero, tau3d_aero ) + + ! This routine will : + ! 1) recevie the aerosols(already read and interpolated) corresponding to flag_aerosol + ! 2) calculate the optical properties for the aerosols + ! + + USE dimphy + USE aero_mod + USE phys_local_var_mod, only: sconcso4,sconcno3,sconcoa,sconcbc,sconcss,sconcdust, & + concso4,concno3,concoa,concbc,concss,concdust,loadso4,loadoa,loadbc,loadss,loaddust, & + loadno3,load_tmp1,load_tmp2,load_tmp3,load_tmp4,load_tmp5,load_tmp6,load_tmp7, & + load_tmp8,load_tmp9,load_tmp10,m_allaer + + USE infotrac_phy, ONLY: tracers, nqtot, nbtr + USE YOMCST + + IMPLICIT NONE + + include "clesphys.h" + + ! Input arguments + !**************************************************************************************** + LOGICAL, INTENT(IN) :: debut + LOGICAL, INTENT(IN) :: aerosol_couple + LOGICAL, INTENT(IN) :: ok_alw + LOGICAL, INTENT(IN) :: ok_volcan + INTEGER, INTENT(IN) :: flag_aerosol + LOGICAL, INTENT(IN) :: flag_bc_internal_mixture + INTEGER, INTENT(IN) :: itap + REAL, INTENT(IN) :: rjourvrai + REAL, INTENT(IN) :: pdtphys + REAL, DIMENSION(klon,klev), INTENT(IN) :: pplay + REAL, DIMENSION(klon,klev+1), INTENT(IN) :: paprs + REAL, DIMENSION(klon,klev), INTENT(IN) :: t_seri + REAL, DIMENSION(klon,klev), INTENT(IN) :: rhcl ! humidite relative ciel clair + REAL, DIMENSION(klev), INTENT(IN) :: presnivs + REAL, DIMENSION(klon,klev,nbtr), INTENT(IN) :: tr_seri ! concentration tracer + + ! Output arguments + !**************************************************************************************** + REAL, DIMENSION(klon,klev), INTENT(OUT) :: mass_solu_aero ! Total mass for all soluble aerosols + REAL, DIMENSION(klon,klev), INTENT(OUT) :: mass_solu_aero_pi ! -"- preindustrial values + REAL, DIMENSION(klon,klev,2,NSW), INTENT(OUT) :: tau_aero ! Aerosol optical thickness + REAL, DIMENSION(klon,klev,2,NSW), INTENT(OUT) :: piz_aero ! Single scattering albedo aerosol + REAL, DIMENSION(klon,klev,2,NSW), INTENT(OUT) :: cg_aero ! asymmetry parameter aerosol + REAL, DIMENSION(klon,nwave,naero_tot), INTENT(OUT) :: tausum_aero + REAL, DIMENSION(klon,naero_tot), INTENT(OUT) :: drytausum_aero + REAL, DIMENSION(klon,klev,nwave,naero_tot), INTENT(OUT) :: tau3d_aero + + ! Local variables + !**************************************************************************************** + REAL, DIMENSION(klon) :: aerindex ! POLDER aerosol index + REAL, DIMENSION(klon,klev) :: sulfacc ! SO4 accumulation concentration [ug/m3] + REAL, DIMENSION(klon,klev) :: sulfcoarse ! SO4 coarse concentration [ug/m3] + REAL, DIMENSION(klon,klev) :: bcsol ! BC soluble concentration [ug/m3] + REAL, DIMENSION(klon,klev) :: bcins ! BC insoluble concentration [ug/m3] + REAL, DIMENSION(klon,klev) :: pomsol ! POM soluble concentration [ug/m3] + REAL, DIMENSION(klon,klev) :: pomins ! POM insoluble concentration [ug/m3] + REAL, DIMENSION(klon,klev) :: cidust ! DUST aerosol concentration [ug/m3] + REAL, DIMENSION(klon,klev) :: sscoarse ! SS Coarse concentration [ug/m3] + REAL, DIMENSION(klon,klev) :: sssupco ! SS Super Coarse concentration [ug/m3] + REAL, DIMENSION(klon,klev) :: ssacu ! SS Acumulation concentration [ug/m3] + REAL, DIMENSION(klon,klev) :: nitracc ! nitrate accumulation concentration [ug/m3] + REAL, DIMENSION(klon,klev) :: nitrcoarse ! nitrate coarse concentration [ug/m3] + REAL, DIMENSION(klon,klev) :: nitrinscoarse ! nitrate insoluble coarse concentration [ug/m3] + REAL, DIMENSION(klon,klev) :: sulfacc_pi + REAL, DIMENSION(klon,klev) :: sulfcoarse_pi + REAL, DIMENSION(klon,klev) :: bcsol_pi + REAL, DIMENSION(klon,klev) :: bcins_pi + REAL, DIMENSION(klon,klev) :: pomsol_pi + REAL, DIMENSION(klon,klev) :: pomins_pi + REAL, DIMENSION(klon,klev) :: cidust_pi + REAL, DIMENSION(klon,klev) :: sscoarse_pi + REAL, DIMENSION(klon,klev) :: sssupco_pi + REAL, DIMENSION(klon,klev) :: ssacu_pi + REAL, DIMENSION(klon,klev) :: nitracc_pi + REAL, DIMENSION(klon,klev) :: nitrcoarse_pi + REAL, DIMENSION(klon,klev) :: nitrinscoarse_pi + REAL, DIMENSION(klon,klev) :: pdel, zrho +! REAL, DIMENSION(klon,klev,naero_tot) :: m_allaer + REAL, DIMENSION(klon,klev,naero_tot) :: m_allaer_pi !RAF + + integer :: id_ASBCM, id_ASPOMM, id_ASSO4M, id_ASMSAM, id_CSSO4M, id_CSMSAM, id_SSSSM + integer :: id_CSSSM, id_ASSSM, id_CIDUSTM, id_AIBCM, id_AIPOMM, id_ASNO3M, id_CSNO3M, id_CINO3M + INTEGER :: k, i, iq, itr + + !--air density + zrho(:,:)=pplay(:,:)/t_seri(:,:)/RD !--kg/m3 + + !**************************************************************************************** + ! 1) Get aerosol mass + ! + !**************************************************************************************** + ! + ! + IF (aerosol_couple) THEN !--we get aerosols from tr_seri array from INCA + ! + !--copy fields from INCA tr_seri + !--convert to ug m-3 unit for consistency with offline fields + ! + itr = 0 + DO iq = 1,nqtot + IF(.NOT. tracers(iq)%isInPhysics) CYCLE + itr = itr+1 + SELECT CASE(trim(tracers(iq)%name)) + CASE ("ASBCM"); id_ASBCM = itr + CASE ("ASPOMM"); id_ASPOMM = itr + CASE ("ASSO4M"); id_ASSO4M = itr + CASE ("ASMSAM"); id_ASMSAM = itr + CASE ("CSSO4M"); id_CSSO4M = itr + CASE ("CSMSAM"); id_CSMSAM = itr + CASE ("SSSSM"); id_SSSSM = itr + CASE ("CSSSM"); id_CSSSM = itr + CASE ("ASSSM"); id_ASSSM = itr + CASE ("CIDUSTM");id_CIDUSTM= itr + CASE ("AIBCM"); id_AIBCM = itr + CASE ("AIPOMM"); id_AIPOMM = itr + CASE ("ASNO3M"); id_ASNO3M = itr + CASE ("CSNO3M"); id_CSNO3M = itr + CASE ("CINO3M"); id_CINO3M = itr + END SELECT + END DO + + bcsol(:,:) = tr_seri(:,:,id_ASBCM) *zrho(:,:)*1.e9 ! ASBCM + pomsol(:,:) = tr_seri(:,:,id_ASPOMM) *zrho(:,:)*1.e9 ! ASPOMM + sulfacc(:,:) = (tr_seri(:,:,id_ASSO4M)+tr_seri(:,:,id_ASMSAM))*zrho(:,:)*1.e9 ! ASSO4M (=SO4) + ASMSAM (=MSA) + sulfcoarse(:,:) = (tr_seri(:,:,id_CSSO4M)+tr_seri(:,:,id_CSMSAM))*zrho(:,:)*1.e9 ! CSSO4M (=SO4) + CSMSAM (=MSA) + sssupco(:,:) = tr_seri(:,:,id_SSSSM) *zrho(:,:)*1.e9 ! SSSSM + sscoarse(:,:) = tr_seri(:,:,id_CSSSM) *zrho(:,:)*1.e9 ! CSSSM + ssacu(:,:) = tr_seri(:,:,id_ASSSM) *zrho(:,:)*1.e9 ! ASSSM + cidust(:,:) = tr_seri(:,:,id_CIDUSTM) *zrho(:,:)*1.e9 ! CIDUSTM + bcins(:,:) = tr_seri(:,:,id_AIBCM) *zrho(:,:)*1.e9 ! AIBCM + pomins(:,:) = tr_seri(:,:,id_AIPOMM) *zrho(:,:)*1.e9 ! AIPOMM + nitracc(:,:) = tr_seri(:,:,id_ASNO3M) *zrho(:,:)*1.e9 ! ASNO3M + nitrcoarse(:,:) = tr_seri(:,:,id_CSNO3M) *zrho(:,:)*1.e9 ! CSNO3M + nitrinscoarse(:,:)= tr_seri(:,:,id_CINO3M) *zrho(:,:)*1.e9 ! CINO3M + ! + bcsol_pi(:,:) = 0.0 ! ASBCM pre-ind + pomsol_pi(:,:) = 0.0 ! ASPOMM pre-ind + sulfacc_pi(:,:) = 0.0 ! ASSO4M (=SO4) + ASMSAM (=MSA) pre-ind + sulfcoarse_pi(:,:) = 0.0 ! CSSO4M (=SO4) + CSMSAM (=MSA) pre-ind + sssupco_pi(:,:) = 0.0 ! SSSSM pre-ind + sscoarse_pi(:,:) = 0.0 ! CSSSM pre-ind + ssacu_pi(:,:) = 0.0 ! ASSSM pre-ind + cidust_pi(:,:) = 0.0 ! CIDUSTM pre-ind + bcins_pi(:,:) = 0.0 ! AIBCM pre-ind + pomins_pi(:,:) = 0.0 ! AIPOMM pre-ind + nitracc_pi(:,:) = 0.0 ! ASNO3M pre-ind + nitrcoarse_pi(:,:) = 0.0 ! CSNO3M pre-ind + nitrinscoarse_pi(:,:)= 0.0 ! CINO3M + ! + ELSE !--not aerosol_couple + ! + ! Read and interpolate sulfate + IF ( flag_aerosol .EQ. 1 .OR. flag_aerosol .EQ. 6 .OR. flag_aerosol .EQ. 7 ) THEN + + CALL readaerosol_interp(id_ASSO4M_phy, itap, pdtphys, rjourvrai, debut, pplay, paprs, t_seri, sulfacc, sulfacc_pi,loadso4) + ELSE + sulfacc(:,:) = 0. ; sulfacc_pi(:,:) = 0. + loadso4=0. + ENDIF + + ! Read and interpolate bcsol and bcins + IF ( flag_aerosol .EQ. 2 .OR. flag_aerosol .EQ. 6 .OR. flag_aerosol .EQ. 7 ) THEN + + ! Get bc aerosol distribution + CALL readaerosol_interp(id_ASBCM_phy, itap, pdtphys, rjourvrai, debut, pplay, paprs, t_seri, bcsol, bcsol_pi, load_tmp1 ) + CALL readaerosol_interp(id_AIBCM_phy, itap, pdtphys, rjourvrai, debut, pplay, paprs, t_seri, bcins, bcins_pi, load_tmp2 ) + loadbc(:)=load_tmp1(:)+load_tmp2(:) + ELSE + bcsol(:,:) = 0. ; bcsol_pi(:,:) = 0. + bcins(:,:) = 0. ; bcins_pi(:,:) = 0. + loadbc=0. + ENDIF + + ! Read and interpolate pomsol and pomins + IF ( flag_aerosol .EQ. 3 .OR. flag_aerosol .EQ. 6 .OR. flag_aerosol .EQ. 7 ) THEN + + CALL readaerosol_interp(id_ASPOMM_phy, itap, pdtphys, rjourvrai, debut, pplay, paprs, t_seri, pomsol, pomsol_pi, load_tmp3) + CALL readaerosol_interp(id_AIPOMM_phy, itap, pdtphys, rjourvrai, debut, pplay, paprs, t_seri, pomins, pomins_pi, load_tmp4) + loadoa(:)=load_tmp3(:)+load_tmp4(:) + ELSE + pomsol(:,:) = 0. ; pomsol_pi(:,:) = 0. + pomins(:,:) = 0. ; pomins_pi(:,:) = 0. + loadoa=0. + ENDIF + + ! Read and interpolate csssm, ssssm, assssm + IF (flag_aerosol .EQ. 4 .OR. flag_aerosol .EQ. 6 .OR. flag_aerosol .EQ. 7 ) THEN + + CALL readaerosol_interp(id_SSSSM_phy ,itap, pdtphys,rjourvrai, & + debut, pplay, paprs, t_seri, sssupco, sssupco_pi, load_tmp5) + CALL readaerosol_interp(id_CSSSM_phy ,itap, pdtphys,rjourvrai, & + debut, pplay, paprs, t_seri, sscoarse,sscoarse_pi, load_tmp6) + CALL readaerosol_interp(id_ASSSM_phy ,itap, pdtphys,rjourvrai, & + debut, pplay, paprs, t_seri, ssacu, ssacu_pi, load_tmp7) + loadss(:)=load_tmp5(:)+load_tmp6(:)+load_tmp7(:) + ELSE + sscoarse(:,:) = 0. ; sscoarse_pi(:,:) = 0. + ssacu(:,:) = 0. ; ssacu_pi(:,:) = 0. + sssupco(:,:) = 0. ; sssupco_pi = 0. + loadss=0. + ENDIF + + ! Read and interpolate cidustm + IF (flag_aerosol .EQ. 5 .OR. flag_aerosol .EQ. 6 .OR. flag_aerosol .EQ. 7 ) THEN + + CALL readaerosol_interp(id_CIDUSTM_phy, itap, pdtphys, rjourvrai, debut, pplay, paprs, t_seri, cidust, cidust_pi, loaddust) + + ELSE + cidust(:,:) = 0. ; cidust_pi(:,:) = 0. + loaddust=0. + ENDIF + ! + ! Read and interpolate asno3m, csno3m, cino3m + IF (flag_aerosol .EQ. 6 .OR. flag_aerosol .EQ. 7 ) THEN + + CALL readaerosol_interp(id_ASNO3M_phy, itap, pdtphys, rjourvrai, & + debut, pplay, paprs, t_seri, nitracc, nitracc_pi, load_tmp8) + CALL readaerosol_interp(id_CSNO3M_phy, itap, pdtphys, rjourvrai, & + debut, pplay, paprs, t_seri, nitrcoarse, nitrcoarse_pi, load_tmp9) + CALL readaerosol_interp(id_CINO3M_phy, itap, pdtphys, rjourvrai, & + debut, pplay, paprs, t_seri, nitrinscoarse, nitrinscoarse_pi, load_tmp10) + loadno3(:)=load_tmp8(:)+load_tmp9(:)+load_tmp10(:) + + ELSE + nitracc(:,:) = 0.0 ; nitracc_pi(:,:) = 0.0 + nitrcoarse(:,:) = 0.0 ; nitrcoarse_pi(:,:) = 0.0 + nitrinscoarse(:,:) = 0.0 ; nitrinscoarse_pi(:,:)= 0.0 + loadno3(:)=0.0 + ENDIF + ! + ! CSSO4M is set to 0 as not reliable + sulfcoarse(:,:) = 0.0 ! CSSO4M (=SO4) + CSMSAM (=MSA) + sulfcoarse_pi(:,:) = 0.0 ! CSSO4M (=SO4) + CSMSAM (=MSA) pre-ind + + ENDIF !--not aerosol_couple + + ! + ! Store all aerosols mixing ratios in one variable for radiation scheme (unit kg/kg for ECRAD) + ! present-day values + m_allaer(:,:,id_ASBCM_phy) = bcsol(:,:) /1.e9/zrho(:,:) ! ASBCM + m_allaer(:,:,id_ASPOMM_phy) = pomsol(:,:) /1.e9/zrho(:,:) ! ASPOMM + m_allaer(:,:,id_ASSO4M_phy) = sulfacc(:,:) /1.e9/zrho(:,:) ! ASSO4M (= SO4) + m_allaer(:,:,id_CSSO4M_phy) = sulfcoarse(:,:) /1.e9/zrho(:,:) ! CSSO4M + m_allaer(:,:,id_SSSSM_phy) = sssupco(:,:) /1.e9/zrho(:,:) ! SSSSM + m_allaer(:,:,id_CSSSM_phy) = sscoarse(:,:) /1.e9/zrho(:,:) ! CSSSM + m_allaer(:,:,id_ASSSM_phy) = ssacu(:,:) /1.e9/zrho(:,:) ! ASSSM + m_allaer(:,:,id_CIDUSTM_phy)= cidust(:,:) /1.e9/zrho(:,:) ! CIDUSTM + m_allaer(:,:,id_AIBCM_phy) = bcins(:,:) /1.e9/zrho(:,:) ! AIBCM + m_allaer(:,:,id_ASNO3M_phy) = nitracc(:,:) /1.e9/zrho(:,:) ! ASNO3M + m_allaer(:,:,id_CSNO3M_phy) = nitrcoarse(:,:) /1.e9/zrho(:,:) ! CSNO3M + m_allaer(:,:,id_CINO3M_phy) = nitrinscoarse(:,:)/1.e9/zrho(:,:) ! CINO3M + m_allaer(:,:,id_AIPOMM_phy) = pomins(:,:) /1.e9/zrho(:,:) ! AIPOMM + m_allaer(:,:,id_STRAT_phy) = 0.0 + + ! pre-industrial (pi) values + m_allaer_pi(:,:,id_ASBCM_phy) = bcsol_pi(:,:) /1.e9/zrho(:,:) ! ASBCM pre-ind + m_allaer_pi(:,:,id_ASPOMM_phy) = pomsol_pi(:,:) /1.e9/zrho(:,:) ! ASPOMM pre-ind + m_allaer_pi(:,:,id_ASSO4M_phy) = sulfacc_pi(:,:) /1.e9/zrho(:,:) ! ASSO4M (= SO4) pre-ind + m_allaer_pi(:,:,id_CSSO4M_phy) = sulfcoarse_pi(:,:) /1.e9/zrho(:,:) ! CSSO4M pre-ind + m_allaer_pi(:,:,id_SSSSM_phy) = sssupco_pi(:,:) /1.e9/zrho(:,:) ! SSSSM pre-ind + m_allaer_pi(:,:,id_CSSSM_phy) = sscoarse_pi(:,:) /1.e9/zrho(:,:) ! CSSSM pre-ind + m_allaer_pi(:,:,id_ASSSM_phy) = ssacu_pi(:,:) /1.e9/zrho(:,:) ! ASSSM pre-ind + m_allaer_pi(:,:,id_CIDUSTM_phy)= cidust_pi(:,:) /1.e9/zrho(:,:) ! CIDUSTM pre-ind + m_allaer_pi(:,:,id_AIBCM_phy) = bcins_pi(:,:) /1.e9/zrho(:,:) ! AIBCM pre-ind + m_allaer_pi(:,:,id_ASNO3M_phy) = nitracc_pi(:,:) /1.e9/zrho(:,:) ! ASNO3M pre-ind + m_allaer_pi(:,:,id_CSNO3M_phy) = nitrcoarse_pi(:,:) /1.e9/zrho(:,:) ! CSNO3M pre-ind + m_allaer_pi(:,:,id_CINO3M_phy) = nitrinscoarse_pi(:,:)/1.e9/zrho(:,:) ! CINO3M pre-ind + m_allaer_pi(:,:,id_AIPOMM_phy) = pomins_pi(:,:) /1.e9/zrho(:,:) ! AIPOMM pre-ind + m_allaer_pi(:,:,id_STRAT_phy) = 0.0 + + ! + ! Calculate the total mass of all soluble aersosols (in unit ug /m3) + ! to be revisited for AR6 + mass_solu_aero(:,:) = sulfacc(:,:) + bcsol(:,:) + pomsol(:,:) + nitracc(:,:) + ssacu(:,:) + mass_solu_aero_pi(:,:) = sulfacc_pi(:,:) + bcsol_pi(:,:) + pomsol_pi(:,:) + nitracc_pi(:,:) + ssacu_pi(:,:) + + !**************************************************************************************** + ! 2) Calculate optical properties for the aerosols + ! + !**************************************************************************************** + DO k = 1, klev + DO i = 1, klon + pdel(i,k) = paprs(i,k) - paprs (i,k+1) + ENDDO + ENDDO + + ! Diagnostics calculation for CMIP5 protocol unit (in unit kg/m3) + sconcso4(:) =m_allaer(:,1,id_ASSO4M_phy)*1.e-9 + sconcno3(:) =(m_allaer(:,1,id_ASNO3M_phy)+m_allaer(:,1,id_CSNO3M_phy)+m_allaer(:,1,id_CINO3M_phy))*1.e-9 + sconcoa(:) =(m_allaer(:,1,id_ASPOMM_phy)+m_allaer(:,1,id_AIPOMM_phy))*1.e-9 + sconcbc(:) =(m_allaer(:,1,id_ASBCM_phy)+m_allaer(:,1,id_AIBCM_phy))*1.e-9 + sconcss(:) =(m_allaer(:,1,id_ASSSM_phy)+m_allaer(:,1,id_CSSSM_phy)+m_allaer(:,1,id_SSSSM_phy))*1.e-9 + sconcdust(:) =m_allaer(:,1,id_CIDUSTM_phy)*1.e-9 + concso4(:,:) =m_allaer(:,:,id_ASSO4M_phy)*1.e-9 + concno3(:,:) =(m_allaer(:,:,id_ASNO3M_phy)+m_allaer(:,:,id_CSNO3M_phy)+m_allaer(:,:,id_CINO3M_phy))*1.e-9 + concoa(:,:) =(m_allaer(:,:,id_ASPOMM_phy)+m_allaer(:,:,id_AIPOMM_phy))*1.e-9 + concbc(:,:) =(m_allaer(:,:,id_ASBCM_phy)+m_allaer(:,:,id_AIBCM_phy))*1.e-9 + concss(:,:) =(m_allaer(:,:,id_ASSSM_phy)+m_allaer(:,:,id_CSSSM_phy)+m_allaer(:,:,id_SSSSM_phy))*1.e-9 + concdust(:,:)=m_allaer(:,:,id_CIDUSTM_phy)*1.e-9 + +END SUBROUTINE readaerosol_optic_ecrad Index: LMDZ6/trunk/libf/phylmd/ecrad/setup_aerosol_optics_lmdz_m.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecrad/setup_aerosol_optics_lmdz_m.F90 (revision 4489) +++ LMDZ6/trunk/libf/phylmd/ecrad/setup_aerosol_optics_lmdz_m.F90 (revision 4489) @@ -0,0 +1,126 @@ +module setup_aerosol_optics_lmdz_m + + implicit none + +contains + + subroutine setup_aerosol_optics_lmdz(ao, file_name) + + ! Read aerosol optical properties. Note differences with + ! "radiation_aerosol_optics_data::setup_aerosol_optics": + + ! -- The input NetCDF file is not flat, it contains NetCDF groups. + + ! -- We do not define ao%ssa_mono_phobic, ao%g_mono_phobic, + ! ao%lidar_ratio_mono_phobic, ao%ssa_mono_philic, + ! ao%g_mono_philic, ao%lidar_ratio_mono_philic. They are not in + ! the input NetCDF file and they are not used by ECRad. + + ! -- We do not define ao%description_phobic_str and + ! ao%description_philic_str. We just leave the initialization + ! value, which is a blank. + + ! -- We have to cshift the shortwave fields because the the + ! shortwave bands are in ascending order in the NetCDF file while + ! they are not in ECRad. + + use radiation_aerosol_optics_data, only: aerosol_optics_type, & + IAerosolClassUndefined + use netcdf95, only: nf95_open, nf95_inq_grp_full_ncid, nf95_close, & + nf95_inq_dimid, nf95_inq_varid, nf95_inquire_dimension, & + nf95_get_var, nf95_gw_var + use netcdf, only: nf90_nowrite + + type(aerosol_optics_type), intent(out):: ao + + character(len=*), intent(in):: file_name + ! NetCDF file containing the aerosol optics data + + ! Local: + integer ncid, grpid, dimid, varid + + !----------------------------------------------------------------------- + + ao%use_hydrophilic = .true. + ao%use_monochromatic = .true. + print*,'file_name= ',file_name + call nf95_open(file_name, nf90_nowrite, ncid) + call nf95_inq_grp_full_ncid(ncid, "Hydrophilic", grpid) + call nf95_inq_dimid(grpid, "hur", dimid) + call nf95_inquire_dimension(grpid, dimid, nclen = ao%nrh) + allocate(ao%rh_lower(ao%nrh)) + call nf95_inq_varid(grpid, "hur_bounds", varid) + call nf95_get_var(grpid, varid, ao%rh_lower, count_nc = [1, ao%nrh]) + + ! Hydrophilic/LW_bands: + call nf95_inq_grp_full_ncid(ncid, "Hydrophilic/LW_bands", grpid) + call nf95_inq_varid(grpid, "asymmetry", varid) + call nf95_gw_var(grpid, varid, ao%g_lw_philic) + call nf95_inq_varid(grpid, "single_scat_alb", varid) + call nf95_gw_var(grpid, varid, ao%ssa_lw_philic) + call nf95_inq_varid(grpid, "mass_ext", varid) + call nf95_gw_var(grpid, varid, ao%mass_ext_lw_philic) + + ! Hydrophilic/SW_bands: + call nf95_inq_grp_full_ncid(ncid, "Hydrophilic/SW_bands", grpid) + call nf95_inq_varid(grpid, "asymmetry", varid) + call nf95_gw_var(grpid, varid, ao%g_sw_philic) + ao%g_sw_philic = cshift(ao%g_sw_philic, 1) + call nf95_inq_varid(grpid, "single_scat_alb", varid) + call nf95_gw_var(grpid, varid, ao%ssa_sw_philic) + ao%g_sw_philic = cshift(ao%ssa_sw_philic, 1) + call nf95_inq_varid(grpid, "mass_ext", varid) + call nf95_gw_var(grpid, varid, ao%mass_ext_sw_philic) + ao%g_sw_philic = cshift(ao%mass_ext_sw_philic, 1) + + ! Hydrophilic/Monochromatic: + call nf95_inq_grp_full_ncid(ncid, "Hydrophilic/Monochromatic", grpid) + call nf95_inq_varid(grpid, "mass_ext", varid) + call nf95_gw_var(grpid, varid, ao%mass_ext_mono_philic) + + ! Hydrophobic/LW_bands: + call nf95_inq_grp_full_ncid(ncid, "Hydrophobic/LW_bands", grpid) + call nf95_inq_varid(grpid, "asymmetry", varid) + call nf95_gw_var(grpid, varid, ao%g_lw_phobic) + call nf95_inq_varid(grpid, "single_scat_alb", varid) + call nf95_gw_var(grpid, varid, ao%ssa_lw_phobic) + call nf95_inq_varid(grpid, "mass_ext", varid) + call nf95_gw_var(grpid, varid, ao%mass_ext_lw_phobic) + + ! Hydrophobic/SW_bands: + call nf95_inq_grp_full_ncid(ncid, "Hydrophobic/SW_bands", grpid) + call nf95_inq_varid(grpid, "asymmetry", varid) + call nf95_gw_var(grpid, varid, ao%g_sw_phobic) + ao%g_sw_phobic = cshift(ao%g_sw_phobic, 1) + call nf95_inq_varid(grpid, "single_scat_alb", varid) + call nf95_gw_var(grpid, varid, ao%ssa_sw_phobic) + ao%g_sw_phobic = cshift(ao%ssa_sw_phobic, 1) + call nf95_inq_varid(grpid, "mass_ext", varid) + call nf95_gw_var(grpid, varid, ao%mass_ext_sw_phobic) + ao%g_sw_phobic = cshift(ao%mass_ext_sw_phobic, 1) + + ! Hydrophobic/Monochromatic: + call nf95_inq_grp_full_ncid(ncid, "Hydrophobic/Monochromatic", grpid) + call nf95_inq_varid(grpid, "mass_ext", varid) + call nf95_gw_var(grpid, varid, ao%mass_ext_mono_phobic) + + call nf95_close(ncid) + + ! Get array sizes + ao%n_bands_lw = size(ao%mass_ext_lw_phobic, 1) + ao%n_bands_sw = size(ao%mass_ext_sw_phobic, 1) + ao%n_mono_wl = size(ao%mass_ext_mono_phobic, 1) + ao%n_type_phobic = size(ao%mass_ext_lw_phobic, 2) + ao%n_type_philic = size(ao%mass_ext_lw_philic, 3) + + ! Allocate memory for mapping arrays + ao%ntype = ao%n_type_phobic + ao%n_type_philic + allocate(ao%iclass(ao%ntype)) + allocate(ao%itype(ao%ntype)) + + ao%iclass = IAerosolClassUndefined + ao%itype = 0 + + end subroutine setup_aerosol_optics_lmdz + +end module setup_aerosol_optics_lmdz_m Index: LMDZ6/trunk/libf/phylmd/open_climoz_m.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/open_climoz_m.F90 (revision 4487) +++ LMDZ6/trunk/libf/phylmd/open_climoz_m.F90 (revision 4489) @@ -27,7 +27,7 @@ ! Arguments (OpenMP shared): INTEGER, INTENT(OUT):: ncid !--- "climoz_LMDZ.nc" identifier - REAL, POINTER :: press_in_cen(:) !--- at cells centers - REAL, POINTER :: press_in_edg(:) !--- at the interfaces (pressure intervals) - REAL, POINTER :: time_in(:) !--- records times, in days since Jan. 1st + REAL, allocatable, intent(out):: press_in_cen(:) !--- at cells centers + REAL, allocatable, INTENT(OUT):: press_in_edg(:) !--- at the interfaces (pressure intervals) + REAL, allocatable, intent(out):: time_in(:) !--- records times, in days since Jan. 1st LOGICAL, INTENT(IN) :: daily !--- daily files (calendar dependent days nb) LOGICAL, INTENT(IN) :: adjust !--- tropopause adjustement required Index: LMDZ6/trunk/libf/phylmd/phys_local_var_mod.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/phys_local_var_mod.F90 (revision 4487) +++ LMDZ6/trunk/libf/phylmd/phys_local_var_mod.F90 (revision 4489) @@ -24,4 +24,6 @@ REAL, SAVE, ALLOCATABLE :: tr_seri(:,:,:) !$OMP THREADPRIVATE(tr_seri) + REAL, SAVE, ALLOCATABLE :: rhcl(:,:) + !$OMP THREADPRIVATE(rhcl) REAL, SAVE, ALLOCATABLE :: d_t_dyn(:,:), d_q_dyn(:,:) !$OMP THREADPRIVATE(d_t_dyn, d_q_dyn) @@ -116,4 +118,7 @@ !$OMP THREADPRIVATE(d_ts, d_tr) +! aerosols + REAL, SAVE, ALLOCATABLE :: m_allaer (:,:,:) + !$OMP THREADPRIVATE(m_allaer) ! diagnostique pour le rayonnement REAL, SAVE, ALLOCATABLE :: topswad_aero(:), solswad_aero(:) ! diag @@ -608,4 +613,5 @@ l_mix(:,:,:)=0.;l_mixmin(:,:,:)=0.;tke_dissip(:,:,:)=0.;wprime(:,:,:)=0. ! doit etre initialse car pas toujours remplis + ALLOCATE(rhcl(klon,klev)) ALLOCATE(tr_seri(klon,klev,nbtr)) ALLOCATE(d_t_dyn(klon,klev),d_q_dyn(klon,klev)) @@ -647,4 +653,7 @@ ALLOCATE(d_u_lif(klon,klev),d_v_lif(klon,klev)) ALLOCATE(d_ts(klon,nbsrf), d_tr(klon,klev,nbtr)) + +! aerosols + ALLOCATE(m_allaer(klon,klev,naero_tot)) ! Special RRTM ALLOCATE(ZLWFT0_i(klon,klev+1),ZSWFT0_i(klon,klev+1),ZFLDN0(klon,klev+1)) @@ -937,4 +946,5 @@ DEALLOCATE(l_mixmin,l_mix, tke_dissip,wprime) + DEALLOCATE(rhcl) DEALLOCATE(tr_seri) DEALLOCATE(d_t_dyn,d_q_dyn) @@ -1046,5 +1056,6 @@ DEALLOCATE(solsw_aerop, solsw0_aerop) DEALLOCATE(topswcf_aerop, solswcf_aerop) - +!AI Aerosols + DEALLOCATE(m_allaer) !CK LW diagnostics DEALLOCATE(toplwad_aerop, sollwad_aerop) Index: LMDZ6/trunk/libf/phylmd/phys_output_write_mod.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/phys_output_write_mod.F90 (revision 4487) +++ LMDZ6/trunk/libf/phylmd/phys_output_write_mod.F90 (revision 4489) @@ -1569,4 +1569,5 @@ !--OLIVIER !This is warranted by treating INCA aerosols as offline aerosols +#ifndef CPP_ECRAD IF (flag_aerosol.GT.0) THEN IF (type_trac/='inca' .OR. config_inca=='aeNP') THEN @@ -1774,4 +1775,5 @@ ENDIF ENDIF + CALL histwrite_phy(o_lwcon, flwc) CALL histwrite_phy(o_iwcon, fiwc) @@ -1808,4 +1810,5 @@ #endif !solbnd end +#endif #endif Index: LMDZ6/trunk/libf/phylmd/physiq_mod.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/physiq_mod.F90 (revision 4487) +++ LMDZ6/trunk/libf/phylmd/physiq_mod.F90 (revision 4489) @@ -145,4 +145,5 @@ ! Variables locales pour effectuer les appels en serie t_seri,q_seri,ql_seri,qs_seri,u_seri,v_seri,tr_seri,rneb_seri, & + rhcl, & ! Dynamic tendencies (diagnostics) d_t_dyn,d_q_dyn,d_ql_dyn,d_qs_dyn,d_u_dyn,d_v_dyn,d_tr_dyn,d_rneb_dyn, & @@ -826,5 +827,5 @@ ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! - REAL rhcl(klon,klev) ! humiditi relative ciel clair +! REAL rhcl(klon,klev) ! humiditi relative ciel clair REAL dialiq(klon,klev) ! eau liquide nuageuse REAL diafra(klon,klev) ! fraction nuageuse @@ -1120,7 +1121,7 @@ ! climatology and the daylight climatology INTEGER,SAVE :: ncid_climoz ! NetCDF file identifier - REAL, POINTER, SAVE :: press_cen_climoz(:) ! Pressure levels - REAL, POINTER, SAVE :: press_edg_climoz(:) ! Edges of pressure intervals - REAL, POINTER, SAVE :: time_climoz(:) ! Time vector + REAL, allocatable, SAVE :: press_cen_climoz(:) ! Pressure levels + REAL, allocatable, SAVE :: press_edg_climoz(:) ! Edges of pressure intervals + REAL, allocatable, SAVE :: time_climoz(:) ! Time vector CHARACTER(LEN=13), PARAMETER :: vars_climoz(2) & = ["tro3 ","tro3_daylight"] @@ -4013,5 +4014,5 @@ tausum_aero, tau3d_aero) ENDIF - ELSE ! RRTM radiation + ELSE IF (iflag_rrtm .EQ.1) THEN ! RRTM radiation IF (aerosol_couple .AND. config_inca == 'aero' ) THEN abort_message='config_inca=aero et rrtm=1 impossible' @@ -4079,5 +4080,19 @@ ! ENDIF + ELSE IF (iflag_rrtm .EQ.2) THEN ! ecrad RADIATION +#ifdef CPP_ECRAD + !--climatologies or INCA aerosols + CALL readaerosol_optic_ecrad( debut, aerosol_couple, ok_alw, ok_volcan, & + flag_aerosol, flag_bc_internal_mixture, itap, jD_cur-jD_ref, & + pdtphys, pplay, paprs, t_seri, rhcl, presnivs, & + tr_seri, mass_solu_aero, mass_solu_aero_pi, & + tau_aero_sw_rrtm, piz_aero_sw_rrtm, cg_aero_sw_rrtm, & + tausum_aero, drytausum_aero, tau3d_aero) +#else + abort_message='You should compile with -rad ecrad if running with iflag_rrtm=2' + CALL abort_physic(modname,abort_message,1) +#endif ENDIF + ELSE !--flag_aerosol = 0 tausum_aero(:,:,:) = 0. @@ -5388,6 +5403,6 @@ IF (read_climoz >= 1) THEN IF (is_mpi_root) CALL nf95_close(ncid_climoz) - DEALLOCATE(press_edg_climoz) ! pointer - DEALLOCATE(press_cen_climoz) ! pointer + DEALLOCATE(press_edg_climoz) + DEALLOCATE(press_cen_climoz) ENDIF Index: LMDZ6/trunk/libf/phylmd/press_coefoz_m.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/press_coefoz_m.F90 (revision 4487) +++ LMDZ6/trunk/libf/phylmd/press_coefoz_m.F90 (revision 4489) @@ -4,5 +4,5 @@ implicit none - real, pointer, save:: plev(:) + real, allocatable, save:: plev(:) ! (pressure level of Mobidic input data, converted to Pa, in strictly ! ascending order) Index: LMDZ6/trunk/libf/phylmd/radlwsw_m.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/radlwsw_m.F90 (revision 4487) +++ LMDZ6/trunk/libf/phylmd/radlwsw_m.F90 (revision 4489) @@ -78,4 +78,5 @@ ! Besoin pour ECRAD de pctsrf, zmasq, longitude, altitude #ifdef CPP_ECRAD + USE phys_local_var_mod, ONLY: rhcl, m_allaer USE geometry_mod, ONLY: latitude, longitude USE phys_state_var_mod, ONLY: pctsrf @@ -323,5 +324,5 @@ ZQ_SNOW(klon,klev) ! Snow cloud mass mixing ratio (kg/kg) ? REAL(KIND=8) ZAEROSOL_OLD(KLON,6,KLEV), & ! - ZAEROSOL(KLON,KLEV,naero_tot) ! + ZAEROSOL(KLON,KLEV,naero_grp) ! ! OUTPUTS REAL(KIND=8) ZFLUX_DIR(klon), & ! Direct compt of surf flux into horizontal plane @@ -1181,7 +1182,7 @@ ! ! AI ATTENTION Aerosols A REVOIR -! DO i = 1, kdlon -! DO k = 1, kflev -! DO kk= 1, naero_tot + DO i = 1, kdlon + DO k = 1, kflev + DO kk= 1, naero_grp ! DO kk=1, NSW ! @@ -1194,8 +1195,9 @@ ! PCGA_NAT(i,kflev+1-k,kk)=cg_aero_sw_rrtm(i,k,1,kk) ! ZAEROSOL(i,kflev+1-k,kk)=m_allaer(i,k,kk) -! -! ENDDO -! ENDDO -! ENDDO + ZAEROSOL(i,kflev+1-k,kk)=m_allaer(i,k,kk) +! + ENDDO + ENDDO + ENDDO !-end OB ! @@ -1345,8 +1347,9 @@ CALL RADIATION_SCHEME & - & (ist, iend, klon, klev, naero_tot, NSW, & -! ??? naero_tot + & (ist, iend, klon, klev, naero_grp, NSW, & & day_cur, current_time, & +! Cste solaire/(d_Terre-Soleil)**2 & SOLARIRAD, & +! Cos(angle zin), temp sol & rmu0, tsol, & ! Albedo diffuse et directe @@ -1354,11 +1357,7 @@ ! Emessivite : PEMIS_WINDOW (???), & & ZEMIS, ZEMISW, & -! PCCN_LAND, PCCN_SEA, & ??? - & pctsrf(:,is_ter), pctsrf(:,is_oce), & ! longitude(rad), sin(latitude), PMASQ_ ??? - & ZGELAM, ZGEMU, zmasq, & -! pression et temp aux milieux - & pplay_i, t_i, & -! PTEMPERATURE_H ?, + & ZGELAM, ZGEMU, & +! Temp et pres aux interf, vapeur eau, Satur spec humid & paprs_i, ZTH_i, q_i, qsat_i, & ! Gas @@ -1366,5 +1365,6 @@ & ZCCL4, POZON_i(:,:,1), ZO2, & ! nuages : - & cldfra_i, flwc_i, fiwc_i, ZQ_RAIN, ZQ_SNOW, & + & cldfra_i, flwc_i, fiwc_i, ZQ_SNOW, & +! rayons effectifs des gouttelettes & ref_liq_i, ref_ice_i, & ! aerosols Index: LMDZ6/trunk/libf/phylmd/readaerosolstrato.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/readaerosolstrato.F90 (revision 4487) +++ LMDZ6/trunk/libf/phylmd/readaerosolstrato.F90 (revision 4489) @@ -31,8 +31,8 @@ integer n_lev ! number of levels in the input data integer n_month ! number of months in the input data - real, pointer:: latitude(:) - real, pointer:: longitude(:) - real, pointer:: time(:) - real, pointer:: lev(:) + real, allocatable:: latitude(:) + real, allocatable:: longitude(:) + real, allocatable:: time(:) + real, allocatable:: lev(:) integer i, k, band, wave integer, save :: mth_pre=1 Index: LMDZ6/trunk/libf/phylmd/readaerosolstrato_m.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/readaerosolstrato_m.F90 (revision 4487) +++ LMDZ6/trunk/libf/phylmd/readaerosolstrato_m.F90 (revision 4489) @@ -32,6 +32,6 @@ ! USE YOERAD, ONLY : NLW IMPLICIT NONE - REAL, POINTER:: latitude(:) - REAL, POINTER:: longitude(:) + REAL, allocatable:: latitude(:) + REAL, allocatable:: longitude(:) INTEGER :: nlat, nlon REAL :: null_array(0) @@ -75,6 +75,6 @@ ! USE YOERAD, ONLY : NLW IMPLICIT NONE - REAL, POINTER:: latitude(:) - REAL, POINTER:: wav(:) + REAL, allocatable:: latitude(:) + REAL, allocatable:: wav(:) INTEGER :: nlat,n_wav REAL :: null_array(0) Index: LMDZ6/trunk/libf/phylmd/readchlorophyll.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/readchlorophyll.F90 (revision 4487) +++ LMDZ6/trunk/libf/phylmd/readchlorophyll.F90 (revision 4489) @@ -29,7 +29,7 @@ INTEGER n_lev ! number of levels in the input data INTEGER n_month ! number of months in the input data - REAL, POINTER :: latitude(:) - REAL, POINTER :: longitude(:) - REAL, POINTER :: time(:) + REAL, ALLOCATABLE :: latitude(:) + REAL, ALLOCATABLE :: longitude(:) + REAL, ALLOCATABLE :: time(:) INTEGER i, k INTEGER, SAVE :: mth_pre Index: LMDZ6/trunk/libf/phylmd/regr_horiz_time_climoz_m.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/regr_horiz_time_climoz_m.F90 (revision 4487) +++ LMDZ6/trunk/libf/phylmd/regr_horiz_time_climoz_m.F90 (revision 4489) @@ -4,10 +4,10 @@ USE mod_grid_phy_lmdz, ONLY: nbp_lon, nbp_lat, grid_type, unstructured USE nrtype, ONLY: pi - USE netcdf, ONLY: NF90_CLOBBER, NF90_FLOAT, NF90_GET_VAR, NF90_OPEN, & + USE netcdf, ONLY: NF90_CLOBBER, NF90_FLOAT, NF90_OPEN, & NF90_NOWRITE, NF90_NOERR, NF90_GET_ATT, NF90_GLOBAL USE netcdf95, ONLY: NF95_DEF_DIM, NF95_INQ_DIMID, NF95_INQUIRE_DIMENSION, & - NF95_DEF_VAR, NF95_INQ_VARID, NF95_INQUIRE_VARIABLE, & - NF95_OPEN, NF95_CREATE, NF95_GET_ATT, NF95_GW_VAR, HANDLE_ERR, & - NF95_CLOSE, NF95_ENDDEF, NF95_PUT_ATT, NF95_PUT_VAR, NF95_COPY_ATT + NF95_DEF_VAR, NF95_INQ_VARID, NF95_INQUIRE_VARIABLE, & + NF95_OPEN, NF95_CREATE, NF95_GET_ATT, NF95_GW_VAR, nf95_get_var, & + NF95_CLOSE, NF95_ENDDEF, NF95_PUT_ATT, NF95_PUT_VAR, NF95_COPY_ATT USE print_control_mod, ONLY: lunout USE dimphy @@ -88,7 +88,7 @@ INTEGER :: nlev_in ! Number of pressure levels INTEGER :: nmth_in ! Number of months - REAL, POINTER :: lon_in(:) ! Longitudes (ascending order, rad) - REAL, POINTER :: lat_in(:) ! Latitudes (ascending order, rad) - REAL, POINTER :: lev_in(:) ! Pressure levels (ascen. order, hPa) + REAL, ALLOCATABLE:: lon_in(:) ! Longitudes (ascending order, rad) + REAL, ALLOCATABLE:: lat_in(:) ! Latitudes (ascending order, rad) + REAL, ALLOCATABLE:: lev_in(:) ! Pressure levels (ascen. order, hPa) REAL, ALLOCATABLE :: lon_in_edge(:) ! Longitude intervals edges ! (ascending order, / ) @@ -125,5 +125,5 @@ INTEGER :: fID_in_m, fID_in, levID_ou, dimid, vID_in(read_climoz), ntim_ou INTEGER :: fID_in_p, fID_ou, timID_ou, varid, vID_ou(read_climoz), ndims, ncerr - INTEGER, POINTER :: dIDs(:) + INTEGER, ALLOCATABLE :: dIDs(:) CHARACTER(LEN=20) :: cal_ou !--- Calendar; no time inter => same as input CHARACTER(LEN=80) :: press_unit !--- Pressure unit @@ -333,20 +333,16 @@ !--- Read full current file and one record each available contiguous file DO iv=1,read_climoz - msg=TRIM(sub)//" NF90_GET_VAR "//TRIM(vars_in(iv)) CALL NF95_INQ_VARID(fID_in, vars_in(1), vID_in(iv)) - IF(l3D) ncerr=NF90_GET_VAR(fID_in, vID_in(iv), o3_in3(1:nlon_in,:,:,1:12,iv)) - IF(l2D) ncerr=NF90_GET_VAR(fID_in, vID_in(iv), o3_in2( :,:,1:12,iv)) - CALL handle_err(TRIM(msg), ncerr, fID_in) + IF(l3D) call NF95_GET_VAR(fID_in, vID_in(iv), o3_in3(1:nlon_in,:,:,1:12,iv)) + IF(l2D) call NF95_GET_VAR(fID_in, vID_in(iv), o3_in2( :,:,1:12,iv)) IF(lprev) THEN; sta(ndims)=12 CALL NF95_INQ_VARID(fID_in_m, vars_in(1), vID_in(iv)) - IF(l3D) ncerr=NF90_GET_VAR(fID_in_m,vID_in(iv),o3_in3(1:nlon_in,:,:, 0,iv),sta,cnt) - IF(l2d) ncerr=NF90_GET_VAR(fID_in_m,vID_in(iv),o3_in2( :,:, 0,iv),sta,cnt) - CALL handle_err(TRIM(msg)//" previous", ncerr, fID_in_m) + IF(l3D) call NF95_GET_VAR(fID_in_m,vID_in(iv),o3_in3(1:nlon_in,:,:, 0,iv),sta,cnt) + IF(l2d) call NF95_GET_VAR(fID_in_m,vID_in(iv),o3_in2( :,:, 0,iv),sta,cnt) END IF IF(lnext) THEN; sta(ndims)=1 CALL NF95_INQ_VARID(fID_in_p, vars_in(1), vID_in(iv)) - IF(l3D) ncerr=NF90_GET_VAR(fID_in_p,vID_in(iv),o3_in3(1:nlon_in,:,:,13,iv),sta,cnt) - IF(l2D) ncerr=NF90_GET_VAR(fID_in_p,vID_in(iv),o3_in2( :,:,13,iv),sta,cnt) - CALL handle_err(TRIM(msg)//" next", ncerr, fID_in_p) + IF(l3D) call NF95_GET_VAR(fID_in_p,vID_in(iv),o3_in3(1:nlon_in,:,:,13,iv),sta,cnt) + IF(l2D) call NF95_GET_VAR(fID_in_p,vID_in(iv),o3_in2( :,:,13,iv),sta,cnt) END IF END DO Index: LMDZ6/trunk/libf/phylmd/regr_lat_time_coefoz_m.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/regr_lat_time_coefoz_m.F90 (revision 4487) +++ LMDZ6/trunk/libf/phylmd/regr_lat_time_coefoz_m.F90 (revision 4489) @@ -43,7 +43,7 @@ use regr_conserv_m, only: regr_conserv use regr_lint_m, only: regr_lint - use netcdf95, only: nf95_open, nf95_close, nf95_inq_varid, handle_err, & + use netcdf95, only: nf95_open, nf95_close, nf95_inq_varid, nf95_get_var, & nf95_put_var, nf95_gw_var - use netcdf, only: nf90_nowrite, nf90_get_var + use netcdf, only: nf90_nowrite use nrtype, only: pi use regular_lonlat_mod, only: boundslat_reg, south @@ -55,5 +55,5 @@ integer n_lat! number of latitudes in the input data - real, pointer:: latitude(:) + real, allocatable:: latitude(:) ! (of input data, converted to rad, sorted in strictly ascending order) @@ -62,5 +62,5 @@ ! ascending order) - real, pointer:: plev(:) ! pressure level of input data + real, allocatable:: plev(:) ! pressure level of input data logical desc_lat ! latitude in descending order in the input file @@ -172,5 +172,5 @@ forall (j = 2:n_lat) lat_in_edg(j) = (latitude(j - 1) + latitude(j)) / 2 lat_in_edg(n_lat + 1) = pi / 2 - deallocate(latitude) ! pointer + deallocate(latitude) call nf95_inq_varid(ncid_in, "plev", varid) @@ -192,5 +192,5 @@ call nf95_put_var(ncid_out, varid_plev, plev) - deallocate(plev) ! pointer + deallocate(plev) allocate(o3_par_in(n_lat, n_plev, 12)) @@ -201,7 +201,5 @@ ! Process ozone parameter "name_in(i_v)" - ncerr = nf90_get_var(ncid_in, varid_in(i_v), o3_par_in) - call handle_err("nf90_get_var", ncerr, ncid_in) - + call nf95_get_var(ncid_in, varid_in(i_v), o3_par_in) if (desc_lat) o3_par_in = o3_par_in(n_lat:1:-1, :, :) Index: LMDZ6/trunk/libf/phylmd/regr_pr_int_m.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/regr_pr_int_m.F90 (revision 4487) +++ LMDZ6/trunk/libf/phylmd/regr_pr_int_m.F90 (revision 4489) @@ -25,6 +25,5 @@ use dimphy, only: klon - use netcdf95, only: nf95_inq_varid, handle_err - use netcdf, only: nf90_get_var + use netcdf95, only: nf95_inq_varid, nf95_get_var use assert_m, only: assert use regr_lint_m, only: regr_lint @@ -79,6 +78,5 @@ ! Get data at the right day from the input file: - ncerr = nf90_get_var(ncid, varid, v1(1, :, 1:), start=(/1, 1, julien/)) - call handle_err("regr_pr_int nf90_get_var " // name, ncerr, ncid) + call nf95_get_var(ncid, varid, v1(1, :, 1:), start=(/1, 1, julien/)) ! Latitudes are in ascending order in the input file while ! "rlatu" is in descending order so we need to invert order: Index: LMDZ6/trunk/libf/phylmd/regr_pr_o3_m.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/regr_pr_o3_m.F90 (revision 4487) +++ LMDZ6/trunk/libf/phylmd/regr_pr_o3_m.F90 (revision 4489) @@ -25,6 +25,6 @@ ! hPa and strictly increasing. - use netcdf95, only: nf95_open, nf95_close, nf95_inq_varid, handle_err - use netcdf, only: nf90_nowrite, nf90_get_var + use netcdf95, only: nf95_open, nf95_close, nf95_inq_varid, nf95_get_var + use netcdf, only: nf90_nowrite use assert_m, only: assert use regr_conserv_m, only: regr_conserv @@ -63,6 +63,5 @@ call nf95_inq_varid(ncid, "r_Mob", varid) ! Get data at the right day from the input file: - ncerr = nf90_get_var(ncid, varid, r_mob, start=(/1, 1, day_ref/)) - call handle_err("nf90_get_var r_Mob", ncerr) + call nf95_get_var(ncid, varid, r_mob, start=(/1, 1, day_ref/)) ! Latitudes are in ascending order in the input file while ! "rlatu" is in descending order so we need to invert order: Index: LMDZ6/trunk/libf/phylmd/regr_pr_time_av_m.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/regr_pr_time_av_m.F90 (revision 4487) +++ LMDZ6/trunk/libf/phylmd/regr_pr_time_av_m.F90 (revision 4489) @@ -113,7 +113,7 @@ !------------------------------------------------------------------------------- USE dimphy, ONLY: klon - USE netcdf95, ONLY: NF95_INQ_VARID, NF95_INQUIRE_VARIABLE, handle_err, & - NF95_INQ_DIMID, NF95_INQUIRE_DIMENSION - USE netcdf, ONLY: NF90_INQ_VARID, NF90_GET_VAR, NF90_NOERR + USE netcdf95, ONLY: NF95_INQ_VARID, NF95_INQUIRE_VARIABLE, & + NF95_INQ_DIMID, NF95_INQUIRE_DIMENSION, nf95_get_var + USE netcdf, ONLY: NF90_INQ_VARID, NF90_NOERR USE assert_m, ONLY: assert USE assert_eq_m, ONLY: assert_eq @@ -482,7 +482,6 @@ CALL NF95_INQ_VARID(fID, TRIM(var), vID) CALL NF95_INQUIRE_VARIABLE(fID, vID, ndims=n_dim) - IF(n_dim==2) ncerr=NF90_GET_VAR(fID,vID,v(1,:), start=[ 1,irec]) - IF(n_dim==3) ncerr=NF90_GET_VAR(fID,vID,v(:,:), start=[1,1,irec]) - CALL handle_err(TRIM(sub)//" NF90_GET_VAR "//TRIM(var),ncerr,fID) + IF(n_dim==2) call NF95_GET_VAR(fID,vID,v(1,:), start=[ 1,irec]) + IF(n_dim==3) call NF95_GET_VAR(fID,vID,v(:,:), start=[1,1,irec]) !--- Flip latitudes: ascending in input file, descending in "rlatu". @@ -514,7 +513,6 @@ CALL NF95_INQ_VARID(fID, TRIM(nam(i)), vID) CALL NF95_INQUIRE_VARIABLE(fID, vID, ndims=n_dim) - IF(n_dim==3) ncerr=NF90_GET_VAR(fID,vID,v(1,:,:,i), start=[ 1,1,irec]) - IF(n_dim==4) ncerr=NF90_GET_VAR(fID,vID,v(:,:,:,i), start=[1,1,1,irec]) - CALL handle_err(TRIM(sub)//" NF90_GET_VAR "//TRIM(nam(i)),ncerr,fID) + IF(n_dim==3) call NF95_GET_VAR(fID,vID,v(1,:,:,i), start=[ 1,1,irec]) + IF(n_dim==4) call NF95_GET_VAR(fID,vID,v(:,:,:,i), start=[1,1,1,irec]) END DO Index: LMDZ6/trunk/libf/phylmd/rrtm/read_rsun_rrtm.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/rrtm/read_rsun_rrtm.F90 (revision 4487) +++ LMDZ6/trunk/libf/phylmd/rrtm/read_rsun_rrtm.F90 (revision 4489) @@ -27,5 +27,5 @@ ! Local variables INTEGER :: ncid, dimid, varid, ncerr, nbday - REAL, POINTER :: wlen(:), time(:) + REAL, ALLOCATABLE :: wlen(:), time(:) REAL, ALLOCATABLE, SAVE, DIMENSION(:,:) :: SSI_FRAC !$OMP THREADPRIVATE(SSI_FRAC) Index: LMDZ6/trunk/libf/phylmd/rrtm/readaerosolstrato1_rrtm.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/rrtm/readaerosolstrato1_rrtm.F90 (revision 4487) +++ LMDZ6/trunk/libf/phylmd/rrtm/readaerosolstrato1_rrtm.F90 (revision 4489) @@ -32,8 +32,8 @@ INTEGER n_lev ! number of levels in the input data INTEGER n_month ! number of months in the input data - REAL, POINTER:: latitude(:) - REAL, POINTER:: longitude(:) - REAL, POINTER:: time(:) - REAL, POINTER:: lev(:) + REAL, ALLOCATABLE:: latitude(:) + REAL, ALLOCATABLE:: longitude(:) + REAL, ALLOCATABLE:: time(:) + REAL, ALLOCATABLE:: lev(:) INTEGER k, band, wave, i INTEGER, SAVE :: mth_pre=1 Index: LMDZ6/trunk/libf/phylmd/rrtm/readaerosolstrato2_rrtm.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/rrtm/readaerosolstrato2_rrtm.F90 (revision 4487) +++ LMDZ6/trunk/libf/phylmd/rrtm/readaerosolstrato2_rrtm.F90 (revision 4489) @@ -40,8 +40,8 @@ INTEGER n_month ! number of months in the input data INTEGER n_wav ! number of wavelengths in the input data - REAL, POINTER:: latitude(:) - REAL, POINTER:: time(:) - REAL, POINTER:: lev(:) - REAL, POINTER:: wav(:) + REAL, ALLOCATABLE:: latitude(:) + REAL, ALLOCATABLE:: time(:) + REAL, ALLOCATABLE:: lev(:) + REAL, ALLOCATABLE:: wav(:) INTEGER i,k,wave,band INTEGER, SAVE :: mth_pre=1 Index: LMDZ6/trunk/libf/phylmd/tracco2i_mod.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/tracco2i_mod.F90 (revision 4487) +++ LMDZ6/trunk/libf/phylmd/tracco2i_mod.F90 (revision 4489) @@ -365,5 +365,5 @@ INTEGER :: n_glo, n_month - REAL, POINTER:: vector(:), time(:) + REAL, allocatable:: vector(:), time(:) REAL,ALLOCATABLE :: flx_co2ff_glo(:,:) ! fossil-fuel CO2 REAL,ALLOCATABLE :: flx_co2bb_glo(:,:) ! biomass-burning CO2 Index: LMDZ6/trunk/makelmdz =================================================================== --- LMDZ6/trunk/makelmdz (revision 4487) +++ LMDZ6/trunk/makelmdz (revision 4489) @@ -476,4 +476,7 @@ #=============================================================================== +INCLUDE="$INCLUDE ${NETCDF95_INCDIR}" +LIB="$LIB ${NETCDF95_LIBDIR} -l${LIBPREFIX}netcdf95" + if [[ $io == ioipsl ]] then Index: LMDZ6/trunk/makelmdz_fcm =================================================================== --- LMDZ6/trunk/makelmdz_fcm (revision 4487) +++ LMDZ6/trunk/makelmdz_fcm (revision 4489) @@ -501,4 +501,7 @@ fi +INCLUDE="$INCLUDE ${NETCDF95_INCDIR}" +LIB="$LIB ${NETCDF95_LIBDIR} ${NETCDF95_LIB}" + if [[ $io == ioipsl ]] then @@ -790,10 +793,4 @@ build_status=$? -err=$? -# Check error message from fcm build -if [ $err != 0 ] ; then - exit 1 -fi - rm -rf tmp_src rm -rf config