From 100a64649b77296bc16388dfb4573830165f6a29 Mon Sep 17 00:00:00 2001 From: "Bin.Liu" Date: Wed, 24 Jun 2020 15:05:59 +0000 Subject: [PATCH] Cleanup trailing whitespace for some new added/modified source code related to hwrf_physics. --- physics/HWRF_mcica_random_numbers.F90 | 216 +-- physics/HWRF_mersenne_twister.F90 | 600 ++++---- physics/docs/pdftxt/HWRF_FAMP.txt | 30 +- physics/gfdl_sfc_layer.F90 | 366 ++--- physics/gfdl_sfc_layer.meta | 2 +- physics/module_sf_exchcoef.f90 | 46 +- physics/module_sf_noahlsm.F90 | 56 +- physics/module_sf_noahlsm_glacial_only.F90 | 28 +- physics/radiation_clouds.f | 818 +++++----- physics/radlw_main.F90 | 1568 ++++++++++---------- physics/radsw_main.F90 | 1116 +++++++------- physics/sfc_noah_wrfv4.F90 | 60 +- physics/sfc_noah_wrfv4.meta | 10 +- physics/sfc_noah_wrfv4_interstitial.F90 | 156 +- physics/sfc_noah_wrfv4_interstitial.meta | 2 +- 15 files changed, 2537 insertions(+), 2537 deletions(-) diff --git a/physics/HWRF_mcica_random_numbers.F90 b/physics/HWRF_mcica_random_numbers.F90 index b2f2d20dd..c1d5ae821 100644 --- a/physics/HWRF_mcica_random_numbers.F90 +++ b/physics/HWRF_mcica_random_numbers.F90 @@ -1,109 +1,109 @@ - module mcica_random_numbers - - ! Generic module to wrap random number generators. - ! The module defines a type that identifies the particular stream of random - ! numbers, and has procedures for initializing it and getting real numbers - ! in the range 0 to 1. - ! This version uses the Mersenne Twister to generate random numbers on [0, 1]. - ! - use MersenneTwister, only: randomNumberSequence, & ! The random number engine. - new_RandomNumberSequence, getRandomReal -!! mji -!! use time_manager_mod, only: time_type, get_date - -!mz use parkind, only : im => kind_im, rb => kind_rb + module mcica_random_numbers + + ! Generic module to wrap random number generators. + ! The module defines a type that identifies the particular stream of random + ! numbers, and has procedures for initializing it and getting real numbers + ! in the range 0 to 1. + ! This version uses the Mersenne Twister to generate random numbers on [0, 1]. + ! + use MersenneTwister, only: randomNumberSequence, & ! The random number engine. + new_RandomNumberSequence, getRandomReal +!! mji +!! use time_manager_mod, only: time_type, get_date + +!mz use parkind, only : im => kind_im, rb => kind_rb use machine, only: im => kind_io4, rb => kind_phys - - implicit none - private - - type randomNumberStream - type(randomNumberSequence) :: theNumbers - end type randomNumberStream - - interface getRandomNumbers - module procedure getRandomNumber_Scalar, getRandomNumber_1D, getRandomNumber_2D - end interface getRandomNumbers - - interface initializeRandomNumberStream - module procedure initializeRandomNumberStream_S, initializeRandomNumberStream_V - end interface initializeRandomNumberStream - - public :: randomNumberStream, & - initializeRandomNumberStream, getRandomNumbers -!! mji -!! initializeRandomNumberStream, getRandomNumbers, & -!! constructSeed -contains - ! --------------------------------------------------------- - ! Initialization - ! --------------------------------------------------------- - function initializeRandomNumberStream_S(seed) result(new) - integer(kind=im), intent( in) :: seed - type(randomNumberStream) :: new - - new%theNumbers = new_RandomNumberSequence(seed) - - end function initializeRandomNumberStream_S - ! --------------------------------------------------------- - function initializeRandomNumberStream_V(seed) result(new) - integer(kind=im), dimension(:), intent( in) :: seed - type(randomNumberStream) :: new - - new%theNumbers = new_RandomNumberSequence(seed) - - end function initializeRandomNumberStream_V - - ! --------------------------------------------------------- - ! Procedures for drawing random numbers - ! --------------------------------------------------------- - subroutine getRandomNumber_Scalar(stream, number) - type(randomNumberStream), intent(inout) :: stream - real(kind=rb), intent( out) :: number - - number = getRandomReal(stream%theNumbers) - end subroutine getRandomNumber_Scalar - ! --------------------------------------------------------- - subroutine getRandomNumber_1D(stream, numbers) - type(randomNumberStream), intent(inout) :: stream - real(kind=rb), dimension(:), intent( out) :: numbers - - ! Local variables - integer(kind=im) :: i - - do i = 1, size(numbers) - numbers(i) = getRandomReal(stream%theNumbers) - end do - end subroutine getRandomNumber_1D - ! --------------------------------------------------------- - subroutine getRandomNumber_2D(stream, numbers) - type(randomNumberStream), intent(inout) :: stream - real(kind=rb), dimension(:, :), intent( out) :: numbers - - ! Local variables - integer(kind=im) :: i - - do i = 1, size(numbers, 2) - call getRandomNumber_1D(stream, numbers(:, i)) - end do - end subroutine getRandomNumber_2D - -! mji -! ! --------------------------------------------------------- -! ! Constructing a unique seed from grid cell index and model date/time -! ! Once we have the GFDL stuff we'll add the year, month, day, hour, minute -! ! --------------------------------------------------------- -! function constructSeed(i, j, time) result(seed) -! integer(kind=im), intent( in) :: i, j -! type(time_type), intent( in) :: time -! integer(kind=im), dimension(8) :: seed -! -! ! Local variables -! integer(kind=im) :: year, month, day, hour, minute, second -! -! -! call get_date(time, year, month, day, hour, minute, second) -! seed = (/ i, j, year, month, day, hour, minute, second /) -! end function constructSeed - - end module mcica_random_numbers + + implicit none + private + + type randomNumberStream + type(randomNumberSequence) :: theNumbers + end type randomNumberStream + + interface getRandomNumbers + module procedure getRandomNumber_Scalar, getRandomNumber_1D, getRandomNumber_2D + end interface getRandomNumbers + + interface initializeRandomNumberStream + module procedure initializeRandomNumberStream_S, initializeRandomNumberStream_V + end interface initializeRandomNumberStream + + public :: randomNumberStream, & + initializeRandomNumberStream, getRandomNumbers +!! mji +!! initializeRandomNumberStream, getRandomNumbers, & +!! constructSeed +contains + ! --------------------------------------------------------- + ! Initialization + ! --------------------------------------------------------- + function initializeRandomNumberStream_S(seed) result(new) + integer(kind=im), intent( in) :: seed + type(randomNumberStream) :: new + + new%theNumbers = new_RandomNumberSequence(seed) + + end function initializeRandomNumberStream_S + ! --------------------------------------------------------- + function initializeRandomNumberStream_V(seed) result(new) + integer(kind=im), dimension(:), intent( in) :: seed + type(randomNumberStream) :: new + + new%theNumbers = new_RandomNumberSequence(seed) + + end function initializeRandomNumberStream_V + + ! --------------------------------------------------------- + ! Procedures for drawing random numbers + ! --------------------------------------------------------- + subroutine getRandomNumber_Scalar(stream, number) + type(randomNumberStream), intent(inout) :: stream + real(kind=rb), intent( out) :: number + + number = getRandomReal(stream%theNumbers) + end subroutine getRandomNumber_Scalar + ! --------------------------------------------------------- + subroutine getRandomNumber_1D(stream, numbers) + type(randomNumberStream), intent(inout) :: stream + real(kind=rb), dimension(:), intent( out) :: numbers + + ! Local variables + integer(kind=im) :: i + + do i = 1, size(numbers) + numbers(i) = getRandomReal(stream%theNumbers) + end do + end subroutine getRandomNumber_1D + ! --------------------------------------------------------- + subroutine getRandomNumber_2D(stream, numbers) + type(randomNumberStream), intent(inout) :: stream + real(kind=rb), dimension(:, :), intent( out) :: numbers + + ! Local variables + integer(kind=im) :: i + + do i = 1, size(numbers, 2) + call getRandomNumber_1D(stream, numbers(:, i)) + end do + end subroutine getRandomNumber_2D + +! mji +! ! --------------------------------------------------------- +! ! Constructing a unique seed from grid cell index and model date/time +! ! Once we have the GFDL stuff we'll add the year, month, day, hour, minute +! ! --------------------------------------------------------- +! function constructSeed(i, j, time) result(seed) +! integer(kind=im), intent( in) :: i, j +! type(time_type), intent( in) :: time +! integer(kind=im), dimension(8) :: seed +! +! ! Local variables +! integer(kind=im) :: year, month, day, hour, minute, second +! +! +! call get_date(time, year, month, day, hour, minute, second) +! seed = (/ i, j, year, month, day, hour, minute, second /) +! end function constructSeed + + end module mcica_random_numbers diff --git a/physics/HWRF_mersenne_twister.F90 b/physics/HWRF_mersenne_twister.F90 index f9e3b0b0a..a7a4a85c4 100644 --- a/physics/HWRF_mersenne_twister.F90 +++ b/physics/HWRF_mersenne_twister.F90 @@ -1,304 +1,304 @@ -! Fortran-95 implementation of the Mersenne Twister 19937, following -! the C implementation described below (code mt19937ar-cok.c, dated 2002/2/10), -! adapted cosmetically by making the names more general. -! Users must declare one or more variables of type randomNumberSequence in the calling -! procedure which are then initialized using a required seed. If the -! variable is not initialized the random numbers will all be 0. -! For example: -! program testRandoms -! use RandomNumbers -! type(randomNumberSequence) :: randomNumbers -! integer :: i -! -! randomNumbers = new_RandomNumberSequence(seed = 100) -! do i = 1, 10 -! print ('(f12.10, 2x)'), getRandomReal(randomNumbers) -! end do -! end program testRandoms -! -! Fortran-95 implementation by -! Robert Pincus -! NOAA-CIRES Climate Diagnostics Center -! Boulder, CO 80305 -! email: Robert.Pincus@colorado.edu -! -! This documentation in the original C program reads: -! ------------------------------------------------------------- -! A C-program for MT19937, with initialization improved 2002/2/10. -! Coded by Takuji Nishimura and Makoto Matsumoto. -! This is a faster version by taking Shawn Cokus's optimization, -! Matthe Bellew's simplification, Isaku Wada's real version. -! -! Before using, initialize the state by using init_genrand(seed) -! or init_by_array(init_key, key_length). -! -! Copyright (C) 1997 - 2002, Makoto Matsumoto and Takuji Nishimura, -! All rights reserved. -! -! Redistribution and use in source and binary forms, with or without -! modification, are permitted provided that the following conditions -! are met: -! -! 1. Redistributions of source code must retain the above copyright -! notice, this list of conditions and the following disclaimer. -! -! 2. Redistributions in binary form must reproduce the above copyright -! notice, this list of conditions and the following disclaimer in the -! documentation and/or other materials provided with the distribution. -! -! 3. The names of its contributors may not be used to endorse or promote -! products derived from this software without specific prior written -! permission. -! -! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -! "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT -! LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR -! A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR -! CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, -! EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, -! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR -! PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF -! LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING -! NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS -! SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -! -! -! Any feedback is very welcome. -! http://www.math.keio.ac.jp/matumoto/emt.html -! email: matumoto@math.keio.ac.jp -! ------------------------------------------------------------- - - module MersenneTwister -! ------------------------------------------------------------- - -!mz use parkind, only : im => kind_im, rb => kind_rb +! Fortran-95 implementation of the Mersenne Twister 19937, following +! the C implementation described below (code mt19937ar-cok.c, dated 2002/2/10), +! adapted cosmetically by making the names more general. +! Users must declare one or more variables of type randomNumberSequence in the calling +! procedure which are then initialized using a required seed. If the +! variable is not initialized the random numbers will all be 0. +! For example: +! program testRandoms +! use RandomNumbers +! type(randomNumberSequence) :: randomNumbers +! integer :: i +! +! randomNumbers = new_RandomNumberSequence(seed = 100) +! do i = 1, 10 +! print ('(f12.10, 2x)'), getRandomReal(randomNumbers) +! end do +! end program testRandoms +! +! Fortran-95 implementation by +! Robert Pincus +! NOAA-CIRES Climate Diagnostics Center +! Boulder, CO 80305 +! email: Robert.Pincus@colorado.edu +! +! This documentation in the original C program reads: +! ------------------------------------------------------------- +! A C-program for MT19937, with initialization improved 2002/2/10. +! Coded by Takuji Nishimura and Makoto Matsumoto. +! This is a faster version by taking Shawn Cokus's optimization, +! Matthe Bellew's simplification, Isaku Wada's real version. +! +! Before using, initialize the state by using init_genrand(seed) +! or init_by_array(init_key, key_length). +! +! Copyright (C) 1997 - 2002, Makoto Matsumoto and Takuji Nishimura, +! All rights reserved. +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! +! 3. The names of its contributors may not be used to endorse or promote +! products derived from this software without specific prior written +! permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +! LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +! A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR +! CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, +! EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, +! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR +! PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +! LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +! NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +! SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +! +! +! Any feedback is very welcome. +! http://www.math.keio.ac.jp/matumoto/emt.html +! email: matumoto@math.keio.ac.jp +! ------------------------------------------------------------- + + module MersenneTwister +! ------------------------------------------------------------- + +!mz use parkind, only : im => kind_im, rb => kind_rb use machine, only: im => kind_io4, rb => kind_phys - - implicit none - private - - ! Algorithm parameters - ! ------- - ! Period parameters - integer(kind=im), parameter :: blockSize = 624, & - M = 397, & - MATRIX_A = -1727483681, & ! constant vector a (0x9908b0dfUL) - UMASK = -2147483647-1, & ! most significant w-r bits (0x80000000UL) - LMASK = 2147483647 ! least significant r bits (0x7fffffffUL) - ! Tempering parameters - integer(kind=im), parameter :: TMASKB= -1658038656, & ! (0x9d2c5680UL) - TMASKC= -272236544 ! (0xefc60000UL) - ! ------- - - ! The type containing the state variable - type randomNumberSequence - integer(kind=im) :: currentElement ! = blockSize - integer(kind=im), dimension(0:blockSize -1) :: state ! = 0 - end type randomNumberSequence - - interface new_RandomNumberSequence - module procedure initialize_scalar, initialize_vector - end interface new_RandomNumberSequence - - - public :: randomNumberSequence - public :: new_RandomNumberSequence, finalize_RandomNumberSequence, & - getRandomInt, getRandomPositiveInt, getRandomReal -! ------------------------------------------------------------- -contains - ! ------------------------------------------------------------- - ! Private functions - ! --------------------------- - function mixbits(u, v) - integer(kind=im), intent( in) :: u, v - integer(kind=im) :: mixbits - - mixbits = ior(iand(u, UMASK), iand(v, LMASK)) - end function mixbits - ! --------------------------- - function twist(u, v) - integer(kind=im), intent( in) :: u, v - integer(kind=im) :: twist - - ! Local variable - integer(kind=im), parameter, dimension(0:1) :: t_matrix = (/ 0_im, MATRIX_A /) - - twist = ieor(ishft(mixbits(u, v), -1_im), t_matrix(iand(v, 1_im))) - twist = ieor(ishft(mixbits(u, v), -1_im), t_matrix(iand(v, 1_im))) - end function twist - ! --------------------------- - subroutine nextState(twister) - type(randomNumberSequence), intent(inout) :: twister - - ! Local variables - integer(kind=im) :: k - - do k = 0, blockSize - M - 1 - twister%state(k) = ieor(twister%state(k + M), & - twist(twister%state(k), twister%state(k + 1_im))) - end do - do k = blockSize - M, blockSize - 2 - twister%state(k) = ieor(twister%state(k + M - blockSize), & - twist(twister%state(k), twister%state(k + 1_im))) - end do - twister%state(blockSize - 1_im) = ieor(twister%state(M - 1_im), & - twist(twister%state(blockSize - 1_im), twister%state(0_im))) - twister%currentElement = 0_im - - end subroutine nextState - ! --------------------------- - elemental function temper(y) - integer(kind=im), intent(in) :: y - integer(kind=im) :: temper - - integer(kind=im) :: x - - ! Tempering - x = ieor(y, ishft(y, -11)) - x = ieor(x, iand(ishft(x, 7), TMASKB)) - x = ieor(x, iand(ishft(x, 15), TMASKC)) - temper = ieor(x, ishft(x, -18)) - end function temper - ! ------------------------------------------------------------- - ! Public (but hidden) functions - ! -------------------- - function initialize_scalar(seed) result(twister) - integer(kind=im), intent(in ) :: seed - type(randomNumberSequence) :: twister - - integer(kind=im) :: i - ! See Knuth TAOCP Vol2. 3rd Ed. P.106 for multiplier. In the previous versions, - ! MSBs of the seed affect only MSBs of the array state[]. - ! 2002/01/09 modified by Makoto Matsumoto - - twister%state(0) = iand(seed, -1_im) - do i = 1, blockSize - 1 ! ubound(twister%state) - twister%state(i) = 1812433253_im * ieor(twister%state(i-1), & - ishft(twister%state(i-1), -30_im)) + i - twister%state(i) = iand(twister%state(i), -1_im) ! for >32 bit machines - end do - twister%currentElement = blockSize - end function initialize_scalar - ! ------------------------------------------------------------- - function initialize_vector(seed) result(twister) - integer(kind=im), dimension(0:), intent(in) :: seed - type(randomNumberSequence) :: twister - - integer(kind=im) :: i, j, k, nFirstLoop, nWraps - - nWraps = 0 - twister = initialize_scalar(19650218_im) - - nFirstLoop = max(blockSize, size(seed)) - do k = 1, nFirstLoop - i = mod(k + nWraps, blockSize) - j = mod(k - 1, size(seed)) - if(i == 0) then - twister%state(i) = twister%state(blockSize - 1) - twister%state(1) = ieor(twister%state(1), & - ieor(twister%state(1-1), & - ishft(twister%state(1-1), -30_im)) * 1664525_im) + & - seed(j) + j ! Non-linear - twister%state(i) = iand(twister%state(i), -1_im) ! for >32 bit machines - nWraps = nWraps + 1 - else - twister%state(i) = ieor(twister%state(i), & - ieor(twister%state(i-1), & - ishft(twister%state(i-1), -30_im)) * 1664525_im) + & - seed(j) + j ! Non-linear - twister%state(i) = iand(twister%state(i), -1_im) ! for >32 bit machines - end if - end do - - ! - ! Walk through the state array, beginning where we left off in the block above - ! - do i = mod(nFirstLoop, blockSize) + nWraps + 1, blockSize - 1 - twister%state(i) = ieor(twister%state(i), & - ieor(twister%state(i-1), & + + implicit none + private + + ! Algorithm parameters + ! ------- + ! Period parameters + integer(kind=im), parameter :: blockSize = 624, & + M = 397, & + MATRIX_A = -1727483681, & ! constant vector a (0x9908b0dfUL) + UMASK = -2147483647-1, & ! most significant w-r bits (0x80000000UL) + LMASK = 2147483647 ! least significant r bits (0x7fffffffUL) + ! Tempering parameters + integer(kind=im), parameter :: TMASKB= -1658038656, & ! (0x9d2c5680UL) + TMASKC= -272236544 ! (0xefc60000UL) + ! ------- + + ! The type containing the state variable + type randomNumberSequence + integer(kind=im) :: currentElement ! = blockSize + integer(kind=im), dimension(0:blockSize -1) :: state ! = 0 + end type randomNumberSequence + + interface new_RandomNumberSequence + module procedure initialize_scalar, initialize_vector + end interface new_RandomNumberSequence + + + public :: randomNumberSequence + public :: new_RandomNumberSequence, finalize_RandomNumberSequence, & + getRandomInt, getRandomPositiveInt, getRandomReal +! ------------------------------------------------------------- +contains + ! ------------------------------------------------------------- + ! Private functions + ! --------------------------- + function mixbits(u, v) + integer(kind=im), intent( in) :: u, v + integer(kind=im) :: mixbits + + mixbits = ior(iand(u, UMASK), iand(v, LMASK)) + end function mixbits + ! --------------------------- + function twist(u, v) + integer(kind=im), intent( in) :: u, v + integer(kind=im) :: twist + + ! Local variable + integer(kind=im), parameter, dimension(0:1) :: t_matrix = (/ 0_im, MATRIX_A /) + + twist = ieor(ishft(mixbits(u, v), -1_im), t_matrix(iand(v, 1_im))) + twist = ieor(ishft(mixbits(u, v), -1_im), t_matrix(iand(v, 1_im))) + end function twist + ! --------------------------- + subroutine nextState(twister) + type(randomNumberSequence), intent(inout) :: twister + + ! Local variables + integer(kind=im) :: k + + do k = 0, blockSize - M - 1 + twister%state(k) = ieor(twister%state(k + M), & + twist(twister%state(k), twister%state(k + 1_im))) + end do + do k = blockSize - M, blockSize - 2 + twister%state(k) = ieor(twister%state(k + M - blockSize), & + twist(twister%state(k), twister%state(k + 1_im))) + end do + twister%state(blockSize - 1_im) = ieor(twister%state(M - 1_im), & + twist(twister%state(blockSize - 1_im), twister%state(0_im))) + twister%currentElement = 0_im + + end subroutine nextState + ! --------------------------- + elemental function temper(y) + integer(kind=im), intent(in) :: y + integer(kind=im) :: temper + + integer(kind=im) :: x + + ! Tempering + x = ieor(y, ishft(y, -11)) + x = ieor(x, iand(ishft(x, 7), TMASKB)) + x = ieor(x, iand(ishft(x, 15), TMASKC)) + temper = ieor(x, ishft(x, -18)) + end function temper + ! ------------------------------------------------------------- + ! Public (but hidden) functions + ! -------------------- + function initialize_scalar(seed) result(twister) + integer(kind=im), intent(in ) :: seed + type(randomNumberSequence) :: twister + + integer(kind=im) :: i + ! See Knuth TAOCP Vol2. 3rd Ed. P.106 for multiplier. In the previous versions, + ! MSBs of the seed affect only MSBs of the array state[]. + ! 2002/01/09 modified by Makoto Matsumoto + + twister%state(0) = iand(seed, -1_im) + do i = 1, blockSize - 1 ! ubound(twister%state) + twister%state(i) = 1812433253_im * ieor(twister%state(i-1), & + ishft(twister%state(i-1), -30_im)) + i + twister%state(i) = iand(twister%state(i), -1_im) ! for >32 bit machines + end do + twister%currentElement = blockSize + end function initialize_scalar + ! ------------------------------------------------------------- + function initialize_vector(seed) result(twister) + integer(kind=im), dimension(0:), intent(in) :: seed + type(randomNumberSequence) :: twister + + integer(kind=im) :: i, j, k, nFirstLoop, nWraps + + nWraps = 0 + twister = initialize_scalar(19650218_im) + + nFirstLoop = max(blockSize, size(seed)) + do k = 1, nFirstLoop + i = mod(k + nWraps, blockSize) + j = mod(k - 1, size(seed)) + if(i == 0) then + twister%state(i) = twister%state(blockSize - 1) + twister%state(1) = ieor(twister%state(1), & + ieor(twister%state(1-1), & + ishft(twister%state(1-1), -30_im)) * 1664525_im) + & + seed(j) + j ! Non-linear + twister%state(i) = iand(twister%state(i), -1_im) ! for >32 bit machines + nWraps = nWraps + 1 + else + twister%state(i) = ieor(twister%state(i), & + ieor(twister%state(i-1), & + ishft(twister%state(i-1), -30_im)) * 1664525_im) + & + seed(j) + j ! Non-linear + twister%state(i) = iand(twister%state(i), -1_im) ! for >32 bit machines + end if + end do + + ! + ! Walk through the state array, beginning where we left off in the block above + ! + do i = mod(nFirstLoop, blockSize) + nWraps + 1, blockSize - 1 + twister%state(i) = ieor(twister%state(i), & + ieor(twister%state(i-1), & ishft(twister%state(i-1), -30_im)) * 1566083941_im) - i ! Non-linear - twister%state(i) = iand(twister%state(i), -1_im) ! for >32 bit machines - end do - - twister%state(0) = twister%state(blockSize - 1) - - do i = 1, mod(nFirstLoop, blockSize) + nWraps - twister%state(i) = ieor(twister%state(i), & - ieor(twister%state(i-1), & + twister%state(i) = iand(twister%state(i), -1_im) ! for >32 bit machines + end do + + twister%state(0) = twister%state(blockSize - 1) + + do i = 1, mod(nFirstLoop, blockSize) + nWraps + twister%state(i) = ieor(twister%state(i), & + ieor(twister%state(i-1), & ishft(twister%state(i-1), -30_im)) * 1566083941_im) - i ! Non-linear - twister%state(i) = iand(twister%state(i), -1_im) ! for >32 bit machines - end do - - twister%state(0) = UMASK - twister%currentElement = blockSize - - end function initialize_vector - ! ------------------------------------------------------------- - ! Public functions - ! -------------------- - function getRandomInt(twister) - type(randomNumberSequence), intent(inout) :: twister - integer(kind=im) :: getRandomInt - ! Generate a random integer on the interval [0,0xffffffff] - ! Equivalent to genrand_int32 in the C code. - ! Fortran doesn't have a type that's unsigned like C does, - ! so this is integers in the range -2**31 - 2**31 - ! All functions for getting random numbers call this one, - ! then manipulate the result - - if(twister%currentElement >= blockSize) call nextState(twister) - - getRandomInt = temper(twister%state(twister%currentElement)) - twister%currentElement = twister%currentElement + 1 - - end function getRandomInt - ! -------------------- - function getRandomPositiveInt(twister) - type(randomNumberSequence), intent(inout) :: twister - integer(kind=im) :: getRandomPositiveInt - ! Generate a random integer on the interval [0,0x7fffffff] - ! or [0,2**31] - ! Equivalent to genrand_int31 in the C code. - - ! Local integers - integer(kind=im) :: localInt - - localInt = getRandomInt(twister) - getRandomPositiveInt = ishft(localInt, -1) - - end function getRandomPositiveInt - ! -------------------- - ! -------------------- -!! mji - modified Jan 2007, double converted to rrtmg real kind type - function getRandomReal(twister) - type(randomNumberSequence), intent(inout) :: twister -! double precision :: getRandomReal - real(kind=rb) :: getRandomReal - ! Generate a random number on [0,1] - ! Equivalent to genrand_real1 in the C code - ! The result is stored as double precision but has 32 bit resolution - - integer(kind=im) :: localInt - - localInt = getRandomInt(twister) - if(localInt < 0) then -! getRandomReal = dble(localInt + 2.0d0**32)/(2.0d0**32 - 1.0d0) - getRandomReal = (localInt + 2.0**32_rb)/(2.0**32_rb - 1.0_rb) - else -! getRandomReal = dble(localInt )/(2.0d0**32 - 1.0d0) - getRandomReal = (localInt )/(2.0**32_rb - 1.0_rb) - end if - - end function getRandomReal - ! -------------------- - subroutine finalize_RandomNumberSequence(twister) - type(randomNumberSequence), intent(inout) :: twister - - twister%currentElement = blockSize - twister%state(:) = 0_im - end subroutine finalize_RandomNumberSequence - - ! -------------------- - - end module MersenneTwister + twister%state(i) = iand(twister%state(i), -1_im) ! for >32 bit machines + end do + + twister%state(0) = UMASK + twister%currentElement = blockSize + + end function initialize_vector + ! ------------------------------------------------------------- + ! Public functions + ! -------------------- + function getRandomInt(twister) + type(randomNumberSequence), intent(inout) :: twister + integer(kind=im) :: getRandomInt + ! Generate a random integer on the interval [0,0xffffffff] + ! Equivalent to genrand_int32 in the C code. + ! Fortran doesn't have a type that's unsigned like C does, + ! so this is integers in the range -2**31 - 2**31 + ! All functions for getting random numbers call this one, + ! then manipulate the result + + if(twister%currentElement >= blockSize) call nextState(twister) + + getRandomInt = temper(twister%state(twister%currentElement)) + twister%currentElement = twister%currentElement + 1 + + end function getRandomInt + ! -------------------- + function getRandomPositiveInt(twister) + type(randomNumberSequence), intent(inout) :: twister + integer(kind=im) :: getRandomPositiveInt + ! Generate a random integer on the interval [0,0x7fffffff] + ! or [0,2**31] + ! Equivalent to genrand_int31 in the C code. + + ! Local integers + integer(kind=im) :: localInt + + localInt = getRandomInt(twister) + getRandomPositiveInt = ishft(localInt, -1) + + end function getRandomPositiveInt + ! -------------------- + ! -------------------- +!! mji - modified Jan 2007, double converted to rrtmg real kind type + function getRandomReal(twister) + type(randomNumberSequence), intent(inout) :: twister +! double precision :: getRandomReal + real(kind=rb) :: getRandomReal + ! Generate a random number on [0,1] + ! Equivalent to genrand_real1 in the C code + ! The result is stored as double precision but has 32 bit resolution + + integer(kind=im) :: localInt + + localInt = getRandomInt(twister) + if(localInt < 0) then +! getRandomReal = dble(localInt + 2.0d0**32)/(2.0d0**32 - 1.0d0) + getRandomReal = (localInt + 2.0**32_rb)/(2.0**32_rb - 1.0_rb) + else +! getRandomReal = dble(localInt )/(2.0d0**32 - 1.0d0) + getRandomReal = (localInt )/(2.0**32_rb - 1.0_rb) + end if + + end function getRandomReal + ! -------------------- + subroutine finalize_RandomNumberSequence(twister) + type(randomNumberSequence), intent(inout) :: twister + + twister%currentElement = blockSize + twister%state(:) = 0_im + end subroutine finalize_RandomNumberSequence + + ! -------------------- + + end module MersenneTwister diff --git a/physics/docs/pdftxt/HWRF_FAMP.txt b/physics/docs/pdftxt/HWRF_FAMP.txt index 4fb555d84..b12ff0d80 100644 --- a/physics/docs/pdftxt/HWRF_FAMP.txt +++ b/physics/docs/pdftxt/HWRF_FAMP.txt @@ -8,17 +8,17 @@ cloud ice (\f$q_i\f$), and snow-graupel (\f$q_s\f$). The FA scheme is currently in the North American Mesoscale Forecast System (NAM; including the parent 12-km domain, the 3-km NAM nests, and the 1.5km fire weather nest), the Hurricane Weather Research and Forecasting Model (HWRF), the Hurricanes in a Multi-scale Ocean-coupled Non-hydrostatic Model (HMON), and the High-Resolution -Window (HiResW) Non-dydrostatic Multiscale Model on the B grid (NMMB). The FA scheme advects each +Window (HiResW) Non-dydrostatic Multiscale Model on the B grid (NMMB). The FA scheme advects each species separately in the NAM nests, and advects the total condensate in the 12-km parent NAM,HiResW NMMB, HWRF, and HMON. Unique to the FA scheme is the calculation of a diagnostic array called the "rime factor" (RF), which -represents the degree of riming onto snow-graupel, and takes into account the temperature of the ice particle, +represents the degree of riming onto snow-graupel, and takes into account the temperature of the ice particle, the impact velocity of the cloud droplet on the ice particle, and the size of the cloud droplet. For all practical purposes, one can categorize precipitation ice as snow, graupel, or hail, similar to the ice -species predicted in other microphysical schemes based on the value of the RF. For example, an RF = 1 +species predicted in other microphysical schemes based on the value of the RF. For example, an RF = 1 represents unrimed snow; lightly rimed snow occurs when 1 < RF < 2; heavily rimed snow when 2< RF \f$\leq\f$ 5; -graupel when 5 < RF < 10; and frozen drops or hail when RF \f$geqslant\f$ 10. In reality, the RF knows +graupel when 5 < RF < 10; and frozen drops or hail when RF \f$geqslant\f$ 10. In reality, the RF knows no arbitrary cutoff between different ice categories, and the categorizations above are somewhat subjective. Figure 1 is a schematic illustration of the FA scheme processes and each process is described in Table 1. @@ -26,9 +26,9 @@ Figure 1 is a schematic illustration of the FA scheme processes and each process Table 1. List of microphysical processes and their description. All processes are in units of \f$kg kg^{-1}\f$. \tableofcontents -| Microphysical Source/Sinks | Description | +| Microphysical Source/Sinks | Description | |----------------------------------|--------------------------------------------------------| -| PIHOM | Homogeneous freezing of cloud water to ice. | +| PIHOM | Homogeneous freezing of cloud water to ice. | | PIDEP | Net ice deposition (> 0) or sublimation (< 0). | | PINIT | Initiation (nucleation) of cloud ice. | | PIACW | Cloud water collection by precipitation ice. | @@ -44,34 +44,34 @@ Table 1. List of microphysical processes and their description. All processes ar | PIACWR | Accreted cloud water shed to form rain at > 0 | \tableofcontents -Owing to operational computation constraints, and unique to the FA scheme, the sedimentation process -does not use finite differencing of precipitation fluxes in the vertical in order to circumvent the -requirement that small time steps be used in order to maintain numerical stability, particularly since +Owing to operational computation constraints, and unique to the FA scheme, the sedimentation process +does not use finite differencing of precipitation fluxes in the vertical in order to circumvent the +requirement that small time steps be used in order to maintain numerical stability, particularly since the vertical resolution often increases dramatically near the ground. The algorithm is instead based upon a partitioning of precipitation already present in the grid box at the beginning of the time step and the -precipitation entering the grid box from above at the end of the time step. A more detailed description +precipitation entering the grid box from above at the end of the time step. A more detailed description of the sedimentation algorithm can be found in Aligo et al. (2018, appendix D). An algorithm was developed in FA to improve stratiform rainfall by allowing the rain intercept parameter, -\f$N_{or}\f$, to vary with height and the mean drop diameter to be fixed below melting layers. This is +\f$N_{or}\f$, to vary with height and the mean drop diameter to be fixed below melting layers. This is different from other single-moment microphysics schemes (WSM6 and Lin) that assume a constant value for \f$N_{or}\f$. The algorithm in the FA scheme, simular to what is done in the Thompson scheme \cite Thompson_2008, assumes that a snow-graupel particle about to enter the melting layer from above has the same mean mass as a drop formed from melting below the melting layer. The mean drop diameter calculated below the melting layer acts as the lower limit for the mean drop sizes as the rain descends to lower levels. This algorithm is only -active if 1) the snow-graupel density above the melting level (i.e.\f$T_c<0^{o}C\f$) is \f$<225kg m^{-3}\f$ +active if 1) the snow-graupel density above the melting level (i.e.\f$T_c<0^{o}C\f$) is \f$<225kg m^{-3}\f$ (which corresponds to an RF=10), 2) the rain content does not exceed \f$1gm^{-3}\f$, and 3) there is vertical continuity of the rain at lower levels with the rain that formed from melting ice. The FA scheme also uses a drizzle parameterization in order to minimize the spatial extent of light (<20dBZ) reflectivity echoes that developed at the top of moist boundary layers, over the Southeastern U.S., within warm conveyor belts, and over ocean areas covered by stratocumulus in the NMMB. The drizzle parameterization -uses a variable \f$N_{or}\f$ following Westbrook et al. (2010) \cite westbrook_et_al_2010, and approach +uses a variable \f$N_{or}\f$ following Westbrook et al. (2010) \cite westbrook_et_al_2010, and approach conceptually similar to that described in Thompson et al.(2008) \cite Thompson_2008 for drizzle. Figure 2a shows an example of drizzle forming in a single low-level liquid cloud layer above \f$0^oC\f$, in which the smaller, more numerous drizzle drops produce lower radar reflectivities, compared to rain, with \f$N_{or}=8\times10^6m\f$, for example. For multiple cloud layers, drizzle from low clouds must be completely disconnected from rain formed -aloft from melting ice, such that a rain-free layer must seperate any stratiform rain layer aloft from drizzle formed +aloft from melting ice, such that a rain-free layer must seperate any stratiform rain layer aloft from drizzle formed within liquid clouds at lower levels.Supercooled drizzle is also allowed to form from warm-rain processes below \f$0^oC\f$. The quantity \f$N_{or}\f$ is modified only when the rainwater content is \f$< 0.5 gm^{-3}\f$, such that \f$N_{or}\f$ is assumed to vary (red line in Fig.2b) with rain content (\f$\rho_\alpha\times q_r\f$) as @@ -82,7 +82,7 @@ assumed to vary (red line in Fig.2b) with rain content (\f$\rho_\alpha\times q_r \section intra_famp Intraphysics Communication -\ref arg_table_mp_fer_hires_run +\ref arg_table_mp_fer_hires_run \section gen_famp General Algorithm \ref gen_al_famp diff --git a/physics/gfdl_sfc_layer.F90 b/physics/gfdl_sfc_layer.F90 index 6bd969ac3..b3c539994 100644 --- a/physics/gfdl_sfc_layer.F90 +++ b/physics/gfdl_sfc_layer.F90 @@ -16,57 +16,57 @@ module gfdl_sfc_layer !> \section arg_table_gfdl_sfc_layer_init Argument Table !! \htmlinclude gfdl_sfc_layer_init.html -!! +!! subroutine gfdl_sfc_layer_init (icoef_sf, cplwav, cplwav2atm, lcurr_sf, & pert_cd, ntsflg, errmsg, errflg) - + implicit none - + integer, intent(in) :: icoef_sf, ntsflg logical, intent(in) :: cplwav, cplwav2atm, lcurr_sf, pert_cd - + character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg - + ! Initialize CCPP error handling variables errmsg = '' errflg = 0 - + #if HWRF==1 write(errmsg,'(*(a))') 'The GFDL surface layer scheme does not support '& //'use of the HWRF preprocessor flag in gfdl_sfc_layer.F90' errflg = 1 return -#endif - +#endif + if (icoef_sf < 0 .or. icoef_sf > 8) then write(errmsg,'(*(a))') 'The value of icoef_sf is outside of the ' & //'supported range (0-8) in gfdl_sfc_layer.F90' errflg = 1 return end if - + if (cplwav .or. cplwav2atm) then write(errmsg,'(*(a))') 'The GFDL surface layer scheme is not set up ' & //'to be coupled to waves in gfdl_sfc_layer.F90' errflg = 1 return end if - + if (lcurr_sf) then write(errmsg,'(*(a))') 'The GFDL surface layer scheme is not set up ' & //'to be used with the lcurr_sf option in gfdl_sfc_layer.F90' errflg = 1 return end if - + if (pert_cd) then write(errmsg,'(*(a))') 'The GFDL surface layer scheme is not set up ' & //'to be used with the pert_cd option in gfdl_sfc_layer.F90' errflg = 1 return end if - + if (ntsflg > 0) then !GJF: In order to enable ntsflg > 0, the variable 'tstrc' passed into MFLUX2 should be set ! to the surface_skin_temperature_over_X_interstitial rather than the average of it and @@ -75,8 +75,8 @@ subroutine gfdl_sfc_layer_init (icoef_sf, cplwav, cplwav2atm, lcurr_sf, & //' in gfdl_sfc_layer.F90' errflg = 1 return - end if - + end if + !GJF: Initialization notes: In WRF, the subroutine module_sf_myjsfc/myjsfcinit ! is called for initialization of the GFDL surface layer scheme from ! the module_physics_init subroutine. It contains the following @@ -90,7 +90,7 @@ subroutine gfdl_sfc_layer_init (icoef_sf, cplwav, cplwav2atm, lcurr_sf, & ! ENDDO ! ENDIF !also initialize surface roughness length - + end subroutine gfdl_sfc_layer_init subroutine gfdl_sfc_layer_finalize () @@ -99,7 +99,7 @@ end subroutine gfdl_sfc_layer_finalize !> \section arg_table_gfdl_sfc_layer_run Argument Table !! \htmlinclude gfdl_sfc_layer_run.html !! - subroutine gfdl_sfc_layer_run (im, nsoil, km, xlat, xlon, flag_iter, lsm, & + subroutine gfdl_sfc_layer_run (im, nsoil, km, xlat, xlon, flag_iter, lsm, & lsm_noah, lsm_noahmp, lsm_ruc, lsm_noah_wrfv4, icoef_sf, cplwav, & cplwav2atm, lcurr_sf, pert_Cd, ntsflg, sfenth, z1, shdmax, ivegsrc, & vegtype, sigmaf, dt, wet, dry, icy, isltyp, rd, grav, ep1, ep2, smois, & @@ -110,9 +110,9 @@ subroutine gfdl_sfc_layer_run (im, nsoil, km, xlat, xlon, flag_iter, lsm, & fm_ocn, fm_lnd, fm_ice, fh_ocn, fh_lnd, fh_ice, fh2_ocn, fh2_lnd, & fh2_ice, ch_ocn, ch_lnd, ch_ice, fm10_ocn, fm10_lnd, fm10_ice, qss_ocn, & qss_lnd, qss_ice, errmsg, errflg) - + use funcphys, only: fpvs - + !#### GJF: temporarily grab parameters from LSM-specific modules -- should go through CCPP #### ! (fixing this involves replacing the functionality of set_soilveg and namelist_soilveg) use namelist_soilveg, only: maxsmc_noah => maxsmc, drysmc_noah => drysmc @@ -120,7 +120,7 @@ subroutine gfdl_sfc_layer_run (im, nsoil, km, xlat, xlon, flag_iter, lsm, & use noahmp_tables, only: maxsmc_noahmp => smcmax_table, drysmc_noahmp => smcdry_table use module_sf_noahlsm, only: maxsmc_noah_wrfv4 => maxsmc, drysmc_noah_wrfv4 => drysmc !################################################################################################ - + implicit none integer, intent(in) :: im, nsoil, km, ivegsrc @@ -138,53 +138,53 @@ subroutine gfdl_sfc_layer_run (im, nsoil, km, xlat, xlon, flag_iter, lsm, & real(kind=kind_phys), dimension(im), intent(in) :: psfc, prsl1, & q1, t1, u1, v1, wspd, u10, v10, gsw, glw, z1, shdmax, sigmaf, xlat, & xlon, tsurf_ocn, tsurf_lnd, tsurf_ice - - real(kind=kind_phys), intent(inout), dimension(im) :: tskin_ocn, & + + real(kind=kind_phys), intent(inout), dimension(im) :: tskin_ocn, & tskin_lnd, tskin_ice, ustar_ocn, ustar_lnd, ustar_ice, & znt_ocn, znt_lnd, znt_ice, cdm_ocn, cdm_lnd, cdm_ice, & stress_ocn, stress_lnd, stress_ice, rib_ocn, rib_lnd, rib_ice, & fm_ocn, fm_lnd, fm_ice, fh_ocn, fh_lnd, fh_ice, fh2_ocn, fh2_lnd, & fh2_ice, ch_ocn, ch_lnd, ch_ice, fm10_ocn, fm10_lnd, fm10_ice, & qss_ocn, qss_lnd, qss_ice - + character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg - + !local variables - + integer :: i, its, ite, ims, ime - + logical :: ch_bound_excursion - + !GJF: the vonKarman constant should come in through the CCPP and be defined by the host model real (kind=kind_phys), parameter :: karman = 0.4 real (kind=kind_phys), parameter :: log01=log(0.01), log05=log(0.05), & log07=log(0.07) - + !GJF: if the following variables will be used, they should be turned into intent(in) namelist options integer :: iwavecpl, ens_random_seed, issflx logical :: diag_wind10m, diag_qss real(kind=kind_phys) :: ens_Cdamp - + real(kind=kind_phys), dimension(im) :: wetc, pspc, pkmax, tstrc, upc, & vpc, mznt, slwdc, wind10, qfx, qgh, zkmax, z1_cm, z0max, ztmax real(kind=kind_phys), dimension(im) :: u10_lnd, u10_ocn, u10_ice, & v10_lnd, v10_ocn, v10_ice - + !GJF: the following variables are identified as: !"SCURX" "Surface Currents(X)" "m s-1" !"SCURY" "Surface Currents(Y)" "m s-1 !"CHARN" "Charnock Coeff" " " !"MSANG" "Wind/Stress Angle" "Radian" real(kind=kind_phys), dimension(im) :: charn, msang, scurx, scury - + real(kind=kind_phys), dimension(im) :: fxh, fxe, fxmx, fxmy, xxfh, & xxfh2, tzot real(kind=kind_phys), dimension(1:30) :: maxsmc, drysmc real(kind=kind_phys) :: smcmax, smcdry, zhalf, cd10, & esat, fm_lnd_old, fh_lnd_old, tem1, tem2, czilc, cd_low_limit, & cd_high_limit, ch_low_limit, ch_high_limit, fh2_fh_ratio - + !#### This block will become unnecessary when maxsmc and drysmc come through the CCPP #### if (lsm == lsm_noah) then maxsmc = maxsmc_noah @@ -215,88 +215,88 @@ subroutine gfdl_sfc_layer_run (im, nsoil, km, xlat, xlon, flag_iter, lsm, & 0.000, 0.000, 0.000, 0.000, 0.000, 0.000/ end if !######################################################################## - - !GJF: This code has not been tested with iwavecpl = 1; the variables 'charn' and 'msang' (and others?) need to be input in order to use this + + !GJF: This code has not been tested with iwavecpl = 1; the variables 'charn' and 'msang' (and others?) need to be input in order to use this ! if (cplwav .or. cplwav2atm) then ! iwavecpl = 1 ! else ! iwavecpl = 0 ! end if iwavecpl = 0 - + !GJF: temporary setting of variables that should be moved to namelist is they are used ens_random_seed = 0 !used for HWRF ensemble? ens_Cdamp = 0.0 !used for HWRF ensemble? issflx = 0 !GJF: 1 = calculate surface fluxes, 0 = don't - diag_wind10m = .false. !GJF: if one wants 10m wind speeds to come from this scheme, set this to True, + diag_wind10m = .false. !GJF: if one wants 10m wind speeds to come from this scheme, set this to True, ! put [u,v]10_[lnd/ocn/ice] in the scheme argument list (and metadata), and modify ! GFS_surface_compsites to receive the individual components and calculate an all-grid value diag_qss = .false. !GJF: saturation specific humidities are calculated by LSM, sea surface, and sea ice schemes in ! GFS-based suites - + ! Initialize CCPP error handling variables errmsg = '' errflg = 0 - + its = 1 ims = 1 ite = im ime = im - + do i=its, ite if (flag_iter(i)) then !GJF: Perform data preparation that is the same for all surface types - + pspc(i) = psfc(i)*10. ! convert from Pa to cgs pkmax(i) = prsl1(i)*10. ! convert from Pa to cgs upc(i) = u1(i)*100. ! convert from m s-1 to cm s-1 vpc(i) = v1(i)*100. ! convert from m s-1 to cm s-1 - + !Wang: use previous u10 v10 to compute wind10, input to MFLUX2 to compute z0 (for first time step, u10 and v10 may be zero) wind10(i)=sqrt(u10(i)*u10(i)+v10(i)*v10(i)) !m s-1 - + !Wang: calulate height of the first half level ! if (wind10(i) <= 1.0e-10 .or. wind10(i) > 150.0) then ! zhalf = -rd*t1(i)*alog(pkmax(i)/pspc(i))/grav !m ! endif - + !GJF: rather than calculate the height of the first half level, if it is precalculated ! in a different scheme, pass it in and use it; note that in FV3, calculating via the hypsometric equation ! occasionally produced values much shallower than those passed in !zkmax(i) = -rd*t1(i)*alog(pkmax(i)/pspc(i))/grav !m zkmax(i) = z1(i) z1_cm(i) = 100.0*z1(i) - + !GJF: these drag coefficient limits were suggested by Chunxi Zhang via his module_sf_sfclayrev.f90 cd_low_limit = 1.0e-5/zkmax(i) cd_high_limit = 0.1 - !GJF: use the lower of 0.1 from Chunxi Zhang or 0.05/wspd from WRF's module_sf_gfdl.F + !GJF: use the lower of 0.1 from Chunxi Zhang or 0.05/wspd from WRF's module_sf_gfdl.F ! (this will always be the latter if wspd has a minimum of 1.0 m s-1 from above) ch_low_limit = cd_low_limit ch_high_limit = min(0.1,0.05/wspd(i)) - + !slwdc... GFDL downward net flux in units of cal/(cm**2/min) !also divide by 10**4 to convert from /m**2 to /cm**2 slwdc(i)=gsw(i)+glw(i) slwdc(i)=0.239*60.*slwdc(i)*1.e-4 - + !GJF: these variables should be passed in if these options are used charn(i) = 0.0 !used with wave coupling (iwavecpl == 1) msang(i) = 0.0 !used with wave coupling (iwavecpl == 1) scurx(i) = 0.0 !used with ocean currents? (lcurr_sf == T) scury(i) = 0.0 !used with ocean currents? (lcurr_sf == T) - + if (diag_qss) then esat = fpvs(t1(i)) qgh(i) = ep2*esat/(psfc(i)-esat) end if - + !GJF: these vars are not needed in a GFS-based suite !rho1(i)=prsl1(i)/(rd*t1(i)*(1.+ep1*q1(i))) !cpm(i)=cp*(1.+0.8*q1(i)) - + !GJF: perform data preparation that depends on surface types and call the mflux2 subroutine for each surface type ! Note that this is different than the original WRF module_sf_gfdl.F where mflux2 is called once for all surface ! types, with negative roughness lengths denoting open ocean. @@ -306,24 +306,24 @@ subroutine gfdl_sfc_layer_run (im, nsoil, km, xlat, xlon, flag_iter, lsm, & smcmax=maxsmc(isltyp(i)) wetc(i)=(smois(i,1)-smcdry)/(smcmax-smcdry) wetc(i)=amin1(1.,amax1(wetc(i),0.)) - + !GJF: the lower boundary temperature passed in to MFLUX2 either follows GFS: tstrc(i) = 0.5*(tskin_lnd(i) + tsurf_lnd(i)) !averaging tskin_lnd and tsurf_lnd as in GFS surface layer breaks ntsflg functionality !GJF: or WRF module_sf_gfdl.F: !tstrc(i) = tskin_lnd(i) - + !GJF: Roughness Length Limitation section ! The WRF version of module_sf_gfdl.F has no checks on the roughness lengths prior to entering MFLUX2. ! The following limits were placed on roughness lengths from the GFS surface layer scheme at the suggestion ! of Chunxi Zhang. Using the GFDL surface layer without such checks can lead to instability in the UFS. - + !znt_lnd is in cm, z0max/ztmax are in m at this point z0max(i) = max(1.0e-6, min(0.01 * znt_lnd(i), zkmax(i))) - + tem1 = 1.0 - shdmax(i) tem2 = tem1 * tem1 tem1 = 1.0 - tem2 - + if( ivegsrc == 1 ) then if (vegtype(i) == 10) then z0max(i) = exp( tem2*log01 + tem1*log07 ) @@ -353,7 +353,7 @@ subroutine gfdl_sfc_layer_run (im, nsoil, km, xlat, xlon, flag_iter, lsm, & z0max(i) = exp( tem2*log01 + tem1*log(z0max(i)) ) endif endif - + z0max(i) = max(z0max(i), 1.0e-6) ! czilc = 10.0 ** (- (0.40/0.07) * z0) ! fei's canopy height dependance of czil @@ -363,16 +363,16 @@ subroutine gfdl_sfc_layer_run (im, nsoil, km, xlat, xlon, flag_iter, lsm, & ztmax(i) = z0max(i)*exp( - tem1*tem1 & & * czilc*karman*sqrt(ustar_lnd(i)*(0.01/1.5e-05))) ztmax(i) = max(ztmax(i), 1.0e-6) - + !GJF: from WRF's module_sf_gfdl.F if (wind10(i) <= 1.0e-10 .or. wind10(i) > 150.0) then wind10(i)=wspd(i)*alog(10.0/z0max(i))/alog(z1(i)/z0max(i)) !m s-1 end if wind10(i)=wind10(i)*100.0 !convert from m/s to cm/s - + ztmax(i) = ztmax(i)*100.0 !convert from m to cm z0max(i) = z0max(i)*100.0 !convert from m to cm - + call mflux2 (fxh(i), fxe(i), fxmx(i), fxmy(i), cdm_lnd(i), rib_lnd(i), & xxfh(i), ztmax(i), z0max(i), tstrc(i), & pspc(i), pkmax(i), wetc(i), slwdc(i), z1_cm(i), icoef_sf, iwavecpl, lcurr_sf, charn(i), msang(i), & @@ -380,62 +380,62 @@ subroutine gfdl_sfc_layer_run (im, nsoil, km, xlat, xlon, flag_iter, lsm, & dt, wind10(i), xxfh2(i), ntsflg, sfenth, tzot(i), errmsg, & errflg) if (errflg /= 0) return - + !GJF: this is broken when tstrc is set to an average of two variables if (ntsflg==1) then - tskin_lnd(i) = tstrc(i) ! gopal's doing + tskin_lnd(i) = tstrc(i) ! gopal's doing end if - + if (diag_wind10m) then u10_lnd(i) = u1(i)*(0.01*wind10(i)/wspd(i)) v10_lnd(i) = v1(i)*(0.01*wind10(i)/wspd(i)) end if - + !GJF: these variables are not needed in a GFS-based suite, but are found in WRF's module_sf_gfdl.F and kept in comments for legacy - !gz1oz0(i) = alog(zkmax(i)/(0.01*znt_lnd(i))) + !gz1oz0(i) = alog(zkmax(i)/(0.01*znt_lnd(i))) !taux(i) = fxmx(i)/10. ! gopal's doing for Ocean coupling !tauy(i) = fxmy(i)/10. ! gopal's doing for Ocean coupling - + cdm_lnd(i) = max(cdm_lnd(i), cd_low_limit) cdm_lnd(i) = min(cdm_lnd(i), cd_high_limit) fm_lnd(i) = karman/sqrt(cdm_lnd(i)) - + !1) try fh_lnd from MFLUX2 fh_lnd(i) = karman*xxfh(i) - + !2) calc ch_lnd from fm_lnd and fh_lnd ch_lnd(i) = karman*karman/(fm_lnd(i) * fh_lnd(i)) - + !3) check if ch_lnd is out of bounds (if so, recalculate fh_lnd from bounded value) ch_bound_excursion = .false. - if (ch_lnd(i) < ch_low_limit) then + if (ch_lnd(i) < ch_low_limit) then ch_bound_excursion = .true. ch_lnd(i) = ch_low_limit else if (ch_lnd(i) > ch_high_limit) then ch_bound_excursion = .true. ch_lnd(i) = ch_high_limit end if - + fh2_lnd(i) = karman*xxfh2(i) - + if (ch_bound_excursion) then fh2_fh_ratio = min(xxfh2(i)/xxfh(i), 1.0) fh_lnd(i) = karman*karman/(fm_lnd(i)*ch_lnd(i)) fh2_lnd(i) = fh2_fh_ratio*fh_lnd(i) end if - + !GJF: Other CCPP schemes (PBL) ask for fm/fh instead of psim/psih !psim_lnd(i)=gz1oz0(i)-fm_lnd(i) !psih_lnd(i)=gz1oz0(i)-fh_lnd(i) - + !GJF: from WRF's module_sf_gfdl.F ustar_lnd(i) = 0.01*sqrt(cdm_lnd(i)* & (upc(i)*upc(i) + vpc(i)*vpc(i))) !GJF: from Chunxi Zhang's module_sf_sfclayrev.f90 (I'm not sure it's necessary.) ustar_lnd(i) = amax1(ustar_lnd(i),0.001) - + stress_lnd(i) = cdm_lnd(i)*wspd(i)*wspd(i) - + !GJF: from WRF's module_sf_gfdl.F ! convert cd, ch to values at 10m, for output cd10 = cdm_lnd(i) @@ -446,48 +446,48 @@ subroutine gfdl_sfc_layer_run (im, nsoil, km, xlat, xlon, flag_iter, lsm, & ! (alog(zkmax(i)/tmp9)/alog(10.0/tmp9)) end if fm10_lnd(i) = karman/sqrt(cd10) - - !GJF: conductances aren't used in other CCPP schemes, but this limit + + !GJF: conductances aren't used in other CCPP schemes, but this limit ! might be able to replace the limits on drag coefficients above - + !chs_lnd(i)=ch_lnd(i)*wspd (i) !conductance !chs2_lnd(i)=ustar_lnd(i)*karman/fh2_lnd(i) !2m conductance - + !!!2014-0922 cap CHS over land points ! chs_lnd(i)=amin1(chs_lnd(i), 0.05) ! chs2_lnd(i)=amin1(chs2_lnd(i), 0.05) ! if (chs2_lnd(i) < 0) chs2_lnd(i)=1.0e-6 - + if (diag_qss) then esat = fpvs(tskin_lnd(i)) qss_lnd(i) = ep2*esat/(psfc(i)-esat) end if - + !GJF: not used in CCPP !flhc_lnd(i)=cpm(i)*rho1(i)*chs_lnd(i) !flqc_lnd(i)=rho1(i)*chs_lnd(i) !cqs2_lnd(i)=chs2_lnd(i) end if !dry - + if (icy(i)) then !GJF: from WRF's module_sf_gfdl.F smcdry=drysmc(isltyp(i)) smcmax=maxsmc(isltyp(i)) wetc(i)=(smois(i,1)-smcdry)/(smcmax-smcdry) wetc(i)=amin1(1.,amax1(wetc(i),0.)) - - + + !GJF: the lower boundary temperature passed in to MFLUX2 either follows GFS: tstrc(i) = 0.5*(tskin_ice(i) + tsurf_ice(i)) !averaging tskin_ice and tsurf_ice as in GFS surface layer breaks ntsflg functionality !GJF: or WRF module_sf_gfdl.F: !tstrc(i) = tskin_ice(i) !averaging tskin_ice and tsurf_ice as in GFS surface layer breaks ntsflg functionality - + !GJF: Roughness Length Limitation section ! The WRF version of module_sf_gfdl.F has no checks on the roughness lengths prior to entering MFLUX2. ! The following limits were placed on roughness lengths from the GFS surface layer scheme at the suggestion ! of Chunxi Zhang. Using the GFDL surface layer without such checks can lead to instability in the UFS. - + !znt_ice is in cm, z0max/ztmax are in m at this point z0max(i) = max(1.0e-6, min(0.01 * znt_ice(i), zkmax(i))) !** xubin's new z0 over land and sea ice @@ -511,17 +511,17 @@ subroutine gfdl_sfc_layer_run (im, nsoil, km, xlat, xlon, flag_iter, lsm, & ztmax(i) = z0max(i)*exp( - tem1*tem1 & & * czilc*karman*sqrt(ustar_ice(i)*(0.01/1.5e-05))) ztmax(i) = max(ztmax(i), 1.0e-6) - - + + !GJF: from WRF's module_sf_gfdl.F if (wind10(i) <= 1.0e-10 .or. wind10(i) > 150.0) then wind10(i)=wspd(i)*alog(10.0/z0max(i))/alog(z1(i)/z0max(i)) end if wind10(i)=wind10(i)*100.0 !! m/s to cm/s - + ztmax(i) = ztmax(i)*100.0 !m to cm z0max(i) = z0max(i)*100.0 !m to cm - + call mflux2 (fxh(i), fxe(i), fxmx(i), fxmy(i), cdm_ice(i), rib_ice(i), & xxfh(i), ztmax(i), z0max(i), tstrc(i), & pspc(i), pkmax(i), wetc(i), slwdc(i), z1_cm(i), icoef_sf, iwavecpl, lcurr_sf, charn(i), msang(i), & @@ -529,61 +529,61 @@ subroutine gfdl_sfc_layer_run (im, nsoil, km, xlat, xlon, flag_iter, lsm, & dt, wind10(i), xxfh2(i), ntsflg, sfenth, tzot(i), errmsg, & errflg) if (errflg /= 0) return - + !GJF: this is broken when tstrc is set to an average of two variables if (ntsflg==1) then - tskin_ice(i) = tstrc(i) ! gopal's doing + tskin_ice(i) = tstrc(i) ! gopal's doing end if - + if (diag_wind10m) then u10_ice(i) = u1(i)*(0.01*wind10(i)/wspd(i)) v10_ice(i) = v1(i)*(0.01*wind10(i)/wspd(i)) end if - + !GJF: these variables are not needed in a GFS-based suite, but are found in WRF's module_sf_gfdl.F and kept in comments for legacy !gz1oz0(i) = alog(zkmax(i)/znt_ice(i)) !taux(i) = fxmx(i)/10. ! gopal's doing for Ocean coupling !tauy(i) = fxmy(i)/10. ! gopal's doing for Ocean coupling - + cdm_ice(i) = max(cdm_ice(i), cd_low_limit) cdm_ice(i) = min(cdm_ice(i), cd_high_limit) fm_ice(i) = karman/sqrt(cdm_ice(i)) - + !1) try fh_ice from MFLUX2 fh_ice(i) = karman*xxfh(i) - + !2) calc ch_ice from fm_ice and fh_ice ch_ice(i) = karman*karman/(fm_ice(i) * fh_ice(i)) - + !3) check if ch_ice is out of bounds (if so, recalculate fh_ice from bounded value) ch_bound_excursion = .false. - if (ch_ice(i) < ch_low_limit) then + if (ch_ice(i) < ch_low_limit) then ch_bound_excursion = .true. ch_ice(i) = ch_low_limit else if (ch_ice(i) > ch_high_limit) then ch_bound_excursion = .true. ch_ice(i) = ch_high_limit end if - + fh2_ice(i) = karman*xxfh2(i) - + if (ch_bound_excursion) then fh2_fh_ratio = min(xxfh2(i)/xxfh(i), 1.0) fh_ice(i) = karman*karman/(fm_ice(i)*ch_ice(i)) fh2_ice(i) = fh2_fh_ratio*fh_ice(i) end if - + !Other CCPP schemes (PBL) ask for fm/fh instead of psim/psih !psim_ice(i)=gz1oz0(i)-fm_ice(i) !psih_ice(i)=gz1oz0(i)-fh_ice(i) - + ustar_ice(i) = 0.01*sqrt(cdm_ice(i)* & (upc(i)*upc(i) + vpc(i)*vpc(i))) !GJF: from Chunxi Zhang's module_sf_sfclayrev.f90 (I'm not sure it's necessary.) ustar_ice(i) = amax1(ustar_ice(i),0.001) - + stress_ice(i) = cdm_ice(i)*wspd(i)*wspd(i) - + !GJF: from WRF's module_sf_gfdl.F !!! convert cd, ch to values at 10m, for output cd10 = cdm_ice(i) @@ -594,38 +594,38 @@ subroutine gfdl_sfc_layer_run (im, nsoil, km, xlat, xlon, flag_iter, lsm, & ! (alog(zkmax(i)/tmp9)/alog(10.0/tmp9)) end if fm10_ice(i) = karman/sqrt(cd10) - + !GJF: conductances aren't used in other CCPP schemes !chs_ice(i)=ch_ice(i)*wspd (i) !conductance !chs2_ice(i)=ustar_ice(i)*karman/fh2_ice(i) !2m conductance - + if (diag_qss) then esat = fpvs(tskin_ice(i)) qss_ice(i) = ep2*esat/(psfc(i)-esat) end if - + !flhc_ice(i)=cpm(i)*rho1(i)*chs_ice(i) !flqc_ice(i)=rho1(i)*chs_ice(i) !cqs2_ice(i)=chs2_ice(i) end if !ice - + if (wet(i)) then wetc(i) = 1.0 - + !GJF: the lower boundary temperature passed in to MFLUX2 either follows GFS: tstrc(i) = 0.5*(tskin_ocn(i) + tsurf_ocn(i)) !averaging tskin_ocn and tsurf_ocn as in GFS surface layer breaks ntsflg functionality !GJF: or WRF module_sf_gfdl.F: !tstrc(i) = tskin_ocn(i) - + !GJF: from WRF's module_sf_gfdl.F if (wind10(i) <= 1.0e-10 .or. wind10(i) > 150.0) then wind10(i)=wspd(i)*alog(10.0/(0.01*znt_ocn(i)))/alog(z1(i)/(0.01*znt_ocn(i))) end if wind10(i)=wind10(i)*100.0 !! m/s to cm/s - + !GJF: mflux2 expects negative roughness length for ocean points znt_ocn(i) = -znt_ocn(i) - + call mflux2 (fxh(i), fxe(i), fxmx(i), fxmy(i), cdm_ocn(i), rib_ocn(i), & xxfh(i), znt_ocn(i), mznt(i), tstrc(i), & pspc(i), pkmax(i), wetc(i), slwdc(i), z1_cm(i), icoef_sf, iwavecpl, lcurr_sf, charn(i), msang(i), & @@ -633,67 +633,67 @@ subroutine gfdl_sfc_layer_run (im, nsoil, km, xlat, xlon, flag_iter, lsm, & dt, wind10(i), xxfh2(i), ntsflg, sfenth, tzot(i), errmsg, & errflg) if (errflg /= 0) return - + !GJF: this is broken when tstrc is set to an average of two variables if (ntsflg==1) then - tskin_ocn(i) = tstrc(i) ! gopal's doing + tskin_ocn(i) = tstrc(i) ! gopal's doing end if - + znt_ocn(i)= abs(znt_ocn(i)) mznt(i)= abs(mznt(i)) - + !GJF: these bounds on ocean roughness lengths are from Chunxi Zhang's module_sf_sfclayrev.f90 (in cm) znt_ocn(i)=min(2.85e-1,max(znt_ocn(i),1.27e-5)) - + if (diag_wind10m) then u10_ocn(i) = u1(i)*(0.01*wind10(i)/wspd(i)) v10_ocn(i) = v1(i)*(0.01*wind10(i)/wspd(i)) end if - + !GJF: these variables are not needed in a GFS-based suite, but are found in WRF's module_sf_gfdl.F and kept in comments for legacy !gz1oz0(i) = alog(zkmax(i)/znt_ocn(i)) !taux(i) = fxmx(i)/10. ! gopal's doing for Ocean coupling !tauy(i) = fxmy(i)/10. ! gopal's doing for Ocean coupling - + cdm_ocn(i) = max(cdm_ocn(i), cd_low_limit) cdm_ocn(i) = min(cdm_ocn(i), cd_high_limit) fm_ocn(i) = karman/sqrt(cdm_ocn(i)) - + !1) try fh_ocn from MFLUX2 fh_ocn(i) = karman*xxfh(i) - + !2) calc ch_ocn from fm_ocn and fh_ocn ch_ocn(i) = karman*karman/(fm_ocn(i) * fh_ocn(i)) - + !3) check if ch_lnd is out of bounds (if so, recalculate fh_lnd from bounded value) ch_bound_excursion = .false. - if (ch_ocn(i) < ch_low_limit) then + if (ch_ocn(i) < ch_low_limit) then ch_bound_excursion = .true. ch_ocn(i) = ch_low_limit else if (ch_ocn(i) > ch_high_limit) then ch_bound_excursion = .true. ch_ocn(i) = ch_high_limit end if - + fh2_ocn(i) = karman*xxfh2(i) - + if (ch_bound_excursion) then fh2_fh_ratio = min(xxfh2(i)/xxfh(i), 1.0) fh_ocn(i) = karman*karman/(fm_ocn(i)*ch_ocn(i)) fh2_ocn(i) = fh2_fh_ratio*fh_ocn(i) end if - + !Other CCPP schemes (PBL) ask for fm/fh instead of psim/psih !psim_ocn(i)=gz1oz0(i)-fm_ocn(i) !psih_ocn(i)=gz1oz0(i)-fh_ocn(i) - + ustar_ocn(i) = 0.01*sqrt(cdm_ocn(i)* & (upc(i)*upc(i) + vpc(i)*vpc(i))) !GJF: from Chunxi Zhang's module_sf_sfclayrev.f90 (I'm not sure it's necessary.) ustar_ocn(i) = amax1(ustar_ocn(i),0.001) - + stress_ocn(i) = cdm_ocn(i)*wspd(i)*wspd(i) - + !GJF: from WRF's module_sf_gfdl.F !!! convert cd, ch to values at 10m, for output cd10 = cdm_ocn(i) @@ -704,23 +704,23 @@ subroutine gfdl_sfc_layer_run (im, nsoil, km, xlat, xlon, flag_iter, lsm, & ! (alog(zkmax(i)/tmp9)/alog(10.0/tmp9)) end if fm10_ocn(i) = karman/sqrt(cd10) - + !GJF: conductances aren't used in other CCPP schemes !chs_ocn(i)=ch_ocn(i)*wspd (i) !conductance !chs2_ocn(i)=ustar_ocn(i)*karman/fh2_ocn(i) !2m conductance - + if (diag_qss) then esat = fpvs(tskin_ocn(i)) qss_ocn(i) = ep2*esat/(psfc(i)-esat) end if end if !wet - + !flhc_ocn(i)=cpm(i)*rho1(i)*chs_ocn(i) !flqc_ocn(i)=rho1(i)*chs_ocn(i) !cqs2_ocn(i)=chs2_ocn(i) end if !flag_iter end do - + !GJF: this code has not been updated since GFS suites don't require this; one would need to have different values of hfx, qfx, lh for each surface type ! if (isfflx.eq.0) then ! do i=its,ite @@ -734,7 +734,7 @@ subroutine gfdl_sfc_layer_run (im, nsoil, km, xlat, xlon, flag_iter, lsm, & ! !water ! hfx(i)= -10.*cp*fxh(i) ! else if (islmsk == 1) then - ! hfx(i)= -10.*cp*fxh(i) + ! hfx(i)= -10.*cp*fxh(i) ! hfx(i)=amax1(hfx(i),-250.) ! end if ! qfx(j)=-10.*fxe(i) @@ -742,8 +742,8 @@ subroutine gfdl_sfc_layer_run (im, nsoil, km, xlat, xlon, flag_iter, lsm, & ! lh(i)=xlv*qfx(i) ! enddo ! endif - - + + end subroutine gfdl_sfc_layer_run !--------------------------------- @@ -754,13 +754,13 @@ SUBROUTINE MFLUX2( fxh,fxe,fxmx,fxmy,cdm,rib,xxfh,zoc,mzoc,tstrc, & !m pert_Cd, ens_random_seed, ens_Cdamp, & upc,vpc,tpc,rpc,dt,wind10,xxfh2,ntsflg,sfenth, & tzot, errmsg, errflg) - + !------------------------------------------------------------------------ ! -! MFLUX2 computes surface fluxes of momentum, heat,and moisture -! using monin-obukhov. the roughness length "z0" is prescribed +! MFLUX2 computes surface fluxes of momentum, heat,and moisture +! using monin-obukhov. the roughness length "z0" is prescribed ! over land and over ocean "z0" is computed using charnocks formula. -! the universal functions (from similarity theory approach) are +! the universal functions (from similarity theory approach) are ! those of hicks. This is Bob's doing. ! !------------------------------------------------------------------------ @@ -782,7 +782,7 @@ SUBROUTINE MFLUX2( fxh,fxe,fxmx,fxmy,cdm,rib,xxfh,zoc,mzoc,tstrc, & !m integer,intent(in) :: icoef_sf integer,intent(in) :: iwavecpl logical,intent(in) :: lcurr_sf - logical,intent(in) :: pert_Cd + logical,intent(in) :: pert_Cd integer,intent(in) :: ens_random_seed real(kind=kind_phys),intent(in) :: ens_Cdamp @@ -815,7 +815,7 @@ SUBROUTINE MFLUX2( fxh,fxe,fxmx,fxmy,cdm,rib,xxfh,zoc,mzoc,tstrc, & !m real(kind=kind_phys), intent ( in), dimension (ims :ime ) :: vpc real(kind=kind_phys), intent ( in), dimension (ims :ime ) :: tpc real(kind=kind_phys), intent ( in), dimension (ims :ime ) :: rpc - + character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg @@ -841,7 +841,7 @@ SUBROUTINE MFLUX2( fxh,fxe,fxmx,fxmy,cdm,rib,xxfh,zoc,mzoc,tstrc, & !m real(kind=kind_phys), dimension(1 :ime) :: estsop real(kind=kind_phys), dimension(1 :ime) :: fmz1 real(kind=kind_phys), dimension(1 :ime) :: fmz10 - real(kind=kind_phys), dimension(1 :ime) :: fmz2 + real(kind=kind_phys), dimension(1 :ime) :: fmz2 real(kind=kind_phys), dimension(1 :ime) :: fmzo1 real(kind=kind_phys), dimension(1 :ime) :: foft real(kind=kind_phys), dimension(1 :ime) :: foftm @@ -855,7 +855,7 @@ SUBROUTINE MFLUX2( fxh,fxe,fxmx,fxmy,cdm,rib,xxfh,zoc,mzoc,tstrc, & !m real(kind=kind_phys), dimension(1 :ime) :: rstso real(kind=kind_phys), dimension(1 :ime) :: rstsop real(kind=kind_phys), dimension(1 :ime) :: sf10 - real(kind=kind_phys), dimension(1 :ime) :: sf2 + real(kind=kind_phys), dimension(1 :ime) :: sf2 real(kind=kind_phys), dimension(1 :ime) :: sfm real(kind=kind_phys), dimension(1 :ime) :: sfzo real(kind=kind_phys), dimension(1 :ime) :: sgzm @@ -876,7 +876,7 @@ SUBROUTINE MFLUX2( fxh,fxe,fxmx,fxmy,cdm,rib,xxfh,zoc,mzoc,tstrc, & !m real(kind=kind_phys), dimension(1 :ime) :: tss real(kind=kind_phys), dimension(1 :ime) :: ucom real(kind=kind_phys), dimension(1 :ime) :: uf10 - real(kind=kind_phys), dimension(1 :ime) :: uf2 + real(kind=kind_phys), dimension(1 :ime) :: uf2 real(kind=kind_phys), dimension(1 :ime) :: ufh real(kind=kind_phys), dimension(1 :ime) :: ufm real(kind=kind_phys), dimension(1 :ime) :: ufzo @@ -894,7 +894,7 @@ SUBROUTINE MFLUX2( fxh,fxe,fxmx,fxmy,cdm,rib,xxfh,zoc,mzoc,tstrc, & !m real(kind=kind_phys), dimension(1 :ime) :: xxfm real(kind=kind_phys), dimension(1 :ime) :: xxsh real(kind=kind_phys), dimension(1 :ime) :: z10 - real(kind=kind_phys), dimension(1 :ime) :: z2 + real(kind=kind_phys), dimension(1 :ime) :: z2 real(kind=kind_phys), dimension(1 :ime) :: zeta real(kind=kind_phys), dimension(1 :ime) :: zkmax @@ -910,7 +910,7 @@ SUBROUTINE MFLUX2( fxh,fxe,fxmx,fxmy,cdm,rib,xxfh,zoc,mzoc,tstrc, & !m real(kind=kind_phys) :: ux13, yo, y,xo,x,ux21,ugzzo,ux11,ux12,uzetao,xnum,alll real(kind=kind_phys) :: ux1,ugz,x10,uzo,uq,ux2,ux3,xtan,xden,y10,uzet1o,ugz10 - real(kind=kind_phys) :: szet2, zal2,ugz2 + real(kind=kind_phys) :: szet2, zal2,ugz2 real(kind=kind_phys) :: rovcp,boycon,cmo2,psps1,zog,enrca,rca,cmo1,amask,en,ca,a,c real(kind=kind_phys) :: sgz,zal10,szet10,fmz,szo,sq,fmzo,rzeta1,zal1g,szetao,rzeta2,zal2g real(kind=kind_phys) :: hcap,xks,pith,teps,diffot,delten,alevp,psps2,alfus,nstep @@ -925,7 +925,7 @@ SUBROUTINE MFLUX2( fxh,fxe,fxmx,fxmy,cdm,rib,xxfh,zoc,mzoc,tstrc, & !m ! internal variables !----------------------------------------------------------------------- - real(kind=kind_phys), dimension (223) :: tab + real(kind=kind_phys), dimension (223) :: tab real(kind=kind_phys), dimension (223) :: table real(kind=kind_phys), dimension (101) :: tab11 real(kind=kind_phys), dimension (41) :: table4 @@ -947,7 +947,7 @@ SUBROUTINE MFLUX2( fxh,fxe,fxmx,fxmy,cdm,rib,xxfh,zoc,mzoc,tstrc, & !m data amask/ -98.0/ !----------------------------------------------------------------------- -! tables used to obtain the vapor pressures or saturated vapor +! tables used to obtain the vapor pressures or saturated vapor ! pressure !----------------------------------------------------------------------- @@ -1003,7 +1003,7 @@ SUBROUTINE MFLUX2( fxh,fxe,fxmx,fxmy,cdm,rib,xxfh,zoc,mzoc,tstrc, & !m data table3/.7520e+03,.7980e+03,.8470e+03,.8980e+03,.9520e+03, & &.1008e+04,.1067e+04,.1129e+04,.1194e+04,.1263e+04,.1334e+04, & &.1409e+04,.1488e+04,.1569e+04,.1656e+04,.1745e+04,.1840e+04, & - &.1937e+04,.2041e+04,.2147e+04,.2259e+04,.2375e+04,.2497e+04, & + &.1937e+04,.2041e+04,.2147e+04,.2259e+04,.2375e+04,.2497e+04, & &.2624e+04,.2756e+04,.2893e+04,.3036e+04,.3186e+04,.3340e+04, & &.3502e+04,.3670e+04,.3843e+04,.4025e+04,.4213e+04,.4408e+04, & &.4611e+04,.4821e+04,.5035e+04,.5270e+04,.5500e+04,.5740e+04, & @@ -1027,7 +1027,7 @@ SUBROUTINE MFLUX2( fxh,fxe,fxmx,fxmy,cdm,rib,xxfh,zoc,mzoc,tstrc, & !m real,parameter :: rgas = 2.87e6 real,parameter :: og = 1./g integer :: ntstep = 0 - + ! Initialize CCPP error handling variables errmsg = '' errflg = 0 @@ -1072,7 +1072,7 @@ SUBROUTINE MFLUX2( fxh,fxe,fxmx,fxmy,cdm,rib,xxfh,zoc,mzoc,tstrc, & !m ! routine = 'mflux2' ! !------------------------------------------------------------------------ -! set water availability constant "ecof" and land mask "land". +! set water availability constant "ecof" and land mask "land". ! limit minimum wind speed to 100 cm/s !------------------------------------------------------------------------ ! constants for 10 m winds (correction for knots @@ -1162,13 +1162,13 @@ SUBROUTINE MFLUX2( fxh,fxe,fxmx,fxmy,cdm,rib,xxfh,zoc,mzoc,tstrc, & !m enddo !------------------------------------------------------------------------ -! define constants: -! a and c = constants used in evaluating universal function for -! stable case -! ca = karmen constant -! cm01 = constant part of vertical integral of universal -! function; stable case ( 0.5 < zeta < or = 10.0) -! cm02 = constant part of vertical integral of universal +! define constants: +! a and c = constants used in evaluating universal function for +! stable case +! ca = karmen constant +! cm01 = constant part of vertical integral of universal +! function; stable case ( 0.5 < zeta < or = 10.0) +! cm02 = constant part of vertical integral of universal ! function; stable case ( zeta > 10.0) !------------------------------------------------------------------------ @@ -1204,14 +1204,14 @@ SUBROUTINE MFLUX2( fxh,fxe,fxmx,fxmy,cdm,rib,xxfh,zoc,mzoc,tstrc, & !m if(psps1 .EQ. 0.0)then psps1 = .1 endif - rstso(i) = 0.622*estso(i)/psps1 + rstso(i) = 0.622*estso(i)/psps1 vrts (i) = 1. + boycon*ecof(i)*rstso(i) enddo !------------------------------------------------------------------------ ! check if consideration of virtual temperature changes stability. -! if so, set "dthetav" to near neutral value (1.0e-4). also check -! for very small lapse rates; if ABS(tempa1) <1.0e-4 then +! if so, set "dthetav" to near neutral value (1.0e-4). also check +! for very small lapse rates; if ABS(tempa1) <1.0e-4 then ! tempa1=1.0e-4 !------------------------------------------------------------------------ @@ -1238,13 +1238,13 @@ SUBROUTINE MFLUX2( fxh,fxe,fxmx,fxmy,cdm,rib,xxfh,zoc,mzoc,tstrc, & !m enddo !------------------------------------------------------------------------ -! begin looping through points on line, solving wegsteins iteration +! begin looping through points on line, solving wegsteins iteration ! for zeta at each point, and using hicks functions !------------------------------------------------------------------------ !------------------------------------------------------------------------ -! set initial guess of zeta=non - dimensional height "szeta" for -! stable points +! set initial guess of zeta=non - dimensional height "szeta" for +! stable points !------------------------------------------------------------------------ rca = 1./ca @@ -1346,14 +1346,14 @@ SUBROUTINE MFLUX2( fxh,fxe,fxmx,fxmy,cdm,rib,xxfh,zoc,mzoc,tstrc, & !m if (szet2 .LE. 0.5) then fmz2 (i) = (zal2 + a*szet2 )*rca else if (szet2 .GT. 0.5 .AND. szet2 .LE. 2.) then - rzeta2 = 1./szet2 + rzeta2 = 1./szet2 fmz2 (i) = (8.*zal2 + 4.25*rzeta2 - & 0.5*rzeta2*rzeta2 + cmo1)*rca else if (szet2 .GT. 2.) then fmz2 (i) = (c*szet2 + cmo2)*rca endif sf2 (i) = fmz2 (i) - fmzo1(i) - + sfm(i) = fmz1(i) - fmzo1(i) sfh(i) = fmz1(i) - fhzo1(i) sgz = ca*rib(istb(i))*sfm(i)*sfm(i)/ & @@ -1385,7 +1385,7 @@ SUBROUTINE MFLUX2( fxh,fxe,fxmx,fxmy,cdm,rib,xxfh,zoc,mzoc,tstrc, & !m go to 130 110 continue - + write(errmsg,'(*(a))') 'NON-CONVERGENCE FOR STABLE ZETA IN gfdl_sfc_layer.F90/MFLUX2' errflg = 1 return @@ -1394,7 +1394,7 @@ SUBROUTINE MFLUX2( fxh,fxe,fxmx,fxmy,cdm,rib,xxfh,zoc,mzoc,tstrc, & !m !------------------------------------------------------------------------ ! update "zo" for ocean points. "zo"cannot be updated within the ! wegsteins iteration as the scheme (for the near neutral case) -! can become unstable +! can become unstable !------------------------------------------------------------------------ 130 continue @@ -1416,7 +1416,7 @@ SUBROUTINE MFLUX2( fxh,fxe,fxmx,fxmy,cdm,rib,xxfh,zoc,mzoc,tstrc, & !m ustar = sqrt( -szo / zog) restar = -ustar * szo / vis - restar = max(restar,cons_p000001) + restar = max(restar,cons_p000001) ! Rat taken from Zeng, Zhao and Dickinson 1997 rat = 2.67 * restar ** .25 - 2.57 rat = min(rat ,cons_7) !constant @@ -1425,7 +1425,7 @@ SUBROUTINE MFLUX2( fxh,fxe,fxmx,fxmy,cdm,rib,xxfh,zoc,mzoc,tstrc, & !m else zot(istb(i)) = zoc(istb(i)) endif - + ! in hwrf thermal znot is loaded back into the zoc array for next step zoc(istb(i)) = szo enddo @@ -1450,7 +1450,7 @@ SUBROUTINE MFLUX2( fxh,fxe,fxmx,fxmy,cdm,rib,xxfh,zoc,mzoc,tstrc, & !m endif ! the above correction done by GFDL in centi-kts!!!-change back wind10(istb(i)) = wind10(istb(i)) / 1.944 - enddo + enddo !------------------------------------------------------------------------ ! unstable points @@ -1537,7 +1537,7 @@ SUBROUTINE MFLUX2( fxh,fxe,fxmx,fxmy,cdm,rib,xxfh,zoc,mzoc,tstrc, & !m ugz2 = ALOG(z2 (iutb(i))/ABS(zoc(iutb(i)))) uzet1o = ABS(z2 (iutb(i)))/zkmax(iutb(i))*uzeta(i) uzetao = ABS(zoc(iutb(i)))/zkmax(iutb(i))*uzeta(i) - ux11 = 1. - 16.*uzet1o + ux11 = 1. - 16.*uzet1o ux12 = 1. - 16.*uzetao y = SQRT(ux11) yo = SQRT(ux12) @@ -1579,7 +1579,7 @@ SUBROUTINE MFLUX2( fxh,fxe,fxmx,fxmy,cdm,rib,xxfh,zoc,mzoc,tstrc, & !m 'uq is 1 ',ux2,ugz,ugzm(i),uzeta(i),uzetam(i) errflg = 1 return - + ! call MPI_CLOSE(1,routine) !------------------------------------------------------------------------ @@ -1591,7 +1591,7 @@ SUBROUTINE MFLUX2( fxh,fxe,fxmx,fxmy,cdm,rib,xxfh,zoc,mzoc,tstrc, & !m !------------------------------------------------------------------------ ! update "zo" for ocean points. zo cannot be updated within the ! wegsteins iteration as the scheme (for the near neutral case) -! can become unstable. +! can become unstable. !------------------------------------------------------------------------ do i = 1,iq @@ -1636,7 +1636,7 @@ SUBROUTINE MFLUX2( fxh,fxe,fxmx,fxmy,cdm,rib,xxfh,zoc,mzoc,tstrc, & !m endif ! the above correction done by GFDL in centi-kts!!!-change back wind10(iutb(i)) = wind10(iutb(i)) / 1.944 - enddo + enddo do i = 1,iq xxfm(iutb(i)) = ufm(i) @@ -1661,7 +1661,7 @@ SUBROUTINE MFLUX2( fxh,fxe,fxmx,fxmy,cdm,rib,xxfh,zoc,mzoc,tstrc, & !m enddo ! do land sfc temperature prediction if ntsflg=1 -! ntsflg = 1 ! gopal's doing +! ntsflg = 1 ! gopal's doing if (ntsflg .EQ. 0) go to 370 alll = 600. @@ -1671,7 +1671,7 @@ SUBROUTINE MFLUX2( fxh,fxe,fxmx,fxmy,cdm,rib,xxfh,zoc,mzoc,tstrc, & !m alfus = alll/2.39e-8 teps = 0.1 ! slwdc... in units of cal/min ???? -! slwa... in units of ergs/sec/cm*2 +! slwa... in units of ergs/sec/cm*2 ! 1 erg=2.39e-8 cal !------------------------------------------------------------------------ ! pack land and sea ice points @@ -1732,7 +1732,7 @@ SUBROUTINE MFLUX2( fxh,fxe,fxmx,fxmy,cdm,rib,xxfh,zoc,mzoc,tstrc, & !m if(psps2 .EQ. 0.0)then psps2 = .1 endif - rstsop(i) = 0.622*estsop(i)/psps2 + rstsop(i) = 0.622*estsop(i)/psps2 rdiff (i) = amin1(0.0,(rkmaxp(i) - rstsop(i))) foft(i) = tss(i) + delsrad(i)*(slwa(i) - aap(i)*tsp(i)**4 - & @@ -1742,7 +1742,7 @@ SUBROUTINE MFLUX2( fxh,fxe,fxmx,fxmy,cdm,rib,xxfh,zoc,mzoc,tstrc, & !m frac(i) = ABS((foft(i) - tsp(i))/tsp(i)) !------------------------------------------------------------------------ -! check for convergence of all points use wegstein iteration +! check for convergence of all points use wegstein iteration !------------------------------------------------------------------------ if (frac(i) .GE. teps) then @@ -1770,7 +1770,7 @@ SUBROUTINE MFLUX2( fxh,fxe,fxmx,fxmy,cdm,rib,xxfh,zoc,mzoc,tstrc, & !m ! call MPI_CLOSE(1,routine) endif enddo - + do i = 1,ip ii = indx(i) tstrc(ii) = tsp (i) @@ -1782,7 +1782,7 @@ SUBROUTINE MFLUX2( fxh,fxe,fxmx,fxmy,cdm,rib,xxfh,zoc,mzoc,tstrc, & !m 370 continue do i = its,ite -!!! +!!! if ( iwavecpl .eq. 1 .and. zoc(i) .le. 0.0 ) then windmks = wind10(i) * 0.01 call znot_wind10m(windmks,znott,znotm,icoef_sf) @@ -1816,5 +1816,5 @@ SUBROUTINE MFLUX2( fxh,fxe,fxmx,fxmy,cdm,rib,xxfh,zoc,mzoc,tstrc, & !m ntstep = ntstep + 1 return end subroutine MFLUX2 - + end module gfdl_sfc_layer diff --git a/physics/gfdl_sfc_layer.meta b/physics/gfdl_sfc_layer.meta index 5a245cd69..cb20690b3 100644 --- a/physics/gfdl_sfc_layer.meta +++ b/physics/gfdl_sfc_layer.meta @@ -436,7 +436,7 @@ type = real kind = kind_phys intent = in - optional = F + optional = F [glw] standard_name = surface_downwelling_longwave_flux long_name = surface downwelling longwave flux at current time diff --git a/physics/module_sf_exchcoef.f90 b/physics/module_sf_exchcoef.f90 index 0e3dae80c..500fc3afd 100755 --- a/physics/module_sf_exchcoef.f90 +++ b/physics/module_sf_exchcoef.f90 @@ -1,4 +1,4 @@ -! This MODULE holds the routines that calculate air-sea exchange coefficients +! This MODULE holds the routines that calculate air-sea exchange coefficients MODULE module_sf_exchcoef CONTAINS @@ -48,7 +48,7 @@ SUBROUTINE znot_m_v1(uref,znotm) END IF END SUBROUTINE znot_m_v1 - + SUBROUTINE znot_m_v0(uref,znotm) IMPLICIT NONE @@ -57,7 +57,7 @@ SUBROUTINE znot_m_v0(uref,znotm) ! Author : Biju Thomas on 02/07/2014 REAL, INTENT(IN) :: uref - REAL, INTENT(OUT):: znotm + REAL, INTENT(OUT):: znotm REAL :: yz, y1, y2, y3, y4 yz = 0.0001344 @@ -145,7 +145,7 @@ SUBROUTINE znot_t_v1(uref,znott) END IF END SUBROUTINE znot_t_v1 - + SUBROUTINE znot_t_v0(uref,znott) IMPLICIT NONE @@ -154,7 +154,7 @@ SUBROUTINE znot_t_v0(uref,znott) ! Author : Biju Thomas on 02/07/2014 REAL, INTENT(IN) :: uref - REAL, INTENT(OUT):: znott + REAL, INTENT(OUT):: znott IF ( uref .LT. 7.0 ) THEN znott = (0.0185 / 9.8*(7.59e-4*uref**2+2.46e-2*uref)**2) @@ -210,7 +210,7 @@ SUBROUTINE znot_t_v2(uu,znott) znott = ta6 + ta5*uu + ta4*uu**2 + ta3*uu**3 + ta2*uu**4 + & ta1*uu**5 + ta0*uu**6 ELSEIF ( uu .GE. 15.0 .AND. uu .LT. 60.0) THEN - znott = tb6 + tb5*uu + tb4*uu**2 + tb3*uu**3 + tb2*uu**4 + & + znott = tb6 + tb5*uu + tb4*uu**2 + tb3*uu**3 + tb2*uu**4 + & tb1*uu**5 + tb0*uu**6 ELSE znott = tt6 + tt5*uu + tt4*uu**2 + tt3*uu**3 + tt2*uu**4 + & @@ -226,7 +226,7 @@ SUBROUTINE znot_m_v6(uref,znotm) ! For high winds, try to fit available observational data ! ! Bin Liu, NOAA/NCEP/EMC 2017 -! +! ! uref(m/s) : wind speed at 10-m height ! znotm(meter): areodynamical roughness scale over water ! @@ -361,10 +361,10 @@ SUBROUTINE znot_m_v7(uref,znotm) ! Calculate areodynamical roughness over water with input 10-m wind ! For low-to-moderate winds, try to match the Cd-U10 relationship from COARE V3.5 (Edson et al. 2013) ! For high winds, try to fit available observational data -! Comparing to znot_t_v6, slightly decrease Cd for higher wind speed +! Comparing to znot_t_v6, slightly decrease Cd for higher wind speed ! ! Bin Liu, NOAA/NCEP/EMC 2018 -! +! ! uref(m/s) : wind speed at 10-m height ! znotm(meter): areodynamical roughness scale over water ! @@ -443,28 +443,28 @@ SUBROUTINE znot_t_v7(uref,znott) p12 = 3.342963077911962e-05 p11 = -2.633566691328004e-04 p10 = 8.644979973037803e-04 - + p25 = -9.402722450219142e-12 p24 = 1.325396583616614e-09 p23 = -7.299148051141852e-08 p22 = 1.982901461144764e-06 p21 = -2.680293455916390e-05 p20 = 1.484341646128200e-04 - + p35 = 7.921446674311864e-12 p34 = -1.019028029546602e-09 p33 = 5.251986927351103e-08 p32 = -1.337841892062716e-06 p31 = 1.659454106237737e-05 p30 = -7.558911792344770e-05 - + p45 = -2.694370426850801e-10 p44 = 5.817362913967911e-08 p43 = -5.000813324746342e-06 p42 = 2.143803523428029e-04 p41 = -4.588070983722060e-03 p40 = 3.924356617245624e-02 - + p56 = -1.663918773476178e-13 p55 = 6.724854483077447e-11 p54 = -1.127030176632823e-08 @@ -472,7 +472,7 @@ SUBROUTINE znot_t_v7(uref,znott) p52 = -5.012618091180904e-05 p51 = 1.329762020689302e-03 p50 = -1.450062148367566e-02 - + p60 = 6.840803042788488e-05 if (uref >= 0.0 .and. uref < 5.9 ) then @@ -500,11 +500,11 @@ SUBROUTINE znot_m_v8(uref,znotm) ! Calculate areodynamical roughness over water with input 10-m wind ! For low-to-moderate winds, try to match the Cd-U10 relationship from COARE V3.5 (Edson et al. 2013) ! For high winds, try to fit available observational data -! Comparing to znot_t_v6, slightly decrease Cd for higher wind speed +! Comparing to znot_t_v6, slightly decrease Cd for higher wind speed ! And this is another variation similar to v7 ! ! Bin Liu, NOAA/NCEP/EMC 2018 -! +! ! uref(m/s) : wind speed at 10-m height ! znotm(meter): areodynamical roughness scale over water ! @@ -584,14 +584,14 @@ SUBROUTINE znot_t_v8(uref,znott) p12 = 3.342963077911962e-05 p11 = -2.633566691328004e-04 p10 = 8.644979973037803e-04 - + p25 = -9.402722450219142e-12 p24 = 1.325396583616614e-09 p23 = -7.299148051141852e-08 p22 = 1.982901461144764e-06 p21 = -2.680293455916390e-05 p20 = 1.484341646128200e-04 - + p35 = 7.921446674311864e-12 p34 = -1.019028029546602e-09 p33 = 5.251986927351103e-08 @@ -605,7 +605,7 @@ SUBROUTINE znot_t_v8(uref,znott) p42 = 2.156326523752734e-04 p41 = -4.617267288861201e-03 p40 = 3.951492707214883e-02 - + p56 = -1.112896580069263e-13 p55 = 4.450334755105140e-11 p54 = -7.375373918500171e-09 @@ -613,7 +613,7 @@ SUBROUTINE znot_t_v8(uref,znott) p52 = -3.206421106713471e-05 p51 = 8.407596231678149e-04 p50 = -9.027924333673693e-03 - + p60 = 5.791179079892191e-05 if (uref >= 0.0 .and. uref < 5.9 ) then @@ -672,7 +672,7 @@ SUBROUTINE znot_wind10m(w10m,znott,znotm,icoef_sf) call znot_t_v2(windmks,zt) !! adjust a little to match obs at 10m, cd is reduced tmp=0.4*0.4/(alog(zlev/zm))**2 ! cd at zlev - zm1=z10/exp( sqrt(0.4*0.4/(tmp*0.95-0.0002)) ) + zm1=z10/exp( sqrt(0.4*0.4/(tmp*0.95-0.0002)) ) !ch tmp=0.4*0.4/(alog(zlevt/zm)*alog(zlevt/zt)) ! ch at zlev using old formula zt1=z10/exp( 0.4*0.4/( 0.95*tmp*alog(z10/zm1) ) ) @@ -681,7 +681,7 @@ SUBROUTINE znot_wind10m(w10m,znott,znotm,icoef_sf) call znot_m_v1(windmks,zm) call znot_t_v2(windmks,zt) -!! for wind<20, cd similar to icoef=2 at 10m, then reduced +!! for wind<20, cd similar to icoef=2 at 10m, then reduced tmp=0.4*0.4/(alog(10.0/zm))**2 ! cd at zlev aaa=0.75 if (windmks < 20) then @@ -689,7 +689,7 @@ SUBROUTINE znot_wind10m(w10m,znott,znotm,icoef_sf) elseif(windmks < 45.0) then aaa=0.99+(windmks-20)*(0.75-0.99)/(45.0-20.0) endif - zm1=z10/exp( sqrt(0.4*0.4/(tmp*aaa)) ) + zm1=z10/exp( sqrt(0.4*0.4/(tmp*aaa)) ) !ch tmp=0.4*0.4/(alog(zlevt/zm)*alog(zlevt/zt)) ! ch at zlev using old formula zt1=z10/exp( 0.4*0.4/( 0.95*tmp*alog(z10/zm1) ) ) diff --git a/physics/module_sf_noahlsm.F90 b/physics/module_sf_noahlsm.F90 index 13d8e9813..f8afe5a86 100644 --- a/physics/module_sf_noahlsm.F90 +++ b/physics/module_sf_noahlsm.F90 @@ -3,10 +3,10 @@ MODULE module_sf_noahlsm !ckay=KIRAN ALAPATY @ US EPA -- November 01, 2015 ! ! Tim Glotfelty@CNSU; AJ Deng@PSU -!modified for use with FASDAS -!Flux Adjusting Surface Data Assimilation System to assimilate +!modified for use with FASDAS +!Flux Adjusting Surface Data Assimilation System to assimilate !surface layer and soil layers temperature and moisture using -! surfance reanalsys +! surfance reanalsys !Reference: Alapaty et al., 2008: Development of the flux-adjusting surface ! data assimilation system for mesoscale models. JAMC, 47, 2331-2350 ! @@ -70,7 +70,7 @@ SUBROUTINE SFLX (IILOC,JJLOC,FFROZP,ISURBAN,DT,ZLVL,NSOIL,SLDPTH, & !C EC,EDIR,ET,ETT,ESNOW,DRIP,DEW, & !O BETA,ETP,SSOIL, & !O FLX1,FLX2,FLX3, & !O - FLX4,FVB,FBUR,FGSN,UA_PHYS, & !UA + FLX4,FVB,FBUR,FGSN,UA_PHYS, & !UA SNOMLT,SNCOVR, & !O RUNOFF1,RUNOFF2,RUNOFF3, & !O RC,PC,RSMIN,XLAI,RCS,RCT,RCQ,RCSOIL, & !O @@ -388,7 +388,7 @@ SUBROUTINE SFLX (IILOC,JJLOC,FFROZP,ISURBAN,DT,ZLVL,NSOIL,SLDPTH, & !C ! ---------------------------------------------------------------------- errmsg = '' errflg = 0 - + ILOC = IILOC JLOC = JJLOC @@ -585,7 +585,7 @@ SUBROUTINE SFLX (IILOC,JJLOC,FFROZP,ISURBAN,DT,ZLVL,NSOIL,SLDPTH, & !C CH = CH/(1.+RU*CH) ENDIF - SNCOVR = MIN(SNCOVR,0.98) + SNCOVR = MIN(SNCOVR,0.98) CALL ALCALC (ALB,SNOALB,EMBRD,SHDFAC,SHDMIN,SNCOVR,T1, & ALBEDO,EMISSI,DT,SNOWNG,SNOTIME1,LVCOEF) @@ -774,7 +774,7 @@ SUBROUTINE SFLX (IILOC,JJLOC,FFROZP,ISURBAN,DT,ZLVL,NSOIL,SLDPTH, & !C BETA,DRIP,DEW,FLX1,FLX3,VEGTYP,ISURBAN, & SFHEAD1RT,INFXS1RT,ETPND1,SOILTYP,OPT_THCND & ,XSDA_QFX,QFX_PHY,XQNORM,fasdas,HCPCT_FASDAS, & !fasdas - SIGMA,CPH2O) + SIGMA,CPH2O) ETA_KINEMATIC = ETA ELSE CALL SNOPAC (ETP,ETA,PRCP,PRCPF,SNOWNG,SMC,SMCMAX,SMCWLT, & @@ -793,7 +793,7 @@ SUBROUTINE SFLX (IILOC,JJLOC,FFROZP,ISURBAN,DT,ZLVL,NSOIL,SLDPTH, & !C ETPN,FLX4,UA_PHYS, & SFHEAD1RT,INFXS1RT,ETPND1,SOILTYP,OPT_THCND & ,QFX_PHY,fasdas,HCPCT_FASDAS,SIGMA,CPH2O,CPICE, & !fasdas - LSUBF) + LSUBF) ETA_KINEMATIC = ESNOW + ETNS - 1000.0*DEW END IF @@ -807,7 +807,7 @@ SUBROUTINE SFLX (IILOC,JJLOC,FFROZP,ISURBAN,DT,ZLVL,NSOIL,SLDPTH, & !C ! ---------------------------------------------------------------------- SHEAT = - (CH * CP * SFCPRS)/ (R * T2V) * ( TH2- T1 ) - IF(UA_PHYS) SHEAT = SHEAT + FLX4 + IF(UA_PHYS) SHEAT = SHEAT + FLX4 ! ! FASDAS ! @@ -826,7 +826,7 @@ SUBROUTINE SFLX (IILOC,JJLOC,FFROZP,ISURBAN,DT,ZLVL,NSOIL,SLDPTH, & !C ET(K) = ET(K) * LVH2O ENDDO ETT = ETT * LVH2O - + ETPND1=ETPND1 * LVH2O ESNOW = ESNOW * LSUBS @@ -1425,7 +1425,7 @@ END SUBROUTINE EVAPO ! ---------------------------------------------------------------------- SUBROUTINE FAC2MIT(SMCMAX,FLIMIT) - IMPLICIT NONE + IMPLICIT NONE REAL, INTENT(IN) :: SMCMAX REAL, INTENT(OUT) :: FLIMIT @@ -2025,7 +2025,7 @@ SUBROUTINE NOPAC (ETP,ETA,PRCP,SMC,SMCMAX,SMCWLT, & EFDIR = EFDIR * wetty(1) !TWG2015 Bugfix Flip Sign to conform to Net upward Flux EDIR1 = EDIR1 + EFDIR ! new value - + EFC = (EC1/EALL_now)*XSDA_QFX*1.0E-03*XQNORM !TWG2015 Bugfix Flip Sign to conform to Net upward Flux EC1 = EC1 + EFC ! new value @@ -2264,11 +2264,11 @@ SUBROUTINE PENMAN (SFCTMP,SFCPRS,CH,T2V,TH2,PRCP,FDOWN,T24,SSOIL, & FLX4 = 0.0 IF(UA_PHYS) THEN IF(SNEQV > 0. .AND. FNET > 0. .AND. SOLDN > 0. ) THEN - TOTABS = (1.-ALBEDO)*SOLDN*FVB ! solar radiation absorbed + TOTABS = (1.-ALBEDO)*SOLDN*FVB ! solar radiation absorbed ! by vegetated fraction UCABS = MIN(TOTABS,((1.0-ALGDSN)*(1.0-ALVGSN)*SOLDN*GAMA)*FVB) ! print*,'penman',UCABS,TOTABS,SOLDN,GAMA,FVB -! UCABS = MIN(TOTABS,(0.44*SOLDN*GAMA)*FVB) +! UCABS = MIN(TOTABS,(0.44*SOLDN*GAMA)*FVB) ! UCABS -> solar radiation ! absorbed under canopy FLX4 = MIN(TOTABS - UCABS, MIN(250., 0.5*(1.-ALBEDO)*SOLDN)) @@ -2431,11 +2431,11 @@ SUBROUTINE REDPRM (VEGTYP,SOILTYP,SLOPETYP,CFACTR,CMCMAX,RSMAX, & REAL :: FRZFACT,FRZK,REFDK character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg - + CHARACTER*256 :: err_message errmsg = '' errflg = 0 - + ! SAVE ! ---------------------------------------------------------------------- ! @@ -2656,14 +2656,14 @@ SUBROUTINE SHFLX (SSOIL,STC,SMC,SMCMAX,NSOIL,T1,DT,YY,ZZ1,ZSOIL, & ! ---------------------------------------------------------------------- ! HRT ROUTINE CALCS THE RIGHT HAND SIDE OF THE SOIL TEMP DIF EQN ! ---------------------------------------------------------------------- - + IF (TIME_AVERAGE_T_UPDATE) THEN OLDT1 = T1 DO I = 1, NSOIL OLDSTC(I) = STC(I) ENDDO ENDIF - + ! Land case CALL HRT (RHSTS,STC,SMC,SMCMAX,NSOIL,ZSOIL,YY,ZZ1,TBOT, & @@ -2688,15 +2688,15 @@ SUBROUTINE SHFLX (SSOIL,STC,SMC,SMCMAX,NSOIL,T1,DT,YY,ZZ1,ZSOIL, & ! CALCULATE SURFACE SOIL HEAT FLUX ! ---------------------------------------------------------------------- T1 = (YY + (ZZ1- 1.0) * STC (1)) / ZZ1 - - !GJF: Following the GFS version of Noah, time average the updating of skin temperature and soil temperature + + !GJF: Following the GFS version of Noah, time average the updating of skin temperature and soil temperature IF (TIME_AVERAGE_T_UPDATE) THEN T1 = CTFIL1*T1 + CTFIL2*OLDT1 DO I = 1, NSOIL STC(I) = CTFIL1*STC(I) + CTFIL2*OLDSTC(I) ENDDO ENDIF - + SSOIL = DF1 * (STC (1) - T1) / (0.5 * ZSOIL (1)) ! ---------------------------------------------------------------------- @@ -2907,7 +2907,7 @@ SUBROUTINE SNFRAC (SNEQV,SNUP,SALP,SNOWH,SNCOVR, & END IF !------------------------------------------------------------------ ! FBUR: VERTICAL FRACTION OF VEGETATION COVERED BY SNOW -! GRASS, CROP, AND SHRUB: MULTIPLY 0.4 BY ZTOPV AND ZBOTV BECAUSE +! GRASS, CROP, AND SHRUB: MULTIPLY 0.4 BY ZTOPV AND ZBOTV BECAUSE ! THEY WILL BE PRESSED DOWN BY THE SNOW. ! FOREST: DON'T NEED TO CHANGE ZTOPV AND ZBOTV. @@ -3620,10 +3620,10 @@ SUBROUTINE SNOWZ0 (SNCOVR,Z0, Z0BRD, SNOWH,FBUR,FGSN,SHDMAX,UA_PHYS) BURIAL = 7.0*Z0BRD - SNOWH IF(BURIAL.LE.0.0007) THEN Z0EFF = Z0S - ELSE + ELSE Z0EFF = BURIAL/7.0 ENDIF - + Z0 = (1.- SNCOVR)* Z0BRD + SNCOVR * Z0EFF ENDIF @@ -3853,7 +3853,7 @@ SUBROUTINE SRT (RHSTT,EDIR,ET,SH2O,SH2OA,NSOIL,PCPDRP, & INFMAX = MAX (INFMAX,WCND) INFMAX = MIN (INFMAX,PX/DT) -#ifdef WRF_HYDRO +#ifdef WRF_HYDRO !DJG NDHMS/WRF-Hydro edit... !DJG IF (PCPDRP > INFMAX) THEN IF (SFCWATR > INFMAX) THEN @@ -4167,12 +4167,12 @@ SUBROUTINE TDFCND ( DF, SMC, QZ, SMCMAX, SH2O, BEXP, PSISAT, SOILTYP, OPT_THCND) ! June 2001 CHANGES: FROZEN SOIL CONDITION. ! ---------------------------------------------------------------------- IMPLICIT NONE - INTEGER, INTENT(IN) :: SOILTYP, OPT_THCND + INTEGER, INTENT(IN) :: SOILTYP, OPT_THCND REAL, INTENT(IN) :: QZ, SMC, SMCMAX, SH2O, BEXP, PSISAT REAL, INTENT(OUT) :: DF REAL :: AKE, GAMMD, THKDRY, THKICE, THKO, & THKQTZ,THKSAT,THKS,THKW,SATRATIO,XU, & - XUNFROZ,AKEI,AKEL,PSIF,PF + XUNFROZ,AKEI,AKEL,PSIF,PF ! ---------------------------------------------------------------------- ! WE NOW GET QUARTZ AS AN INPUT ARGUMENT (SET IN ROUTINE REDPRM): @@ -4276,7 +4276,7 @@ SUBROUTINE TDFCND ( DF, SMC, QZ, SMCMAX, SH2O, BEXP, PSISAT, SOILTYP, OPT_THCND) DF=.1744 END IF - ENDIF ! for OPT_THCND OPTIONS + ENDIF ! for OPT_THCND OPTIONS ! ---------------------------------------------------------------------- END SUBROUTINE TDFCND ! ---------------------------------------------------------------------- diff --git a/physics/module_sf_noahlsm_glacial_only.F90 b/physics/module_sf_noahlsm_glacial_only.F90 index 602b21e3b..a489cd13e 100644 --- a/physics/module_sf_noahlsm_glacial_only.F90 +++ b/physics/module_sf_noahlsm_glacial_only.F90 @@ -41,9 +41,9 @@ SUBROUTINE SFLX_GLACIAL (IILOC,JJLOC,ISICE,FFROZP,DT,ZLVL,NSOIL,SLDPTH, & & RIBB,errflg, errmsg) ! ---------------------------------------------------------------------- ! SUB-DRIVER FOR "Noah LSM" FAMILY OF PHYSICS SUBROUTINES FOR A -! SOIL/VEG/SNOWPACK LAND-SURFACE MODEL TO UPDATE ICE TEMPERATURE, SKIN -! TEMPERATURE, SNOWPACK WATER CONTENT, SNOWDEPTH, AND ALL TERMS OF THE -! SURFACE ENERGY BALANCE (EXCLUDING INPUT ATMOSPHERIC FORCINGS OF +! SOIL/VEG/SNOWPACK LAND-SURFACE MODEL TO UPDATE ICE TEMPERATURE, SKIN +! TEMPERATURE, SNOWPACK WATER CONTENT, SNOWDEPTH, AND ALL TERMS OF THE +! SURFACE ENERGY BALANCE (EXCLUDING INPUT ATMOSPHERIC FORCINGS OF ! DOWNWARD RADIATION AND PRECIP) ! ---------------------------------------------------------------------- ! SFLX ARGUMENT LIST KEY: @@ -196,10 +196,10 @@ SUBROUTINE SFLX_GLACIAL (IILOC,JJLOC,ISICE,FFROZP,DT,ZLVL,NSOIL,SLDPTH, & REAL, PARAMETER :: LVH2O = 2.501E+6 REAL, PARAMETER :: LSUBS = 2.83E+6 REAL, PARAMETER :: R = 287.04 - + errmsg = '' errflg = 0 - + ! ---------------------------------------------------------------------- iloc = iiloc jloc = jjloc @@ -210,7 +210,7 @@ SUBROUTINE SFLX_GLACIAL (IILOC,JJLOC,ISICE,FFROZP,DT,ZLVL,NSOIL,SLDPTH, & END DO ! ---------------------------------------------------------------------- -! IF S.W.E. (SNEQV) BELOW THRESHOLD LOWER BOUND (0.10 M FOR GLACIAL +! IF S.W.E. (SNEQV) BELOW THRESHOLD LOWER BOUND (0.10 M FOR GLACIAL ! ICE), THEN SET AT LOWER BOUND ! ---------------------------------------------------------------------- IF ( SNEQV < 0.10 ) THEN @@ -270,7 +270,7 @@ SUBROUTINE SFLX_GLACIAL (IILOC,JJLOC,ISICE,FFROZP,DT,ZLVL,NSOIL,SLDPTH, & ! ---------------------------------------------------------------------- ! kmh 09/04/2006 set Snow Density at 0.2 g/cm**3 ! for "cold permanent ice" or new "dry" snow -! if soil temperature less than 268.15 K, treat as typical +! if soil temperature less than 268.15 K, treat as typical ! Antarctic/Greenland snow firn ! ---------------------------------------------------------------------- IF ( SNCOVR .GT. 0.99 ) THEN @@ -293,17 +293,17 @@ SUBROUTINE SFLX_GLACIAL (IILOC,JJLOC,ISICE,FFROZP,DT,ZLVL,NSOIL,SLDPTH, & ! KWM: Set SNCOVR to 1.0 because SNUP is set small in VEGPARM.TBL, ! and SNEQV is at least 0.1 (as set above) ! ---------------------------------------------------------------------- - SNCOVR = 1.0 + SNCOVR = 1.0 ! ---------------------------------------------------------------------- ! DETERMINE SURFACE ALBEDO MODIFICATION DUE TO SNOWDEPTH STATE. ! ---------------------------------------------------------------------- CALL ALCALC (ALB,SNOALB,EMBRD,T1,ALBEDO,EMISSI, & - & DT,SNOWNG,SNOTIME1) + & DT,SNOWNG,SNOTIME1) ! ---------------------------------------------------------------------- -! THERMAL CONDUCTIVITY +! THERMAL CONDUCTIVITY ! ---------------------------------------------------------------------- DF1 = SNCOND @@ -402,7 +402,7 @@ SUBROUTINE SFLX_GLACIAL (IILOC,JJLOC,ISICE,FFROZP,DT,ZLVL,NSOIL,SLDPTH, & SSOIL = -1.0* SSOIL ! ---------------------------------------------------------------------- -! FOR THE CASE OF GLACIAL-ICE, ADD ANY SNOWMELT DIRECTLY TO SURFACE +! FOR THE CASE OF GLACIAL-ICE, ADD ANY SNOWMELT DIRECTLY TO SURFACE ! RUNOFF (RUNOFF1) SINCE THERE IS NO SOIL MEDIUM ! ---------------------------------------------------------------------- RUNOFF1 = SNOMLT / DT @@ -891,7 +891,7 @@ SUBROUTINE SNOPAC (ETP,ETA,PRCP,PRCPF,SNOWNG,NSOIL,DT,DF1, & & SNOEXP = 2.0 ! ---------------------------------------------------------------------- -! FOR GLACIAL-ICE, SNOWCOVER FRACTION = 1.0, AND SUBLIMATION IS AT THE +! FOR GLACIAL-ICE, SNOWCOVER FRACTION = 1.0, AND SUBLIMATION IS AT THE ! POTENTIAL RATE. ! ---------------------------------------------------------------------- ! INITIALIZE EVAP TERMS. @@ -1052,7 +1052,7 @@ SUBROUTINE SNOPAC (ETP,ETA,PRCP,PRCPF,SNOWNG,NSOIL,DT,DF1, & ! SPECIAL VALUES THAT ENSURE THAT GROUND HEAT FLUX CALCULATED IN SHFLX ! MATCHES THAT ALREADY COMPUTED FOR BELOW THE SNOWPACK, THUS THE SFC ! HEAT FLUX TO BE COMPUTED IN SHFLX WILL EFFECTIVELY BE THE FLUX AT THE -! SNOW TOP SURFACE. +! SNOW TOP SURFACE. ! ---------------------------------------------------------------------- ZZ1 = 1.0 YY = STC (1) -0.5* SSOIL * ZSOIL (1)* ZZ1/ DF1 @@ -1221,7 +1221,7 @@ SUBROUTINE SNOWZ0 (Z0, Z0BRD, SNOWH) BURIAL = 7.0*Z0BRD - SNOWH IF(BURIAL.LE.0.0007) THEN Z0EFF = Z0S - ELSE + ELSE Z0EFF = BURIAL/7.0 ENDIF diff --git a/physics/radiation_clouds.f b/physics/radiation_clouds.f index 65f483821..b04c3ff7a 100644 --- a/physics/radiation_clouds.f +++ b/physics/radiation_clouds.f @@ -184,7 +184,7 @@ !! !! Sub-grid cloud approximation (namelist control parameter - \b ISUBC_LW=2, \b ISUBC_SW=2) !!\n ISUBC=0: grid averaged quantities, without sub-grid cloud approximation -!!\n ISUBC=1: with McICA sub-grid approximation (use prescribed permutation seeds) +!!\n ISUBC=1: with McICA sub-grid approximation (use prescribed permutation seeds) !!\n ISUBC=2: with McICA sub-grid approximation (use random permutation seeds) !! !!\version NCEP-Radiation_clouds v5.1 Nov 2012 @@ -192,7 +192,7 @@ !! @} !> This module computes cloud related quantities for radiation computations. - module module_radiation_clouds + module module_radiation_clouds ! use physparam, only : icldflg, iovrsw, iovrlw, & & lcrick, lcnorm, lnoprec, & @@ -626,7 +626,7 @@ subroutine progcld1 & enddo endif -!> - Compute SFC/low/middle/high cloud top pressure for each cloud +!> - Compute SFC/low/middle/high cloud top pressure for each cloud !! domain for given latitude. ! ptopc(k,i): top presure of each cld domain (k=1-4 are sfc,L,m,h; ! --- i=1,2 are low-lat (<45 degree) and pole regions) @@ -755,14 +755,14 @@ subroutine progcld1 & enddo endif -!> - Compute effective ice cloud droplet radius following Heymsfield +!> - Compute effective ice cloud droplet radius following Heymsfield !! and McFarquhar (1996) \cite heymsfield_and_mcfarquhar_1996. if(.not.effr_in) then do k = 1, NLAY do i = 1, IX tem2 = tlyr(i,k) - con_ttp - + if (cip(i,k) > 0.0) then tem3 = gord * cip(i,k) * plyr(i,k) / (delp(i,k)*tvly(i,k)) @@ -810,8 +810,8 @@ subroutine progcld1 & !> - Call gethml() to compute low,mid,high,total, and boundary layer !! cloud fractions and clouds top/bottom layer indices for low, mid, -!! and high clouds. The three cloud domain boundaries are defined by -!! ptopc. The cloud overlapping method is defined by control flag +!! and high clouds. The three cloud domain boundaries are defined by +!! ptopc. The cloud overlapping method is defined by control flag !! 'iovr', which may be different for lw and sw radiation programs. call gethml & ! --- inputs: @@ -852,7 +852,7 @@ end subroutine progcld1 !!\param delp (IX,NLAY), model layer pressure thickness in mb (100Pa) !!\param IX horizontal dimention !!\param NLAY,NLP1 vertical layer/level dimensions -!!\param lmfshal flag for mass-flux shallow convection scheme in the cloud fraction calculation +!!\param lmfshal flag for mass-flux shallow convection scheme in the cloud fraction calculation !!\param lmfdeep2 flag for mass-flux deep convection scheme in the cloud fraction calculation !!\param clouds (IX,NLAY,NF_CLDS), cloud profiles !!\n (:,:,1) - layer total cloud fraction @@ -872,10 +872,10 @@ end subroutine progcld1 !> @{ subroutine progcld2 & & ( plyr,plvl,tlyr,qlyr,qstl,rhly,tvly,clw, & ! --- inputs: - & xlat,xlon,slmsk,dz,delp, & + & xlat,xlon,slmsk,dz,delp, & & ntrac, ntcw, ntiw, ntrw, & & IX, NLAY, NLP1, & - & lmfshal, lmfdeep2, & + & lmfshal, lmfdeep2, & & clouds,clds,mtop,mbot,de_lgth & ! --- outputs: & ) @@ -1055,7 +1055,7 @@ subroutine progcld2 & enddo !> - Compute cloud ice effective radii - + do k = 1, NLAY do i = 1, IX tem2 = tlyr(i,k) - con_ttp @@ -1164,7 +1164,7 @@ subroutine progcld2 & clouds(i,k,3) = rew(i,k) clouds(i,k,4) = cip(i,k) clouds(i,k,5) = rei(i,k) - clouds(i,k,6) = crp(i,k) ! added for Thompson + clouds(i,k,6) = crp(i,k) ! added for Thompson clouds(i,k,7) = rer(i,k) clouds(i,k,8) = csp(i,k) ! added for Thompson clouds(i,k,9) = res(i,k) @@ -1230,7 +1230,7 @@ end subroutine progcld2 !!\param nlay,nlp1 vertical layer/level dimensions !!\param deltaq (ix,nlay), half total water distribution width !!\param sup supersaturation -!!\param kdt +!!\param kdt !!\param me print control flag !!\param clouds (ix,nlay,nf_clds), cloud profiles !!\n (:,:,1) - layer total cloud fraction @@ -1608,7 +1608,7 @@ end subroutine progcld3 !----------------------------------- !> \ingroup module_radiation_clouds -!> This subroutine computes cloud related quantities using +!> This subroutine computes cloud related quantities using !! GFDL Lin MP prognostic cloud microphysics scheme. !!\param plyr (ix,nlay), model layer mean pressure in mb (100Pa) !!\param plvl (ix,nlp1), model level pressure in mb (100Pa) @@ -1631,7 +1631,7 @@ end subroutine progcld3 !!\param nlay vertical layer dimension !!\param nlp1 vertical level dimension !!\param clouds (ix,nlay,nf_clds), cloud profiles -!!\n clouds(:,:,1) - layer total cloud fraction +!!\n clouds(:,:,1) - layer total cloud fraction !!\n clouds(:,:,2) - layer cloud liquid water path (\f$g m^{-2}\f$) !!\n clouds(:,:,3) - mean effective radius for liquid cloud (micron) !!\n clouds(:,:,4) - layer cloud ice water path (\f$g m^{-2}\f$) @@ -1646,10 +1646,10 @@ end subroutine progcld3 !!\param de_lgth clouds decorrelation length (km) !>\section gen_progcld4 progcld4 General Algorithm !! @{ - subroutine progcld4 & + subroutine progcld4 & & ( plyr,plvl,tlyr,tvly,qlyr,qstl,rhly,clw,cnvw,cnvc, & ! --- inputs: & xlat,xlon,slmsk,cldtot, dz, delp, & - & IX, NLAY, NLP1, & + & IX, NLAY, NLP1, & & clouds,clds,mtop,mbot,de_lgth & ! --- outputs: & ) @@ -1981,9 +1981,9 @@ end subroutine progcld4 !!\n clouds(:,:,8) - layer snow flake water path (\f$g m^{-2}\f$) !!\n clouds(:,:,9) - mean effective radius for snow flake (micron) !>\param clds (ix,5), fraction of clouds for low, mid, hi, tot, bl -!>\param mtop (ix,3), vertical indices for low, mid, hi cloud tops +!>\param mtop (ix,3), vertical indices for low, mid, hi cloud tops !>\param mbot (ix,3), vertical indices for low, mid, hi cloud bases -!>\param de_lgth clouds decorrelation length (km) +!>\param de_lgth clouds decorrelation length (km) !>\section gen_progcld4o progcld4o General Algorithm !! @{ subroutine progcld4o & @@ -2230,7 +2230,7 @@ subroutine progcld4o & clouds(i,k,3) = rew(i,k) clouds(i,k,4) = cip(i,k) clouds(i,k,5) = rei(i,k) - clouds(i,k,6) = crp(i,k) + clouds(i,k,6) = crp(i,k) clouds(i,k,7) = rer(i,k) clouds(i,k,8) = csp(i,k) clouds(i,k,9) = rei(i,k) @@ -2364,7 +2364,7 @@ subroutine progcld5 & ! --- inputs integer, intent(in) :: IX, NLAY, NLP1, ICLOUD - integer, intent(in) :: ntrac, ntcw, ntiw, ntrw + integer, intent(in) :: ntrac, ntcw, ntiw, ntrw logical, intent(in) :: uni_cld, lmfshal, lmfdeep2 @@ -2424,9 +2424,9 @@ subroutine progcld5 & crp (i,k) = 0.0 csp (i,k) = 0.0 rew (i,k) = re_cloud(i,k) - rei (i,k) = re_ice(i,k) + rei (i,k) = re_ice(i,k) rer (i,k) = rrain_def ! default rain radius to 1000 micron - res (i,k) = re_snow(i,K) + res (i,k) = re_snow(i,K) ! tem2d (i,k) = min( 1.0, max( 0.0, (con_ttp-tlyr(i,k))*0.05 ) ) clwf(i,k) = 0.0 enddo @@ -2452,7 +2452,7 @@ subroutine progcld5 & do k = 1, NLAY do i = 1, IX - clwf(i,k) = clw(i,k,ntcw) + clw(i,k,ntiw) + clwf(i,k) = clw(i,k,ntcw) + clw(i,k,ntiw) enddo enddo !> - Find top pressure for each cloud domain for given latitude. @@ -2573,7 +2573,7 @@ subroutine progcld5 & enddo enddo endif -!mz +!mz if (icloud .ne. 0) then ! assign/calculate efective radii for cloud water, ice, rain, snow @@ -2595,7 +2595,7 @@ subroutine progcld5 & endif enddo -!> -# Compute effective ice cloud droplet radius following Heymsfield +!> -# Compute effective ice cloud droplet radius following Heymsfield !! and McFarquhar (1996) \cite heymsfield_and_mcfarquhar_1996. do k = 1, NLAY @@ -2617,13 +2617,13 @@ subroutine progcld5 & rei(i,k) = max(25.,rei(i,k)) !mz* HWRF endif rei(i,k) = min(rei(i,k), 135.72) !- 1.0315*rei<= 140 microns - enddo - enddo + enddo + enddo -!mz +!mz !> -# Compute effective snow cloud droplet radius - do k = 1, NLAY - do i = 1, IX + do k = 1, NLAY + do i = 1, IX res(i,k) = 10.0 enddo enddo @@ -2637,14 +2637,14 @@ subroutine progcld5 & clouds(i,k,3) = rew(i,k) clouds(i,k,4) = cip(i,k) clouds(i,k,5) = rei(i,k) - clouds(i,k,6) = crp(i,k) ! added for Thompson + clouds(i,k,6) = crp(i,k) ! added for Thompson clouds(i,k,7) = rer(i,k) !mz inflg .ne.5 - clouds(i,k,8) = 0. + clouds(i,k,8) = 0. clouds(i,k,9) = 10. !mz for diagnostics? re_cloud(i,k) = rew(i,k) - re_ice(i,k) = rei(i,k) + re_ice(i,k) = rei(i,k) re_snow(i,k) = 10. enddo @@ -2713,296 +2713,296 @@ subroutine progcld6 & ! subprograms called: gethml ! ! ! ! attributes: ! -! language: fortran 90 ! -! machine: ibm-sp, sgi ! -! ! -! ! -! ==================== definition of variables ==================== ! -! ! -! ! -! input variables: ! -! plyr (IX,NLAY) : model layer mean pressure in mb (100Pa) ! -! plvl (IX,NLP1) : model level pressure in mb (100Pa) ! -! tlyr (IX,NLAY) : model layer mean temperature in k ! -! tvly (IX,NLAY) : model layer virtual temperature in k ! -! qlyr (IX,NLAY) : layer specific humidity in gm/gm ! -! qstl (IX,NLAY) : layer saturate humidity in gm/gm ! -! rhly (IX,NLAY) : layer relative humidity (=qlyr/qstl) ! -! clw (IX,NLAY,ntrac) : layer cloud condensate amount ! -! xlat (IX) : grid latitude in radians, default to pi/2 -> -pi/2! -! range, otherwise see in-line comment ! -! xlon (IX) : grid longitude in radians (not used) ! -! slmsk (IX) : sea/land mask array (sea:0,land:1,sea-ice:2) ! -! dz (ix,nlay) : layer thickness (km) ! -! delp (ix,nlay) : model layer pressure thickness in mb (100Pa) ! -! IX : horizontal dimention ! -! NLAY,NLP1 : vertical layer/level dimensions ! -! uni_cld : logical - true for cloud fraction from shoc ! -! lmfshal : logical - true for mass flux shallow convection ! -! lmfdeep2 : logical - true for mass flux deep convection ! -! cldcov : layer cloud fraction (used when uni_cld=.true. ! -! ! -! output variables: ! -! clouds(IX,NLAY,NF_CLDS) : cloud profiles ! -! clouds(:,:,1) - layer total cloud fraction ! -! clouds(:,:,2) - layer cloud liq water path (g/m**2) ! -! clouds(:,:,3) - mean eff radius for liq cloud (micron) ! -! clouds(:,:,4) - layer cloud ice water path (g/m**2) ! -! clouds(:,:,5) - mean eff radius for ice cloud (micron) ! -! clouds(:,:,6) - layer rain drop water path not assigned ! -! clouds(:,:,7) - mean eff radius for rain drop (micron) ! -! *** clouds(:,:,8) - layer snow flake water path not assigned ! -! clouds(:,:,9) - mean eff radius for snow flake (micron) ! -! *** fu's scheme need to be normalized by snow density (g/m**3/1.0e6) ! -! clds (IX,5) : fraction of clouds for low, mid, hi, tot, bl ! -! mtop (IX,3) : vertical indices for low, mid, hi cloud tops ! -! mbot (IX,3) : vertical indices for low, mid, hi cloud bases ! -! de_lgth(ix) : clouds decorrelation length (km) ! -! ! -! module variables: ! -! ivflip : control flag of vertical index direction ! -! =0: index from toa to surface ! -! =1: index from surface to toa ! -! lmfshal : mass-flux shallow conv scheme flag ! -! lmfdeep2 : scale-aware mass-flux deep conv scheme flag ! -! lcrick : control flag for eliminating CRICK ! -! =t: apply layer smoothing to eliminate CRICK ! -! =f: do not apply layer smoothing ! -! lcnorm : control flag for in-cld condensate ! -! =t: normalize cloud condensate ! -! =f: not normalize cloud condensate ! -! ! -! ==================== end of description ===================== ! -! +! language: fortran 90 ! +! machine: ibm-sp, sgi ! +! ! +! ! +! ==================== definition of variables ==================== ! +! ! +! ! +! input variables: ! +! plyr (IX,NLAY) : model layer mean pressure in mb (100Pa) ! +! plvl (IX,NLP1) : model level pressure in mb (100Pa) ! +! tlyr (IX,NLAY) : model layer mean temperature in k ! +! tvly (IX,NLAY) : model layer virtual temperature in k ! +! qlyr (IX,NLAY) : layer specific humidity in gm/gm ! +! qstl (IX,NLAY) : layer saturate humidity in gm/gm ! +! rhly (IX,NLAY) : layer relative humidity (=qlyr/qstl) ! +! clw (IX,NLAY,ntrac) : layer cloud condensate amount ! +! xlat (IX) : grid latitude in radians, default to pi/2 -> -pi/2! +! range, otherwise see in-line comment ! +! xlon (IX) : grid longitude in radians (not used) ! +! slmsk (IX) : sea/land mask array (sea:0,land:1,sea-ice:2) ! +! dz (ix,nlay) : layer thickness (km) ! +! delp (ix,nlay) : model layer pressure thickness in mb (100Pa) ! +! IX : horizontal dimention ! +! NLAY,NLP1 : vertical layer/level dimensions ! +! uni_cld : logical - true for cloud fraction from shoc ! +! lmfshal : logical - true for mass flux shallow convection ! +! lmfdeep2 : logical - true for mass flux deep convection ! +! cldcov : layer cloud fraction (used when uni_cld=.true. ! +! ! +! output variables: ! +! clouds(IX,NLAY,NF_CLDS) : cloud profiles ! +! clouds(:,:,1) - layer total cloud fraction ! +! clouds(:,:,2) - layer cloud liq water path (g/m**2) ! +! clouds(:,:,3) - mean eff radius for liq cloud (micron) ! +! clouds(:,:,4) - layer cloud ice water path (g/m**2) ! +! clouds(:,:,5) - mean eff radius for ice cloud (micron) ! +! clouds(:,:,6) - layer rain drop water path not assigned ! +! clouds(:,:,7) - mean eff radius for rain drop (micron) ! +! *** clouds(:,:,8) - layer snow flake water path not assigned ! +! clouds(:,:,9) - mean eff radius for snow flake (micron) ! +! *** fu's scheme need to be normalized by snow density (g/m**3/1.0e6) ! +! clds (IX,5) : fraction of clouds for low, mid, hi, tot, bl ! +! mtop (IX,3) : vertical indices for low, mid, hi cloud tops ! +! mbot (IX,3) : vertical indices for low, mid, hi cloud bases ! +! de_lgth(ix) : clouds decorrelation length (km) ! +! ! +! module variables: ! +! ivflip : control flag of vertical index direction ! +! =0: index from toa to surface ! +! =1: index from surface to toa ! +! lmfshal : mass-flux shallow conv scheme flag ! +! lmfdeep2 : scale-aware mass-flux deep conv scheme flag ! +! lcrick : control flag for eliminating CRICK ! +! =t: apply layer smoothing to eliminate CRICK ! +! =f: do not apply layer smoothing ! +! lcnorm : control flag for in-cld condensate ! +! =t: normalize cloud condensate ! +! =f: not normalize cloud condensate ! +! ! +! ==================== end of description ===================== ! +! implicit none ! --- inputs integer, intent(in) :: IX, NLAY, NLP1 integer, intent(in) :: ntrac, ntcw, ntiw, ntrw, ntsw, ntgl - logical, intent(in) :: uni_cld, lmfshal, lmfdeep2 - - real (kind=kind_phys), dimension(:,:), intent(in) :: plvl, plyr, & - & tlyr, qlyr, qstl, rhly, cldcov, delp, dz, & - & re_cloud, re_ice, re_snow - - real (kind=kind_phys), dimension(:,:,:), intent(in) :: clw - - real (kind=kind_phys), dimension(:), intent(in) :: xlat, xlon, & - & slmsk - -! --- outputs - real (kind=kind_phys), dimension(:,:,:), intent(out) :: clouds - - real (kind=kind_phys), dimension(:,:), intent(out) :: clds - real (kind=kind_phys), dimension(:), intent(out) :: de_lgth - - integer, dimension(:,:), intent(out) :: mtop,mbot - -! --- local variables: - real (kind=kind_phys), dimension(IX,NLAY) :: cldtot, cldcnv, & - & cwp, cip, crp, csp, rew, rei, res, rer, tem2d, clwf - - real (kind=kind_phys) :: ptop1(IX,NK_CLDS+1), rxlat(ix) + logical, intent(in) :: uni_cld, lmfshal, lmfdeep2 + + real (kind=kind_phys), dimension(:,:), intent(in) :: plvl, plyr, & + & tlyr, qlyr, qstl, rhly, cldcov, delp, dz, & + & re_cloud, re_ice, re_snow + + real (kind=kind_phys), dimension(:,:,:), intent(in) :: clw + + real (kind=kind_phys), dimension(:), intent(in) :: xlat, xlon, & + & slmsk + +! --- outputs + real (kind=kind_phys), dimension(:,:,:), intent(out) :: clouds + + real (kind=kind_phys), dimension(:,:), intent(out) :: clds + real (kind=kind_phys), dimension(:), intent(out) :: de_lgth + + integer, dimension(:,:), intent(out) :: mtop,mbot + +! --- local variables: + real (kind=kind_phys), dimension(IX,NLAY) :: cldtot, cldcnv, & + & cwp, cip, crp, csp, rew, rei, res, rer, tem2d, clwf + + real (kind=kind_phys) :: ptop1(IX,NK_CLDS+1), rxlat(ix) real (kind=kind_phys) :: clwmin, clwm, clwt, onemrh, value, & & tem1, tem2, tem3 integer :: i, k, id, nf - -! --- constant values -! real (kind=kind_phys), parameter :: xrc3 = 200. - real (kind=kind_phys), parameter :: xrc3 = 100. - -! -!===> ... begin here - -! - do nf=1,nf_clds - do k=1,nlay - do i=1,ix - clouds(i,k,nf) = 0.0 - enddo - enddo - enddo -! clouds(:,:,:) = 0.0 - - do k = 1, NLAY - do i = 1, IX - cldtot(i,k) = 0.0 - cldcnv(i,k) = 0.0 - cwp (i,k) = 0.0 - cip (i,k) = 0.0 - crp (i,k) = 0.0 - csp (i,k) = 0.0 - rew (i,k) = re_cloud(i,k) - rei (i,k) = re_ice(i,k) - rer (i,k) = rrain_def ! default rain radius to 1000 micron - res (i,k) = re_snow(i,K) -! tem2d (i,k) = min( 1.0, max( 0.0, (con_ttp-tlyr(i,k))*0.05 ) ) - clwf(i,k) = 0.0 - enddo - enddo -! -! -! if ( lcrick ) then -! do i = 1, IX -! clwf(i,1) = 0.75*clw(i,1) + 0.25*clw(i,2) -! clwf(i,nlay) = 0.75*clw(i,nlay) + 0.25*clw(i,nlay-1) -! enddo -! do k = 2, NLAY-1 -! do i = 1, IX -! clwf(i,K) = 0.25*clw(i,k-1) + 0.5*clw(i,k) + 0.25*clw(i,k+1) -! enddo -! enddo -! else -! do k = 1, NLAY -! do i = 1, IX -! clwf(i,k) = clw(i,k) -! enddo -! enddo -! endif - - do k = 1, NLAY - do i = 1, IX - clwf(i,k) = clw(i,k,ntcw) + clw(i,k,ntiw) + clw(i,k,ntsw) - enddo - enddo -!> - Find top pressure for each cloud domain for given latitude. -!! ptopc(k,i): top presure of each cld domain (k=1-4 are sfc,L,m,h; -!! i=1,2 are low-lat (<45 degree) and pole regions) - - do i =1, IX - rxlat(i) = abs( xlat(i) / con_pi ) ! if xlat in pi/2 -> -pi/2 range -! rxlat(i) = abs(0.5 - xlat(i)/con_pi) ! if xlat in 0 -> pi range - enddo - - do id = 1, 4 - tem1 = ptopc(id,2) - ptopc(id,1) - - do i =1, IX - ptop1(i,id) = ptopc(id,1) + tem1*max( 0.0, 4.0*rxlat(i)-1.0 ) - enddo - enddo - -!> - Compute cloud liquid/ice condensate path in \f$ g/m^2 \f$ . - - do k = 1, NLAY - do i = 1, IX - cwp(i,k) = max(0.0, clw(i,k,ntcw) * gfac * delp(i,k)) - cip(i,k) = max(0.0, clw(i,k,ntiw) * gfac * delp(i,k)) - crp(i,k) = max(0.0, clw(i,k,ntrw) * gfac * delp(i,k)) - csp(i,k) = max(0.0, (clw(i,k,ntsw)+clw(i,k,ntgl)) * & - & gfac * delp(i,k)) - enddo - enddo - - if (uni_cld) then ! use unified sgs clouds generated outside - do k = 1, NLAY - do i = 1, IX - cldtot(i,k) = cldcov(i,k) - enddo - enddo - - else - + +! --- constant values +! real (kind=kind_phys), parameter :: xrc3 = 200. + real (kind=kind_phys), parameter :: xrc3 = 100. + +! +!===> ... begin here + +! + do nf=1,nf_clds + do k=1,nlay + do i=1,ix + clouds(i,k,nf) = 0.0 + enddo + enddo + enddo +! clouds(:,:,:) = 0.0 + + do k = 1, NLAY + do i = 1, IX + cldtot(i,k) = 0.0 + cldcnv(i,k) = 0.0 + cwp (i,k) = 0.0 + cip (i,k) = 0.0 + crp (i,k) = 0.0 + csp (i,k) = 0.0 + rew (i,k) = re_cloud(i,k) + rei (i,k) = re_ice(i,k) + rer (i,k) = rrain_def ! default rain radius to 1000 micron + res (i,k) = re_snow(i,K) +! tem2d (i,k) = min( 1.0, max( 0.0, (con_ttp-tlyr(i,k))*0.05 ) ) + clwf(i,k) = 0.0 + enddo + enddo +! +! +! if ( lcrick ) then +! do i = 1, IX +! clwf(i,1) = 0.75*clw(i,1) + 0.25*clw(i,2) +! clwf(i,nlay) = 0.75*clw(i,nlay) + 0.25*clw(i,nlay-1) +! enddo +! do k = 2, NLAY-1 +! do i = 1, IX +! clwf(i,K) = 0.25*clw(i,k-1) + 0.5*clw(i,k) + 0.25*clw(i,k+1) +! enddo +! enddo +! else +! do k = 1, NLAY +! do i = 1, IX +! clwf(i,k) = clw(i,k) +! enddo +! enddo +! endif + + do k = 1, NLAY + do i = 1, IX + clwf(i,k) = clw(i,k,ntcw) + clw(i,k,ntiw) + clw(i,k,ntsw) + enddo + enddo +!> - Find top pressure for each cloud domain for given latitude. +!! ptopc(k,i): top presure of each cld domain (k=1-4 are sfc,L,m,h; +!! i=1,2 are low-lat (<45 degree) and pole regions) + + do i =1, IX + rxlat(i) = abs( xlat(i) / con_pi ) ! if xlat in pi/2 -> -pi/2 range +! rxlat(i) = abs(0.5 - xlat(i)/con_pi) ! if xlat in 0 -> pi range + enddo + + do id = 1, 4 + tem1 = ptopc(id,2) - ptopc(id,1) + + do i =1, IX + ptop1(i,id) = ptopc(id,1) + tem1*max( 0.0, 4.0*rxlat(i)-1.0 ) + enddo + enddo + +!> - Compute cloud liquid/ice condensate path in \f$ g/m^2 \f$ . + + do k = 1, NLAY + do i = 1, IX + cwp(i,k) = max(0.0, clw(i,k,ntcw) * gfac * delp(i,k)) + cip(i,k) = max(0.0, clw(i,k,ntiw) * gfac * delp(i,k)) + crp(i,k) = max(0.0, clw(i,k,ntrw) * gfac * delp(i,k)) + csp(i,k) = max(0.0, (clw(i,k,ntsw)+clw(i,k,ntgl)) * & + & gfac * delp(i,k)) + enddo + enddo + + if (uni_cld) then ! use unified sgs clouds generated outside + do k = 1, NLAY + do i = 1, IX + cldtot(i,k) = cldcov(i,k) + enddo + enddo + + else + !> - Calculate layer cloud fraction. - clwmin = 0.0 - if (.not. lmfshal) then - do k = 1, NLAY - do i = 1, IX - clwt = 1.0e-6 * (plyr(i,k)*0.001) -! clwt = 2.0e-6 * (plyr(i,k)*0.001) - - if (clwf(i,k) > clwt) then - - onemrh= max( 1.e-10, 1.0-rhly(i,k) ) - clwm = clwmin / max( 0.01, plyr(i,k)*0.001 ) - - tem1 = min(max(sqrt(sqrt(onemrh*qstl(i,k))),0.0001),1.0) - tem1 = 2000.0 / tem1 - -! tem1 = 1000.0 / tem1 - - value = max( min( tem1*(clwf(i,k)-clwm), 50.0 ), 0.0 ) - tem2 = sqrt( sqrt(rhly(i,k)) ) - - cldtot(i,k) = max( tem2*(1.0-exp(-value)), 0.0 ) - endif - enddo - enddo - else - do k = 1, NLAY - do i = 1, IX - clwt = 1.0e-6 * (plyr(i,k)*0.001) -! clwt = 2.0e-6 * (plyr(i,k)*0.001) - - if (clwf(i,k) > clwt) then - onemrh= max( 1.e-10, 1.0-rhly(i,k) ) - clwm = clwmin / max( 0.01, plyr(i,k)*0.001 ) -! - tem1 = min(max((onemrh*qstl(i,k))**0.49,0.0001),1.0) !jhan - if (lmfdeep2) then - tem1 = xrc3 / tem1 - else - tem1 = 100.0 / tem1 - endif -! - value = max( min( tem1*(clwf(i,k)-clwm), 50.0 ), 0.0 ) - tem2 = sqrt( sqrt(rhly(i,k)) ) - - cldtot(i,k) = max( tem2*(1.0-exp(-value)), 0.0 ) - endif - enddo - enddo - endif - - endif ! if (uni_cld) then - - do k = 1, NLAY - do i = 1, IX - if (cldtot(i,k) < climit) then - cldtot(i,k) = 0.0 - cwp(i,k) = 0.0 - cip(i,k) = 0.0 - crp(i,k) = 0.0 - csp(i,k) = 0.0 - endif - enddo - enddo - - if ( lcnorm ) then - do k = 1, NLAY - do i = 1, IX - if (cldtot(i,k) >= climit) then - tem1 = 1.0 / max(climit2, cldtot(i,k)) - cwp(i,k) = cwp(i,k) * tem1 - cip(i,k) = cip(i,k) * tem1 - crp(i,k) = crp(i,k) * tem1 - csp(i,k) = csp(i,k) * tem1 - endif - enddo - enddo - endif - -! - do k = 1, NLAY - do i = 1, IX - clouds(i,k,1) = cldtot(i,k) - clouds(i,k,2) = cwp(i,k) - clouds(i,k,3) = rew(i,k) - clouds(i,k,4) = cip(i,k) - clouds(i,k,5) = rei(i,k) - clouds(i,k,6) = crp(i,k) ! added for Thompson - clouds(i,k,7) = rer(i,k) - clouds(i,k,8) = csp(i,k) ! added for Thompson - clouds(i,k,9) = res(i,k) - enddo - enddo - -! --- ... estimate clouds decorrelation length in km -! this is only a tentative test, need to consider change later + clwmin = 0.0 + if (.not. lmfshal) then + do k = 1, NLAY + do i = 1, IX + clwt = 1.0e-6 * (plyr(i,k)*0.001) +! clwt = 2.0e-6 * (plyr(i,k)*0.001) + + if (clwf(i,k) > clwt) then + + onemrh= max( 1.e-10, 1.0-rhly(i,k) ) + clwm = clwmin / max( 0.01, plyr(i,k)*0.001 ) + + tem1 = min(max(sqrt(sqrt(onemrh*qstl(i,k))),0.0001),1.0) + tem1 = 2000.0 / tem1 + +! tem1 = 1000.0 / tem1 + + value = max( min( tem1*(clwf(i,k)-clwm), 50.0 ), 0.0 ) + tem2 = sqrt( sqrt(rhly(i,k)) ) + + cldtot(i,k) = max( tem2*(1.0-exp(-value)), 0.0 ) + endif + enddo + enddo + else + do k = 1, NLAY + do i = 1, IX + clwt = 1.0e-6 * (plyr(i,k)*0.001) +! clwt = 2.0e-6 * (plyr(i,k)*0.001) + + if (clwf(i,k) > clwt) then + onemrh= max( 1.e-10, 1.0-rhly(i,k) ) + clwm = clwmin / max( 0.01, plyr(i,k)*0.001 ) +! + tem1 = min(max((onemrh*qstl(i,k))**0.49,0.0001),1.0) !jhan + if (lmfdeep2) then + tem1 = xrc3 / tem1 + else + tem1 = 100.0 / tem1 + endif +! + value = max( min( tem1*(clwf(i,k)-clwm), 50.0 ), 0.0 ) + tem2 = sqrt( sqrt(rhly(i,k)) ) + + cldtot(i,k) = max( tem2*(1.0-exp(-value)), 0.0 ) + endif + enddo + enddo + endif + + endif ! if (uni_cld) then + + do k = 1, NLAY + do i = 1, IX + if (cldtot(i,k) < climit) then + cldtot(i,k) = 0.0 + cwp(i,k) = 0.0 + cip(i,k) = 0.0 + crp(i,k) = 0.0 + csp(i,k) = 0.0 + endif + enddo + enddo + + if ( lcnorm ) then + do k = 1, NLAY + do i = 1, IX + if (cldtot(i,k) >= climit) then + tem1 = 1.0 / max(climit2, cldtot(i,k)) + cwp(i,k) = cwp(i,k) * tem1 + cip(i,k) = cip(i,k) * tem1 + crp(i,k) = crp(i,k) * tem1 + csp(i,k) = csp(i,k) * tem1 + endif + enddo + enddo + endif + +! + do k = 1, NLAY + do i = 1, IX + clouds(i,k,1) = cldtot(i,k) + clouds(i,k,2) = cwp(i,k) + clouds(i,k,3) = rew(i,k) + clouds(i,k,4) = cip(i,k) + clouds(i,k,5) = rei(i,k) + clouds(i,k,6) = crp(i,k) ! added for Thompson + clouds(i,k,7) = rer(i,k) + clouds(i,k,8) = csp(i,k) ! added for Thompson + clouds(i,k,9) = res(i,k) + enddo + enddo + +! --- ... estimate clouds decorrelation length in km +! this is only a tentative test, need to consider change later if ( iovr == 3 ) then do i = 1, ix @@ -3029,7 +3029,7 @@ subroutine progcld6 & ! - return + return !............................................ end subroutine progcld6 @@ -3066,9 +3066,9 @@ end subroutine progcld6 !!\n (:,:,3) - mean eff radius for liq cloud (micron) !!\n (:,:,4) - layer cloud ice water path \f$(g/m^2)\f$ !!\n (:,:,5) - mean eff radius for ice cloud (micron) -!!\n (:,:,6) - layer rain drop water path +!!\n (:,:,6) - layer rain drop water path !!\n (:,:,7) - mean eff radius for rain drop (micron) -!!\n (:,:,8) - layer snow flake water path +!!\n (:,:,8) - layer snow flake water path !!\n (:,:,9) - mean eff radius for snow flake (micron) !!\param clds (IX,5), fraction of clouds for low, mid, hi, tot, bl !!\param mtop (IX,3), vertical indices for low, mid, hi cloud tops @@ -3313,7 +3313,7 @@ subroutine progclduni & endif enddo -!> -# Compute effective ice cloud droplet radius following Heymsfield +!> -# Compute effective ice cloud droplet radius following Heymsfield !! and McFarquhar (1996) \cite heymsfield_and_mcfarquhar_1996. do k = 1, NLAY @@ -3859,17 +3859,17 @@ SUBROUTINE cal_cldfra3(CLDFRA, qv, qc, qi, qs, & !+---+ !..First cut scale-aware. Higher resolution should require closer to -!.. saturated grid box for higher cloud fraction. Simple functions -!.. chosen based on Mocko and Cotton (1995) starting point and desire -!.. to get near 100% RH as grid spacing moves toward 1.0km, but higher -!.. RH over ocean required as compared to over land. - - RH_00L = 0.7 + SQRT(1./(25.0+gridkm*gridkm*gridkm)) - RH_00O = 0.81 + SQRT(1./(50.0+gridkm*gridkm*gridkm)) +!.. saturated grid box for higher cloud fraction. Simple functions +!.. chosen based on Mocko and Cotton (1995) starting point and desire +!.. to get near 100% RH as grid spacing moves toward 1.0km, but higher +!.. RH over ocean required as compared to over land. + + RH_00L = 0.7 + SQRT(1./(25.0+gridkm*gridkm*gridkm)) + RH_00O = 0.81 + SQRT(1./(50.0+gridkm*gridkm*gridkm)) DO j = jts,jte DO k = kts,kte - DO i = its,ite + DO i = its,ite RHI_max = 0.0 CLDFRA(I,K,J) = 0.0 @@ -3942,11 +3942,11 @@ SUBROUTINE cal_cldfra3(CLDFRA, qv, qc, qi, qs, & ENDDO ! if (debug_flag) then -! WRITE (dbg_msg,*) 'DEBUG-GT: finding cloud layers at point (', i, ', ', j, ')' +! WRITE (dbg_msg,*) 'DEBUG-GT: finding cloud layers at point (', i, ', ', j, ')' ! CALL wrf_debug (150, dbg_msg) -! endif +! endif call find_cloudLayers(qvs1d, cfr1d, T1d, P1d, R1d, entrmnt, & - & debug_flag, qc1d, qi1d, qs1d, kts,kte) + & debug_flag, qc1d, qi1d, qs1d, kts,kte) DO k = kts,kte cldfra(i,k,j) = cfr1d(k) @@ -3964,7 +3964,7 @@ END SUBROUTINE cal_cldfra3 !.. unless existing LWC/IWC is already there. SUBROUTINE find_cloudLayers(qvs1d, cfr1d, T1d, P1d, R1d, entrmnt, & - & debugfl, qc1d, qi1d, qs1d, kts,kte) + & debugfl, qc1d, qi1d, qs1d, kts,kte) ! IMPLICIT NONE @@ -4004,8 +4004,8 @@ SUBROUTINE find_cloudLayers(qvs1d, cfr1d, T1d, P1d, R1d, entrmnt, & dz(kts) = dz(kts+1) !..Find tropopause height, best surrogate, because we would not really -!.. wish to put fake clouds into the stratosphere. The 10/1500 ratio -!.. d(Theta)/d(Z) approximates a vertical line on typical SkewT chart +!.. wish to put fake clouds into the stratosphere. The 10/1500 ratio +!.. d(Theta)/d(Z) approximates a vertical line on typical SkewT chart !.. near typical (mid-latitude) tropopause height. Since messy data !.. could give us a false signal of such a transition, do the check over !.. three K-level change, not just a level-to-level check. This method @@ -4069,103 +4069,103 @@ SUBROUTINE find_cloudLayers(qvs1d, cfr1d, T1d, P1d, R1d, entrmnt, & in_cloud = .true. k_cldt = MAX(k_cldt, k) endif - if (in_cloud) then - DO k2 = k_cldt-1, k_m12C, -1 - if (cfr1d(k2).lt.0.01 .or. k2.eq.k_m12C) then - k_cldb = k2+1 - goto 87 - endif - ENDDO - 87 continue - in_cloud = .false. - endif - if ((k_cldt - k_cldb + 1) .ge. 2) then -! if (debugfl) then + if (in_cloud) then + DO k2 = k_cldt-1, k_m12C, -1 + if (cfr1d(k2).lt.0.01 .or. k2.eq.k_m12C) then + k_cldb = k2+1 + goto 87 + endif + ENDDO + 87 continue + in_cloud = .false. + endif + if ((k_cldt - k_cldb + 1) .ge. 2) then +! if (debugfl) then ! print*, 'An ice cloud layer is found between ', k_cldt, ! k_cldb, P1d(k_cldt)*0.01, P1d(k_cldb)*0.01 ! WRITE (dbg_msg,*) 'DEBUG-GT: An ice cloud layer is found between ! ', k_cldt, k_cldb, P1d(k_cldt)*0.01, P1d(k_cldb)*0.01 -! CALL wrf_debug (150, dbg_msg) -! endif +! CALL wrf_debug (150, dbg_msg) +! endif call adjust_cloudIce(cfr1d, qi1d, qs1d, qvs1d, T1d,R1d,dz, & - & entrmnt, k_cldb,k_cldt,kts,kte) - k = k_cldb - else + & entrmnt, k_cldb,k_cldt,kts,kte) + k = k_cldb + else if (cfr1d(k_cldb).gt.0.and.qi1d(k_cldb).lt.1.E-6) & - & qi1d(k_cldb)=1.E-5*cfr1d(k_cldb) - endif - - - k = k - 1 - ENDDO - - - - k_cldb = k_tropo - in_cloud = .false. - k = k_m12C + 2 - DO WHILE (.not. in_cloud .AND. k.gt.kbot) - k_cldt = 0 - if (cfr1d(k).ge.0.01) then - in_cloud = .true. - k_cldt = MAX(k_cldt, k) - endif - if (in_cloud) then - DO k2 = k_cldt-1, kbot, -1 - if (cfr1d(k2).lt.0.01 .or. k2.eq.kbot) then - k_cldb = k2+1 - goto 88 - endif - ENDDO - 88 continue - in_cloud = .false. - endif - if ((k_cldt - k_cldb + 1) .ge. 2) then -! if (debugfl) then + & qi1d(k_cldb)=1.E-5*cfr1d(k_cldb) + endif + + + k = k - 1 + ENDDO + + + + k_cldb = k_tropo + in_cloud = .false. + k = k_m12C + 2 + DO WHILE (.not. in_cloud .AND. k.gt.kbot) + k_cldt = 0 + if (cfr1d(k).ge.0.01) then + in_cloud = .true. + k_cldt = MAX(k_cldt, k) + endif + if (in_cloud) then + DO k2 = k_cldt-1, kbot, -1 + if (cfr1d(k2).lt.0.01 .or. k2.eq.kbot) then + k_cldb = k2+1 + goto 88 + endif + ENDDO + 88 continue + in_cloud = .false. + endif + if ((k_cldt - k_cldb + 1) .ge. 2) then +! if (debugfl) then ! print*, 'A water cloud layer is found between ', k_cldt, ! k_cldb, P1d(k_cldt)*0.01, P1d(k_cldb)*0.01 ! WRITE (dbg_msg,*) 'DEBUG-GT: A water cloud layer is found ! between ', k_cldt, k_cldb, P1d(k_cldt)*0.01, P1d(k_cldb)*0.01 -! CALL wrf_debug (150, dbg_msg) -! endif +! CALL wrf_debug (150, dbg_msg) +! endif call adjust_cloudH2O(cfr1d, qc1d, qvs1d, T1d,R1d,dz, & - & entrmnt, k_cldb,k_cldt,kts,kte) - k = k_cldb - else + & entrmnt, k_cldb,k_cldt,kts,kte) + k = k_cldb + else if (cfr1d(k_cldb).gt.0.and.qc1d(k_cldb).lt.1.E-6) & - & qc1d(k_cldb)=1.E-5*cfr1d(k_cldb) - endif - k = k - 1 - ENDDO - + & qc1d(k_cldb)=1.E-5*cfr1d(k_cldb) + endif + k = k - 1 + ENDDO + !..Do a final total column adjustment since we may have added more than -!1mm -!.. LWP/IWP for multiple cloud decks. - - call adjust_cloudFinal(cfr1d, qc1d, qi1d, R1d,dz, kts,kte,k_tropo) - -! if (debugfl) then -! print*, ' Made-up fake profile of clouds' -! do k = kte, kts, -1 +!1mm +!.. LWP/IWP for multiple cloud decks. + + call adjust_cloudFinal(cfr1d, qc1d, qi1d, R1d,dz, kts,kte,k_tropo) + +! if (debugfl) then +! print*, ' Made-up fake profile of clouds' +! do k = kte, kts, -1 ! write(*,'(i3, 2x, f8.2, 2x, f9.2, 2x, f6.2, 2x, f15.7, 2x, -! f15.7)') & +! f15.7)') & ! & K, T1d(k)-273.15, P1d(k)*0.01, cfr1d(k)*100., -! qc1d(k)*1000.,qi1d(k)*1000. -! enddo -! WRITE (dbg_msg,*) 'DEBUG-GT: Made-up fake profile of clouds' -! CALL wrf_debug (150, dbg_msg) -! do k = kte, kts, -1 +! qc1d(k)*1000.,qi1d(k)*1000. +! enddo +! WRITE (dbg_msg,*) 'DEBUG-GT: Made-up fake profile of clouds' +! CALL wrf_debug (150, dbg_msg) +! do k = kte, kts, -1 ! write(dbg_msg,'(f8.2, 2x, f9.2, 2x, f6.2, 2x, f15.7, 2x, -! f15.7)') & +! f15.7)') & ! & T1d(k)-273.15, P1d(k)*0.01, cfr1d(k)*100., -! qc1d(k)*1000.,qi1d(k)*1000. -! CALL wrf_debug (150, dbg_msg) -! enddo -! endif - - - END SUBROUTINE find_cloudLayers - +! qc1d(k)*1000.,qi1d(k)*1000. +! CALL wrf_debug (150, dbg_msg) +! enddo +! endif + + + END SUBROUTINE find_cloudLayers + !+---+-----------------------------------------------------------------+ SUBROUTINE adjust_cloudIce(cfr,qi,qs,qvs, T,Rho,dz, entr, k1,k2, & diff --git a/physics/radlw_main.F90 b/physics/radlw_main.F90 index f5278ed33..58a446f0b 100644 --- a/physics/radlw_main.F90 +++ b/physics/radlw_main.F90 @@ -229,7 +229,7 @@ ! apr 2012, b. ferrier and y. hou -- added conversion factor to fu's! ! cloud-snow optical property scheme. ! ! nov 2012, yu-tai hou -- modified control parameters thru ! -! module 'physparam'. ! +! module 'physparam'. ! ! FEB 2017 A.Cheng - add odpth output, effective radius input ! ! jun 2018, h-m lin/y-t hou -- added new option of cloud overlap ! ! method 'de-correlation-length' for mcica application ! @@ -238,9 +238,9 @@ !!!!! end descriptions !!!!! !!!!! ============================================================== !!!!! -!> This module contains the CCPP-compliant NCEP's modifications of the +!> This module contains the CCPP-compliant NCEP's modifications of the !! rrtm-lw radiation code from aer inc. - module rrtmg_lw + module rrtmg_lw ! use physparam, only : ilwrate, ilwrgas, ilwcliq, ilwcice, & & isubclw, icldflg, iovrlw, ivflip, & @@ -359,7 +359,7 @@ module rrtmg_lw subroutine rrtmg_lw_init () end subroutine rrtmg_lw_init -!> \defgroup module_radlw_main GFS RRTMG Longwave Module +!> \defgroup module_radlw_main GFS RRTMG Longwave Module !! \brief This module includes NCEP's modifications of the RRTMG-LW radiation !! code from AER. !! @@ -618,8 +618,8 @@ subroutine rrtmg_lw_run & ! ! Dimensions: (ncol,nlay,nbndlw) !mz* output from cldprmc integer :: ncbands ! number of cloud spectral bands - real(kind=kind_phys),dimension(ngptlw,nlay) :: taucmc ! cloud optical depth [mcica] - ! Dimensions: (ngptlw,nlayers) + real(kind=kind_phys),dimension(ngptlw,nlay) :: taucmc ! cloud optical depth [mcica] + ! Dimensions: (ngptlw,nlayers) !mz ! --- outputs: @@ -662,8 +662,8 @@ subroutine rrtmg_lw_run & & scaleminorn2, temcol, dz !mz* - real(kind=rb),dimension(0:nlay,nbands) :: planklay,planklev - real(kind=rb),dimension(0:nlay) :: pz + real(kind=rb),dimension(0:nlay,nbands) :: planklay,planklev + real(kind=rb),dimension(0:nlay) :: pz ! real(kind=rb) :: plankbnd(nbndlw) real (kind=kind_phys), dimension(nbands,0:nlay) :: pklev, pklay @@ -674,7 +674,7 @@ subroutine rrtmg_lw_run & real (kind=kind_phys), dimension(ngptlw,nlay) :: fracs, tautot real (kind=kind_phys), dimension(nlay,ngptlw) :: fracs_r !mz rtrnmc_mcica - real (kind=kind_phys), dimension(nlay,ngptlw) :: taut + real (kind=kind_phys), dimension(nlay,ngptlw) :: taut !mz* Atmosphere/clouds - cldprop real(kind=kind_phys), dimension(ngptlw,nlay) :: cldfmc, & & cldfmc_save ! cloud fraction [mcica] @@ -815,22 +815,22 @@ subroutine rrtmg_lw_run & if (iovrlw == 4 ) then !Add layer height needed for exponential (icld=4) and -! exponential-random (icld=5) overlap options +! exponential-random (icld=5) overlap options !iplon = 1 irng = 0 permuteseed = 150 -!mz* Derive height +!mz* Derive height dzsum =0.0 do k = 1,nlay hgt(iplon,k)= dzsum+0.5*dzlyr(iplon,k)*1000. !km->m - dzsum = dzsum+ dzlyr(iplon,k)*1000. + dzsum = dzsum+ dzlyr(iplon,k)*1000. enddo ! Zero out cloud optical properties here; not used when passing physical properties -! to radiation and taucld is calculated in radiation - do k = 1, nlay +! to radiation and taucld is calculated in radiation + do k = 1, nlay do j = 1, nbands taucld3(j,iplon,k) = 0.0 enddo @@ -843,7 +843,7 @@ subroutine rrtmg_lw_run & & cld_ref_snow, taucld3, & & cldfmcl, & !--output & ciwpmcl, clwpmcl, cswpmcl, reicmcl, relqmcl, & - & resnmcl, taucmcl) + & resnmcl, taucmcl) endif !mz* end @@ -948,7 +948,7 @@ subroutine rrtmg_lw_run & cda4(k) = cld_ref_snow(iplon,k1) enddo ! HWRF RRMTG - if (iovrlw == 4) then !mz HWRF + if (iovrlw == 4) then !mz HWRF do k = 1, nlay k1 = nlp1 - k do ig = 1, ngptlw @@ -1072,7 +1072,7 @@ subroutine rrtmg_lw_run & enddo if (iovrlw == 4) then !mz* Move incoming GCM cloud arrays to RRTMG cloud arrays. -!For GCM input, incoming reicmcl is defined based on selected +!For GCM input, incoming reicmcl is defined based on selected !ice parameterization (inflglw) do k = 1, nlay do ig = 1, ngptlw @@ -1209,12 +1209,12 @@ subroutine rrtmg_lw_run & endif !mz* HWRF: calculate taucmc with mcica - if (iovrlw == 4) then + if (iovrlw == 4) then call cldprmc(nlay, inflglw, iceflglw, liqflglw, & & cldfmc, ciwpmc, & & clwpmc, cswpmc, reicmc, relqmc, resnmc, & & ncbands, taucmc) - endif + endif ! if (lprnt) then ! print *,' after cldprop' @@ -1421,14 +1421,14 @@ end subroutine rrtmg_lw_run !----------------------------------- !> @} subroutine rrtmg_lw_finalize () - end subroutine rrtmg_lw_finalize + end subroutine rrtmg_lw_finalize !> \ingroup module_radlw_main !> \brief This subroutine performs calculations necessary for the initialization !! of the longwave model, which includes non-varying model variables, conversion -!! factors, and look-up tables +!! factors, and look-up tables !! !! Lookup tables are computed for use in the lw !! radiative transfer, and input absorption coefficient data for each @@ -1660,8 +1660,8 @@ end subroutine rlwinit !!\param nlay number of layer number !!\param nlp1 number of veritcal levels !!\param ipseed permutation seed for generating random numbers (isubclw>0) -!!\param dz layer thickness (km) -!!\param de_lgth layer cloud decorrelation length (km) +!!\param dz layer thickness (km) +!!\param de_lgth layer cloud decorrelation length (km) !!\param cldfmc cloud fraction for each sub-column !!\param taucld cloud optical depth for bands (non-mcica) !!\section gen_cldprop cldprop General Algorithm @@ -2042,7 +2042,7 @@ subroutine mcica_subcol & & ) !> -# Sub-column set up according to overlapping assumption: -!! - For random overlap, pick a random value at every level +!! - For random overlap, pick a random value at every level !! - For max-random overlap, pick a random value at every level !! - For maximum overlap, pick same random numebr at every level @@ -3928,7 +3928,7 @@ end subroutine rtrnmc !!\param tautot total optical depth (gas+aerosols) !>\section taumol_gen taumol General Algorithm !! @{ -!! subprograms called: taugb## (## = 01 -16) +!! subprograms called: taugb## (## = 01 -16) subroutine taumol & & ( laytrop,pavel,coldry,colamt,colbrd,wx,tauaer, & ! --- inputs & rfrate,fac00,fac01,fac10,fac11,jp,jt,jt1, & @@ -6960,7 +6960,7 @@ subroutine mcica_subcol_lw(iplon, ncol, nlay, icld, permuteseed, & integer(kind=im), intent(in) :: ncol ! number of columns integer(kind=im), intent(in) :: nlay ! number of model layers integer(kind=im), intent(in) :: icld ! clear/cloud, cloud overlap flag - integer(kind=im), intent(in) :: permuteseed ! if the cloud generator is called multiple times, + integer(kind=im), intent(in) :: permuteseed ! if the cloud generator is called multiple times, ! permute the seed between each call. ! between calls for LW and SW, recommended ! permuteseed differes by 'ngpt' @@ -6970,7 +6970,7 @@ subroutine mcica_subcol_lw(iplon, ncol, nlay, icld, permuteseed, & ! Twister ! Atmosphere - real(kind=rb), intent(in) :: play(:,:) ! layer pressures (mb) + real(kind=rb), intent(in) :: play(:,:) ! layer pressures (mb) ! Dimensions: (ncol,nlay) ! mji - Add height @@ -6999,8 +6999,8 @@ subroutine mcica_subcol_lw(iplon, ncol, nlay, icld, permuteseed, & real(kind=rb), intent(in) :: res(:,:) ! snow particle size ! Dimensions: (ncol,nlay) -! ----- Output ----- -! Atmosphere/clouds - cldprmc [mcica] +! ----- Output ----- +! Atmosphere/clouds - cldprmc [mcica] real(kind=rb), intent(out) :: cldfmcl(:,:,:) ! cloud fraction [mcica] ! Dimensions: (ngptlw,ncol,nlay) real(kind=rb), intent(out) :: ciwpmcl(:,:,:) ! in-cloud ice water path [mcica] @@ -7059,7 +7059,7 @@ end subroutine mcica_subcol_lw subroutine generate_stochastic_clouds(ncol, nlay, nsubcol, icld, & & irng, pmid, hgt, cld, clwp, ciwp, cswp, tauc, & & cld_stoch, clwp_stoch, ciwp_stoch, & - & cswp_stoch, tauc_stoch, changeSeed) + & cswp_stoch, tauc_stoch, changeSeed) !------------------------------------------------------------------------------------------------- !------------------------------------------------------------------------------------------------- ! Contact: Cecile Hannay (hannay@ucar.edu) @@ -7083,15 +7083,15 @@ subroutine generate_stochastic_clouds(ncol, nlay, nsubcol, icld, & ! Overlap assumption: ! The cloud are consistent with 5 overlap assumptions: random, maximum, maximum-random, exponential and exponential random. ! The default option is maximum-random (option 2) -! The options are: 1=random overlap, 2=max/random, 3=maximum overlap, 4=exponential overlap, 5=exp/random +! The options are: 1=random overlap, 2=max/random, 3=maximum overlap, 4=exponential overlap, 5=exp/random ! This is set with the variable "overlap" ! The exponential overlap uses also a length scale, Zo. (real, parameter :: Zo = 2500. ) ! ! Seed: ! If the stochastic cloud generator is called several times during the same timestep, ! one should change the seed between the call to insure that the -! subcolumns are different. -! This is done by changing the argument 'changeSeed' +! subcolumns are different. +! This is done by changing the argument 'changeSeed' ! For example, if one wants to create a set of columns for the ! shortwave and another set for the longwave , ! use 'changeSeed = 1' for the first call and'changeSeed = 2' for the second call @@ -7105,8 +7105,8 @@ subroutine generate_stochastic_clouds(ncol, nlay, nsubcol, icld, & ! Option to add diagnostics variables in the history file. (using FINCL in the namelist) ! nsubcol = number of subcolumns ! overlap = overlap type (1-3) -! Zo = length scale -! CLOUD_S = mean of the subcolumn cloud fraction ('_S" means Stochastic) +! Zo = length scale +! CLOUD_S = mean of the subcolumn cloud fraction ('_S" means Stochastic) ! CLDLIQ_S = mean of the subcolumn cloud water ! CLDICE_S = mean of the subcolumn cloud ice ! @@ -7135,7 +7135,7 @@ subroutine generate_stochastic_clouds(ncol, nlay, nsubcol, icld, & ! 0 = kissvec ! 1 = Mersenne Twister integer(kind=im), intent(in) :: nsubcol ! number of sub-columns (g-point intervals) - integer(kind=im), optional, intent(in) :: changeSeed ! allows permuting seed + integer(kind=im), optional, intent(in) :: changeSeed ! allows permuting seed ! Column state (cloud fraction, cloud water, cloud ice) + variables needed to read physics state real(kind=rb), intent(in) :: pmid(:,:) ! layer pressure (Pa) @@ -7185,12 +7185,12 @@ subroutine generate_stochastic_clouds(ncol, nlay, nsubcol, icld, & ! real(kind=rb) :: mean_clwp_stoch(ncol, nlay) ! cloud water ! real(kind=rb) :: mean_ciwp_stoch(ncol, nlay) ! cloud ice ! real(kind=rb) :: mean_tauc_stoch(ncol, nlay) ! cloud optical depth -! real(kind=rb) :: mean_ssac_stoch(ncol, nlay) ! cloud single scattering albedo -! real(kind=rb) :: mean_asmc_stoch(ncol, nlay) ! cloud asymmetry parameter +! real(kind=rb) :: mean_ssac_stoch(ncol, nlay) ! cloud single scattering albedo +! real(kind=rb) :: mean_asmc_stoch(ncol, nlay) ! cloud asymmetry parameter ! Set overlap integer(kind=im) :: overlap ! 1 = random overlap, 2 = maximum-random, - ! 3 = maximum overlap, 4 = exponential, + ! 3 = maximum overlap, 4 = exponential, ! 5 = exponential-random real(kind=rb), parameter :: Zo = 2500._rb ! length scale (m) real(kind=rb), dimension(ncol,nlay) :: alpha ! overlap parameter @@ -7233,7 +7233,7 @@ subroutine generate_stochastic_clouds(ncol, nlay, nsubcol, icld, & ! ----- Create seed -------- ! Advance randum number generator by changeseed values - if (irng.eq.0) then + if (irng.eq.0) then ! For kissvec, create a seed that depends on the state of the columns. Maybe not the best way, but it works. ! Must use pmid from bottom four layers. do i=1,ncol @@ -7257,7 +7257,7 @@ subroutine generate_stochastic_clouds(ncol, nlay, nsubcol, icld, & ! generate the random numbers - select case (overlap) + select case (overlap) case(1) ! Random overlap @@ -7268,7 +7268,7 @@ subroutine generate_stochastic_clouds(ncol, nlay, nsubcol, icld, & do ilev = 1,nlay call kissvec(seed1, seed2, seed3, seed4, rand_num) ! we get different random number for each level CDF(isubcol,:,ilev) = rand_num - enddo + enddo enddo elseif (irng.eq.1) then do isubcol = 1, nsubcol @@ -7282,7 +7282,7 @@ subroutine generate_stochastic_clouds(ncol, nlay, nsubcol, icld, & endif case(2) -! Maximum-Random overlap +! Maximum-Random overlap ! i) pick a random number for top layer. ! ii) walk down the column: ! - if the layer above is cloudy, we use the same random number than in the layer above @@ -7400,10 +7400,10 @@ subroutine generate_stochastic_clouds(ncol, nlay, nsubcol, icld, & end select -! -- generate subcolumns for homogeneous clouds ----- - do ilev = 1,nlay +! -- generate subcolumns for homogeneous clouds ----- + do ilev = 1,nlay iscloudy(:,:,ilev) = (CDF(:,:,ilev) >= 1._rb - & - & spread(cldf(:,ilev), dim=1, nCopies=nsubcol) ) + & spread(cldf(:,ilev), dim=1, nCopies=nsubcol) ) enddo ! where the subcolumn is cloudy, the subcolumn cloud fraction is 1; @@ -7418,7 +7418,7 @@ subroutine generate_stochastic_clouds(ncol, nlay, nsubcol, icld, & cld_stoch(isubcol,i,ilev) = 1._rb clwp_stoch(isubcol,i,ilev) = clwp(i,ilev) ciwp_stoch(isubcol,i,ilev) = ciwp(i,ilev) -!mz +!mz ! cswp_stoch(isubcol,i,ilev) = cswp(i,ilev) cswp_stoch(isubcol,i,ilev) = 0._rb n = ngb(isubcol) @@ -7446,13 +7446,13 @@ subroutine generate_stochastic_clouds(ncol, nlay, nsubcol, icld, & ! mean_ssac_stoch(:,:) = 0._rb ! mean_asmc_stoch(:,:) = 0._rb ! do i = 1, nsubcol -! mean_cld_stoch(:,:) = cld_stoch(i,:,:) + mean_cld_stoch(:,:) +! mean_cld_stoch(:,:) = cld_stoch(i,:,:) + mean_cld_stoch(:,:) ! mean_clwp_stoch(:,:) = clwp_stoch( i,:,:) + mean_clwp_stoch(:,:) ! mean_ciwp_stoch(:,:) = ciwp_stoch( i,:,:) + mean_ciwp_stoch(:,:) ! mean_tauc_stoch(:,:) = tauc_stoch( i,:,:) + mean_tauc_stoch(:,:) ! mean_ssac_stoch(:,:) = ssac_stoch( i,:,:) + mean_ssac_stoch(:,:) ! mean_asmc_stoch(:,:) = asmc_stoch( i,:,:) + mean_asmc_stoch(:,:) -! end do +! end do ! mean_cld_stoch(:,:) = mean_cld_stoch(:,:) / nsubcol ! mean_clwp_stoch(:,:) = mean_clwp_stoch(:,:) / nsubcol ! mean_ciwp_stoch(:,:) = mean_ciwp_stoch(:,:) / nsubcol @@ -7464,10 +7464,10 @@ end subroutine generate_stochastic_clouds !------------------------------------------------------------------ ! Private subroutines -!------------------------------------------------------------------ +!------------------------------------------------------------------ -!----------------------------------------------------------------- - subroutine kissvec(seed1,seed2,seed3,seed4,ran_arr) +!----------------------------------------------------------------- + subroutine kissvec(seed1,seed2,seed3,seed4,ran_arr) !---------------------------------------------------------------- ! public domain code @@ -7478,19 +7478,19 @@ subroutine kissvec(seed1,seed2,seed3,seed4,ran_arr) ! The KISS (Keep It Simple Stupid) random number generator. Combines: ! (1) The congruential generator x(n)=69069*x(n-1)+1327217885, period 2^32. ! (2) A 3-shift shift-register generator, period 2^32-1, -! (3) Two 16-bit multiply-with-carry generators, period 597273182964842497>2^59 -! Overall period>2^123; +! (3) Two 16-bit multiply-with-carry generators, period 597273182964842497>2^59 +! Overall period>2^123; real(kind=rb), dimension(:), intent(inout) :: ran_arr integer(kind=im), dimension(:), intent(inout) :: seed1,seed2,seed3& & ,seed4 integer(kind=im) :: i,sz,kiss integer(kind=im) :: m, k, n -! inline function +! inline function m(k, n) = ieor (k, ishft (k, n) ) sz = size(ran_arr) - do i = 1, sz + do i = 1, sz seed1(i) = 69069_im * seed1(i) + 1327217885_im seed2(i) = m (m (m (seed2(i), 13_im), - 17_im), 5_im) seed3(i) = 18000_im * iand (seed3(i), 65535_im) + & @@ -7499,7 +7499,7 @@ subroutine kissvec(seed1,seed2,seed3,seed4,ran_arr) & ishft (seed4(i), - 16_im) kiss = seed1(i) + seed2(i) + ishft (seed3(i), 16_im) + seed4(i) ran_arr(i) = kiss*2.328306e-10_rb + 0.5_rb - end do + end do end subroutine kissvec ! @@ -7517,445 +7517,445 @@ subroutine rtrnmc_mcica(nlayers, istart, iend, iout, pz, semiss, & ! This program calculates the upward fluxes, downward fluxes, and ! heating rates for an arbitrary clear or cloudy atmosphere. The input ! to this program is the atmospheric profile, all Planck function -! information, and the cloud fraction by layer. A variable diffusivity -! angle (SECDIFF) is used for the angle integration. Bands 2-3 and 5-9 -! use a value for SECDIFF that varies from 1.50 to 1.80 as a function of -! the column water vapor, and other bands use a value of 1.66. The Gaussian -! weight appropriate to this angle (WTDIFF=0.5) is applied here. Note that -! use of the emissivity angle for the flux integration can cause errors of -! 1 to 4 W/m2 within cloudy layers. -! Clouds are treated with the McICA stochastic approach and maximum-random -! cloud overlap. -!*************************************************************************** - -! ------- Declarations ------- - -! ----- Input ----- - integer(kind=im), intent(in) :: nlayers ! total number of layers - integer(kind=im), intent(in) :: istart ! beginning band of calculation - integer(kind=im), intent(in) :: iend ! ending band of calculation - integer(kind=im), intent(in) :: iout ! output option flag - -! Atmosphere +! information, and the cloud fraction by layer. A variable diffusivity +! angle (SECDIFF) is used for the angle integration. Bands 2-3 and 5-9 +! use a value for SECDIFF that varies from 1.50 to 1.80 as a function of +! the column water vapor, and other bands use a value of 1.66. The Gaussian +! weight appropriate to this angle (WTDIFF=0.5) is applied here. Note that +! use of the emissivity angle for the flux integration can cause errors of +! 1 to 4 W/m2 within cloudy layers. +! Clouds are treated with the McICA stochastic approach and maximum-random +! cloud overlap. +!*************************************************************************** + +! ------- Declarations ------- + +! ----- Input ----- + integer(kind=im), intent(in) :: nlayers ! total number of layers + integer(kind=im), intent(in) :: istart ! beginning band of calculation + integer(kind=im), intent(in) :: iend ! ending band of calculation + integer(kind=im), intent(in) :: iout ! output option flag + +! Atmosphere real(kind=rb), intent(in) :: pz(0:) ! level (interface) pressures (hPa, mb) - ! Dimensions: (0:nlayers) - real(kind=rb), intent(in) :: pwvcm ! precipitable water vapor (cm) - real(kind=rb), intent(in) :: semiss(:) ! lw surface emissivity - ! Dimensions: (nbndlw) + ! Dimensions: (0:nlayers) + real(kind=rb), intent(in) :: pwvcm ! precipitable water vapor (cm) + real(kind=rb), intent(in) :: semiss(:) ! lw surface emissivity + ! Dimensions: (nbndlw) !mz - real(kind=rb), intent(in) :: planklay(0:,:) ! - ! Dimensions: (nlayers,nbndlw) - real(kind=rb), intent(in) :: planklev(0:,:) ! - ! Dimensions: (0:nlayers,nbndlw) -! real(kind=rb), intent(in) :: plankbnd(:) ! - ! Dimensions: (nbndlw) - real(kind=rb), intent(in) :: fracs(:,:) ! - ! Dimensions: (nlayers,ngptw) - real(kind=rb), intent(in) :: taut(:,:) ! gaseous + aerosol optical depths - ! Dimensions: (nlayers,ngptlw) - -! Clouds - integer(kind=im), intent(in) :: ncbands ! number of cloud spectral bands - real(kind=rb), intent(in) :: cldfmc(:,:) ! layer cloud fraction [mcica] - ! Dimensions: (ngptlw,nlayers) - real(kind=rb), intent(in) :: taucmc(:,:) ! layer cloud optical depth [mcica] - ! Dimensions: (ngptlw,nlayers) - -! ----- Output ----- - real(kind=rb), intent(out) :: totuflux(0:) ! upward longwave flux (w/m2) - ! Dimensions: (0:nlayers) - real(kind=rb), intent(out) :: totdflux(0:) ! downward longwave flux (w/m2) - ! Dimensions: (0:nlayers) -!mz* real(kind=rb), intent(out) :: fnet(0:) ! net longwave flux (w/m2) - ! Dimensions: (0:nlayers) + real(kind=rb), intent(in) :: planklay(0:,:) ! + ! Dimensions: (nlayers,nbndlw) + real(kind=rb), intent(in) :: planklev(0:,:) ! + ! Dimensions: (0:nlayers,nbndlw) +! real(kind=rb), intent(in) :: plankbnd(:) ! + ! Dimensions: (nbndlw) + real(kind=rb), intent(in) :: fracs(:,:) ! + ! Dimensions: (nlayers,ngptw) + real(kind=rb), intent(in) :: taut(:,:) ! gaseous + aerosol optical depths + ! Dimensions: (nlayers,ngptlw) + +! Clouds + integer(kind=im), intent(in) :: ncbands ! number of cloud spectral bands + real(kind=rb), intent(in) :: cldfmc(:,:) ! layer cloud fraction [mcica] + ! Dimensions: (ngptlw,nlayers) + real(kind=rb), intent(in) :: taucmc(:,:) ! layer cloud optical depth [mcica] + ! Dimensions: (ngptlw,nlayers) + +! ----- Output ----- + real(kind=rb), intent(out) :: totuflux(0:) ! upward longwave flux (w/m2) + ! Dimensions: (0:nlayers) + real(kind=rb), intent(out) :: totdflux(0:) ! downward longwave flux (w/m2) + ! Dimensions: (0:nlayers) +!mz* real(kind=rb), intent(out) :: fnet(0:) ! net longwave flux (w/m2) + ! Dimensions: (0:nlayers) real(kind=rb), intent(out) :: htr(:) -!mz real(kind=rb), intent(out) :: htr(0:) ! longwave heating rate (k/day) - ! Dimensions: (0:nlayers) +!mz real(kind=rb), intent(out) :: htr(0:) ! longwave heating rate (k/day) + ! Dimensions: (0:nlayers) real(kind=rb), intent(out) :: totuclfl(0:) ! clear sky upward longwave flux (w/m2) - ! Dimensions: (0:nlayers) + ! Dimensions: (0:nlayers) real(kind=rb), intent(out) :: totdclfl(0:) ! clear sky downward longwave flux (w/m2) - ! Dimensions: (0:nlayers) + ! Dimensions: (0:nlayers) !mz*real(kind=rb), intent(out) :: fnetc(0:) ! clear sky net longwave flux (w/m2) - ! Dimensions: (0:nlayers) - real(kind=rb), intent(out) :: htrc(:) + ! Dimensions: (0:nlayers) + real(kind=rb), intent(out) :: htrc(:) ! real(kind=rb), intent(out) :: htrc(0:) ! clear sky longwave heating rate (k/day) - ! Dimensions: (0:nlayers) - -! ----- Local ----- -! Declarations for radiative transfer + ! Dimensions: (0:nlayers) + +! ----- Local ----- +! Declarations for radiative transfer real (kind=kind_phys), dimension(0:nlayers) :: fnet, fnetc - real(kind=rb) :: abscld(nlayers,ngptlw) - real(kind=rb) :: atot(nlayers) - real(kind=rb) :: atrans(nlayers) - real(kind=rb) :: bbugas(nlayers) - real(kind=rb) :: bbutot(nlayers) - real(kind=rb) :: clrurad(0:nlayers) - real(kind=rb) :: clrdrad(0:nlayers) - real(kind=rb) :: efclfrac(nlayers,ngptlw) - real(kind=rb) :: uflux(0:nlayers) - real(kind=rb) :: dflux(0:nlayers) - real(kind=rb) :: urad(0:nlayers) - real(kind=rb) :: drad(0:nlayers) - real(kind=rb) :: uclfl(0:nlayers) - real(kind=rb) :: dclfl(0:nlayers) - real(kind=rb) :: odcld(nlayers,ngptlw) - - - real(kind=rb) :: secdiff(nbands) ! secant of diffusivity angle + real(kind=rb) :: abscld(nlayers,ngptlw) + real(kind=rb) :: atot(nlayers) + real(kind=rb) :: atrans(nlayers) + real(kind=rb) :: bbugas(nlayers) + real(kind=rb) :: bbutot(nlayers) + real(kind=rb) :: clrurad(0:nlayers) + real(kind=rb) :: clrdrad(0:nlayers) + real(kind=rb) :: efclfrac(nlayers,ngptlw) + real(kind=rb) :: uflux(0:nlayers) + real(kind=rb) :: dflux(0:nlayers) + real(kind=rb) :: urad(0:nlayers) + real(kind=rb) :: drad(0:nlayers) + real(kind=rb) :: uclfl(0:nlayers) + real(kind=rb) :: dclfl(0:nlayers) + real(kind=rb) :: odcld(nlayers,ngptlw) + + + real(kind=rb) :: secdiff(nbands) ! secant of diffusivity angle real(kind=rb) :: transcld, radld, radclrd, plfrac, blay, dplankup,& - & dplankdn - real(kind=rb) :: odepth, odtot, odepth_rec, odtot_rec, gassrc + & dplankdn + real(kind=rb) :: odepth, odtot, odepth_rec, odtot_rec, gassrc real(kind=rb) :: tblind, tfactot, bbd, bbdtot, tfacgas, transc, & - & tausfac - real(kind=rb) :: rad0, reflect, radlu, radclru - - integer(kind=im) :: icldlyr(nlayers) ! flag for cloud in layer - integer(kind=im) :: ibnd, ib, iband, lay, lev, l, ig ! loop indices - integer(kind=im) :: igc ! g-point interval counter - integer(kind=im) :: iclddn ! flag for cloud in down path - integer(kind=im) :: ittot, itgas, itr ! lookup table indices + & tausfac + real(kind=rb) :: rad0, reflect, radlu, radclru + + integer(kind=im) :: icldlyr(nlayers) ! flag for cloud in layer + integer(kind=im) :: ibnd, ib, iband, lay, lev, l, ig ! loop indices + integer(kind=im) :: igc ! g-point interval counter + integer(kind=im) :: iclddn ! flag for cloud in down path + integer(kind=im) :: ittot, itgas, itr ! lookup table indices !mz* real (kind=kind_phys), parameter :: rec_6 = 0.166667 ! The cumulative sum of new g-points for each band integer(kind=im) :: ngs(nbands) ngs(:) = (/10,22,38,52,68,76,88,96,108,114,122,130,134,136,138, & & 140/) - -! ------- Definitions ------- -! input -! nlayers ! number of model layers -! ngptlw ! total number of g-point subintervals -! nbndlw ! number of longwave spectral bands -! ncbands ! number of spectral bands for clouds -! secdiff ! diffusivity angle -! wtdiff ! weight for radiance to flux conversion -! pavel ! layer pressures (mb) -! pz ! level (interface) pressures (mb) -! tavel ! layer temperatures (k) -! tz ! level (interface) temperatures(mb) -! tbound ! surface temperature (k) -! cldfrac ! layer cloud fraction -! taucloud ! layer cloud optical depth -! itr ! integer look-up table index -! icldlyr ! flag for cloudy layers -! iclddn ! flag for cloud in column at any layer -! semiss ! surface emissivities for each band -! reflect ! surface reflectance -! bpade ! 1/(pade constant) -! tau_tbl ! clear sky optical depth look-up table -! exp_tbl ! exponential look-up table for transmittance -! tfn_tbl ! tau transition function look-up table - -! local -! atrans ! gaseous absorptivity -! abscld ! cloud absorptivity -! atot ! combined gaseous and cloud absorptivity -! odclr ! clear sky (gaseous) optical depth -! odcld ! cloud optical depth -! odtot ! optical depth of gas and cloud -! tfacgas ! gas-only pade factor, used for planck fn -! tfactot ! gas and cloud pade factor, used for planck fn -! bbdgas ! gas-only planck function for downward rt -! bbugas ! gas-only planck function for upward rt -! bbdtot ! gas and cloud planck function for downward rt -! bbutot ! gas and cloud planck function for upward calc. -! gassrc ! source radiance due to gas only -! efclfrac ! effective cloud fraction -! radlu ! spectrally summed upward radiance -! radclru ! spectrally summed clear sky upward radiance -! urad ! upward radiance by layer -! clrurad ! clear sky upward radiance by layer -! radld ! spectrally summed downward radiance -! radclrd ! spectrally summed clear sky downward radiance -! drad ! downward radiance by layer -! clrdrad ! clear sky downward radiance by layer - - -! output -! totuflux ! upward longwave flux (w/m2) -! totdflux ! downward longwave flux (w/m2) -! fnet ! net longwave flux (w/m2) -! htr ! longwave heating rate (k/day) -! totuclfl ! clear sky upward longwave flux (w/m2) -! totdclfl ! clear sky downward longwave flux (w/m2) -! fnetc ! clear sky net longwave flux (w/m2) -! htrc ! clear sky longwave heating rate (k/day) - - -!jm not thread safe hvrrtc = '$Revision: 1.3 $' - - do ibnd = 1,nbands!mz*nbndlw - if (ibnd.eq.1 .or. ibnd.eq.4 .or. ibnd.ge.10) then - secdiff(ibnd) = 1.66_rb - else - secdiff(ibnd) = a0(ibnd) + a1(ibnd)*exp(a2(ibnd)*pwvcm) - if (secdiff(ibnd) .gt. 1.80_rb) secdiff(ibnd) = 1.80_rb - if (secdiff(ibnd) .lt. 1.50_rb) secdiff(ibnd) = 1.50_rb - endif - enddo - - urad(0) = 0.0_rb - drad(0) = 0.0_rb - totuflux(0) = 0.0_rb - totdflux(0) = 0.0_rb - clrurad(0) = 0.0_rb - clrdrad(0) = 0.0_rb - totuclfl(0) = 0.0_rb - totdclfl(0) = 0.0_rb - - do lay = 1, nlayers - urad(lay) = 0.0_rb - drad(lay) = 0.0_rb - totuflux(lay) = 0.0_rb - totdflux(lay) = 0.0_rb - clrurad(lay) = 0.0_rb - clrdrad(lay) = 0.0_rb - totuclfl(lay) = 0.0_rb - totdclfl(lay) = 0.0_rb - icldlyr(lay) = 0 - -! Change to band loop? - do ig = 1, ngptlw - if (cldfmc(ig,lay) .eq. 1._rb) then - ib = ngb(ig) - odcld(lay,ig) = secdiff(ib) * taucmc(ig,lay) - transcld = exp(-odcld(lay,ig)) - abscld(lay,ig) = 1._rb - transcld - efclfrac(lay,ig) = abscld(lay,ig) * cldfmc(ig,lay) - icldlyr(lay) = 1 - else - odcld(lay,ig) = 0.0_rb - abscld(lay,ig) = 0.0_rb - efclfrac(lay,ig) = 0.0_rb - endif - enddo - - enddo - - igc = 1 -! Loop over frequency bands. - do iband = istart, iend - -! Reinitialize g-point counter for each band if output for each band is requested. - if (iout.gt.0.and.iband.ge.2) igc = ngs(iband-1)+1 - -! Loop over g-channels. - 1000 continue - -! Radiative transfer starts here. - radld = 0._rb - radclrd = 0._rb - iclddn = 0 - -! Downward radiative transfer loop. - - do lev = nlayers, 1, -1 - plfrac = fracs(lev,igc) - blay = planklay(lev,iband) - dplankup = planklev(lev,iband) - blay - dplankdn = planklev(lev-1,iband) - blay - odepth = secdiff(iband) * taut(lev,igc) - if (odepth .lt. 0.0_rb) odepth = 0.0_rb -! Cloudy layer - if (icldlyr(lev).eq.1) then - iclddn = 1 - odtot = odepth + odcld(lev,igc) - if (odtot .lt. 0.06_rb) then - atrans(lev) = odepth - 0.5_rb*odepth*odepth + +! ------- Definitions ------- +! input +! nlayers ! number of model layers +! ngptlw ! total number of g-point subintervals +! nbndlw ! number of longwave spectral bands +! ncbands ! number of spectral bands for clouds +! secdiff ! diffusivity angle +! wtdiff ! weight for radiance to flux conversion +! pavel ! layer pressures (mb) +! pz ! level (interface) pressures (mb) +! tavel ! layer temperatures (k) +! tz ! level (interface) temperatures(mb) +! tbound ! surface temperature (k) +! cldfrac ! layer cloud fraction +! taucloud ! layer cloud optical depth +! itr ! integer look-up table index +! icldlyr ! flag for cloudy layers +! iclddn ! flag for cloud in column at any layer +! semiss ! surface emissivities for each band +! reflect ! surface reflectance +! bpade ! 1/(pade constant) +! tau_tbl ! clear sky optical depth look-up table +! exp_tbl ! exponential look-up table for transmittance +! tfn_tbl ! tau transition function look-up table + +! local +! atrans ! gaseous absorptivity +! abscld ! cloud absorptivity +! atot ! combined gaseous and cloud absorptivity +! odclr ! clear sky (gaseous) optical depth +! odcld ! cloud optical depth +! odtot ! optical depth of gas and cloud +! tfacgas ! gas-only pade factor, used for planck fn +! tfactot ! gas and cloud pade factor, used for planck fn +! bbdgas ! gas-only planck function for downward rt +! bbugas ! gas-only planck function for upward rt +! bbdtot ! gas and cloud planck function for downward rt +! bbutot ! gas and cloud planck function for upward calc. +! gassrc ! source radiance due to gas only +! efclfrac ! effective cloud fraction +! radlu ! spectrally summed upward radiance +! radclru ! spectrally summed clear sky upward radiance +! urad ! upward radiance by layer +! clrurad ! clear sky upward radiance by layer +! radld ! spectrally summed downward radiance +! radclrd ! spectrally summed clear sky downward radiance +! drad ! downward radiance by layer +! clrdrad ! clear sky downward radiance by layer + + +! output +! totuflux ! upward longwave flux (w/m2) +! totdflux ! downward longwave flux (w/m2) +! fnet ! net longwave flux (w/m2) +! htr ! longwave heating rate (k/day) +! totuclfl ! clear sky upward longwave flux (w/m2) +! totdclfl ! clear sky downward longwave flux (w/m2) +! fnetc ! clear sky net longwave flux (w/m2) +! htrc ! clear sky longwave heating rate (k/day) + + +!jm not thread safe hvrrtc = '$Revision: 1.3 $' + + do ibnd = 1,nbands!mz*nbndlw + if (ibnd.eq.1 .or. ibnd.eq.4 .or. ibnd.ge.10) then + secdiff(ibnd) = 1.66_rb + else + secdiff(ibnd) = a0(ibnd) + a1(ibnd)*exp(a2(ibnd)*pwvcm) + if (secdiff(ibnd) .gt. 1.80_rb) secdiff(ibnd) = 1.80_rb + if (secdiff(ibnd) .lt. 1.50_rb) secdiff(ibnd) = 1.50_rb + endif + enddo + + urad(0) = 0.0_rb + drad(0) = 0.0_rb + totuflux(0) = 0.0_rb + totdflux(0) = 0.0_rb + clrurad(0) = 0.0_rb + clrdrad(0) = 0.0_rb + totuclfl(0) = 0.0_rb + totdclfl(0) = 0.0_rb + + do lay = 1, nlayers + urad(lay) = 0.0_rb + drad(lay) = 0.0_rb + totuflux(lay) = 0.0_rb + totdflux(lay) = 0.0_rb + clrurad(lay) = 0.0_rb + clrdrad(lay) = 0.0_rb + totuclfl(lay) = 0.0_rb + totdclfl(lay) = 0.0_rb + icldlyr(lay) = 0 + +! Change to band loop? + do ig = 1, ngptlw + if (cldfmc(ig,lay) .eq. 1._rb) then + ib = ngb(ig) + odcld(lay,ig) = secdiff(ib) * taucmc(ig,lay) + transcld = exp(-odcld(lay,ig)) + abscld(lay,ig) = 1._rb - transcld + efclfrac(lay,ig) = abscld(lay,ig) * cldfmc(ig,lay) + icldlyr(lay) = 1 + else + odcld(lay,ig) = 0.0_rb + abscld(lay,ig) = 0.0_rb + efclfrac(lay,ig) = 0.0_rb + endif + enddo + + enddo + + igc = 1 +! Loop over frequency bands. + do iband = istart, iend + +! Reinitialize g-point counter for each band if output for each band is requested. + if (iout.gt.0.and.iband.ge.2) igc = ngs(iband-1)+1 + +! Loop over g-channels. + 1000 continue + +! Radiative transfer starts here. + radld = 0._rb + radclrd = 0._rb + iclddn = 0 + +! Downward radiative transfer loop. + + do lev = nlayers, 1, -1 + plfrac = fracs(lev,igc) + blay = planklay(lev,iband) + dplankup = planklev(lev,iband) - blay + dplankdn = planklev(lev-1,iband) - blay + odepth = secdiff(iband) * taut(lev,igc) + if (odepth .lt. 0.0_rb) odepth = 0.0_rb +! Cloudy layer + if (icldlyr(lev).eq.1) then + iclddn = 1 + odtot = odepth + odcld(lev,igc) + if (odtot .lt. 0.06_rb) then + atrans(lev) = odepth - 0.5_rb*odepth*odepth odepth_rec = rec_6*odepth - gassrc = plfrac*(blay+dplankdn*odepth_rec)*atrans(lev) - - atot(lev) = odtot - 0.5_rb*odtot*odtot - odtot_rec = rec_6*odtot - bbdtot = plfrac * (blay+dplankdn*odtot_rec) - bbd = plfrac*(blay+dplankdn*odepth_rec) + gassrc = plfrac*(blay+dplankdn*odepth_rec)*atrans(lev) + + atot(lev) = odtot - 0.5_rb*odtot*odtot + odtot_rec = rec_6*odtot + bbdtot = plfrac * (blay+dplankdn*odtot_rec) + bbd = plfrac*(blay+dplankdn*odepth_rec) radld = radld - radld * (atrans(lev) + & & efclfrac(lev,igc) * (1. - atrans(lev))) + & & gassrc + cldfmc(igc,lev) * & - & (bbdtot * atot(lev) - gassrc) - drad(lev-1) = drad(lev-1) + radld - - bbugas(lev) = plfrac * (blay+dplankup*odepth_rec) - bbutot(lev) = plfrac * (blay+dplankup*odtot_rec) - - elseif (odepth .le. 0.06_rb) then - atrans(lev) = odepth - 0.5_rb*odepth*odepth - odepth_rec = rec_6*odepth - gassrc = plfrac*(blay+dplankdn*odepth_rec)*atrans(lev) - - odtot = odepth + odcld(lev,igc) - tblind = odtot/(bpade+odtot) - ittot = tblint*tblind + 0.5_rb - tfactot = tfn_tbl(ittot) - bbdtot = plfrac * (blay + tfactot*dplankdn) - bbd = plfrac*(blay+dplankdn*odepth_rec) - atot(lev) = 1. - exp_tbl(ittot) - + & (bbdtot * atot(lev) - gassrc) + drad(lev-1) = drad(lev-1) + radld + + bbugas(lev) = plfrac * (blay+dplankup*odepth_rec) + bbutot(lev) = plfrac * (blay+dplankup*odtot_rec) + + elseif (odepth .le. 0.06_rb) then + atrans(lev) = odepth - 0.5_rb*odepth*odepth + odepth_rec = rec_6*odepth + gassrc = plfrac*(blay+dplankdn*odepth_rec)*atrans(lev) + + odtot = odepth + odcld(lev,igc) + tblind = odtot/(bpade+odtot) + ittot = tblint*tblind + 0.5_rb + tfactot = tfn_tbl(ittot) + bbdtot = plfrac * (blay + tfactot*dplankdn) + bbd = plfrac*(blay+dplankdn*odepth_rec) + atot(lev) = 1. - exp_tbl(ittot) + radld = radld - radld * (atrans(lev) + & & efclfrac(lev,igc) * (1._rb - atrans(lev))) + & & gassrc + cldfmc(igc,lev) * & - & (bbdtot * atot(lev) - gassrc) - drad(lev-1) = drad(lev-1) + radld - - bbugas(lev) = plfrac * (blay + dplankup*odepth_rec) - bbutot(lev) = plfrac * (blay + tfactot * dplankup) - - else - - tblind = odepth/(bpade+odepth) - itgas = tblint*tblind+0.5_rb - odepth = tau_tbl(itgas) - atrans(lev) = 1._rb - exp_tbl(itgas) - tfacgas = tfn_tbl(itgas) - gassrc = atrans(lev) * plfrac * (blay + tfacgas*dplankdn) - - odtot = odepth + odcld(lev,igc) - tblind = odtot/(bpade+odtot) - ittot = tblint*tblind + 0.5_rb - tfactot = tfn_tbl(ittot) - bbdtot = plfrac * (blay + tfactot*dplankdn) - bbd = plfrac*(blay+tfacgas*dplankdn) - atot(lev) = 1._rb - exp_tbl(ittot) - + & (bbdtot * atot(lev) - gassrc) + drad(lev-1) = drad(lev-1) + radld + + bbugas(lev) = plfrac * (blay + dplankup*odepth_rec) + bbutot(lev) = plfrac * (blay + tfactot * dplankup) + + else + + tblind = odepth/(bpade+odepth) + itgas = tblint*tblind+0.5_rb + odepth = tau_tbl(itgas) + atrans(lev) = 1._rb - exp_tbl(itgas) + tfacgas = tfn_tbl(itgas) + gassrc = atrans(lev) * plfrac * (blay + tfacgas*dplankdn) + + odtot = odepth + odcld(lev,igc) + tblind = odtot/(bpade+odtot) + ittot = tblint*tblind + 0.5_rb + tfactot = tfn_tbl(ittot) + bbdtot = plfrac * (blay + tfactot*dplankdn) + bbd = plfrac*(blay+tfacgas*dplankdn) + atot(lev) = 1._rb - exp_tbl(ittot) + radld = radld - radld * (atrans(lev) + & & efclfrac(lev,igc) * (1._rb - atrans(lev))) + & & gassrc + cldfmc(igc,lev) * & - & (bbdtot * atot(lev) - gassrc) - drad(lev-1) = drad(lev-1) + radld - bbugas(lev) = plfrac * (blay + tfacgas * dplankup) - bbutot(lev) = plfrac * (blay + tfactot * dplankup) - endif -! Clear layer - else - if (odepth .le. 0.06_rb) then - atrans(lev) = odepth-0.5_rb*odepth*odepth - odepth = rec_6*odepth - bbd = plfrac*(blay+dplankdn*odepth) - bbugas(lev) = plfrac*(blay+dplankup*odepth) - else - tblind = odepth/(bpade+odepth) - itr = tblint*tblind+0.5_rb - transc = exp_tbl(itr) - atrans(lev) = 1._rb-transc - tausfac = tfn_tbl(itr) - bbd = plfrac*(blay+tausfac*dplankdn) - bbugas(lev) = plfrac * (blay + tausfac * dplankup) - endif - radld = radld + (bbd-radld)*atrans(lev) - drad(lev-1) = drad(lev-1) + radld - endif -! Set clear sky stream to total sky stream as long as layers -! remain clear. Streams diverge when a cloud is reached (iclddn=1), -! and clear sky stream must be computed separately from that point. - if (iclddn.eq.1) then - radclrd = radclrd + (bbd-radclrd) * atrans(lev) - clrdrad(lev-1) = clrdrad(lev-1) + radclrd - else - radclrd = radld - clrdrad(lev-1) = drad(lev-1) - endif - enddo - -! Spectral emissivity & reflectance -! Include the contribution of spectrally varying longwave emissivity -! and reflection from the surface to the upward radiative transfer. -! Note: Spectral and Lambertian reflection are identical for the -! diffusivity angle flux integration used here. - + & (bbdtot * atot(lev) - gassrc) + drad(lev-1) = drad(lev-1) + radld + bbugas(lev) = plfrac * (blay + tfacgas * dplankup) + bbutot(lev) = plfrac * (blay + tfactot * dplankup) + endif +! Clear layer + else + if (odepth .le. 0.06_rb) then + atrans(lev) = odepth-0.5_rb*odepth*odepth + odepth = rec_6*odepth + bbd = plfrac*(blay+dplankdn*odepth) + bbugas(lev) = plfrac*(blay+dplankup*odepth) + else + tblind = odepth/(bpade+odepth) + itr = tblint*tblind+0.5_rb + transc = exp_tbl(itr) + atrans(lev) = 1._rb-transc + tausfac = tfn_tbl(itr) + bbd = plfrac*(blay+tausfac*dplankdn) + bbugas(lev) = plfrac * (blay + tausfac * dplankup) + endif + radld = radld + (bbd-radld)*atrans(lev) + drad(lev-1) = drad(lev-1) + radld + endif +! Set clear sky stream to total sky stream as long as layers +! remain clear. Streams diverge when a cloud is reached (iclddn=1), +! and clear sky stream must be computed separately from that point. + if (iclddn.eq.1) then + radclrd = radclrd + (bbd-radclrd) * atrans(lev) + clrdrad(lev-1) = clrdrad(lev-1) + radclrd + else + radclrd = radld + clrdrad(lev-1) = drad(lev-1) + endif + enddo + +! Spectral emissivity & reflectance +! Include the contribution of spectrally varying longwave emissivity +! and reflection from the surface to the upward radiative transfer. +! Note: Spectral and Lambertian reflection are identical for the +! diffusivity angle flux integration used here. + !mz* -! rad0 = fracs(1,igc) * plankbnd(iband) +! rad0 = fracs(1,igc) * plankbnd(iband) rad0 = semiss(iband) * fracs(1,igc) * planklay(0,iband) !mz -! Add in specular reflection of surface downward radiance. - reflect = 1._rb - semiss(iband) - radlu = rad0 + reflect * radld - radclru = rad0 + reflect * radclrd - - -! Upward radiative transfer loop. - urad(0) = urad(0) + radlu - clrurad(0) = clrurad(0) + radclru - - do lev = 1, nlayers -! Cloudy layer - if (icldlyr(lev) .eq. 1) then +! Add in specular reflection of surface downward radiance. + reflect = 1._rb - semiss(iband) + radlu = rad0 + reflect * radld + radclru = rad0 + reflect * radclrd + + +! Upward radiative transfer loop. + urad(0) = urad(0) + radlu + clrurad(0) = clrurad(0) + radclru + + do lev = 1, nlayers +! Cloudy layer + if (icldlyr(lev) .eq. 1) then gassrc = bbugas(lev) * atrans(lev) radlu = radlu - radlu * (atrans(lev) + & & efclfrac(lev,igc) * (1._rb - atrans(lev))) + & & gassrc + cldfmc(igc,lev) * & - & (bbutot(lev) * atot(lev) - gassrc) - urad(lev) = urad(lev) + radlu -! Clear layer - else - radlu = radlu + (bbugas(lev)-radlu)*atrans(lev) - urad(lev) = urad(lev) + radlu - endif -! Set clear sky stream to total sky stream as long as all layers -! are clear (iclddn=0). Streams must be calculated separately at -! all layers when a cloud is present (ICLDDN=1), because surface -! reflectance is different for each stream. - if (iclddn.eq.1) then - radclru = radclru + (bbugas(lev)-radclru)*atrans(lev) - clrurad(lev) = clrurad(lev) + radclru - else - radclru = radlu - clrurad(lev) = urad(lev) - endif - enddo - -! Increment g-point counter - igc = igc + 1 -! Return to continue radiative transfer for all g-channels in present band - if (igc .le. ngs(iband)) go to 1000 - -! Process longwave output from band for total and clear streams. -! Calculate upward, downward, and net flux. - do lev = nlayers, 0, -1 - uflux(lev) = urad(lev)*wtdiff - dflux(lev) = drad(lev)*wtdiff - urad(lev) = 0.0_rb - drad(lev) = 0.0_rb - totuflux(lev) = totuflux(lev) + uflux(lev) * delwave(iband) - totdflux(lev) = totdflux(lev) + dflux(lev) * delwave(iband) - uclfl(lev) = clrurad(lev)*wtdiff - dclfl(lev) = clrdrad(lev)*wtdiff - clrurad(lev) = 0.0_rb - clrdrad(lev) = 0.0_rb - totuclfl(lev) = totuclfl(lev) + uclfl(lev) * delwave(iband) - totdclfl(lev) = totdclfl(lev) + dclfl(lev) * delwave(iband) - enddo - -! End spectral band loop - enddo - -! Calculate fluxes at surface - totuflux(0) = totuflux(0) * fluxfac - totdflux(0) = totdflux(0) * fluxfac - fnet(0) = totuflux(0) - totdflux(0) - totuclfl(0) = totuclfl(0) * fluxfac - totdclfl(0) = totdclfl(0) * fluxfac - fnetc(0) = totuclfl(0) - totdclfl(0) - -! Calculate fluxes at model levels - do lev = 1, nlayers - totuflux(lev) = totuflux(lev) * fluxfac - totdflux(lev) = totdflux(lev) * fluxfac - fnet(lev) = totuflux(lev) - totdflux(lev) - totuclfl(lev) = totuclfl(lev) * fluxfac - totdclfl(lev) = totdclfl(lev) * fluxfac - fnetc(lev) = totuclfl(lev) - totdclfl(lev) - l = lev - 1 - -! Calculate heating rates at model layers - htr(l)=heatfac*(fnet(l)-fnet(lev))/(pz(l)-pz(lev)) - htrc(l)=heatfac*(fnetc(l)-fnetc(lev))/(pz(l)-pz(lev)) - enddo - -! Set heating rate to zero in top layer - htr(nlayers) = 0.0_rb - htrc(nlayers) = 0.0_rb - - end subroutine rtrnmc_mcica + & (bbutot(lev) * atot(lev) - gassrc) + urad(lev) = urad(lev) + radlu +! Clear layer + else + radlu = radlu + (bbugas(lev)-radlu)*atrans(lev) + urad(lev) = urad(lev) + radlu + endif +! Set clear sky stream to total sky stream as long as all layers +! are clear (iclddn=0). Streams must be calculated separately at +! all layers when a cloud is present (ICLDDN=1), because surface +! reflectance is different for each stream. + if (iclddn.eq.1) then + radclru = radclru + (bbugas(lev)-radclru)*atrans(lev) + clrurad(lev) = clrurad(lev) + radclru + else + radclru = radlu + clrurad(lev) = urad(lev) + endif + enddo + +! Increment g-point counter + igc = igc + 1 +! Return to continue radiative transfer for all g-channels in present band + if (igc .le. ngs(iband)) go to 1000 + +! Process longwave output from band for total and clear streams. +! Calculate upward, downward, and net flux. + do lev = nlayers, 0, -1 + uflux(lev) = urad(lev)*wtdiff + dflux(lev) = drad(lev)*wtdiff + urad(lev) = 0.0_rb + drad(lev) = 0.0_rb + totuflux(lev) = totuflux(lev) + uflux(lev) * delwave(iband) + totdflux(lev) = totdflux(lev) + dflux(lev) * delwave(iband) + uclfl(lev) = clrurad(lev)*wtdiff + dclfl(lev) = clrdrad(lev)*wtdiff + clrurad(lev) = 0.0_rb + clrdrad(lev) = 0.0_rb + totuclfl(lev) = totuclfl(lev) + uclfl(lev) * delwave(iband) + totdclfl(lev) = totdclfl(lev) + dclfl(lev) * delwave(iband) + enddo + +! End spectral band loop + enddo + +! Calculate fluxes at surface + totuflux(0) = totuflux(0) * fluxfac + totdflux(0) = totdflux(0) * fluxfac + fnet(0) = totuflux(0) - totdflux(0) + totuclfl(0) = totuclfl(0) * fluxfac + totdclfl(0) = totdclfl(0) * fluxfac + fnetc(0) = totuclfl(0) - totdclfl(0) + +! Calculate fluxes at model levels + do lev = 1, nlayers + totuflux(lev) = totuflux(lev) * fluxfac + totdflux(lev) = totdflux(lev) * fluxfac + fnet(lev) = totuflux(lev) - totdflux(lev) + totuclfl(lev) = totuclfl(lev) * fluxfac + totdclfl(lev) = totdclfl(lev) * fluxfac + fnetc(lev) = totuclfl(lev) - totdclfl(lev) + l = lev - 1 + +! Calculate heating rates at model layers + htr(l)=heatfac*(fnet(l)-fnet(lev))/(pz(l)-pz(lev)) + htrc(l)=heatfac*(fnetc(l)-fnetc(lev))/(pz(l)-pz(lev)) + enddo + +! Set heating rate to zero in top layer + htr(nlayers) = 0.0_rb + htrc(nlayers) = 0.0_rb + + end subroutine rtrnmc_mcica ! ------------------------------------------------------------------------------ subroutine cldprmc(nlayers, inflag, iceflag, liqflag, cldfmc, & @@ -8007,59 +8007,59 @@ subroutine cldprmc(nlayers, inflag, iceflag, liqflag, cldfmc, & integer(kind=im) :: lay ! Layer index integer(kind=im) :: ib ! spectral band index integer(kind=im) :: ig ! g-point interval index - integer(kind=im) :: index - integer(kind=im) :: icb(nbands) + integer(kind=im) :: index + integer(kind=im) :: icb(nbands) real(kind=rb) , dimension(2) :: absice0 real(kind=rb) , dimension(2,5) :: absice1 real(kind=rb) , dimension(43,16) :: absice2 real(kind=rb) , dimension(46,16) :: absice3 real(kind=rb) :: absliq0 real(kind=rb) , dimension(58,16) :: absliq1 - - real(kind=rb) :: abscoice(ngptlw) ! ice absorption coefficients - real(kind=rb) :: abscoliq(ngptlw) ! liquid absorption coefficients - real(kind=rb) :: abscosno(ngptlw) ! snow absorption coefficients - real(kind=rb) :: cwp ! cloud water path - real(kind=rb) :: radice ! cloud ice effective size (microns) - real(kind=rb) :: factor ! - real(kind=rb) :: fint ! - real(kind=rb) :: radliq ! cloud liquid droplet radius (microns) - real(kind=rb) :: radsno ! cloud snow effective size (microns) - real(kind=rb), parameter :: eps = 1.e-6_rb ! epsilon - real(kind=rb), parameter :: cldmin = 1.e-20_rb ! minimum value for cloud quantities - character*80 errmess - -! ------- Definitions ------- - -! Explanation of the method for each value of INFLAG. Values of -! 0 or 1 for INFLAG do not distingish being liquid and ice clouds. -! INFLAG = 2 does distinguish between liquid and ice clouds, and -! requires further user input to specify the method to be used to -! compute the aborption due to each. -! INFLAG = 0: For each cloudy layer, the cloud fraction and (gray) -! optical depth are input. -! INFLAG = 1: For each cloudy layer, the cloud fraction and cloud -! water path (g/m2) are input. The (gray) cloud optical -! depth is computed as in CCM2. -! INFLAG = 2: For each cloudy layer, the cloud fraction, cloud -! water path (g/m2), and cloud ice fraction are input. -! ICEFLAG = 0: The ice effective radius (microns) is input and the -! optical depths due to ice clouds are computed as in CCM3. -! ICEFLAG = 1: The ice effective radius (microns) is input and the -! optical depths due to ice clouds are computed as in -! Ebert and Curry, JGR, 97, 3831-3836 (1992). The -! spectral regions in this work have been matched with -! the spectral bands in RRTM to as great an extent -! as possible: -! E&C 1 IB = 5 RRTM bands 9-16 -! E&C 2 IB = 4 RRTM bands 6-8 -! E&C 3 IB = 3 RRTM bands 3-5 -! E&C 4 IB = 2 RRTM band 2 -! E&C 5 IB = 1 RRTM band 1 + + real(kind=rb) :: abscoice(ngptlw) ! ice absorption coefficients + real(kind=rb) :: abscoliq(ngptlw) ! liquid absorption coefficients + real(kind=rb) :: abscosno(ngptlw) ! snow absorption coefficients + real(kind=rb) :: cwp ! cloud water path + real(kind=rb) :: radice ! cloud ice effective size (microns) + real(kind=rb) :: factor ! + real(kind=rb) :: fint ! + real(kind=rb) :: radliq ! cloud liquid droplet radius (microns) + real(kind=rb) :: radsno ! cloud snow effective size (microns) + real(kind=rb), parameter :: eps = 1.e-6_rb ! epsilon + real(kind=rb), parameter :: cldmin = 1.e-20_rb ! minimum value for cloud quantities + character*80 errmess + +! ------- Definitions ------- + +! Explanation of the method for each value of INFLAG. Values of +! 0 or 1 for INFLAG do not distingish being liquid and ice clouds. +! INFLAG = 2 does distinguish between liquid and ice clouds, and +! requires further user input to specify the method to be used to +! compute the aborption due to each. +! INFLAG = 0: For each cloudy layer, the cloud fraction and (gray) +! optical depth are input. +! INFLAG = 1: For each cloudy layer, the cloud fraction and cloud +! water path (g/m2) are input. The (gray) cloud optical +! depth is computed as in CCM2. +! INFLAG = 2: For each cloudy layer, the cloud fraction, cloud +! water path (g/m2), and cloud ice fraction are input. +! ICEFLAG = 0: The ice effective radius (microns) is input and the +! optical depths due to ice clouds are computed as in CCM3. +! ICEFLAG = 1: The ice effective radius (microns) is input and the +! optical depths due to ice clouds are computed as in +! Ebert and Curry, JGR, 97, 3831-3836 (1992). The +! spectral regions in this work have been matched with +! the spectral bands in RRTM to as great an extent +! as possible: +! E&C 1 IB = 5 RRTM bands 9-16 +! E&C 2 IB = 4 RRTM bands 6-8 +! E&C 3 IB = 3 RRTM bands 3-5 +! E&C 4 IB = 2 RRTM band 2 +! E&C 5 IB = 1 RRTM band 1 ! ICEFLAG = 2: The ice effective radius (microns) is input and the ! optical properties due to ice clouds are computed from ! the optical properties stored in the RT code, -! STREAMER v3.0 (Reference: Key. J., Streamer +! STREAMER v3.0 (Reference: Key. J., Streamer ! User's Guide, Cooperative Institute for ! Meteorological Satellite Studies, 2001, 96 pp.). ! Valid range of values for re are between 5.0 and @@ -8074,20 +8074,20 @@ subroutine cldprmc(nlayers, inflag, iceflag, liqflag, cldfmc, & ! 140.0 micron. ! LIQFLAG = 0: The optical depths due to water clouds are computed as ! in CCM3. -! LIQFLAG = 1: The water droplet effective radius (microns) is input -! and the optical depths due to water clouds are computed +! LIQFLAG = 1: The water droplet effective radius (microns) is input +! and the optical depths due to water clouds are computed ! as in Hu and Stamnes, J., Clim., 6, 728-742, (1993). ! The values for absorption coefficients appropriate for -! the spectral bands in RRTM have been obtained for a -! range of effective radii by an averaging procedure +! the spectral bands in RRTM have been obtained for a +! range of effective radii by an averaging procedure ! based on the work of J. Pinto (private communication). -! Linear interpolation is used to get the absorption +! Linear interpolation is used to get the absorption ! coefficients for the input effective radius. data icb /1,2,3,3,3,4,4,4,5, 5, 5, 5, 5, 5, 5, 5/ ! Everything below is for INFLAG = 2. -! ABSICEn(J,IB) are the parameters needed to compute the liquid water +! ABSICEn(J,IB) are the parameters needed to compute the liquid water ! absorption coefficient in spectral region IB for ICEFLAG=n. The units ! of ABSICEn(1,IB) are m2/g and ABSICEn(2,IB) has units (microns (m2/g)). ! For ICEFLAG = 0. @@ -8142,57 +8142,57 @@ subroutine cldprmc(nlayers, inflag, iceflag, liqflag, cldfmc, & ! band 4 1.804566e-01_rb,1.168987e-01_rb,8.680442e-02_rb,6.910060e-02_rb,5.738174e-02_rb, & 4.902332e-02_rb,4.274585e-02_rb,3.784923e-02_rb,3.391734e-02_rb,3.068690e-02_rb, & - 2.798301e-02_rb,2.568480e-02_rb,2.370600e-02_rb,2.198337e-02_rb,2.046940e-02_rb, & - 1.912777e-02_rb,1.793016e-02_rb,1.685420e-02_rb,1.588193e-02_rb,1.499882e-02_rb, & - 1.419293e-02_rb,1.345440e-02_rb,1.277496e-02_rb,1.214769e-02_rb,1.156669e-02_rb, & - 1.102694e-02_rb,1.052412e-02_rb,1.005451e-02_rb,9.614854e-03_rb,9.202335e-03_rb, & - 8.814470e-03_rb,8.449077e-03_rb,8.104223e-03_rb,7.778195e-03_rb,7.469466e-03_rb, & - 7.176671e-03_rb,6.898588e-03_rb,6.634117e-03_rb,6.382264e-03_rb,6.142134e-03_rb, & - 5.912913e-03_rb,5.693862e-03_rb,5.484308e-03_rb/) - absice2(:,5) = (/ & -! band 5 - 2.131806e-01_rb,1.311372e-01_rb,9.407171e-02_rb,7.299442e-02_rb,5.941273e-02_rb, & - 4.994043e-02_rb,4.296242e-02_rb,3.761113e-02_rb,3.337910e-02_rb,2.994978e-02_rb, & - 2.711556e-02_rb,2.473461e-02_rb,2.270681e-02_rb,2.095943e-02_rb,1.943839e-02_rb, & - 1.810267e-02_rb,1.692057e-02_rb,1.586719e-02_rb,1.492275e-02_rb,1.407132e-02_rb, & - 1.329989e-02_rb,1.259780e-02_rb,1.195618e-02_rb,1.136761e-02_rb,1.082583e-02_rb, & - 1.032552e-02_rb,9.862158e-03_rb,9.431827e-03_rb,9.031157e-03_rb,8.657217e-03_rb, & - 8.307449e-03_rb,7.979609e-03_rb,7.671724e-03_rb,7.382048e-03_rb,7.109032e-03_rb, & - 6.851298e-03_rb,6.607615e-03_rb,6.376881e-03_rb,6.158105e-03_rb,5.950394e-03_rb, & - 5.752942e-03_rb,5.565019e-03_rb,5.385963e-03_rb/) - absice2(:,6) = (/ & -! band 6 - 1.546177e-01_rb,1.039251e-01_rb,7.910347e-02_rb,6.412429e-02_rb,5.399997e-02_rb, & - 4.664937e-02_rb,4.104237e-02_rb,3.660781e-02_rb,3.300218e-02_rb,3.000586e-02_rb, & - 2.747148e-02_rb,2.529633e-02_rb,2.340647e-02_rb,2.174723e-02_rb,2.027731e-02_rb, & - 1.896487e-02_rb,1.778492e-02_rb,1.671761e-02_rb,1.574692e-02_rb,1.485978e-02_rb, & - 1.404543e-02_rb,1.329489e-02_rb,1.260066e-02_rb,1.195636e-02_rb,1.135657e-02_rb, & - 1.079664e-02_rb,1.027257e-02_rb,9.780871e-03_rb,9.318505e-03_rb,8.882815e-03_rb, & - 8.471458e-03_rb,8.082364e-03_rb,7.713696e-03_rb,7.363817e-03_rb,7.031264e-03_rb, & - 6.714725e-03_rb,6.413021e-03_rb,6.125086e-03_rb,5.849958e-03_rb,5.586764e-03_rb, & - 5.334707e-03_rb,5.093066e-03_rb,4.861179e-03_rb/) - absice2(:,7) = (/ & -! band 7 - 7.583404e-02_rb,6.181558e-02_rb,5.312027e-02_rb,4.696039e-02_rb,4.225986e-02_rb, & - 3.849735e-02_rb,3.538340e-02_rb,3.274182e-02_rb,3.045798e-02_rb,2.845343e-02_rb, & - 2.667231e-02_rb,2.507353e-02_rb,2.362606e-02_rb,2.230595e-02_rb,2.109435e-02_rb, & - 1.997617e-02_rb,1.893916e-02_rb,1.797328e-02_rb,1.707016e-02_rb,1.622279e-02_rb, & - 1.542523e-02_rb,1.467241e-02_rb,1.395997e-02_rb,1.328414e-02_rb,1.264164e-02_rb, & - 1.202958e-02_rb,1.144544e-02_rb,1.088697e-02_rb,1.035218e-02_rb,9.839297e-03_rb, & - 9.346733e-03_rb,8.873057e-03_rb,8.416980e-03_rb,7.977335e-03_rb,7.553066e-03_rb, & - 7.143210e-03_rb,6.746888e-03_rb,6.363297e-03_rb,5.991700e-03_rb,5.631422e-03_rb, & - 5.281840e-03_rb,4.942378e-03_rb,4.612505e-03_rb/) - absice2(:,8) = (/ & -! band 8 - 9.022185e-02_rb,6.922700e-02_rb,5.710674e-02_rb,4.898377e-02_rb,4.305946e-02_rb, & - 3.849553e-02_rb,3.484183e-02_rb,3.183220e-02_rb,2.929794e-02_rb,2.712627e-02_rb, & - 2.523856e-02_rb,2.357810e-02_rb,2.210286e-02_rb,2.078089e-02_rb,1.958747e-02_rb, & - 1.850310e-02_rb,1.751218e-02_rb,1.660205e-02_rb,1.576232e-02_rb,1.498440e-02_rb, & - 1.426107e-02_rb,1.358624e-02_rb,1.295474e-02_rb,1.236212e-02_rb,1.180456e-02_rb, & - 1.127874e-02_rb,1.078175e-02_rb,1.031106e-02_rb,9.864433e-03_rb,9.439878e-03_rb, & - 9.035637e-03_rb,8.650140e-03_rb,8.281981e-03_rb,7.929895e-03_rb,7.592746e-03_rb, & - 7.269505e-03_rb,6.959238e-03_rb,6.661100e-03_rb,6.374317e-03_rb,6.098185e-03_rb, & - 5.832059e-03_rb,5.575347e-03_rb,5.327504e-03_rb/) + 2.798301e-02_rb,2.568480e-02_rb,2.370600e-02_rb,2.198337e-02_rb,2.046940e-02_rb, & + 1.912777e-02_rb,1.793016e-02_rb,1.685420e-02_rb,1.588193e-02_rb,1.499882e-02_rb, & + 1.419293e-02_rb,1.345440e-02_rb,1.277496e-02_rb,1.214769e-02_rb,1.156669e-02_rb, & + 1.102694e-02_rb,1.052412e-02_rb,1.005451e-02_rb,9.614854e-03_rb,9.202335e-03_rb, & + 8.814470e-03_rb,8.449077e-03_rb,8.104223e-03_rb,7.778195e-03_rb,7.469466e-03_rb, & + 7.176671e-03_rb,6.898588e-03_rb,6.634117e-03_rb,6.382264e-03_rb,6.142134e-03_rb, & + 5.912913e-03_rb,5.693862e-03_rb,5.484308e-03_rb/) + absice2(:,5) = (/ & +! band 5 + 2.131806e-01_rb,1.311372e-01_rb,9.407171e-02_rb,7.299442e-02_rb,5.941273e-02_rb, & + 4.994043e-02_rb,4.296242e-02_rb,3.761113e-02_rb,3.337910e-02_rb,2.994978e-02_rb, & + 2.711556e-02_rb,2.473461e-02_rb,2.270681e-02_rb,2.095943e-02_rb,1.943839e-02_rb, & + 1.810267e-02_rb,1.692057e-02_rb,1.586719e-02_rb,1.492275e-02_rb,1.407132e-02_rb, & + 1.329989e-02_rb,1.259780e-02_rb,1.195618e-02_rb,1.136761e-02_rb,1.082583e-02_rb, & + 1.032552e-02_rb,9.862158e-03_rb,9.431827e-03_rb,9.031157e-03_rb,8.657217e-03_rb, & + 8.307449e-03_rb,7.979609e-03_rb,7.671724e-03_rb,7.382048e-03_rb,7.109032e-03_rb, & + 6.851298e-03_rb,6.607615e-03_rb,6.376881e-03_rb,6.158105e-03_rb,5.950394e-03_rb, & + 5.752942e-03_rb,5.565019e-03_rb,5.385963e-03_rb/) + absice2(:,6) = (/ & +! band 6 + 1.546177e-01_rb,1.039251e-01_rb,7.910347e-02_rb,6.412429e-02_rb,5.399997e-02_rb, & + 4.664937e-02_rb,4.104237e-02_rb,3.660781e-02_rb,3.300218e-02_rb,3.000586e-02_rb, & + 2.747148e-02_rb,2.529633e-02_rb,2.340647e-02_rb,2.174723e-02_rb,2.027731e-02_rb, & + 1.896487e-02_rb,1.778492e-02_rb,1.671761e-02_rb,1.574692e-02_rb,1.485978e-02_rb, & + 1.404543e-02_rb,1.329489e-02_rb,1.260066e-02_rb,1.195636e-02_rb,1.135657e-02_rb, & + 1.079664e-02_rb,1.027257e-02_rb,9.780871e-03_rb,9.318505e-03_rb,8.882815e-03_rb, & + 8.471458e-03_rb,8.082364e-03_rb,7.713696e-03_rb,7.363817e-03_rb,7.031264e-03_rb, & + 6.714725e-03_rb,6.413021e-03_rb,6.125086e-03_rb,5.849958e-03_rb,5.586764e-03_rb, & + 5.334707e-03_rb,5.093066e-03_rb,4.861179e-03_rb/) + absice2(:,7) = (/ & +! band 7 + 7.583404e-02_rb,6.181558e-02_rb,5.312027e-02_rb,4.696039e-02_rb,4.225986e-02_rb, & + 3.849735e-02_rb,3.538340e-02_rb,3.274182e-02_rb,3.045798e-02_rb,2.845343e-02_rb, & + 2.667231e-02_rb,2.507353e-02_rb,2.362606e-02_rb,2.230595e-02_rb,2.109435e-02_rb, & + 1.997617e-02_rb,1.893916e-02_rb,1.797328e-02_rb,1.707016e-02_rb,1.622279e-02_rb, & + 1.542523e-02_rb,1.467241e-02_rb,1.395997e-02_rb,1.328414e-02_rb,1.264164e-02_rb, & + 1.202958e-02_rb,1.144544e-02_rb,1.088697e-02_rb,1.035218e-02_rb,9.839297e-03_rb, & + 9.346733e-03_rb,8.873057e-03_rb,8.416980e-03_rb,7.977335e-03_rb,7.553066e-03_rb, & + 7.143210e-03_rb,6.746888e-03_rb,6.363297e-03_rb,5.991700e-03_rb,5.631422e-03_rb, & + 5.281840e-03_rb,4.942378e-03_rb,4.612505e-03_rb/) + absice2(:,8) = (/ & +! band 8 + 9.022185e-02_rb,6.922700e-02_rb,5.710674e-02_rb,4.898377e-02_rb,4.305946e-02_rb, & + 3.849553e-02_rb,3.484183e-02_rb,3.183220e-02_rb,2.929794e-02_rb,2.712627e-02_rb, & + 2.523856e-02_rb,2.357810e-02_rb,2.210286e-02_rb,2.078089e-02_rb,1.958747e-02_rb, & + 1.850310e-02_rb,1.751218e-02_rb,1.660205e-02_rb,1.576232e-02_rb,1.498440e-02_rb, & + 1.426107e-02_rb,1.358624e-02_rb,1.295474e-02_rb,1.236212e-02_rb,1.180456e-02_rb, & + 1.127874e-02_rb,1.078175e-02_rb,1.031106e-02_rb,9.864433e-03_rb,9.439878e-03_rb, & + 9.035637e-03_rb,8.650140e-03_rb,8.281981e-03_rb,7.929895e-03_rb,7.592746e-03_rb, & + 7.269505e-03_rb,6.959238e-03_rb,6.661100e-03_rb,6.374317e-03_rb,6.098185e-03_rb, & + 5.832059e-03_rb,5.575347e-03_rb,5.327504e-03_rb/) absice2(:,9) = (/ & ! band 9 1.294087e-01_rb,8.788217e-02_rb,6.728288e-02_rb,5.479720e-02_rb,4.635049e-02_rb, & @@ -8210,79 +8210,79 @@ subroutine cldprmc(nlayers, inflag, iceflag, liqflag, cldfmc, & 4.171159e-02_rb,3.638480e-02_rb,3.226692e-02_rb,2.898717e-02_rb,2.631256e-02_rb, & 2.408925e-02_rb,2.221156e-02_rb,2.060448e-02_rb,1.921325e-02_rb,1.799699e-02_rb, & 1.692456e-02_rb,1.597177e-02_rb,1.511961e-02_rb,1.435289e-02_rb,1.365933e-02_rb, & - 1.302890e-02_rb,1.245334e-02_rb,1.192576e-02_rb,1.144037e-02_rb,1.099230e-02_rb, & - 1.057739e-02_rb,1.019208e-02_rb,9.833302e-03_rb,9.498395e-03_rb,9.185047e-03_rb, & - 8.891237e-03_rb,8.615185e-03_rb,8.355325e-03_rb,8.110267e-03_rb,7.878778e-03_rb, & - 7.659759e-03_rb,7.452224e-03_rb,7.255291e-03_rb,7.068166e-03_rb,6.890130e-03_rb, & - 6.720536e-03_rb,6.558794e-03_rb,6.404371e-03_rb/) - absice2(:,11) = (/ & -! band 11 - 1.656227e-01_rb,1.032129e-01_rb,7.487359e-02_rb,5.871431e-02_rb,4.828355e-02_rb, & - 4.099989e-02_rb,3.562924e-02_rb,3.150755e-02_rb,2.824593e-02_rb,2.560156e-02_rb, & - 2.341503e-02_rb,2.157740e-02_rb,2.001169e-02_rb,1.866199e-02_rb,1.748669e-02_rb, & - 1.645421e-02_rb,1.554015e-02_rb,1.472535e-02_rb,1.399457e-02_rb,1.333553e-02_rb, & - 1.273821e-02_rb,1.219440e-02_rb,1.169725e-02_rb,1.124104e-02_rb,1.082096e-02_rb, & - 1.043290e-02_rb,1.007336e-02_rb,9.739338e-03_rb,9.428223e-03_rb,9.137756e-03_rb, & - 8.865964e-03_rb,8.611115e-03_rb,8.371686e-03_rb,8.146330e-03_rb,7.933852e-03_rb, & - 7.733187e-03_rb,7.543386e-03_rb,7.363597e-03_rb,7.193056e-03_rb,7.031072e-03_rb, & - 6.877024e-03_rb,6.730348e-03_rb,6.590531e-03_rb/) - absice2(:,12) = (/ & -! band 12 - 9.194591e-02_rb,6.446867e-02_rb,4.962034e-02_rb,4.042061e-02_rb,3.418456e-02_rb, & - 2.968856e-02_rb,2.629900e-02_rb,2.365572e-02_rb,2.153915e-02_rb,1.980791e-02_rb, & - 1.836689e-02_rb,1.714979e-02_rb,1.610900e-02_rb,1.520946e-02_rb,1.442476e-02_rb, & - 1.373468e-02_rb,1.312345e-02_rb,1.257858e-02_rb,1.209010e-02_rb,1.164990e-02_rb, & - 1.125136e-02_rb,1.088901e-02_rb,1.055827e-02_rb,1.025531e-02_rb,9.976896e-03_rb, & - 9.720255e-03_rb,9.483022e-03_rb,9.263160e-03_rb,9.058902e-03_rb,8.868710e-03_rb, & - 8.691240e-03_rb,8.525312e-03_rb,8.369886e-03_rb,8.224042e-03_rb,8.086961e-03_rb, & - 7.957917e-03_rb,7.836258e-03_rb,7.721400e-03_rb,7.612821e-03_rb,7.510045e-03_rb, & - 7.412648e-03_rb,7.320242e-03_rb,7.232476e-03_rb/) + 1.302890e-02_rb,1.245334e-02_rb,1.192576e-02_rb,1.144037e-02_rb,1.099230e-02_rb, & + 1.057739e-02_rb,1.019208e-02_rb,9.833302e-03_rb,9.498395e-03_rb,9.185047e-03_rb, & + 8.891237e-03_rb,8.615185e-03_rb,8.355325e-03_rb,8.110267e-03_rb,7.878778e-03_rb, & + 7.659759e-03_rb,7.452224e-03_rb,7.255291e-03_rb,7.068166e-03_rb,6.890130e-03_rb, & + 6.720536e-03_rb,6.558794e-03_rb,6.404371e-03_rb/) + absice2(:,11) = (/ & +! band 11 + 1.656227e-01_rb,1.032129e-01_rb,7.487359e-02_rb,5.871431e-02_rb,4.828355e-02_rb, & + 4.099989e-02_rb,3.562924e-02_rb,3.150755e-02_rb,2.824593e-02_rb,2.560156e-02_rb, & + 2.341503e-02_rb,2.157740e-02_rb,2.001169e-02_rb,1.866199e-02_rb,1.748669e-02_rb, & + 1.645421e-02_rb,1.554015e-02_rb,1.472535e-02_rb,1.399457e-02_rb,1.333553e-02_rb, & + 1.273821e-02_rb,1.219440e-02_rb,1.169725e-02_rb,1.124104e-02_rb,1.082096e-02_rb, & + 1.043290e-02_rb,1.007336e-02_rb,9.739338e-03_rb,9.428223e-03_rb,9.137756e-03_rb, & + 8.865964e-03_rb,8.611115e-03_rb,8.371686e-03_rb,8.146330e-03_rb,7.933852e-03_rb, & + 7.733187e-03_rb,7.543386e-03_rb,7.363597e-03_rb,7.193056e-03_rb,7.031072e-03_rb, & + 6.877024e-03_rb,6.730348e-03_rb,6.590531e-03_rb/) + absice2(:,12) = (/ & +! band 12 + 9.194591e-02_rb,6.446867e-02_rb,4.962034e-02_rb,4.042061e-02_rb,3.418456e-02_rb, & + 2.968856e-02_rb,2.629900e-02_rb,2.365572e-02_rb,2.153915e-02_rb,1.980791e-02_rb, & + 1.836689e-02_rb,1.714979e-02_rb,1.610900e-02_rb,1.520946e-02_rb,1.442476e-02_rb, & + 1.373468e-02_rb,1.312345e-02_rb,1.257858e-02_rb,1.209010e-02_rb,1.164990e-02_rb, & + 1.125136e-02_rb,1.088901e-02_rb,1.055827e-02_rb,1.025531e-02_rb,9.976896e-03_rb, & + 9.720255e-03_rb,9.483022e-03_rb,9.263160e-03_rb,9.058902e-03_rb,8.868710e-03_rb, & + 8.691240e-03_rb,8.525312e-03_rb,8.369886e-03_rb,8.224042e-03_rb,8.086961e-03_rb, & + 7.957917e-03_rb,7.836258e-03_rb,7.721400e-03_rb,7.612821e-03_rb,7.510045e-03_rb, & + 7.412648e-03_rb,7.320242e-03_rb,7.232476e-03_rb/) absice2(:,13) = (/ & -! band 13 - 1.437021e-01_rb,8.872535e-02_rb,6.392420e-02_rb,4.991833e-02_rb,4.096790e-02_rb, & - 3.477881e-02_rb,3.025782e-02_rb,2.681909e-02_rb,2.412102e-02_rb,2.195132e-02_rb, & - 2.017124e-02_rb,1.868641e-02_rb,1.743044e-02_rb,1.635529e-02_rb,1.542540e-02_rb, & - 1.461388e-02_rb,1.390003e-02_rb,1.326766e-02_rb,1.270395e-02_rb,1.219860e-02_rb, & - 1.174326e-02_rb,1.133107e-02_rb,1.095637e-02_rb,1.061442e-02_rb,1.030126e-02_rb, & - 1.001352e-02_rb,9.748340e-03_rb,9.503256e-03_rb,9.276155e-03_rb,9.065205e-03_rb, & - 8.868808e-03_rb,8.685571e-03_rb,8.514268e-03_rb,8.353820e-03_rb,8.203272e-03_rb, & - 8.061776e-03_rb,7.928578e-03_rb,7.803001e-03_rb,7.684443e-03_rb,7.572358e-03_rb, & - 7.466258e-03_rb,7.365701e-03_rb,7.270286e-03_rb/) - absice2(:,14) = (/ & -! band 14 - 1.288870e-01_rb,8.160295e-02_rb,5.964745e-02_rb,4.703790e-02_rb,3.888637e-02_rb, & - 3.320115e-02_rb,2.902017e-02_rb,2.582259e-02_rb,2.330224e-02_rb,2.126754e-02_rb, & - 1.959258e-02_rb,1.819130e-02_rb,1.700289e-02_rb,1.598320e-02_rb,1.509942e-02_rb, & - 1.432666e-02_rb,1.364572e-02_rb,1.304156e-02_rb,1.250220e-02_rb,1.201803e-02_rb, & - 1.158123e-02_rb,1.118537e-02_rb,1.082513e-02_rb,1.049605e-02_rb,1.019440e-02_rb, & - 9.916989e-03_rb,9.661116e-03_rb,9.424457e-03_rb,9.205005e-03_rb,9.001022e-03_rb, & - 8.810992e-03_rb,8.633588e-03_rb,8.467646e-03_rb,8.312137e-03_rb,8.166151e-03_rb, & - 8.028878e-03_rb,7.899597e-03_rb,7.777663e-03_rb,7.662498e-03_rb,7.553581e-03_rb, & - 7.450444e-03_rb,7.352662e-03_rb,7.259851e-03_rb/) - absice2(:,15) = (/ & -! band 15 - 8.254229e-02_rb,5.808787e-02_rb,4.492166e-02_rb,3.675028e-02_rb,3.119623e-02_rb, & - 2.718045e-02_rb,2.414450e-02_rb,2.177073e-02_rb,1.986526e-02_rb,1.830306e-02_rb, & - 1.699991e-02_rb,1.589698e-02_rb,1.495199e-02_rb,1.413374e-02_rb,1.341870e-02_rb, & - 1.278883e-02_rb,1.223002e-02_rb,1.173114e-02_rb,1.128322e-02_rb,1.087900e-02_rb, & - 1.051254e-02_rb,1.017890e-02_rb,9.873991e-03_rb,9.594347e-03_rb,9.337044e-03_rb, & - 9.099589e-03_rb,8.879842e-03_rb,8.675960e-03_rb,8.486341e-03_rb,8.309594e-03_rb, & - 8.144500e-03_rb,7.989986e-03_rb,7.845109e-03_rb,7.709031e-03_rb,7.581007e-03_rb, & - 7.460376e-03_rb,7.346544e-03_rb,7.238978e-03_rb,7.137201e-03_rb,7.040780e-03_rb, & - 6.949325e-03_rb,6.862483e-03_rb,6.779931e-03_rb/) - absice2(:,16) = (/ & -! band 16 - 1.382062e-01_rb,8.643227e-02_rb,6.282935e-02_rb,4.934783e-02_rb,4.063891e-02_rb, & - 3.455591e-02_rb,3.007059e-02_rb,2.662897e-02_rb,2.390631e-02_rb,2.169972e-02_rb, & - 1.987596e-02_rb,1.834393e-02_rb,1.703924e-02_rb,1.591513e-02_rb,1.493679e-02_rb, & - 1.407780e-02_rb,1.331775e-02_rb,1.264061e-02_rb,1.203364e-02_rb,1.148655e-02_rb, & - 1.099099e-02_rb,1.054006e-02_rb,1.012807e-02_rb,9.750215e-03_rb,9.402477e-03_rb, & - 9.081428e-03_rb,8.784143e-03_rb,8.508107e-03_rb,8.251146e-03_rb,8.011373e-03_rb, & - 7.787140e-03_rb,7.577002e-03_rb,7.379687e-03_rb,7.194071e-03_rb,7.019158e-03_rb, & - 6.854061e-03_rb,6.697986e-03_rb,6.550224e-03_rb,6.410138e-03_rb,6.277153e-03_rb, & - 6.150751e-03_rb,6.030462e-03_rb,5.915860e-03_rb/) - -! ICEFLAG = 3; Fu parameterization. Particle size 5 - 140 micron in +! band 13 + 1.437021e-01_rb,8.872535e-02_rb,6.392420e-02_rb,4.991833e-02_rb,4.096790e-02_rb, & + 3.477881e-02_rb,3.025782e-02_rb,2.681909e-02_rb,2.412102e-02_rb,2.195132e-02_rb, & + 2.017124e-02_rb,1.868641e-02_rb,1.743044e-02_rb,1.635529e-02_rb,1.542540e-02_rb, & + 1.461388e-02_rb,1.390003e-02_rb,1.326766e-02_rb,1.270395e-02_rb,1.219860e-02_rb, & + 1.174326e-02_rb,1.133107e-02_rb,1.095637e-02_rb,1.061442e-02_rb,1.030126e-02_rb, & + 1.001352e-02_rb,9.748340e-03_rb,9.503256e-03_rb,9.276155e-03_rb,9.065205e-03_rb, & + 8.868808e-03_rb,8.685571e-03_rb,8.514268e-03_rb,8.353820e-03_rb,8.203272e-03_rb, & + 8.061776e-03_rb,7.928578e-03_rb,7.803001e-03_rb,7.684443e-03_rb,7.572358e-03_rb, & + 7.466258e-03_rb,7.365701e-03_rb,7.270286e-03_rb/) + absice2(:,14) = (/ & +! band 14 + 1.288870e-01_rb,8.160295e-02_rb,5.964745e-02_rb,4.703790e-02_rb,3.888637e-02_rb, & + 3.320115e-02_rb,2.902017e-02_rb,2.582259e-02_rb,2.330224e-02_rb,2.126754e-02_rb, & + 1.959258e-02_rb,1.819130e-02_rb,1.700289e-02_rb,1.598320e-02_rb,1.509942e-02_rb, & + 1.432666e-02_rb,1.364572e-02_rb,1.304156e-02_rb,1.250220e-02_rb,1.201803e-02_rb, & + 1.158123e-02_rb,1.118537e-02_rb,1.082513e-02_rb,1.049605e-02_rb,1.019440e-02_rb, & + 9.916989e-03_rb,9.661116e-03_rb,9.424457e-03_rb,9.205005e-03_rb,9.001022e-03_rb, & + 8.810992e-03_rb,8.633588e-03_rb,8.467646e-03_rb,8.312137e-03_rb,8.166151e-03_rb, & + 8.028878e-03_rb,7.899597e-03_rb,7.777663e-03_rb,7.662498e-03_rb,7.553581e-03_rb, & + 7.450444e-03_rb,7.352662e-03_rb,7.259851e-03_rb/) + absice2(:,15) = (/ & +! band 15 + 8.254229e-02_rb,5.808787e-02_rb,4.492166e-02_rb,3.675028e-02_rb,3.119623e-02_rb, & + 2.718045e-02_rb,2.414450e-02_rb,2.177073e-02_rb,1.986526e-02_rb,1.830306e-02_rb, & + 1.699991e-02_rb,1.589698e-02_rb,1.495199e-02_rb,1.413374e-02_rb,1.341870e-02_rb, & + 1.278883e-02_rb,1.223002e-02_rb,1.173114e-02_rb,1.128322e-02_rb,1.087900e-02_rb, & + 1.051254e-02_rb,1.017890e-02_rb,9.873991e-03_rb,9.594347e-03_rb,9.337044e-03_rb, & + 9.099589e-03_rb,8.879842e-03_rb,8.675960e-03_rb,8.486341e-03_rb,8.309594e-03_rb, & + 8.144500e-03_rb,7.989986e-03_rb,7.845109e-03_rb,7.709031e-03_rb,7.581007e-03_rb, & + 7.460376e-03_rb,7.346544e-03_rb,7.238978e-03_rb,7.137201e-03_rb,7.040780e-03_rb, & + 6.949325e-03_rb,6.862483e-03_rb,6.779931e-03_rb/) + absice2(:,16) = (/ & +! band 16 + 1.382062e-01_rb,8.643227e-02_rb,6.282935e-02_rb,4.934783e-02_rb,4.063891e-02_rb, & + 3.455591e-02_rb,3.007059e-02_rb,2.662897e-02_rb,2.390631e-02_rb,2.169972e-02_rb, & + 1.987596e-02_rb,1.834393e-02_rb,1.703924e-02_rb,1.591513e-02_rb,1.493679e-02_rb, & + 1.407780e-02_rb,1.331775e-02_rb,1.264061e-02_rb,1.203364e-02_rb,1.148655e-02_rb, & + 1.099099e-02_rb,1.054006e-02_rb,1.012807e-02_rb,9.750215e-03_rb,9.402477e-03_rb, & + 9.081428e-03_rb,8.784143e-03_rb,8.508107e-03_rb,8.251146e-03_rb,8.011373e-03_rb, & + 7.787140e-03_rb,7.577002e-03_rb,7.379687e-03_rb,7.194071e-03_rb,7.019158e-03_rb, & + 6.854061e-03_rb,6.697986e-03_rb,6.550224e-03_rb,6.410138e-03_rb,6.277153e-03_rb, & + 6.150751e-03_rb,6.030462e-03_rb,5.915860e-03_rb/) + +! ICEFLAG = 3; Fu parameterization. Particle size 5 - 140 micron in ! increments of 3 microns. ! units = m2/g ! Hexagonal Ice Particle Parameterization @@ -8346,9 +8346,9 @@ subroutine cldprmc(nlayers, inflag, iceflag, liqflag, cldfmc, & 1.301260e-02_rb,1.254781e-02_rb,1.210941e-02_rb,1.169468e-02_rb,1.130118e-02_rb, & 1.092675e-02_rb,1.056945e-02_rb,1.022757e-02_rb,9.899560e-03_rb,9.584021e-03_rb, & 9.279705e-03_rb,8.985479e-03_rb,8.700322e-03_rb,8.423306e-03_rb,8.153590e-03_rb, & - 7.890412e-03_rb/) - absice3(:,6) = (/ & -! band 6 + 7.890412e-03_rb/) + absice3(:,6) = (/ & +! band 6 1.145369e-01_rb,1.174566e-01_rb,9.917866e-02_rb,8.332990e-02_rb,7.104263e-02_rb, & 6.153370e-02_rb,5.405472e-02_rb,4.806281e-02_rb,4.317918e-02_rb,3.913795e-02_rb, & 3.574916e-02_rb,3.287437e-02_rb,3.041067e-02_rb,2.828017e-02_rb,2.642292e-02_rb, & @@ -8358,9 +8358,9 @@ subroutine cldprmc(nlayers, inflag, iceflag, liqflag, cldfmc, & 1.293447e-02_rb,1.252685e-02_rb,1.213939e-02_rb,1.176968e-02_rb,1.141555e-02_rb, & 1.107508e-02_rb,1.074655e-02_rb,1.042839e-02_rb,1.011923e-02_rb,9.817799e-03_rb, & 9.522962e-03_rb,9.233688e-03_rb,8.949041e-03_rb,8.668171e-03_rb,8.390301e-03_rb, & - 8.114723e-03_rb/) - absice3(:,7) = (/ & -! band 7 + 8.114723e-03_rb/) + absice3(:,7) = (/ & +! band 7 1.222345e-02_rb,5.344230e-02_rb,5.523465e-02_rb,5.128759e-02_rb,4.676925e-02_rb, & 4.266150e-02_rb,3.910561e-02_rb,3.605479e-02_rb,3.342843e-02_rb,3.115052e-02_rb, & 2.915776e-02_rb,2.739935e-02_rb,2.583499e-02_rb,2.443266e-02_rb,2.316681e-02_rb, & @@ -8370,9 +8370,9 @@ subroutine cldprmc(nlayers, inflag, iceflag, liqflag, cldfmc, & 1.191172e-02_rb,1.149171e-02_rb,1.108936e-02_rb,1.070341e-02_rb,1.033271e-02_rb, & 9.976220e-03_rb,9.633021e-03_rb,9.302273e-03_rb,8.983216e-03_rb,8.675161e-03_rb, & 8.377478e-03_rb,8.089595e-03_rb,7.810986e-03_rb,7.541170e-03_rb,7.279706e-03_rb, & - 7.026186e-03_rb/) - absice3(:,8) = (/ & -! band 8 + 7.026186e-03_rb/) + absice3(:,8) = (/ & +! band 8 6.711058e-02_rb,6.918198e-02_rb,6.127484e-02_rb,5.411944e-02_rb,4.836902e-02_rb, & 4.375293e-02_rb,3.998077e-02_rb,3.683587e-02_rb,3.416508e-02_rb,3.186003e-02_rb, & 2.984290e-02_rb,2.805671e-02_rb,2.645895e-02_rb,2.501733e-02_rb,2.370689e-02_rb, & @@ -8382,9 +8382,9 @@ subroutine cldprmc(nlayers, inflag, iceflag, liqflag, cldfmc, & 1.173682e-02_rb,1.129925e-02_rb,1.088393e-02_rb,1.048961e-02_rb,1.011516e-02_rb, & 9.759543e-03_rb,9.421813e-03_rb,9.101089e-03_rb,8.796559e-03_rb,8.507464e-03_rb, & 8.233098e-03_rb,7.972798e-03_rb,7.725942e-03_rb,7.491940e-03_rb,7.270238e-03_rb, & - 7.060305e-03_rb/) - absice3(:,9) = (/ & -! band 9 + 7.060305e-03_rb/) + absice3(:,9) = (/ & +! band 9 1.236780e-01_rb,9.222386e-02_rb,7.383997e-02_rb,6.204072e-02_rb,5.381029e-02_rb, & 4.770678e-02_rb,4.296928e-02_rb,3.916131e-02_rb,3.601540e-02_rb,3.335878e-02_rb, & 3.107493e-02_rb,2.908247e-02_rb,2.732282e-02_rb,2.575276e-02_rb,2.433968e-02_rb, & @@ -8394,9 +8394,9 @@ subroutine cldprmc(nlayers, inflag, iceflag, liqflag, cldfmc, & 1.208808e-02_rb,1.167094e-02_rb,1.127862e-02_rb,1.090979e-02_rb,1.056323e-02_rb, & 1.023786e-02_rb,9.932665e-03_rb,9.646744e-03_rb,9.379250e-03_rb,9.129409e-03_rb, & 8.896500e-03_rb,8.679856e-03_rb,8.478852e-03_rb,8.292904e-03_rb,8.121463e-03_rb, & - 7.964013e-03_rb/) - absice3(:,10) = (/ & -! band 10 + 7.964013e-03_rb/) + absice3(:,10) = (/ & +! band 10 1.655966e-01_rb,1.134205e-01_rb,8.714344e-02_rb,7.129241e-02_rb,6.063739e-02_rb, & 5.294203e-02_rb,4.709309e-02_rb,4.247476e-02_rb,3.871892e-02_rb,3.559206e-02_rb, & 3.293893e-02_rb,3.065226e-02_rb,2.865558e-02_rb,2.689288e-02_rb,2.532221e-02_rb, & @@ -8406,9 +8406,9 @@ subroutine cldprmc(nlayers, inflag, iceflag, liqflag, cldfmc, & 1.239992e-02_rb,1.198486e-02_rb,1.159647e-02_rb,1.123323e-02_rb,1.089375e-02_rb, & 1.057679e-02_rb,1.028124e-02_rb,1.000607e-02_rb,9.750376e-03_rb,9.513303e-03_rb, & 9.294082e-03_rb,9.092003e-03_rb,8.906412e-03_rb,8.736702e-03_rb,8.582314e-03_rb, & - 8.442725e-03_rb/) - absice3(:,11) = (/ & -! band 11 + 8.442725e-03_rb/) + absice3(:,11) = (/ & +! band 11 1.775615e-01_rb,1.180046e-01_rb,8.929607e-02_rb,7.233500e-02_rb,6.108333e-02_rb, & 5.303642e-02_rb,4.696927e-02_rb,4.221206e-02_rb,3.836768e-02_rb,3.518576e-02_rb, & 3.250063e-02_rb,3.019825e-02_rb,2.819758e-02_rb,2.643943e-02_rb,2.487953e-02_rb, & @@ -8418,9 +8418,9 @@ subroutine cldprmc(nlayers, inflag, iceflag, liqflag, cldfmc, & 1.229321e-02_rb,1.189350e-02_rb,1.151915e-02_rb,1.116859e-02_rb,1.084042e-02_rb, & 1.053338e-02_rb,1.024636e-02_rb,9.978326e-03_rb,9.728357e-03_rb,9.495613e-03_rb, & 9.279327e-03_rb,9.078798e-03_rb,8.893383e-03_rb,8.722488e-03_rb,8.565568e-03_rb, & - 8.422115e-03_rb/) - absice3(:,12) = (/ & -! band 12 + 8.422115e-03_rb/) + absice3(:,12) = (/ & +! band 12 9.465447e-02_rb,6.432047e-02_rb,5.060973e-02_rb,4.267283e-02_rb,3.741843e-02_rb, & 3.363096e-02_rb,3.073531e-02_rb,2.842405e-02_rb,2.651789e-02_rb,2.490518e-02_rb, & 2.351273e-02_rb,2.229056e-02_rb,2.120335e-02_rb,2.022541e-02_rb,1.933763e-02_rb, & @@ -8430,9 +8430,9 @@ subroutine cldprmc(nlayers, inflag, iceflag, liqflag, cldfmc, & 1.112148e-02_rb,1.081609e-02_rb,1.052642e-02_rb,1.025178e-02_rb,9.991540e-03_rb, & 9.745130e-03_rb,9.512038e-03_rb,9.291797e-03_rb,9.083980e-03_rb,8.888195e-03_rb, & 8.704081e-03_rb,8.531306e-03_rb,8.369560e-03_rb,8.218558e-03_rb,8.078032e-03_rb, & - 7.947730e-03_rb/) - absice3(:,13) = (/ & -! band 13 + 7.947730e-03_rb/) + absice3(:,13) = (/ & +! band 13 1.560311e-01_rb,9.961097e-02_rb,7.502949e-02_rb,6.115022e-02_rb,5.214952e-02_rb, & 4.578149e-02_rb,4.099731e-02_rb,3.724174e-02_rb,3.419343e-02_rb,3.165356e-02_rb, & 2.949251e-02_rb,2.762222e-02_rb,2.598073e-02_rb,2.452322e-02_rb,2.321642e-02_rb, & @@ -8442,9 +8442,9 @@ subroutine cldprmc(nlayers, inflag, iceflag, liqflag, cldfmc, & 1.204183e-02_rb,1.167164e-02_rb,1.132567e-02_rb,1.100281e-02_rb,1.070207e-02_rb, & 1.042258e-02_rb,1.016352e-02_rb,9.924197e-03_rb,9.703953e-03_rb,9.502199e-03_rb, & 9.318400e-03_rb,9.152066e-03_rb,9.002749e-03_rb,8.870038e-03_rb,8.753555e-03_rb, & - 8.652951e-03_rb/) - absice3(:,14) = (/ & -! band 14 + 8.652951e-03_rb/) + absice3(:,14) = (/ & +! band 14 1.559547e-01_rb,9.896700e-02_rb,7.441231e-02_rb,6.061469e-02_rb,5.168730e-02_rb, & 4.537821e-02_rb,4.064106e-02_rb,3.692367e-02_rb,3.390714e-02_rb,3.139438e-02_rb, & 2.925702e-02_rb,2.740783e-02_rb,2.578547e-02_rb,2.434552e-02_rb,2.305506e-02_rb, & @@ -8454,9 +8454,9 @@ subroutine cldprmc(nlayers, inflag, iceflag, liqflag, cldfmc, & 1.205973e-02_rb,1.169780e-02_rb,1.135989e-02_rb,1.104492e-02_rb,1.075192e-02_rb, & 1.048004e-02_rb,1.022850e-02_rb,9.996611e-03_rb,9.783753e-03_rb,9.589361e-03_rb, & 9.412924e-03_rb,9.253977e-03_rb,9.112098e-03_rb,8.986903e-03_rb,8.878039e-03_rb, & - 8.785184e-03_rb/) - absice3(:,15) = (/ & -! band 15 + 8.785184e-03_rb/) + absice3(:,15) = (/ & +! band 15 1.102926e-01_rb,7.176622e-02_rb,5.530316e-02_rb,4.606056e-02_rb,4.006116e-02_rb, & 3.579628e-02_rb,3.256909e-02_rb,3.001360e-02_rb,2.791920e-02_rb,2.615617e-02_rb, & 2.464023e-02_rb,2.331426e-02_rb,2.213817e-02_rb,2.108301e-02_rb,2.012733e-02_rb, & @@ -8466,9 +8466,9 @@ subroutine cldprmc(nlayers, inflag, iceflag, liqflag, cldfmc, & 1.145348e-02_rb,1.114612e-02_rb,1.085730e-02_rb,1.058633e-02_rb,1.033263e-02_rb, & 1.009564e-02_rb,9.874895e-03_rb,9.669960e-03_rb,9.480449e-03_rb,9.306014e-03_rb, & 9.146339e-03_rb,9.001138e-03_rb,8.870154e-03_rb,8.753148e-03_rb,8.649907e-03_rb, & - 8.560232e-03_rb/) + 8.560232e-03_rb/) absice3(:,16) = (/ & -! band 16 +! band 16 1.688344e-01_rb,1.077072e-01_rb,7.994467e-02_rb,6.403862e-02_rb,5.369850e-02_rb, & 4.641582e-02_rb,4.099331e-02_rb,3.678724e-02_rb,3.342069e-02_rb,3.065831e-02_rb, & 2.834557e-02_rb,2.637680e-02_rb,2.467733e-02_rb,2.319286e-02_rb,2.188299e-02_rb, & @@ -8478,16 +8478,16 @@ subroutine cldprmc(nlayers, inflag, iceflag, liqflag, cldfmc, & 1.149683e-02_rb,1.116436e-02_rb,1.085153e-02_rb,1.055701e-02_rb,1.027961e-02_rb, & 1.001831e-02_rb,9.772141e-03_rb,9.540280e-03_rb,9.321966e-03_rb,9.116517e-03_rb, & 8.923315e-03_rb,8.741803e-03_rb,8.571472e-03_rb,8.411860e-03_rb,8.262543e-03_rb, & - 8.123136e-03_rb/) - -! For LIQFLAG = 0. - absliq0 = 0.0903614_rb - -! For LIQFLAG = 1. In each band, the absorption -! coefficients are listed for a range of effective radii from 2.5 -! to 59.5 microns in increments of 1.0 micron. - absliq1(:, 1) = (/ & -! band 1 + 8.123136e-03_rb/) + +! For LIQFLAG = 0. + absliq0 = 0.0903614_rb + +! For LIQFLAG = 1. In each band, the absorption +! coefficients are listed for a range of effective radii from 2.5 +! to 59.5 microns in increments of 1.0 micron. + absliq1(:, 1) = (/ & +! band 1 1.64047e-03_rb, 6.90533e-02_rb, 7.72017e-02_rb, 7.78054e-02_rb, 7.69523e-02_rb, & 7.58058e-02_rb, 7.46400e-02_rb, 7.35123e-02_rb, 7.24162e-02_rb, 7.13225e-02_rb, & 6.99145e-02_rb, 6.66409e-02_rb, 6.36582e-02_rb, 6.09425e-02_rb, 5.84593e-02_rb, & @@ -8499,9 +8499,9 @@ subroutine cldprmc(nlayers, inflag, iceflag, liqflag, cldfmc, & 2.47189e-02_rb, 2.40678e-02_rb, 2.34418e-02_rb, 2.28392e-02_rb, 2.22586e-02_rb, & 2.16986e-02_rb, 2.11580e-02_rb, 2.06356e-02_rb, 2.01305e-02_rb, 1.96417e-02_rb, & 1.91682e-02_rb, 1.87094e-02_rb, 1.82643e-02_rb, 1.78324e-02_rb, 1.74129e-02_rb, & - 1.70052e-02_rb, 1.66088e-02_rb, 1.62231e-02_rb/) - absliq1(:, 2) = (/ & -! band 2 + 1.70052e-02_rb, 1.66088e-02_rb, 1.62231e-02_rb/) + absliq1(:, 2) = (/ & +! band 2 2.19486e-01_rb, 1.80687e-01_rb, 1.59150e-01_rb, 1.44731e-01_rb, 1.33703e-01_rb, & 1.24355e-01_rb, 1.15756e-01_rb, 1.07318e-01_rb, 9.86119e-02_rb, 8.92739e-02_rb, & 8.34911e-02_rb, 7.70773e-02_rb, 7.15240e-02_rb, 6.66615e-02_rb, 6.23641e-02_rb, & @@ -8513,9 +8513,9 @@ subroutine cldprmc(nlayers, inflag, iceflag, liqflag, cldfmc, & 2.08834e-02_rb, 2.03051e-02_rb, 1.97536e-02_rb, 1.92271e-02_rb, 1.87239e-02_rb, & 1.82425e-02_rb, 1.77816e-02_rb, 1.73399e-02_rb, 1.69162e-02_rb, 1.65094e-02_rb, & 1.61187e-02_rb, 1.57430e-02_rb, 1.53815e-02_rb, 1.50334e-02_rb, 1.46981e-02_rb, & - 1.43748e-02_rb, 1.40628e-02_rb, 1.37617e-02_rb/) - absliq1(:, 3) = (/ & -! band 3 + 1.43748e-02_rb, 1.40628e-02_rb, 1.37617e-02_rb/) + absliq1(:, 3) = (/ & +! band 3 2.95174e-01_rb, 2.34765e-01_rb, 1.98038e-01_rb, 1.72114e-01_rb, 1.52083e-01_rb, & 1.35654e-01_rb, 1.21613e-01_rb, 1.09252e-01_rb, 9.81263e-02_rb, 8.79448e-02_rb, & 8.12566e-02_rb, 7.44563e-02_rb, 6.86374e-02_rb, 6.36042e-02_rb, 5.92094e-02_rb, & @@ -8527,9 +8527,9 @@ subroutine cldprmc(nlayers, inflag, iceflag, liqflag, cldfmc, & 1.96561e-02_rb, 1.91239e-02_rb, 1.86161e-02_rb, 1.81311e-02_rb, 1.76673e-02_rb, & 1.72234e-02_rb, 1.67981e-02_rb, 1.63903e-02_rb, 1.59989e-02_rb, 1.56230e-02_rb, & 1.52615e-02_rb, 1.49138e-02_rb, 1.45791e-02_rb, 1.42565e-02_rb, 1.39455e-02_rb, & - 1.36455e-02_rb, 1.33559e-02_rb, 1.30761e-02_rb/) - absliq1(:, 4) = (/ & -! band 4 + 1.36455e-02_rb, 1.33559e-02_rb, 1.30761e-02_rb/) + absliq1(:, 4) = (/ & +! band 4 3.00925e-01_rb, 2.36949e-01_rb, 1.96947e-01_rb, 1.68692e-01_rb, 1.47190e-01_rb, & 1.29986e-01_rb, 1.15719e-01_rb, 1.03568e-01_rb, 9.30028e-02_rb, 8.36658e-02_rb, & 7.71075e-02_rb, 7.07002e-02_rb, 6.52284e-02_rb, 6.05024e-02_rb, 5.63801e-02_rb, & @@ -8541,9 +8541,9 @@ subroutine cldprmc(nlayers, inflag, iceflag, liqflag, cldfmc, & 1.91711e-02_rb, 1.86625e-02_rb, 1.81769e-02_rb, 1.77126e-02_rb, 1.72683e-02_rb, & 1.68426e-02_rb, 1.64344e-02_rb, 1.60427e-02_rb, 1.56664e-02_rb, 1.53046e-02_rb, & 1.49565e-02_rb, 1.46214e-02_rb, 1.42985e-02_rb, 1.39871e-02_rb, 1.36866e-02_rb, & - 1.33965e-02_rb, 1.31162e-02_rb, 1.28453e-02_rb/) - absliq1(:, 5) = (/ & -! band 5 + 1.33965e-02_rb, 1.31162e-02_rb, 1.28453e-02_rb/) + absliq1(:, 5) = (/ & +! band 5 2.64691e-01_rb, 2.12018e-01_rb, 1.78009e-01_rb, 1.53539e-01_rb, 1.34721e-01_rb, & 1.19580e-01_rb, 1.06996e-01_rb, 9.62772e-02_rb, 8.69710e-02_rb, 7.87670e-02_rb, & 7.29272e-02_rb, 6.70920e-02_rb, 6.20977e-02_rb, 5.77732e-02_rb, 5.39910e-02_rb, & @@ -8555,9 +8555,9 @@ subroutine cldprmc(nlayers, inflag, iceflag, liqflag, cldfmc, & 1.89917e-02_rb, 1.84984e-02_rb, 1.80269e-02_rb, 1.75755e-02_rb, 1.71431e-02_rb, & 1.67283e-02_rb, 1.63303e-02_rb, 1.59478e-02_rb, 1.55801e-02_rb, 1.52262e-02_rb, & 1.48853e-02_rb, 1.45568e-02_rb, 1.42400e-02_rb, 1.39342e-02_rb, 1.36388e-02_rb, & - 1.33533e-02_rb, 1.30773e-02_rb, 1.28102e-02_rb/) - absliq1(:, 6) = (/ & -! band 6 + 1.33533e-02_rb, 1.30773e-02_rb, 1.28102e-02_rb/) + absliq1(:, 6) = (/ & +! band 6 8.81182e-02_rb, 1.06745e-01_rb, 9.79753e-02_rb, 8.99625e-02_rb, 8.35200e-02_rb, & 7.81899e-02_rb, 7.35939e-02_rb, 6.94696e-02_rb, 6.56266e-02_rb, 6.19148e-02_rb, & 5.83355e-02_rb, 5.49306e-02_rb, 5.19642e-02_rb, 4.93325e-02_rb, 4.69659e-02_rb, & @@ -8569,9 +8569,9 @@ subroutine cldprmc(nlayers, inflag, iceflag, liqflag, cldfmc, & 1.94280e-02_rb, 1.89501e-02_rb, 1.84913e-02_rb, 1.80506e-02_rb, 1.76270e-02_rb, & 1.72196e-02_rb, 1.68276e-02_rb, 1.64500e-02_rb, 1.60863e-02_rb, 1.57357e-02_rb, & 1.53975e-02_rb, 1.50710e-02_rb, 1.47558e-02_rb, 1.44511e-02_rb, 1.41566e-02_rb, & - 1.38717e-02_rb, 1.35960e-02_rb, 1.33290e-02_rb/) - absliq1(:, 7) = (/ & -! band 7 + 1.38717e-02_rb, 1.35960e-02_rb, 1.33290e-02_rb/) + absliq1(:, 7) = (/ & +! band 7 4.32174e-02_rb, 7.36078e-02_rb, 6.98340e-02_rb, 6.65231e-02_rb, 6.41948e-02_rb, & 6.23551e-02_rb, 6.06638e-02_rb, 5.88680e-02_rb, 5.67124e-02_rb, 5.38629e-02_rb, & 4.99579e-02_rb, 4.86289e-02_rb, 4.70120e-02_rb, 4.52854e-02_rb, 4.35466e-02_rb, & @@ -8583,9 +8583,9 @@ subroutine cldprmc(nlayers, inflag, iceflag, liqflag, cldfmc, & 1.90824e-02_rb, 1.86174e-02_rb, 1.81706e-02_rb, 1.77411e-02_rb, 1.73281e-02_rb, & 1.69307e-02_rb, 1.65483e-02_rb, 1.61801e-02_rb, 1.58254e-02_rb, 1.54835e-02_rb, & 1.51538e-02_rb, 1.48358e-02_rb, 1.45288e-02_rb, 1.42322e-02_rb, 1.39457e-02_rb, & - 1.36687e-02_rb, 1.34008e-02_rb, 1.31416e-02_rb/) - absliq1(:, 8) = (/ & -! band 8 + 1.36687e-02_rb, 1.34008e-02_rb, 1.31416e-02_rb/) + absliq1(:, 8) = (/ & +! band 8 1.41881e-01_rb, 7.15419e-02_rb, 6.30335e-02_rb, 6.11132e-02_rb, 6.01931e-02_rb, & 5.92420e-02_rb, 5.78968e-02_rb, 5.58876e-02_rb, 5.28923e-02_rb, 4.84462e-02_rb, & 4.60839e-02_rb, 4.56013e-02_rb, 4.45410e-02_rb, 4.31866e-02_rb, 4.17026e-02_rb, & @@ -8597,9 +8597,9 @@ subroutine cldprmc(nlayers, inflag, iceflag, liqflag, cldfmc, & 1.88056e-02_rb, 1.83564e-02_rb, 1.79241e-02_rb, 1.75079e-02_rb, 1.71070e-02_rb, & 1.67207e-02_rb, 1.63482e-02_rb, 1.59890e-02_rb, 1.56424e-02_rb, 1.53077e-02_rb, & 1.49845e-02_rb, 1.46722e-02_rb, 1.43702e-02_rb, 1.40782e-02_rb, 1.37955e-02_rb, & - 1.35219e-02_rb, 1.32569e-02_rb, 1.30000e-02_rb/) - absliq1(:, 9) = (/ & -! band 9 + 1.35219e-02_rb, 1.32569e-02_rb, 1.30000e-02_rb/) + absliq1(:, 9) = (/ & +! band 9 6.72726e-02_rb, 6.61013e-02_rb, 6.47866e-02_rb, 6.33780e-02_rb, 6.18985e-02_rb, & 6.03335e-02_rb, 5.86136e-02_rb, 5.65876e-02_rb, 5.39839e-02_rb, 5.03536e-02_rb, & 4.71608e-02_rb, 4.63630e-02_rb, 4.50313e-02_rb, 4.34526e-02_rb, 4.17876e-02_rb, & @@ -8611,9 +8611,9 @@ subroutine cldprmc(nlayers, inflag, iceflag, liqflag, cldfmc, & 1.83944e-02_rb, 1.79578e-02_rb, 1.75378e-02_rb, 1.71335e-02_rb, 1.67440e-02_rb, & 1.63687e-02_rb, 1.60069e-02_rb, 1.56579e-02_rb, 1.53210e-02_rb, 1.49958e-02_rb, & 1.46815e-02_rb, 1.43778e-02_rb, 1.40841e-02_rb, 1.37999e-02_rb, 1.35249e-02_rb, & - 1.32585e-02_rb, 1.30004e-02_rb, 1.27502e-02_rb/) - absliq1(:,10) = (/ & -! band 10 + 1.32585e-02_rb, 1.30004e-02_rb, 1.27502e-02_rb/) + absliq1(:,10) = (/ & +! band 10 7.97040e-02_rb, 7.63844e-02_rb, 7.36499e-02_rb, 7.13525e-02_rb, 6.93043e-02_rb, & 6.72807e-02_rb, 6.50227e-02_rb, 6.22395e-02_rb, 5.86093e-02_rb, 5.37815e-02_rb, & 5.14682e-02_rb, 4.97214e-02_rb, 4.77392e-02_rb, 4.56961e-02_rb, 4.36858e-02_rb, & @@ -8625,9 +8625,9 @@ subroutine cldprmc(nlayers, inflag, iceflag, liqflag, cldfmc, & 1.83483e-02_rb, 1.79043e-02_rb, 1.74778e-02_rb, 1.70678e-02_rb, 1.66735e-02_rb, & 1.62941e-02_rb, 1.59286e-02_rb, 1.55766e-02_rb, 1.52371e-02_rb, 1.49097e-02_rb, & 1.45937e-02_rb, 1.42885e-02_rb, 1.39936e-02_rb, 1.37085e-02_rb, 1.34327e-02_rb, & - 1.31659e-02_rb, 1.29075e-02_rb, 1.26571e-02_rb/) - absliq1(:,11) = (/ & -! band 11 + 1.31659e-02_rb, 1.29075e-02_rb, 1.26571e-02_rb/) + absliq1(:,11) = (/ & +! band 11 1.49438e-01_rb, 1.33535e-01_rb, 1.21542e-01_rb, 1.11743e-01_rb, 1.03263e-01_rb, & 9.55774e-02_rb, 8.83382e-02_rb, 8.12943e-02_rb, 7.42533e-02_rb, 6.70609e-02_rb, & 6.38761e-02_rb, 5.97788e-02_rb, 5.59841e-02_rb, 5.25318e-02_rb, 4.94132e-02_rb, & @@ -8639,9 +8639,9 @@ subroutine cldprmc(nlayers, inflag, iceflag, liqflag, cldfmc, & 1.84317e-02_rb, 1.79679e-02_rb, 1.75238e-02_rb, 1.70983e-02_rb, 1.66901e-02_rb, & 1.62983e-02_rb, 1.59219e-02_rb, 1.55599e-02_rb, 1.52115e-02_rb, 1.48761e-02_rb, & 1.45528e-02_rb, 1.42411e-02_rb, 1.39402e-02_rb, 1.36497e-02_rb, 1.33690e-02_rb, & - 1.30976e-02_rb, 1.28351e-02_rb, 1.25810e-02_rb/) - absliq1(:,12) = (/ & -! band 12 + 1.30976e-02_rb, 1.28351e-02_rb, 1.25810e-02_rb/) + absliq1(:,12) = (/ & +! band 12 3.71985e-02_rb, 3.88586e-02_rb, 3.99070e-02_rb, 4.04351e-02_rb, 4.04610e-02_rb, & 3.99834e-02_rb, 3.89953e-02_rb, 3.74886e-02_rb, 3.54551e-02_rb, 3.28870e-02_rb, & 3.32576e-02_rb, 3.22444e-02_rb, 3.12384e-02_rb, 3.02584e-02_rb, 2.93146e-02_rb, & @@ -8653,10 +8653,10 @@ subroutine cldprmc(nlayers, inflag, iceflag, liqflag, cldfmc, & 1.56842e-02_rb, 1.53840e-02_rb, 1.50920e-02_rb, 1.48080e-02_rb, 1.45318e-02_rb, & 1.42631e-02_rb, 1.40016e-02_rb, 1.37472e-02_rb, 1.34996e-02_rb, 1.32586e-02_rb, & 1.30239e-02_rb, 1.27954e-02_rb, 1.25728e-02_rb, 1.23559e-02_rb, 1.21445e-02_rb, & - 1.19385e-02_rb, 1.17376e-02_rb, 1.15417e-02_rb/) + 1.19385e-02_rb, 1.17376e-02_rb, 1.15417e-02_rb/) - absliq1(:,13) = (/ & -! band 13 + absliq1(:,13) = (/ & +! band 13 3.11868e-02_rb, 4.48357e-02_rb, 4.90224e-02_rb, 4.96406e-02_rb, 4.86806e-02_rb, & 4.69610e-02_rb, 4.48630e-02_rb, 4.25795e-02_rb, 4.02138e-02_rb, 3.78236e-02_rb, & 3.74266e-02_rb, 3.60384e-02_rb, 3.47074e-02_rb, 3.34434e-02_rb, 3.22499e-02_rb, & @@ -8668,9 +8668,9 @@ subroutine cldprmc(nlayers, inflag, iceflag, liqflag, cldfmc, & 1.62956e-02_rb, 1.59624e-02_rb, 1.56393e-02_rb, 1.53259e-02_rb, 1.50219e-02_rb, & 1.47268e-02_rb, 1.44404e-02_rb, 1.41624e-02_rb, 1.38925e-02_rb, 1.36302e-02_rb, & 1.33755e-02_rb, 1.31278e-02_rb, 1.28871e-02_rb, 1.26530e-02_rb, 1.24253e-02_rb, & - 1.22038e-02_rb, 1.19881e-02_rb, 1.17782e-02_rb/) - absliq1(:,14) = (/ & -! band 14 + 1.22038e-02_rb, 1.19881e-02_rb, 1.17782e-02_rb/) + absliq1(:,14) = (/ & +! band 14 1.58988e-02_rb, 3.50652e-02_rb, 4.00851e-02_rb, 4.07270e-02_rb, 3.98101e-02_rb, & 3.83306e-02_rb, 3.66829e-02_rb, 3.50327e-02_rb, 3.34497e-02_rb, 3.19609e-02_rb, & 3.13712e-02_rb, 3.03348e-02_rb, 2.93415e-02_rb, 2.83973e-02_rb, 2.75037e-02_rb, & @@ -8682,9 +8682,9 @@ subroutine cldprmc(nlayers, inflag, iceflag, liqflag, cldfmc, & 1.50936e-02_rb, 1.48146e-02_rb, 1.45429e-02_rb, 1.42782e-02_rb, 1.40203e-02_rb, & 1.37691e-02_rb, 1.35243e-02_rb, 1.32858e-02_rb, 1.30534e-02_rb, 1.28270e-02_rb, & 1.26062e-02_rb, 1.23909e-02_rb, 1.21810e-02_rb, 1.19763e-02_rb, 1.17766e-02_rb, & - 1.15817e-02_rb, 1.13915e-02_rb, 1.12058e-02_rb/) - absliq1(:,15) = (/ & -! band 15 + 1.15817e-02_rb, 1.13915e-02_rb, 1.12058e-02_rb/) + absliq1(:,15) = (/ & +! band 15 5.02079e-03_rb, 2.17615e-02_rb, 2.55449e-02_rb, 2.59484e-02_rb, 2.53650e-02_rb, & 2.45281e-02_rb, 2.36843e-02_rb, 2.29159e-02_rb, 2.22451e-02_rb, 2.16716e-02_rb, & 2.11451e-02_rb, 2.05817e-02_rb, 2.00454e-02_rb, 1.95372e-02_rb, 1.90567e-02_rb, & @@ -8696,9 +8696,9 @@ subroutine cldprmc(nlayers, inflag, iceflag, liqflag, cldfmc, & 1.20881e-02_rb, 1.19131e-02_rb, 1.17412e-02_rb, 1.15723e-02_rb, 1.14063e-02_rb, & 1.12434e-02_rb, 1.10834e-02_rb, 1.09264e-02_rb, 1.07722e-02_rb, 1.06210e-02_rb, & 1.04725e-02_rb, 1.03269e-02_rb, 1.01839e-02_rb, 1.00436e-02_rb, 9.90593e-03_rb, & - 9.77080e-03_rb, 9.63818e-03_rb, 9.50800e-03_rb/) - absliq1(:,16) = (/ & -! band 16 + 9.77080e-03_rb, 9.63818e-03_rb, 9.50800e-03_rb/) + absliq1(:,16) = (/ & +! band 16 5.64971e-02_rb, 9.04736e-02_rb, 8.11726e-02_rb, 7.05450e-02_rb, 6.20052e-02_rb, & 5.54286e-02_rb, 5.03503e-02_rb, 4.63791e-02_rb, 4.32290e-02_rb, 4.06959e-02_rb, & 3.74690e-02_rb, 3.52964e-02_rb, 3.33799e-02_rb, 3.16774e-02_rb, 3.01550e-02_rb, & @@ -8710,7 +8710,7 @@ subroutine cldprmc(nlayers, inflag, iceflag, liqflag, cldfmc, & 1.41532e-02_rb, 1.38734e-02_rb, 1.36028e-02_rb, 1.33410e-02_rb, 1.30875e-02_rb, & 1.28420e-02_rb, 1.26041e-02_rb, 1.23735e-02_rb, 1.21497e-02_rb, 1.19325e-02_rb, & 1.17216e-02_rb, 1.15168e-02_rb, 1.13177e-02_rb, 1.11241e-02_rb, 1.09358e-02_rb, & - 1.07525e-02_rb, 1.05741e-02_rb, 1.04003e-02_rb/) + 1.07525e-02_rb, 1.05741e-02_rb, 1.04003e-02_rb/) !jm not thread safe hvrclc = '$Revision: 1.8 $' @@ -8786,76 +8786,76 @@ subroutine cldprmc(nlayers, inflag, iceflag, liqflag, cldfmc, & if (radice .lt. 5.0_rb .or. radice .gt. 140.0_rb) then write(errmess,'(A,i5,i5,f8.2,f8.2)' ) & & 'ERROR: ICE GENERALIZED EFFECTIVE SIZE OUT OF BOUNDS' & - & ,ig, lay, ciwpmc(ig,lay), radice - !mz call wrf_error_fatal(errmess) - end if - ncbands = 16 - factor = (radice - 2._rb)/3._rb - index = int(factor) - if (index .eq. 46) index = 45 - fint = factor - float(index) - ib = ngb(ig) + & ,ig, lay, ciwpmc(ig,lay), radice + !mz call wrf_error_fatal(errmess) + end if + ncbands = 16 + factor = (radice - 2._rb)/3._rb + index = int(factor) + if (index .eq. 46) index = 45 + fint = factor - float(index) + ib = ngb(ig) abscoice(ig) = & & absice3(index,ib) + fint * & - & (absice3(index+1,ib) - (absice3(index,ib))) - abscosno(ig) = 0.0_rb - - endif - -!..Incorporate additional effects due to snow. - if (cswpmc(ig,lay).gt.0.0_rb .and. iceflag .eq. 5) then - radsno = resnmc(lay) - if (radsno .lt. 5.0_rb .or. radsno .gt. 140.0_rb) then + & (absice3(index+1,ib) - (absice3(index,ib))) + abscosno(ig) = 0.0_rb + + endif + +!..Incorporate additional effects due to snow. + if (cswpmc(ig,lay).gt.0.0_rb .and. iceflag .eq. 5) then + radsno = resnmc(lay) + if (radsno .lt. 5.0_rb .or. radsno .gt. 140.0_rb) then write(errmess,'(A,i5,i5,f8.2,f8.2)' ) & - & 'ERROR: SNOW GENERALIZED EFFECTIVE SIZE OUT OF BOUNDS' & - & ,ig, lay, cswpmc(ig,lay), radsno - !mz call wrf_error_fatal(errmess) - end if - ncbands = 16 - factor = (radsno - 2._rb)/3._rb - index = int(factor) - if (index .eq. 46) index = 45 - fint = factor - float(index) - ib = ngb(ig) + & 'ERROR: SNOW GENERALIZED EFFECTIVE SIZE OUT OF BOUNDS' & + & ,ig, lay, cswpmc(ig,lay), radsno + !mz call wrf_error_fatal(errmess) + end if + ncbands = 16 + factor = (radsno - 2._rb)/3._rb + index = int(factor) + if (index .eq. 46) index = 45 + fint = factor - float(index) + ib = ngb(ig) abscosno(ig) = & & absice3(index,ib) + fint * & - & (absice3(index+1,ib) - (absice3(index,ib))) - endif - - - -! Calculation of absorption coefficients due to water clouds. - if (clwpmc(ig,lay) .eq. 0.0_rb) then - abscoliq(ig) = 0.0_rb - - elseif (liqflag .eq. 0) then - abscoliq(ig) = absliq0 - - elseif (liqflag .eq. 1) then - radliq = relqmc(lay) + & (absice3(index+1,ib) - (absice3(index,ib))) + endif + + + +! Calculation of absorption coefficients due to water clouds. + if (clwpmc(ig,lay) .eq. 0.0_rb) then + abscoliq(ig) = 0.0_rb + + elseif (liqflag .eq. 0) then + abscoliq(ig) = absliq0 + + elseif (liqflag .eq. 1) then + radliq = relqmc(lay) if (radliq .lt. 2.5_rb .or. radliq .gt. 60._rb) stop & - & 'LIQUID EFFECTIVE RADIUS OUT OF BOUNDS' - index = int(radliq - 1.5_rb) - if (index .eq. 0) index = 1 - if (index .eq. 58) index = 57 - fint = radliq - 1.5_rb - float(index) - ib = ngb(ig) + & 'LIQUID EFFECTIVE RADIUS OUT OF BOUNDS' + index = int(radliq - 1.5_rb) + if (index .eq. 0) index = 1 + if (index .eq. 58) index = 57 + fint = radliq - 1.5_rb - float(index) + ib = ngb(ig) abscoliq(ig) = & & absliq1(index,ib) + fint * & - & (absliq1(index+1,ib) - (absliq1(index,ib))) - endif - + & (absliq1(index+1,ib) - (absliq1(index,ib))) + endif + taucmc(ig,lay) = ciwpmc(ig,lay) * abscoice(ig) + & & clwpmc(ig,lay) * abscoliq(ig) + & - & cswpmc(ig,lay) * abscosno(ig) - - endif - endif - enddo - enddo - - end subroutine cldprmc - + & cswpmc(ig,lay) * abscosno(ig) + + endif + endif + enddo + enddo + + end subroutine cldprmc + !........................................!$ end module rrtmg_lw !$ diff --git a/physics/radsw_main.F90 b/physics/radsw_main.F90 index 321414976..8465f2dd2 100644 --- a/physics/radsw_main.F90 +++ b/physics/radsw_main.F90 @@ -264,9 +264,9 @@ !!!!! end descriptions !!!!! !!!!! ============================================================== !!!!! -!> This module contains the CCPP-compliant NCEP's modifications of the rrtm-sw radiation -!! code from aer inc. - module rrtmg_sw +!> This module contains the CCPP-compliant NCEP's modifications of the rrtm-sw radiation +!! code from aer inc. + module rrtmg_sw ! use physparam, only : iswrate, iswrgas, iswcliq, iswcice, & & isubcsw, icldflg, iovrsw, ivflip, & @@ -369,7 +369,7 @@ module rrtmg_sw ! --- public accessable subprograms public rrtmg_sw_init, rrtmg_sw_run, rrtmg_sw_finalize, rswinit, & - & kissvec, generate_stochastic_clouds_sw, mcica_subcol_sw + & kissvec, generate_stochastic_clouds_sw, mcica_subcol_sw ! ================= @@ -668,8 +668,8 @@ subroutine rrtmg_sw_run & real (kind=kind_phys), dimension(npts,nlay), intent(in) :: & & plyr, tlyr, qlyr, olyr, dzlyr, delpin - real (kind=kind_phys),dimension(npts),intent(in):: sfcalb_nir_dir - real (kind=kind_phys),dimension(npts),intent(in):: sfcalb_nir_dif + real (kind=kind_phys),dimension(npts),intent(in):: sfcalb_nir_dir + real (kind=kind_phys),dimension(npts),intent(in):: sfcalb_nir_dif real (kind=kind_phys),dimension(npts),intent(in):: sfcalb_uvis_dir real (kind=kind_phys),dimension(npts),intent(in):: sfcalb_uvis_dif @@ -745,11 +745,11 @@ subroutine rrtmg_sw_run & real(kind=kind_phys),dimension(ngptsw,npts,nlay) :: taucmcl ! In-cloud optical depth ! Dimensions: (ngptsw,ncol,nlay) real(kind=kind_phys),dimension(ngptsw,npts,nlay) :: ssacmcl ! in-cloud single scattering albedo [mcica] - ! Dimensions: (ngptsw,ncol,nlay) + ! Dimensions: (ngptsw,ncol,nlay) real(kind=kind_phys),dimension(ngptsw,npts,nlay) :: asmcmcl ! in-cloud asymmetry parameter [mcica] - ! Dimensions: (ngptsw,ncol,nlay) - real(kind=kind_phys),dimension(ngptsw,npts,nlay) :: fsfcmcl ! in-cloud forward scattering fraction [mcica] - ! Dimensions: (ngptsw,ncol,nlay) + ! Dimensions: (ngptsw,ncol,nlay) + real(kind=kind_phys),dimension(ngptsw,npts,nlay) :: fsfcmcl ! in-cloud forward scattering fraction [mcica] + ! Dimensions: (ngptsw,ncol,nlay) !HWRF cldprmc_sw input ! real(kind=kind_phys),dimension(ngptsw,nlay) :: cldfmc,cldfmc_save! cloud fraction [mcica] ! ! Dimensions: (ngptsw,nlayers) @@ -761,30 +761,30 @@ subroutine rrtmg_sw_run & ! Dimensions: (ngptsw,nlayers) real(kind=kind_phys),dimension(nlay) :: resnmc ! cloud snow particle effective radius (microns) ! Dimensions: (nlayers) - real(kind=kind_phys),dimension(nlay) :: relqmc ! cloud liquid particle effective radius (microns) - ! Dimensions: (nlayers) - real(kind=kind_phys),dimension(nlay) :: reicmc ! cloud ice particle effective radius (microns) - ! Dimensions: (nlayers) - ! specific definition of reicmc depends on setting of iceflag: + real(kind=kind_phys),dimension(nlay) :: relqmc ! cloud liquid particle effective radius (microns) + ! Dimensions: (nlayers) + real(kind=kind_phys),dimension(nlay) :: reicmc ! cloud ice particle effective radius (microns) + ! Dimensions: (nlayers) + ! specific definition of reicmc depends on setting of iceflag: ! iceflag = 1: ice effective radius, r_ec, (Ebert and Curry, 1992), - ! r_ec range is limited to 13.0 to 130.0 microns - ! iceflag = 2: ice effective radius, r_k, (Key, Streamer Ref. Manual, 1996) - ! r_k range is limited to 5.0 to 131.0 microns - ! iceflag = 3: generalized effective size, dge, (Fu, 1996), - ! dge range is limited to 5.0 to 140.0 microns - ! [dge = 1.0315 * r_ec] - real(kind=kind_phys),dimension(ngptsw,nlay) :: fsfcmc ! cloud forward scattering fraction - ! Dimensions: (ngptsw,nlayers) + ! r_ec range is limited to 13.0 to 130.0 microns + ! iceflag = 2: ice effective radius, r_k, (Key, Streamer Ref. Manual, 1996) + ! r_k range is limited to 5.0 to 131.0 microns + ! iceflag = 3: generalized effective size, dge, (Fu, 1996), + ! dge range is limited to 5.0 to 140.0 microns + ! [dge = 1.0315 * r_ec] + real(kind=kind_phys),dimension(ngptsw,nlay) :: fsfcmc ! cloud forward scattering fraction + ! Dimensions: (ngptsw,nlayers) !mz* HWRF cldprmc_sw output (delta scaled) - real(kind=kind_phys),dimension(ngptsw,nlay) :: taucmc ! cloud optical depth (delta scaled) - ! Dimensions: (ngptsw,nlayers) - real(kind=kind_phys),dimension(ngptsw,nlay) :: ssacmc ! single scattering albedo (delta scaled) - ! Dimensions: (ngptsw,nlayers) - real(kind=kind_phys),dimension(ngptsw,nlay) :: asmcmc ! asymmetry parameter (delta scaled) - ! Dimensions: (ngptsw,nlayers) - real(kind=kind_phys),dimension(ngptsw,nlay) :: taormc ! cloud optical depth (non-delta scaled) - ! Dimensions: (ngptsw,nlayers) + real(kind=kind_phys),dimension(ngptsw,nlay) :: taucmc ! cloud optical depth (delta scaled) + ! Dimensions: (ngptsw,nlayers) + real(kind=kind_phys),dimension(ngptsw,nlay) :: ssacmc ! single scattering albedo (delta scaled) + ! Dimensions: (ngptsw,nlayers) + real(kind=kind_phys),dimension(ngptsw,nlay) :: asmcmc ! asymmetry parameter (delta scaled) + ! Dimensions: (ngptsw,nlayers) + real(kind=kind_phys),dimension(ngptsw,nlay) :: taormc ! cloud optical depth (non-delta scaled) + ! Dimensions: (ngptsw,nlayers) !mz* real (kind=kind_phys), dimension(nlay,ngptsw) :: cldfmc, & @@ -946,7 +946,7 @@ subroutine rrtmg_sw_run & !Add layer height needed for exponential (icld=4) and -! exponential-random (icld=5) overlap options +! exponential-random (icld=5) overlap options !iplon = 1 irng = 0 @@ -962,7 +962,7 @@ subroutine rrtmg_sw_run & enddo ! Zero out cloud optical properties here; not used when passing physical properties -! to radiation and taucld is calculated in radiation +! to radiation and taucld is calculated in radiation do k = 1, nlay do ib = 1, nbdsw taucld3(ib,j1,k) = 0.0 @@ -979,7 +979,7 @@ subroutine rrtmg_sw_run & & cld_ref_snow, taucld3,ssacld3,asmcld3,fsfcld3, & & cldfmcl, ciwpmcl, clwpmcl, cswpmcl, & !--output & reicmcl, relqmcl, resnmcl, & - & taucmcl, ssacmcl, asmcmcl, fsfcmcl) + & taucmcl, ssacmcl, asmcmcl, fsfcmcl) endif !mz* end @@ -1183,7 +1183,7 @@ subroutine rrtmg_sw_run & enddo if (iovrsw == 4) then !mz* HWRF !mz* Move incoming GCM cloud arrays to RRTMG cloud arrays. -!For GCM input, incoming reicmcl is defined based on selected +!For GCM input, incoming reicmcl is defined based on selected !ice parameterization (inflglw) do k = 1, nlay do ig = 1, ngptsw @@ -1258,7 +1258,7 @@ subroutine rrtmg_sw_run & do k = 1, nlay do ig = 1, ngptsw cldfmc_save(k,ig)=cldfmc (k,ig) - enddo + enddo enddo endif @@ -1270,14 +1270,14 @@ subroutine rrtmg_sw_run & & taucw, ssacw, asycw, cldfrc, cldfmc & & ) - if (iovrsw == 4) then - !mz for HWRF, still using mcica cldfmc - do k = 1, nlay - do ig = 1, ngptsw - cldfmc(k,ig)=cldfmc_save(k,ig) - enddo - enddo - endif + if (iovrsw == 4) then + !mz for HWRF, still using mcica cldfmc + do k = 1, nlay + do ig = 1, ngptsw + cldfmc(k,ig)=cldfmc_save(k,ig) + enddo + enddo + endif ! --- ... save computed layer cloud optical depth for output ! rrtm band 10 is approx to the 0.55 mu spectrum @@ -1674,7 +1674,7 @@ subroutine rswinit & heatfac = con_g * 1.0e-2 / con_cp ! (in k/second) endif -!> -# Define exponential lookup tables for transmittance. +!> -# Define exponential lookup tables for transmittance. ! tau is computed as a function of the \a tau transition function, and ! transmittance is calculated as a function of tau. all tables ! are computed at intervals of 0.0001. the inverse of the @@ -2790,11 +2790,11 @@ subroutine spcvrtc & zasy3 = 0.75 * zasy1 !> - Perform general two-stream expressions: -!!\n control parameters in module "physparam" -!!\n iswmode - control flag for 2-stream transfer schemes -!!\n = 1 delta-eddington (joseph et al., 1976) -!!\n = 2 pifm (zdunkowski et al., 1980) -!!\n = 3 discrete ordinates (liou, 1973) +!!\n control parameters in module "physparam" +!!\n iswmode - control flag for 2-stream transfer schemes +!!\n = 1 delta-eddington (joseph et al., 1976) +!!\n = 2 pifm (zdunkowski et al., 1980) +!!\n = 3 discrete ordinates (liou, 1973) if ( iswmode == 1 ) then zgam1 = 1.75 - zssa1 * (f_one + zasy3) zgam2 =-0.25 + zssa1 * (f_one - zasy3) @@ -3568,10 +3568,10 @@ subroutine spcvrtm & zasy3 = 0.75 * zasy1 !> - Perform general two-stream expressions: -!!\n control parameters in module "physparam" -!!\n iswmode - control flag for 2-stream transfer schemes -!!\n = 1 delta-eddington (joseph et al., 1976) -!!\n = 2 pifm (zdunkowski et al., 1980) +!!\n control parameters in module "physparam" +!!\n iswmode - control flag for 2-stream transfer schemes +!!\n = 1 delta-eddington (joseph et al., 1976) +!!\n = 2 pifm (zdunkowski et al., 1980) !!\n = 3 discrete ordinates (liou, 1973) if ( iswmode == 1 ) then zgam1 = 1.75 - zssa1 * (f_one + zasy3) @@ -3799,7 +3799,7 @@ subroutine spcvrtm & endif zgam4 = f_one - zgam3 -!> - Compute homogeneous reflectance and transmittance for both convertive +!> - Compute homogeneous reflectance and transmittance for both convertive !! and non-convertive scattering. if ( zssaw >= zcrit ) then ! for conservative scattering @@ -5666,568 +5666,568 @@ subroutine mcica_subcol_sw(iplon, ncol, nlay, icld, permuteseed, & & ssac, asmc, fsfc, & & cldfmcl, ciwpmcl, clwpmcl, cswpmcl, reicmcl, & & relqmcl, resnmcl, & - & taucmcl, ssacmcl, asmcmcl, fsfcmcl) - -! ----- Input ----- -! Control - integer(kind=im), intent(in) :: iplon ! column/longitude dimension - integer(kind=im), intent(in) :: ncol ! number of columns - integer(kind=im), intent(in) :: nlay ! number of model layers - integer(kind=im), intent(in) :: icld ! clear/cloud, cloud overlap flag - integer(kind=im), intent(in) :: permuteseed ! if the cloud generator is called multiple times, + & taucmcl, ssacmcl, asmcmcl, fsfcmcl) + +! ----- Input ----- +! Control + integer(kind=im), intent(in) :: iplon ! column/longitude dimension + integer(kind=im), intent(in) :: ncol ! number of columns + integer(kind=im), intent(in) :: nlay ! number of model layers + integer(kind=im), intent(in) :: icld ! clear/cloud, cloud overlap flag + integer(kind=im), intent(in) :: permuteseed ! if the cloud generator is called multiple times, ! permute the seed between each call; ! between calls for LW and SW, recommended - ! permuteseed differs by 'ngpt' - integer(kind=im), intent(inout) :: irng ! flag for random number generator - ! 0 = kissvec - ! 1 = Mersenne Twister - -! Atmosphere - real(kind=rb), intent(in) :: play(:,:) ! layer pressures (mb) - ! Dimensions: (ncol,nlay) - real(kind=rb), intent(in) :: hgt(:,:) ! layer height (m) - ! Dimensions: (ncol,nlay) - -! Atmosphere/clouds - cldprop - real(kind=rb), intent(in) :: cldfrac(:,:) ! layer cloud fraction - ! Dimensions: (ncol,nlay) - real(kind=rb), intent(in) :: tauc(:,:,:) ! in-cloud optical depth - ! Dimensions: (nbndsw,ncol,nlay) + ! permuteseed differs by 'ngpt' + integer(kind=im), intent(inout) :: irng ! flag for random number generator + ! 0 = kissvec + ! 1 = Mersenne Twister + +! Atmosphere + real(kind=rb), intent(in) :: play(:,:) ! layer pressures (mb) + ! Dimensions: (ncol,nlay) + real(kind=rb), intent(in) :: hgt(:,:) ! layer height (m) + ! Dimensions: (ncol,nlay) + +! Atmosphere/clouds - cldprop + real(kind=rb), intent(in) :: cldfrac(:,:) ! layer cloud fraction + ! Dimensions: (ncol,nlay) + real(kind=rb), intent(in) :: tauc(:,:,:) ! in-cloud optical depth + ! Dimensions: (nbndsw,ncol,nlay) real(kind=rb), intent(in) :: ssac(:,:,:) ! in-cloud single scattering albedo (non-delta scaled) - ! Dimensions: (nbndsw,ncol,nlay) - real(kind=rb), intent(in) :: asmc(:,:,:) ! in-cloud asymmetry parameter (non-delta scaled) - ! Dimensions: (nbndsw,ncol,nlay) + ! Dimensions: (nbndsw,ncol,nlay) + real(kind=rb), intent(in) :: asmc(:,:,:) ! in-cloud asymmetry parameter (non-delta scaled) + ! Dimensions: (nbndsw,ncol,nlay) real(kind=rb), intent(in) :: fsfc(:,:,:) ! in-cloud forward scattering fraction (non-delta scaled) - ! Dimensions: (nbndsw,ncol,nlay) - real(kind=rb), intent(in) :: ciwp(:,:) ! in-cloud ice water path - ! Dimensions: (ncol,nlay) - real(kind=rb), intent(in) :: clwp(:,:) ! in-cloud liquid water path - ! Dimensions: (ncol,nlay) - real(kind=rb), intent(in) :: cswp(:,:) ! in-cloud snow water path - ! Dimensions: (ncol,nlay) - real(kind=rb), intent(in) :: rei(:,:) ! cloud ice particle size - ! Dimensions: (ncol,nlay) - real(kind=rb), intent(in) :: rel(:,:) ! cloud liquid particle size - ! Dimensions: (ncol,nlay) - real(kind=rb), intent(in) :: res(:,:) ! cloud snow particle size - ! Dimensions: (ncol,nlay) - -! ----- Output ----- -! Atmosphere/clouds - cldprmc [mcica] - real(kind=rb), intent(out) :: cldfmcl(:,:,:) ! cloud fraction [mcica] - ! Dimensions: (ngptsw,ncol,nlay) - real(kind=rb), intent(out) :: ciwpmcl(:,:,:) ! in-cloud ice water path [mcica] - ! Dimensions: (ngptsw,ncol,nlay) - real(kind=rb), intent(out) :: clwpmcl(:,:,:) ! in-cloud liquid water path [mcica] - ! Dimensions: (ngptsw,ncol,nlay) - real(kind=rb), intent(out) :: cswpmcl(:,:,:) ! in-cloud snow water path [mcica] - ! Dimensions: (ngptsw,ncol,nlay) - real(kind=rb), intent(out) :: relqmcl(:,:) ! liquid particle size (microns) - ! Dimensions: (ncol,nlay) - real(kind=rb), intent(out) :: reicmcl(:,:) ! ice partcle size (microns) - ! Dimensions: (ncol,nlay) - real(kind=rb), intent(out) :: resnmcl(:,:) ! snow partcle size (microns) - ! Dimensions: (ncol,nlay) - real(kind=rb), intent(out) :: taucmcl(:,:,:) ! in-cloud optical depth [mcica] - ! Dimensions: (ngptsw,ncol,nlay) + ! Dimensions: (nbndsw,ncol,nlay) + real(kind=rb), intent(in) :: ciwp(:,:) ! in-cloud ice water path + ! Dimensions: (ncol,nlay) + real(kind=rb), intent(in) :: clwp(:,:) ! in-cloud liquid water path + ! Dimensions: (ncol,nlay) + real(kind=rb), intent(in) :: cswp(:,:) ! in-cloud snow water path + ! Dimensions: (ncol,nlay) + real(kind=rb), intent(in) :: rei(:,:) ! cloud ice particle size + ! Dimensions: (ncol,nlay) + real(kind=rb), intent(in) :: rel(:,:) ! cloud liquid particle size + ! Dimensions: (ncol,nlay) + real(kind=rb), intent(in) :: res(:,:) ! cloud snow particle size + ! Dimensions: (ncol,nlay) + +! ----- Output ----- +! Atmosphere/clouds - cldprmc [mcica] + real(kind=rb), intent(out) :: cldfmcl(:,:,:) ! cloud fraction [mcica] + ! Dimensions: (ngptsw,ncol,nlay) + real(kind=rb), intent(out) :: ciwpmcl(:,:,:) ! in-cloud ice water path [mcica] + ! Dimensions: (ngptsw,ncol,nlay) + real(kind=rb), intent(out) :: clwpmcl(:,:,:) ! in-cloud liquid water path [mcica] + ! Dimensions: (ngptsw,ncol,nlay) + real(kind=rb), intent(out) :: cswpmcl(:,:,:) ! in-cloud snow water path [mcica] + ! Dimensions: (ngptsw,ncol,nlay) + real(kind=rb), intent(out) :: relqmcl(:,:) ! liquid particle size (microns) + ! Dimensions: (ncol,nlay) + real(kind=rb), intent(out) :: reicmcl(:,:) ! ice partcle size (microns) + ! Dimensions: (ncol,nlay) + real(kind=rb), intent(out) :: resnmcl(:,:) ! snow partcle size (microns) + ! Dimensions: (ncol,nlay) + real(kind=rb), intent(out) :: taucmcl(:,:,:) ! in-cloud optical depth [mcica] + ! Dimensions: (ngptsw,ncol,nlay) real(kind=rb), intent(out) :: ssacmcl(:,:,:) ! in-cloud single scattering albedo [mcica] - ! Dimensions: (ngptsw,ncol,nlay) + ! Dimensions: (ngptsw,ncol,nlay) real(kind=rb), intent(out) :: asmcmcl(:,:,:) ! in-cloud asymmetry parameter [mcica] - ! Dimensions: (ngptsw,ncol,nlay) - real(kind=rb), intent(out) :: fsfcmcl(:,:,:) ! in-cloud forward scattering fraction [mcica] - ! Dimensions: (ngptsw,ncol,nlay) + ! Dimensions: (ngptsw,ncol,nlay) + real(kind=rb), intent(out) :: fsfcmcl(:,:,:) ! in-cloud forward scattering fraction [mcica] + ! Dimensions: (ngptsw,ncol,nlay) -! ----- Local ----- +! ----- Local ----- -! Stochastic cloud generator variables [mcica] +! Stochastic cloud generator variables [mcica] integer(kind=im), parameter :: nsubcsw = ngptsw ! number of sub-columns (g-point intervals) - integer(kind=im) :: ilev ! loop index + integer(kind=im) :: ilev ! loop index - real(kind=rb) :: pmid(ncol,nlay) ! layer pressures (Pa) -! real(kind=rb) :: pdel(ncol,nlay) ! layer pressure thickness (Pa) -! real(kind=rb) :: qi(ncol,nlay) ! ice water (specific humidity) -! real(kind=rb) :: ql(ncol,nlay) ! liq water (specific humidity) + real(kind=rb) :: pmid(ncol,nlay) ! layer pressures (Pa) +! real(kind=rb) :: pdel(ncol,nlay) ! layer pressure thickness (Pa) +! real(kind=rb) :: qi(ncol,nlay) ! ice water (specific humidity) +! real(kind=rb) :: ql(ncol,nlay) ! liq water (specific humidity) -! Return if clear sky - if (icld.eq.0) return +! Return if clear sky + if (icld.eq.0) return -! NOTE: For GCM mode, permuteseed must be offset between LW and SW by at least number of subcolumns +! NOTE: For GCM mode, permuteseed must be offset between LW and SW by at least number of subcolumns -! Pass particle sizes to new arrays, no subcolumns for these properties yet -! Convert pressures from mb to Pa +! Pass particle sizes to new arrays, no subcolumns for these properties yet +! Convert pressures from mb to Pa - reicmcl(:ncol,:nlay) = rei(:ncol,:nlay) - relqmcl(:ncol,:nlay) = rel(:ncol,:nlay) + reicmcl(:ncol,:nlay) = rei(:ncol,:nlay) + relqmcl(:ncol,:nlay) = rel(:ncol,:nlay) resnmcl(:ncol,:nlay) = res(:ncol,:nlay) - pmid(:ncol,:nlay) = play(:ncol,:nlay)*1.e2_rb - -! Convert input ice and liquid cloud water paths to specific humidity ice and liquid components - -! cwp = (q * pdel * 1000.) / gravit) -! = (kg/kg * kg m-1 s-2 *1000.) / m s-2 -! = (g m-2) -! -! q = (cwp * gravit) / (pdel *1000.) -! = (g m-2 * m s-2) / (kg m-1 s-2 * 1000.) -! = kg/kg - -! do ilev = 1, nlay -! qi(ilev) = (ciwp(ilev) * grav) / (pdel(ilev) * 1000._rb) -! ql(ilev) = (clwp(ilev) * grav) / (pdel(ilev) * 1000._rb) -! enddo + pmid(:ncol,:nlay) = play(:ncol,:nlay)*1.e2_rb + +! Convert input ice and liquid cloud water paths to specific humidity ice and liquid components + +! cwp = (q * pdel * 1000.) / gravit) +! = (kg/kg * kg m-1 s-2 *1000.) / m s-2 +! = (g m-2) +! +! q = (cwp * gravit) / (pdel *1000.) +! = (g m-2 * m s-2) / (kg m-1 s-2 * 1000.) +! = kg/kg + +! do ilev = 1, nlay +! qi(ilev) = (ciwp(ilev) * grav) / (pdel(ilev) * 1000._rb) +! ql(ilev) = (clwp(ilev) * grav) / (pdel(ilev) * 1000._rb) +! enddo call generate_stochastic_clouds_sw (ncol, nlay, nsubcsw, icld, & & irng, pmid, hgt, cldfrac, clwp, ciwp, cswp, & & tauc, ssac, asmc, fsfc, cldfmcl, clwpmcl, & & ciwpmcl, cswpmcl, & - & taucmcl, ssacmcl, asmcmcl, fsfcmcl, permuteseed) + & taucmcl, ssacmcl, asmcmcl, fsfcmcl, permuteseed) - end subroutine mcica_subcol_sw + end subroutine mcica_subcol_sw !------------------------------------------------------------------------------------------------- subroutine generate_stochastic_clouds_sw(ncol, nlay, nsubcol, & & icld, irng, pmid, hgt, cld, clwp, ciwp, cswp, & & tauc, ssac, asmc, fsfc, cld_stoch, clwp_stoch, & & ciwp_stoch, cswp_stoch, & - & tauc_stoch, ssac_stoch, asmc_stoch, fsfc_stoch, changeSeed) -!------------------------------------------------------------------------------------------------- -! Contact: Cecile Hannay (hannay@ucar.edu) -! -! Original code: Based on Raisanen et al., QJRMS, 2004. -! + & tauc_stoch, ssac_stoch, asmc_stoch, fsfc_stoch, changeSeed) +!------------------------------------------------------------------------------------------------- +! Contact: Cecile Hannay (hannay@ucar.edu) +! +! Original code: Based on Raisanen et al., QJRMS, 2004. +! ! Modifications: Generalized for use with RRTMG and added Mersenne Twister as the default -! random number generator, which can be changed to the optional kissvec random number generator -! with flag 'irng'. Some extra functionality has been commented or removed. -! Michael J. Iacono, AER, Inc., February 2007 -! -! Given a profile of cloud fraction, cloud water and cloud ice, we produce a set of subcolumns. -! Each layer within each subcolumn is homogeneous, with cloud fraction equal to zero or one -! and uniform cloud liquid and cloud ice concentration. -! The ensemble as a whole reproduces the probability function of cloud liquid and ice within each layer -! and obeys an overlap assumption in the vertical. -! -! Overlap assumption: -! The cloud are consistent with 4 overlap assumptions: random, maximum, maximum-random and exponential. -! The default option is maximum-random (option 3) +! random number generator, which can be changed to the optional kissvec random number generator +! with flag 'irng'. Some extra functionality has been commented or removed. +! Michael J. Iacono, AER, Inc., February 2007 +! +! Given a profile of cloud fraction, cloud water and cloud ice, we produce a set of subcolumns. +! Each layer within each subcolumn is homogeneous, with cloud fraction equal to zero or one +! and uniform cloud liquid and cloud ice concentration. +! The ensemble as a whole reproduces the probability function of cloud liquid and ice within each layer +! and obeys an overlap assumption in the vertical. +! +! Overlap assumption: +! The cloud are consistent with 4 overlap assumptions: random, maximum, maximum-random and exponential. +! The default option is maximum-random (option 3) ! The options are: 1=random overlap, 2=max/random, 3=maximum overlap, 4=exponential overlap -! This is set with the variable "overlap" -!mji - Exponential overlap option (overlap=4) has been deactivated in this version -! The exponential overlap uses also a length scale, Zo. (real, parameter :: Zo = 2500. ) -! -! Seed: -! If the stochastic cloud generator is called several times during the same timestep, +! This is set with the variable "overlap" +!mji - Exponential overlap option (overlap=4) has been deactivated in this version +! The exponential overlap uses also a length scale, Zo. (real, parameter :: Zo = 2500. ) +! +! Seed: +! If the stochastic cloud generator is called several times during the same timestep, ! one should change the seed between the call to insure that the subcolumns are different. -! This is done by changing the argument 'changeSeed' +! This is done by changing the argument 'changeSeed' ! For example, if one wants to create a set of columns for the shortwave and another set for the longwave , -! use 'changeSeed = 1' for the first call and'changeSeed = 2' for the second call -! -! PDF assumption: -! We can use arbitrary complicated PDFS. -! In the present version, we produce homogeneuous clouds (the simplest case). -! Future developments include using the PDF scheme of Ben Johnson. -! -! History file: +! use 'changeSeed = 1' for the first call and'changeSeed = 2' for the second call +! +! PDF assumption: +! We can use arbitrary complicated PDFS. +! In the present version, we produce homogeneuous clouds (the simplest case). +! Future developments include using the PDF scheme of Ben Johnson. +! +! History file: ! Option to add diagnostics variables in the history file. (using FINCL in the namelist) -! nsubcol = number of subcolumns -! overlap = overlap type (1-3) +! nsubcol = number of subcolumns +! overlap = overlap type (1-3) ! Zo = length scale -! CLOUD_S = mean of the subcolumn cloud fraction ('_S" means Stochastic) +! CLOUD_S = mean of the subcolumn cloud fraction ('_S" means Stochastic) ! CLDLIQ_S = mean of the subcolumn cloud water -! CLDICE_S = mean of the subcolumn cloud ice -! -! -! Note: -! Here: we force that the cloud condensate to be consistent with the cloud fraction -! i.e we only have cloud condensate when the cell is cloudy. -! In CAM: The cloud condensate and the cloud fraction are obtained from 2 different equations -! and the 2 quantities can be inconsistent (i.e. CAM can produce cloud fraction -! without cloud condensate or the opposite). +! CLDICE_S = mean of the subcolumn cloud ice +! +! +! Note: +! Here: we force that the cloud condensate to be consistent with the cloud fraction +! i.e we only have cloud condensate when the cell is cloudy. +! In CAM: The cloud condensate and the cloud fraction are obtained from 2 different equations +! and the 2 quantities can be inconsistent (i.e. CAM can produce cloud fraction +! without cloud condensate or the opposite). !---------------------------------------------------------------------- - + use mcica_random_numbers -! The Mersenne Twister random number engine - use MersenneTwister, only: randomNumberSequence, & - new_RandomNumberSequence, getRandomReal - - type(randomNumberSequence) :: randomNumbers - +! The Mersenne Twister random number engine + use MersenneTwister, only: randomNumberSequence, & + new_RandomNumberSequence, getRandomReal + + type(randomNumberSequence) :: randomNumbers + ! -- Arguments - - integer(kind=im), intent(in) :: ncol ! number of layers - integer(kind=im), intent(in) :: nlay ! number of layers - integer(kind=im), intent(in) :: icld ! clear/cloud, cloud overlap flag - integer(kind=im), intent(inout) :: irng ! flag for random number generator - ! 0 = kissvec - ! 1 = Mersenne Twister + + integer(kind=im), intent(in) :: ncol ! number of layers + integer(kind=im), intent(in) :: nlay ! number of layers + integer(kind=im), intent(in) :: icld ! clear/cloud, cloud overlap flag + integer(kind=im), intent(inout) :: irng ! flag for random number generator + ! 0 = kissvec + ! 1 = Mersenne Twister integer(kind=im), intent(in) :: nsubcol ! number of sub-columns (g-point intervals) - integer(kind=im), optional, intent(in) :: changeSeed ! allows permuting seed - -! Column state (cloud fraction, cloud water, cloud ice) + variables needed to read physics state - real(kind=rb), intent(in) :: pmid(:,:) ! layer pressure (Pa) - ! Dimensions: (ncol,nlay) -! mji - Add height - real(kind=rb), intent(in) :: hgt(:,:) ! layer height (m) - ! Dimensions: (ncol,nlay) - real(kind=rb), intent(in) :: cld(:,:) ! cloud fraction - ! Dimensions: (ncol,nlay) - real(kind=rb), intent(in) :: clwp(:,:) ! in-cloud liquid water path (g/m2) - ! Dimensions: (ncol,nlay) - real(kind=rb), intent(in) :: ciwp(:,:) ! in-cloud ice water path (g/m2) - ! Dimensions: (ncol,nlay) - real(kind=rb), intent(in) :: cswp(:,:) ! in-cloud snow water path (g/m2) - ! Dimensions: (ncol,nlay) + integer(kind=im), optional, intent(in) :: changeSeed ! allows permuting seed + +! Column state (cloud fraction, cloud water, cloud ice) + variables needed to read physics state + real(kind=rb), intent(in) :: pmid(:,:) ! layer pressure (Pa) + ! Dimensions: (ncol,nlay) +! mji - Add height + real(kind=rb), intent(in) :: hgt(:,:) ! layer height (m) + ! Dimensions: (ncol,nlay) + real(kind=rb), intent(in) :: cld(:,:) ! cloud fraction + ! Dimensions: (ncol,nlay) + real(kind=rb), intent(in) :: clwp(:,:) ! in-cloud liquid water path (g/m2) + ! Dimensions: (ncol,nlay) + real(kind=rb), intent(in) :: ciwp(:,:) ! in-cloud ice water path (g/m2) + ! Dimensions: (ncol,nlay) + real(kind=rb), intent(in) :: cswp(:,:) ! in-cloud snow water path (g/m2) + ! Dimensions: (ncol,nlay) real(kind=rb), intent(in) :: tauc(:,:,:) ! in-cloud optical depth (non-delta scaled) - ! Dimensions: (nbndsw,ncol,nlay) + ! Dimensions: (nbndsw,ncol,nlay) real(kind=rb), intent(in) :: ssac(:,:,:) ! in-cloud single scattering albedo (non-delta scaled) - ! Dimensions: (nbndsw,ncol,nlay) - real(kind=rb), intent(in) :: asmc(:,:,:) ! in-cloud asymmetry parameter (non-delta scaled) + ! Dimensions: (nbndsw,ncol,nlay) + real(kind=rb), intent(in) :: asmc(:,:,:) ! in-cloud asymmetry parameter (non-delta scaled) ! Dimensions: (nbndsw,ncol,nlay) real(kind=rb), intent(in) :: fsfc(:,:,:) ! in-cloud forward scattering fraction (non-delta scaled) - ! Dimensions: (nbndsw,ncol,nlay) - real(kind=rb), intent(out) :: cld_stoch(:,:,:) ! subcolumn cloud fraction - ! Dimensions: (ngptsw,ncol,nlay) + ! Dimensions: (nbndsw,ncol,nlay) + real(kind=rb), intent(out) :: cld_stoch(:,:,:) ! subcolumn cloud fraction + ! Dimensions: (ngptsw,ncol,nlay) real(kind=rb), intent(out) :: clwp_stoch(:,:,:) ! subcolumn in-cloud liquid water path - ! Dimensions: (ngptsw,ncol,nlay) - real(kind=rb), intent(out) :: ciwp_stoch(:,:,:) ! subcolumn in-cloud ice water path - ! Dimensions: (ngptsw,ncol,nlay) - real(kind=rb), intent(out) :: cswp_stoch(:,:,:) ! subcolumn in-cloud snow water path - ! Dimensions: (ngptsw,ncol,nlay) - real(kind=rb), intent(out) :: tauc_stoch(:,:,:) ! subcolumn in-cloud optical depth - ! Dimensions: (ngptsw,ncol,nlay) - real(kind=rb), intent(out) :: ssac_stoch(:,:,:) ! subcolumn in-cloud single scattering albedo - ! Dimensions: (ngptsw,ncol,nlay) + ! Dimensions: (ngptsw,ncol,nlay) + real(kind=rb), intent(out) :: ciwp_stoch(:,:,:) ! subcolumn in-cloud ice water path + ! Dimensions: (ngptsw,ncol,nlay) + real(kind=rb), intent(out) :: cswp_stoch(:,:,:) ! subcolumn in-cloud snow water path + ! Dimensions: (ngptsw,ncol,nlay) + real(kind=rb), intent(out) :: tauc_stoch(:,:,:) ! subcolumn in-cloud optical depth + ! Dimensions: (ngptsw,ncol,nlay) + real(kind=rb), intent(out) :: ssac_stoch(:,:,:) ! subcolumn in-cloud single scattering albedo + ! Dimensions: (ngptsw,ncol,nlay) real(kind=rb), intent(out) :: asmc_stoch(:,:,:) ! subcolumn in-cloud asymmetry parameter - ! Dimensions: (ngptsw,ncol,nlay) - real(kind=rb), intent(out) :: fsfc_stoch(:,:,:) ! subcolumn in-cloud forward scattering fraction - ! Dimensions: (ngptsw,ncol,nlay) - -! -- Local variables - real(kind=rb) :: cldf(ncol,nlay) ! cloud fraction + ! Dimensions: (ngptsw,ncol,nlay) + real(kind=rb), intent(out) :: fsfc_stoch(:,:,:) ! subcolumn in-cloud forward scattering fraction + ! Dimensions: (ngptsw,ncol,nlay) + +! -- Local variables + real(kind=rb) :: cldf(ncol,nlay) ! cloud fraction ! Dimensions: (ncol,nlay) - -! Mean over the subcolumns (cloud fraction, cloud water , cloud ice) - inactive -! real(kind=rb) :: mean_cld_stoch(ncol,nlay) ! cloud fraction -! real(kind=rb) :: mean_clwp_stoch(ncol,nlay) ! cloud water -! real(kind=rb) :: mean_ciwp_stoch(ncol,nlay) ! cloud ice -! real(kind=rb) :: mean_tauc_stoch(ncol,nlay) ! cloud optical depth -! real(kind=rb) :: mean_ssac_stoch(ncol,nlay) ! cloud single scattering albedo -! real(kind=rb) :: mean_asmc_stoch(ncol,nlay) ! cloud asymmetry parameter -! real(kind=rb) :: mean_fsfc_stoch(ncol,nlay) ! cloud forward scattering fraction - -! Set overlap + +! Mean over the subcolumns (cloud fraction, cloud water , cloud ice) - inactive +! real(kind=rb) :: mean_cld_stoch(ncol,nlay) ! cloud fraction +! real(kind=rb) :: mean_clwp_stoch(ncol,nlay) ! cloud water +! real(kind=rb) :: mean_ciwp_stoch(ncol,nlay) ! cloud ice +! real(kind=rb) :: mean_tauc_stoch(ncol,nlay) ! cloud optical depth +! real(kind=rb) :: mean_ssac_stoch(ncol,nlay) ! cloud single scattering albedo +! real(kind=rb) :: mean_asmc_stoch(ncol,nlay) ! cloud asymmetry parameter +! real(kind=rb) :: mean_fsfc_stoch(ncol,nlay) ! cloud forward scattering fraction + +! Set overlap integer(kind=im) :: overlap ! 1 = random overlap, 2 = maximum-random, ! 3 = maximum overlap, 4 = exponential, - ! 5 = exponential-random - real(kind=rb), parameter :: Zo = 2500._rb ! length scale (m) - real(kind=rb), dimension(ncol,nlay) :: alpha ! overlap parameter - -! Constants (min value for cloud fraction and cloud water and ice) - real(kind=rb), parameter :: cldmin = 1.0e-20_rb ! min cloud fraction -! real(kind=rb), parameter :: qmin = 1.0e-10_rb ! min cloud water and cloud ice (not used) - -! Variables related to random number and seed - real(kind=rb), dimension(nsubcol, ncol, nlay) :: CDF, CDF2 ! random numbers - integer(kind=im), dimension(ncol) :: seed1, seed2, seed3, seed4 ! seed to create random number - real(kind=rb), dimension(ncol) :: rand_num ! random number (kissvec) - integer(kind=im) :: iseed ! seed to create random number (Mersenne Twister) - real(kind=rb) :: rand_num_mt ! random number (Mersenne Twister) - -! Flag to identify cloud fraction in subcolumns + ! 5 = exponential-random + real(kind=rb), parameter :: Zo = 2500._rb ! length scale (m) + real(kind=rb), dimension(ncol,nlay) :: alpha ! overlap parameter + +! Constants (min value for cloud fraction and cloud water and ice) + real(kind=rb), parameter :: cldmin = 1.0e-20_rb ! min cloud fraction +! real(kind=rb), parameter :: qmin = 1.0e-10_rb ! min cloud water and cloud ice (not used) + +! Variables related to random number and seed + real(kind=rb), dimension(nsubcol, ncol, nlay) :: CDF, CDF2 ! random numbers + integer(kind=im), dimension(ncol) :: seed1, seed2, seed3, seed4 ! seed to create random number + real(kind=rb), dimension(ncol) :: rand_num ! random number (kissvec) + integer(kind=im) :: iseed ! seed to create random number (Mersenne Twister) + real(kind=rb) :: rand_num_mt ! random number (Mersenne Twister) + +! Flag to identify cloud fraction in subcolumns logical, dimension(nsubcol, ncol, nlay) :: isCloudy ! flag that says whether a gridbox is cloudy - -! Indices - integer(kind=im) :: ilev, isubcol, i, n, ngbm ! indices - -!------------------------------------------------------------------------------------------ - -! Check that irng is in bounds; if not, set to default - if (irng .ne. 0) irng = 1 - -! Pass input cloud overlap setting to local variable + +! Indices + integer(kind=im) :: ilev, isubcol, i, n, ngbm ! indices + +!------------------------------------------------------------------------------------------ + +! Check that irng is in bounds; if not, set to default + if (irng .ne. 0) irng = 1 + +! Pass input cloud overlap setting to local variable overlap = icld - -! Ensure that cloud fractions are in bounds - do ilev = 1, nlay - do i = 1, ncol - cldf(i,ilev) = cld(i,ilev) - if (cldf(i,ilev) < cldmin) then - cldf(i,ilev) = 0._rb - endif - enddo - enddo - -! ----- Create seed -------- - -! Advance randum number generator by changeseed values - if (irng.eq.0) then -! For kissvec, create a seed that depends on the state of the columns. Maybe not the best way, but it works. - -! Must use pmid from bottom four layers. - do i=1,ncol - if (pmid(i,1).lt.pmid(i,2)) then + +! Ensure that cloud fractions are in bounds + do ilev = 1, nlay + do i = 1, ncol + cldf(i,ilev) = cld(i,ilev) + if (cldf(i,ilev) < cldmin) then + cldf(i,ilev) = 0._rb + endif + enddo + enddo + +! ----- Create seed -------- + +! Advance randum number generator by changeseed values + if (irng.eq.0) then +! For kissvec, create a seed that depends on the state of the columns. Maybe not the best way, but it works. + +! Must use pmid from bottom four layers. + do i=1,ncol + if (pmid(i,1).lt.pmid(i,2)) then stop 'MCICA_SUBCOL: KISSVEC SEED GENERATOR REQUIRES PMID FROM BOTTOM FOUR LAYERS.' - endif - seed1(i) = (pmid(i,1) - int(pmid(i,1))) * 1000000000_im - seed2(i) = (pmid(i,2) - int(pmid(i,2))) * 1000000000_im - seed3(i) = (pmid(i,3) - int(pmid(i,3))) * 1000000000_im - seed4(i) = (pmid(i,4) - int(pmid(i,4))) * 1000000000_im - enddo - do i=1,changeSeed - call kissvec(seed1, seed2, seed3, seed4, rand_num) - enddo - elseif (irng.eq.1) then - randomNumbers = new_RandomNumberSequence(seed = changeSeed) - endif - - -! ------ Apply overlap assumption -------- - -! generate the random numbers - - select case (overlap) - - - case(1) -! Random overlap -! i) pick a random value at every level - - if (irng.eq.0) then - do isubcol = 1,nsubcol - do ilev = 1,nlay - call kissvec(seed1, seed2, seed3, seed4, rand_num) - CDF(isubcol,:,ilev) = rand_num - enddo - enddo - elseif (irng.eq.1) then - do isubcol = 1, nsubcol - do i = 1, ncol - do ilev = 1, nlay - rand_num_mt = getRandomReal(randomNumbers) - CDF(isubcol,i,ilev) = rand_num_mt - enddo - enddo - enddo - endif - - case(2) -! Maximum-Random overlap -! i) pick a random number for top layer. -! ii) walk down the column: -! - if the layer above is cloudy, we use the same random number than in the layer above -! - if the layer above is clear, we use a new random number - - if (irng.eq.0) then - do isubcol = 1,nsubcol - do ilev = 1,nlay - call kissvec(seed1, seed2, seed3, seed4, rand_num) - CDF(isubcol,:,ilev) = rand_num - enddo - enddo - elseif (irng.eq.1) then - do isubcol = 1, nsubcol + endif + seed1(i) = (pmid(i,1) - int(pmid(i,1))) * 1000000000_im + seed2(i) = (pmid(i,2) - int(pmid(i,2))) * 1000000000_im + seed3(i) = (pmid(i,3) - int(pmid(i,3))) * 1000000000_im + seed4(i) = (pmid(i,4) - int(pmid(i,4))) * 1000000000_im + enddo + do i=1,changeSeed + call kissvec(seed1, seed2, seed3, seed4, rand_num) + enddo + elseif (irng.eq.1) then + randomNumbers = new_RandomNumberSequence(seed = changeSeed) + endif + + +! ------ Apply overlap assumption -------- + +! generate the random numbers + + select case (overlap) + + + case(1) +! Random overlap +! i) pick a random value at every level + + if (irng.eq.0) then + do isubcol = 1,nsubcol + do ilev = 1,nlay + call kissvec(seed1, seed2, seed3, seed4, rand_num) + CDF(isubcol,:,ilev) = rand_num + enddo + enddo + elseif (irng.eq.1) then + do isubcol = 1, nsubcol do i = 1, ncol - do ilev = 1, nlay - rand_num_mt = getRandomReal(randomNumbers) - CDF(isubcol,i,ilev) = rand_num_mt - enddo - enddo - enddo - endif - - do ilev = 2,nlay - do i = 1, ncol - do isubcol = 1, nsubcol - if (CDF(isubcol, i, ilev-1) > 1._rb - cldf(i,ilev-1) ) then - CDF(isubcol,i,ilev) = CDF(isubcol,i,ilev-1) - else - CDF(isubcol,i,ilev) = CDF(isubcol,i,ilev) * (1._rb - cldf(i,ilev-1)) - endif - enddo - enddo - enddo - + do ilev = 1, nlay + rand_num_mt = getRandomReal(randomNumbers) + CDF(isubcol,i,ilev) = rand_num_mt + enddo + enddo + enddo + endif + + case(2) +! Maximum-Random overlap +! i) pick a random number for top layer. +! ii) walk down the column: +! - if the layer above is cloudy, we use the same random number than in the layer above +! - if the layer above is clear, we use a new random number + + if (irng.eq.0) then + do isubcol = 1,nsubcol + do ilev = 1,nlay + call kissvec(seed1, seed2, seed3, seed4, rand_num) + CDF(isubcol,:,ilev) = rand_num + enddo + enddo + elseif (irng.eq.1) then + do isubcol = 1, nsubcol + do i = 1, ncol + do ilev = 1, nlay + rand_num_mt = getRandomReal(randomNumbers) + CDF(isubcol,i,ilev) = rand_num_mt + enddo + enddo + enddo + endif + + do ilev = 2,nlay + do i = 1, ncol + do isubcol = 1, nsubcol + if (CDF(isubcol, i, ilev-1) > 1._rb - cldf(i,ilev-1) ) then + CDF(isubcol,i,ilev) = CDF(isubcol,i,ilev-1) + else + CDF(isubcol,i,ilev) = CDF(isubcol,i,ilev) * (1._rb - cldf(i,ilev-1)) + endif + enddo + enddo + enddo + case(3) ! Maximum overlap -! i) pick same random numebr at every level - - if (irng.eq.0) then - do isubcol = 1,nsubcol - call kissvec(seed1, seed2, seed3, seed4, rand_num) - do ilev = 1,nlay - CDF(isubcol,:,ilev) = rand_num - enddo - enddo - elseif (irng.eq.1) then - do isubcol = 1, nsubcol - do i = 1, ncol - rand_num_mt = getRandomReal(randomNumbers) - do ilev = 1, nlay - CDF(isubcol,i,ilev) = rand_num_mt - enddo - enddo - enddo - endif - - -! mji - Activate exponential cloud overlap option - case(4) +! i) pick same random numebr at every level + + if (irng.eq.0) then + do isubcol = 1,nsubcol + call kissvec(seed1, seed2, seed3, seed4, rand_num) + do ilev = 1,nlay + CDF(isubcol,:,ilev) = rand_num + enddo + enddo + elseif (irng.eq.1) then + do isubcol = 1, nsubcol + do i = 1, ncol + rand_num_mt = getRandomReal(randomNumbers) + do ilev = 1, nlay + CDF(isubcol,i,ilev) = rand_num_mt + enddo + enddo + enddo + endif + + +! mji - Activate exponential cloud overlap option + case(4) ! Exponential overlap: weighting between maximum and random overlap increases with the distance. - ! The random numbers for exponential overlap verify: - ! j=1 RAN(j)=RND1 - ! j>1 if RND1 < alpha(j,j-1) => RAN(j) = RAN(j-1) - ! RAN(j) = RND2 - ! alpha is obtained from the equation - ! alpha = exp(-(Z(j)-Z(j-1))/Zo) where Zo is a characteristic length scale - - ! compute alpha - do i = 1, ncol - alpha(i, 1) = 0._rb - do ilev = 2,nlay - alpha(i, ilev) = exp( -( hgt (i, ilev) - hgt (i, ilev-1)) / Zo) - enddo - enddo - - ! generate 2 streams of random numbers - if (irng.eq.0) then - do isubcol = 1,nsubcol - do ilev = 1,nlay - call kissvec(seed1, seed2, seed3, seed4, rand_num) - CDF(isubcol, :, ilev) = rand_num - call kissvec(seed1, seed2, seed3, seed4, rand_num) - CDF2(isubcol, :, ilev) = rand_num - enddo - enddo - elseif (irng.eq.1) then - do isubcol = 1, nsubcol - do i = 1, ncol - do ilev = 1, nlay - rand_num_mt = getRandomReal(randomNumbers) - CDF(isubcol,i,ilev) = rand_num_mt - rand_num_mt = getRandomReal(randomNumbers) - CDF2(isubcol,i,ilev) = rand_num_mt - enddo - enddo - enddo - endif - - ! generate random numbers - do ilev = 2,nlay - where (CDF2(:, :, ilev) < spread(alpha (:,ilev), dim=1, nCopies=nsubcol) ) - CDF(:,:,ilev) = CDF(:,:,ilev-1) - end where - end do - -! mji - Activate exponential-random cloud overlap option - case(5) - ! Exponential-random overlap: -! call wrf_error_fatal("Cloud Overlap case 5: ER has not yet been implemented. Stopping...") - - end select - - -! -- generate subcolumns for homogeneous clouds ----- - do ilev = 1, nlay - isCloudy(:,:,ilev) = (CDF(:,:,ilev) >= 1._rb - spread(cldf(:,ilev), dim=1, nCopies=nsubcol) ) - enddo - -! where the subcolumn is cloudy, the subcolumn cloud fraction is 1; -! where the subcolumn is not cloudy, the subcolumn cloud fraction is 0; -! where there is a cloud, define the subcolumn cloud properties, -! otherwise set these to zero - - ngbm = ngb(1) - 1 - do ilev = 1,nlay - do i = 1, ncol - do isubcol = 1, nsubcol - if ( iscloudy(isubcol,i,ilev) ) then - cld_stoch(isubcol,i,ilev) = 1._rb - clwp_stoch(isubcol,i,ilev) = clwp(i,ilev) - ciwp_stoch(isubcol,i,ilev) = ciwp(i,ilev) - cswp_stoch(isubcol,i,ilev) = cswp(i,ilev) - n = ngb(isubcol) - ngbm - tauc_stoch(isubcol,i,ilev) = tauc(n,i,ilev) - ssac_stoch(isubcol,i,ilev) = ssac(n,i,ilev) - asmc_stoch(isubcol,i,ilev) = asmc(n,i,ilev) - fsfc_stoch(isubcol,i,ilev) = fsfc(n,i,ilev) - else - cld_stoch(isubcol,i,ilev) = 0._rb - clwp_stoch(isubcol,i,ilev) = 0._rb - ciwp_stoch(isubcol,i,ilev) = 0._rb - cswp_stoch(isubcol,i,ilev) = 0._rb - tauc_stoch(isubcol,i,ilev) = 0._rb - ssac_stoch(isubcol,i,ilev) = 1._rb - asmc_stoch(isubcol,i,ilev) = 0._rb - fsfc_stoch(isubcol,i,ilev) = 0._rb - endif - enddo - enddo - enddo - - -! -- compute the means of the subcolumns --- -! mean_cld_stoch(:,:) = 0._rb -! mean_clwp_stoch(:,:) = 0._rb -! mean_ciwp_stoch(:,:) = 0._rb -! mean_tauc_stoch(:,:) = 0._rb -! mean_ssac_stoch(:,:) = 0._rb -! mean_asmc_stoch(:,:) = 0._rb -! mean_fsfc_stoch(:,:) = 0._rb -! do i = 1, nsubcol -! mean_cld_stoch(:,:) = cld_stoch(i,:,:) + mean_cld_stoch(:,:) -! mean_clwp_stoch(:,:) = clwp_stoch( i,:,:) + mean_clwp_stoch(:,:) -! mean_ciwp_stoch(:,:) = ciwp_stoch( i,:,:) + mean_ciwp_stoch(:,:) -! mean_tauc_stoch(:,:) = tauc_stoch( i,:,:) + mean_tauc_stoch(:,:) -! mean_ssac_stoch(:,:) = ssac_stoch( i,:,:) + mean_ssac_stoch(:,:) -! mean_asmc_stoch(:,:) = asmc_stoch( i,:,:) + mean_asmc_stoch(:,:) -! mean_fsfc_stoch(:,:) = fsfc_stoch( i,:,:) + mean_fsfc_stoch(:,:) -! end do -! mean_cld_stoch(:,:) = mean_cld_stoch(:,:) / nsubcol -! mean_clwp_stoch(:,:) = mean_clwp_stoch(:,:) / nsubcol -! mean_ciwp_stoch(:,:) = mean_ciwp_stoch(:,:) / nsubcol -! mean_tauc_stoch(:,:) = mean_tauc_stoch(:,:) / nsubcol -! mean_ssac_stoch(:,:) = mean_ssac_stoch(:,:) / nsubcol -! mean_asmc_stoch(:,:) = mean_asmc_stoch(:,:) / nsubcol -! mean_fsfc_stoch(:,:) = mean_fsfc_stoch(:,:) / nsubcol + ! The random numbers for exponential overlap verify: + ! j=1 RAN(j)=RND1 + ! j>1 if RND1 < alpha(j,j-1) => RAN(j) = RAN(j-1) + ! RAN(j) = RND2 + ! alpha is obtained from the equation + ! alpha = exp(-(Z(j)-Z(j-1))/Zo) where Zo is a characteristic length scale + + ! compute alpha + do i = 1, ncol + alpha(i, 1) = 0._rb + do ilev = 2,nlay + alpha(i, ilev) = exp( -( hgt (i, ilev) - hgt (i, ilev-1)) / Zo) + enddo + enddo + + ! generate 2 streams of random numbers + if (irng.eq.0) then + do isubcol = 1,nsubcol + do ilev = 1,nlay + call kissvec(seed1, seed2, seed3, seed4, rand_num) + CDF(isubcol, :, ilev) = rand_num + call kissvec(seed1, seed2, seed3, seed4, rand_num) + CDF2(isubcol, :, ilev) = rand_num + enddo + enddo + elseif (irng.eq.1) then + do isubcol = 1, nsubcol + do i = 1, ncol + do ilev = 1, nlay + rand_num_mt = getRandomReal(randomNumbers) + CDF(isubcol,i,ilev) = rand_num_mt + rand_num_mt = getRandomReal(randomNumbers) + CDF2(isubcol,i,ilev) = rand_num_mt + enddo + enddo + enddo + endif + + ! generate random numbers + do ilev = 2,nlay + where (CDF2(:, :, ilev) < spread(alpha (:,ilev), dim=1, nCopies=nsubcol) ) + CDF(:,:,ilev) = CDF(:,:,ilev-1) + end where + end do + +! mji - Activate exponential-random cloud overlap option + case(5) + ! Exponential-random overlap: +! call wrf_error_fatal("Cloud Overlap case 5: ER has not yet been implemented. Stopping...") + + end select + + +! -- generate subcolumns for homogeneous clouds ----- + do ilev = 1, nlay + isCloudy(:,:,ilev) = (CDF(:,:,ilev) >= 1._rb - spread(cldf(:,ilev), dim=1, nCopies=nsubcol) ) + enddo + +! where the subcolumn is cloudy, the subcolumn cloud fraction is 1; +! where the subcolumn is not cloudy, the subcolumn cloud fraction is 0; +! where there is a cloud, define the subcolumn cloud properties, +! otherwise set these to zero + + ngbm = ngb(1) - 1 + do ilev = 1,nlay + do i = 1, ncol + do isubcol = 1, nsubcol + if ( iscloudy(isubcol,i,ilev) ) then + cld_stoch(isubcol,i,ilev) = 1._rb + clwp_stoch(isubcol,i,ilev) = clwp(i,ilev) + ciwp_stoch(isubcol,i,ilev) = ciwp(i,ilev) + cswp_stoch(isubcol,i,ilev) = cswp(i,ilev) + n = ngb(isubcol) - ngbm + tauc_stoch(isubcol,i,ilev) = tauc(n,i,ilev) + ssac_stoch(isubcol,i,ilev) = ssac(n,i,ilev) + asmc_stoch(isubcol,i,ilev) = asmc(n,i,ilev) + fsfc_stoch(isubcol,i,ilev) = fsfc(n,i,ilev) + else + cld_stoch(isubcol,i,ilev) = 0._rb + clwp_stoch(isubcol,i,ilev) = 0._rb + ciwp_stoch(isubcol,i,ilev) = 0._rb + cswp_stoch(isubcol,i,ilev) = 0._rb + tauc_stoch(isubcol,i,ilev) = 0._rb + ssac_stoch(isubcol,i,ilev) = 1._rb + asmc_stoch(isubcol,i,ilev) = 0._rb + fsfc_stoch(isubcol,i,ilev) = 0._rb + endif + enddo + enddo + enddo + + +! -- compute the means of the subcolumns --- +! mean_cld_stoch(:,:) = 0._rb +! mean_clwp_stoch(:,:) = 0._rb +! mean_ciwp_stoch(:,:) = 0._rb +! mean_tauc_stoch(:,:) = 0._rb +! mean_ssac_stoch(:,:) = 0._rb +! mean_asmc_stoch(:,:) = 0._rb +! mean_fsfc_stoch(:,:) = 0._rb +! do i = 1, nsubcol +! mean_cld_stoch(:,:) = cld_stoch(i,:,:) + mean_cld_stoch(:,:) +! mean_clwp_stoch(:,:) = clwp_stoch( i,:,:) + mean_clwp_stoch(:,:) +! mean_ciwp_stoch(:,:) = ciwp_stoch( i,:,:) + mean_ciwp_stoch(:,:) +! mean_tauc_stoch(:,:) = tauc_stoch( i,:,:) + mean_tauc_stoch(:,:) +! mean_ssac_stoch(:,:) = ssac_stoch( i,:,:) + mean_ssac_stoch(:,:) +! mean_asmc_stoch(:,:) = asmc_stoch( i,:,:) + mean_asmc_stoch(:,:) +! mean_fsfc_stoch(:,:) = fsfc_stoch( i,:,:) + mean_fsfc_stoch(:,:) +! end do +! mean_cld_stoch(:,:) = mean_cld_stoch(:,:) / nsubcol +! mean_clwp_stoch(:,:) = mean_clwp_stoch(:,:) / nsubcol +! mean_ciwp_stoch(:,:) = mean_ciwp_stoch(:,:) / nsubcol +! mean_tauc_stoch(:,:) = mean_tauc_stoch(:,:) / nsubcol +! mean_ssac_stoch(:,:) = mean_ssac_stoch(:,:) / nsubcol +! mean_asmc_stoch(:,:) = mean_asmc_stoch(:,:) / nsubcol +! mean_fsfc_stoch(:,:) = mean_fsfc_stoch(:,:) / nsubcol end subroutine generate_stochastic_clouds_sw - - -!-------------------------------------------------------------------------------------------------- - subroutine kissvec(seed1,seed2,seed3,seed4,ran_arr) -!-------------------------------------------------------------------------------------------------- + + +!-------------------------------------------------------------------------------------------------- + subroutine kissvec(seed1,seed2,seed3,seed4,ran_arr) +!-------------------------------------------------------------------------------------------------- ! public domain code made available from http://www.fortran.com/ -! downloaded by pjr on 03/16/04 for NCAR CAM -! converted to vector form, functions inlined by pjr,mvr on 05/10/2004 - -! The KISS (Keep It Simple Stupid) random number generator. Combines: -! (1) The congruential generator x(n)=69069*x(n-1)+1327217885, period 2^32. -! (2) A 3-shift shift-register generator, period 2^32-1, -! (3) Two 16-bit multiply-with-carry generators, period 597273182964842497>2^59 -! Overall period>2^123; - -! - real(kind=rb), dimension(:), intent(inout) :: ran_arr - integer(kind=im), dimension(:), intent(inout) :: seed1,seed2,seed3,seed4 - integer(kind=im) :: i,sz,kiss - integer(kind=im) :: m, k, n - -! inline function - m(k, n) = ieor (k, ishft (k, n) ) - - sz = size(ran_arr) - do i = 1, sz - seed1(i) = 69069_im * seed1(i) + 1327217885_im - seed2(i) = m (m (m (seed2(i), 13_im), - 17_im), 5_im) - seed3(i) = 18000_im * iand (seed3(i), 65535_im) + ishft (seed3(i), - 16_im) - seed4(i) = 30903_im * iand (seed4(i), 65535_im) + ishft (seed4(i), - 16_im) - kiss = seed1(i) + seed2(i) + ishft (seed3(i), 16_im) + seed4(i) - ran_arr(i) = kiss*2.328306e-10_rb + 0.5_rb - end do - - end subroutine kissvec - +! downloaded by pjr on 03/16/04 for NCAR CAM +! converted to vector form, functions inlined by pjr,mvr on 05/10/2004 + +! The KISS (Keep It Simple Stupid) random number generator. Combines: +! (1) The congruential generator x(n)=69069*x(n-1)+1327217885, period 2^32. +! (2) A 3-shift shift-register generator, period 2^32-1, +! (3) Two 16-bit multiply-with-carry generators, period 597273182964842497>2^59 +! Overall period>2^123; + +! + real(kind=rb), dimension(:), intent(inout) :: ran_arr + integer(kind=im), dimension(:), intent(inout) :: seed1,seed2,seed3,seed4 + integer(kind=im) :: i,sz,kiss + integer(kind=im) :: m, k, n + +! inline function + m(k, n) = ieor (k, ishft (k, n) ) + + sz = size(ran_arr) + do i = 1, sz + seed1(i) = 69069_im * seed1(i) + 1327217885_im + seed2(i) = m (m (m (seed2(i), 13_im), - 17_im), 5_im) + seed3(i) = 18000_im * iand (seed3(i), 65535_im) + ishft (seed3(i), - 16_im) + seed4(i) = 30903_im * iand (seed4(i), 65535_im) + ishft (seed4(i), - 16_im) + kiss = seed1(i) + seed2(i) + ishft (seed3(i), 16_im) + seed4(i) + ran_arr(i) = kiss*2.328306e-10_rb + 0.5_rb + end do + + end subroutine kissvec + !! @} ! diff --git a/physics/sfc_noah_wrfv4.F90 b/physics/sfc_noah_wrfv4.F90 index c435b2d38..33885449e 100644 --- a/physics/sfc_noah_wrfv4.F90 +++ b/physics/sfc_noah_wrfv4.F90 @@ -1,7 +1,7 @@ !> \file sfc_noah_wrfv4.F90 !! This file contains the Noah land surface scheme driver for the version of the scheme found in WRF v4.0. -!> This module contains the CCPP-compliant Noah land surface scheme driver for +!> This module contains the CCPP-compliant Noah land surface scheme driver for !! the version found in WRF v4.0. module sfc_noah_wrfv4 @@ -20,9 +20,9 @@ module sfc_noah_wrfv4 subroutine sfc_noah_wrfv4_init(lsm, lsm_noah_wrfv4, nsoil, ua_phys, fasdas, restart, errmsg, errflg) use machine, only : kind_phys - + implicit none - + integer, intent(in) :: lsm, lsm_noah_wrfv4, nsoil, fasdas logical, intent(in) :: ua_phys, restart @@ -32,32 +32,32 @@ subroutine sfc_noah_wrfv4_init(lsm, lsm_noah_wrfv4, nsoil, ua_phys, fasdas, rest ! Initialize CCPP error handling variables errmsg = '' errflg = 0 - + if (lsm/=lsm_noah_wrfv4) then write(errmsg,'(*(a))') "Logic error: namelist choice of LSM is different from NOAH WRFv4" errflg = 1 return end if - + if (nsoil < 2) then write(errmsg,'(*(a))') "The NOAH WRFv4 scheme expects at least 2 soil layers." errflg = 1 return end if - + if (ua_phys) then write(errmsg,'(*(a))') "The NOAH WRFv4 scheme has not been tested with ua_phys = T" errflg = 1 return end if - - + + if (fasdas > 0) then write(errmsg,'(*(a))') "The NOAH WRFv4 scheme has not been tested with fasdas > 0" errflg = 1 return end if - + if (restart) then !GJF: for restart functionality, the host model will need to write/read snotime (time_since_last_snowfall (s)) write(errmsg,'(*(a))') "The NOAH WRFv4 scheme has not been configured for restarts." @@ -67,7 +67,7 @@ subroutine sfc_noah_wrfv4_init(lsm, lsm_noah_wrfv4, nsoil, ua_phys, fasdas, rest !GJF: check for rdlai != F? !GJF: check for usemonalb != T? - + end subroutine sfc_noah_wrfv4_init @@ -103,19 +103,19 @@ subroutine sfc_noah_wrfv4_run (im, isice, flag_lsm, flag_lsm_glacier, srflag, is lsubf, sheat, eta, ec, edir, ett, esnow, etp, ssoil, & flx1, flx2, flx3, sncovr, runoff1, runoff2, soilm, qsurf, ribb, & smcwlt, smcref, smcmax, opt_thcnd, snotime, errmsg, errflg) - + use machine , only : kind_phys use module_sf_noahlsm, only: sflx, lutype, sltype use module_sf_noahlsm_glacial_only, only: sflx_glacial implicit none - + integer, intent(in) :: im, isice, isurban, nsoil, opt_thcnd, fasdas logical, intent(in) :: rdlai, ua_phys, usemonalb !GJF: usemonalb = True if the surface diffused shortwave albedo is EITHER read from input OR ! provided by a previous scheme (like radiation: as is done in GFS_rrtmgp_sw_pre) real(kind=kind_phys), intent(in) :: aoasis - + real(kind=kind_phys), intent(in) :: dt, cp, rd, sigma, cph2o, cpice, lsubf integer, dimension(im), intent(in) :: vegtyp, soiltyp, slopetyp @@ -129,7 +129,7 @@ subroutine sfc_noah_wrfv4_run (im, isice, flag_lsm, flag_lsm_glacier, srflag, is cmc, t1, snowhk, sneqv, chk, flx1, & flx2, flx3, ribb, snotime real(kind=kind_phys), dimension(im,nsoil), intent(inout) :: stc, smc, swc - + !variables that are intent(out) in module_sf_noahlsm, but are inout here due to being set within an IF statement real(kind=kind_phys), dimension(im), intent(inout) :: embrd, sheat, eta, ec, & edir, ett, esnow, etp, ssoil, sncovr, & @@ -138,28 +138,28 @@ subroutine sfc_noah_wrfv4_run (im, isice, flag_lsm, flag_lsm_glacier, srflag, is character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg - + !GJF: There is some confusion regarding specific humidities vs mixing ratios in NOAH LSM. ! Looking at module_sf_noahlsm.F, sometimes the comments say mixing ratio and sometimes - ! specific humidity. The WRF code (module_sf_noahdrv.F) specifically converts from mixing + ! specific humidity. The WRF code (module_sf_noahdrv.F) specifically converts from mixing ! ratio to specific humidity in preparation for calling SFLX, so I am assuming that - ! all inputs/outputs into SFLX should be specific humidities, despite some comments in + ! all inputs/outputs into SFLX should be specific humidities, despite some comments in ! module_sf_noahdrv.F describing arguments saying "mixing ratios". This applies to many ! arguments into SFLX (q1k, qs1, dqsdt2, eta, qsurf, etc.). - + ! local Variables integer :: i, k logical, parameter :: local = .false. !(not actually used in SFLX) described in module_sf_noahlsm as: ! Flag for local-site simulation (where there is no maps for albedo, veg fraction, and roughness ! true: all LSM parameters (inluding albedo, veg fraction and roughness length) will be defined by three tables - real(kind=kind_phys) :: dummy - + real(kind=kind_phys) :: dummy + !GJF: The following variables are part of the interface to SFLX but not required as diagnostic - ! output or otherwise outside of this subroutine (at least as part of a GFS-based suite). - ! If any of these variables are needed by other schemes or diagnostics, one needs to add it to + ! output or otherwise outside of this subroutine (at least as part of a GFS-based suite). + ! If any of these variables are needed by other schemes or diagnostics, one needs to add it to ! the host model and CCPP metadata. Alternatively, none of these variables NEED to be allocated - ! and one could also just pass in dummy arguments. + ! and one could also just pass in dummy arguments. ! ! The variables descriptions are from module_sf_noahlsm.F: ! @@ -187,7 +187,7 @@ subroutine sfc_noah_wrfv4_run (im, isice, flag_lsm, flag_lsm_glacier, srflag, is ! smcdry (output from SFLX): dry soil moisture threshold where direct evap frm top layer ends (volumetric) ! smcmax (output from SFLX): porosity, i.e. saturated value of soil moisture (volumetric) ! nroot (output from SFLX): number of root layers, a function of veg type, determined in subroutine redprm. - + integer :: nroot real(kind=kind_phys) :: albedok, eta_kinematic, fdown, drip, dew, beta, snomlt, & runoff3, rc, pc, rsmin, xlai, rcs, rct, rcq, & @@ -195,15 +195,15 @@ subroutine sfc_noah_wrfv4_run (im, isice, flag_lsm, flag_lsm_glacier, srflag, is real (kind=kind_phys), dimension(nsoil) :: et, smav real(kind=kind_phys) :: sfcheadrt, infxsrt, etpnd1 !don't appear to be used unless WRF_HYDRO preprocessor directive is defined and no documentation real(kind=kind_phys) :: xsda_qfx, hfx_phy, qfx_phy, xqnorm, hcpct_fasdas !only used if fasdas = 1 - + !variables associated with UA_PHYS (not used for now) real(kind=kind_phys) :: flx4, fvb, fbur, fgsn errmsg = '' errflg = 0 - + do i=1, im - if (flag_lsm(i)) then + if (flag_lsm(i)) then !GJF: Why do LSMs want the dynamics time step instead of the physics time step? call sflx (i, 1, srflag(i), & isurban, dt, zlvl(i), nsoil, sthick, & !c @@ -222,7 +222,7 @@ subroutine sfc_noah_wrfv4_run (im, isice, flag_lsm, flag_lsm_glacier, srflag, is eta(i), sheat(i), eta_kinematic, fdown, & !O ec(i), edir(i), et, ett(i), esnow(i), drip, dew, & !O beta, etp(i), ssoil(i), flx1(i), flx2(i), flx3(i),& !O - flx4, fvb, fbur, fgsn, ua_phys, & !UA + flx4, fvb, fbur, fgsn, ua_phys, & !UA snomlt, sncovr(i), runoff1(i), runoff2(i),runoff3,& !O rc, pc, rsmin, xlai, rcs, rct, rcq, rcsoil, & !O soilw, soilm(i), qsurf(i), smav, & !D @@ -239,7 +239,7 @@ subroutine sfc_noah_wrfv4_run (im, isice, flag_lsm, flag_lsm_glacier, srflag, is runoff2(i) = 0.0 swc(i,:) = 1.0 smc(i,:) = 1.0 - + call sflx_glacial (i, 1, isice, srflag(i), dt, zlvl(i), & nsoil, sthick, lwdn(i), solnet(i), sfcprs(i), & prcp(i), sfctmp(i), q1k(i), th1(i), qs1(i), & @@ -254,7 +254,7 @@ subroutine sfc_noah_wrfv4_run (im, isice, flag_lsm, flag_lsm_glacier, srflag, is if (errflg > 0) return end if end do - + end subroutine sfc_noah_wrfv4_run !> @} diff --git a/physics/sfc_noah_wrfv4.meta b/physics/sfc_noah_wrfv4.meta index 781a21d3b..05cd94ab1 100644 --- a/physics/sfc_noah_wrfv4.meta +++ b/physics/sfc_noah_wrfv4.meta @@ -133,7 +133,7 @@ type = real kind = kind_phys intent = in - optional = F + optional = F [isurban] standard_name = urban_vegetation_category long_name = index of the urban vegetation category in the chosen vegetation dataset @@ -200,7 +200,7 @@ type = real kind = kind_phys intent = in - optional = F + optional = F [nsoil] standard_name = soil_vertical_dimension long_name = soil vertical layer dimension @@ -208,7 +208,7 @@ dimensions = () type = integer intent = in - optional = F + optional = F [sthick] standard_name = soil_layer_thickness long_name = soil layer thickness @@ -217,7 +217,7 @@ type = real kind = kind_phys intent = in - optional = F + optional = F [lwdn] standard_name = surface_downwelling_longwave_flux_absorbed_by_ground_over_land long_name = total sky surface downward longwave flux absorbed by the ground over land @@ -226,7 +226,7 @@ type = real kind = kind_phys intent = in - optional = F + optional = F [soldn] standard_name = surface_downwelling_shortwave_flux long_name = total sky surface downward shortwave flux diff --git a/physics/sfc_noah_wrfv4_interstitial.F90 b/physics/sfc_noah_wrfv4_interstitial.F90 index b30f8a131..d2d496934 100644 --- a/physics/sfc_noah_wrfv4_interstitial.F90 +++ b/physics/sfc_noah_wrfv4_interstitial.F90 @@ -7,11 +7,11 @@ module sfc_noah_wrfv4_pre implicit none public :: sfc_noah_wrfv4_pre_init, sfc_noah_wrfv4_pre_run, sfc_noah_wrfv4_pre_finalize - + private logical :: is_initialized = .false. - + contains !> \ingroup NOAH_LSM_WRFv4 @@ -22,33 +22,33 @@ subroutine sfc_noah_wrfv4_pre_init(lsm, lsm_noah_wrfv4, veg_data_choice, & soil_data_choice, isurban, isice, iswater, errmsg, errflg) use machine, only : kind_phys - + implicit none - + integer, intent(in) :: lsm, lsm_noah_wrfv4, & veg_data_choice, soil_data_choice - + integer, intent(inout) :: isurban, isice, iswater - + character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg - + ! Local variables - + character(len=256) :: mminlu, mminsl - + ! Initialize CCPP error handling variables errmsg = '' errflg = 0 if (is_initialized) return - + if (lsm/=lsm_noah_wrfv4) then write(errmsg,'(*(a))') "Logic error: namelist choice of LSM is different from NOAH WRFv4" errflg = 1 return end if - + select case (veg_data_choice) case (0) mminlu = 'USGS' @@ -80,7 +80,7 @@ subroutine sfc_noah_wrfv4_pre_init(lsm, lsm_noah_wrfv4, veg_data_choice, & errflg = 1 return end select - + select case (soil_data_choice) case (1) mminsl = 'STAS' @@ -91,11 +91,11 @@ subroutine sfc_noah_wrfv4_pre_init(lsm, lsm_noah_wrfv4, veg_data_choice, & errflg = 1 return end select - + call soil_veg_gen_parm(trim(mminlu), trim(mminsl), errmsg, errflg) - + is_initialized = .true. - + end subroutine sfc_noah_wrfv4_pre_init @@ -140,10 +140,10 @@ subroutine sfc_noah_wrfv4_pre_run (im, nsoil, ialb, isice, land, & !GJF: Data preparation and output preparation from SFLX follows the GFS physics code (sfc_drv.F) ! rather than the WRF code (module_sf_noahdrv.F) in order to "fit in" with other GFS physics-based ! suites. Another version of this scheme (and the associated post) could potentially be - ! created from the WRF version. No attempt was made to test sensitivities to either approach. + ! created from the WRF version. No attempt was made to test sensitivities to either approach. ! Note that the version of NOAH LSM expected here is "generic" - there are no urban, fasdas, or ! or University of Arizona(?) additions. - + integer, intent(in) :: im, nsoil, ialb, isice logical, intent(in) :: restart, first_time_step real(kind=kind_phys), intent(in) :: dt, rhowater, rd, rvrdm1, eps, epsm1 @@ -166,30 +166,30 @@ subroutine sfc_noah_wrfv4_pre_run (im, nsoil, ialb, isice, land, & ! local Variables integer :: i, k real(kind=kind_phys) :: sneqv - + REAL, PARAMETER :: A2=17.67,A3=273.15,A4=29.65, & A23M4=A2*(A3-A4) - real(kind=kind_phys), parameter, dimension(4) :: zsoil = (/ -0.1,-0.4,-1.0,-2.0/) !what if nsoil /= 4? - + real(kind=kind_phys), parameter, dimension(4) :: zsoil = (/ -0.1,-0.4,-1.0,-2.0/) !what if nsoil /= 4? + !> - Initialize CCPP error handling variables errmsg = '' errflg = 0 - + !from module_sf_noahdrv.F/lsminit if (.not. restart .and. first_time_step .and. ialb == 0) then - do i = 1, im + do i = 1, im snoalb(i) = maxalb(int(0.5 + vtype(i)))*0.01 end do end if - + do i=1, im if (land(i) .and. flag_guess(i)) then weasd_save(i) = weasd(i) snwdph_save(i) = snwdph(i) tsfc_save(i) = tsfc(i) canopy_save(i) = canopy(i) - + do k=1,nsoil smc_save(i,k) = smc(i,k) stc_save(i,k) = stc(i,k) @@ -197,12 +197,12 @@ subroutine sfc_noah_wrfv4_pre_run (im, nsoil, ialb, isice, land, & end do end if end do - + sthick(1) = - zsoil(1) do k = 2, nsoil sthick(k) = zsoil(k-1) - zsoil(k) enddo - + flag_lsm(:) = .false. flag_lsm_glacier(:) = .false. do i=1, im @@ -214,7 +214,7 @@ subroutine sfc_noah_wrfv4_pre_run (im, nsoil, ialb, isice, land, & end if !GJF: module_sf_noahdrv.F from WRF has hardcoded slopetyp = 1; why? replicate here? !GJF: shdfac is zeroed out for particular combinations of vegetation table source and vegetation types; replicate here? - + ep(i) = 0.0 evap (i) = 0.0 hflx (i) = 0.0 @@ -227,28 +227,28 @@ subroutine sfc_noah_wrfv4_pre_run (im, nsoil, ialb, isice, land, & sbsno(i) = 0.0 snowc(i) = 0.0 snohf(i) = 0.0 - + !GJF: could potentially pass in pre-calculated rates instead of calculating here prcp(i) = rhowater * tprcp(i) / dt - + !GJF: The GFS version of NOAH prepares the specific humidity in sfc_drv.f as follows: q2k(i) = max(q1(i), 1.e-8) rho1(i) = sfcprs(i) / (rd*sfctmp(i)*(1.0+rvrdm1*q2k(i))) - + qs1(i) = fpvs( sfctmp(i) ) qs1(i) = max(eps*qs1(i) / (sfcprs(i)+epsm1*qs1(i)), 1.e-8) q2k(i) = min(qs1(i), q2k(i)) - + !GJF: could potentially pass in pre-calcualted potential temperature if other schemes also need it (to avoid redundant calculation) th1(i) = sfctmp(i) * prslki(i) - + !GJF: module_sf_noahdrv.F from WRF modifies dqsdt2 if the surface has snow. dqsdt2(i)=qs1(i)*a23m4/(sfctmp(i)-a4)**2 - + !GJF: convert canopy moisture from kg m-2 to m canopy(i) = max(canopy(i), 0.0) !check for positive values in sfc_drv.f cmc(i) = canopy(i)/rhowater - + !GJF: snow depth passed in to NOAH is conditionally modified differently in GFS and WRF: sneqv = weasd(i) * 0.001 snowhk(i) = snwdph(i) * 0.001 @@ -259,18 +259,18 @@ subroutine sfc_noah_wrfv4_pre_run (im, nsoil, ialb, isice, land, & ! if (sneqv(i) /= 0.0 .and. snwdph(i) == 0.0) then ! snowhk(i) = 10.0 * sneqv(i) ! endif - + !GJF: calculate conductance from surface exchange coefficient chk(i) = ch(i) * wind(i) - + chh(i) = chk(i) * rho1(i) cmm(i) = cm(i) * wind(i) - + !GJF: If the perturbations of vegetation fraction is desired, one could uncomment this code ! and add appropriate arguments to make this work. This is from the GFS version of NOAH LSM ! in sfc_drv.f. - + !> - Call surface_perturbation::ppfbet() to perturb vegetation fraction that goes into gsflx(). ! perturb vegetation fraction that goes into sflx, use the same ! perturbation strategy as for albedo (percentile matching) @@ -295,10 +295,10 @@ subroutine sfc_noah_wrfv4_pre_run (im, nsoil, ialb, isice, land, & ! *** sfc-perts, mgehne endif end do - - + + end subroutine sfc_noah_wrfv4_pre_run - + subroutine soil_veg_gen_parm( mminlu, mminsl, errmsg, errflg) !this routine is mostly taken from module_sf_noahdrv.F in WRF use module_sf_noahlsm, only: shdtbl, nrotbl, rstbl, rgltbl, hstbl, snuptbl, & ! begin land use / vegetation variables @@ -319,7 +319,7 @@ subroutine soil_veg_gen_parm( mminlu, mminsl, errmsg, errflg) character(len=*), intent(in) :: mminlu, mminsl character(len=*), intent(inout) :: errmsg integer, intent(inout) :: errflg - + integer :: lumatch, iindex, lc, num_slope, iunit_noah integer :: ierr integer , parameter :: open_ok = 0 @@ -329,7 +329,7 @@ subroutine soil_veg_gen_parm( mminlu, mminsl, errmsg, errflg) character*256 :: a_string integer , parameter :: loop_max = 10 integer :: loop_count, i - + !-----SPECIFY VEGETATION RELATED CHARACTERISTICS : ! ALBBCK: SFC albedo (in percentage) ! Z0: Roughness length (m) @@ -368,14 +368,14 @@ subroutine soil_veg_gen_parm( mminlu, mminsl, errmsg, errflg) 'can not find unused fortran unit to read.' return endif - + open(iunit_noah, file='VEGPARM.TBL',form='formatted',status='old',iostat=ierr) if(ierr .ne. open_ok ) then errflg = 1 errmsg = 'sfc_noah_wrfv4_interstitial: set_soil_veg_parm: failure opening VEGPARM.TBL' return end if - + lumatch=0 loop_count = 0 @@ -402,7 +402,7 @@ subroutine soil_veg_gen_parm( mminlu, mminsl, errmsg, errflg) enddo find_vegetation_parameter_flag endif enddo find_lutype - + ! prevent possible array overwrite, Bill Bovermann, IBM, May 6, 2008 if ( size(shdtbl) < lucats .or. & size(nrotbl) < lucats .or. & @@ -436,7 +436,7 @@ subroutine soil_veg_gen_parm( mminlu, mminsl, errmsg, errflg) albedomaxtbl(lc), z0mintbl(lc), z0maxtbl(lc),& ztopvtbl(lc), zbotvtbl(lc) enddo - + read (iunit_noah,*) read (iunit_noah,*)topt_data read (iunit_noah,*) @@ -472,8 +472,8 @@ subroutine soil_veg_gen_parm( mminlu, mminsl, errmsg, errflg) errmsg = 'sfc_noah_wrfv4_interstitial: set_soil_veg_parm: land use dataset '//mminlu//' not found in VEGPARM.TBL.' return endif - - + + !CALL wrf_dm_bcast_string ( LUTYPE , 4 ) !CALL wrf_dm_bcast_integer ( LUCATS , 1 ) !CALL wrf_dm_bcast_integer ( IINDEX , 1 ) @@ -504,11 +504,11 @@ subroutine soil_veg_gen_parm( mminlu, mminsl, errmsg, errflg) !CALL wrf_dm_bcast_integer ( LOW_DENSITY_RESIDENTIAL , 1 ) !CALL wrf_dm_bcast_integer ( HIGH_DENSITY_RESIDENTIAL , 1 ) !CALL wrf_dm_bcast_integer ( HIGH_INTENSITY_INDUSTRIAL , 1 ) - + ! !-----READ IN SOIL PROPERTIES FROM SOILPARM.TBL ! - + open(iunit_noah, file='SOILPARM.TBL',form='formatted',status='old',iostat=ierr) if(ierr .ne. open_ok ) then errflg = 1 @@ -557,7 +557,7 @@ subroutine soil_veg_gen_parm( mminlu, mminsl, errmsg, errflg) 2003 continue close (iunit_noah) - + ! CALL wrf_dm_bcast_integer ( LUMATCH , 1 ) ! CALL wrf_dm_bcast_string ( SLTYPE , 4 ) @@ -584,7 +584,7 @@ subroutine soil_veg_gen_parm( mminlu, mminsl, errmsg, errflg) ! !-----READ IN GENERAL PARAMETERS FROM GENPARM.TBL ! - + open(iunit_noah, file='GENPARM.TBL',form='formatted',status='old',iostat=ierr) if(ierr .ne. open_ok ) then errflg = 1 @@ -633,7 +633,7 @@ subroutine soil_veg_gen_parm( mminlu, mminsl, errmsg, errflg) read (iunit_noah,*) read (iunit_noah,*)lvcoef_data close (iunit_noah) - + ! call wrf_dm_bcast_integer ( num_slope , 1 ) ! call wrf_dm_bcast_integer ( slpcats , 1 ) @@ -658,7 +658,7 @@ end subroutine soil_veg_gen_parm end module sfc_noah_wrfv4_pre module sfc_noah_wrfv4_post - + implicit none private @@ -666,13 +666,13 @@ module sfc_noah_wrfv4_post public :: sfc_noah_wrfv4_post_init, sfc_noah_wrfv4_post_run, sfc_noah_wrfv4_post_finalize contains - + subroutine sfc_noah_wrfv4_post_init () end subroutine sfc_noah_wrfv4_post_init - + subroutine sfc_noah_wrfv4_post_finalize () end subroutine sfc_noah_wrfv4_post_finalize - + !! \section arg_table_sfc_noah_wrfv4_post_run Argument Table !! \htmlinclude sfc_noah_wrfv4_post_run.html !! @@ -680,13 +680,13 @@ subroutine sfc_noah_wrfv4_post_run (im, nsoil, land, flag_guess, flag_lsm, & rhowater, cp, hvap, cmc, rho1, sheat, eta, flx1, flx2, flx3, sncovr, runoff1,& runoff2, soilm, snowhk, weasd_save, snwdph_save, tsfc_save, tsurf, & canopy_save, smc_save, stc_save, slc_save, smcmax, canopy, shflx, & - lhflx, snohf, snowc, runoff, drain, stm, weasd, snwdph, tsfc, smc, stc,& + lhflx, snohf, snowc, runoff, drain, stm, weasd, snwdph, tsfc, smc, stc,& slc, wet1, errmsg, errflg) - + use machine, only : kind_phys - + implicit none - + integer, intent(in) :: im, nsoil logical, dimension(im), intent(in) :: land, flag_guess, flag_lsm real(kind=kind_phys), intent(in) :: rhowater, cp, hvap @@ -694,59 +694,59 @@ subroutine sfc_noah_wrfv4_post_run (im, nsoil, land, flag_guess, flag_lsm, & flx1, flx2, flx3, sncovr, runoff1, runoff2, soilm, snowhk real(kind=kind_phys), dimension(im), intent(in) :: weasd_save, snwdph_save, tsfc_save, tsurf, canopy_save, smcmax real(kind=kind_phys), dimension(im,nsoil), intent(in) :: smc_save, stc_save, slc_save - + real(kind=kind_phys), dimension(im), intent(inout) :: canopy, shflx, lhflx, & snohf, snowc, runoff, drain, stm, wet1 real(kind=kind_phys), dimension(im), intent(inout) :: weasd, snwdph, tsfc real(kind=kind_phys), dimension(im, nsoil), intent(inout) :: smc, stc, slc - + character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg - + !local variables integer :: i, k - + ! Initialize CCPP error handling variables errmsg = '' errflg = 0 - + do i=1, im if (flag_lsm(i)) then canopy(i) = cmc(i)*rhowater snwdph(i) = 1000.0*snowhk(i) - + shflx(i) = sheat(i) / (cp*rho1(i)) lhflx(i) = eta(i) / (hvap*rho1(i)) - + !aggregating several outputs into one like GFS sfc_drv.F snohf(i) = flx1(i) + flx2(i) + flx3(i) - + snowc(i) = sncovr(i) !GJF: redundant? - + !convert from m s-1 to kg m-2 s-1 by multiplying by rhowater runoff(i) = runoff1(i) * rhowater drain(i) = runoff2(i) * rhowater - + stm(i) = soilm(i) * rhowater - + wet1(i) = smc(i,1) / smcmax(i) !Sarah Lu added 09/09/2010 (for GOCART) end if end do - + do i=1, im - if (land(i)) then + if (land(i)) then if (flag_guess(i)) then weasd(i) = weasd_save(i) snwdph(i) = snwdph_save(i) tsfc(i) = tsfc_save(i) canopy(i) = canopy_save(i) - + do k=1,nsoil smc(i,k) = smc_save(i,k) stc(i,k) = stc_save(i,k) slc(i,k) = slc_save(i,k) end do - + else tsfc(i) = tsurf(i) end if @@ -754,5 +754,5 @@ subroutine sfc_noah_wrfv4_post_run (im, nsoil, land, flag_guess, flag_lsm, & end do end subroutine sfc_noah_wrfv4_post_run - + end module sfc_noah_wrfv4_post diff --git a/physics/sfc_noah_wrfv4_interstitial.meta b/physics/sfc_noah_wrfv4_interstitial.meta index e993780fd..59f5723d8 100644 --- a/physics/sfc_noah_wrfv4_interstitial.meta +++ b/physics/sfc_noah_wrfv4_interstitial.meta @@ -683,7 +683,7 @@ type = integer intent = out optional = F - + ######################################################################## [ccpp-arg-table] name = sfc_noah_wrfv4_post_run