diff --git a/.gitignore b/.gitignore index a5309e6b90..4d3244a698 100644 --- a/.gitignore +++ b/.gitignore @@ -1 +1,2 @@ build*/ +.*.swp diff --git a/CMakeLists.txt b/CMakeLists.txt index bfeb9438b8..093f822128 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -185,7 +185,9 @@ project(GSI) find_package( LAPACK ) endif() # build the WRF I/O libraries - if(EXISTS ${CMAKE_CURRENT_SOURCE_DIR}/libsrc/wrflib) + if(DEFINED ENV{GSIWRF_LIB}) + set(wrflib "$ENV{GSIWRF_LIB}" CACHE INTERNAL "WRFIO library" ) + elseif(EXISTS ${CMAKE_CURRENT_SOURCE_DIR}/libsrc/wrflib) add_subdirectory(libsrc/wrflib) else() message("libsrc/wrflib not pulled from git, looking for WRF dependencies locally") @@ -230,12 +232,12 @@ project(GSI) find_package( IP ) if(BUILD_NCDIAG) - set(NCDIAG_INCS "${PROJECT_BINARY_DIR}/libsrc/ncdiag/include") + set(NCDIAG_INCS "${PROJECT_BINARY_DIR}/src/ncdiag/include") add_subdirectory(src/ncdiag) set(NCDIAG_LIBRARIES ncdiag ) endif(BUILD_NCDIAG) if(BUILD_FV3GFS_NCIO) - set(FV3GFS_NCIO_INCS "${PROJECT_BINARY_DIR}/libsrc/fv3gfs_ncio/include") + set(FV3GFS_NCIO_INCS "${PROJECT_BINARY_DIR}/src/fv3gfs_ncio/include") add_subdirectory(src/fv3gfs_ncio) set(FV3GFS_NCIO_LIBRARIES fv3gfs_ncio ) endif(BUILD_FV3GFS_NCIO) @@ -255,9 +257,9 @@ project(GSI) find_package( IP ) if(BUILD_GSDCLOUD_ARW) - set(GSDCLOUD_DIR "${CMAKE_SOURCE_DIR}/libsrc/GSD/gsdcloud") + set(GSDCLOUD_DIR "${CMAKE_SOURCE_DIR}/src/GSD/gsdcloud") set(gsdcloud gsdcloud_arw) - add_subdirectory(libsrc/GSD/gsdcloud) + add_subdirectory(src/GSD/gsdcloud) set(GSDCLOUD_LIBRARY ${gsdcloud} ) else(BUILD_GSDCLOUD_ARW) set(GSDCLOUD_LIBRARY "") diff --git a/cmake/Modules/platforms/Generic.cmake b/cmake/Modules/platforms/Generic.cmake index 1e06239a4e..b584cf66cf 100644 --- a/cmake/Modules/platforms/Generic.cmake +++ b/cmake/Modules/platforms/Generic.cmake @@ -11,4 +11,14 @@ macro (setGeneric) set(GSI_Intel_Platform_FLAGS "-DPOUND_FOR_STRINGIFY -O3 -fp-model source -assume byterecl -convert big_endian -g -traceback -D_REAL8_ ${OpenMP_Fortran_FLAGS} ${MPI_Fortran_COMPILE_FLAGS}" CACHE INTERNAL "GSI Fortran Flags") set(ENKF_Platform_FLAGS "-O3 ${HOST_FLAG} -warn all -implicitnone -traceback -fp-model strict -convert big_endian -DGFS -D_REAL8_ ${OpenMP_Fortran_FLAGS}" CACHE INTERNAL "ENKF Fortran Flags") + message("setting values for corelibs") + set(BUILD_BUFR "OFF" CACHE INTERNAL "Build the BUFR library" ) + set(BUILD_BACIO "OFF" CACHE INTERNAL "Build the BACIO library" ) + set(BUILD_SFCIO "OFF" CACHE INTERNAL "Build the SFCIO library" ) + set(BUILD_SIGIO "OFF" CACHE INTERNAL "Build the SIGIO library" ) + set(BUILD_NEMSIO "OFF" CACHE INTERNAL "Build the NEMSIO library" ) + set(BUILD_SP "OFF" CACHE INTERNAL "Build the SP library" ) + set(BUILD_CRTM "OFF" CACHE INTERNAL "Build the CRTM library" ) + set(BUILD_W3EMC "OFF" CACHE INTERNAL "Build the EMC library" ) + set(BUILD_NCO "OFF" CACHE INTERNAL "Build the NCO library" ) endmacro() diff --git a/cmake/Modules/setGNUFlags.cmake b/cmake/Modules/setGNUFlags.cmake index 1e1e075fa1..e4ef2d9ade 100644 --- a/cmake/Modules/setGNUFlags.cmake +++ b/cmake/Modules/setGNUFlags.cmake @@ -27,6 +27,7 @@ function (setGNU) set(W3NCO_C_FLAGS " -DLINUX -O3 -fconvert=big-endian -ffast-math -fno-second-underscore -frecord-marker=4 -funroll-loops -ggdb -static -Wall -fno-range-check -D_REAL8_ -fopenmp" CACHE INTERNAL "") set(WRFLIB_Fortran_FLAGS " -O3 -fconvert=big-endian -ffast-math -fno-second-underscore -frecord-marker=4 -funroll-loops -ggdb -static -Wall -fno-range-check -D_REAL8_ -fopenmp -ffree-line-length-0" CACHE INTERNAL "") set( NCDIAG_Fortran_FLAGS "-ffree-line-length-none" CACHE INTERNAL "" ) + set( FV3GFS_NCIO_Fortran_FLAGS "-ffree-line-length-none" CACHE INTERNAL "" ) set( NDATE_Fortran_FLAGS "-fconvert=big-endian -DCOMMCODE -DLINUX -DUPPLITTLEENDIAN -O3 -Wl,-noinhibit-exec" CACHE INTERNAL "") set( COV_CALC_FLAGS "-c -O3 -fconvert=little-endian -ffast-math -ffree-form -fno-second-underscore -frecord-marker=4 -funroll-loops -ggdb -static -Wall -fopenmp" CACHE INTERNAL "") set(GSDCLOUD_Fortran_FLAGS "-O3 -fconvert=big-endian" CACHE INTERNAL "") @@ -56,6 +57,7 @@ function (setGNU) set(W3NCO_C_FLAGS " -DLINUX -g -fbacktrace -fconvert=big-endian -ffast-math -fno-second-underscore -frecord-marker=4 -funroll-loops -g -ggdb -static -Wall -fno-range-check -D_REAL8_ -fopenmp" CACHE INTERNAL "") set(WRFLIB_Fortran_FLAGS " -g -fbacktrace -fconvert=big-endian -ffast-math -fno-second-underscore -frecord-marker=4 -funroll-loops -g -ggdb -static -Wall -fno-range-check -D_REAL8_ -fopenmp -ffree-line-length-0" CACHE INTERNAL "") set( NCDIAG_Fortran_FLAGS "-ffree-line-length-none" CACHE INTERNAL "" ) + set( FV3GFS_NCIO_Fortran_FLAGS "-ffree-line-length-none" CACHE INTERNAL "" ) set( NDATE_Fortran_FLAGS "-fconvert=big-endian -DCOMMCODE -DLINUX -DUPPLITTLEENDIAN -g -fbacktrace -Wl,-noinhibit-exec" CACHE INTERNAL "") set( COV_CALC_FLAGS "-c -O3 -fconvert=little-endian -ffast-math -ffree-form -fno-second-underscore -frecord-marker=4 -funroll-loops -ggdb -static -Wall -fopenmp" CACHE INTERNAL "") set(GSDCLOUD_Fortran_FLAGS "-O3 -fconvert=big-endian" CACHE INTERNAL "") diff --git a/src/GSD/gsdcloud/ARPS_cldLib.f90 b/src/GSD/gsdcloud/ARPS_cldLib.f90 new file mode 100644 index 0000000000..2fe9c006e5 --- /dev/null +++ b/src/GSD/gsdcloud/ARPS_cldLib.f90 @@ -0,0 +1,1405 @@ +! +!$$$ subprogram documentation block +! . . . . +! subprogram: ARPS_cldLib +! +! PRGMMR: Ming Hu ORG: GSD/AMB DATE: +! +! ABSTRACT: +! This file include a collection of subroutines that are related to +! cloud analysis from ARPS cloud analysis +! +! PROGRAM HISTORY LOG: +! 2009-01-02 Hu Add NCO document block +! +! +! input argument list: +! +! output argument list: +! +! USAGE: +! INPUT FILES: +! +! OUTPUT FILES: +! +! REMARKS: +! +! ATTRIBUTES: +! LANGUAGE: FORTRAN 90 +! MACHINE: Linux cluster (WJET) +! +!$$$ +! +!_____________________________________________________________________ +! +! +! +!################################################################## +!################################################################## +!###### ###### +!###### SUBROUTINE GET_STABILITY ###### +!###### ###### +!###### Developed by ###### +!###### Center for Analysis and Prediction of Storms ###### +!###### University of Oklahoma ###### +!###### ###### +!################################################################## +!################################################################## +! + +SUBROUTINE get_stability (nz,t_1d,zs_1d,p_mb_1d,kbtm,ktop & + ,dte_dz_1d) +! +! +!----------------------------------------------------------------------- +! +! PURPOSE: +! This routine returns stability at a given level given +! 1D temperature and pressure array inputs +! +!----------------------------------------------------------------------- +! +! AUTHOR: Jian Zhang +! 05/96 Based on LAPS cloud analysis code of 07/95 +! +! MODIFICATION HISTORY: +! +! 05/11/96 (J. Zhang) +! Modified for ADAS format. Added full documentation. +! +!----------------------------------------------------------------------- +! +!----------------------------------------------------------------------- +! +! Variable Declarations. +! +!----------------------------------------------------------------------- +! + use gsd_kinds, only: r_single,i_kind,r_kind + IMPLICIT NONE +! +!----------------------------------------------------------------------- +! +! INPUT: + integer(i_kind),INTENT(IN) :: nz ! number of vertical model levels + REAL(r_single) ,INTENT(IN) :: t_1d(nz) ! temperature (degree Kelvin) profile + REAL(r_single) ,INTENT(IN) :: zs_1d(nz) ! heights (m MSL) of each level + REAL(r_single) ,INTENT(IN) :: p_mb_1d(nz)! pressure (mb) at each level + INTEGER(i_kind),INTENT(IN) :: kbtm,ktop ! indices of the bottom and top cloud layer +! +! OUTPUT: + REAL(r_single) ,INTENT(out):: dte_dz_1d(nz) ! stability array +! +! LOCAL: + REAL(r_single) :: thetae_1d(nz) ! (equivalent) potential temperature. +! +!----------------------------------------------------------------------- +! +! Misc local variables +! +!----------------------------------------------------------------------- +! + INTEGER(i_kind) :: k,km1,kp1,klow,khigh + REAL(r_single) :: os_fast +! +!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ +! +! Beginning of executable code... +! +!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ +! +! +!----------------------------------------------------------------------- +! +! Calculate Stability +! +!----------------------------------------------------------------------- +! + klow = MAX(kbtm-1,1) + khigh = MIN(ktop+1,nz-1) + + DO k = klow,khigh + thetae_1d(k) = os_fast(t_1d(k), p_mb_1d(k)) + END DO ! k + + dte_dz_1d=0._r_kind + + DO k = kbtm,ktop + km1 = MAX(k-1,1) + kp1 = MIN(k+1,nz-1) + + IF( (zs_1d(kp1) - zs_1d(km1)) <= 0._r_kind) THEN + write(6,*) 'GNRLCLD_mpi, get_stability: Error in get_stability ' + write(6,*) 'GNRLCLD_mpi, get_stability: k,kp1,km1 = ',k,kp1,km1 + write(6,*) 'GNRLCLD_mpi, get_stability: zs_1d(kp1),zs_1d(km1)= ',zs_1d(kp1),zs_1d(km1), & + (zs_1d(kp1) - zs_1d(km1)) + call STOP2(114) + ELSE + dte_dz_1d(k) = (thetae_1d(kp1) - thetae_1d(km1)) & + / (zs_1d(kp1) - zs_1d(km1)) + END IF + END DO ! k + + RETURN +END SUBROUTINE get_stability + + +! +!################################################################## +!################################################################## +!###### ###### +!###### FUNCTION OS_FAST ###### +!###### ###### +!################################################################## +!################################################################## +! + + FUNCTION os_fast(tk,p) +! +!----------------------------------------------------------------------- +! +! PURPOSE: +! +! THIS FUNCTION RETURNS THE EQUIVALENT POTENTIAL TEMPERATURE OS +! (K) FOR A PARCEL OF AIR SATURATED AT TEMPERATURE T (K) +! AND PRESSURE P (MILLIBARS). +! +! +!----------------------------------------------------------------------- +! +! AUTHOR: (BAKER,SCHLATTER) +! 05/17/1982 +! +! +! MODIFICATION HISTORY: +! 05/11/96 (Jian Zhang) +! Modified for ADAS grid. Add document stuff. +! +!----------------------------------------------------------------------- +! +! Variables declaration +! +!----------------------------------------------------------------------- +! + use gsd_kinds, only: r_single,i_kind,r_kind + IMPLICIT NONE +! +!----------------------------------------------------------------------- +! +! INPUT: + REAL(r_single) ,INTENT(IN) :: tk ! temperature in kelvin + REAL(r_single) ,INTENT(IN) :: p ! pressure in mb +! +! OUTPUT: + REAL(r_single) :: os_fast ! equivalent potential temperature +! +! LOCAL: + REAL(r_kind) :: b ! empirical const. approx.= latent heat of + ! vaporiz'n for water devided by the specific + ! heat at const. pressure for dry air. + DATA b/2.6518986_r_kind/ + + REAL(r_kind) :: tc,x,w + REAL(r_kind) :: eslo +! +!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ +! +! Beginning of executable code... +! +!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ +! + tc = tk - 273.15_r_kind +! +!----------------------------------------------------------------------- +! +! From W routine +! +!----------------------------------------------------------------------- +! + x= eslo(tc) + w= 622._r_kind*x/(p-x) + + os_fast= tk*((1000._r_kind/p)**.286_r_kind)*(EXP(b*w/tk)) + + RETURN + END FUNCTION os_fast + + + +! +! +!################################################################## +!################################################################## +!###### ###### +!###### SUBROUTINE GET_CLOUDTYPE ###### +!###### ###### +!###### Developed by ###### +!###### Center for Analysis and Prediction of Storms ###### +!###### University of Oklahoma ###### +!###### ###### +!################################################################## +!################################################################## +! + +SUBROUTINE get_cloudtype(temp_k,dte_dz,cbase_m,ctop_m & + ,itype,c2_type) +! +!----------------------------------------------------------------------- +! +! PURPOSE: +! This routine returns cloud type at a given point given +! temperature and stability inputs +! +!----------------------------------------------------------------------- +! +! AUTHOR: Jian Zhang +! 05/96 Based on the LAPS cloud analysis code of 05/1995 +! +! MODIFICATION HISTORY: +! +! 05/11/96 (J. Zhang) +! Modified for ADAS format. Added full documentation. +! +!----------------------------------------------------------------------- +! +!----------------------------------------------------------------------- +! +! Variable Declarations. +! +!----------------------------------------------------------------------- +! + use gsd_kinds, only: r_single,i_kind,r_kind + IMPLICIT NONE +! +!----------------------------------------------------------------------- +! +! INPUT: + REAL(r_single),INTENT(IN) :: temp_k ! temperature + REAL(r_single),INTENT(IN) :: dte_dz ! stability factor + REAL(r_single),INTENT(IN) :: cbase_m ! height at cloud base level + REAL(r_single),INTENT(IN) :: ctop_m ! height at cloud top level +! +! OUTPUT: + INTEGER(i_kind),INTENT(out):: itype ! cloud type index + CHARACTER (LEN=2) :: c2_type +! +! LOCAL: + CHARACTER (LEN=2) :: c2_cldtyps(10) + + DATA c2_cldtyps /'St','Sc','Cu','Ns','Ac' & + ,'As','Cs','Ci','Cc','Cb'/ +! +!----------------------------------------------------------------------- +! +! Misc local variables +! +!----------------------------------------------------------------------- +! + REAL(r_kind) :: depth_m,temp_c +! +!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ +! +! Beginning of executable code... +! +!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ +! + temp_c = temp_k - 273.15_r_kind + depth_m = ctop_m - cbase_m +! +!----------------------------------------------------------------------- +! +! Go from Stability to Cloud Type +! +!----------------------------------------------------------------------- +! + IF ( temp_c >= -10._r_kind) THEN + IF (dte_dz >= +.001_r_kind) THEN + itype = 1 ! St + ELSE IF (dte_dz < +.001_r_kind .AND. dte_dz >= -.001_r_kind) THEN + itype = 2 ! Sc + ELSE IF (dte_dz < -.001_r_kind .AND. dte_dz >= -.005_r_kind) THEN + itype = 3 ! Cu + ELSE ! dte_dz .lt. -.005 + IF(depth_m > 5000) THEN + itype = 10 ! Cb + ELSE ! depth < 5km + itype = 3 ! Cu + END IF + END IF + + ELSE IF (temp_c < -10._r_kind .AND. temp_c >= -20._r_kind) THEN + + IF (dte_dz < 0._r_kind) THEN + IF(depth_m > 5000) THEN + itype = 10 ! Cb + ELSE + itype = 5 ! Ac + END IF + ELSE + itype = 6 ! As + END IF + + ELSE ! temp_c.lt.-20. + + IF (dte_dz >= +.0005_r_kind) THEN + itype = 7 ! Cs + ELSE IF (dte_dz < +.0005_r_kind .AND. dte_dz >= -.0005_r_kind) THEN + itype = 8 ! Ci + ELSE ! dte_dz .lt. -.0005 + itype = 9 ! Cc + END IF + + IF(depth_m > 5000 .AND. dte_dz < -.0000_r_kind) THEN + itype = 10 ! Cb + END IF + + END IF + + c2_type = c2_cldtyps(itype) + + RETURN +END SUBROUTINE get_cloudtype + +! +!################################################################## +!################################################################## +!###### ###### +!###### SUBROUTINE GET_SFM_1D ###### +!###### ###### +!###### Developed by ###### +!###### Center for Analysis and Prediction of Storms ###### +!###### University of Oklahoma ###### +!###### ###### +!################################################################## +!################################################################## +! + +SUBROUTINE get_sfm_1d (nz,zcb,zctop,zs_1d,p_mb_1d,t_1d,ql,qi,cldt, & + l_prt) +! +!----------------------------------------------------------------------- +! +! PURPOSE: +!c----------------------------------------------------------------- +!c +!c This is the streamlined version of the Smith-Feddes +!c and Temperature Adjusted LWC calculation methodologies +!c produced at Purdue University under sponsorship +!c by the FAA Technical Center. +!c +!c Currently, this subroutine will only use the Smith- +!c Feddes and will only do so as if there are solely +!c stratiform clouds present, however, it is very easy +!c to switch so that only the Temperature Adjusted +!c method is used. +!c +!c Dilution by glaciation is also included, it is a +!c linear function of in cloud temperature going from +!c all liquid water at -10 C to all ice at -30 C +!c as such the amount of ice is also calculated +! +!----------------------------------------------------------------------- +! +! AUTHOR: Jian Zhang +! 05/96 Based on the LAPS cloud analysis code of 07/1995 +! +! MODIFICATION HISTORY: +! +! 05/16/96 (Jian Zhang) +! Modified for ADAS format. Added full documentation. +! +!----------------------------------------------------------------------- +! +!----------------------------------------------------------------------- +! +! Variable Declarations. +! +!----------------------------------------------------------------------- +! + use gsd_kinds, only: r_single,i_kind + IMPLICIT NONE +! +! +!----------------------------------------------------------------------- +! +! INPUT: + INTEGER(i_kind),intent(in) :: nz ! number of model vertical levels + REAL(r_single),intent(in) :: zs_1d(nz) ! physical height (m) at each scalar level + REAL(r_single),intent(in) :: p_mb_1d(nz)! pressure (mb) at each level + REAL(r_single),intent(in) :: t_1d(nz) ! temperature (K) at each level + + REAL(r_single),intent(in) :: zcb ! cloud base height (m) + REAL(r_single),intent(in) :: zctop ! cloud top height (m) +! +! OUTPUT: + REAL(r_single),intent(out) :: ql(nz) ! liquid water content (g/kg) + REAL(r_single),intent(out) :: qi(nz) ! ice water content (g/kg) + REAL(r_single),intent(out) :: cldt(nz) +! +! LOCAL: + REAL(r_single) :: calw(200) + REAL(r_single) :: cali(200) + REAL(r_single) :: catk(200) + REAL(r_single) :: entr(200) +! +!----------------------------------------------------------------------- +! +! Misc local variables +! +!----------------------------------------------------------------------- +! + REAL(r_single) :: dz,rv,rair,grav,cp,rlvo,rlso,dlvdt,eso + REAL(r_single) :: c,a1,b1,c1,a2,b2,c2 + REAL(r_single) :: delz,delt,cldbtm,cldbp,cldtpt,tbar + REAL(r_single) :: arg,fraclw,tlwc + REAL(r_single) :: temp,press,zbase,alw,zht,ht,y + REAL(r_single) :: rl,es,qvs1,p,des,dtz,es2,qvs2 + INTEGER(i_kind):: i,j,k,nlevel,nlm1,ip,kctop,kctop1,kcb,kcb1 + REAL(r_single) :: zcloud,entc,tmpk + LOGICAL :: l_prt +! +!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ +! +! Beginning of executable code... +! +!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ +! +! +!----------------------------------------------------------------------- +! +! Initialize 1d liquid water and ice arrays (for 100m layers) +! +!----------------------------------------------------------------------- +! + DO i=1,200 + calw(i)=0.0_r_single + cali(i)=0.0_r_single + END DO +! if(i_prt.le.20) then +! i_prt=i_prt+1 +! l_prt=.true. +! else +! l_prt=.false. +! endif +! +!----------------------------------------------------------------------- +! +! Preset some constants and coefficients. +! +!----------------------------------------------------------------------- +! + dz=100.0_r_single ! m + rv=461.5_r_single ! J/deg/kg + rair=287.04_r_single ! J/deg/kg + grav=9.81_r_single ! m/s2 + cp=1004._r_single ! J/deg/kg + rlvo=2.5003E+6_r_single ! J/kg + rlso=2.8339E+6_r_single ! J/kg + dlvdt=-2.3693E+3_r_single ! J/kg/K + eso=610.78_r_single ! pa + c=0.01_r_single + a1=8.4897_r_single + b1=-13.2191_r_single + c1=4.7295_r_single + a2=10.357_r_single + b2=-28.2416_r_single + c2=8.8846_r_single +! +!----------------------------------------------------------------------- +! +! Calculate indices of cloud top and base +! +!----------------------------------------------------------------------- +! + DO k=1,nz-1 + IF(zs_1d(k) < zcb .AND. zs_1d(k+1) > zcb) THEN + kcb=k + kcb1=kcb+1 + END IF + IF(zs_1d(k) < zctop .AND. zs_1d(k+1) > zctop) THEN + kctop=k + kctop1=kctop+1 + END IF + END DO +! +!----------------------------------------------------------------------- +! +! Obtain cloud base and top conditions +! +!----------------------------------------------------------------------- +! + delz = zs_1d(kcb+1)-zs_1d(kcb) + delt = t_1d(kcb+1)-t_1d(kcb) + cldbtm = delt*(zcb-zs_1d(kcb))/delz+t_1d(kcb) + tbar = (cldbtm+t_1d(kcb))/2._r_single + arg = -grav*(zcb-zs_1d(kcb))/rair/tbar + cldbp = p_mb_1d(kcb)*EXP(arg) + delz = zs_1d(kctop+1)-zs_1d(kctop) + delt = t_1d(kctop+1)-t_1d(kctop) + cldtpt = delt*(zctop-zs_1d(kctop))/delz+t_1d(kctop) +! +!----------------------------------------------------------------------- +! +! Calculate cloud lwc profile for cloud base/top pair +! +!----------------------------------------------------------------------- +! + temp = cldbtm + press = cldbp*100.0_r_single + zbase = zcb + nlevel = ((zctop-zcb)/100.0_r_single)+1 + IF(nlevel <= 0) nlevel=1 + alw = 0.0_r_single + calw(1)= 0.0_r_single + cali(1)= 0.0_r_single + catk(1)= temp + entr(1)= 1.0_r_single + nlm1 = nlevel-1 + IF(nlm1 < 1) nlm1=1 + zht = zbase + + DO j=1,nlm1 + rl = rlvo+(273.15_r_single-temp)*dlvdt + arg = rl*(temp-273.15_r_single)/273.15_r_single/temp/rv + es = eso*EXP(arg) + qvs1 = 0.622_r_single*es/(press-es) +! rho1 = press/(rair*temp) + arg = -grav*dz/rair/temp + p = press*EXP(arg) +! +!----------------------------------------------------------------------- +! +! Calculate saturated adiabatic lapse rate +! +!----------------------------------------------------------------------- +! + des = es*rl/temp/temp/rv + dtz = -grav*((1.0_r_single+0.621_r_single*es*rl/(press*rair*temp))/ & + (cp+0.621_r_single*rl*des/press)) + zht = zht+dz + press = p + temp = temp+dtz*dz + rl = rlvo+(273.15_r_single-temp)*dlvdt + arg = rl*(temp-273.15_r_single)/273.15_r_single/temp/rv + es2 = eso*EXP(arg) + qvs2 = 0.622_r_single*es2/(press-es2) + + alw = alw+(qvs1-qvs2) ! kg/kg + calw(j+1) = alw +! +!----------------------------------------------------------------------- +! +! Reduction of lwc by entrainment +! +!----------------------------------------------------------------------- +! + ht = (zht-zbase)*.001_r_single +! +!c ------------------------------------------------------------------ +!c +!c skatskii's curve(convective) +!c +!c ------------------------------------------------------------------ +!c if(ht.lt.0.3) then +!c y = -1.667*(ht-0.6) +!c elseif(ht.lt.1.0) then +!c arg1 = b1*b1-4.0*a1*(c1-ht) +!c y = (-b1-sqrt(arg1))/(2.0*a1) +!c elseif(ht.lt.2.9) then +!c arg2 = b2*b2-4.0*a2*(c2-ht) +!c y = (-b2-sqrt(arg2))/(2.0*a2) +!c else +!c y = 0.26 +!c endif +!c +!c ------------------------------------------------------------------ +!c +!c warner's curve(stratiform) +!c +!c ------------------------------------------------------------------ + IF(ht < 0.032_r_single) THEN + y = -11.0_r_single*ht+1.0_r_single ! y(ht=0.032) = 0.648 + ELSE IF(ht <= 0.177_r_single) THEN + y = -1.4_r_single*ht+0.6915_r_single ! y(ht=0.177) = 0.4437 + ELSE IF(ht <= 0.726_r_single) THEN + y = -0.356_r_single*ht+0.505_r_single ! y(ht=0.726) = 0.2445 + ELSE IF(ht <= 1.5_r_single) THEN + y = -0.0608_r_single*ht+0.2912_r_single ! y(ht=1.5) = 0.2 + ELSE + y = 0.20_r_single + END IF +! +!----------------------------------------------------------------------- +! +! Calculate reduced lwc by entrainment and dilution +! +! Note at -5 C and warmer, all liquid. ! changed from -10 KB +! at -25 C and colder, all ice ! changed from -30 KB +! Linear ramp between. +! +!----------------------------------------------------------------------- +! + IF(temp < 268.15_r_single) THEN + IF(temp > 248.15_r_single) THEN + fraclw=0.05*(temp-248.15_r_single) + ELSE + fraclw=0.0_r_single + END IF + ELSE + fraclw=1.0_r_single + END IF + + tlwc=1000._r_single*y*calw(j+1) ! g/kg + calw(j+1)=tlwc*fraclw + cali(j+1)=tlwc*(1._r_single-fraclw) + catk(j+1)=temp + entr(j+1)=y + + END DO +! +!----------------------------------------------------------------------- +! +! Obtain profile of LWCs at the given grid point +! +!----------------------------------------------------------------------- +! + DO ip=2,nz-1 + IF(zs_1d(ip) <= zcb .OR. zs_1d(ip) > zctop) THEN + ql(ip)=0.0_r_single + qi(ip)=0.0_r_single + cldt(ip)=t_1d(ip) + ELSE + DO j=2,nlevel + zcloud = zcb+(j-1)*dz + IF(zcloud >= zs_1d(ip)) THEN + ql(ip) = (zs_1d(ip)-zcloud+100._r_single)* & + (calw(j)-calw(j-1))*0.01_r_single+calw(j-1) + qi(ip) = (zs_1d(ip)-zcloud+100._r_single)* & + (cali(j)-cali(j-1))*0.01_r_single+cali(j-1) + tmpk = (zs_1d(ip)-zcloud+100._r_single)* & + (catk(j)-catk(j-1))*0.01_r_single & + +catk(j-1) + entc = (zs_1d(ip)-zcloud+100._r_single)* & + (entr(j)-entr(j-1))*0.01_r_single & + +entr(j-1) + cldt(ip) = (1.-entc)*t_1d(ip) + entc*tmpk + + EXIT + END IF + END DO + END IF + END DO +! + RETURN +END SUBROUTINE get_sfm_1d + + +! +! +!################################################################## +!################################################################## +!###### ###### +!###### SUBROUTINE PCP_TYPE_3D ###### +!###### ###### +!###### Developed by ###### +!###### Center for Analysis and Prediction of Storms ###### +!###### University of Oklahoma ###### +!###### ###### +!################################################################## +!################################################################## +! + +SUBROUTINE pcp_type_3d (nx,ny,nz,temp_3d,rh_3d,p_pa_3d & + ,radar_3d,l_mask,cldpcp_type_3d,istatus) + +! +!----------------------------------------------------------------------- +! +! PURPOSE: +! This routine returns 3D cloud and precipitation type field. +! +!----------------------------------------------------------------------- +! +! AUTHOR: Jian Zhang +! 05/1996 Based on the LAPS cloud analysis code developed by +! Steve Albers. +! +! This program modifies the most significant 4 bits of the integer +! array by inserting multiples of 16. +! +! MODIFICATION HISTORY: +! +! 05/16/96 (J. Zhang) +! Modified for ADAS format. Added full documentation. +! 01/20/98 (J. Zhang) +! Fixed a bug that no precip. type was assigned for a +! grid point at the top of the radar echo with Tw +! falling in the range of 0 to 1.3 degree C. +! 01/21/98 (J. Zhang) +! Fixed a bug that does the freezing/refreezing test +! on ice precipitates. +! 02/17/98 (J. Zhang) +! Change the hail diagnose procedure. +! +!----------------------------------------------------------------------- +! +!----------------------------------------------------------------------- +! +! Variable Declarations. +! +!----------------------------------------------------------------------- +! + use gsd_kinds, only: r_single,i_kind, r_kind + IMPLICIT NONE +! +!----------------------------------------------------------------------- +! +! INPUT: + INTEGER(i_kind), intent(in) :: nx,ny,nz ! Model grid size + REAL(r_single), intent(in) :: temp_3d(nx,ny,nz) ! temperature (K) + REAL(r_single), intent(in) :: rh_3d(nx,ny,nz) ! relative humudity + REAL(r_single), intent(in) :: p_pa_3d(nx,ny,nz) ! pressure (Pascal) + REAL(r_kind), intent(in) :: radar_3d(nx,ny,nz) ! radar refl. (dBZ) +! +! OUTPUT: + INTEGER(i_kind), intent(out) :: istatus + INTEGER(i_kind), intent(out) :: cldpcp_type_3d(nx,ny,nz)! cld/precip type + LOGICAL :: l_mask(nx,ny) ! "Potential" Precip Type +! +! LOCAL functions: + REAL(r_kind) :: wb_melting_thres ! define melting temp. thresh. + REAL(r_kind) :: tw ! for wet-bulb temp calcl'n +! +!----------------------------------------------------------------------- +! +! Misc local variables +! +!----------------------------------------------------------------------- +! + INTEGER(i_kind) :: itype ! cld/precip type index + INTEGER(i_kind) :: i,j,k,k_upper + REAL(r_kind) :: t_c,td_c,t_wb_c,temp_lower_c,temp_upper_c,tbar_c & + ,p_mb,thickns,frac_below_zero + INTEGER(i_kind) :: iprecip_type,iprecip_type_last,iflag_melt & + ,iflag_refreez + REAL(r_kind) :: zero_c,rlayer_refreez_max,rlayer_refreez + INTEGER(i_kind) :: n_zr,n_sl,n_last + REAL(r_kind) :: tmelt_c,x +! +!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ +! +! Beginning of executable code... +! +!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ +! +!----------------------------------------------------------------------- +! + return + istatus=0 + wb_melting_thres = 1.3 ! Units are C +! +!----------------------------------------------------------------------- +! +! Stuff precip type into cloud type array +! 0 - No Precip +! 1 - Rain +! 2 - Snow +! 3 - Freezing Rain +! 4 - Sleet +! 5 - Hail +! +!----------------------------------------------------------------------- +! + zero_c = 273.15_r_kind + rlayer_refreez_max = 0.0_r_kind + + n_zr = 0 + n_sl = 0 + n_last = 0 + + DO j = 1,ny-1 + DO i = 1,nx-1 + + iflag_melt = 0 + iflag_refreez = 0 + rlayer_refreez = 0.0_r_kind + + iprecip_type_last = 0 + + DO k = nz-1,1,-1 + + IF(radar_3d(i,j,k) >= 0._r_kind.OR. l_mask(i,j)) THEN +! +!----------------------------------------------------------------------- +! +! Set refreezing flag +! +!----------------------------------------------------------------------- +! + t_c = temp_3d(i,j,k) - zero_c +! compute dew point depression. +! td_c = dwpt(t_c,rh_3d(i,j,k)) + x = 1._r_kind-0.01_r_kind*rh_3d(i,j,k) + td_c =t_c-(14.55_r_kind+0.114_r_kind*t_c)*x+ & + ((2.5_r_kind+0.007_r_kind*t_c)*x)**3+ & + (15.9_r_kind+0.117_r_kind*t_c)*x**14 + + p_mb = 0.01_r_kind*p_pa_3d(i,j,k) + + tmelt_c = wb_melting_thres + t_wb_c = tw(t_c,td_c,p_mb) + + IF(t_wb_c < 0._r_kind) THEN + IF(iflag_melt == 1) THEN +! +!----------------------------------------------------------------------- +! +! Integrate below freezing temperature times column thickness +! - ONLY for portion of layer below freezing +! +!----------------------------------------------------------------------- +! + temp_lower_c = t_wb_c + k_upper = MIN(k+1,nz-1) +! +!----------------------------------------------------------------------- +! +! For simplicity and efficiency, the assumption is here made that +! the wet bulb depression is constant throughout the level. +! +!----------------------------------------------------------------------- +! + temp_upper_c = t_wb_c + ( temp_3d(i,j,k_upper) & + - temp_3d(i,j,k)) + IF(temp_upper_c <= 0._r_kind) THEN + frac_below_zero = 1.0_r_kind + tbar_c = 0.5_r_kind * (temp_lower_c + temp_upper_c) + + ELSE ! Layer straddles the freezing level + frac_below_zero = temp_lower_c & + / (temp_lower_c - temp_upper_c) + tbar_c = 0.5_r_kind * temp_lower_c + + END IF + + thickns = p_pa_3d(i,j,k_upper) - p_pa_3d(i,j,k) + rlayer_refreez = rlayer_refreez & + + ABS(tbar_c * thickns * frac_below_zero) + + IF(rlayer_refreez >= 25000._r_kind) THEN + iflag_refreez = 1 + END IF + + rlayer_refreez_max = & + MAX(rlayer_refreez_max,rlayer_refreez) + + END IF ! iflag_melt = 1 + + ELSE ! Temp > 0C + iflag_refreez = 0 + rlayer_refreez = 0.0 + + END IF ! T < 0.0c, Temp is below freezing +! +!----------------------------------------------------------------------- +! +! Set melting flag +! +!----------------------------------------------------------------------- +! + IF(t_wb_c >= tmelt_c) THEN + iflag_melt = 1 + END IF + + IF(t_wb_c >= tmelt_c) THEN ! Melted to Rain + iprecip_type = 1 + + ELSE ! Check if below zero_c (Refrozen Precip or Snow) + IF(t_wb_c < 0.0_r_kind) THEN + IF(iflag_melt == 1) THEN + IF(iprecip_type_last == 1 .OR.iprecip_type_last == 3) THEN + ! test if rain or zr freeze + IF(iflag_refreez == 0) THEN ! Freezing Rain + n_zr = n_zr + 1 + IF(n_zr < 30) THEN +! WRITE(6,5)i,j,k,t_wb_c,temp_3d(i,j,k) & +! ,rh_3d(i,j,k) + 5 FORMAT('zr',3I3,2F8.2,f8.1) + END IF + iprecip_type = 3 + + ELSE ! (iflag_refreez = 1) ! Sleet + n_sl = n_sl + 1 + iprecip_type = 4 + END IF ! iflag_refreez .eq. 0 + ELSE + iprecip_type = iprecip_type_last ! Unchanged + n_last = n_last + 1 + IF(n_last < 5) THEN +! WRITE(6,*)'Unchanged Precip',i,j,k,t_wb_c + END IF + END IF ! liquid precip. at upper level? + + ELSE ! iflag_melt =0 ! Snow + iprecip_type = 2 + + END IF ! iflag_melt = 1? + ELSE ! t_wb_c >= 0c, and t_wb_c < tmelt_c + + IF (iprecip_type_last == 0) THEN ! 1/20/98 + iprecip_type = 1 ! rain:at echo top and 0= tmelt_c + + ELSE ! radar_3d < 0dBZ; No Radar Echo + iprecip_type = 0 + iflag_melt = 0 + iflag_refreez = 0 + rlayer_refreez = 0.0_r_kind + + END IF ! radar_3d(i,j,k).ge.0. .or. l_mask(i,j); Radar Echo? +! +!----------------------------------------------------------------------- +! +! Insert most sig 4 bits into array +! +!----------------------------------------------------------------------- +! + itype = cldpcp_type_3d(i,j,k) + itype = itype - (itype/16)*16 ! Initialize the 4 bits + itype = itype + iprecip_type * 16 ! Add in the new value + cldpcp_type_3d(i,j,k) = itype + + iprecip_type_last = iprecip_type + + END DO ! k + END DO ! j + END DO ! i + + DO j = 1,ny-1 + DO i = 1,nx-1 + DO k = 1,nz-1 + IF(radar_3d(i,j,k) >= 50._r_kind) THEN + iprecip_type = 5 + itype = cldpcp_type_3d(i,j,k) + itype = itype - (itype/16)*16 ! Initialize the 4 bits + itype = itype + iprecip_type * 16 ! Add in the new value + cldpcp_type_3d(i,j,k) = itype + END IF + END DO ! k + END DO ! j + END DO ! i + + istatus=1 + + RETURN +END SUBROUTINE pcp_type_3d + +! +! +!################################################################## +!################################################################## +!###### ###### +!###### SUBROUTINE GET_SLWC1D ###### +!###### ###### +!###### Developed by ###### +!###### Center for Analysis and Prediction of Storms ###### +!###### University of Oklahoma ###### +!###### ###### +!################################################################## +!################################################################## +! + +SUBROUTINE get_slwc1d (nk,cbase_m,ctop_m,kbase,ktop & + ,zs_1d,t_1d,p_pa_1d,iflag_slwc,slwc_1d) + +! +!----------------------------------------------------------------------- +! +! PURPOSE: +! This routine calls a subroutine "lwc_rep" which calculates +! the adiabatic liquid water content. +! +!----------------------------------------------------------------------- +! +! AUTHOR: Jian Zhang +! 05/96 Based on the LAPS cloud analysis code of 07/1995 +! +! MODIFICATION HISTORY: +! +! 05/13/96 (Jian Zhang) +! Modified for ADAS format. Added full documentation. +! +!----------------------------------------------------------------------- +! +!----------------------------------------------------------------------- +! +! Variable Declarations. +! +!----------------------------------------------------------------------- +! + use gsd_kinds, only: r_single,i_kind,r_kind + IMPLICIT NONE +! +!----------------------------------------------------------------------- +! +! INPUT: + INTEGER(i_kind),intent(in) :: iflag_slwc ! indicator for LWC scheme option + INTEGER(i_kind),intent(in) :: nk ! number of model vertical levels + REAL(r_single),intent(in) :: t_1d(nk) ! temperature (k) in one model column + REAL(r_single),intent(in) :: zs_1d(nk) ! heights (m) at grd pts in one model column + REAL(r_single),intent(in) :: p_pa_1d(nk) ! pressure (pa) in one model column + REAL(r_single),intent(in) :: cbase_m,ctop_m ! heights (m) of cloud base and top levels + INTEGER(i_kind),intent(in) :: kbase,ktop ! vertical index of cloud base and top levels +! +! OUTPUT: + REAL(r_single),intent(out) :: slwc_1d(nk) ! estimated adiabatic liquid water +! +! LOCAL: + INTEGER(i_kind) :: i_status1,i_status2 ! flag for subroutine calling +! +!----------------------------------------------------------------------- +! +! Misc local variables +! +!----------------------------------------------------------------------- +! + INTEGER(i_kind):: k + REAL(r_single) :: p_low,p_high,cbase_pa,cbase_k,ctop_k,frac_k & + ,grid_top_pa,grid_top_k + REAL(r_single) :: fraction,thickness,dlog_space + REAL(r_single) :: adiabatic_lwc,adjusted_lwc,adjusted_slwc +! +!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ +! +! Beginning of executable code... +! +!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ +! +! +!----------------------------------------------------------------------- +! +! Initialize +! +!----------------------------------------------------------------------- +! + DO k = 1,nk + slwc_1d(k) = 0.0_r_single + END DO + + IF(ctop_m > cbase_m) THEN +! +!----------------------------------------------------------------------- +! +! Determine Lowest and Highest Grid Points within the cloud +! +!----------------------------------------------------------------------- +! + IF(ktop >= kbase .AND. kbase >= 2) THEN +! +!----------------------------------------------------------------------- +! +! Get cloud base pressure and temperature +! +!----------------------------------------------------------------------- +! + cbase_pa = -999._r_single ! Default value is off the grid + DO k = 1,nk-2 + IF(zs_1d(k+1) > cbase_m .AND. zs_1d(k) <= cbase_m) THEN + thickness = zs_1d(k+1) - zs_1d(k) + fraction = (cbase_m - zs_1d(k))/thickness + p_low = p_pa_1d(k) + p_high = p_pa_1d(k+1) + dlog_space = LOG(p_high/p_low) + cbase_pa = p_low * EXP(dlog_space*fraction) + END IF + END DO ! k + + frac_k=(cbase_m-zs_1d(kbase-1))/(zs_1d(kbase)-zs_1d(kbase-1)) + IF(frac_k /= fraction) & + PRINT*,' **GET_SLWC1D** frac=',fraction,' frac_k=',frac_k + + cbase_k = t_1d(kbase-1)*(1.0_r_single-frac_k) + t_1d(kbase)*frac_k +! +!----------------------------------------------------------------------- +! +! Get cloud top temperature +! +!----------------------------------------------------------------------- +! + frac_k = (ctop_m-zs_1d(ktop-1)) / (zs_1d(ktop)-zs_1d(ktop-1)) + ctop_k = t_1d(ktop-1)*(1.0_r_single - frac_k) + t_1d(ktop) * frac_k +! +!----------------------------------------------------------------------- +! +! Calculate SLWC at each vertical grid point. For each level +! we use an assumed cloud extending from the actual cloud base +! to the height of the grid point in question. +! +!----------------------------------------------------------------------- +! + DO k=kbase,ktop + grid_top_pa = p_pa_1d(k) + grid_top_k = t_1d(k) + + CALL slwc_revb(cbase_pa,cbase_k & + ,grid_top_pa,grid_top_k,ctop_k & + ,adiabatic_lwc,adjusted_lwc,adjusted_slwc & + ,i_status1,i_status2) +! + IF(i_status2 == 1) THEN + IF(iflag_slwc == 1) THEN + slwc_1d(k) = adiabatic_lwc + ELSE IF(iflag_slwc == 2) THEN + slwc_1d(k) = adjusted_lwc + ELSE IF(iflag_slwc == 3) THEN + slwc_1d(k) = adjusted_slwc + END IF + ELSE + WRITE(6,*)' Error Detected in SLWC' + END IF + END DO ! k + END IF ! ktop > kbase & kbase > 2, thick enough cloud exists + END IF ! ctop_m > cbase_m, cloud exists + + RETURN +END SUBROUTINE get_slwc1d + +SUBROUTINE slwc_revb(cb_pa,cb_k,gt_pa,gt_k,ct_k, & + adiabatic_lwc,adjusted_lwc,adjusted_slwc, & + i_status1,i_status2) +! +!.......................HISTORY............................. +! +! WRITTEN: CA. 1982 BY W. A. COOPER IN HP FORTRAN 4 +! +!....... CALCULATES TEMPERATURE T AND LIQUID WATER CONTENT FROM +!.. CLOUD BASE PRESSURE P0 AND TEMPERATURE T0, FOR ADIABATIC +!.. ASCENT TO THE PRESSURE P. +!.. -> INPUT: CLOUD BASE PRESSURE P0 AND TEMPERATURE T0 +!.. PRESSURE AT OBSERVATION LEVEL P +!.. -> OUTPUT: "ADIABATIC" TEMPERATURE T AND LIQUID WATER CONTENT +! +! MODIFIED: November 1989 by Paul Lawson for LAPS/WISP. Routine +! now calculates adiabatic liquid water content +! (ADIABATIC_LWC) using cloud base pressure and grid-top +! temperature and pressure. Also calculated are ADJUSTED_LWC, +! which adjusts ADIABATIC_LWC using an empirical cloud +! water depletion algorithm, and ADJUSTED_SLWC, which is +! ADIABATIC_LWC in regions where T < 0 C adjusted +! using an empirical algorithm by Marcia Politovich. +! +! Subroutine is now hardwired for stratiform cloud only. +! Can be modified to include Cu with input from LAPS main. +! +! revb: ca 12/89 Calculate adiabatic lwc by going from cloud +! base to LAPS grid level instead to cloud top, thus +! helping to better calculate in layer clouds. +! Add TG (grid temperature) to calcualtion. +! +! revc: 2/27/90 Correct error in code. Zero-out slwc when grid +! temperature (GT) > 0. +! +! J.Z.: 4/7/97 Correct error in code +! Grid temperature should be TG, not GT. +! +! +! OUTPUTS: ADIABATIC_LWC +! ADJUSTED_LWC +! ADJUSTED_SLWC +! I_STATUS1 - 1 when -20 < cld_top_temp < 0 for Stratus +! 0 Otherwise +! I_STATUS2 - 1 when valid input data provided from main +! + use gsd_kinds, only: r_single,i_kind,r_kind + IMPLICIT NONE + + real(r_single), intent(in) :: cb_pa,cb_k,gt_pa,gt_k,ct_k + real(r_single), intent(out) :: adiabatic_lwc,adjusted_lwc,adjusted_slwc + INTEGER(i_kind),intent(out) :: i_status1,i_status2 + + real(r_kind) :: eps,cpd,cw,rd,alhv + DATA eps/0.622_r_kind/,cpd/1.0042E3_r_kind/,cw/4.218E3_r_kind/,rd/287.05_r_kind/,alhv/2.501E6_r_kind/ + INTEGER(i_kind) :: cty,i + real(r_kind) :: p0,p,t0,tg,ctt,tk,e,r,cpt,t1,thetaq,rv,t,tw + real(r_kind) :: vapor +! +! + i_status1=1 + i_status2=1 +! 2 Print *,'ENTER: P-BASE(mb), T-BASE(C), P-TOP, T-TOP, CLD TYPE' +! READ(5,*) P0, T0, P, CTT, CTY +! If(CTY.ne.0.and.CTY.ne.1) Go to 2 +! +! Hardwire cloud type (CTY) for stratus for now +! + cty=0 +! +!.....Convert Pa to mb and Kelvin to Celcius +! + p0 = cb_pa/100._r_kind + p = gt_pa/100._r_kind + t0 = cb_k - 273.15_r_kind + tg = gt_k - 273.15_r_kind + ctt= ct_k - 273.15_r_kind +! Print *, 'CTT in Sub = ', CTT +! +! Check for valid input data... +! + IF(p0 > 1013._r_kind.OR.p0 < 50._r_kind) THEN + i_status2=0 + RETURN + ELSE + END IF +! +! + IF(t0 > 50._r_kind.OR.t0 < -70._r_kind) THEN + i_status2=0 + RETURN + ELSE + END IF +! +! + IF(p > 1013._r_kind.OR.p < 50._r_kind) THEN + i_status2=0 + RETURN + ELSE + END IF +! +! Set I_STATUS1 = F if 0 < cld top < -20 C (for stratus). +! + IF(tg >= 0._r_kind.OR.ctt < -20._r_kind) i_status1=0 +! + tk=t0+273.15_r_kind + e=vapor(t0) + r=eps*e/(p0-e) + cpt=cpd+r*cw + thetaq=tk*(1000._r_kind/(p0-e))**(rd/cpt)*EXP(alhv*r/(cpt*tk)) +! 1ST APPROX + t1=tk + e=vapor(t1-273.15_r_kind) + rv=eps*e/(p-e) + t1=thetaq/((1000._r_kind/(p-e))**(rd/cpt)*EXP(alhv*rv/(cpt*t1))) +! SUCCESSIVE APPROXIMATIONS + DO i=1,10 + e=vapor(t1-273.15_r_kind) + rv=eps*e/(p-e) + t1=(thetaq/((1000._r_kind/(p-e))**(rd/cpt)*EXP(alhv*rv/(cpt*t1))) & + +t1)/2._r_kind + t=t1-273.15_r_kind +! Print *, P0,T0,P,T,E,RV,THETAQ + END DO +! GET LWC + e=vapor(t) + rv=eps*e/(p-e) + tw=r-rv + adiabatic_lwc=tw*p*28.9644_r_kind/(8.314E7_r_kind*t1)*1.e9_r_kind + IF(adiabatic_lwc < 0._r_kind) adiabatic_lwc=0._r_kind +! Print *, 'Adiabtic LWC = ', ADIABATIC_LWC + IF(tg >= 0._r_kind) THEN +! + adjusted_slwc=0._r_kind ! Added 2/27/90 +! + + IF(cty == 0._r_kind) THEN + IF(ctt < -20._r_kind) THEN + adjusted_lwc=0._r_kind + ELSE IF(ctt < -15._r_kind.AND.ctt >= -20._r_kind) THEN + adjusted_lwc=adiabatic_lwc/8._r_kind + ELSE IF(ctt < -10._r_kind.AND.ctt >= -15._r_kind) THEN + adjusted_lwc=adiabatic_lwc/4._r_kind + ELSE + adjusted_lwc=adiabatic_lwc/2._r_kind + END IF + ELSE + IF(ctt < -25._r_kind) THEN + adjusted_lwc=0._r_kind + ELSE IF(ctt < -15._r_kind.AND.ctt >= -25._r_kind) THEN + adjusted_lwc=adiabatic_lwc/8._r_kind + ELSE IF(ctt < -10._r_kind.AND.ctt >= -15._r_kind) THEN + adjusted_lwc=adiabatic_lwc/4._r_kind + ELSE + adjusted_lwc=adiabatic_lwc/2._r_kind + END IF + END IF + ELSE + IF(cty == 0._r_kind) THEN + IF(ctt < -20._r_kind) THEN + adjusted_lwc=0._r_kind + adjusted_slwc=0._r_kind + ELSE IF(ctt < -15._r_kind.AND.ctt >= -20._r_kind) THEN + adjusted_lwc=adiabatic_lwc/8._r_kind + adjusted_slwc=adiabatic_lwc/8._r_kind + ELSE IF(ctt < -10._r_kind.AND.ctt >= -15._r_kind) THEN + adjusted_lwc=adiabatic_lwc/4._r_kind + adjusted_slwc=adiabatic_lwc/4._r_kind + ELSE + adjusted_lwc=adiabatic_lwc/2._r_kind + adjusted_slwc=adiabatic_lwc/2._r_kind + END IF + ELSE + IF(ctt < -25._r_kind) THEN + adjusted_lwc=0._r_kind + adjusted_slwc=0._r_kind + ELSE IF(ctt < -15._r_kind.AND.ctt >= -25._r_kind) THEN + adjusted_lwc=adiabatic_lwc/8._r_kind + adjusted_slwc=adiabatic_lwc/8._r_kind + ELSE IF(ctt < -10._r_kind.AND.ctt >= -15._r_kind) THEN + adjusted_lwc=adiabatic_lwc/4._r_kind + adjusted_slwc=adiabatic_lwc/4._r_kind + ELSE + adjusted_lwc=adiabatic_lwc/2._r_kind + adjusted_slwc=adiabatic_lwc/2._r_kind + END IF + END IF + END IF +! Print *,'Adjusted LWC = ', ADJUSTED_LWC +! Print *,'Adjusted SLWC = ', ADJUSTED_SLWC +END SUBROUTINE slwc_revb + +! FUNCTION TO CALCULATE VAPOR PRESSURE: +! + + FUNCTION vapor(tfp) +! INPUT IS IN DEGREES C. IF GT 0, ASSUMED TO BE DEW POINT. IF +! LESS THAN 0, ASSUMED TO BE FROST POINT. +! ROUTINE CODES GOFF-GRATCH FORMULA + use gsd_kinds, only: i_kind,r_kind + IMPLICIT NONE + + real(r_kind), intent(in) :: tfp + real(r_kind) :: vapor + +! + real(r_kind) :: tvap, e + + tvap=273.16_r_kind+tfp + IF(tfp > 0.) GO TO 1 +! THIS IS ICE SATURATION VAPOR PRESSURE + IF(tvap <= 0) tvap=1E-20_r_kind + e=-9.09718_r_kind*(273.16_r_kind/tvap-1._r_kind)- & + 3.56654_r_kind*LOG10(273.16_r_kind/tvap) & + +0.876793_r_kind*(1.-tvap/273.16_r_kind) + vapor=6.1071_r_kind*10._r_kind**e + RETURN + 1 CONTINUE +! THIS IS WATER SATURATION VAPOR PRESSURE + IF(tvap <= 0) tvap=1E-20_r_kind + e=-7.90298_r_kind*(373.16_r_kind/tvap-1._r_kind)+ & + 5.02808_r_kind*LOG10(373.16_r_kind/tvap) & + -1.3816E-7_r_kind*(10._r_kind**(11.344_r_kind*& + (1._r_kind-tvap/373.16_r_kind))-1._r_kind) & + +8.1328E-3_r_kind*(10._r_kind**(3.49149_r_kind& + *(1-373.16_r_kind/tvap))-1) + vapor=1013.246_r_kind*10._r_kind**e + RETURN + END FUNCTION vapor diff --git a/src/GSD/gsdcloud/BackgroundCld.f90 b/src/GSD/gsdcloud/BackgroundCld.f90 new file mode 100644 index 0000000000..53ec3e1611 --- /dev/null +++ b/src/GSD/gsdcloud/BackgroundCld.f90 @@ -0,0 +1,315 @@ +SUBROUTINE BackgroundCldgfs(mype,lon2,lat2,nsig,tbk,pbk,psbk,q,hbk) +! +!$$$ subprogram documentation block +! . . . . +! subprogram: BackgroundCld Ingest gfs background fields for cloud analysis +! +! PRGMMR: Ming Hu ORG: GSD/AMB DATE: 2006-10-27 +! +! ABSTRACT: +! This subroutine reads in background hydrometeor fields for cloud analysis +! +! PROGRAM HISTORY LOG: +! 2009-01-02 Hu Add NCO document block +! 2010-04-26 Hu delete the module gridmod and guess_grids. +! transfer information subroutine dummy variables +! +! +! input argument list: +! mype - processor ID +! lon2 - no. of lons on subdomain (buffer points on ends) +! lat2 - no. of lats on subdomain (buffer points on ends) +! nsig - no. of vertical levels +! tbk - 3D background potential temperature (K) +! psbk - 2D background surface pressure (hPa) +! q - 3D moisture (water vapor mixing ratio kg/kg) +! pbk - 3D background pressure (hPa) +! +! output argument list: +! hbk - 3D height above the ground (not the sea level) +!!!! z_lcl - lifting condensation level +! +! USAGE: +! INPUT FILES: +! +! OUTPUT FILES: +! +! REMARKS: +! +! ATTRIBUTES: +! LANGUAGE: FORTRAN 90 +! MACHINE: Linux cluster (WJET) +! +!$$$ +! +!_____________________________________________________________________ +! + + use gsd_kinds, only: r_single,i_kind,r_kind + use constants, only: rd_over_cp, h1000 + use constants, only: rd, grav, half, rad2deg + + implicit none + + integer(i_kind),intent(in):: mype + integer(i_kind),intent(in):: lon2 + integer(i_kind),intent(in):: lat2 + integer(i_kind),intent(in):: nsig + +! background +! +! read in from WRF +! + real(r_single),intent(inout) :: tbk(lon2,lat2,nsig) ! temperature + real(r_single),intent(in) :: psbk(lon2,lat2) ! surface pressure + real(r_single),intent(inout) :: q(lon2,lat2,nsig) ! moisture + real(r_single),intent(in) :: pbk(lon2,lat2,nsig) ! pressure hPa +! +! derived fields +! + real(r_single),intent(out) :: hbk(lon2,lat2,nsig)! height +! +! misc. +! + INTEGER :: i,j,k + + REAL(r_single) :: rdog, h, dz + REAL(r_single) :: height(nsig+1) + +! +!================================================================ +! + do k=1,nsig + do j=1,lat2 + do i=1,lon2 + q(i,j,k) = q(i,j,k)/(1.0_r_kind-q(i,j,k)) ! water vapor mixing ratio (kg/kg) + enddo + enddo + enddo + +! +! Compute geopotential height above the ground at midpoint of each layer +! + rdog = rd/grav + do j=1,lat2 + do i=1,lon2 + k = 1 + h = rdog * tbk(i,j,k) + dz = h * log(psbk(i,j)/pbk(i,j,k)) + height(k) = dz + + do k=2,nsig + h = rdog * half * (tbk(i,j,k-1)+tbk(i,j,k)) + dz = h * log(pbk(i,j,k-1)/pbk(i,j,k)) + height(k) = height(k-1) + dz + end do + + do k=1,nsig + hbk(i,j,k)=height(k) + end do + end do + end do + + do k=1,nsig + do j=1,lat2 + do i=1,lon2 + tbk(i,j,k)=tbk(i,j,k)*(h1000/pbk(i,j,k))**rd_over_cp + enddo + enddo + enddo + +END SUBROUTINE BackgroundCldgfs + +SUBROUTINE BackgroundCld(mype,lon2,lat2,nsig,tbk,pbk,psbk,q,hbk, & + zh,pt_ll,eta1_ll,aeta1_ll,eta2_ll,aeta2_ll,regional,wrf_mass_regional) +! +!$$$ subprogram documentation block +! . . . . +! subprogram: BackgroundCld Ingest background fields for cloud analysis +! +! PRGMMR: Ming Hu ORG: GSD/AMB DATE: 2006-10-27 +! +! ABSTRACT: +! This subroutine reads in background hydrometeor fields for cloud analysis +! +! PROGRAM HISTORY LOG: +! 2009-01-02 Hu Add NCO document block +! 2010-04-26 Hu delete the module gridmod and guess_grids. +! transfer information subroutine dummy variables +! 2017-03-23 Hu - add code to use hybrid vertical coodinate in WRF MASS +! core +! +! +! input argument list: +! mype - processor ID +! lon2 - no. of lons on subdomain (buffer points on ends) +! lat2 - no. of lats on subdomain (buffer points on ends) +! nsig - no. of vertical levels +! tbk - 3D background potential temperature (K) +! psbk - 2D background surface pressure (hPa) +! q - 3D moisture (water vapor mixing ratio kg/kg) +! zh - terrain +! pt_ll - vertical coordinate +! eta1_ll - vertical coordinate +! aeta1_ll - vertical coordinate +! regional - if regional +! wrf_mass_regional - if mass core +! +! output argument list: +! pbk - 3D background pressure (hPa) +! hbk - 3D height above the ground (not the sea level) +!!!! z_lcl - lifting condensation level +! +! USAGE: +! INPUT FILES: +! +! OUTPUT FILES: +! +! REMARKS: +! +! ATTRIBUTES: +! LANGUAGE: FORTRAN 90 +! MACHINE: Linux cluster (WJET) +! +!$$$ +! +!_____________________________________________________________________ +! + + use gsd_kinds, only: r_single,i_kind,r_kind + use constants, only: rd_over_cp, h1000 + use constants, only: rd, grav, half, rad2deg + + implicit none + + integer(i_kind),intent(in):: mype + integer(i_kind),intent(in):: lon2 + integer(i_kind),intent(in):: lat2 + integer(i_kind),intent(in):: nsig + + real(r_kind), intent(in) :: pt_ll + real(r_kind), intent(in) :: eta1_ll(nsig+1) ! + real(r_kind), intent(in) :: aeta1_ll(nsig) ! + real(r_kind), intent(in) :: eta2_ll(nsig+1) ! + real(r_kind), intent(in) :: aeta2_ll(nsig) ! + logical, intent(in) :: regional ! .t. for regional background/analysis + logical, intent(in) :: wrf_mass_regional ! + + +! background +! +! read in from WRF +! + real(r_single),intent(inout) :: tbk(lon2,lat2,nsig) ! temperature + real(r_single),intent(inout) :: psbk(lon2,lat2) ! surface pressure + real(r_single),intent(in) :: zh(lon2,lat2) ! terrain elevation + real(r_single),intent(inout) :: q(lon2,lat2,nsig) ! moisture +! +! derived fields +! + real(r_single),intent(out) :: hbk(lon2,lat2,nsig)! height + real(r_single),intent(out) :: pbk(lon2,lat2,nsig)! pressure hPa +! real(r_single),intent(out) :: z_lcl(lon2,lat2) ! lifting condensation level +! +! misc. +! + INTEGER :: i,j,k + + REAL(r_single) :: rdog, h, dz + REAL(r_single) :: height(nsig+1) + real(r_single) :: q_integral(lon2,lat2),q_integralc4h(lon2,lat2) + real(r_single) :: deltasigma, deltasigmac4h,psfc_this + +! +!================================================================ +! + q_integral=1 + q_integralc4h=0.0 + do k=1,nsig + deltasigma=eta1_ll(k)-eta1_ll(k+1) + deltasigmac4h=eta2_ll(k)-eta2_ll(k+1) + do j=1,lat2 + do i=1,lon2 + q(i,j,k) = q(i,j,k)/(1.0_r_kind-q(i,j,k)) ! water vapor mixing ratio (kg/kg) + q_integral(i,j)=q_integral(i,j)+deltasigma*q(i,j,k) + q_integralc4h(i,j)=q_integralc4h(i,j)+deltasigmac4h*q(i,j,k) + enddo + enddo + enddo + do j=1,lat2 + do i=1,lon2 + psfc_this=pt_ll+(psbk(i,j)-pt_ll)/q_integral(i,j) + psbk(i,j)= psfc_this + enddo + enddo + +! +! assign CAPE as 0, this part needs more work +! +! gsfc(:,:,3)=0.0 ! CAPE, we need but not included in wrf_inout +! 1: land use; 2: sfc soil T; 3: CAPE +! +! get land use and convert latitude and longitude back to degree +! xland=gsfc(:,:,1) +! soil_tbk=gsfc(:,:,2) +! +! get virtual potential temperature (thv) +! +! thv=0.0 +! do k=1,nsig +! do j=1,nlat +! do i=1,nlon +! rl=qr(i,j,k)+qs(i,j,k)+qg(i,j,k)+qc(i,j,k)+qi(i,j,k) +! thv(i,j,k)=tbk(i,j,k)*(1.0+0.61*q(i,j,k)-rl) +! ENDDO +! ENDDO +! ENDDO +!! +! +! now get pressure (pbk) and height (hbk) at each grid point +! + if(regional .and. wrf_mass_regional ) then + + do k=1,nsig + do j=1,lat2 + do i=1,lon2 + pbk(i,j,k)=aeta1_ll(k)*(psbk(i,j)-pt_ll)+pt_ll + aeta2_ll(k) + end do + end do + end do + +! Compute geopotential height at midpoint of each layer + rdog = rd/grav + do j=1,lat2 + do i=1,lon2 + k = 1 + h = rdog * tbk(i,j,k) + dz = h * log(psbk(i,j)/pbk(i,j,k)) + height(k) = zh(i,j) + dz + + do k=2,nsig + h = rdog * half * (tbk(i,j,k-1)+tbk(i,j,k)) + dz = h * log(pbk(i,j,k-1)/pbk(i,j,k)) + height(k) = height(k-1) + dz + end do + + do k=1,nsig + hbk(i,j,k)=height(k) - zh(i,j) + end do + end do + end do + else + write(6,*) ' Only wrf mass grid is done for cloud analysis ' + write(6,*) ' You are choosing grid that is not recoginzed by cloud analysis' + call stop2(114) + endif + + do k=1,nsig + do j=1,lat2 + do i=1,lon2 + tbk(i,j,k)=tbk(i,j,k)*(h1000/pbk(i,j,k))**rd_over_cp + enddo + enddo + enddo + +END SUBROUTINE BackgroundCld diff --git a/src/GSD/gsdcloud/BckgrndCC.f90 b/src/GSD/gsdcloud/BckgrndCC.f90 new file mode 100644 index 0000000000..57b0246a18 --- /dev/null +++ b/src/GSD/gsdcloud/BckgrndCC.f90 @@ -0,0 +1,158 @@ +SUBROUTINE BckgrndCC(nlon,nlat,nsig,tbk,pbk,q,hbk,zh, & + cv_bk,t_k,z_lcl) +! +!$$$ subprogram documentation block +! . . . . +! subprogram: BckgrndCC generate background field for +! fractional cloud cover based on RH +! +! PRGMMR: Ming Hu ORG: GSD/AMB DATE: 2006-10-27 +! +! ABSTRACT: +! This subroutine calculate cloud field based on background fields +! +! PROGRAM HISTORY LOG: +! 2009-01-20 Hu Add NCO document block +! +! +! input argument list: +! nlon - no. of lons on subdomain (buffer points on ends) +! nlat - no. of lats on subdomain (buffer points on ends) +! nsig - no. of levels +! tbk - 3D background potentional temperature (K) +! pbk - 3D background pressure (hPa) +! q - 3D moisture (kg/kg) +! hbk - 3D height +! zh - terrain +! +! output argument list: +! cv_bk - 3D background cloud cover +! t_k - 3D temperature in K +! z_lcl - lifting condensation level +! +! USAGE: +! INPUT FILES: +! +! OUTPUT FILES: +! +! REMARKS: +! +! ATTRIBUTES: +! LANGUAGE: FORTRAN 90 +! MACHINE: Linux cluster (WJET) +! +!$$$ +! +!_____________________________________________________________________ +! + use gsd_kinds, only: r_single,i_kind,r_kind + use constants, only: h1000, rd_over_cp, g_over_rd + + implicit none + + integer(i_kind),intent(in):: nlon,nlat,nsig +! background +! +! read in from WRF +! + real(r_single),intent(in) :: tbk(nlon,nlat,nsig) ! potential temperature + real(r_single),intent(in) :: zh(nlon,nlat) ! terrain elevation + real(r_single),intent(in) :: q(nlon,nlat,nsig) ! moisture + real(r_single),intent(in) :: hbk(nlon,nlat,nsig) ! height + real(r_single),intent(in) :: pbk(nlon,nlat,nsig) ! pressure + + real(r_single),intent(out) :: t_k(nlon,nlat,nsig) ! temperature in K + real(r_single),intent(out) :: z_lcl(nlon,nlat) ! lifting condensation level + real(r_single),intent(out) :: cv_bk(nlon,nlat,nsig)! cloud cover + +! CONSTANTS: + real(r_single) :: gamma_d ! dry adiabatic lapse rate (K/m) + real(r_single) :: z_ref_lcl + PARAMETER(z_ref_lcl = 180.0_r_single) + +! misc. +! + real(r_single) :: rhbk(nlon,nlat,nsig) ! rh + + INTEGER :: i,j,k + + + REAL(r_kind) :: f_qvsat + REAL(r_kind) :: qvsat + REAL(r_kind) :: rh_to_cldcv + + REAL(r_kind) :: z_ref,x + REAL(r_kind) :: arg,arg2, t_ref_c, td_ref_c + REAL(r_kind) :: frac_z, t_ref_k,rh_ref + +! +!================================================================ +! + gamma_d = g_over_rd/rd_over_cp +! +! get the RH +! + do k=1,nsig + do j=2,nlat-1 + do i=2,nlon-1 + t_k(i,j,k)=tbk(i,j,k)*(pbk(i,j,k)/h1000)**rd_over_cp + qvsat=f_qvsat(pbk(i,j,k)*100.0_r_kind,t_k(i,j,k)) + ! Saturation water vapor specific humidity + qvsat = qvsat/(1.0 - qvsat) ! convert to saturation mixing ratio (kg/kg) + rhbk(i,j,k)=100._r_kind*MIN(1._r_kind,MAX(0._r_kind,(q(i,j,k)/qvsat))) + ! q is mixing ration kg/kg + enddo + enddo + enddo +! +! Find the lifting condensation level +! + z_lcl = -99999.0_r_kind + do j=2,nlat-1 + do i=2,nlon-1 + z_ref = z_ref_lcl + zh(i,j) + IF (z_ref <= hbk(i,j,2) .OR. z_ref > hbk(i,j,nsig-1)) THEN + write(6,*) 'Error, ref.level is out of bounds at pt:' & + ,i,j,z_ref,hbk(i,j,2),hbk(i,j,nsig-1) + call STOP2(114) + END IF + + DO k = 3,nsig-1 + IF ( z_ref < hbk(i,j,k) .and. z_ref >= hbk(i,j,k-1)) THEN + frac_z = (z_ref-hbk(i,j,k-1))/(hbk(i,j,k)-hbk(i,j,k-1)) + t_ref_k = t_k(i,j,k-1)+ frac_z*(t_k(i,j,k)-t_k(i,j,k-1)) + t_ref_c = t_ref_k - 273.15_r_kind +! + rh_ref = rhbk(i,j,k-1)+ frac_z*(rhbk(i,j,k)-rhbk(i,j,k-1)) +! compute dew point depression. +! td_ref_c = dwpt(t_ref_c,rh_ref) + x = 1._r_kind-0.01_r_kind*rh_ref + td_ref_c =t_ref_c-(14.55_r_kind+0.114_r_kind*t_ref_c)*x+ & + ((2.5_r_kind+0.007_r_kind*t_ref_c)*x)**3+ & + (15.9_r_kind+0.117_r_kind*t_ref_c)*x**14 + + END IF + END DO ! k = 2,nz-1 +! + z_lcl(i,j) = z_ref + (t_ref_c - td_ref_c)/gamma_d + z_lcl(i,j) = min(hbk(i,j,nsig-1),max(z_lcl(i,j),hbk(i,j,2))) + enddo + enddo +! +! get background cloud cover +! + cv_bk=0.0_r_kind + do k=1,nsig + do j=2,nlat-1 + do i=2,nlon-1 + IF (hbk(i,j,k) >= z_lcl(i,j)) THEN + arg = hbk(i,j,k) - zh(i,j) + arg2=rhbk(i,j,k)*0.01_r_kind + cv_bk(i,j,k) = rh_to_cldcv(arg2,arg) + ENDIF + enddo + enddo + enddo +! + +END SUBROUTINE BckgrndCC diff --git a/src/GSD/gsdcloud/CMakeLists.txt b/src/GSD/gsdcloud/CMakeLists.txt new file mode 100644 index 0000000000..3b2ca84f12 --- /dev/null +++ b/src/GSD/gsdcloud/CMakeLists.txt @@ -0,0 +1,7 @@ +cmake_minimum_required(VERSION 2.6) +if(BUILD_GSDCLOUD_ARW) + file(GLOB GSDCLOUD_SRC ${GSDCLOUD_DIR}/*.f90) + set_source_files_properties( ${GSDCLOUD_SRC} COMPILE_FLAGS ${GSDCLOUD_Fortran_FLAGS}) + add_library( ${gsdcloud} STATIC ${GSDCLOUD_SRC} ) + set_target_properties( ${gsdcloud} PROPERTIES Fortran_MODULE_DIRECTORY ${CMAKE_INCLUDE_OUTPUT_DIRECTORY} ) +endif() diff --git a/src/GSD/gsdcloud/PrecipMxr_radar.f90 b/src/GSD/gsdcloud/PrecipMxr_radar.f90 new file mode 100644 index 0000000000..cbe889744c --- /dev/null +++ b/src/GSD/gsdcloud/PrecipMxr_radar.f90 @@ -0,0 +1,213 @@ +SUBROUTINE PrecipMxR_radar(mype,nlat,nlon,nsig, & + t_bk,p_bk,ref_mos_3d, & + cldpcp_type_3d,qr_cld,qnr_3d,qs_cld,qg_cld,cldqropt) +! +!$$$ subprogram documentation block +! . . . . +! subprogram: PrecipMxR_radar find cloud liquid water content +! +! PRGMMR: Ming Hu ORG: GSD/AMB DATE: 2006-11-20 +! +! ABSTRACT: +! This is the driver to call subroutines that calculate liquid water content based on +! radar reflectivity and hydrometeor type diagnosed from radar +! and background 3-D temperature fields +! +! PROGRAM HISTORY LOG: +! 2009-01-20 Hu Add NCO document block +! +! +! input argument list: +! mype - processor ID +! nlon - no. of lons on subdomain (buffer points on ends) +! nlat - no. of lats on subdomain (buffer points on ends) +! nsig - no. of levels +! +! t_bk - 3D background potential temperature (K) +! p_bk - 3D background pressure (hPa) +! ref_mos_3d - 3D reflectivity in analysis grid (dBZ) +! cldpcp_type_3d - 3D hydrometeor type +! cldqropt - scheme used to retrieve +! mixing ratios for hydrometeors related to precipitation (qr, qs, qg) +! 1=Kessler 2=Lin 3=Thompson +! +! output argument list: +! qr_cld - rain mixing ratio (g/kg) +! qnr_3d - rain number concentration +! qs_cld - snow mixing ratio (g/kg) +! qg_cld - graupel mixing ratio (g/kg) +! +! USAGE: +! INPUT FILES: +! +! OUTPUT FILES: +! +! REMARKS: +! +! ATTRIBUTES: +! LANGUAGE: FORTRAN 90 +! MACHINE: Linux cluster (WJET) +! +!$$$ +! +!_____________________________________________________________________ +! + + use constants, only: rd_over_cp, h1000 + use gsd_kinds, only: r_single,i_kind,r_kind + + implicit none + integer(i_kind),intent(in):: nlat,nlon,nsig + integer(i_kind),intent(in):: mype +!mhu integer(i_kind),intent(in) :: regional_time(6) +! +! background +! + real(r_single),intent(in) :: t_bk(nlon,nlat,nsig) ! potential temperature + real(r_single),intent(in) :: p_bk(nlon,nlat,nsig) ! height +! + real(r_kind),intent(in) :: ref_mos_3d(nlon,nlat,nsig) +! +! Variables for cloud analysis +! + integer(i_kind),intent(in) :: cldpcp_type_3d(nlon,nlat,nsig) +! +! hydrometeors +! + REAL(r_single),intent(out) :: qr_cld(nlon,nlat,nsig) ! rain + REAL(r_single),intent(out) :: qnr_3d(nlon,nlat,nsig) ! rain number concentration(/kg) + REAL(r_single),intent(out) :: qs_cld(nlon,nlat,nsig) ! snow + REAL(r_single),intent(out) :: qg_cld(nlon,nlat,nsig) ! graupel + +!----------------------------------------------------------- +! +! temp. +! + + REAL(r_single) :: t_3d(nlon,nlat,nsig) + REAL(r_single) :: p_3d(nlon,nlat,nsig) +! REAL(r_kind) :: qs_max + + INTEGER(i_kind) :: cldqropt + INTEGER(i_kind) :: istatus_pcp + INTEGER(i_kind) :: i,j,k +! INTEGER(i_kind) :: k_qs_max +! REAL(r_kind) :: threshold_t_1st + +! +!==================================================================== +! Begin +! +! cldqropt = 2 + + DO j = 2,nlat-1 + DO i = 2,nlon-1 + DO k = 1,nsig + t_3d(i,j,k) = t_bk(i,j,k)*(p_bk(i,j,k)/h1000)**rd_over_cp + p_3d(i,j,k) = p_bk(i,j,k)*100.0_r_single + END DO + END DO + END DO + +!----------------------------------------------------------------------- +! +! Calculate 3D precipitation hydrometeor mixing ratios +! from radar reflectivity in g/kg. +! Note that qr_cld, qs_cld, and qg_cld are diagnosed +! qr, qs and qg in g/kg, respectively. +! +!----------------------------------------------------------------------- +! + IF (cldqropt == 1) THEN +! +! Kessler's scheme +! + if(mype==0) then + WRITE(6,'(a)') 'PrecipMxR_radar: Computing Precip mixing ratio.' + WRITE(6,'(a)') & + ' Using Kessler radar reflectivity equations...' + endif + CALL pcp_mxr (nlon,nlat,nsig,t_3d,p_3d,ref_mos_3d, & + cldpcp_type_3d, & + qr_cld,qs_cld,qg_cld, & + istatus_pcp) + + ELSE IF (cldqropt == 2) THEN +! +! Ferrier's scheme +! + if(mype==0) then + WRITE(6,'(a)') 'PrecipMxR_radar: Computing Precip mixing ratio.' + WRITE(6,'(a)') & + ' Using Ferrier radar reflectivity equations...' + endif + CALL pcp_mxr_ferrier (nlon,nlat,nsig,t_3d,p_3d,ref_mos_3d, & + cldpcp_type_3d, & + qr_cld,qs_cld,qg_cld, & + istatus_pcp,mype) + + ELSE IF (cldqropt == 3) THEN +! +! Thompson's scheme +! + if(mype==0) then + WRITE(6,'(a)') ' PrecipMxR_radar: Computing Precip mixing ratio.' + WRITE(6,'(a)') & + ' Using Thompson RUC radar reflectivity equations...' + endif +! call pcp_mxr_thompsonRUC(qr_cld,qs_cld,qg_cld, & +! p_3d,t_3d, & +! ref_mos_3d,nlon,nlat,nsig,cldpcp_type_3d) + call hydro_mxr_thompson (nlon,nlat,nsig, t_3d, p_3d, ref_mos_3d, & + qr_cld,qnr_3d,qs_cld, istatus_pcp,mype) + + END IF !cldqropt=1 or 2 or 3 +! +! +! Set qs to radar retrieved snow mixing ratio at all levels +! within 150 hPa above surface in all seasons (this condition +! should occur rarely in summer in the US lower 48 states). +! +! If there is no reflectivity at all below (for qs) +! within 150 hPa of surface in a column, but there is radar-qs > 0 +! above, then apply radar-qs to model-qs at 2 levels with +! maximum radar-qs in the column but for no other levels. +! +! move this function out of this subroutine to main driver. Feb.4 2013 +! +! If the 1st level temperature is less than 5 degree, then keep +! snow. Otherwise, keep a sinlge layer (maximum) of snow. +! +! if(l_cleanSnow_WarmTs) then +! threshold_t_1st=r_cleanSnow_WarmTs_threshold +! DO j = 2,nlat-1 +! DO i = 2,nlon-1 +! +! k_qs_max=2 +! qs_max=0.0_r_kind +! DO k = 2,nsig +! if(qs_max < qs_cld(i,j,k) ) then +! qs_max = qs_cld(i,j,k) +! k_qs_max=k +! endif +! END DO +! +! if((t_3d(i,j,1)-273.15_r_kind) < threshold_t_1st) then +!! keep snow falling +! else +! if(qs_max > 1.0e-7_r_kind) then +! DO k = 1,nsig +!! if(k==k_qs_max) then +!! do nothing to keep snow mixing ratio +! else +! qs_cld(i,j,k)=0.0_r_kind +! endif +! END DO +! endif +! endif +! END DO !i +! END DO ! j +! endif ! l_cleanSnow_WarmTs + +END SUBROUTINE PrecipMxR_radar + diff --git a/src/GSD/gsdcloud/PrecipType.f90 b/src/GSD/gsdcloud/PrecipType.f90 new file mode 100644 index 0000000000..7ebb889059 --- /dev/null +++ b/src/GSD/gsdcloud/PrecipType.f90 @@ -0,0 +1,118 @@ +SUBROUTINE PrecipType(nlat,nlon,nsig,t_bk,p_bk,q_bk,radar_3d, & + wthr_type,cldpcp_type_3d) +! +!$$$ subprogram documentation block +! . . . . +! subprogram: PrecipType decide precipitation type +! +! PRGMMR: Ming Hu ORG: GSD/AMB DATE: 2006-11-20 +! +! ABSTRACT: +! This subroutine calculates precipitation type +! +! PROGRAM HISTORY LOG: +! 2009-01-20 Hu Add NCO document block +! +! +! input argument list: +! nlon - no. of lons on subdomain (buffer points on ends) +! nlat - no. of lats on subdomain (buffer points on ends) +! nsig - no. of levels +! t_bk - 3D background potential temperature (K) +! p_bk - 3D background pressure (hPa) +! q_bk - 3D moisture +! radar_3d - 3D radar reflectivity in analysis grid (dBZ) +! wthr_type - weather type +! +! output argument list: +! cldpcp_type_3d - 3D precipitation type +! +! USAGE: +! INPUT FILES: +! +! OUTPUT FILES: +! +! REMARKS: +! +! ATTRIBUTES: +! LANGUAGE: FORTRAN 90 +! MACHINE: Linux cluster (WJET) +! +!$$$ +! +!_____________________________________________________________________ +! + + use constants, only: rd_over_cp, h1000 + use gsd_kinds, only: r_single,i_kind,r_kind + + implicit none + integer(i_kind),INTENT(IN):: nlat,nlon,nsig +! +! surface observation +! +! +! background +! + real(r_single),INTENT(IN) :: t_bk(nlon,nlat,nsig) ! potential temperature + real(r_single),INTENT(IN) :: p_bk(nlon,nlat,nsig) ! pressure + real(r_single),INTENT(IN) :: q_bk(nlon,nlat,nsig) ! moisture +! +! observation +! + real(r_kind),INTENT(IN) :: radar_3d(nlon,nlat,nsig) ! reflectivity +! +! +! Variables for cloud analysis +! + integer(i_kind),INTENT(out) :: cldpcp_type_3d(nlon,nlat,nsig) + integer(i_kind),INTENT(in) :: wthr_type(nlon,nlat) + LOGICAL :: l_mask(nlon,nlat) ! "Potential" Precip Type + +! +!----------------------------------------------------------- +! +! temp. +! + INTEGER(i_kind):: i,j,k + real(r_single) :: temp_3d(nlon,nlat,nsig) ! temperature (C) + real(r_single) :: rh_3d(nlon,nlat,nsig) ! relative humidity + real(r_single) :: p_pa_3d(nlon,nlat,nsig) ! + REAL(r_single) :: qvsat + REAL(r_single) :: f_qvsat + INTEGER :: istatus +! +!==================================================================== +! Begin +! +!----------------------------------------------------------------------- +! +! Find Cloud Layers and Computing Output Field(s) +! The procedure works column by column. +! +!----------------------------------------------------------------------- +! + + DO j = 1,nlat + DO i = 1,nlon +! + DO k = 1,nsig ! Initialize + temp_3d(i,j,k)=t_bk(i,j,k)*(p_bk(i,j,k)/h1000)**rd_over_cp ! convert to K + qvsat=f_qvsat(p_bk(i,j,k)*100.0_r_single,temp_3d(i,j,k)) + qvsat = qvsat/(1.0_r_single-qvsat) ! convert to mixing ratio (kg/kg) + rh_3d(i,j,k)=100._r_single*MIN(1.,MAX(0._r_single,(q_bk(i,j,k)/qvsat))) + p_pa_3d(i,j,k) = p_bk(i,j,k)*100.0_r_single + END DO +!----------------------------------------------------------------------- + + ENDDO ! i + ENDDO ! j + + l_mask = .false. + + call pcp_type_3d (nlon,nlat,nsig,temp_3d,rh_3d,p_pa_3d & + ,radar_3d,l_mask,cldpcp_type_3d,istatus) + + +END SUBROUTINE precipType + diff --git a/src/GSD/gsdcloud/TempAdjust.f90 b/src/GSD/gsdcloud/TempAdjust.f90 new file mode 100644 index 0000000000..4e86df1602 --- /dev/null +++ b/src/GSD/gsdcloud/TempAdjust.f90 @@ -0,0 +1,199 @@ +SUBROUTINE TempAdjust(mype,nlat,nlon,nsig,cldptopt, t_bk, p_bk,w_bk,q_bk, & + qc,qi,ctmp_bk) + +! +!$$$ subprogram documentation block +! . . . . +! subprogram: TempAdjust temperature adjustment +! +! PRGMMR: Ming Hu ORG: GSD/AMB DATE: 2006-11-26 +! +! ABSTRACT: +! This subroutine adjusts the perturbation potential temperature field to account +! for the latent heating release. +! +! PROGRAM HISTORY LOG: +! 2009-01-20 Hu Add NCO document block +! +! +! input argument list: +! mype - processor ID +! nlon - no. of lons on subdomain (buffer points on ends) +! nlat - no. of lats on subdomain (buffer points on ends) +! nsig - no. of levels +! cldptopt - schemes of adjustment +! 3=latent heat, 4,5,6 = adiabat profile +! t_bk - 3D background potential temperature (K) +! p_bk - 3D background pressure (hPa) +! w_bk - 3D background vertical velocity +! q_bk - 3D moisture (water vapor mixing ratio) +! qc - 3D cloud water mixing ratio (kg/kg) +! qi - 3D cloud ice mixing ratio (kg/kg) +! ctmp_bk - 3D cloud temperature +! +! output argument list: +! t_bk - 3D background potential temperature (K) +! +! USAGE: +! INPUT FILES: +! +! OUTPUT FILES: +! +! REMARKS: +! +! ATTRIBUTES: +! LANGUAGE: FORTRAN 90 +! MACHINE: Linux cluster (WJET) +! +!$$$ +! +!_____________________________________________________________________ +! + + use constants, only: cp,rd_over_cp, h1000, hvap + use gsd_kinds, only: r_single,i_kind + + implicit none + integer(i_kind),intent(in):: nlat,nlon,nsig + integer(i_kind),intent(in):: mype + +! +! background +! + real(r_single),intent(inout) :: t_bk(nlon,nlat,nsig) ! temperature + real(r_single),intent(in) :: p_bk(nlon,nlat,nsig) ! pressure + real(r_single),intent(in) :: w_bk(nlon,nlat,nsig) ! terrain + real(r_single),intent(in) :: q_bk(nlon,nlat,nsig) ! moisture - water vapor mixing ratio +! +! real(r_single) :: t_bk_check(nlon,nlat,nsig) ! temperature +! +! +! cloud water and cloud ice mixing ratios +! + real (r_single),intent(in) :: qc(nlon,nlat,nsig) + real (r_single),intent(in) :: qi(nlon,nlat,nsig) + real (r_single),intent(in) :: ctmp_bk(nlon,nlat,nsig) +! +! constant + REAL :: p0 +! +! +! temp. +! + INTEGER :: i,j,k + INTEGER(i_kind),intent(in) :: cldptopt + REAL :: frac_qc_2_lh, max_lh_2_pt + REAL :: max_pt_adj + REAL :: p0inv,arg,ptdiff + REAL :: ppi,wratio,ptcld +! +! +!----------------------------------------------------------- +! +! t_bk_check=0.0 + + p0=h1000 +! + wratio=1.0 +! cldptopt=3 + frac_qc_2_lh =1.0 + max_lh_2_pt=20.0 +! + IF (cldptopt == 3) THEN +if(mype==0) then + WRITE(6,'(a)')'TempAdjust: Adjusting t_bk to account for latent heating.' + WRITE(6,'(a,f10.4,a,f10.4)') & + 'TempAdjust: frac of qc:',frac_qc_2_lh,' adj_lim:',max_lh_2_pt +endif + p0inv=1./p0 + max_pt_adj = 0.0 + DO k=2,nsig + DO j=2,nlat-1 + DO i=2,nlon-1 + arg=max(0.0,qc(i,j,k)) + max(0.0,qi(i,j,k)) + if( arg > 0.0 ) then + ppi = (p_bk(i,j,k)*p0inv) ** rd_over_cp + arg = hvap*frac_qc_2_lh*arg*0.001/(cp*ppi) + max_pt_adj = MAX(max_pt_adj,arg) + t_bk(i,j,k) = t_bk(i,j,k) + MIN(arg,max_lh_2_pt) + endif + END DO + END DO + END DO + if(mype==0) PRINT*,'max_adj=',max_pt_adj + ELSE IF (cldptopt == 4) THEN +if(mype==0) then + WRITE(6,'(a)')'TempAdjust: Adjusting t_bk to account for latent heating in w.' + PRINT*,'frac of qc:',frac_qc_2_lh,' adj_lim:',max_lh_2_pt +endif + max_pt_adj = 0.0 + DO k=2,nsig + DO j=2,nlat-1 + DO i=2,nlon-1 + IF(w_bk(i,j,k) > 0. .and. ctmp_bk(i,j,k) > 0.0) THEN + wratio=1.0 + ptcld=ctmp_bk(i,j,k)*(p0/p_bk(i,j,k))**rd_over_cp + ptdiff=ptcld-t_bk(i,j,k) + IF(ptdiff > 0.) THEN + arg = frac_qc_2_lh*wratio*ptdiff + t_bk(i,j,k) = t_bk(i,j,k) + MIN(arg,max_lh_2_pt) + max_pt_adj = MAX(max_pt_adj,arg) + END IF + END IF + END DO + END DO + END DO + if(mype==0) PRINT*,'max_adj=',max_pt_adj + ELSE IF (cldptopt == 5) THEN +if(mype==0) then + WRITE(6,'(a)')'TempAdjust: Adjusting t_bk to moist-adiab cloud temp for w>-0.2' + PRINT*,'frac of qc:',frac_qc_2_lh,' adj_lim:',max_lh_2_pt +endif + max_pt_adj = 0.0 + DO k=2,nsig + DO j=2,nlat-1 + DO i=2,nlon-1 + IF( ctmp_bk(i,j,k) > 0.0) THEN + wratio=min(max(0.,(5.0*(w_bk(i,j,k)+0.2))),1.0) + ptcld=ctmp_bk(i,j,k)*(p0/p_bk(i,j,k))**rd_over_cp + ptdiff=ptcld-t_bk(i,j,k) + IF(ptdiff > 0.) THEN + arg = frac_qc_2_lh*wratio*ptdiff + t_bk(i,j,k) = t_bk(i,j,k) + MIN(arg,max_lh_2_pt) + max_pt_adj = MAX(max_pt_adj,arg) + END IF + ENDIF + END DO + END DO + END DO + if(mype==0) PRINT*,'max_adj=',max_pt_adj + + ELSE IF (cldptopt == 6) THEN +if(mype==0) then + WRITE(6,'(a)')'TempAdjust: Adjusting t_bk to moist-adiab cloud temp for w>0.0' + PRINT*,'frac of qc:',frac_qc_2_lh,' adj_lim:',max_lh_2_pt +endif + max_pt_adj = 0.0 + DO k=2,nsig + DO j=2,nlat-1 + DO i=2,nlon-1 + IF(w_bk(i,j,k) > 0. .and. ctmp_bk(i,j,k)>0.0 ) THEN + ptcld=ctmp_bk(i,j,k)*(p0/p_bk(i,j,k))**rd_over_cp + ptdiff=ptcld-t_bk(i,j,k) + IF(ptdiff > 0.) THEN + arg = frac_qc_2_lh*ptdiff + t_bk(i,j,k) = t_bk(i,j,k) + MIN(arg,max_lh_2_pt) +! t_bk_check(i,j,k) = MIN(arg,max_lh_2_pt) + max_pt_adj = MAX(max_pt_adj,arg) + END IF + END IF + END DO + END DO + END DO + if(mype==0) PRINT*,'max_adj=',max_pt_adj + + END IF ! cldptopt=3? + +! t_bk = t_bk_check + +END SUBROUTINE TempAdjust diff --git a/src/GSD/gsdcloud/adaslib.f90 b/src/GSD/gsdcloud/adaslib.f90 new file mode 100644 index 0000000000..7a7eac0b77 --- /dev/null +++ b/src/GSD/gsdcloud/adaslib.f90 @@ -0,0 +1,474 @@ +! +!$$$ subprogram documentation block +! . . . . +! ABSTRACT: +! This file collects subroutines related to cloud analysis in ADAS (CAPS) +! +! PROGRAM HISTORY LOG: +! 2009-01-20 Hu Add NCO document block +! +! +! input argument list: +! +! output argument list: +! +! USAGE: +! INPUT FILES: +! +! OUTPUT FILES: +! +! REMARKS: +! +! ATTRIBUTES: +! LANGUAGE: FORTRAN 90 +! MACHINE: Linux cluster (WJET) +! +!$$$ +! +!_____________________________________________________________________ +! +! +!################################################################## +!################################################################## +!###### ###### +!###### FUNCTION RH_TO_CLDCV ###### +!###### ###### +!################################################################## +!################################################################## +! + + FUNCTION rh_to_cldcv(rh,hgt) +! +!----------------------------------------------------------------------- +! +! PURPOSE: +! +! Obtain first guess cloud cover field from relative humidity. +! +! +! AUTHOR: Jian Zhang +! 07/95 +! +! MODIFICATION HISTORY +! +! 04/08/97 J. Zhang +! Added the empirical relationship between RH and +! cloud cover used by Koch et al. (1997). +! Reference: +! Reference: +! Koch, S.E., A. Aksakal, and J.T. McQueen, 1997: +! The influence of mesoscale humidity and evapotranspiration +! fields on a model forecast of a cold-frontal squall line. +! Mon. Wea. Rev., Vol.125, 384-409 +! 09/10/97 J. Zhang +! Modified the empirical relationship between cloud +! fraction and relative humidity from quadratic +! to one-fourth-power. +! +! +!----------------------------------------------------------------------- +! +! INPUT: +! rh ! relative humidity +! hgt ! height (AGL) +! +! OUTPUT: +! rh_to_cld_cv ! cloud fractional cover value +! +! LOCAL: +! rh0 ! the critical RH value that seperate clear + ! air condition and cloudy condition +! +!----------------------------------------------------------------------- +! +! Variable Declarations. +! +!----------------------------------------------------------------------- +! + use gsd_kinds, only: r_single,i_kind,r_kind + + IMPLICIT NONE + + INTEGER(i_kind) :: rh2cform + PARAMETER (rh2cform=2) + + REAL(r_kind), intent(in) :: rh,hgt + REAL(r_kind) :: rh_to_cldcv + REAL(r_kind) :: rh0 + +! +!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ +! +! Beginning of executable code... +! +!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ +! +! + IF(rh2cform == 1) THEN +! +!----------------------------------------------------------------------- +! +! A quadratic relationship between relative humidity and cloud +! fractional cover. +! +!----------------------------------------------------------------------- +! + IF (hgt < 600.0_r_kind) THEN + rh0 = 0.9_r_kind + ELSE IF (hgt < 1500.0_r_kind) THEN + rh0 = 0.8_r_kind + ELSE IF (hgt < 2500.0_r_kind) THEN + rh0 = 0.6_r_kind + ELSE + rh0 = 0.5_r_kind + END IF + + IF (rh < rh0) THEN + rh_to_cldcv = 0.0_r_kind + ELSE + rh_to_cldcv = (rh - rh0)/(1.0_r_kind - rh0) + rh_to_cldcv = rh_to_cldcv*rh_to_cldcv + END IF + + ELSE IF(rh2cform == 2) THEN +! +!----------------------------------------------------------------------- +! +! A quadratic relationship between relative humidity and cloud +! fractional cover with fixed rh0=0.75 +! +!----------------------------------------------------------------------- +! +! + IF (rh < 0.75_r_kind) THEN + rh_to_cldcv = 0.0_r_kind + ELSE + rh_to_cldcv = 16._r_kind*(rh - 0.75_r_kind)*(rh - 0.75_r_kind) + END IF + + ELSE +! +!-----------------------------------------------------------------------! +! A modified version of the sqrt relationship between +! relative humidity and cloud fractional cover used in Eta model. +! +!----------------------------------------------------------------------- +! + IF (hgt < 600._r_kind) THEN + rh0 = 0.8_r_kind + ELSE + rh0 = 0.75_r_kind + END IF + + IF (rh < rh0) THEN + rh_to_cldcv = 0.0_r_kind + ELSE + rh_to_cldcv = 1.0_r_kind - SQRT((1.0_r_kind - rh)/(1.0_r_kind - rh0)) + END IF + + END IF + + RETURN + END FUNCTION rh_to_cldcv +! +! +!################################################################## +!################################################################## +!###### ###### +!###### FUNCTION F_ES ###### +!###### ###### +!###### Developed by ###### +!###### Center for Analysis and Prediction of Storms ###### +!###### University of Oklahoma ###### +!###### ###### +!################################################################## +!################################################################## +! + +FUNCTION f_es( p, t ) +! +!----------------------------------------------------------------------- +! +! PURPOSE: +! +! Calculate the saturation specific humidity using enhanced Teten's +! formula. +! +!----------------------------------------------------------------------- +! +! AUTHOR: Yuhe Liu +! 01/08/1998 +! +! MODIFICATION HISTORY: +! +!----------------------------------------------------------------------- +! +! INPUT : +! +! p Pressure (Pascal) +! t Temperature (K) +! +! OUTPUT: +! +! f_es Saturation water vapor pressure (Pa) +! +!----------------------------------------------------------------------- +! + +! +!----------------------------------------------------------------------- +! +! Variable Declarations. +! +!----------------------------------------------------------------------- +! + IMPLICIT NONE + + REAL :: p ! Pressure (Pascal) + REAL :: t ! Temperature (K) + REAL :: f_es ! Saturation water vapor pressure (Pa) +! +!----------------------------------------------------------------------- +! +! Function f_es and inline directive for Cray PVP +! +!----------------------------------------------------------------------- +! + REAL :: f_esl, f_esi + +!fpp$ expand (f_esl) +!fpp$ expand (f_esi) +!!dir$ inline always f_esl, f_esi +!*$* inline routine (f_esl, f_esi) + +! +!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ +! +! Beginning of executable code... +! +!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ +! + IF ( t >= 273.15 ) THEN ! for water + f_es = f_esl( p,t ) + ELSE ! for ice + f_es = f_esi( p,t ) + END IF + + RETURN +END FUNCTION f_es + +! +!----------------------------------------------------------------------- +! +! Calculate the saturation water vapor over liquid water using +! enhanced Teten's formula. +! +!----------------------------------------------------------------------- +! + +FUNCTION f_esl( p, t ) + + IMPLICIT NONE + +! constant + REAL :: satfwa, satfwb + PARAMETER ( satfwa = 1.0007 ) + PARAMETER ( satfwb = 3.46E-8 ) ! for p in Pa + + REAL :: satewa, satewb, satewc + PARAMETER ( satewa = 611.21 ) ! es in Pa + PARAMETER ( satewb = 17.502 ) + PARAMETER ( satewc = 32.18 ) + + REAL :: p ! Pressure (Pascal) + REAL :: t ! Temperature (K) + REAL :: f_esl ! Saturation water vapor pressure over liquid water + + REAL :: f + +! +!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ +! +! Beginning of executable code... +! +!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ +! + f = satfwa + satfwb * p + f_esl = f * satewa * EXP( satewb*(t-273.15)/(t-satewc) ) + + RETURN +END FUNCTION f_esl +! +!----------------------------------------------------------------------- +! +! Calculate the saturation water vapor over ice using enhanced +! Teten's formula. +! +!----------------------------------------------------------------------- +! + +FUNCTION f_esi( p, t ) + + IMPLICIT NONE + +! + REAL :: satfia, satfib + PARAMETER ( satfia = 1.0003 ) + PARAMETER ( satfib = 4.18E-8 ) ! for p in Pa + + REAL :: sateia, sateib, sateic + PARAMETER ( sateia = 611.15 ) ! es in Pa + PARAMETER ( sateib = 22.452 ) + PARAMETER ( sateic = 0.6 ) + + REAL :: p ! Pressure (Pascal) + REAL :: t ! Temperature (K) + REAL :: f_esi ! Saturation water vapor pressure over ice (Pa) + + REAL :: f + +! +!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ +! +! Beginning of executable code... +! +!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ +! + f = satfia + satfib * p + f_esi = f * sateia * EXP( sateib*(t-273.15)/(t-sateic) ) + + RETURN +END FUNCTION f_esi +! +! +!################################################################## +!################################################################## +!###### ###### +!###### FUNCTION F_QVSAT ###### +!###### ###### +!###### Developed by ###### +!###### Center for Analysis and Prediction of Storms ###### +!###### University of Oklahoma ###### +!###### ###### +!################################################################## +!################################################################## +! + +FUNCTION f_qvsat( p, t ) +! +!----------------------------------------------------------------------- +! +! PURPOSE: +! +! Calculate the saturation specific humidity using enhanced Teten's +! formula. +! +!----------------------------------------------------------------------- +! +! AUTHOR: Yuhe Liu +! 01/08/1998 +! +! MODIFICATION HISTORY: +! +!----------------------------------------------------------------------- +! +! INPUT : +! +! p Pressure (Pascal) +! t Temperature (K) +! +! OUTPUT: +! +! f_qvsat Saturation water vapor specific humidity (kg/kg). +! +!----------------------------------------------------------------------- +! + +! +!----------------------------------------------------------------------- +! +! Variable Declarations. +! +!----------------------------------------------------------------------- +! + IMPLICIT NONE + + REAL :: p ! Pressure (Pascal) + REAL :: t ! Temperature (K) + REAL :: f_qvsat ! Saturation water vapor specific humidity (kg/kg) +! +!----------------------------------------------------------------------- +! +! Include files: +! +!----------------------------------------------------------------------- +! +! + + REAL :: rd ! Gas constant for dry air (m**2/(s**2*K)) + PARAMETER( rd = 287.0 ) + + REAL :: rv ! Gas constant for water vapor (m**2/(s**2*K)). + PARAMETER( rv = 461.0 ) + + REAL :: rddrv + PARAMETER( rddrv = rd/rv ) + +! +!----------------------------------------------------------------------- +! +! Function f_es and inline directive for Cray PVP +! +!----------------------------------------------------------------------- +! + REAL :: f_es +! +!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ +! +! Beginning of executable code... +! +!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ +! + f_qvsat = rddrv * f_es(p,t) / (p-(1.0-rddrv)*f_es(p,t)) + + RETURN +END FUNCTION f_qvsat + +SUBROUTINE getdays(nday,iyear,imonth,iday) + + use gsd_kinds, only: i_kind + implicit none +! + INTEGER(i_kind), intent(in) :: iyear,imonth,iday + INTEGER(i_kind), intent(out) :: nday +! + + nday=0 + if(imonth==1) then + nday=iday + elseif(imonth==2) then + nday=31+iday + elseif(imonth==3) then + nday=59+iday + elseif(imonth==4) then + nday=90+iday + elseif(imonth==5) then + nday=120+iday + elseif(imonth==6) then + nday=151+iday + elseif(imonth==7) then + nday=181+iday + elseif(imonth==8) then + nday=212+iday + elseif(imonth==9) then + nday=243+iday + elseif(imonth==10) then + nday=273+iday + elseif(imonth==11) then + nday=304+iday + elseif(imonth==12) then + nday=334+iday + endif + if(mod(iyear,4) == 0 .and. imonth > 2 ) nday=nday+1 + +END SUBROUTINE getdays diff --git a/src/GSD/gsdcloud/build_missing_REFcone.f90 b/src/GSD/gsdcloud/build_missing_REFcone.f90 new file mode 100644 index 0000000000..7ad7cf54c2 --- /dev/null +++ b/src/GSD/gsdcloud/build_missing_REFcone.f90 @@ -0,0 +1,245 @@ +SUBROUTINE build_missing_REFcone(mype,nlon,nlat,nsig,krad_bot_in,ref_mos_3d,h_bk,pblh) +! +! radar observation +! +! +!$$$ subprogram documentation block +! . . . . +! subprogram: build_missing_REFcone build missing reflectivity area +! below cone down to assumed cloud base +! +! PRGMMR: Ming Hu ORG: GSD/AMB DATE: 2008-11-26 +! +! ABSTRACT: +! This subroutine sets reflectivity values at missing reflectivity volumes +! below the radar "data cone" down to an assumed cloud base +! As of March 2010, this code code not yet use the local PBL base +! as used in the RUC cloud/hydrometeor analysis since summer 2009. +! +! PROGRAM HISTORY LOG: +! 2009-01-20 Hu Add NCO document block +! 2011-04-08 Hu Clean the reflectivity below PBL height or level 7 +! +! +! input argument list: +! mype - processor ID +! nlon - no. of lons on subdomain (buffer points on ends) +! nlat - no. of lats on subdomain (buffer points on ends) +! nsig - no. of levels +! krad_bot - radar bottom level +! ref_mos_3d - 3D radar reflectivity +! h_bk - 3D background height +! pblh - PBL height in grid +! +! output argument list: +! ref_mos_3d - 3D radar reflectivity +! +! USAGE: +! INPUT FILES: +! +! OUTPUT FILES: +! +! REMARKS: +! +! ATTRIBUTES: +! LANGUAGE: FORTRAN 90 +! MACHINE: Linux cluster (WJET) +! +!$$$ +! +!_____________________________________________________________________ +! + + use gsd_kinds, only: r_kind,i_kind,r_single + implicit none + + INTEGER(i_kind), intent(in) :: mype + INTEGER(i_kind), intent(in) :: nlon,nlat,nsig + real(r_single), intent(in) :: h_bk(nlon,nlat,nsig) ! 3D height + real(r_kind), intent(inout):: ref_mos_3d(nlon,nlat,nsig) ! reflectivity in grid + real(r_single), intent(in) :: pblh(nlon,nlat) ! PBL height + real(r_single), intent(in) :: krad_bot_in +! + integer(i_kind) :: krad_bot,ifmissing +! + integer(i_kind) :: maxlvl + parameter (maxlvl=31) + real(r_kind) :: newlvlAll(maxlvl) ! vertical levels of reflectivity statistic profile(km) + DATA newlvlAll/0.2, 0.5, 0.75, 1, 1.25, 1.5, 1.75, 2, 2.25, 2.5, 2.75, & + 3, 3.5, 4, 4.5, 5, 5.5, 6, 6.5, 7, 7.5, 8, 8.5, & + 9, 10, 11, 12, 13, 14, 15, 16/ + + real(r_kind) :: refprofile_winter(maxlvl,6) ! statistic reflectivity profile used to + ! retrieve vertical ref based on lightning +! max reflectivity 20-35 dbz + DATA refprofile_winter(:,1) / & + 0.999,0.938,0.957,0.975,0.983,0.990,0.995,0.999,1.000,1.000, & + 0.994,0.985,0.957,0.926,0.892,0.854,0.819,0.791,0.770,0.747, & + 0.729,0.711,0.705,0.685,0.646,0.631,0.649,0.711,0.828,0.931, & + 0.949/ +! max reflectivity 25-30 dbz + DATA refprofile_winter(:,2) / & + 0.965,0.937,0.954,0.970,0.984,0.991,0.996,1.000,0.997,0.988, & + 0.973,0.954,0.908,0.856,0.808,0.761,0.718,0.684,0.659,0.631, & + 0.607,0.586,0.570,0.550,0.523,0.512,0.531,0.601,0.711,0.813, & + 0.870/ +! max reflectivity 30-35 dbz + DATA refprofile_winter(:,3) / & + 0.966,0.958,0.977,0.989,0.998,1.000,0.997,0.992,0.981,0.962, & + 0.933,0.898,0.826,0.752,0.687,0.626,0.578,0.547,0.522,0.526, & + 0.519,0.501,0.482,0.464,0.437,0.430,0.454,0.539,0.662,0.742, & + 0.793/ +! max reflectivity 35-40 dbz + DATA refprofile_winter(:,4) / & + 0.947,0.953,0.980,0.994,1.000,0.996,0.987,0.974,0.956,0.928, & + 0.891,0.848,0.761,0.679,0.613,0.559,0.522,0.491,0.473,0.462, & + 0.451,0.433,0.415,0.403,0.382,0.380,0.406,0.482,0.603,0.707, & + 0.723/ +! max reflectivity 40-45 dbz + DATA refprofile_winter(:,5) / & + 0.937,0.955,0.986,1.000,0.997,0.995,0.988,0.978,0.957,0.920, & + 0.871,0.824,0.735,0.654,0.584,0.518,0.465,0.442,0.435,0.412, & + 0.398,0.385,0.376,0.360,0.340,0.350,0.377,0.446,0.551,0.625, & + 0.656/ +! max reflectivity 45-50 dbz + DATA refprofile_winter(:,6) / & + 0.900,0.949,0.982,0.995,1.000,0.998,0.983,0.954,0.914,0.874, & + 0.834,0.793,0.721,0.664,0.612,0.565,0.530,0.496,0.460,0.431, & + 0.402,0.383,0.370,0.354,0.335,0.321,0.347,0.342,0.441,0.510, & + 0.548/ + + + real(r_kind) :: refprofile_summer(maxlvl,6) ! statistic reflectivity profile used to + ! retrieve vertical ref based on lightning +! max reflectivity 20-25 dbz + DATA refprofile_summer(:,1) / & + 0.883,0.870,0.879,0.892,0.904,0.912,0.913,0.915,0.924,0.936, & + 0.946,0.959,0.984,0.999,1.000,0.995,0.988,0.978,0.962,0.940, & + 0.916,0.893,0.865,0.839,0.778,0.708,0.666,0.686,0.712,0.771, & + 0.833/ +! max reflectivity 25-30 dbz + DATA refprofile_summer(:,2) / & + 0.836,0.874,0.898,0.915,0.927,0.938,0.945,0.951,0.960,0.970, & + 0.980,0.989,1.000,0.995,0.968,0.933,0.901,0.861,0.822,0.783, & + 0.745,0.717,0.683,0.661,0.614,0.564,0.538,0.543,0.578,0.633, & + 0.687/ +! max reflectivity 30-35 dbz + DATA refprofile_summer(:,3) / & + 0.870,0.885,0.914,0.931,0.943,0.954,0.967,0.975,0.982,0.989, & + 0.995,1.000,0.998,0.973,0.918,0.850,0.791,0.735,0.690,0.657, & + 0.625,0.596,0.569,0.544,0.510,0.479,0.461,0.460,0.477,0.522, & + 0.570/ +! max reflectivity 35-40 dbz + DATA refprofile_summer(:,4) / & + 0.871,0.895,0.924,0.948,0.961,0.971,0.978,0.983,0.988,0.992, & + 0.997,1.000,0.995,0.966,0.913,0.848,0.781,0.719,0.660,0.611, & + 0.576,0.542,0.523,0.513,0.481,0.448,0.416,0.402,0.417,0.448, & + 0.491/ +! max reflectivity 40-45 dbz + DATA refprofile_summer(:,5) / & + 0.875,0.895,0.914,0.936,0.942,0.951,0.964,0.979,0.990,0.998, & + 1.000,0.992,0.961,0.905,0.834,0.772,0.722,0.666,0.618,0.579, & + 0.545,0.518,0.509,0.483,0.419,0.398,0.392,0.403,0.423,0.480, & + 0.440/ +! max reflectivity 45-50 dbz + DATA refprofile_summer(:,6) / & + 0.926,0.920,0.948,0.975,0.988,0.989,0.995,0.997,1.000,1.000, & + 0.997,0.991,0.970,0.939,0.887,0.833,0.788,0.741,0.694,0.655, & + 0.611,0.571,0.551,0.537,0.507,0.470,0.432,0.410,0.420,0.405, & + 0.410/ + + INTEGER(i_kind) :: season ! 1= summer, 2=winter + + REAL(r_kind) :: heightGSI,upref,downref,wght + INTEGER(i_kind) :: ilvl + REAL(r_kind) :: lowest,highest,tempref(nsig), tempprofile(maxlvl) + REAL(r_kind) :: maxref + + INTEGER(i_kind) :: i,j, k2, k, mref + +! +! vertical reflectivity distribution +! + season=1 + DO k=1,maxlvl + newlvlAll(k)=newlvlAll(k)*1000.0_r_kind + ENDDO +! + DO j=2,nlat-1 + DO i=2,nlon-1 + ifmissing=0 + maxref=-9999.0_r_kind +!mhu krad_bot= int( max(krad_bot_in,pblh(i,j)) + 0.5_r_single ) ! consider PBL height +! Here, we only use PBL height to build missing corn and clean the reflectivity lower than +! PBL height. The krad_bot_in will be used when calculate the radar tten but not the hydrometer retrieval. +! Nov 21, 2011. Ming Hu + krad_bot= int( pblh(i,j) + 0.5_r_single ) ! consider PBL height +! +! in our case, -99 is no echo +! + DO k2=int(nsig/2),krad_bot,-1 + if(ref_mos_3d(i,j,k2+1)>=20._r_kind .and. & + ref_mos_3d(i,j,k2) < -100._r_kind ) ifmissing=k2 + if(ref_mos_3d(i,j,k2)>=maxref) maxref=ref_mos_3d(i,j,k2) + ENDDO + IF(ifmissing > 1 ) then + DO k2=krad_bot,1,-1 + if(ref_mos_3d(i,j,k2) >maxref) maxref=ref_mos_3d(i,j,k2) + ENDDO + if(maxref < 19.0_r_kind) then + write(6,*) 'build_missing_REFcone:',ifmissing,i,j,ifmissing + write(6,*) (ref_mos_3d(i,j,k2),k2=1,nsig) + endif + endif + IF(ifmissing > 1 .and. maxref > 19.0_r_kind ) then + mref = min(6,(int((maxref - 20.0_r_kind)/5.0_r_kind) + 1 )) + if(season== 2 ) then + DO k=1,maxlvl + tempprofile(k)=refprofile_winter(k,mref)*maxref + enddo + lowest=newlvlAll(2) + highest=7000.0_r_kind + else if(season== 1 ) then + DO k=1,maxlvl + tempprofile(k)=refprofile_summer(k,mref)*maxref + enddo + lowest=newlvlAll(3) + highest=12000.0_r_kind + endif +! make a ref profile + tempref=-9999.9_r_kind + DO k2=1,nsig + heightGSI=h_bk(i,j,k2) + if(heightGSI >= lowest .and. heightGSI < highest) then ! lower 12km ? + do k=1,maxlvl-1 + if( heightGSI >=newlvlAll(k) .and. & + heightGSI < newlvlAll(k+1) ) ilvl=k + enddo + upref=tempprofile(ilvl+1) + downref=tempprofile(ilvl) + wght=(heightGSI-newlvlAll(ilvl))/(newlvlAll(ilvl+1)-newlvlAll(ilvl)) + tempref(k2)=(1-wght)*downref + wght*upref + endif + ENDDO +! build missing volumes down to krad_bot level +! NOTE: no use of PBL base yet, as done in RUC analysis since summer 2009 + maxref=ref_mos_3d(i,j,ifmissing+1)-tempref(ifmissing+1) + if(abs(maxref) < 10.0_r_kind ) then + DO k2=ifmissing,krad_bot,-1 + ref_mos_3d(i,j,k2) = tempref(k2) + maxref + ENDDO + else + DO k2=ifmissing,krad_bot,-1 + ref_mos_3d(i,j,k2) = ref_mos_3d(i,j,ifmissing+1) + ENDDO + endif +! + ENDIF +! clean echo less than PBL height and level 7 + DO k2=1,krad_bot + ref_mos_3d(i,j,k2) = -99999.0_r_kind + ENDDO + ENDDO + ENDDO + +END SUBROUTINE build_missing_REFcone diff --git a/src/GSD/gsdcloud/cloudCover_NESDIS.f90 b/src/GSD/gsdcloud/cloudCover_NESDIS.f90 new file mode 100644 index 0000000000..9ca6eb6760 --- /dev/null +++ b/src/GSD/gsdcloud/cloudCover_NESDIS.f90 @@ -0,0 +1,713 @@ +SUBROUTINE cloudCover_NESDIS(mype,regional_time,nlat,nlon,nsig,& + xlong,xlat,t_bk,p_bk,h_bk,xland, & + soil_tbk,sat_ctp,sat_tem,w_frac,& + l_cld_bld,cld_bld_hgt,build_cloud_frac_p,clear_cloud_frac_p,nlev_cld, & + cld_cover_3d,cld_type_3d,wthr_type,Osfc_station_map) +! +! +!$$$ subprogram documentation block +! . . . . +! subprogram: cloudCover_NESDIS cloud cover analysis using NESDIS cloud products +! +! PRGMMR: Ming Hu ORG: GSD/AMB DATE: 2006-11-10 +! +! ABSTRACT: +! This subroutine determines cloud_cover (fractional) field using NESDIS cloud products +! Based on RUC assimilation code - (Benjamin, Weygandt, Kim, Brown) +! +! PROGRAM HISTORY LOG: +! 2009-01-20 Hu Add NCO document block +! +! +! input argument list: +! mype - processor ID +! regional_time - analysis time +! nlon - no. of lons on subdomain (buffer points on ends) +! nlat - no. of lats on subdomain (buffer points on ends) +! nsig - no. of levels +! xlong - 2D longitude in each grid +! xlat - 2D latitude in each grid +! +! t_bk - 3D background potential temperature (K) +! p_bk - 3D background pressure (hPa) +! h_bk - 3D background height +! xland - surface type (water, land) +! soil_tbk - background soil temperature +! sat_ctp - GOES cloud top pressure in analysis grid +! sat_tem - GOES cloud top temperature in analysis grid +! w_frac - GOES cloud coverage in analysis grid +! l_cld_bld - logical for turning on GOES cloud building +! cld_bld_hgt - Height below which cloud building is done +! build_cloud_frac_p - Threshold above which we build clouds +! clear_cloud_frac_p - Threshold below which we clear clouds +! +! output argument list: +! nlev_cld - cloud status +! cld_cover_3d- 3D cloud cover (fractional cloud) +! cld_type_3d - 3D cloud type +! wthr_type - 3D weather type +! +! USAGE: +! INPUT FILES: +! +! OUTPUT FILES: +! +! REMARKS: +! +! ATTRIBUTES: +! LANGUAGE: FORTRAN 90 +! MACHINE: Linux cluster (WJET) +! +!$$$ +! +!_____________________________________________________________________ +! + + use constants, only: rd_over_cp, h1000 + use constants, only: deg2rad, rad2deg, pi + use gsd_kinds, only: r_single,i_kind,r_kind + + implicit none + + integer(i_kind),intent(in) :: mype + integer(i_kind),intent(in) :: regional_time(6) + integer(i_kind),intent(in) :: nlat,nlon,nsig +! +! background +! + real(r_single),intent(in) :: xlong(nlon,nlat) ! longitude + real(r_single),intent(in) :: xlat(nlon,nlat) ! latitude + real(r_single),intent(in) :: t_bk(nlon,nlat,nsig) ! potentional temperature + real(r_single),intent(inout) :: p_bk(nlon,nlat,nsig) ! pressure + real(r_single),intent(in) :: h_bk(nlon,nlat,nsig) ! height + real(r_single),intent(in) :: xland(nlon,nlat) ! surface + real(r_single),intent(in) :: soil_tbk(nlon,nlat) ! soil tmperature +! real(r_single),intent(in) :: q_bk(nlon,nlat,nsig) ! moisture, water vapor mixing ratio (kg/kg) +! +! Observation +! + real(r_single),intent(inout) :: sat_ctp(nlon,nlat) + real(r_single),intent(inout) :: sat_tem(nlon,nlat) + real(r_single),intent(inout) :: w_frac(nlon,nlat) + integer(i_kind),intent(out) :: nlev_cld(nlon,nlat) + integer(i_kind),intent(in) :: Osfc_station_map(nlon,nlat) +! +! Turn on cloud building and height limit + logical, intent(in) :: l_cld_bld + real(r_kind), intent(in) :: cld_bld_hgt + real(r_kind), intent(in) :: build_cloud_frac_p + real(r_kind), intent(in) :: clear_cloud_frac_p +! +! Variables for cloud analysis +! + real (r_single),intent(inout) :: cld_cover_3d(nlon,nlat,nsig) + integer(i_kind),intent(inout) :: cld_type_3d(nlon,nlat,nsig) + integer(i_kind),intent(inout) :: wthr_type(nlon,nlat) +! +!------------------------------------------------------------------------- +! --- Key parameters +! Min_cloud_lev_p = 3 Lowest model level to check for cloud +! Sat_cloud_pthick_p= 50. Depth (mb) of new sat-sensed cloud layer +! Cloud_up_p = 10 Pressure thickness for +! Upward extrapolation of cloud +! (if model level is within cloud_up_p +! mb of sat cloud level) +! min_cloud_p_p = 960. Max pressure at which NESDIS cloud +! info is considered reliable +! (i.e., not reliable at low levels) + +! zen_limit = 0.20 Solar zenith angle - lower limit +! at which sun is considered +! high enough to trust the +! GOES cloud data + + integer(i_kind) :: min_cloud_lev_p + real(r_kind) :: sat_cloud_pthick_p + real(r_kind) :: cloud_up_p + real(r_kind) :: min_cloud_p_p + real(r_kind) :: co2_preslim_p + real(r_kind) :: zen_limit + real(r_kind) :: dt_remap_pcld_limit_p + +! --- Key parameters + data Min_cloud_lev_p / 1_i_kind / ! w/ sfc cld assim +! data Min_cloud_lev_p / 3_i_kind / ! w/ sfc cld assim + data Sat_cloud_pthick_p / 30._r_kind/ +! data Sat_cloud_pthick_p / 50._r_kind/ + data cloud_up_p / 0._r_kind / + data min_cloud_p_p / 1080._r_kind/ ! w/ sfc cld assim + data co2_preslim_p / 620._r_kind/ +! -- change to 82 deg per Patrick Minnis - 4 Nov 09 + data zen_limit / 0.14_r_kind/ +! data zen_limit / 0.20_r_kind / + data dt_remap_pcld_limit_p / 3.5_r_kind / +!----------------------------------------------------------- +! +! temp. +! + INTEGER(i_kind) :: null_p + REAL(r_kind) :: spval_p + PARAMETER ( null_p = -1 ) + PARAMETER ( spval_p = 99999.0 ) + + INTEGER(i_kind) :: i,j,k,k1,i1,j1,jp1,jm1,ip1,im1 + INTEGER(i_kind) :: gmt,nday,iyear,imonth,iday + REAL(r_kind) :: declin + real(r_kind) :: hrang,xxlat + real(r_single) :: csza(nlon,nlat) + + INTEGER(i_kind) :: ndof_tot, npts_clear, npts_build, npts_bel650 + INTEGER(i_kind) :: npts_warm_cld_flag, npts_tskin_flag, npts_stab_flag, npts_ptly_cloudy + real (r_single) :: tbk_k(nlon,nlat,nsig) + + INTEGER(i_kind) :: npts_ctp_change, npts_ctp_delete, npts_ctp_nobuddy + INTEGER(i_kind) :: npts_clr_nobuddy,npts_ctp_marine_remap + real (r_single) :: dctp, dctpabs + + real(r_single) :: tsmin + + INTEGER(i_kind) :: kisotherm, ibuddy, ktempmin + real(r_kind) :: tempmin,dth2dp2, stab, stab_threshold + + real(r_kind) :: firstcloud, pdiff,pdiffabove + + INTEGER(i_kind) :: k_closest, cld_warm_strat(nlon,nlat) + REAL(r_kind) :: tdiff + +! +!==================================================================== +! Begin +! +! calculation solar declination +! + iyear=regional_time(1) + imonth=regional_time(2) + iday=regional_time(3) + call getdays(nday,iyear,imonth,iday) + declin=deg2rad*23.45_r_kind*sin(2.0_r_kind*pi*(284+nday)/365.0_r_kind) + + cld_warm_strat=-1 +! +! from mb to Pa +! + do k = 1,nsig + do j = 1,nlat + do i = 1,nlon +! qw=q_bk(i,j,k)/(1. + q_bk(i,j,k)) ! convert to specific humidity + tbk_k(i,j,k)=t_bk(i,j,k)*(p_bk(i,j,k)/h1000)**rd_over_cp ! convert to temperature(K) + p_bk(i,j,k) = p_bk(i,j,k)*100._r_kind + end do + end do + end do + + if( p_bk(nlon/2,nlat/2,2) < 5000.0_r_kind ) then + write(6,*) 'cloudCover_NESDIS: pressure unit check failed', p_bk(nlon/2,nlat/2,2) + call stop2(114) + endif + if( tbk_k(nlon/2,nlat/2,nsig-2) > 300._r_kind) then + write(6,*) 'cloudCover_NESDIS: temperature unit check failed', & + tbk_k(nlon/2,nlat/2,nsig-2) + call stop2(114) + endif + +! +! csza = fraction of solar constant (cos of zenith angle) + gmt = regional_time(4) ! UTC + do j=2,nlat-1 + do i=2,nlon-1 + hrang= (15._r_kind*gmt + xlong(i,j) - 180._r_kind )*deg2rad + xxlat=xlat(i,j)*deg2rad + csza(i,j)=sin(xxlat)*sin(declin) & + +cos(xxlat)*cos(declin)*cos(hrang) + end do + end do + +! +! start checking the data +! + ndof_tot = 0 !counting total number of grids of sat info + npts_clear = 0 + npts_build = 0 + npts_bel650 = 0 + npts_tskin_flag = 0 + npts_stab_flag = 0 + npts_ptly_cloudy = 0 + + do j=2,nlat-1 + do i=2,nlon-1 + jp1 = min(j+1,nlat) + jm1 = max(j-1,1 ) + ip1 = min(i+1,nlon) + im1 = max(i-1,1 ) + tsmin = soil_tbk(i,j) +! --- Determine min skin temp in 3x3 around grid point. +! This is to detect nearby presence of coastline. + do j1 = jm1,jp1 + do i1 = im1,ip1 + tsmin = min(tsmin,soil_tbk(i1,j1) ) + end do + end do + + if ( w_frac(i,j) > -1._r_kind & + .and. (sat_tem(i,j)-soil_tbk(i,j)) > 4._r_kind & + .and. soil_tbk(i,j) < 263._r_kind & + .and. sat_ctp(i,j) > co2_preslim_p & + .and. sat_ctp(i,j) < 1010._r_kind & + .and. abs(xland(i,j))>0.0001_r_single & + .and. p_bk(i,j,1)/100. >=850._r_kind ) then +! w_frac(i,j) = -99999._r_kind +! sat_tem(i,j) = 99999._r_kind +! sat_ctp(i,j) = 0._r_kind +! nlev_cld(i,j) = -999 + npts_warm_cld_flag = npts_warm_cld_flag + 1 + cld_warm_strat(i,j)=5 + end if +! PH changed condition to match RUC: Tcld-Tskin(bkg) < 4, > -2 + if ( w_frac(i,j) > -1._r_kind & + .and. (sat_tem(i,j)-tsmin) > -2._r_kind & + .and. (sat_tem(i,j)-tsmin) <= 4._r_kind & + .and. sat_ctp(i,j) > co2_preslim_p & + .and. sat_ctp(i,j) < 1010._r_kind & + .and. abs(xland(i,j)) > 0.0001_r_single & + .and. p_bk(i,j,1)/100._r_kind>= 950._r_kind ) then + w_frac(i,j) = -99999._r_kind + sat_tem(i,j) = 99999._r_kind + sat_ctp(i,j) = 0._r_kind + nlev_cld(i,j)= -999 + npts_tskin_flag = npts_tskin_flag + 1 + cld_warm_strat(i,j)=4 + end if + if (w_frac(i,j)<=clear_cloud_frac_p .and. & + w_frac(i,j)>-1._r_kind) then + sat_ctp(i,j) = 1013.0_r_kind + npts_clear = npts_clear + 1 + cld_warm_strat(i,j)=0 + end if + if (w_frac(i,j) > clear_cloud_frac_p.and. & + w_frac(i,j) < build_cloud_frac_p) then +! w_frac(i,j) = -99999._r_kind + sat_tem(i,j)= 99999._r_kind +! mhu: this can cause problem: a miss line between cloud and clean, set it to clean +! PH: for CLAVR data, just set sat_ctp = 0. + sat_ctp(i,j) = 0._r_kind + nlev_cld(i,j)= -999 + npts_ptly_cloudy = npts_ptly_cloudy + 1 + cld_warm_strat(i,j)=1 + end if + if (w_frac(i,j) >= build_cloud_frac_p.and. & + sat_ctp(i,j) < 1050) then + npts_build = npts_build + 1 + cld_warm_strat(i,j)=2 + end if + if (sat_ctp(i,j)>co2_preslim_p .and. sat_ctp(i,j)<1010._r_kind) & + npts_bel650 = npts_bel650 + 1 + +! -- nlev_cld = 1 if cloud info is present +! -- nlev_cld = 0 if no cloud info is at this grid point + + if(nlev_cld(i,j) >= 1) ndof_tot = ndof_tot + 1 + end do ! i + end do ! j +! + if(mype==0) then + write(6,*) 'cloudCover_NESDIS: TOTAL NUMBER OF GRID pts w/ GOES CLOUD data =',ndof_tot + write(6,*) 'cloudCover_NESDIS: CLEAR NUMBER OF GRID pts w/ GOES CLOUD data =',npts_clear + write(6,*) 'cloudCover_NESDIS: BUILD NUMBER OF GRID pts w/ GOES CLOUD data =',npts_build + write(6,*) 'cloudCover_NESDIS: PTCLDY NUMBER OF GRID pts w/ GOES CLOUD data =',npts_ptly_cloudy + write(6,*) 'cloudCover_NESDIS: > 650mb - no OF GRID pts w/ GOES CLOUD data =',npts_bel650 + write(6,*) 'cloudCover_NESDIS: Flag CTP - skin temp too close to TB, no=',npts_tskin_flag + write(6,*) 'cloudCover_NESDIS: Clear -> cloud frac < clear frac' + write(6,*) 'cloudCover_NESDIS: Build -> cloud frac > build frac' + endif + +! +!! +! + npts_ctp_change = 0 + npts_ctp_delete = 0 + npts_ctp_nobuddy = 0 + npts_clr_nobuddy = 0 + npts_ctp_marine_remap = 0 + dctp = 0. + dctpabs = 0. + +! - stability threshold for building cloud - 3K / 100 mb (10000 Pa) + + stab_threshold = 3._r_kind/10000._r_kind + do j=2,nlat-1 + do i=2,nlon-1 + +! -- GOES indicates clouds in the lower troposphere + if (sat_ctp(i,j) < 1010._r_kind .and. sat_ctp(i,j) > co2_preslim_p) then + + tdiff = 999. + k_closest = -1 + do k=3,nsig-1 +! Attempt remapping if within 75 hPa (arbitrary) + if ((sat_ctp(i,j)-p_bk(i,j,k)/100._r_kind)< 75._r_kind) then + if (abs(sat_tem(i,j)-tbk_k(i,j,k)) < tdiff) then + k_closest = k + tdiff = abs(sat_tem(i,j)-tbk_k(i,j,k)) + end if + end if + end do ! k loop + + if (k_closest <= 0 .and. abs(xland(i,j)) > 0.0001_r_single) then + npts_ctp_delete = npts_ctp_delete + 1 + write (6,*) i,j,sat_tem(i,j),tdiff,k_closest,xland(i,j) + go to 111 + end if + + k = k_closest + + if( abs(xland(i,j)) >0.0001_r_single ) then +! PH: dt_limit was hardwired to 1.5K, changed it to 3.5K to match RUC + if ((tdiff < dt_remap_pcld_limit_p) .or. & + (cld_warm_strat(i,j) == 5 .and. tdiff < 4._r_kind )) then + dctpabs = dctpabs + abs(sat_ctp(i,j)-p_bk(i,j,k)/100._r_kind) + dctp = dctp+ (sat_ctp(i,j)-p_bk(i,j,k)/100._r_kind) + k1 = k + +1115 continue + +! --- This stability check only for reassigining CTP using RUC bkg profile. +! There is a later general check also. + stab = (t_bk(i,j,k1+1)-t_bk(i,j,k1)) & + /(p_bk(i,j,k1)-p_bk(i,j,k1+1)) + if (stab < stab_threshold) then + k1 = k1 + 1 + if ((p_bk(i,j,k)-p_bk(i,j,k1)) > 5000._r_kind) then + w_frac(i,j) = -99999._r_kind + sat_tem(i,j) = 99999._r_kind + sat_ctp(i,j) = 99999._r_kind + nlev_cld(i,j) = -999 + npts_stab_flag= npts_stab_flag + 1 + go to 111 + end if + go to 1115 + end if + + sat_ctp(i,j) = p_bk(i,j,k)/100._r_kind + npts_ctp_change = npts_ctp_change + 1 + go to 111 + else + npts_ctp_delete = npts_ctp_delete + 1 +! write (6,*) i,j,sat_tem(i,j),tdiff + go to 111 + end if + + else ! xland==0: over water + +! --- Remap marine cloud to min temp level below 880 mb +! if no matching RUC temp already found + + if (sat_ctp(i,j)>880._r_kind)then + tempmin = -500._r_kind + +! --- Look thru lowest 15 levels for lowest temp for +! level to put marine cloud at. +! --- Start at level 3 + kisotherm = 20 + ktempmin = 20 + do k=min_cloud_lev_p+2,15 + if (p_bk(i,j,k)/100._r_kind .lt. 880._r_kind) go to 1101 + dth2dp2 = t_bk(i,j,k+1)+t_bk(i,j,k-1)-2._r_kind*t_bk(i,j,k) + if (kisotherm==0 .and. & + tbk_k(i,j,k) < tbk_k(i,j,k+1)) kisotherm = k + if (dth2dp2>tempmin) then + ktempmin = k + tempmin = max(dth2dp2,tempmin) + end if + end do +1101 continue + ktempmin = min(ktempmin,kisotherm) + sat_ctp(i,j) = p_bk(i,j,ktempmin)/100._r_kind + npts_ctp_marine_remap = npts_ctp_marine_remap + 1 + end if ! sat_ctp(i,j)>880._r_kind + endif ! xland == 0 + end if +111 continue + enddo ! i + enddo ! j + + if(mype==0) then + write(6,*) 'cloudCover_NESDIS: Flag CTP - unstable w/i 50mb of CTP, no=', npts_stab_flag + write(6,*) 'cloudCover_NESDIS: Flag CTP - can''t remap CTP, no=', npts_ctp_delete + write(6,*) 'cloudCover_NESDIS: Flag CTP -remap marine cloud, no=', npts_ctp_marine_remap + endif + + if (npts_ctp_change > 0) then + if(mype==0) write (6,1121) npts_ctp_change, dctp/float(npts_ctp_change), & + dctpabs/float(npts_ctp_change) +1121 format (/'No. of pts w/ cloud-top pres change = ',i6 & + /'Mean cloud-top pres change (old-new)= ',f8.1 & + /'Mean abs cloud-top pres change = ',f8.1/) + end if +! +! --- Make sure that any cloud point has another cloud point nearby. +! Otherwise, get rid of it. + do j=2,nlat-1 + do i=2,nlon-1 + if (sat_ctp(i,j)< 1010._r_kind .and. sat_ctp(i,j)>50._r_kind) then + ibuddy = 0 + do j1=j-1,j+1 + do i1=i-1,i+1 + if (sat_ctp(i1,j1)<1010._r_kind .and. sat_ctp(i1,j1)>50._r_kind) ibuddy = 1 + end do + end do + if (ibuddy==0) then + w_frac(i,j) = -99999._r_kind + sat_tem(i,j) = 99999._r_kind + sat_ctp(i,j) = 99999._r_kind + nlev_cld(i,j) = -999 + npts_ctp_nobuddy = npts_ctp_nobuddy + 1 + end if + end if + if (sat_ctp(i,j)>1010._r_kind .and. sat_ctp(i,j) <1100._r_kind) then + ibuddy = 0 + do j1=j-1,j+1 + do i1=i-1,i+1 + if (sat_ctp(i1,j1) > 1010._r_kind .and. sat_ctp(i1,j1) <1100._r_kind) ibuddy = 1 + end do + end do + if (ibuddy == 0) then + w_frac(i,j) = -99999._r_kind + sat_tem(i,j) = 99999._r_kind + sat_ctp(i,j) = 99999._r_kind + nlev_cld(i,j) = -999 + npts_clr_nobuddy = npts_clr_nobuddy + 1 + end if + end if + enddo + enddo + + if(mype==0) then + write(6,*) 'cloudCover_NESDIS: Flag CTP - no contiguous points also w/ cloud, no=', & + npts_ctp_nobuddy + + write(6,*) 'cloudCover_NESDIS: Flag CTP - no contiguous points also w/ clear, no=', & + npts_clr_nobuddy + endif + +! +! ***************************************************************** +! ***************************************************************** +! Start to adjust to GOES cloud top pressure +! ***************************************************************** +! ***************************************************************** + +! --- clear where GOES shows clear down to the surface +! or down to the GOES cloud top level + +! ============================================= +! - clear down to surface in fully clear column (according to GOES) +! ============================================= +! Only trust 'clear' indication under following conditions +! - over ocean +! - or over land only if p<620 mb overnight +! - or at any level in daytime (zenith angle +! greater than zen_limit threshold) +! +! mhu Nov. 26, 2014: Add a metar station map: Osfc_station_map +! when Osfc_station_map=1, it is a grid point around a metar station +! Then the satellite clean step will skip this metar station point. +! ============================================= + do j=2,nlat-1 + do i=2,nlon-1 + if (sat_ctp(i,j) >=1010.0_r_kind .and. sat_ctp(i,j) <1050._r_kind) then !clear + do k=1,nsig + if ((csza(i,j)=zen_limit) then + if(Osfc_station_map(i,j) == 1 .and. & + cld_cover_3d(i,j,k) > 0.0001_r_kind) then + else + cld_cover_3d(i,j,k) = 0.0_r_single + wthr_type(i,j) = 0 + endif +! +!mhu Nov 15 2014: don't let metar build cloud if +! - over land +! - during night +! - lower than co2_preslim_p +! - clear from satellite + else ! mhu Dec 2016: turn off this night low cloud check + if(Osfc_station_map(i,j) == 1 .and. & + cld_cover_3d(i,j,k) >0.0001_r_kind) then + else + cld_cover_3d(i,j,k) = 0.0_r_single + wthr_type(i,j) = 0 + endif +!mhu elseif( (csza(i,j)=co2_preslim_p) .and. & +!mhu abs(xland(i,j)-0._r_single) > 0.0001_r_single .and. & +!mhu cld_cover_3d(i,j,k) >0.0001_r_kind) then +!mhu if(Osfc_station_map(i,j) == 1) then +!mhu else +!mhu cld_cover_3d(i,j,k) = - 77777.0_r_single ! set to unknown +!mhu endif + end if + end do +!mhu: use 1060hps cloud top pressure to clean above the low cloud top + elseif (abs(sat_ctp(i,j)-1060.0_r_kind) < 1.0_r_kind) then !clear since the low cloud top + do k=1,nsig + cld_cover_3d(i,j,k) = 0.0_r_single + wthr_type(i,j) = 0 +!mhu mhu Dec 2016: turn off this night low cloud check +!mhu if (csza(i,j)=zen_limit) then +!mhu if( abs(cld_cover_3d(i,j,k)) > 2.0_r_single ) then +!mhu cld_cover_3d(i,j,k) = 0.0_r_single +!mhu wthr_type(i,j) = 0 +!mhu endif +!mhu end if + end do + end if + enddo + enddo +! ============================================= +! - clearing above cloud top +! ============================================= + + do j=2,nlat-1 + do i=2,nlon-1 + do k=1,nsig-1 + if (sat_ctp(i,j)<1010._r_kind .and. & + sat_ctp(i,j)>p_bk(i,j,k)/100._r_kind) then + if(sat_ctp(i,j) >= 800.0_r_kind .and. Osfc_station_map(i,j) == 1) then + cld_cover_3d(i,j,k+1) = & + max(0.0_r_single, cld_cover_3d(i,j,k+1)) + else + cld_cover_3d(i,j,k+1) = 0.0_r_single + endif + endif + +! - return to previous (but experimental) version - 12 Oct 04 +!mhu if (csza(i,j) < zen_limit & +!mhu .and. p_bk(i,j,k)/100._r_kind=zen_limit) then +! --- since we set GOES to nearest RUC level, only clear at least +! 1 RUC level above cloud top +!mhu if (sat_ctp(i,j)<1010._r_kind .and. & +!mhu sat_ctp(i,j)>p_bk(i,j,k)/100._r_kind) then +! +! mhu, some low cloud top press (> 800 hpa) over clean the cloud that observed by METAR +! so add these check to keep cloud base correct +! +!mhu if(sat_ctp(i,j) >= 800.0_r_kind ) then +!mhu cld_cover_3d(i,j,k+1) = & +!mhu max(0.0_r_single, cld_cover_3d(i,j,k+1)) +!mhu else +!mhu cld_cover_3d(i,j,k+1) = 0.0_r_single +!mhu endif +!mhu endif +!mhu end if + end do + enddo + enddo + +! print *, 'h_bk max: ', maxval(h_bk(:,:,1)), ' min: ', minval(h_bk(:,:,1)) + +! ============================================= +! - start building where GOES indicates so +! ============================================= + do j=2,nlat-1 + do i=2,nlon-1 + + if ((w_frac(i,j)>= build_cloud_frac_p) .and. & + (w_frac(i,j)< 99999._r_kind) )then !Dongsoo added + +! --- Cloud info below MIN_CLOUD_P not reliable + firstcloud = 0 +! - pdiff (diff between sat cloud top and model sfc pres) in mb + do k=nsig-1,min_cloud_lev_p,-1 + pdiff = (sat_ctp(i,j)-p_bk(i,j,k)/100._r_kind) +! --- set closest RUC level w/ cloud + if (pdiff<=0. .and. firstcloud==0) then + pdiffabove = sat_ctp(i,j)-p_bk(i,j,k+1)/100._r_kind + if (abs(pdiffabove) 800 hpa) over clean the cloud that observed by METAR +! so add these check to keep cloud base correct +! + if(sat_ctp(i,j) >= 800.0_r_kind ) then + cld_cover_3d(i,j,k+1) = max(0.0_r_single, cld_cover_3d(i,j,k+1)) + else + cld_cover_3d(i,j,k+1) = 0.0_r_single + endif + firstcloud = 1 + end if + end if + +! no cloud above cloud top + +! +! --- Add 50mb thick (at least 1 level) of cloud where GOES +! indicates cloud top + if (abs(xland(i,j)) > 0.0001_r_single) then + if (sat_ctp(i,j)< min_cloud_p_p .and. & + pdiff<=cloud_up_p ) then + if (firstcloud==0.or. firstcloud==1 & + .and.pdiff >= -1.*sat_cloud_pthick_p) then +! sgb - 2/7/2012 - remove this condition +! Allow cloud building below CO2_preslim and at night and over land +! if (p_bk(i,j,k)/100._r_kind= -1.*sat_cloud_pthick_p) then +! xland ==0 if (p_bk(i,j,k)/100..lt.co2_preslim_p) then + if (l_cld_bld .and. h_bk(i,j,k+1) < cld_bld_hgt) then + cld_cover_3d(i,j,k)=1.0_r_single + else + cld_cover_3d(i,j,k)=-99998.0_r_single + end if + firstcloud = 1 + end if + end if + end if + + end do + end if + enddo ! j + enddo + +! go from pa to mb + do k = 1,nsig + do j = 2,nlat-1 + do i = 2,nlon-1 + p_bk(i,j,k) = p_bk(i,j,k)/100._r_kind + end do + end do + end do +! +END SUBROUTINE cloudCover_NESDIS + diff --git a/src/GSD/gsdcloud/cloudCover_Surface.f90 b/src/GSD/gsdcloud/cloudCover_Surface.f90 new file mode 100644 index 0000000000..40554e9e4c --- /dev/null +++ b/src/GSD/gsdcloud/cloudCover_Surface.f90 @@ -0,0 +1,427 @@ +SUBROUTINE cloudCover_Surface(mype,nlat,nlon,nsig,r_radius,thunderRadius,& + cld_bld_hgt,t_bk,p_bk,q,h_bk,zh, & + mxst_p,NVARCLD_P,numsao,OI,OJ,OCLD,OWX,Oelvtn,Odist,& + cld_cover_3d,cld_type_3d,wthr_type,pcp_type_3d, & + watericemax, kwatericemax,vis2qc) +! +!$$$ subprogram documentation block +! . . . . +! subprogram: cloudCover_Surface cloud cover analysis using surface observation +! +! PRGMMR: Ming Hu ORG: GSD/AMB DATE: 2006-10-30 +! +! ABSTRACT: +! This subroutine determines 3D cloud fractional cover using surface observations +! Code based on RUC assimilation code (hybfront/hybcloud.f) +! +! PROGRAM HISTORY LOG: +! 2009-01-20 Hu Add NCO document block +! +! +! input argument list: +! mype - processor ID +! nlon - no. of lons on subdomain (buffer points on ends) +! nlat - no. of lats on subdomain (buffer points on ends) +! nsig - no. of levels +! r_radius - influence radius of the cloud observation +! thunderRadius - +! cld_bld_hgt - Height below which cloud building is done +! +! t_bk - 3D background potentional temperature (K) +! p_bk - 3D background pressure (hPa) +! q - 3D moisture (water vapor mixing ratio) +! h_bk - 3D background height (m) +! zh - terrain (m) +! +! mxst_p - maximum observation number +! NVARCLD_P - first dimension of OLCD +! numsao - observation number +! OI - observation x location +! OJ - observation y location +! OLCD - cloud amount, cloud height, visibility +! OWX - weather observation +! Oelvtn - observation elevation +! Odist - distance from the nearest station +! +! output argument list: +! cld_cover_3d- 3D cloud cover +! cld_type_3d - 3D cloud type +! wthr_type - 3D weather type +! pcp_type_3d - 3D weather precipitation type +! +! USAGE: +! INPUT FILES: +! +! OUTPUT FILES: +! +! +! REMARKS: +! +! ATTRIBUTES: +! LANGUAGE: FORTRAN 90 +! MACHINE: Linux cluster (WJET) +! +!$$$ +! +!_____________________________________________________________________ +! + + use gsd_kinds, only: r_single,i_kind,r_kind + + implicit none + + integer(i_kind),intent(in) :: mype + REAL(r_single), intent(in) :: r_radius + integer(i_kind),intent(in) :: nlat,nlon,nsig + real(r_single), intent(in) :: thunderRadius + real(r_kind), intent(in) :: cld_bld_hgt +! +! surface observation +! + INTEGER(i_kind),intent(in) :: mxst_p,NVARCLD_P + +! PARAMETER (LSTAID_P=9) + + INTEGER(i_kind),intent(in) :: numsao + real(r_single), intent(in) :: OI(mxst_p) ! x location + real(r_single), intent(in) :: OJ(mxst_p) ! y location + INTEGER(i_kind),intent(in) :: OCLD(NVARCLD_P,mxst_p) ! cloud amount, cloud height, + ! visibility + CHARACTER*10, intent(in) :: OWX(mxst_p) ! weather + real(r_single), intent(in) :: Oelvtn(mxst_p) ! elevation + real(r_single), intent(in) :: Odist(mxst_p) ! distance from the nearest station + +! +! background +! + real(r_single),intent(in) :: t_bk(nlon,nlat,nsig) ! temperature + real(r_single),intent(in) :: p_bk(nlon,nlat,nsig) ! pressure + real(r_single),intent(in) :: zh(nlon,nlat) ! terrain + real(r_single),intent(in) :: q(nlon,nlat,nsig) ! moisture, water vapor mixing ratio (kg/kg) + real(r_single),intent(in) :: h_bk(nlon,nlat,nsig) ! height +! + REAL(r_single),intent(in) :: watericemax(mxst_p) ! max of background total liquid water in station + INTEGER(i_kind),intent(in):: kwatericemax(nlon,nlat) ! lowest level of background total liquid water in grid +! +! Variables for cloud analysis +! + real (r_single),intent(inout) :: cld_cover_3d(nlon,nlat,nsig) + integer(i_kind),intent(inout) :: cld_type_3d(nlon,nlat,nsig) + integer(i_kind),intent(inout) :: wthr_type(nlon,nlat) + integer(i_kind),intent(inout) :: pcp_type_3d(nlon,nlat,nsig) + real (r_single),intent(inout) :: vis2qc(nlon,nlat) +! +! local +! + real (r_single) :: cloud_zthick_p + data cloud_zthick_p /300._r_kind/ +! + REAL (r_kind) :: spval_p + PARAMETER ( spval_p = 99999.0_r_kind ) + + INTEGER(i_kind) :: i,j,k + INTEGER(i_kind) :: i1,j1,ic + INTEGER(i_kind) :: nx_p, ny_p, nztn_p + INTEGER(i_kind) :: ista + INTEGER(i_kind) :: ich !, iob,job + + REAL(r_kind) :: min_dist !, dist + REAL(r_kind) :: zdiff + REAL(r_kind) :: zlev_clr,cloud_dz,cl_base_ista,betav +! +! +! + real(r_single):: tbk_k(nlon,nlat,nsig) + real(r_single):: cv_bk(nlon,nlat,nsig) + real(r_single):: z_lcl(nlon,nlat) + REAL(r_kind) :: cf_model_base,t_model_base, ht_base + REAL(r_kind) :: t_dry_adiabat,t_inversion_strength + + LOGICAL :: l_cf,l_inversion + LOGICAL :: if_cloud_exist + + integer(i_kind) :: firstcloud,cl_base_broken_k + real(r_single) :: underlim + integer(i_kind) :: npts_near_clr + + +!==================================================================== +! Begin +! +! set constant names consistent with original RUC code +! + nx_p=nlon + ny_p=nlat + nztn_p=nsig + + vis2qc=-9999.0_r_kind + npts_near_clr=0 + zlev_clr = 3650. +! +! +!***************************************************************** +! analysis of surface/METAR cloud observations +! ***************************************************************** + + loopstation: DO ista=1,numsao + i1 = int(oi(ista)+0.0001_r_kind) + j1 = int(oj(ista)+0.0001_r_kind) + min_dist = Odist(ista) + +!mh - grid point has the closest cloud station + +! -- find out if any precip is present + do ich=1,1 + if ( owx(ista)(ich:ich+1)=='SH' ) wthr_type(i1,j1)=16 + if ( owx(ista)(ich:ich+1)=='TH' .and. & + min_dist < thunderRadius) wthr_type(i1,j1)=1 + if ( owx(ista)(ich:ich+1)=='RA' ) wthr_type(i1,j1)=11 + if ( owx(ista)(ich:ich+1)=='SN' ) wthr_type(i1,j1)=12 + if ( owx(ista)(ich:ich+1)=='PL' ) wthr_type(i1,j1)=13 + if ( owx(ista)(ich:ich+1)=='DZ' ) wthr_type(i1,j1)=14 + if ( owx(ista)(ich:ich+1)=='UP' ) wthr_type(i1,j1)=15 + if ( owx(ista)(ich:ich+1)=='BR' ) wthr_type(i1,j1)=21 + if ( owx(ista)(ich:ich+1)=='FG' ) wthr_type(i1,j1)=22 + enddo + +! Consider clear condition case +! ----------------------------- + if (ocld(1,ista)==0) then + + do ic=1,6 + if(float(abs(ocld(6+ic,ista))) < 55555) then + write(6,*) 'cloudCover_Surface: Observed cloud above the clear level !!!' + write(6,*) 'cloudCover_Surface: some thing is wrong in surface cloud observation !' + write(6,*) 'cloudCover_Surface: check the station no.', ista, 'at process ', mype + write(6,*) ic,OI(ista),OJ(ista) + write(6,*) (ocld(k,ista),k=1,12) + cycle loopstation + endif + enddo +! clean the whole column up to ceilometer height (12 kft) if ob is CLR +! h_bk is AGL, not ASL (per Ming Hu's notes below +! +! zlev_clr = Oelvtn(ista)+3650. +! Upcoming mods commented out below for this commit - 4/3/2010 +! PH: added in column cleaning up to ceilometer height if ob is CLR +! move this check out of this if block. Because it will be used later. +! zlev_clr = 3650. + + do k=1,nztn_p + if (h_bk(i1,j1,k) < zlev_clr) then + cld_cover_3d(i1,j1,k)=0.0_r_kind + pcp_type_3d(i1,j1,k)=0 + endif + end do + + wthr_type(i1,j1)=0 + +! -- Now consider non-clear obs +! -------------------------- + else + +! increase zthick by 1.5x factor for ceiling < 900 m (~3000 ft - MVFR) + cloud_dz = cloud_zthick_p + cl_base_broken_k = -9 +! ????? check with Stan O(h_p) if (Oelvtn(ista).lt.900.) cloud_dz = cloud_zthick_p * 2 + + do ic = 1,6 + if (ocld(ic,ista)>0 .and. ocld(ic,ista)<50) then +! if ( csza(i,j)>=0.10 .and. sat_ctp(i1,j1)>1010.0 & +! .and. sat_ctp(i1,j1)<1050.) go to 1850 +! +! New tweak - 11/07/2009 +! If there was cloud in background over station but if there +! was partial cloudiness within volume and this is one of the +! clear columns within the polygonal area for this METAR, +! then leave it that way and skip. +! if (watericemax(iob,job).gt.0. .and. +! 1 kwatericemax(iob,job).gt.0 .and. +! 1 kwatericemax(iob,job).le.12) then +! npts_cld_match = npts_cld_match + 1 +! dzbase = cl_base_ista - g3(iob,job,kwatericemax(iob,job),h_p) +! sum_dzbase = sum_dzbase + dzbase +! sum_dzbase_abs = sum_dzbase_abs + abs(dzbase) +! end if + +! mhu, Aug. 28, 2013: comment out patial cloudiness. It causes the degradation +! in 3000' ceiling 1-h forecast. +! if(watericemax(ista) > 0._r_single .and. kwatericemax(i1,j1)==-1) then +! !PH 2/28/2013: ensure cloud building at 4 neighboring +! !gridpoints (Odist < 1), regardless of background +! if(Odist(ista) >= 1.0_r_kind) then +! npts_near_clr = npts_near_clr + 1 +! cycle ! skip cloud build at point (i,j) because +! ! background is clear +! endif +! endif + + if(ocld(ic,ista) == 4) then + if(wthr_type(i1,j1) > 10 .and. wthr_type(i1,j1) < 20) cloud_dz = 1000._r_kind + ! precipitation + highest level + if(wthr_type(i1,j1) == 1) cloud_dz = 10000._r_kind ! thunderstorm + endif + +! --- calculate cloud ceiling level, not exactly, FEW SCT are also considered now +! iob = int(oi(ista)-idw+0.5) +! job = int(oj(ista)-ids+0.5) +! cl_base_ista = (float(ocld(6+ic,ista))+zh(iob,job)) +! cl_base_ista = (float(ocld(6+ic,ista))+Oelvtn(ista)) +! the h_bk is AGL. So observation cloud base should be AGL too, delete Oelvtn(ista) +! cover cloud base observation from AGL to ASL + cl_base_ista = float(ocld(6+ic,ista)) + Oelvtn(ista) - zh(i1,j1) + if(zh(i1,j1) < 1.0_r_kind .and. Oelvtn(ista) > 20.0_r_kind & + .and. float(ocld(6+ic,ista)) < 250.0_r_kind) then + cycle ! limit the use of METAR station over oceas for low cloud base + endif + + firstcloud = 0 + underlim = 10._r_kind ! + + do k=1,nztn_p + zdiff = cl_base_ista - h_bk(i1,j1,k) +! Must be within cloud_dz meters (300 or 1000 currently) +! ------------------------------------------------------------------- +! -- Bring in the clouds if model level is within 10m under cloud level. + if(k==1) underlim=(h_bk(i1,j1,k+1)-h_bk(i1,j1,k))*0.5_r_kind + if(k==2) underlim=10.0_r_kind ! 100 feet + if(k==3) underlim=20.0_r_kind ! 300 feet + if(k==4) underlim=15.0_r_kind ! 500 feet + if(k==5) underlim=33.0_r_kind ! 1000 feet + if (k>=6 .and. k <= 7) underlim = (h_bk(i1,j1,k+1)-h_bk(i1,j1,k))*0.6_r_kind + if(k==8) underlim=95.0_r_kind ! 3000 feet + if(k>=9 .and. k= 1.0 .and. (firstcloud==0 .or. abs(zdiff) 10 .and. wthr_type(i1,j1) < 20) then +! cld_type_3d(i1,j1,k)=5 + pcp_type_3d(i1,j1,k)=1 + endif + else + write(6,*) 'cloudCover_Surface: wrong cloud coverage observation!' + cycle loopstation + endif + endif + firstcloud = firstcloud + 1 + end if ! zdiff < cloud_dz + else +! ---- Clear up to cloud base of first cloud level + if (ic==1) cld_cover_3d(i1,j1,k)=0 + if (ocld(ic,ista) == 1) pcp_type_3d(i1,j1,k)=0 + if (ocld(ic,ista) == 3 .or. ocld(ic,ista) == 4) then + if( (wthr_type(i1,j1) > 10 .and. wthr_type(i1,j1) < 20) & + .or. wthr_type(i1,j1) == 1 ) then + pcp_type_3d(i1,j1,k)=1 + endif + endif + end if ! underlim + end do ! end K loop +! ----clean cloud above stratusphere + do k=1,nztn_p + if( h_bk(i1,j1,k) > 18000 ) cld_cover_3d(i1,j1,k)=0 + enddo +! + end if ! end if ocld > 0 + end do ! end IC loop +! +! clean up to broken (3) or if cloud cover less than 2, clean to cloud top +! + if(cl_base_broken_k > 0 .and. cl_base_broken_k < nztn_p) then + do k=1, cl_base_broken_k + if( cld_cover_3d(i1,j1,k) < -0.001_r_kind ) cld_cover_3d(i1,j1,k)=0 + enddo + else + if(ocld(1,ista) == 1 .or. ocld(1,ista) == 2 ) then + do k=1, nztn_p + if (h_bk(i1,j1,k) < zlev_clr) then + if( cld_cover_3d(i1,j1,k) < -0.001_r_kind ) cld_cover_3d(i1,j1,k)=0 + endif + enddo + endif + endif + + end if ! end if cloudy ob ocld(1,ista) > 0 + +! -- Use visibility for low-level cloud whether + if (wthr_type(i1,j1) < 30 .and. wthr_type(i1,j1) > 20 .and. & + ocld(13,ista) < 5000 .and. ocld(13,ista) > 1 .and. & + min_dist < 20.0_r_single) then + cld_type_3d(i1,j1,1) = 2 + cld_type_3d(i1,j1,2) = 2 + betav = 3.912_r_kind / (float(ocld(13,ista)) / 1000._r_kind) + vis2qc(i1,j1) = ( (betav/144.7_r_kind) ** 1.14_r_kind) / 1000._r_kind + endif ! cloud or clear + + ENDDO loopstation ! ista + + +! Determine if the layer is dry or it has inversion. +! (in either case, the cloud will be cleared out) +! + IF(.false.) THEN ! Set inversion strength flag + call BckgrndCC(nlon,nlat,nsig, & + t_bk,p_bk,q,h_bk,zh, & + cv_bk,tbk_k,z_lcl) ! out + + DO j = 2,nlat-1 + DO i = 2,nlon-1 + + if_cloud_exist=.false. + do k=nsig-1,2,-1 + if(cld_cover_3d(i,j,k) > 0.01_r_kind) then + cf_model_base = cv_bk(i,j,k) + t_model_base = tbk_k(i,j,k) + ht_base=h_bk(i,j,k) + if_cloud_exist=.true. + endif + enddo +! +! note, do we need to consider cloud base from background + if(if_cloud_exist) then + do k=2, nsig-1 + if(cld_cover_3d(i,j,k) > 0.01_r_kind) then + l_cf=.false. + l_inversion=.false. + t_dry_adiabat = tbk_k(i,j,2) -.0098_r_kind * (h_bk(i,j,k) - h_bk(i,j,2)) + t_inversion_strength = tbk_k(i,j,k) - t_dry_adiabat + + IF( (tbk_k(i,j,k) > t_model_base) .and. & + (tbk_k(i,j,k) > 283.15_r_kind) .and. & ! temp check + (t_inversion_strength > 4._r_kind) ) then ! delta theta chk + l_inversion = .true. ! Inversion exists + endif + IF( (cv_bk(i,j,k) < cf_model_base - 0.3_r_kind) .and. & + (h_bk(i,j,k) - ht_base >= 500._r_kind) ) THEN + l_cf = .true. ! Dry layer exists + ENDIF + if(l_inversion) then + cld_cover_3d(i,j,k) =0.0_r_kind + endif + endif ! in cloud + enddo ! k + endif ! if_cloud_exist = true + + ENDDO ! i + ENDDO ! j + + END IF ! .true. for dry-inversion check. + +END SUBROUTINE cloudCover_Surface + diff --git a/src/GSD/gsdcloud/cloudCover_radar.f90 b/src/GSD/gsdcloud/cloudCover_radar.f90 new file mode 100644 index 0000000000..f18b95ebb1 --- /dev/null +++ b/src/GSD/gsdcloud/cloudCover_radar.f90 @@ -0,0 +1,131 @@ +SUBROUTINE cloudCover_radar(mype,nlat,nlon,nsig,h_bk,grid_ref, & + cld_cover_3d,wthr_type) +! +!$$$ subprogram documentation block +! . . . . +! subprogram: cloudCover_radar cloud cover analysis using radar reflectivity +! +! PRGMMR: Ming Hu ORG: GSD/AMB DATE: 2006-11-10 +! +! ABSTRACT: +! This subroutine find cloud cover using radar reflectivity +! +! PROGRAM HISTORY LOG: +! 2009-01-20 Hu Add NCO document block +! +! +! input argument list: +! mype - processor ID +! nlon - no. of lons on subdomain (buffer points on ends) +! nlat - no. of lats on subdomain (buffer points on ends) +! nsig - no. of levels +! h_bk - 3D background height +! grid_ref - radar reflectivity in analysis grid +! +! output argument list: +! cld_cover_3d- 3D cloud cover +! wthr_type - 3D weather type +! +! USAGE: +! INPUT FILES: +! +! OUTPUT FILES: +! +! REMARKS: +! +! ATTRIBUTES: +! LANGUAGE: FORTRAN 90 +! MACHINE: Linux cluster (WJET) +! +!$$$ +! +!_____________________________________________________________________ +! + + use constants, only: rd_over_cp, h1000 + use constants, only: deg2rad, rad2deg, pi + use gsd_kinds, only: r_single,i_kind,r_kind + + implicit none + + integer(i_kind),intent(in) :: mype + integer(i_kind),intent(in) :: nlat,nlon,nsig +! +! background +! + real(r_single), intent(in) :: h_bk(nlon,nlat,nsig+1) ! height +! +! Observation +! + real(r_kind), intent(in) :: grid_ref(nlon,nlat,nsig) +! +! Variables for cloud analysis +! + real (r_single),intent(inout) :: cld_cover_3d(nlon,nlat,nsig) + integer(i_kind),intent(inout) :: wthr_type(nlon,nlat) +! + REAL(r_kind) :: ref_base ! "significant" radar echo at upper levels +! + REAL(r_kind) :: cloud_base +! +!----------------------------------------------------------- +! +! threshold +! + + REAL(r_kind) :: radar_cover + PARAMETER(radar_cover=1.02) + REAL(r_kind) :: thresh_cvr ! lower radar echo threshold for cloud filling + PARAMETER (thresh_cvr = 0.9) +! +! temp. +! + INTEGER(i_kind) :: i,j,k + REAL(r_kind) :: zs_1d(nsig) + +! +!==================================================================== +! Begin +! + ref_base = 10.0 +! +!----------------------------------------------------------------------- +! +! Essentially, this go downward to detect radar tops in time +! to search for a new cloud base +! +!----------------------------------------------------------------------- +! + + DO i = 2,nlon-1 + DO j = 2,nlat-1 + + DO k=1,nsig + zs_1d(k) = h_bk(i,j,k) + END DO + + cloud_base = 200000._r_kind +! + DO k = nsig-1,1,-1 + IF( (cld_cover_3d(i,j,k) < thresh_cvr) .and. & + (cld_cover_3d(i,j,k+1) >= thresh_cvr .and. & + cld_cover_3d(i,j,k+1) < 2.0_r_kind) ) THEN + cloud_base = 0.5_r_kind * (zs_1d(k) + zs_1d(k+1)) + END IF + END DO ! k + + + DO k = 2, nsig-1 + if(grid_ref(i,j,k) > ref_base ) then + if( zs_1d(k) > cloud_base .and. cld_cover_3d(i,j,k) < thresh_cvr ) then + cld_cover_3d(i,j,k)=radar_cover + endif + endif + ENDDO ! k + + ENDDO ! i + ENDDO ! j +! + +END SUBROUTINE cloudCover_radar + diff --git a/src/GSD/gsdcloud/cloudLWC.f90 b/src/GSD/gsdcloud/cloudLWC.f90 new file mode 100644 index 0000000000..5b5a7cfc82 --- /dev/null +++ b/src/GSD/gsdcloud/cloudLWC.f90 @@ -0,0 +1,419 @@ +SUBROUTINE cloudLWC_stratiform(mype,nlat,nlon,nsig,q_bk,t_bk,p_bk, & + cld_cover_3d,cld_type_3d,wthr_type,cloudlayers_i, & + cldwater_3d,cldice_3d) +! +! find cloud liquid water content +! +!$$$ subprogram documentation block +! . . . . +! subprogram: cloudLWC_stratiform find cloud liquid water content +! +! PRGMMR: Ming Hu ORG: GSD/AMB DATE: 2006-11-20 +! +! ABSTRACT: +! This subroutine calculate liquid water content for stratiform cloud +! +! PROGRAM HISTORY LOG: +! 2009-01-20 Hu Add NCO document block +! +! +! input argument list: +! nlon - no. of lons on subdomain (buffer points on ends) +! nlat - no. of lats on subdomain (buffer points on ends) +! nsig - no. of levels +! q_bk - 3D moisture +! t_bk - 3D background potential temperature (K) +! p_bk - 3D background pressure (hPa) +! cld_cover_3d- 3D cloud cover +! cld_type_3d - 3D cloud type +! wthr_type - 3D weather type +! cloudlayers_i - 3D cloud layer index +! +! output argument list: +! cldwater_3d - 3D cloud water mixing ratio (g/kg) +! cldice_3d - 3D cloud ice mixing ratio (g/kg) +! +! USAGE: +! INPUT FILES: +! +! OUTPUT FILES: +! +! REMARKS: +! +! ATTRIBUTES: +! LANGUAGE: FORTRAN 90 +! MACHINE: Linux cluster (WJET) +! +!$$$ +! +!_____________________________________________________________________ +! + + use constants, only: rd_over_cp, h1000 + use gsd_kinds, only: r_single,i_kind, r_kind + + implicit none + + integer(i_kind),intent(in):: mype + integer(i_kind),intent(in):: nlat,nlon,nsig +! +! background +! + real(r_single),intent(in) :: t_bk(nlon,nlat,nsig) ! potential temperature + real(r_single),intent(inout) :: q_bk(nlon,nlat,nsig) ! mixing ratio (kg/kg) + real(r_single),intent(in) :: p_bk(nlon,nlat,nsig) ! pressure +! +! +! Variables for cloud analysis +! + real (r_single),intent(inout) :: cld_cover_3d(nlon,nlat,nsig) + integer(i_kind),intent(in) :: cld_type_3d(nlon,nlat,nsig) + integer(i_kind),intent(in) :: wthr_type(nlon,nlat) +! +! cloud layers +! + integer(i_kind),intent(in) :: cloudlayers_i(nlon,nlat,21) ! 5 =different layers +! 1= the number of layers +! 2,4,... bottom +! 3,5,... top +! +! cloud water and cloud ice +! + real (r_single),intent(out) :: cldwater_3d(nlon,nlat,nsig) + real (r_single),intent(out) :: cldice_3d(nlon,nlat,nsig) + real (r_single) :: cloudtmp_3d(nlon,nlat,nsig) +!----------------------------------------------------------- +! +! temp. +! + INTEGER(i_kind) :: i,j,k,ilvl,nlvl + INTEGER(i_kind) :: kb,kt + real(r_single) :: p_pa_1d(nsig), thv(nsig) + real(r_single) :: cloudqvis(nlon,nlat,nsig) + real(r_single) :: rh(nlon,nlat,nsig) + +! --- Key parameters +! Rh_clear_p = 0.80 RH to use when clearing cloud +! Cloud_q_qvis_rat_p= 0.10 Ratio of cloud water to water/ice + + real(r_single) Cloud_q_qvis_rat_p, cloud_q_qvis_ratio + real(r_single) auto_conver + real(r_single) rh_clear_p + data Cloud_q_qvis_rat_p/ 0.05_r_single/ + data auto_conver /0.0002_r_single/ + data rh_clear_p /0.8_r_single/ + + real(r_kind) :: es0_p + parameter (es0_p=6.1121_r_kind) ! saturation vapor pressure (mb) + real(r_kind) SVP1,SVP2,SVP3 + data SVP1,SVP2,SVP3/es0_p,17.67_r_kind,29.65_r_kind/ + + real(r_kind) :: temp_qvis1, temp_qvis2 + data temp_qvis1, temp_qvis2 /268.15_r_kind, 263.15_r_kind/ + + REAL(r_kind) stab, stab_threshold + INTEGER(i_kind) :: kp3,km3 + + REAL(r_kind) :: q, Temp, tv, evs, qvs1, eis, qvi1, watwgt, qavail +! +!==================================================================== +! Begin +! + cldwater_3d=-99999.9_r_kind + cldice_3d=-99999.9_r_kind + cloudtmp_3d=-99999.9_r_kind +!----------------------------------------------------------------------- +! +! Find Cloud Layers and Computing Output Field(s) +! The procedure works column by column. +! +!----------------------------------------------------------------------- +! + rh=0.0 + DO j = 2,nlat-1 + DO i = 2,nlon-1 +! + DO k = 2,nsig-1 + p_pa_1d(k) = p_bk(i,j,k)*100.0_r_single + q = q_bk(i,j,k)/(1._r_single+q_bk(i,j,k)) ! Q = water vapor specific humidity + ! q_bk = water vapor mixing ratio + tv = t_bk(i,j,k)*(p_bk(i,j,k)/h1000)**rd_over_cp +! now, tmperature from GSI s potential temperature + Temp = tv ! temperature +! evs, eis in mb + evs = svp1*exp(SVP2*(Temp-273.15_r_kind)/(Temp-SVP3)) + qvs1 = 0.62198_r_kind*evs*100._r_kind/(p_pa_1d(k)-100._r_kind*evs) ! qvs1 is mixing ratio kg/kg, so no need next line +! qvs1 = qvs1/(1.0-qvs1) + eis = svp1 *exp(22.514_r_kind - 6.15e3_r_kind/Temp) + qvi1 = 0.62198_r_kind*eis*100._r_kind/(p_pa_1d(k)-100._r_kind*eis) ! qvi1 is mixing ratio kg/kg, so no need next line +! qvi1 = qvi1/(1.0-qvi1) +! watwgt = max(0.,min(1.,(Temp-233.15)/(263.15-233.15))) +! ph - 2/7/2012 - use ice mixing ratio only for temp < 263.15 + watwgt = max(0._r_kind,min(1._r_kind,(Temp-temp_qvis2)/& + (temp_qvis1-temp_qvis2))) + cloudtmp_3d(i,j,k)= Temp + cloudqvis(i,j,k)= (watwgt*qvs1 + (1._r_kind-watwgt)*qvi1) +! qvis(i,j,k)= (watwgt*qvs1 + (1.-watwgt)*qvi1) + rh(i,j,k) = q_bk(i,j,k)/cloudqvis(i,j,k) + enddo + enddo ! i + enddo ! j + + stab_threshold = 3._r_kind/10000._r_kind + DO j = 2,nlat-1 + DO i = 2,nlon-1 + DO k = 1,nsig + p_pa_1d(k) = p_bk(i,j,k)*100.0_r_kind + thv(k) = t_bk(i,j,k)*(1.0_r_kind + 0.6078_r_kind*q_bk(i,j,k)) + ENDDO + nlvl=cloudlayers_i(i,j,1) + if(nlvl > 0 ) then + DO ilvl = 1, nlvl ! loop through cloud layers + kb=cloudlayers_i(i,j,2*ilvl) + kt=cloudlayers_i(i,j,2*ilvl+1) + DO k = kb,kt + +! -- change these to +/- 3 vertical levels + kp3 = min(nsig,k+5) + km3 = max(1 ,k) + stab = (thv(kp3)-thv(km3))/(p_pa_1d(km3)-p_pa_1d(kp3)) + +! -- stability check. Use 2K/100 mb above 600 mb and +! 3K/100mb below (nearer sfc) + if ((stab600._r_kind) & + .or. stab<0.66_r_kind*stab_threshold ) then +! write(*,'(a,3i4,f8.3)') 'skip building cloud in stable layer',i,j,k,stab*10000.0 + cld_cover_3d(i,j,k)=-99999.0 + elseif(rh(i,j,k) < 0.40 .and. ((cloudqvis(i,j,k)-q_bk(i,j,k)) > 0.003_r_kind)) then +! write(*,'(a,3i4,2f6.2)') 'skip building cloud in too-dry layer',i,j,k,& +! rh(i,j,k),(cloudqvis(i,j,k)-q_bk(i,j,k))*1000.0 + cld_cover_3d(i,j,k)=-99999.0_r_single + else +!dk * we need to avoid adding cloud if sat_ctp is lower than 650mb +! ph - 2/7/2012 - use a temperature-dependent cloud_q_qvis_ratio +! and with 0.1 smaller condensate mixing ratio building also for temp < 263.15 + Temp = cloudtmp_3d(i,j,k) +! watwgt = max(0._r_kind,min(1._r_kind,(Temp-temp_qvis2)/& +! (temp_qvis1-temp_qvis2))) +! sgb - 1/13/2017 - change to discrete change from building water cloud or ice +! cloud (at temp_qvis2) + if (temp >= temp_qvis2) then + watwgt = 1. + cloud_q_qvis_ratio = watwgt*cloud_q_qvis_rat_p + qavail = min(0.25_r_single*auto_conver,cloud_q_qvis_ratio*cloudqvis(i,j,k)) + else + watwgt = 0. + cloud_q_qvis_ratio = 0.1*cloud_q_qvis_rat_p + qavail = min(0.1_r_single*auto_conver,cloud_q_qvis_ratio*cloudqvis(i,j,k)) + endif +! qavail = min(0.5_r_single*auto_conver,cloud_q_qvis_ratio*cloudqvis(i,j,k)) +! change cloud water from 0.5 g/kg to 0.25 g/kg + +! ------------------------------------------------------------------- +! - set cloud water mixing ratio - no more than 0.1 g/kg, +! which is the current autoconversion mixing ratio set in exmoisg +! according to John Brown - 14 May 99 +! ------------------------------------------------------------------- + cldwater_3d(i,j,k) = watwgt*qavail*1000.0_r_kind ! g/kg +! - set ice mixing ratio + cldice_3d(i,j,k)= (1.-watwgt)*qavail*1000.0_r_kind ! g/kg +! end if + end if + enddo ! k + enddo ! ilvl + endif ! nlvl > 1 + enddo ! i + enddo ! j + +END SUBROUTINE cloudLWC_stratiform + +SUBROUTINE cloudLWC_Cumulus(nlat,nlon,nsig,h_bk,t_bk,p_bk, & + cld_cover_3d,cld_type_3d,wthr_type,cloudlayers_i, & + cldwater_3d,cldice_3d,cloudtmp_3d) +! +! find cloud liquid water content +! +!$$$ subprogram documentation block +! . . . . +! subprogram: cloudLWC_Cumulus find cloud liquid water content for cumulus cloud +! +! PRGMMR: Ming Hu ORG: GSD/AMB DATE: 2006-11-20 +! +! ABSTRACT: +! This subroutine calculates liquid water content for cumulus cloud +! +! PROGRAM HISTORY LOG: +! 2009-01-20 Hu Add NCO document block +! +! +! input argument list: +! nlon - no. of lons on subdomain (buffer points on ends) +! nlat - no. of lats on subdomain (buffer points on ends) +! nsig - no. of levels +! h_bk - 3D height +! t_bk - 3D background potentional temperature (K) +! p_bk - 3D background pressure (hPa) +! cld_cover_3d- 3D cloud cover +! cld_type_3d - 3D cloud type +! wthr_type - 3D weather type +! cloudlayers_i - 3D cloud layer index +! +! output argument list: +! cldwater_3d - 3D cloud water mixing ratio (g/kg) +! cldice_3d - 3D cloud ice mixing ratio (g/kg) +! cloudtmp_3d - 3D cloud temperature +! +! USAGE: +! INPUT FILES: +! +! OUTPUT FILES: +! +! REMARKS: +! +! ATTRIBUTES: +! LANGUAGE: FORTRAN 90 +! MACHINE: Linux cluster (WJET) +! +!$$$ +! +!_____________________________________________________________________ +! + + use constants, only: rd_over_cp, h1000 + use gsd_kinds, only: r_single,i_kind,r_kind + + implicit none + integer(i_kind),intent(in) :: nlat,nlon,nsig +! +! surface observation +! +! +! background +! + real(r_single),intent(in) :: t_bk(nlon,nlat,nsig) ! temperature + real(r_single),intent(in) :: h_bk(nlon,nlat,nsig) ! height + real(r_single),intent(in) :: p_bk(nlon,nlat,nsig) ! pressure +! +! +! Variables for cloud analysis +! + real (r_single),intent(in) :: cld_cover_3d(nlon,nlat,nsig) + integer(i_kind),intent(in) :: cld_type_3d(nlon,nlat,nsig) + integer(i_kind),intent(in) :: wthr_type(nlon,nlat) +! +! cloud layers +! + integer(i_kind),intent(in) :: cloudlayers_i(nlon,nlat,21) ! 5 =different layers +! 1= the number of layers +! 2,4,... bottom +! 3,5,... top +! +! cloud water and cloud ice +! + real (r_single),intent(out) :: cldwater_3d(nlon,nlat,nsig) + real (r_single),intent(out) :: cldice_3d(nlon,nlat,nsig) + real (r_single),intent(out) :: cloudtmp_3d(nlon,nlat,nsig) +!----------------------------------------------------------- +! +! temp. +! + INTEGER(i_kind) :: i,j,k,ilvl,nlvl + INTEGER(i_kind) :: kb,kt,k1 + real (r_single) :: zs_1d(nsig) + real (r_single) :: t_1d(nsig) + real (r_single) :: p_pa_1d(nsig) + real (r_single) :: p_mb_1d(nsig) + real (r_single) :: cld_base_m, cld_top_m + real (r_single) :: cld_base_qc_m, cld_top_qc_m + + real (r_single) :: slwc_1d(nsig) + real (r_single) :: cice_1d(nsig) + real (r_single) :: ctmp_1d(nsig) + + LOGICAL :: l_prt + INTEGER(i_kind) :: iflag_slwc +! +!==================================================================== +! Begin +! + l_prt =.false. + iflag_slwc = 11 + cldwater_3d=-99999.9_r_single + cldice_3d =-99999.9_r_single + cloudtmp_3d=-99999.9_r_single +!----------------------------------------------------------------------- +! +! Find Cloud Layers and Computing Output Field(s) +! The procedure works column by column. +! +!----------------------------------------------------------------------- +! + DO j = 2,nlat-1 + DO i = 2,nlon-1 +! + DO k = 1,nsig ! Initialize + t_1d(k) = t_bk(i,j,k)*(p_bk(i,j,k)/h1000)**rd_over_cp + zs_1d(k) = h_bk(i,j,k) + p_pa_1d(k) = p_bk(i,j,k)*100.0_r_single + p_mb_1d(k) = p_bk(i,j,k) + END DO +!----------------------------------------------------------------------- + nlvl=cloudlayers_i(i,j,1) + if(nlvl > 0 ) then + DO ilvl = 1, nlvl ! loop through cloud layers + + kb=cloudlayers_i(i,j,2*ilvl) + kt=cloudlayers_i(i,j,2*ilvl+1) + + cld_base_m = 0.5_r_single * (zs_1d(kb-1) + zs_1d(kb)) + cld_top_m = 0.5_r_single * (zs_1d(kt) + zs_1d(kt+1)) +! + IF(iflag_slwc /= 0) THEN + IF(iflag_slwc < 10) THEN ! simple adiabatc scheme + CALL get_slwc1d (nsig,cld_base_m,cld_top_m,kb,kt & + ,zs_1d,t_1d,p_pa_1d,iflag_slwc,slwc_1d) + + ELSE ! iflag_slwc > 10, new Smith-Feddes scheme + DO k1 = 1,nsig ! Initialize + slwc_1d(k1) = 0.0_r_single + cice_1d(k1) = 0.0_r_single + ctmp_1d(k1) = t_bk(i,j,k1) + END DO +! +!----------------------------------------------------------------------- +! +! QC the data going into SMF +! +!----------------------------------------------------------------------- +! + IF(cld_top_m > zs_1d(nsig-1) - 110._r_single) THEN + cld_top_qc_m = zs_1d(nsig-1) - 110._r_single + cld_base_qc_m = & + MIN(cld_base_m,cld_top_qc_m - 110._r_single) + ELSE ! normal case + cld_top_qc_m = cld_top_m + cld_base_qc_m = cld_base_m + END IF +! + CALL get_sfm_1d(nsig,cld_base_qc_m,cld_top_qc_m & + ,zs_1d,p_mb_1d,t_1d & + ,slwc_1d,cice_1d,ctmp_1d,l_prt) +! + END IF ! iflag_slwc < 10 + END IF ! iflag_slwc .ne. 0 +! + DO k1 = kb,kt ! Loop through the cloud layer + IF(iflag_slwc /= 0) THEN + IF(slwc_1d(k1) > 0._r_single) cldwater_3d(i,j,k1)=slwc_1d(k1) + IF(cice_1d(k1) > 0._r_single) cldice_3d(i,j,k1)=cice_1d(k1) + cloudtmp_3d(i,j,k1)=ctmp_1d(k1) + END IF ! iflag_slwc .ne. 0 + END DO ! k1 + + enddo ! ilvl + endif ! nlvl > 0 + + ENDDO ! i + ENDDO ! j + +END SUBROUTINE cloudLWC_Cumulus diff --git a/src/GSD/gsdcloud/cloudLayers.f90 b/src/GSD/gsdcloud/cloudLayers.f90 new file mode 100644 index 0000000000..b446752c26 --- /dev/null +++ b/src/GSD/gsdcloud/cloudLayers.f90 @@ -0,0 +1,167 @@ +SUBROUTINE cloudLayers(nlat,nlon,nsig,h_bk,zh,cld_cover_3d,cld_type_3d, & + cloudlayers_i) +! +! +!$$$ subprogram documentation block +! . . . . +! subprogram: cloudLayers find cloud layers +! +! PRGMMR: Ming Hu ORG: GSD/AMB DATE: 2006-11-17 +! +! ABSTRACT: +! This subroutine find cloud layer based on cloud cover +! +! PROGRAM HISTORY LOG: +! 2009-01-20 Hu Add NCO document block +! +! +! input argument list: +! nlon - no. of lons on subdomain (buffer points on ends) +! nlat - no. of lats on subdomain (buffer points on ends) +! nsig - no. of levels +! h_bk - 3D background height +! zh - terrain +! cld_cover_3d- 3D cloud cover +! cld_type_3d - 3D cloud type +! +! output argument list: +! cloudlayers_i - 3D cloud layer index +! +! USAGE: +! INPUT FILES: +! +! OUTPUT FILES: +! +! REMARKS: +! +! ATTRIBUTES: +! LANGUAGE: FORTRAN 90 +! MACHINE: Linux cluster (WJET) +! +!$$$ +! +!_____________________________________________________________________ +! + + use gsd_kinds, only: r_single,i_kind + + implicit none + + integer(i_kind),intent(in) :: nlat,nlon,nsig +! +! background +! + real(r_single), intent(in) :: zh(nlon,nlat) ! terrain + real(r_single), intent(in) :: h_bk(nlon,nlat,nsig) ! height +! +! Variables for cloud analysis +! + real (r_single),intent(in) :: cld_cover_3d(nlon,nlat,nsig) + integer(i_kind),intent(in) :: cld_type_3d(nlon,nlat,nsig) +! +! output +! + integer(i_kind),intent(out):: cloudlayers_i(nlon,nlat,21) ! 5 different layers +! 1= the number of layers +! 2,4,... bottom +! 3,5,... top +! +! threshold + real (r_single) :: thresh_cvr + parameter ( thresh_cvr = 0.1 ) +!----------------------------------------------------------- +! +! temp. +! + INTEGER :: i,j,k,nlvl + INTEGER :: k_top,k_base + real (r_single) :: zs_1d(nsig) + real (r_single) :: cv_1d(nsig) +! +!==================================================================== +! Begin +! + cloudlayers_i=-99999 +!----------------------------------------------------------------------- +! +! Find Cloud Layers and Computing Output Field(s) +! The procedure works column by column. +! +!----------------------------------------------------------------------- +! + + DO j = 2,nlat-1 + DO i = 2,nlon-1 +! Initialize + DO k = 1,nsig + zs_1d(k) = h_bk(i,j,k) + cv_1d(k) = cld_cover_3d(i,j,k) + END DO +! +!----------------------------------------------------------------------- +! +! Get Base and Top +! +!----------------------------------------------------------------------- +! + k=1 + nlvl=0 + DO WHILE (k <= nsig-1) + + IF((cv_1d(k+1) >= thresh_cvr .and. cv_1d(k)= thresh_cvr) ) THEN + k_base = k + 1 + + k = k + 1 + DO WHILE (cv_1d(k) >= thresh_cvr .and. k < nsig) + k_top = k +! +!----------------------------------------------------------------------- +! +! We have now defined a cloud base and top +! +!----------------------------------------------------------------------- +! + k=k+1 + enddo + k=k-1 +!----------------------------------------------------------------------- +! +! Make sure cloud base and top stay in the model domain +! +!----------------------------------------------------------------------- +! + nlvl=nlvl+2 + if(nlvl > 20 ) then + write(6,*) 'cloudLayers: Too many cloud layers in grid point:' + write(6,*) i,j + call stop2(114) + endif + cloudlayers_i(i,j,nlvl) = MIN(k_base,nsig-1) + cloudlayers_i(i,j,nlvl+1) = MIN(k_top,nsig-1) + endif +! + k=k+1 + ENDDO ! k +! + cloudlayers_i(i,j,1) = nlvl/2 + ENDDO + ENDDO +! +! +! + DO j = 2,nlat-1 + DO i = 2,nlon-1 + if(cloudlayers_i(i,j,1) > 0 ) then + do k=1,cloudlayers_i(i,j,1) + if(cloudlayers_i(i,j,k) < 0 .or. cloudlayers_i(i,j,k) > 55555) then + write(6,*) 'cloudLayers: ckeck', i,j,k, cloudlayers_i(i,j,k) + endif + enddo + endif + enddo + enddo +! + +END SUBROUTINE cloudLayers + diff --git a/src/GSD/gsdcloud/cloudType.f90 b/src/GSD/gsdcloud/cloudType.f90 new file mode 100644 index 0000000000..e3f4e3811d --- /dev/null +++ b/src/GSD/gsdcloud/cloudType.f90 @@ -0,0 +1,147 @@ +SUBROUTINE cloudType(nlat,nlon,nsig,h_bk,t_bk,p_bk,radar_3d, & + cld_cover_3d,cld_type_3d,wthr_type,cloudlayers_i) +! +! +!$$$ subprogram documentation block +! . . . . +! subprogram: cloudType decide cloud type +! +! PRGMMR: Ming Hu ORG: GSD/AMB DATE: 2006-11-20 +! +! ABSTRACT: +! This subroutine decide cloud type +! +! PROGRAM HISTORY LOG: +! 2009-01-20 Hu Add NCO document block +! +! input argument list: +! nlon - no. of lons on subdomain (buffer points on ends) +! nlat - no. of lats on subdomain (buffer points on ends) +! nsig - no. of levels +! h_bk - 3D background height +! t_bk - 3D background potential temperature (K) +! p_bk - 3D background pressure (hPa) +! radar_3d - 3D radar reflectivity in analysis grid (dBZ) +! +! cld_cover_3d- 3D cloud cover +! wthr_type - 3D weather type +! cloudlayers_i - 3D cloud layer index +! +! output argument list: +! cld_type_3d - 3D cloud type +! +! USAGE: +! INPUT FILES: +! +! OUTPUT FILES: +! +! REMARKS: +! +! ATTRIBUTES: +! LANGUAGE: FORTRAN 90 +! MACHINE: Linux cluster (WJET) +! +!$$$ +! +!_____________________________________________________________________ +! + + use constants, only: rd_over_cp, h1000, half + use gsd_kinds, only: r_single,i_kind,r_kind + + implicit none + integer(i_kind),INTENT(IN) :: nlat,nlon,nsig +! +! background +! + real(r_single),INTENT(IN) :: h_bk(nlon,nlat,nsig) ! height + real(r_single),INTENT(IN) :: t_bk(nlon,nlat,nsig) ! temperature + real(r_single),INTENT(IN) :: p_bk(nlon,nlat,nsig) ! pressure +! +! observation +! + real(r_kind),INTENT(IN) :: radar_3d(nlon,nlat,nsig) ! reflectivity +! +! Variables for cloud analysis +! + real (r_single), INTENT(IN) :: cld_cover_3d(nlon,nlat,nsig) + integer(i_kind), INTENT(IN) :: wthr_type(nlon,nlat) + integer(i_kind),INTENT(OUT) :: cld_type_3d(nlon,nlat,nsig) +! +! cloud layers +! + integer(i_kind), INTENT(IN) :: cloudlayers_i(nlon,nlat,21) ! 5 =different layers +! 1= the number of layers +! 2,4,... bottom +! 3,5,... top +! +!----------------------------------------------------------- +! +! temp. +! + INTEGER(i_kind) :: i,j,k,ilvl,nlvl + INTEGER(i_kind) :: itype + INTEGER(i_kind) :: kb,kt,k1 + real(r_single) :: cld_base_m, cld_top_m + + real (r_single) :: zs_1d(nsig) + real (r_single) :: dte_dz_1d(nsig) + real (r_single) :: t_1d(nsig) + real (r_single) :: p_mb_1d(nsig) +! + CHARACTER (LEN=2) :: c2_type +! +!==================================================================== +! Begin +! +!----------------------------------------------------------------------- +! +! Find Cloud Layers and Computing Output Field(s) +! The procedure works column by column. +! +!----------------------------------------------------------------------- +! + return + + DO j = 2,nlat-1 + DO i = 2,nlon-1 +! + DO k = 1,nsig ! Initialize + t_1d(k) = t_bk(i,j,k)*(p_bk(i,j,k)/h1000)**rd_over_cp !K + zs_1d(k) = h_bk(i,j,k) + p_mb_1d(k) = p_bk(i,j,k) + END DO +!----------------------------------------------------------------------- + nlvl=cloudlayers_i(i,j,1) + if(nlvl > 10 ) then + write(*,*) 'warning: too many cloud levels' + nlvl=10 + endif + if(nlvl > 0 ) then + DO ilvl = 1, nlvl ! loop through cloud layers + kb=cloudlayers_i(i,j,2*ilvl) + kt=cloudlayers_i(i,j,2*ilvl+1) + + CALL get_stability (nsig,t_1d,zs_1d,p_mb_1d & + ,kb,kt,dte_dz_1d) + + cld_base_m = half * (zs_1d(kb-1) + zs_1d(kb)) + cld_top_m = half * (zs_1d(kt) + zs_1d(kt+1)) + DO k1 = kb,kt + CALL get_cloudtype(t_1d(k1),dte_dz_1d(k1) & + ,cld_base_m,cld_top_m,itype,c2_type) +! + IF(radar_3d(i,j,k1) > 45._r_kind) THEN + itype = 10 ! CB + END IF + + cld_type_3d(i,j,k1) = itype + END DO !k1 + enddo ! ilvl + endif ! nlvl > 0 + + ENDDO ! i + ENDDO ! j + +END SUBROUTINE cloudType + diff --git a/src/GSD/gsdcloud/cloud_saturation.f90 b/src/GSD/gsdcloud/cloud_saturation.f90 new file mode 100644 index 0000000000..fa9fd5cb7a --- /dev/null +++ b/src/GSD/gsdcloud/cloud_saturation.f90 @@ -0,0 +1,335 @@ +SUBROUTINE cloud_saturation(mype,l_conserve_thetaV,i_conserve_thetaV_iternum, & + nlat,nlon,nsig,q_bk,t_bk,p_bk, & + cld_cover_3d,wthr_type, & + cldwater_3d,cldice_3d,sumqci,qv_max_inc) +! +!$$$ subprogram documentation block +! . . . . +! subprogram: cloud_saturation to ensure water vapor saturation at all cloudy grid points +! also to ensure sub saturation in clear point +! +! PRGMMR: Ming Hu ORG: GSD/AMB DATE: 2006-11-20 +! +! ABSTRACT: +! This subroutine calculate liquid water content for stratiform cloud +! +! PROGRAM HISTORY LOG: +! 2010-10-06 Hu check whole 3D mositure field and get rid of supersaturation +! 2009-01-20 Hu Add NCO document block +! 2017-04-13 Ladwig Add comments & theta-v conservation for missing obs case +! +! +! input argument list: +! nlon - no. of lons on subdomain (buffer points on ends) +! nlat - no. of lats on subdomain (buffer points on ends) +! nsig - no. of levels +! q_bk - 3D moisture +! t_bk - 3D background potential temperature (K) +! p_bk - 3D background pressure (hPa) +! cldwater_3d - 3D analysis cloud water mixing ratio (g/kg) +! cldice_3d - 3D analysis cloud ice mixing ratio (g/kg) +! cld_cover_3d- 3D cloud cover +! wthr_type - 3D weather type +! l_conserve_thetaV - if .true. conserving thetaV +! i_conserve_thetaV_iternum - iteration number for conserving thetaV +! +! output argument list: +! q_bk - 3D moisture +! +! USAGE: +! INPUT FILES: +! +! OUTPUT FILES: +! +! REMARKS: +! +! ATTRIBUTES: +! LANGUAGE: FORTRAN 90 +! MACHINE: Linux cluster (WJET) +! +!$$$ +! +!_____________________________________________________________________ +! + + use constants, only: rd_over_cp, h1000,one,zero,fv + use gsd_kinds, only: r_single,i_kind, r_kind + + implicit none + + integer(i_kind),intent(in):: mype + integer(i_kind),intent(in):: nlat,nlon,nsig + logical,intent(in):: l_conserve_thetaV + integer(i_kind),intent(in):: i_conserve_thetaV_iternum +! +! background +! + real(r_single),intent(inout) :: t_bk(nlon,nlat,nsig) ! potential temperature (K) + real(r_single),intent(inout) :: q_bk(nlon,nlat,nsig) ! mixing ratio (kg/kg) + real(r_single),intent(in) :: p_bk(nlon,nlat,nsig) ! pressure (hpa) + REAL(r_kind),intent(in) :: sumqci(nlon,nlat,nsig) ! total liquid water + real(r_kind),intent(in) :: qv_max_inc ! max qv increment +! +! Variables for cloud analysis +! + real (r_single),intent(in) :: cld_cover_3d(nlon,nlat,nsig) + integer(i_kind),intent(in) :: wthr_type(nlon,nlat) +! +! cloud water and cloud ice +! + real (r_single),intent(in) :: cldwater_3d(nlon,nlat,nsig) ! kg/kg + real (r_single),intent(in) :: cldice_3d(nlon,nlat,nsig) ! kg/kg +!----------------------------------------------------------- +! +! temp. +! + INTEGER(i_kind) :: i,j,k + real(r_single) :: cloudqvis,ruc_saturation + +! --- Key parameters +! Rh_clear_p = 0.80 RH to use when clearing cloud + + real(r_single) rh_cld3_p + real(r_single) rh_clear_p + data rh_cld3_p /0.98_r_single/ ! mhu, do we need to adjust this number to 0.94, WPP has PBL top set as 0.95 + data rh_clear_p /0.8_r_single/ + + real(r_kind) :: es0_p + parameter (es0_p=6.1121_r_kind) ! saturation vapor pressure (mb) + + INTEGER(i_kind) :: miter,nnn + + REAL(r_kind) :: constantTv, Temp + real(r_single) :: qtemp +! +!==================================================================== +! Begin +! +! + miter=i_conserve_thetaV_iternum ! iteration number for conserving Tv + + DO j = 2,nlat-1 + DO i = 2,nlon-1 + DO k = 2,nsig-1 + +!mhu p_pa_1d(k) = p_bk(i,j,k)*100.0_r_single +! qv= q_bk(i,j,k)/(one+q_bk(i,j,k)) ! qv = water vapor specific humidity +! ! q_bk = water vapor mixing ratio +! now, tmperature from GSI s potential temperature. get temperature + Temp = t_bk(i,j,k)*(p_bk(i,j,k)/h1000)**rd_over_cp + +! now, calculate saturation +! + cloudqvis= ruc_saturation(Temp,p_bk(i,j,k)) +! +! moisture adjustment based on cloud +! +! +! check each grid point to make sure no supersaturation + q_bk(i,j,k) = min(q_bk(i,j,k), cloudqvis * 1.00_r_single) +! now, calculate constant virtual temperature + constantTv=Temp*(one + fv*q_bk(i,j,k)) +! + + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! If valid cld_cover_3d + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + if(cld_cover_3d(i,j,k) > -0.0001_r_kind .and. & + cld_cover_3d(i,j,k) < 2.0_r_kind) then + !############################################# + ! if clear ob + !############################################# + if(cld_cover_3d(i,j,k) <= 0.0001_r_kind) then + ! adjust RH to be below 85 percent(50%?) if + ! 1) cloudyn = 0 + ! 2) at least 100 mb above sfc + ! 3) no precip from sfc obs + !make sure that clear volumes are no more than rh_clear_p RH. + if( (sumqci(i,j,k))>1.0e-12_r_kind .and. & + (p_bk(i,j,1) - p_bk(i,j,k))>100._r_kind .and. & + wthr_type(i,j) <=0 ) then + if( q_bk(i,j,k) > cloudqvis * rh_clear_p) then + qtemp = cloudqvis * rh_clear_p + if(l_conserve_thetaV) then + do nnn=1,miter + Temp=constantTv/(one + fv*qtemp) + cloudqvis= ruc_saturation(Temp,p_bk(i,j,k)) + qtemp = cloudqvis * rh_clear_p + enddo + t_bk(i,j,k) = Temp*(h1000/p_bk(i,j,k))**rd_over_cp + endif + !limit increment + q_bk(i,j,k) = min(qtemp, q_bk(i,j,k)+qv_max_inc) + endif + endif + !C - moisten layers above and below cloud layer + if(cld_cover_3d(i,j,k+1) > 0.6_r_kind .or. & + cld_cover_3d(i,j,k-1) > 0.6_r_kind ) then + if( cloudqvis > q_bk(i,j,k) ) then + qtemp = q_bk(i,j,k) + 0.7_r_single* (cloudqvis-q_bk(i,j,k)) + if(l_conserve_thetaV) then + do nnn=1,miter + Temp=constantTv/(one + fv*qtemp) + cloudqvis= ruc_saturation(Temp,p_bk(i,j,k)) + qtemp = q_bk(i,j,k) + 0.7_r_single* (cloudqvis-q_bk(i,j,k)) + enddo + t_bk(i,j,k) = Temp*(h1000/p_bk(i,j,k))**rd_over_cp + endif + !limit increment + q_bk(i,j,k) = min(qtemp, q_bk(i,j,k)+qv_max_inc) + endif + endif + !############################################# + ! -- If SCT/FEW present, reduce RH only down to rh_cld3_p (0.98) + ! corresponding with cloudyn=3 + !############################################# + elseif(cld_cover_3d(i,j,k) > 0.0001_r_kind .and. & + cld_cover_3d(i,j,k) < 0.6_r_kind ) then + if( q_bk(i,j,k) > cloudqvis * rh_cld3_p) then + qtemp = cloudqvis * rh_cld3_p + if(l_conserve_thetaV) then + do nnn=1,miter + Temp=constantTv/(one + fv*qtemp) + cloudqvis= ruc_saturation(Temp,p_bk(i,j,k)) + qtemp = cloudqvis * rh_cld3_p + enddo + t_bk(i,j,k) = Temp*(h1000/p_bk(i,j,k))**rd_over_cp + endif + !limit increment + q_bk(i,j,k) = min(qtemp, q_bk(i,j,k)+qv_max_inc) + endif + !############################################# + ! else: cld_cover_3d is > 0.6: cloudy case + !############################################# + else ! set qv at 102%RH + if( q_bk(i,j,k) < cloudqvis * 1.00_r_single ) then + qtemp = cloudqvis * 1.00_r_single + if(l_conserve_thetaV) then + do nnn=1,miter + Temp=constantTv/(one + fv*qtemp) + cloudqvis= ruc_saturation(Temp,p_bk(i,j,k)) + qtemp = cloudqvis * 1.00_r_single + enddo + t_bk(i,j,k) = Temp*(h1000/p_bk(i,j,k))**rd_over_cp + endif + !limit increment + q_bk(i,j,k) = min(qtemp, q_bk(i,j,k)+qv_max_inc) + endif + endif + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! cld_cover_3d is missing + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + else ! cloud cover is missing + ! Ensure saturation in all cloudy volumes. + ! Since saturation has already been ensured for new cloudy areas (cld_cover_3d > 0.6) + ! we now ensure saturation for all cloud 3-d points, whether cloudy from background + ! (and not changed - cld_cover_3d < 0) + ! If cloud cover is missing, (cldwater_3d(i,j,k)+cldice_3d(i,j,k) = sumqci(i,j,k), + ! which is background cloud liquid water. + if ((cldwater_3d(i,j,k)+cldice_3d(i,j,k))>1.0e-5_r_kind) then + !conserve + qtemp = cloudqvis * 1.00_r_single + if(l_conserve_thetaV) then + do nnn=1,miter + Temp=constantTv/(one + fv*qtemp) + cloudqvis= ruc_saturation(Temp,p_bk(i,j,k)) + qtemp = cloudqvis * 1.00_r_single + enddo + t_bk(i,j,k) = Temp*(h1000/p_bk(i,j,k))**rd_over_cp + endif + !limit increment + q_bk(i,j,k) = min(qtemp, q_bk(i,j,k)+qv_max_inc) + endif + endif +! +! check each grid point to make sure no supersaturation +! + q_bk(i,j,k) = min(q_bk(i,j,k), cloudqvis * 1.00_r_single) +! + + enddo ! k + enddo ! i + enddo ! j + +END SUBROUTINE cloud_saturation + +function ruc_saturation(Temp,pressure) +! +!$$$ subprogram documentation block +! . . . . +! subprogram: ruc_saturation calculate saturation +! +! PRGMMR: Ming Hu ORG: GSD/AMB DATE: 2011-11-28 +! +! ABSTRACT: +! This subroutine calculate saturation +! +! PROGRAM HISTORY LOG: +! 2011-11-28 Hu Initial +! +! +! input argument list: +! pressure - background pressure (hPa) +! Temp - temperature (K) +! +! output argument list: +! ruc_saturation +! +! USAGE: +! INPUT FILES: +! +! OUTPUT FILES: +! +! REMARKS: +! +! ATTRIBUTES: +! LANGUAGE: FORTRAN 90 +! MACHINE: Linux cluster (WJET) +! +!$$$ +! +!_____________________________________________________________________ + + use constants, only: rd_over_cp, h1000,one,zero + use gsd_kinds, only: r_single,i_kind, r_kind +! + implicit none + real(r_single) :: ruc_saturation + + REAL(r_kind), intent(in) :: Temp ! temperature in K + real(r_single),intent(in) :: pressure ! pressure (hpa) + + real(r_kind) :: es0_p + parameter (es0_p=6.1121_r_kind) ! saturation vapor pressure (mb) + real(r_kind) SVP1,SVP2,SVP3 + data SVP1,SVP2,SVP3/es0_p,17.67_r_kind,29.65_r_kind/ + + real(r_kind) :: temp_qvis1, temp_qvis2 + data temp_qvis1, temp_qvis2 /268.15_r_kind, 263.15_r_kind/ + + REAL(r_kind) :: evs, qvs1, eis, qvi1, watwgt +! + +! +! evs, eis in mb +! For this part, must use the water/ice saturation as f(temperature) + evs = svp1*exp(SVP2*(Temp-273.15_r_kind)/(Temp-SVP3)) + qvs1 = 0.62198_r_kind*evs/(pressure-evs) ! qvs1 is mixing ratio kg/kg + ! so no need next line +! qvs1 = qvs1/(1.0-qvs1) +! Get ice saturation and weighted ice/water saturation ready to go +! for ensuring cloud saturation below. + eis = svp1 *exp(22.514_r_kind - 6.15e3_r_kind/Temp) + qvi1 = 0.62198_r_kind*eis/(pressure-eis) ! qvi1 is mixing ratio kg/kg, + ! so no need next line +! qvi1 = qvi1/(1.0-qvi1) +! watwgt = max(0.,min(1.,(Temp-233.15)/(263.15-233.15))) +! watwgt = max(zero,min(one,(Temp-251.15_r_kind)/& +! (263.15_r_kind-251.15_r_kind))) +! ph - 2/7/2012 - use ice mixing ratio only for temp < 263.15 + watwgt = max(zero,min(one,(Temp-temp_qvis2)/& + (temp_qvis1-temp_qvis2))) + ruc_saturation= (watwgt*qvs1 + (one-watwgt)*qvi1) ! kg/kg +! +end function ruc_saturation diff --git a/src/GSD/gsdcloud/configure b/src/GSD/gsdcloud/configure new file mode 100755 index 0000000000..bb10af0ac0 --- /dev/null +++ b/src/GSD/gsdcloud/configure @@ -0,0 +1,93 @@ +#!/bin/sh +# +# Creates configuration Makefile. Before attempting to make anything +# in this directory, enter +# +# ./configure +# +# !REVISION HISTORY +# +# 09oct97 da Silva Initial code. +# 19oct97 da Silva Simplified. +# 22oct97 Jing Guo Converted to libpsas.a environment +# - special configuration for CRAY +# - fool-prove configuration +# - additional information +# 23dec99 da Silva Modified error messages. +# +#..................................................................... + +set -x + +c=`basename $0 .sh` + +type=${1:-"unknown"} +echo $type + + +# If type=clean, remove soft links and exit +# ----------------------------------------- +if [ "$type" = "clean" ]; then + if [ -r makefile ]; then + echo "$c: remove makefile" 1>&2 + rm makefile + fi + if [ -r Makefile.conf ]; then + echo "$c: remove Makefile.conf" 1>&2 + rm Makefile.conf + fi + exit +fi + + +# Set makeconf based on user input +# --------------------------------------- +makeconf="Makefile.conf.$type" + + +# Node specific configuration +# --------------------------------------- +if [ ! -r ${makeconf} ]; then + echo "$c: cannot find ${makeconf} in `pwd`" 1>&2 + makeconf="Makefile.conf.`uname -n | awk '{print $1}'`" +fi + +# Machine specific +# ---------------- +if [ ! -r ${makeconf} ]; then + echo "$c: cannot find ${makeconf} in `pwd`" 1>&2 + machine="`uname -m | awk '{print $1}'`" + machine=`echo $machine | tr "[a-z]" "[A-Z]"` + compiler=$F90 + makeconf="Makefile.conf.`uname -s | awk '{print $1}'`" + makeconf="${makeconf}.${machine}.${compiler}" +fi + +# Site specific configuration +# --------------------------- +if [ ! -r ${makeconf} ]; then + echo "$c: cannot find ${makeconf} in `pwd`" 1>&2 + makeconf="Makefile.conf.`uname -s | awk '{print $1}'`" +fi + +# if the OS is UNICOS, it does not follow the convention +# ------------------------------------------------------ +if [ ! -r ${makeconf} ]; then + echo "$c: cannot find ${makeconf} in `pwd`" 1>&2 + mech="`uname -m | awk '{print $1}'`" + if [ "${mech}" = CRAY ]; then + makeconf="Makefile.conf.UNICOS" + fi +fi + +# Create soft link for Makefile.conf +# ------------------------------------------------------ +if [ -r Makefile.conf ]; then + echo "$c: remove Makefile.conf" 1>&2 + rm Makefile.conf +fi +ln -s ${makeconf} Makefile.conf + +echo "$c: using ${makeconf} in `pwd`" 1>&2 + +#. diff --git a/src/GSD/gsdcloud/constants.f90 b/src/GSD/gsdcloud/constants.f90 new file mode 100755 index 0000000000..3d213431ed --- /dev/null +++ b/src/GSD/gsdcloud/constants.f90 @@ -0,0 +1,324 @@ +module constants +!$$$ module documentation block +! . . . . +! module: constants +! prgmmr: treadon org: np23 date: 2003-09-25 +! +! abstract: This module contains the definition of various constants +! used in the gsi code +! +! program history log: +! 2003-09-25 treadon - original code +! 2004-03-02 treadon - allow global and regional constants to differ +! 2004-06-16 treadon - update documentation +! 2004-10-28 treadon - replace parameter tiny=1.e-12 with tiny_r_kind +! and tiny_single +! 2004-11-16 treadon - add huge_single, huge_r_kind parameters +! 2005-01-27 cucurull - add ione +! 2005-08-24 derber - move cg_term to constants from qcmod +! 2006-03-07 treadon - add rd_over_cp_mass +! 2006-05-18 treadon - add huge_i_kind +! 2006-06-06 su - add var-qc wgtlim, change value to 0.25 (ECMWF) +! 2006-07-28 derber - add r1000 +! 2007-03-20 rancic - add r3600 +! 2009-02-05 cucurull - modify refractive indexes for gpsro data +! +! Subroutines Included: +! sub init_constants_derived - compute derived constants +! sub init_constants - set regional/global constants +! +! Variable Definitions: +! see below +! +! attributes: +! language: f90 +! machine: ibm RS/6000 SP +! +!$$$ end documentation block + + use gsd_kinds, only: r_single,r_kind,i_kind,r_quad,i_long + implicit none + +! set default as private + private +! set subroutines as public + public :: init_constants_derived + public :: init_constants +! set passed variables to public + public :: one,two,ione,half,zero,izero,deg2rad,pi,three,quarter,one_tenth + public :: rad2deg,zero_quad,r3600,r1000,r60inv,five,four,rd_over_cp,grav + public :: rd,rozcon,rearth_equator,zero_single,tiny_r_kind,tiny_single + public :: omega,rcp,rearth,fv,h300,cp,cg_term,tpwcon,xb,ttp,psatk,xa,tmix + public :: xai,xbi,psat,eps,omeps,wgtlim,one_quad,epsq,climit,epsm1,hvap + public :: hsub,cclimit,el2orc,elocp,h1000,cpr,pcpeff0,pcpeff2,delta,pcpeff1 + public :: factor1,c0,pcpeff3,factor2,dx_inv,dx_min,rhcbot,rhctop,hfus,ke2 + public :: rrow,cmr,cws,r60,huge_i_kind,huge_r_kind,t0c,rd_over_cp_mass + public :: somigliana,grav_equator,grav_ratio,flattening,semi_major_axis + public :: n_b,n_a,eccentricity,huge_single,constoz,g_over_rd,amsua_clw_d2 + public :: amsua_clw_d1,n_c,rd_over_g,zero_ilong + +! Declare derived constants + integer(i_kind):: huge_i_kind + real(r_single):: tiny_single, huge_single + real(r_kind):: xai, xa, xbi, xb, dldt, rozcon,ozcon,fv, tpwcon,eps, rd_over_g + real(r_kind):: el2orc, g_over_rd, rd_over_cp, cpr, omeps, epsm1, factor2 + real(r_kind):: factor1, huge_r_kind, tiny_r_kind, deg2rad, pi, rad2deg, cg_term + real(r_kind):: eccentricity_linear, cv, rv, rd_over_cp_mass, cliq, rd, cp_mass + real(r_kind):: eccentricity, grav, rearth, r60inv + + +! Define constants common to global and regional applications + real(r_kind),parameter:: rearth_equator= 6.37813662e6_r_kind ! equatorial earth radius (m) + real(r_kind),parameter:: omega = 7.2921e-5_r_kind ! angular velocity of earth (1/s) + real(r_kind),parameter:: cp = 1.0046e+3_r_kind ! specific heat of air @pressure (J/kg/K) + real(r_kind),parameter:: cvap = 1.8460e+3_r_kind ! specific heat of h2o vapor (J/kg/K) + real(r_kind),parameter:: csol = 2.1060e+3_r_kind ! specific heat of solid h2o (ice)(J/kg/K) + real(r_kind),parameter:: hvap = 2.5000e+6_r_kind ! latent heat of h2o condensation (J/kg) + real(r_kind),parameter:: hfus = 3.3358e+5_r_kind ! latent heat of h2o fusion (J/kg) + real(r_kind),parameter:: psat = 6.1078e+2_r_kind ! pressure at h2o triple point (Pa) + real(r_kind),parameter:: t0c = 2.7315e+2_r_kind ! temperature at zero celsius (K) + real(r_kind),parameter:: ttp = 2.7316e+2_r_kind ! temperature at h2o triple point (K) + real(r_kind),parameter:: jcal = 4.1855e+0_r_kind ! joules per calorie () + real(r_kind),parameter:: stndrd_atmos_ps = 1013.25e2_r_kind ! 1976 US standard atmosphere ps (Pa) + +! Numeric constants + integer(i_kind),parameter:: izero = 0_i_kind + integer(i_kind),parameter:: ione = 1_i_kind + + integer(i_long),parameter:: zero_ilong = 0_i_long + + real(r_single),parameter:: zero_single= 0.0_r_single + + real(r_kind),parameter:: zero = 0.0_r_kind + real(r_kind),parameter:: one_tenth = 0.10_r_kind + real(r_kind),parameter:: quarter = 0.25_r_kind + real(r_kind),parameter:: one = 1.0_r_kind + real(r_kind),parameter:: two = 2.0_r_kind + real(r_kind),parameter:: three = 3.0_r_kind + real(r_kind),parameter:: four = 4.0_r_kind + real(r_kind),parameter:: five = 5.0_r_kind + real(r_kind),parameter:: r60 = 60._r_kind + real(r_kind),parameter:: r1000 = 1000.0_r_kind + real(r_kind),parameter:: r3600 = 3600.0_r_kind + + real(r_quad),parameter:: zero_quad = 0.0_r_quad + real(r_quad),parameter:: one_quad = 1.0_r_quad + + +! Constants for gps refractivity (Bevis et al 1994) + real(r_kind),parameter:: n_a = 77.60_r_kind ! K/mb + real(r_kind),parameter:: n_b = 3.739e+5_r_kind ! K^2/mb + real(r_kind),parameter:: n_c = 70.4_r_kind ! K/mb + +! Parameters below from WGS-84 model software inside GPS receivers. + real(r_kind),parameter:: semi_major_axis = 6378.1370e3_r_kind ! (m) + real(r_kind),parameter:: semi_minor_axis = 6356.7523142e3_r_kind ! (m) + real(r_kind),parameter:: grav_polar = 9.8321849378_r_kind ! (m/s2) + real(r_kind),parameter:: grav_equator = 9.7803253359_r_kind ! (m/s2) + real(r_kind),parameter:: earth_omega = 7.292115e-5_r_kind ! (rad/s) + real(r_kind),parameter:: grav_constant = 3.986004418e14_r_kind ! (m3/s2) + +! Derived geophysical constants + real(r_kind),parameter:: flattening = (semi_major_axis-semi_minor_axis)/semi_major_axis + real(r_kind),parameter:: somigliana = & + (semi_minor_axis/semi_major_axis) * (grav_polar/grav_equator) - one + real(r_kind),parameter:: grav_ratio = (earth_omega*earth_omega * & + semi_major_axis*semi_major_axis * semi_minor_axis) / grav_constant + +! Derived thermodynamic constants + real(r_kind),parameter:: dldti = cvap-csol + real(r_kind),parameter:: hsub = hvap+hfus + real(r_kind),parameter:: psatk = psat*0.001_r_kind + real(r_kind),parameter:: tmix = ttp-20._r_kind + real(r_kind),parameter:: elocp = hvap/cp + real(r_kind),parameter:: rcp = one/cp + +! Constants used in GFS moist physics + real(r_kind),parameter:: h300 = 300._r_kind + real(r_kind),parameter:: half = 0.5_r_kind + real(r_kind),parameter:: cclimit = 0.001_r_kind + real(r_kind),parameter:: climit = 1.e-20_r_kind + real(r_kind),parameter:: epsq = 2.e-12_r_kind + real(r_kind),parameter:: h1000 = r1000 + real(r_kind),parameter:: rhcbot=0.85_r_kind + real(r_kind),parameter:: rhctop=0.85_r_kind + real(r_kind),parameter:: dx_max=-8.8818363_r_kind + real(r_kind),parameter:: dx_min=-5.2574954_r_kind + real(r_kind),parameter:: dx_inv=one/(dx_max-dx_min) + real(r_kind),parameter:: c0=0.002_r_kind + real(r_kind),parameter:: delta=0.6077338_r_kind + real(r_kind),parameter:: pcpeff0=1.591_r_kind + real(r_kind),parameter:: pcpeff1=-0.639_r_kind + real(r_kind),parameter:: pcpeff2=0.0953_r_kind + real(r_kind),parameter:: pcpeff3=-0.00496_r_kind + real(r_kind),parameter:: cmr = one/0.0003_r_kind + real(r_kind),parameter:: cws = 0.025_r_kind + real(r_kind),parameter:: ke2 = 0.00002_r_kind + real(r_kind),parameter:: row = r1000 + real(r_kind),parameter:: rrow = one/row + +! Constant used to process ozone + real(r_kind),parameter:: constoz = 604229.0_r_kind + +! Constants used in cloud liquid water correction for AMSU-A +! brightness temperatures + real(r_kind),parameter:: amsua_clw_d1 = 0.754_r_kind + real(r_kind),parameter:: amsua_clw_d2 = -2.265_r_kind + +! Constants used for variational qc + real(r_kind),parameter:: wgtlim = quarter ! Cutoff weight for concluding that obs has been + ! rejected by nonlinear qc. This limit is arbitrary + ! and DOES NOT affect nonlinear qc. It only affects + ! the printout which "counts" the number of obs that + ! "fail" nonlinear qc. Observations counted as failing + ! nonlinear qc are still assimilated. Their weight + ! relative to other observations is reduced. Changing + ! wgtlim does not alter the analysis, only + ! the nonlinear qc data "count" + +contains + + subroutine init_constants_derived +!$$$ subprogram documentation block +! . . . . +! subprogram: init_constants_derived set derived constants +! prgmmr: treadon org: np23 date: 2004-12-02 +! +! abstract: This routine sets derived constants +! +! program history log: +! 2004-12-02 treadon +! 2005-03-03 treadon - add implicit none +! 2008-06-04 safford - rm unused vars +! +! input argument list: +! +! output argument list: +! +! attributes: +! language: f90 +! machine: ibm rs/6000 sp +! +!$$$ + implicit none + +! Trigonometric constants + pi = acos(-one) + deg2rad = pi/180.0_r_kind + rad2deg = one/deg2rad + cg_term = (sqrt(two*pi))/two ! constant for variational qc + tiny_r_kind = tiny(zero) + huge_r_kind = huge(zero) + tiny_single = tiny(zero_single) + huge_single = huge(zero_single) + huge_i_kind = huge(izero) + r60inv=one/r60 + +! Geophysical parameters used in conversion of geopotential to +! geometric height + eccentricity_linear = sqrt(semi_major_axis**2 - semi_minor_axis**2) + eccentricity = eccentricity_linear / semi_major_axis + + return + end subroutine init_constants_derived + + subroutine init_constants(regional) +!$$$ subprogram documentation block +! . . . . +! subprogram: init_constants set regional or global constants +! prgmmr: treadon org: np23 date: 2004-03-02 +! +! abstract: This routine sets constants specific to regional or global +! applications of the gsi +! +! program history log: +! 2004-03-02 treadon +! 2004-06-16 treadon, documentation +! 2004-10-28 treadon - use intrinsic TINY function to set value +! for smallest machine representable positive +! number +! 2004-12-03 treadon - move derived constants to init_constants_derived +! 2005-03-03 treadon - add implicit none +! +! input argument list: +! regional - if .true., set regional gsi constants; +! otherwise (.false.), use global constants +! +! output argument list: +! +! attributes: +! language: f90 +! machine: ibm rs/6000 sp +! +!$$$ + implicit none + + logical,intent(in ) :: regional + + real(r_kind) reradius,g,r_d,r_v,cliq_wrf + +! Define regional constants here + if (regional) then + +! Name given to WRF constants + reradius = one/6370.e03_r_kind + g = 9.81_r_kind + r_d = 287.04_r_kind + r_v = 461.6_r_kind + cliq_wrf = 4190.0_r_kind + cp_mass = 1004.67_r_kind + +! Transfer WRF constants into unified GSI constants + rearth = one/reradius + grav = g + rd = r_d + rv = r_v + cv = cp-r_d + cliq = cliq_wrf + rd_over_cp_mass = rd / cp_mass + +! Define global constants here + else + rearth = 6.3712e+6_r_kind + grav = 9.80665e+0_r_kind + rd = 2.8705e+2_r_kind + rv = 4.6150e+2_r_kind + cv = 7.1760e+2_r_kind + cliq = 4.1855e+3_r_kind + cp_mass= zero + rd_over_cp_mass = zero + endif + + +! Now define derived constants which depend on constants +! which differ between global and regional applications. + +! Constants related to ozone assimilation + ozcon = grav*21.4e-9_r_kind + rozcon= one/ozcon + +! Constant used in vertical integral for precipitable water + tpwcon = 100.0_r_kind/grav + +! Derived atmospheric constants + fv = rv/rd-one ! used in virtual temperature equation + dldt = cvap-cliq + xa = -(dldt/rv) + xai = -(dldti/rv) + xb = xa+hvap/(rv*ttp) + xbi = xai+hsub/(rv*ttp) + eps = rd/rv + epsm1 = rd/rv-one + omeps = one-eps + factor1 = (cvap-cliq)/rv + factor2 = hvap/rv-factor1*t0c + cpr = cp*rd + el2orc = hvap*hvap/(rv*cp) + rd_over_g = rd/grav + rd_over_cp = rd/cp + g_over_rd = grav/rd + + return + end subroutine init_constants + +end module constants diff --git a/src/GSD/gsdcloud/convert_lghtn2ref.f90 b/src/GSD/gsdcloud/convert_lghtn2ref.f90 new file mode 100644 index 0000000000..34ba58592d --- /dev/null +++ b/src/GSD/gsdcloud/convert_lghtn2ref.f90 @@ -0,0 +1,197 @@ +SUBROUTINE convert_lghtn2ref(mype,nlon,nlat,nsig,ref_mos_3d,lightning,h_bk) +! +!$$$ subprogram documentation block +! . . . . +! subprogram: convert_lghtn2ref convert lightning stroke rate to radar reflectivity +! +! PRGMMR: Ming Hu ORG: GSD/AMB DATE: 2008-11-17 +! +! ABSTRACT: +! This subroutine converts lightning stroke rate to radar reflectivity +! +! PROGRAM HISTORY LOG: +! 2009-01-20 Hu Add NCO document block +! +! +! input argument list: +! mype - processor ID +! nlon - no. of lons on subdomain (buffer points on ends) +! nlat - no. of lats on subdomain (buffer points on ends) +! nsig - no. of levels +! ref_mos_3d - 3D reflectivity in analysis grid +! lightning - 2D lightning flash rate in analysis grid +! h_bk - 3D height +! +! output argument list: +! ref_mos_3d - 3D reflectivity in analysis grid +! +! USAGE: +! INPUT FILES: +! +! OUTPUT FILES: +! +! REMARKS: +! +! ATTRIBUTES: +! LANGUAGE: FORTRAN 90 +! MACHINE: Linux cluster (WJET) +! +!$$$ +! +!_____________________________________________________________________ +! + use gsd_kinds, only: r_kind,i_kind,r_single + implicit none + + INTEGER(i_kind),intent(in) :: mype + INTEGER(i_kind),intent(in) :: nlon,nlat,nsig + real(r_single), intent(in) :: h_bk(nlon,nlat,nsig) ! height + real(r_single), intent(in) :: lightning(nlon,nlat) + real(r_kind), intent(inout):: ref_mos_3d(nlon,nlat,nsig) ! reflectivity in grid +! +! local +! + real(r_kind) :: dbz_lightning(nlon,nlat) + real(r_kind) :: table_lghtn2ref_winter(30) ! table content the map from lightning strakes + ! to maximum reflectivity + DATA table_lghtn2ref_winter/ & + 32.81,33.98,34.93,36.26,36.72,37.07,37.93,38.79,39.65,40.10, & + 40.42,41.42,41.90,42.04,42.19,42.45,42.90,43.20,43.50,43.80, & + 44.10,44.66,44.84,45.56,45.64,45.80,45.95,46.11,46.32,46.50/ + + real(r_kind) :: table_lghtn2ref_summer(30) ! table content the map from lightning strakes + ! to maximum reflectivity + DATA table_lghtn2ref_summer/ & + 30.13,31.61,32.78,33.86,34.68,35.34,36.13,36.15,37.02,37.04, & + 37.74,38.00,38.56,38.85,39.10,39.37,39.78,39.98,40.64,41.33, & + 41.50,41.65,41.85,42.08,42.77,43.03,43.26,43.53,43.74,43.73/ + + integer(i_kind) :: maxlvl + parameter (maxlvl=31) + real(r_kind) :: newlvlAll(maxlvl) ! vertical levels of reflectivity statistic profile + DATA newlvlAll/0.2, 0.5, 0.75, 1, 1.25, 1.5, 1.75, 2, 2.25, 2.5, 2.75, & + 3, 3.5, 4, 4.5, 5, 5.5, 6, 6.5, 7, 7.5, 8, 8.5, & + 9, 10, 11, 12, 13, 14, 15, 16/ + + real(r_kind) :: refprofile_winter(maxlvl,4) ! statistic reflectivity profile used to + ! retrieve vertical ref based on lightning +! max reflectivity 30-35 dbz + DATA refprofile_winter(:,1) / & + 0.966,0.958,0.977,0.989,0.998,1.000,0.997,0.992,0.981,0.962, & + 0.933,0.898,0.826,0.752,0.687,0.626,0.578,0.547,0.522,0.526, & + 0.519,0.501,0.482,0.464,0.437,0.430,0.454,0.539,0.662,0.742, & + 0.793/ +! max reflectivity 35-40 dbz + DATA refprofile_winter(:,2) / & + 0.947,0.953,0.980,0.994,1.000,0.996,0.987,0.974,0.956,0.928, & + 0.891,0.848,0.761,0.679,0.613,0.559,0.522,0.491,0.473,0.462, & + 0.451,0.433,0.415,0.403,0.382,0.380,0.406,0.482,0.603,0.707, & + 0.723/ +! max reflectivity 40-45 dbz + DATA refprofile_winter(:,3) / & + 0.937,0.955,0.986,1.000,0.997,0.995,0.988,0.978,0.957,0.920, & + 0.871,0.824,0.735,0.654,0.584,0.518,0.465,0.442,0.435,0.412, & + 0.398,0.385,0.376,0.360,0.340,0.350,0.377,0.446,0.551,0.625, & + 0.656/ +! max reflectivity 45-50 dbz + DATA refprofile_winter(:,4) / & + 0.900,0.949,0.982,0.995,1.000,0.998,0.983,0.954,0.914,0.874, & + 0.834,0.793,0.721,0.664,0.612,0.565,0.530,0.496,0.460,0.431, & + 0.402,0.383,0.370,0.354,0.335,0.321,0.347,0.342,0.441,0.510, & + 0.548/ + + real(r_kind) :: refprofile_summer(maxlvl,4) ! statistic reflectivity profile used to + ! retrieve vertical ref based on lightning +! max reflectivity 30-35 dbz + DATA refprofile_summer(:,1) / & + 0.870,0.885,0.914,0.931,0.943,0.954,0.967,0.975,0.982,0.989, & + 0.995,1.000,0.998,0.973,0.918,0.850,0.791,0.735,0.690,0.657, & + 0.625,0.596,0.569,0.544,0.510,0.479,0.461,0.460,0.477,0.522, & + 0.570/ +! max reflectivity 35-40 dbz + DATA refprofile_summer(:,2) / & + 0.871,0.895,0.924,0.948,0.961,0.971,0.978,0.983,0.988,0.992, & + 0.997,1.000,0.995,0.966,0.913,0.848,0.781,0.719,0.660,0.611, & + 0.576,0.542,0.523,0.513,0.481,0.448,0.416,0.402,0.417,0.448, & + 0.491/ +! max reflectivity 40-45 dbz + DATA refprofile_summer(:,3) / & + 0.875,0.895,0.914,0.936,0.942,0.951,0.964,0.979,0.990,0.998, & + 1.000,0.992,0.961,0.905,0.834,0.772,0.722,0.666,0.618,0.579, & + 0.545,0.518,0.509,0.483,0.419,0.398,0.392,0.403,0.423,0.480, & + 0.440/ +! max reflectivity 45-50 dbz + DATA refprofile_summer(:,4) / & + 0.926,0.920,0.948,0.975,0.988,0.989,0.995,0.997,1.000,1.000, & + 0.997,0.991,0.970,0.939,0.887,0.833,0.788,0.741,0.694,0.655, & + 0.611,0.571,0.551,0.537,0.507,0.470,0.432,0.410,0.420,0.405, & + 0.410/ + + INTEGER(i_kind) :: season ! 1= summer, 2=winter + INTEGER(i_kind) :: num_lightning + INTEGER(i_kind) :: i,j, k2, k, mref + REAL(r_kind) :: heightGSI,upref,downref,wght + INTEGER(i_kind) :: ilvl + REAL(r_kind) :: lowest,highest,tempref, tempprofile(maxlvl) + + +! +! map lightning strokes to maximum reflectiivty +! + season=1 + dbz_lightning = -9999.0_r_kind + DO j=2,nlat-1 + DO i=2,nlon-1 + if(lightning(i,j) > 0.1_r_kind ) then + num_lightning = max(1,min(30,int(lightning(i,j)))) + if(season== 2 ) then + dbz_lightning(i,j) = table_lghtn2ref_winter(num_lightning) + else if(season== 1 ) then + dbz_lightning(i,j) = table_lghtn2ref_summer(num_lightning) + endif + endif + ENDDO + ENDDO +! +! vertical reflectivity distribution +! + DO k=1,maxlvl + newlvlAll(k)=newlvlAll(k)*1000.0_r_kind + ENDDO + +! ref_mos_3d=-9999.0 + DO j=2,nlat-1 + DO i=2,nlon-1 + if( dbz_lightning(i,j) > 30 ) then + mref = min(4,(int((dbz_lightning(i,j) - 30.0_r_kind)/5.0_r_kind) + 1 )) + if(season== 2 ) then + DO k=1,maxlvl + tempprofile(k)=refprofile_winter(k,mref)*dbz_lightning(i,j) + enddo + lowest=newlvlAll(2) + highest=7000.0_r_kind + else if(season== 1 ) then + DO k=1,maxlvl + tempprofile(k)=refprofile_summer(k,mref)*dbz_lightning(i,j) + enddo + lowest=newlvlAll(3) + highest=12000.0_r_kind + endif + DO k2=1,nsig + heightGSI=h_bk(i,j,k2) + if(heightGSI >= lowest .and. heightGSI < highest) then ! lower 12km ? + do k=1,maxlvl-1 + if( heightGSI >=newlvlAll(k) .and. heightGSI < newlvlAll(k+1) ) ilvl=k + enddo + upref=tempprofile(ilvl+1) + downref=tempprofile(ilvl) + wght=(heightGSI-newlvlAll(ilvl))/(newlvlAll(ilvl+1)-newlvlAll(ilvl)) + tempref=(1-wght)*downref + wght*upref + ref_mos_3d(i,j,k2) = max(ref_mos_3d(i,j,k2),tempref) + endif + ENDDO + endif + ENDDO + ENDDO + +END SUBROUTINE convert_lghtn2ref diff --git a/src/GSD/gsdcloud/get_sfm_1d_gnl.f90 b/src/GSD/gsdcloud/get_sfm_1d_gnl.f90 new file mode 100644 index 0000000000..c94e50716b --- /dev/null +++ b/src/GSD/gsdcloud/get_sfm_1d_gnl.f90 @@ -0,0 +1,384 @@ +! +! +! +!$$$ subprogram documentation block +! . . . . +! subprogram: get_sfm_1d_gnl +! +! PRGMMR: ORG: DATE: +! +! ABSTRACT: +! This subroutine calculate liquid water content for convection cloud +! This subroutine is from ARPS cloud analysis package +! +! PROGRAM HISTORY LOG: +! 2009-01-20 Hu Add NCO document block +! +! +! input argument list: +! +! output argument list: +! +! USAGE: +! INPUT FILES: +! +! OUTPUT FILES: +! +! REMARKS: +! +! ATTRIBUTES: +! LANGUAGE: FORTRAN 90 +! MACHINE: Linux cluster (WJET) +! +!$$$ +! +!_____________________________________________________________________ +! + +!################################################################## +!################################################################## +!###### ###### +!###### SUBROUTINE GET_SFM_1D ###### +!###### ###### +!###### Developed by ###### +!###### Center for Analysis and Prediction of Storms ###### +!###### University of Oklahoma ###### +!###### ###### +!################################################################## +!################################################################## +! + +SUBROUTINE get_sfm_1d_gnl (nz,zcb,zctop,zs_1d,p_mb_1d,t_1d,ql,qi,cldt, & + l_prt) +! +!----------------------------------------------------------------------- +! +! PURPOSE: +!c----------------------------------------------------------------- +!c +!c This is the streamlined version of the Smith-Feddes +!c and Temperature Adjusted LWC calculation methodologies +!c produced at Purdue University under sponsorship +!c by the FAA Technical Center. +!c +!c Currently, this subroutine will only use the Smith- +!c Feddes and will only do so as if there are solely +!c stratiform clouds present, however, it is very easy +!c to switch so that only the Temperature Adjusted +!c method is used. +!c +!c Dilution by glaciation is also included, it is a +!c linear function of in cloud temperature going from +!c all liquid water at -10 C to all ice at -30 C +!c as such the amount of ice is also calculated +! +!----------------------------------------------------------------------- +! +! AUTHOR: Jian Zhang +! 05/96 Based on the LAPS cloud analysis code of 07/1995 +! +! MODIFICATION HISTORY: +! +! 05/16/96 (Jian Zhang) +! Modified for ADAS format. Added full documentation. +! +!----------------------------------------------------------------------- +! +!----------------------------------------------------------------------- +! +! Variable Declarations. +! +!----------------------------------------------------------------------- +! + IMPLICIT NONE +! +! +!----------------------------------------------------------------------- +! +! INPUT: + INTEGER :: nz ! number of model vertical levels + REAL :: zs_1d(nz) ! physical height (m) at each scalar level + REAL :: p_mb_1d(nz) ! pressure (mb) at each level + REAL :: t_1d(nz) ! temperature (K) at each level + + REAL :: zcb ! cloud base height (m) + REAL :: zctop ! cloud top height (m) +! +! OUTPUT: + REAL :: ql(nz) ! liquid water content (g/kg) + REAL :: qi(nz) ! ice water content (g/kg) + REAL :: cldt(nz) +! +! LOCAL: + REAL :: calw(200) + REAL :: cali(200) + REAL :: catk(200) + REAL :: entr(200) +! +!----------------------------------------------------------------------- +! +! Misc local variables +! +!----------------------------------------------------------------------- +! + REAL :: dz,rv,rair,grav,cp,rlvo,rlso,dlvdt,eso + REAL :: c,a1,b1,c1,a2,b2,c2 + REAL :: delz,delt,cldbtm,cldbp,cldtpt,tbar + REAL :: arg,fraclw,tlwc + REAL :: temp,press,zbase,alw,zht,ht,y + REAL :: rl,es,qvs1,p,des,dtz,es2,qvs2 + INTEGER :: i,j,k,nlevel,nlm1,ip,kctop,kctop1,kcb,kcb1 + REAL :: zcloud,entc,tmpk + LOGICAL :: l_prt +! +!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ +! +! Beginning of executable code... +! +!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ +! +! +!----------------------------------------------------------------------- +! +! Initialize 1d liquid water and ice arrays (for 100m layers) +! +!----------------------------------------------------------------------- +! + DO i=1,200 + calw(i)=0.0 + cali(i)=0.0 + END DO +! +!----------------------------------------------------------------------- +! +! Preset some constants and coefficients. +! +!----------------------------------------------------------------------- +! + dz=100.0 ! m + rv=461.5 ! J/deg/kg + rair=287.04 ! J/deg/kg + grav=9.81 ! m/s2 + cp=1004. ! J/deg/kg + rlvo=2.5003E+6 ! J/kg + rlso=2.8339E+6 ! J/kg + dlvdt=-2.3693E+3 ! J/kg/K + eso=610.78 ! pa + c=0.01 + a1=8.4897 + b1=-13.2191 + c1=4.7295 + a2=10.357 + b2=-28.2416 + c2=8.8846 +! +!----------------------------------------------------------------------- +! +! Calculate indices of cloud top and base +! +!----------------------------------------------------------------------- +! + DO k=1,nz-1 + IF(zs_1d(k) < zcb .AND. zs_1d(k+1) > zcb) THEN + kcb=k + kcb1=kcb+1 + END IF + IF(zs_1d(k) < zctop .AND. zs_1d(k+1) > zctop) THEN + kctop=k + kctop1=kctop+1 + END IF + END DO +! +!----------------------------------------------------------------------- +! +! Obtain cloud base and top conditions +! +!----------------------------------------------------------------------- +! + delz = zs_1d(kcb+1)-zs_1d(kcb) + delt = t_1d(kcb+1)-t_1d(kcb) + cldbtm = delt*(zcb-zs_1d(kcb))/delz+t_1d(kcb) + tbar = (cldbtm+t_1d(kcb))/2. + arg = -grav*(zcb-zs_1d(kcb))/rair/tbar + cldbp = p_mb_1d(kcb)*EXP(arg) + delz = zs_1d(kctop+1)-zs_1d(kctop) + delt = t_1d(kctop+1)-t_1d(kctop) + cldtpt = delt*(zctop-zs_1d(kctop))/delz+t_1d(kctop) +! +!----------------------------------------------------------------------- +! +! Calculate cloud lwc profile for cloud base/top pair +! +!----------------------------------------------------------------------- +! + temp = cldbtm + press = cldbp*100.0 + zbase = zcb + nlevel = ((zctop-zcb)/100.0)+1 + IF(nlevel <= 0) nlevel=1 + alw = 0.0 + calw(1)= 0.0 + cali(1)= 0.0 + catk(1)= temp + entr(1)= 1.0 + nlm1 = nlevel-1 + IF(nlm1 < 1) nlm1=1 + zht = zbase + + DO j=1,nlm1 + rl = rlvo+(273.15-temp)*dlvdt + arg = rl*(temp-273.15)/273.15/temp/rv + es = eso*EXP(arg) + qvs1 = 0.622*es/(press-es) +! rho1 = press/(rair*temp) + arg = -grav*dz/rair/temp + p = press*EXP(arg) + + IF(l_prt) THEN + WRITE(6,605) j,zht,temp,press,1000.0*qvs1,es,rl + 605 FORMAT('get_sfm_1d_gnl:',1X,i2,' ht=',f8.0,' T=',f6.1,' P=',f9.1,' qvs=', & + f7.3,' es=',f6.1,' Lv=',e10.3) + END IF +! +!----------------------------------------------------------------------- +! +! Calculate saturated adiabatic lapse rate +! +!----------------------------------------------------------------------- +! + des = es*rl/temp/temp/rv + dtz = -grav*((1.0+0.621*es*rl/(press*rair*temp))/ & + (cp+0.621*rl*des/press)) + zht = zht+dz + press = p + temp = temp+dtz*dz + rl = rlvo+(273.15-temp)*dlvdt + arg = rl*(temp-273.15)/273.15/temp/rv + es2 = eso*EXP(arg) + qvs2 = 0.622*es2/(press-es2) + + alw = alw+(qvs1-qvs2) ! kg/kg + calw(j+1) = alw + + IF (l_prt) THEN + WRITE(6,9015) j,1000.0*calw(j+1),zht + 9015 FORMAT('get_sfm_1d_gnl',1X,'j=',i3,' adiab.lwc =',f7.3,' alt =',f8.0) + END IF +! +!----------------------------------------------------------------------- +! +! Reduction of lwc by entrainment +! +!----------------------------------------------------------------------- +! + ht = (zht-zbase)*.001 +! +!c ------------------------------------------------------------------ +!c +!c skatskii's curve(convective) +!c +!c ------------------------------------------------------------------ +!c if(ht.lt.0.3) then +!c y = -1.667*(ht-0.6) +!c elseif(ht.lt.1.0) then +!c arg1 = b1*b1-4.0*a1*(c1-ht) +!c y = (-b1-sqrt(arg1))/(2.0*a1) +!c elseif(ht.lt.2.9) then +!c arg2 = b2*b2-4.0*a2*(c2-ht) +!c y = (-b2-sqrt(arg2))/(2.0*a2) +!c else +!c y = 0.26 +!c endif +!c +!c ------------------------------------------------------------------ +!c +!c warner's curve(stratiform) +!c +!c ------------------------------------------------------------------ + IF(ht < 0.032) THEN + y = -11.0*ht+1.0 ! y(ht=0.032) = 0.648 + ELSE IF(ht <= 0.177) THEN + y = -1.4*ht+0.6915 ! y(ht=0.177) = 0.4437 + ELSE IF(ht <= 0.726) THEN + y = -0.356*ht+0.505 ! y(ht=0.726) = 0.2445 + ELSE IF(ht <= 1.5) THEN + y = -0.0608*ht+0.2912 ! y(ht=1.5) = 0.2 + ELSE + y = 0.20 + END IF +! +!----------------------------------------------------------------------- +! +! Calculate reduced lwc by entrainment and dilution +! +! Note at -5 C and warmer, all liquid. ! changed from -10 KB +! at -25 C and colder, all ice ! changed from -30 KB +! Linear ramp between. +! +!----------------------------------------------------------------------- +! + IF(temp < 268.15) THEN + IF(temp > 248.15) THEN + fraclw=0.05*(temp-248.15) + ELSE + fraclw=0.0 + END IF + ELSE + fraclw=1.0 + END IF + + tlwc=1000.*y*calw(j+1) ! g/kg + calw(j+1)=tlwc*fraclw + cali(j+1)=tlwc*(1.-fraclw) + catk(j+1)=temp + entr(j+1)=y + + END DO +! +!----------------------------------------------------------------------- +! +! Alternative calculation procedure using the observed or +! inferred in cloud temperature profile +! +!----------------------------------------------------------------------- +! +!----------------------------------------------------------------------- +! +! Obtain profile of LWCs at the given grid point +! +!----------------------------------------------------------------------- +! + + DO ip=2,nz-1 + IF(zs_1d(ip) <= zcb .OR. zs_1d(ip) > zctop) THEN + ql(ip)=0.0 + qi(ip)=0.0 + cldt(ip)=t_1d(ip) + ELSE + DO j=2,nlevel + zcloud = zcb+(j-1)*dz + IF(zcloud >= zs_1d(ip)) THEN + ql(ip) = (zs_1d(ip)-zcloud+100.)*(calw(j)-calw(j-1))*0.01 & + +calw(j-1) + qi(ip) = (zs_1d(ip)-zcloud+100.)*(cali(j)-cali(j-1))*0.01 & + +cali(j-1) + tmpk = (zs_1d(ip)-zcloud+100.)*(catk(j)-catk(j-1))*0.01 & + +catk(j-1) + entc = (zs_1d(ip)-zcloud+100.)*(entr(j)-entr(j-1))*0.01 & + +entr(j-1) + cldt(ip) = (1.-entc)*t_1d(ip) + entc*tmpk + + EXIT + END IF + END DO + END IF + END DO +! +!----------------------------------------------------------------------- +! +! Write out file of lwc comparisons +! +!----------------------------------------------------------------------- +! + RETURN +END SUBROUTINE get_sfm_1d_gnl diff --git a/src/GSD/gsdcloud/hydro_mxr_thompson.f90 b/src/GSD/gsdcloud/hydro_mxr_thompson.f90 new file mode 100644 index 0000000000..aebea2ac75 --- /dev/null +++ b/src/GSD/gsdcloud/hydro_mxr_thompson.f90 @@ -0,0 +1,196 @@ +SUBROUTINE hydro_mxr_thompson (nx, ny, nz, t_3d, p_3d, ref_3d, qr_3d, qnr_3d, qs_3d, istatus, mype ) +! +! PURPOSE: +! Calculate (1) snow mixing ratio, (2) rain mixing ratio, and (3) rain number concentration +! from reflectivity for Thompson microphysics scheme. A Marshall-Palmer drop-size distribution +! is assumed for rain. +! +! HISTORY: +! 2013-01-30: created by David Dowell, Greg Thompson, Ming Hu +! +! ACKNOWLEDGMENTS: +! Donghai Wang and Eric Kemp (code template from pcp_mxr_ferrier) +! +! input argument list: +! nx - no. of lons on subdomain (buffer points on ends) +! ny - no. of lats on subdomain (buffer points on ends) +! nz - no. of levels +! t_3d - 3D background temperature (K) +! p_3d - 3D background pressure (hPa) +! ref_3d - 3D reflectivity in analysis grid (dBZ) +! +! output argument list: +! qr_3d - rain mixing ratio (g/kg) +! qnr_3d - rain number concentration (/kg) +! qs_3d - snow mixing ratio (g/kg) +! istatus - +! + + +!----------------------------------------------------------------------- +! +! Variable Declarations. +! +!----------------------------------------------------------------------- +! + use gsd_kinds, only: r_single, i_kind, r_kind + IMPLICIT NONE +! +!----------------------------------------------------------------------- +! +! INPUT: + INTEGER(i_kind),intent(in) :: nx,ny,nz ! Model grid size + REAL(r_kind), intent(inout) :: ref_3d(nx,ny,nz) ! radar reflectivity (dBZ) + REAL(r_single), intent(in) :: t_3d(nx,ny,nz) ! Temperature (deg. Kelvin) + REAL(r_single), intent(in) :: p_3d(nx,ny,nz) ! Pressure (Pascal) + INTEGER(i_kind),intent(in) :: mype +! +! OUTPUT: + INTEGER(i_kind),intent(out):: istatus + REAL(r_single),intent(out) :: qs_3d(nx,ny,nz) ! snow mixing ratio (g/kg) + REAL(r_single),intent(out) :: qr_3d(nx,ny,nz) ! rain mixing ratio (g/kg) + REAL(r_single),intent(out) :: qnr_3d(nx,ny,nz) ! rain number concentration (/kg) +! +! PARAMETERS: + REAL(r_kind), PARAMETER :: min_ref = 0.0_r_kind ! minimum reflectivity (dBZ) for converting to qs and qr + REAL(r_kind), PARAMETER :: max_ref_snow = 28.0_r_kind ! maximum reflectivity (dBZ) for converting to qs + ! (values above max_ref are treated as max_ref) + REAL(r_kind), PARAMETER :: max_ref_rain = 55.0_r_kind ! maximum reflectivity (dBZ) for converting to qr + ! (values above max_ref are treated as max_ref) + REAL(r_kind), PARAMETER :: n0r_mp = 8.0e6_r_kind ! Marshall-Palmer intercept parameter for rain (m**-4) + REAL(r_kind), PARAMETER :: rd= 287.0_r_kind ! Gas constant for dry air (m**2/(s**2*K)) + REAL(r_kind), PARAMETER :: am_s = 0.069_r_kind + REAL(r_kind), PARAMETER :: bm_s = 2.0_r_kind + REAL(r_kind), PARAMETER :: PI = 3.1415926536_r_kind + REAL(r_kind), PARAMETER :: rho_i = 890.0_r_kind + REAL(r_kind), PARAMETER :: rho_w = 1000.0_r_kind +! +! LOCAL VARIABLES: + INTEGER(i_kind) :: i,j,k + REAL(r_kind) :: rho ! air density (kg m**-3) + REAL(r_kind) :: zes ! reflectivity (m**6 m**-3) associated with snow + REAL(r_kind) :: zer ! reflectivity (m**6 m**-3) associated with rain + REAL(r_kind) :: tc ! temperature (Celsius) + REAL(r_kind) :: rfract ! rain fraction + REAL(r_kind) :: tc0 + REAL(r_kind) :: f + REAL(r_kind) :: loga_ + REAL(r_kind) :: a_ + REAL(r_kind), PARAMETER :: a_min = 1.0e-5_r_kind ! lower bound for a_, to avoid large mixing ratios retrieved + ! for tiny particles sizes in cold temperatures + REAL(r_kind) :: b_ + REAL(r_kind) :: sa(10) + REAL(r_kind) :: sb(10) + REAL(r_kind) :: cse(3) + REAL(r_kind) :: crg(4) + REAL(r_kind) :: am_r + REAL(r_kind) :: oams + REAL(r_kind) :: qs ! snow mixing ratio in kg / kg + REAL(r_kind) :: qr ! rain mixing ratio in kg / kg +! +! for snow moments conversions (from Field et al. 2005) + DATA sa / 5.065339, -0.062659, -3.032362, 0.029469, -0.000285, & + 0.31255, 0.000204, 0.003199, 0.0, -0.015952/ + DATA sb / 0.476221, -0.015896, 0.165977, 0.007468, -0.000141, & + 0.060366, 0.000079, 0.000594, 0.0, -0.003577/ + +!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ +! +! Beginning of executable code... +! +!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ + + istatus=0 + + f = (0.176_r_kind/0.93_r_kind) * (6.0_r_kind/PI)*(6.0_r_kind/PI) * (am_s/rho_i)*(am_s/rho_i) + cse(1) = bm_s + 1.0_r_kind + cse(2) = bm_s + 2.0_r_kind + cse(3) = bm_s * 2.0_r_kind + oams = 1.0_r_kind / am_s + + crg(1) = 24.0_r_kind + crg(2) = 1.0_r_kind + crg(3) = 24.0_r_kind + crg(4) = 5040.0_r_kind + am_r = PI * rho_w / 6.0_r_kind + + DO k = 2,nz-1 + DO j = 2,ny-1 + DO i = 2,nx-1 + + IF (ref_3d(i,j,k) >= min_ref) THEN + + rho = p_3d(i,j,k) / (rd*t_3d(i,j,k)) + tc = t_3d(i,j,k) - 273.15_r_kind + + IF (tc <= 0.0_r_kind) THEN + rfract = 0.0_r_kind + ELSE IF (tc >= 5.0_r_kind) THEN + rfract = 1.0_r_kind + ELSE + rfract = 0.20_r_kind*tc + ENDIF + + zes = ( 10.0_r_kind**( 0.1_r_kind * min(ref_3d(i,j,k), max_ref_snow) ) ) & + * (1.0_r_kind-rfract) & + * 1.0e-18_r_kind ! conversion from (mm**6 m**-3) to (m**6 m**-3) + + zer = ( 10.0_r_kind**( 0.1_r_kind * min(ref_3d(i,j,k), max_ref_rain) ) ) & + * rfract & + * 1.0e-18_r_kind ! conversion from (mm**6 m**-3) to (m**6 m**-3) + + tc0 = MIN(-0.1, tc) + IF (bm_s.lt.(1.999_r_kind) .or. bm_s.gt.(2.001_r_kind)) THEN + PRINT*, 'ABORT (hydro_mxr_thompson): bm_s = ', bm_s + STOP + ENDIF + + ! Calculate bm_s*2 (th) moment. Useful for reflectivity. + loga_ = sa(1) + sa(2)*tc0 + sa(3)*cse(3) & + + sa(4)*tc0*cse(3) + sa(5)*tc0*tc0 & + + sa(6)*cse(3)*cse(3) + sa(7)*tc0*tc0*cse(3) & + + sa(8)*tc0*cse(3)*cse(3) + sa(9)*tc0*tc0*tc0 & + + sa(10)*cse(3)*cse(3)*cse(3) + a_ = max( 10.0_r_kind ** loga_, a_min ) + b_ = sb(1) + sb(2)*tc0 + sb(3)*cse(3) + sb(4)*tc0*cse(3) & + + sb(5)*tc0*tc0 + sb(6)*cse(3)*cse(3) & + + sb(7)*tc0*tc0*cse(3) + sb(8)*tc0*cse(3)*cse(3) & + + sb(9)*tc0*tc0*tc0 + sb(10)*cse(3)*cse(3)*cse(3) + + qs = ( (zes / (f*a_)) ** (1.0_r_kind / b_) ) / (rho*oams) + qs_3d(i,j,k) = 1000.0_r_kind * qs ! convert from kg / kg to g / kg + + qr = n0r_mp * am_r * crg(3) / rho * (zer / (n0r_mp*crg(4)))**(4.0_r_kind/7.0_r_kind) + qnr_3d(i,j,k) = (n0r_mp/rho)**(3.0_r_kind/4.0_r_kind) & + * (qr / (am_r * crg(3)))**(1.0_r_kind/4.0_r_kind) + + qnr_3d(i,j,k) = max(1.0_r_kind, qnr_3d(i,j,k)) + qr_3d(i,j,k) = 1000.0_r_kind * qr ! convert from kg / kg to g / kg + + +! if(mype==51 ) then +! write(*,'(a10,3i5,2f10.5,3f8.2)') 'b=',i,j,k,qs_3d(i,j,k),qr_3d(i,j,k),ref_3d(i,j,k),& +! p_3d(i,j,k)/100.0,tc +! endif + + + ELSE + + qs_3d(i,j,k) = -999._r_kind + qr_3d(i,j,k) = -999._r_kind + qnr_3d(i,j,k) = -999._r_kind + + END IF + + END DO ! k + END DO ! i + END DO ! j +! +! PRINT*,'finish hydro_mxr_thompson...' +! +!----------------------------------------------------------------------- +! + istatus = 1 +! + RETURN +END SUBROUTINE hydro_mxr_thompson diff --git a/src/GSD/gsdcloud/kinds.f90 b/src/GSD/gsdcloud/kinds.f90 new file mode 100755 index 0000000000..3410f68b43 --- /dev/null +++ b/src/GSD/gsdcloud/kinds.f90 @@ -0,0 +1,105 @@ +module gsd_kinds +!$$$ module documentation block +! . . . . +! module: kinds +! prgmmr: treadon org: np23 date: 2004-08-15 +! +! abstract: Module to hold specification kinds for variable declaration. +! This module is based on (copied from) Paul vanDelst's +! type_kinds module found in the community radiative transfer +! model +! +! module history log: +! 2004-08-15 treadon +! +! Subroutines Included: +! +! Functions Included: +! +! remarks: +! The numerical data types defined in this module are: +! i_byte - specification kind for byte (1-byte) integer variable +! i_short - specification kind for short (2-byte) integer variable +! i_long - specification kind for long (4-byte) integer variable +! i_llong - specification kind for double long (8-byte) integer variable +! r_single - specification kind for single precision (4-byte) real variable +! r_double - specification kind for double precision (8-byte) real variable +! r_quad - specification kind for quad precision (16-byte) real variable +! +! i_kind - generic specification kind for default integer +! r_kind - generic specification kind for default floating point +! +! +! attributes: +! language: f90 +! machine: ibm RS/6000 SP +! +!$$$ end documentation block + implicit none + private + +! Integer type definitions below + +! Integer types + integer, parameter, public :: i_byte = selected_int_kind(1) ! byte integer + integer, parameter, public :: i_short = selected_int_kind(4) ! short integer + integer, parameter, public :: i_long = selected_int_kind(8) ! long integer + integer, parameter, private :: llong_t = selected_int_kind(16) ! llong integer + integer, parameter, public :: i_llong = max( llong_t, i_long ) + +! Expected 8-bit byte sizes of the integer kinds + integer, parameter, public :: num_bytes_for_i_byte = 1 + integer, parameter, public :: num_bytes_for_i_short = 2 + integer, parameter, public :: num_bytes_for_i_long = 4 + integer, parameter, public :: num_bytes_for_i_llong = 8 + +! Define arrays for default definition + integer, parameter, private :: num_i_kinds = 4 + integer, parameter, dimension( num_i_kinds ), private :: integer_types = (/ & + i_byte, i_short, i_long, i_llong /) + integer, parameter, dimension( num_i_kinds ), private :: integer_byte_sizes = (/ & + num_bytes_for_i_byte, num_bytes_for_i_short, & + num_bytes_for_i_long, num_bytes_for_i_llong /) + +! Default values +! **** CHANGE THE FOLLOWING TO CHANGE THE DEFAULT INTEGER TYPE KIND *** + integer, parameter, private :: default_integer = 3 ! 1=byte, + ! 2=short, + ! 3=long, + ! 4=llong + integer, parameter, public :: i_kind = integer_types( default_integer ) + integer, parameter, public :: num_bytes_for_i_kind = & + integer_byte_sizes( default_integer ) + + +! Real definitions below + +! Real types + integer, parameter, public :: r_single = selected_real_kind(6) ! single precision + integer, parameter, public :: r_double = selected_real_kind(15) ! double precision + integer, parameter, private :: quad_t = selected_real_kind(20) ! quad precision + integer, parameter, public :: r_quad = max( quad_t, r_double ) + +! Expected 8-bit byte sizes of the real kinds + integer, parameter, public :: num_bytes_for_r_single = 4 + integer, parameter, public :: num_bytes_for_r_double = 8 + integer, parameter, public :: num_bytes_for_r_quad = 16 + +! Define arrays for default definition + integer, parameter, private :: num_r_kinds = 3 + integer, parameter, dimension( num_r_kinds ), private :: real_kinds = (/ & + r_single, r_double, r_quad /) + integer, parameter, dimension( num_r_kinds ), private :: real_byte_sizes = (/ & + num_bytes_for_r_single, num_bytes_for_r_double, & + num_bytes_for_r_quad /) + +! Default values +! **** CHANGE THE FOLLOWING TO CHANGE THE DEFAULT REAL TYPE KIND *** + integer, parameter, private :: default_real = 2 ! 1=single, + ! 2=double, + ! 3=quad + integer, parameter, public :: r_kind = real_kinds( default_real ) + integer, parameter, public :: num_bytes_for_r_kind = & + real_byte_sizes( default_real ) + +end module gsd_kinds diff --git a/src/GSD/gsdcloud/make.dependencies b/src/GSD/gsdcloud/make.dependencies new file mode 100644 index 0000000000..11a2075f69 --- /dev/null +++ b/src/GSD/gsdcloud/make.dependencies @@ -0,0 +1,33 @@ +kinds.o : kinds.f90 +constants.o : constants.f90 kinds.o + +ARPS_cldLib.o : ARPS_cldLib.f90 kinds.o constants.o +BackgroundCld.o : BackgroundCld.f90 kinds.o constants.o +BckgrndCC.o : BckgrndCC.f90 kinds.o constants.o +CheckCld.o : CheckCld.f90 kinds.o constants.o +radar_ref2tten.o : radar_ref2tten.f90 kinds.o constants.o +PrecipMxr_radar.o : PrecipMxr_radar.f90 kinds.o constants.o +PrecipType.o : PrecipType.f90 kinds.o constants.o +TempAdjust.o : TempAdjust.f90 kinds.o constants.o +adaslib.o : adaslib.f90 kinds.o constants.o +build_missing_REFcone.o : build_missing_REFcone.f90 kinds.o constants.o +cloudCover_NESDIS.o : cloudCover_NESDIS.f90 kinds.o constants.o +cloudCover_Surface.o : cloudCover_Surface.f90 kinds.o constants.o +cloudCover_radar.o : cloudCover_radar.f90 kinds.o constants.o +cloudLWC.o : cloudLWC.f90 kinds.o constants.o +cloudLayers.o : cloudLayers.f90 kinds.o constants.o +cloudType.o : cloudType.f90 kinds.o constants.o +convert_lghtn2ref.o : convert_lghtn2ref.f90 kinds.o constants.o +cloud_saturation.o : cloud_saturation.f90 kinds.o +get_sfm_1d_gnl.o : get_sfm_1d_gnl.f90 kinds.o constants.o +vinterp_radar_ref.o : vinterp_radar_ref.f90 kinds.o constants.o +map_ctp.o : map_ctp.f90 kinds.o constants.o +mthermo.o : mthermo.f90 kinds.o constants.o +pcp_mxr_ARPSlib.o : pcp_mxr_ARPSlib.f90 kinds.o constants.o +## q_adjust.o : q_adjust.f90 kinds.o constants.o +read_Lightning_cld.o : read_Lightning_cld.f90 kinds.o constants.o +read_NESDIS.o : read_NESDIS.f90 kinds.o constants.o +read_radar_ref.o : read_radar_ref.f90 kinds.o constants.o +read_Surface.o :read_Surface.f90 kinds.o constants.o +read_nasalarc_cld.o : read_nasalarc_cld.f90 kinds.o constants.o +smooth.o : smooth.f90 kinds.o constants.o diff --git a/src/GSD/gsdcloud/make.filelist b/src/GSD/gsdcloud/make.filelist new file mode 100644 index 0000000000..9b943ba0b8 --- /dev/null +++ b/src/GSD/gsdcloud/make.filelist @@ -0,0 +1,35 @@ +SRC_FILES = ARPS_cldLib.f90 \ + BackgroundCld.f90 \ + BckgrndCC.f90 \ + radar_ref2tten.f90 \ + PrecipMxr_radar.f90 \ + PrecipType.f90 \ + TempAdjust.f90 \ + adaslib.f90 \ + build_missing_REFcone.f90 \ + cloudCover_NESDIS.f90 \ + cloudCover_Surface.f90 \ + cloudCover_radar.f90 \ + cloudLWC.f90 \ + cloudLayers.f90 \ + cloudType.f90 \ + cloud_saturation.f90 \ + convert_lghtn2ref.f90 \ + get_sfm_1d_gnl.f90 \ + vinterp_radar_ref.f90 \ + map_ctp.f90 \ + mthermo.f90 \ + pcp_mxr_ARPSlib.f90 \ + read_Lightning_cld.f90 \ + read_NESDIS.f90 \ + read_radar_ref.f90 \ + read_Surface.f90 \ + read_nasalarc_cld.f90 \ + smooth.f90 \ + constants.f90 \ + kinds.f90 \ + pbl_height.f90 \ + hydro_mxr_thompson.f90 \ + map_ctp_lar.f90 + +OBJ_FILES =${SRC_FILES:.f90=.o} diff --git a/src/GSD/gsdcloud/map_ctp.f90 b/src/GSD/gsdcloud/map_ctp.f90 new file mode 100644 index 0000000000..df72159bbd --- /dev/null +++ b/src/GSD/gsdcloud/map_ctp.f90 @@ -0,0 +1,291 @@ +subroutine map_ctp (ib,jb,nx,ny,nn_obs,numsao,data_s,sat_ctp,sat_tem,w_frac,npts_rad,ioption) + +! +!$$$ subprogram documentation block +! . . . . +! subprogram: map_ctp map GOES cloud product to analysis grid +! +! PRGMMR: Ming Hu ORG: GSD/AMB DATE: 2006-03_10 +! +! ABSTRACT: +! This subroutine map GOES cloud product to analysis grid +! +! PROGRAM HISTORY LOG: +! 2009-01-20 Hu Add NCO document block +! +! +! input argument list: +! ib - begin i point of this domain +! jb - begin j point of this domain +! nx - no. of lons on subdomain (buffer points on ends) +! ny - no. of lats on subdomain (buffer points on ends) +! nn_obs - 1st dimension of observation arry data_s +! numsao - number of observation +! data_s - observation array for GOES cloud products +! npts_rad - impact radius +! +! output argument list: +! sat_ctp - GOES cloud top pressure in analysis grid +! sat_tem - GOES cloud top temperature in analysis grid +! w_frac - GOES cloud coverage in analysis grid +! +! USAGE: +! INPUT FILES: +! +! OUTPUT FILES: +! +! REMARKS: +! +! adapted according to RUC subroutine rd_cld +! * +! * This routine reads NESDIS (Madison, WI) cloud product produced +! * from GOES sounder data. The original product is reprocessed onto +! * MAPS40 grid boxes. There could be more than one cloud product +! * in a grid-box, so we use the nearest one that falls in the +! * grid. The routine combines GOES-8 and 10 products. +! +! ===== History ===== +! +! * Internal variables: +! CTP_E, CTP_W Soft-linked filename for ascii GOES Clouds +! +! * Working variables: +! +! * Working variables used for sorting max size of 10: +! Pxx, Txx, xdist,xxxdist (R4) +! Fxx, Nxx, index, jndex (I4) +! ioption (I4) = 1 if selection is nearest neighbor +! = 2 if selection is median of samples +! +! +! * Output variables on gridpoint (Nx,Ny): +! sat_ctp, sat_tem (R4) Cloud-top pressure and temperature +! w_frac (R4) Effective fractional cloud coverage, option=1 +! fractional coverage within RUC grid, option=2 +! w_eca (R4) Effective fractional cloud regardless option +! (effective cloud amount - eca) +! nlev_cld (I4) Number of cloud levels. TO BE USED LATER +! to incorporate multi-level cloud +! +! * Calling routines +! sorting +! sortmed +! +! * +! +! ATTRIBUTES: +! LANGUAGE: FORTRAN 90 +! MACHINE: Linux cluster (WJET) +! +!$$$ +! +!_____________________________________________________________________ +! + + use gsd_kinds, only: r_kind,r_single,i_kind + use constants, only: zero,one_tenth,one,deg2rad + + implicit none + +! input-file variables: + INTEGER(i_kind),intent(in) :: Nx, Ny + INTEGER(i_kind),intent(in) :: ib, jb + INTEGER(i_kind),intent(in) :: numsao, nn_obs + INTEGER(i_kind),intent(in) :: npts_rad + INTEGER(i_kind),intent(in) :: ioption + real(r_kind),dimension(nn_obs,numsao):: data_s +! Output + real(r_single), intent(out) :: sat_ctp(Nx,Ny) + real(r_single), intent(out) :: sat_tem(Nx,Ny) + real(r_single), intent(out) :: w_frac(Nx,Ny) +! +! misc + integer(i_kind) :: nfov + parameter (nfov=60) + +! Working + real(r_kind) :: Pxx(Nx,Ny,nfov),Txx(Nx,Ny,nfov) + real(r_kind) :: xdist(Nx,Ny,nfov), xxxdist(nfov) + real(r_kind) :: fr,sqrt + integer(i_kind) :: Nxx(Nx,Ny,nfov),index(Nx,Ny), jndex(nfov) + integer(i_kind) :: ipt,ii,jj,i,med_pt,ii1,jj1 + + real(r_kind) :: xc + real(r_kind) :: yc + + real(r_single) :: w_eca(Nx,Ny) + integer(i_kind) :: nlev_cld(Nx,Ny) + integer(i_kind) :: ios + +! +! * Initialize outputs since GOES sounder do not scan all MAPS domain +! + do jj=1,Ny + do ii=1,Nx + w_eca (ii,jj) =-99999._r_kind + index(ii,jj) = 0 + enddo + enddo + +! -- set ios as failed unless valid data points are found below + ios = 0 + +! ----------------------------------------------------------- +! ----------------------------------------------------------- +! Map each FOV onto RR grid points +! ----------------------------------------------------------- +! ----------------------------------------------------------- + do ipt=1,numsao + + xc=data_s(2,ipt) - ib + 1.0_r_kind + yc=data_s(3,ipt) - jb + 1.0_r_kind + if(data_s(8,ipt) > 50 ) cycle + +! * XC,YC should be within subdomain boundary, i.e., XC,YC >0 + + if(XC >= 1._r_kind .and. XC < Nx .and. & + YC >= 1._r_kind .and. YC < Ny) then + ii1 = int(xc+0.5_r_kind) + jj1 = int(yc+0.5_r_kind) + + do jj = max(1,jj1-npts_rad), min(ny,jj1+npts_rad) + if (jj1-1 >= 1 .and. jj1+1 <= ny) then + do ii = max(1,ii1-npts_rad), min(nx,ii1+npts_rad) + if (ii1-1 >= 1 .and. ii1+1 <= nx) then + +! * We check multiple data within gridbox + + if (index(ii,jj) < nfov) then + index(ii,jj) = index(ii,jj) + 1 + + Pxx(ii,jj,index(ii,jj)) = data_s(4,ipt) + Txx(ii,jj,index(ii,jj)) = data_s(6,ipt) +!mhu Nxx(ii,jj,index(ii,jj)) = int(data_s(5,ipt)) +!mhu no cloud amount available, assign to 100 + Nxx(ii,jj,index(ii,jj)) = 100 + nlev_cld(ii,jj) = 1 + xdist(ii,jj,index(ii,jj)) = sqrt( & + (XC+1-ii)**2 + (YC+1-jj)**2) + end if + endif + enddo ! ii + endif + enddo ! jj + endif ! observation is in the domain + enddo ! ipt +! +! * ioption = 1 is nearest neighrhood +! * ioption = 2 is median of cloudy fov + ! remove hard code choice ioption = 2 +! + do jj = 1,Ny + do ii = 1,Nx + if ((index(ii,jj) >= 1 .and. index(ii,jj) < 3) .and. npts_rad > 1) then + sat_ctp(ii,jj) = Pxx(ii,jj,1) + sat_tem(ii,jj) = Txx(ii,jj,1) + w_frac(ii,jj) = float(Nxx(ii,jj,1))/100. + w_eca(ii,jj) = float(Nxx(ii,jj,1))/100. + + elseif(index(ii,jj) >= 3) then + +! * We decided to use nearest neighborhood for ECA values, +! * a kind of convective signal from GOES platform... + + do i=1,index(ii,jj) + jndex(i) = i + xxxdist(i) = xdist(ii,jj,i) + enddo + call sorting(xxxdist,index(ii,jj),jndex) + w_eca(ii,jj) = float(Nxx(ii,jj,jndex(1)))/100._r_kind +! * Sort to find closest distance if more than one sample + if(ioption == 1) then !nearest neighborhood + do i=1,index(ii,jj) + jndex(i) = i + xxxdist(i) = xdist(ii,jj,i) + enddo + call sorting(xxxdist,index(ii,jj),jndex) + sat_ctp(ii,jj) = Pxx(ii,jj,jndex(1)) + sat_tem(ii,jj) = Txx(ii,jj,jndex(1)) + w_frac(ii,jj) = float(Nxx(ii,jj,jndex(1)))/100._r_kind + endif +! * Sort to find median value + if(ioption == 2) then !pick median + do i=1,index(ii,jj) + jndex(i) = i + xxxdist(i) = Pxx(ii,jj,i) + enddo + call sortmed(xxxdist,index(ii,jj),jndex,fr) + med_pt = index(ii,jj)/2 + 1 + sat_ctp(ii,jj) = Pxx(ii,jj,jndex(med_pt)) + sat_tem(ii,jj) = Txx(ii,jj,jndex(med_pt)) + w_frac(ii,jj) = fr + endif + endif + enddo !ii + enddo !jj + + return +end subroutine map_ctp + +subroutine sorting(d,n,is) + use gsd_kinds, only: r_kind,i_kind + implicit none + + integer(i_kind), intent(in) :: n + real(r_kind) , intent(inout) :: d(n) + integer(i_kind), intent(inout) :: is(n) +! + integer(i_kind) :: nm1,ip1,iold,i,j + real(r_kind) :: temp +! +! + nm1 = n-1 + do 10 i=1,nm1 + ip1 = i+1 + do 10 j=ip1,n + if(d(i) <= d(j)) goto 10 + temp = d(i) + d(i) = d(j) + d(j) = temp + iold = is(i) + is(i) = is(j) + is(j) = iold + 10 continue + return +end subroutine sorting + +subroutine sortmed(p,n,is,f) + use gsd_kinds, only: r_kind,i_kind + implicit none + real(r_kind), intent(inout) :: p(n) + integer(i_kind), intent(in) :: n + integer(i_kind), intent(inout) :: is(n) +! * count cloudy fov + real(r_kind), intent(out) :: f + integer(i_kind) :: cfov +! + integer(i_kind) :: i,j,nm1,ip1,iold + real(r_kind) :: temp +! +! +! + cfov = 0 + do i=1,n + if(p(i) < 999._r_kind) cfov = cfov + 1 + enddo + f = float(cfov)/(max(1,n)) +! cloud-top pressure is sorted high cld to clear + nm1 = n-1 + do 10 i=1,nm1 + ip1 = i+1 + do 10 j=ip1,n + if(p(i)<=p(j)) goto 10 + temp = p(i) + p(i) = p(j) + p(j) = temp + iold = is(i) + is(i) = is(j) + is(j) = iold + 10 continue + return +end subroutine sortmed diff --git a/src/GSD/gsdcloud/map_ctp_lar.f90 b/src/GSD/gsdcloud/map_ctp_lar.f90 new file mode 100644 index 0000000000..09034dc358 --- /dev/null +++ b/src/GSD/gsdcloud/map_ctp_lar.f90 @@ -0,0 +1,258 @@ +subroutine map_ctp_lar(mype,ib,jb,nx,ny,nn_obs,numsao,data_s,sat_ctp,sat_tem,w_frac,w_lwp,nlev_cld,ioption) + +! +!$$$ subprogram documentation block +! . . . . +! subprogram: map_ctp map GOES cloud product to analysis grid +! +! PRGMMR: Ming Hu ORG: GSD/AMB DATE: 2006-03_10 +! +! ABSTRACT: +! This subroutine map GOES cloud product to analysis grid +! +! PROGRAM HISTORY LOG: +! 2009-01-20 Hu Add NCO document block +! +! +! input argument list: +! ib - begin i point of this domain +! jb - begin j point of this domain +! nx - no. of lons on subdomain (buffer points on ends) +! ny - no. of lats on subdomain (buffer points on ends) +! nn_obs - 1st dimension of observation arry data_s +! numsao - number of observation +! data_s - observation array for GOES cloud products +! +! output argument list: +! sat_ctp - GOES cloud top pressure in analysis grid +! sat_tem - GOES cloud top temperature in analysis grid +! w_frac - GOES cloud coverage in analysis grid +! +! USAGE: +! INPUT FILES: +! +! OUTPUT FILES: +! +! REMARKS: +! +! adapted according to RUC subroutine rd_cld +! * +! * This routine reads NESDIS (Madison, WI) cloud product produced +! * from GOES sounder data. The original product is reprocessed onto +! * MAPS40 grid boxes. There could be more than one cloud product +! * in a grid-box, so we use the nearest one that falls in the +! * grid. The routine combines GOES-8 and 10 products. +! +! ===== History ===== +! +! * Internal variables: +! CTP_E, CTP_W Soft-linked filename for ascii GOES Clouds +! +! * Working variables: +! +! * Working variables used for sorting max size of 10: +! Pxx, Txx, xdist,xxxdist (R4) +! Fxx, Nxx, index, jndex (I4) +! ioption (I4) = 1 if selection is nearest neighbor +! = 2 if selection is median of samples +! +! +! * Output variables on gridpoint (Nx,Ny): +! sat_ctp, sat_tem (R4) Cloud-top pressure and temperature +! w_frac (R4) Effective fractional cloud coverage, option=1 +! fractional coverage within RUC grid, option=2 +! w_eca (R4) Effective fractional cloud regardless option +! (effective cloud amount - eca) +! nlev_cld (I4) Number of cloud levels. TO BE USED LATER +! to incorporate multi-level cloud +! +! * Calling routines +! sorting +! sortmed +! +! * +! +! ATTRIBUTES: +! LANGUAGE: FORTRAN 90 +! MACHINE: Linux cluster (WJET) +! +!$$$ +! +!_____________________________________________________________________ +! + + use gsd_kinds, only: r_kind,r_single,i_kind + use constants, only: zero,one_tenth,one,deg2rad + + implicit none + + integer(i_kind),intent(in) :: mype +! input-file variables: + INTEGER(i_kind),intent(in) :: Nx, Ny + INTEGER(i_kind),intent(in) :: ib, jb + INTEGER(i_kind),intent(in) :: numsao, nn_obs + INTEGER(i_kind),intent(in) :: ioption + real(r_kind),dimension(nn_obs,numsao):: data_s +! Output + real(r_single), intent(out) :: sat_ctp(Nx,Ny) + real(r_single), intent(out) :: sat_tem(Nx,Ny) + real(r_single), intent(out) :: w_lwp(Nx,Ny) + real(r_single), intent(out) :: w_frac(Nx,Ny) +! +! misc + integer(i_kind) :: nfov + parameter (nfov=650) + +! Working + real(r_kind) :: Pxx(Nx,Ny,nfov),Txx(Nx,Ny,nfov) + real(r_kind) :: PHxx(Nx,Ny,nfov),WPxx(Nx,Ny,nfov) + real(r_kind) :: xdist(Nx,Ny,nfov), xxxdist(nfov) + real(r_kind) :: fr,sqrt + integer(i_kind) :: Nxx(Nx,Ny,nfov) + integer(i_kind) :: index(Nx,Ny), jndex(nfov) + integer(i_kind) :: ipt,ii,jj,i,med_pt, & + ii1,jj1 + + real(r_kind) :: xc + real(r_kind) :: yc + +! real(r_single) :: w_eca(Nx,Ny) + integer(i_kind) :: nlev_cld(Nx,Ny) + integer(i_kind) :: ios,cfov + +! +! * Initialize outputs since GOES sounder do not scan all MAPS domain +! + do jj=1,Ny + do ii=1,Nx + sat_ctp (ii,jj) =-99999._r_kind + sat_tem (ii,jj) =-99999._r_kind + w_lwp (ii,jj) =-99999._r_kind + w_frac (ii,jj) =-99999._r_kind + nlev_cld (ii,jj) =-99999 + index(ii,jj) = 0 + enddo + enddo + +! -- set ios as failed unless valid data points are found below + ios = 0 + +! ----------------------------------------------------------- +! ----------------------------------------------------------- +! Map each FOV onto RR grid points +! ----------------------------------------------------------- +! ----------------------------------------------------------- + do ipt=1,numsao + + xc=data_s(2,ipt) - ib + 1.0_r_kind + yc=data_s(3,ipt) - jb + 1.0_r_kind + +! skip the bad observations + if(abs(data_s(6,ipt)+9.0_r_single) < 0.1_r_single) cycle + +! * XC,YC should be within subdomain boundary, i.e., XC,YC >0 + + if(XC >= 1._r_kind .and. XC < Nx .and. & + YC >= 1._r_kind .and. YC < Ny) then + ii1 = int(xc+0.5_r_kind) + jj1 = int(yc+0.5_r_kind) + + do jj = max(1,jj1-1), min(ny,jj1+1) + if (jj1-1 >= 1 .and. jj1+1 <= ny) then + do ii = max(1,ii1-1), min(nx,ii1+1) + if (ii1-1 >= 1 .and. ii1+1 <= nx) then + +! * We check multiple data within gridbox + + if (index(ii,jj) < nfov) then + index(ii,jj) = index(ii,jj) + 1 + + Pxx(ii,jj,index(ii,jj)) = data_s(4,ipt) + Txx(ii,jj,index(ii,jj)) = data_s(5,ipt) + PHxx(ii,jj,index(ii,jj)) = data_s(6,ipt) + WPxx(ii,jj,index(ii,jj)) = data_s(7,ipt) +!mhu Nxx(ii,jj,index(ii,jj)) = int(data_s(5,ipt)) +!mhu no cloud amount available, assign to 100 + Nxx(ii,jj,index(ii,jj)) = 100 + nlev_cld(ii,jj) = 1 +! write(6,*)'sat_tem1::',index(ii,jj),data_s(4,ipt),data_s(5,ipt),data_s(6,ipt),data_s(7,ipt) + xdist(ii,jj,index(ii,jj)) = sqrt( & + (XC+1-ii)**2 + (YC+1-jj)**2) + end if + endif + enddo ! ii + endif + enddo ! jj + endif ! observation is in the domain + enddo ! ipt +! +! * ioption = 1 is nearest neighrhood +! * ioption = 2 is median of cloudy fov + ! remove hard code choice ioption = 2 +! + do jj = 1,Ny + do ii = 1,Nx + if (index(ii,jj) < 3 ) then +! sat_ctp(ii,jj) = Pxx(ii,jj,1) +! sat_tem(ii,jj) = Txx(ii,jj,1) +! w_frac(ii,jj) = float(Nxx(ii,jj,1))/100. +! w_eca(ii,jj) = float(Nxx(ii,jj,1))/100. + + elseif(index(ii,jj) >= 3) then + +! * We decided to use nearest neighborhood for ECA values, +! * a kind of convective signal from GOES platform... +! +! do i=1,index(ii,jj) +! jndex(i) = i +! xxxdist(i) = xdist(ii,jj,i) +! enddo +! call sorting(xxxdist,index(ii,jj),jndex) +! w_eca(ii,jj) = float(Nxx(ii,jj,jndex(1)))/100._r_kind +! * Sort to find closest distance if more than one sample + if(ioption == 1) then !nearest neighborhood + do i=1,index(ii,jj) + jndex(i) = i + xxxdist(i) = xdist(ii,jj,i) + enddo + call sorting(xxxdist,index(ii,jj),jndex) + sat_ctp(ii,jj) = Pxx(ii,jj,jndex(1)) + sat_tem(ii,jj) = Txx(ii,jj,jndex(1)) + w_frac(ii,jj) = float(Nxx(ii,jj,jndex(1)))/100._r_kind + endif +! * Sort to find median value + if(ioption == 2) then !pick median + do i=1,index(ii,jj) + jndex(i) = i + xxxdist(i) = Pxx(ii,jj,i) + enddo + call sortmed(xxxdist,index(ii,jj),jndex,fr) + med_pt = index(ii,jj)/2 + 1 + sat_ctp(ii,jj) = Pxx(ii,jj,jndex(med_pt)) + sat_tem(ii,jj) = Txx(ii,jj,jndex(med_pt)) + w_lwp(ii,jj) = WPxx(ii,jj,jndex(med_pt)) + if ( abs(sat_ctp(ii,jj)+20.0_r_single) < 0.1_r_single) then + sat_ctp(ii,jj) = 1013. ! hPa - no cloud + w_frac(ii,jj)=0.0 + nlev_cld(ii,jj) = 0 + end if + +! +! cloud fraction based on phase (0 are clear), what about -9 ???? + if( sat_ctp(ii,jj) < 1012.99) then + cfov = 0 + do i=1,index(ii,jj) + if(PHxx(ii,jj,i) .gt. 0.1) cfov = cfov + 1 + enddo + w_frac(ii,jj) = float(cfov)/(max(1,index(ii,jj))) ! fraction + if( w_frac(ii,jj) > 0.01 ) nlev_cld(ii,jj) = 1 + endif + +! write(6,'(a,2I4,I5,2f10.2)')'sat_tem2::',ii,jj,index(ii,jj),sat_ctp(ii,jj),sat_tem(ii,jj) + endif + endif + enddo !ii + enddo !jj + + return +end subroutine map_ctp_lar diff --git a/src/GSD/gsdcloud/mthermo.f90 b/src/GSD/gsdcloud/mthermo.f90 new file mode 100644 index 0000000000..2e2a0b7d39 --- /dev/null +++ b/src/GSD/gsdcloud/mthermo.f90 @@ -0,0 +1,229 @@ +! +!$$$ subprogram documentation block +! . . . . +! ABSTRACT: +! This file collects subroutines and functions related to thermodynamic calculations +! +! PROGRAM HISTORY LOG: +! 2009-01-20 Hu Add NCO document block +! 2010-05-03 Hu Clean the code +! +! +! input argument list: +! +! output argument list: +! +! USAGE: +! INPUT FILES: +! +! OUTPUT FILES: +! +! REMARKS: +! +! ATTRIBUTES: +! LANGUAGE: FORTRAN 90 +! MACHINE: Linux cluster (WJET) +! +!$$$ +! +!_____________________________________________________________________ +! + function esat(t) +! +! this function returns the saturation vapor pressure over +! water (mb) given the temperature (celsius). +! the algorithm is due to nordquist, w.s.,1973: "numerical approxima- +! tions of selected meteorlolgical parameters for cloud physics prob- +! lems," ecom-5475, atmospheric sciences laboratory, u.s. army +! electronics command, white sands missile range, new mexico 88002. + use gsd_kinds, only: r_single,i_kind,r_kind + implicit none + real(r_kind),intent(in) :: t + real(r_single) :: tk,p1,p2,c1 + real(r_kind) :: esat + + tk = t+273.15 + p1 = 11.344-0.0303998*tk + p2 = 3.49149-1302.8844/tk + c1 = 23.832241-5.02808*alog10(tk) + esat = 10.**(c1-1.3816E-7*10.**p1+8.1328E-3*10.**p2-2949.076/tk) + return + end function esat + + function eslo(t) +! +! this function returns the saturation vapor pressure over liquid +! water eslo (millibars) given the temperature t (celsius). the +! formula is due to lowe, paul r.,1977: an approximating polynomial +! for the computation of saturation vapor pressure, journal of applied +! meteorology, vol 16, no. 1 (january), pp. 100-103. +! the polynomial coefficients are a0 through a6. + use gsd_kinds, only: r_single,i_kind,r_kind + implicit none +! + real(r_kind), intent(in) :: t + real(r_kind) :: eslo + + real(r_kind) :: a0,a1,a2,a3,a4,a5,a6 + real(r_kind) :: es + + data a0,a1,a2,a3,a4,a5,a6 & + /6.107799961, 4.436518521E-01, 1.428945805E-02, & + 2.650648471E-04, 3.031240396E-06, 2.034080948E-08, & + 6.136820929E-11/ + es = a0+t*(a1+t*(a2+t*(a3+t*(a4+t*(a5+a6*t))))) + IF (es < 0.) es = 0. + eslo = es + return + end function eslo + + function tda(o,p) +! +! this function returns the temperature tda (celsius) on a dry adiabat +! at pressure p (millibars). the dry adiabat is given by +! potential temperature o (celsius). the computation is based on +! poisson's equation. + use gsd_kinds, only: r_single,i_kind,r_kind + implicit none + real(r_kind), intent(in) :: o,p + real(r_kind) :: tda + + tda= (o+273.15)*((p*.001)**.286)-273.15 + return + end function tda + + function tmr(w,p) +! +! this function returns the temperature (celsius) on a mixing +! ratio line w (g/kg) at pressure p (mb). the formula is given in +! table 1 on page 7 of stipanuk (1973). +! +! initialize constants + use gsd_kinds, only: r_single,i_kind,r_kind + implicit none + real(r_kind), intent(in) :: w,p + real(r_kind) :: tmr + + real(r_kind) :: c1,c2,c3,c4,c5,c6 + real(r_kind) :: x,tmrk + real(r_single) :: y + + data c1/.0498646455/,c2/2.4082965/,c3/7.07475/ + data c4/38.9114/,c5/.0915/,c6/1.2035/ + + y=w*p/(622.+w) + x= alog10(y) + tmrk= 10.**(c1*x+c2)-c3+c4*((10.**(c5*x)-c6)**2.) + tmr= tmrk-273.15 + return + end function tmr + + function tsa(os,p) +! +! this function returns the temperature tsa (celsius) on a saturation +! adiabat at pressure p (millibars). os is the equivalent potential +! temperature of the parcel (celsius). sign(a,b) replaces the +! algebraic sign of a with that of b. +! b is an empirical constant approximately equal to 0.001 of the latent +! heat of vaporization for water divided by the specific heat at constant +! pressure for dry air. + use gsd_kinds, only: r_single,i_kind,r_kind + implicit none + real(r_kind), intent(in) :: os,p + real(r_kind) :: tsa + + real(r_kind) :: a,b,d,tq,x,tqk,w + integer :: i + + data b/2.6518986/ + a= os+273.15 + +! tq is the first guess for tsa. + + tq= 253.15 + +! d is an initial value used in the iteration below. + + d= 120. + +! iterate to obtain sufficient accuracy....see table 1, p.8 +! of stipanuk (1973) for equation used in iteration. + + do i= 1,12 + tqk= tq-273.15 + d= d/2. + x= a*exp(-b*w(tqk,p)/tq)-tq*((1000./p)**.286) + IF (abs(x) < 1E-7) GOTO 2 + tq= tq+sign(d,x) + end do +2 tsa= tq-273.15 + return + end function tsa + + function tw(t,td,p) +! this function returns the wet-bulb temperature tw (celsius) +! given the temperature t (celsius), dew point td (celsius) +! and pressure p (mb). see p.13 in stipanuk (1973), referenced +! above, for a description of the technique. +! +! +! determine the mixing ratio line thru td and p. + use gsd_kinds, only: r_single,i_kind,r_kind + implicit none + real(r_kind), intent(in) :: t,td,p + real(r_kind) :: tw + + real(r_kind) :: aw,ao,pi,tmr,tda,ti,aos,tsa,w,x + integer :: i + + aw = w(td,p) +! +! determine the dry adiabat thru t and p. + + ao = (t+273.15)*((1000./p)**.286)-273.15 + pi = p + +! iterate to locate pressure pi at the intersection of the two +! curves . pi has been set to p for the initial guess. + + do i= 1,10 + x= .02*(tmr(aw,pi)-tda(ao,pi)) + IF (abs(x) < 0.01) exit + pi= pi*(2.**(x)) + end do + +! find the temperature on the dry adiabat ao at pressure pi. + + ti= tda(ao,pi) + +! the intersection has been located...now, find a saturation +! adiabat thru this point. function os returns the equivalent +! potential temperature (c) of a parcel saturated at temperature +! ti and pressure pi. + + aos= (ti+273.15)*((1000./pi)**.286)*(exp(2.6518986*w(ti,pi)/(ti+273.15)))-273.15 + +! function tsa returns the wet-bulb temperature (c) of a parcel at +! pressure p whose equivalent potential temperature is aos. + + tw = tsa(aos,p) + return + end function tw + + function w(t,p) +! +! this function returns the mixing ratio (grams of water vapor per +! kilogram of dry air) given the dew point (celsius) and pressure +! (millibars). if the temperture is input instead of the +! dew point, then saturation mixing ratio (same units) is returned. +! the formula is found in most meteorological texts. + use gsd_kinds, only: r_single,i_kind,r_kind + implicit none + real(r_kind), intent(in) :: t,p + real(r_kind) :: w + + real(r_kind) :: esat + + w= 622.*esat(t)/(p-esat(t)) + return + end function w diff --git a/src/GSD/gsdcloud/pbl_height.f90 b/src/GSD/gsdcloud/pbl_height.f90 new file mode 100644 index 0000000000..e22abd7aa4 --- /dev/null +++ b/src/GSD/gsdcloud/pbl_height.f90 @@ -0,0 +1,103 @@ +SUBROUTINE calc_pbl_height(mype,nlat,nlon,nsig,q_bk,t_bk,p_bk,pblh) +! +!$$$ subprogram documentation block +! . . . . +! subprogram: pbl_height to calculate PBL height or level +! +! PRGMMR: Ming Hu ORG: GSD/AMB DATE: 2011-04-06 +! +! ABSTRACT: +! This subroutine calculate PBL height +! +! PROGRAM HISTORY LOG: +! +! +! input argument list: +! nlon - no. of lons on subdomain (buffer points on ends) +! nlat - no. of lats on subdomain (buffer points on ends) +! nsig - no. of levels +! q_bk - 3D moisture +! t_bk - 3D background potential temperature (K) +! p_bk - 3D background pressure (hPa) +! +! output argument list: +! pblh - 2D PBL height (level number) +! +! USAGE: +! INPUT FILES: +! +! OUTPUT FILES: +! +! REMARKS: +! +! ATTRIBUTES: +! LANGUAGE: FORTRAN 90 +! MACHINE: Linux cluster (WJET) +! +!$$$ +! +!_____________________________________________________________________ +! + + use gsd_kinds, only: r_single,i_kind, r_kind + + implicit none + + integer(i_kind),intent(in):: mype + integer(i_kind),intent(in):: nlat,nlon,nsig +! +! background +! + real(r_single),intent(in) :: t_bk(nlon,nlat,nsig) ! potential temperature (K) + real(r_single),intent(in) :: q_bk(nlon,nlat,nsig) ! mixing ratio (kg/kg) + real(r_single),intent(in) :: p_bk(nlon,nlat,nsig) ! pressure (hpa) +! +! Variables for cloud analysis +! + real (r_single),intent(out) :: pblh(nlon,nlat) +! +!----------------------------------------------------------- +! +! temp. +! + INTEGER(i_kind) :: i,j,k + real(r_single) :: thetav(nsig) + real(r_single) :: thsfc,qsp + +!==================================================================== +! Begin +! +! + DO j = 1,nlat + DO i = 1,nlon + + DO k = 1,nsig + qsp=q_bk(i,j,k)/(1.0+q_bk(i,j,k)) ! q_bk = water vapor mixing ratio + thetav(k) = t_bk(i,j,k)*(1.0 + 0.61 * qsp) ! qsp = spcific humidity +! if(mype==10.and.i==10.and.j==10) then +! write(*,*) 'cal PBL=',k,thetav(k),t_bk(i,j,k),q_bk(i,j,k) +! endif + ENDDO + + pblh(i,j) = 0.0_r_single + thsfc = thetav(1) + k=1 + DO while (abs(pblh(i,j)) < 0.0001_r_single) + if( thetav(k) > thsfc + 1.0_r_single ) then + pblh(i,j) = float(k) - (thetav(k) - (thsfc + 1.0_r_single))/ & + max((thetav(k)-thetav(k-1)),0.01_r_single) + endif + k=k+1 + ENDDO + if(abs(pblh(i,j)) < 0.0001) pblh(i,j)=2.0_r_single + +! if(mype==10.and.i==10.and.j==10) then +! write(*,*) 'cal PBL=',pblh(i,j),k +! endif + + + enddo ! i + enddo ! j + +END SUBROUTINE calc_pbl_height + diff --git a/src/GSD/gsdcloud/pcp_mxr_ARPSlib.f90 b/src/GSD/gsdcloud/pcp_mxr_ARPSlib.f90 new file mode 100644 index 0000000000..ab12b2fd81 --- /dev/null +++ b/src/GSD/gsdcloud/pcp_mxr_ARPSlib.f90 @@ -0,0 +1,509 @@ + +SUBROUTINE pcp_mxr (nx,ny,nz,t_3d,p_3d ,ref_3d & + ,cldpcp_type_3d & + ,qr_3d,qs_3d,qg_3d,istatus ) + +! +!$$$ subprogram documentation block +! . . . . +! subprogram: pcp_mxr calculates hydrometeor mixing ratios based on Kessler radar reflectivity equations +! +! PRGMMR: ORG: DATE: +! +! ABSTRACT: +! This subroutine calculate precipitation based on Kessler radar reflectivity equations +! +! PROGRAM HISTORY LOG: +! 2009-01-20 Hu Add NCO document block +! +! +! input argument list: +! nx - no. of lons on subdomain (buffer points on ends) +! ny - no. of lats on subdomain (buffer points on ends) +! nz - no. of levels +! t_3d - 3D background temperature (K) +! p_3d - 3D background pressure (hPa) +! ref_3d - 3D reflectivity in analysis grid (dBZ) +! cldpcp_type_3d - 3D precipitation type +! +! output argument list: +! qr_3d - rain mixing ratio (g/kg) +! qs_3d - snow mixing ratio (g/kg) +! qg_3d - graupel/hail mixing ratio (g/kg) +! istatus - +! +! USAGE: +! INPUT FILES: +! +! OUTPUT FILES: +! +! REMARKS: +! Old documents from CAPS +! +!----------------------------------------------------------------------- +! +! PURPOSE: +! +! Perform 3D precipitation mixing ratio (in g/kg) analysis using +! radar reflectivity data. For rain water, using Kessler (1969) +! formula: +! qr(g/kg) = a*(rho*arg)**b (1) +! +! Here arg = Z (mm**6/m**3), and dBZ = 10log10 (arg). +! Coeffcients a=17300.0, and b=7/4. +! rho represents the air density. +! +! For snow and graupel/hail, using Rogers and Yau (1989) formula: +! +! qs(g/kg) = c*(rho*arg)**d (2) +! +! where, c=38000.0, d=2.2 +! +! +!----------------------------------------------------------------------- +! +! AUTHOR: (Jian Zhang) +! 06/13/96 +! +! MODIFICATION HISTORY: +! 07/30/97 (J. Zhang) +! Added precipitation type in the argument list so that +! mixing ratios of different precip. types can be computed. +! 09/04/97 (J. Zhang) +! Changed the radar echo thresholds for inserting precip. +! from radar reflectivities. +! +!----------------------------------------------------------------------- +! ATTRIBUTES: +! LANGUAGE: FORTRAN 90 +! MACHINE: Linux cluster (WJET) +! +!$$$ +! +!_____________________________________________________________________ +! + +! +!----------------------------------------------------------------------- +! +! Variable Declarations. +! +!----------------------------------------------------------------------- +! + use gsd_kinds, only: r_single,i_kind, r_kind + IMPLICIT NONE +! +!----------------------------------------------------------------------- +! +! INPUT: + integer(i_kind),intent(in) :: nx,ny,nz ! Model grid size +! + REAL(r_kind), intent(in) :: ref_3d(nx,ny,nz)! radar reflectivity (dBZ) + real(r_single),intent(in) :: t_3d(nx,ny,nz) ! Temperature (deg. Kelvin) + real(r_single),intent(in) :: p_3d(nx,ny,nz) ! Pressure (Pascal) + + integer(i_kind),intent(in):: cldpcp_type_3d(nx,ny,nz) ! cloud/precip type field +! +! OUTPUT: + INTEGER(i_kind),intent(out) :: istatus +! + REAL(r_single),intent(out) :: qr_3d(nx,ny,nz)! rain mixing ratio in (g/kg) + REAL(r_single),intent(out) :: qs_3d(nx,ny,nz)! snow/sleet/frz-rain mixing ratio + ! in (g/kg) + REAL(r_single),intent(out) :: qg_3d(nx,ny,nz)! graupel/hail mixing ratio in (g/kg) +! +! LOCAL: + REAL(r_kind) :: a,b,c,d ! Coef. for Z-qr relation. + PARAMETER (a=17300.0_r_kind, b=7.0/4.0_r_kind) + PARAMETER (c=38000.0_r_kind, d=2.2_r_kind) + REAL(r_kind) :: rair ! Gas constant (J/deg/kg) + PARAMETER (rair = 287.04_r_kind) + REAL(r_kind) :: thresh_ref + PARAMETER (thresh_ref = 0.0_r_kind) + INTEGER(i_kind) :: pcptype +! +!----------------------------------------------------------------------- +! +! Misc local variables +! +!----------------------------------------------------------------------- +! + INTEGER(i_kind) :: i,j,k, iarg + REAL(r_kind) :: arg,rhobar,br,dr + PARAMETER (br=1.0_r_kind/b, dr=1.0_r_kind/d) +! +!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ +! +! Beginning of executable code... +! +!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ +! +! +!----------------------------------------------------------------------- +! + istatus=0 +! +!----------------------------------------------------------------------- +! +! Compute the precip mixing ratio in g/kg from radar reflectivity +! factor following Kessler (1969) or Rogers and Yau (1989). +! +!----------------------------------------------------------------------- +! + DO k = 1,nz-1 + DO j = 2,ny-1 + DO i = 2,nx-1 + IF (ref_3d(i,j,k) >= thresh_ref) THEN ! valid radar refl. + rhobar = p_3d(i,j,k)/rair/t_3d(i,j,k) + arg = 10.0_r_kind**(0.1_r_kind*ref_3d(i,j,k)) + iarg = cldpcp_type_3d(i,j,k) + pcptype = iarg/16 ! precip. type + + IF (pcptype == 0) THEN ! no precip + PRINT*,'+++ NOTE: radar echo though no precip. +++' + ELSE IF (pcptype == 1.OR.pcptype == 3) THEN ! rain or Z R + qr_3d(i,j,k) = (arg/a)**br/rhobar + ELSE IF (pcptype == 2) THEN ! snow + qs_3d(i,j,k) = (arg/c)**dr/rhobar + ELSE IF (pcptype == 4.OR.pcptype == 5) THEN ! hail or sleet + qg_3d(i,j,k) = (arg/c)**dr/rhobar + ELSE ! unknown + PRINT*,'+++ NOTE: unknown precip type. +++' + END IF + ELSE + qr_3d(i,j,k) = 0._r_kind + qs_3d(i,j,k) = 0._r_kind + qg_3d(i,j,k) = 0._r_kind + END IF + END DO ! k + END DO ! i + END DO ! j +! +!----------------------------------------------------------------------- +! + istatus = 1 +! + RETURN +END SUBROUTINE pcp_mxr + +! +SUBROUTINE pcp_mxr_ferrier (nx,ny,nz,t_3d,p_3d ,ref_3d & + ,cldpcp_type_3d & + ,qr_3d,qs_3d,qg_3d,istatus,mype ) +! +!$$$ subprogram documentation block +! . . . . +! subprogram: pcp_mxr calculate hydrometeor type based on ferrier radar reflectivity equations +! +! PRGMMR: ORG: DATE: +! +! ABSTRACT: +! This subroutine calculate precipitation based on ferrier radar reflectivity equations +! +! PROGRAM HISTORY LOG: +! 2009-01-20 Hu Add NCO document block +! +! +! input argument list: +! nx - no. of lons on subdomain (buffer points on ends) +! ny - no. of lats on subdomain (buffer points on ends) +! nz - no. of levels +! t_3d - 3D background temperature (K) +! p_3d - 3D background pressure (hPa) +! ref_3d - 3D reflectivity in analysis grid (dBZ) +! cldpcp_type_3d - 3D precipitation type +! +! output argument list: +! qr_3d - rain mixing ratio (g/kg) +! qs_3d - snow mixing ratio (g/kg) +! qg_3d - graupel/hail mixing ratio (g/kg) +! istatus - +! +! USAGE: +! INPUT FILES: +! +! OUTPUT FILES: +! +! REMARKS: +! Old document from CAPS +!----------------------------------------------------------------------- +!----------------------------------------------------------------------- +! +! PURPOSE: +! +! Perform 3D precipitation mixing ratio (in g/kg) analysis using +! radar reflectivity data. For rain water, using Ferrier et al (1995) +! formulation: +! +! +! For rain water: +! +! 18 +! 10 * 720 1.75 +! Zer = --------------------------- * (rho * qr) +! 1.75 0.75 1.75 +! pi * N0r * rhor +! +! +! For dry snow (t <= 0 C): +! +! +! 18 2 0.25 +! 10 * 720 * |K| * rhos +! ice 1.75 +! Zes = ----------------------------------------- * (rho * qs) t <= 0 C +! 1.75 2 0.75 2 +! pi * |K| * N0s * rhoi +! water +! +! +! For wet snow (t >= 0 C): +! +! +! 18 +! 10 * 720 1.75 +! Zes = ---------------------------- * (rho * qs) t > 0 C +! 1.75 0.75 1.75 +! pi * N0s * rhos +! +! +! For hail water: +! +! +! / 18 \ 0.95 +! / 10 * 720 \ 1.6625 +! Zeh = | ---------------------------- | * (rho * qg) +! \ 1.75 0.75 1.75 / +! \ pi * N0h * rhoh / +! +! Here Zx (mm**6/m**3, x=r,s,h), and dBZ = 10log10 (Zx). +! rho represents the air density, rhor,rhos,rhoh are the density of +! rain, snow and hail respectively. Other variables are all constants +! for this scheme, see below. +! +! +!----------------------------------------------------------------------- +! +! AUTHOR: (Donghai Wang and Eric Kemp) +! 07/20/2000 +! +! MODIFICATION HISTORY: +! +! 11/09/2000 Keith Brewster +! Moved some parameters with real-valued exponentiation to be +! computed at runtime due to compiler complaint. +! +! 04/07/2003 Keith Brewster +! Restructured code to make more tractable.and consistent with +! the reflec_ferrier subroutine. +! +!----------------------------------------------------------------------- +! ATTRIBUTES: +! LANGUAGE: FORTRAN 90 +! MACHINE: Linux cluster (WJET) +! +!$$$ +! +!_____________________________________________________________________ +! + + +!----------------------------------------------------------------------- +! +! Variable Declarations. +! +!----------------------------------------------------------------------- +! + use gsd_kinds, only: r_single,i_kind, r_kind + IMPLICIT NONE +! +!----------------------------------------------------------------------- +! +! INPUT: + INTEGER(i_kind),intent(in) :: nx,ny,nz ! Model grid size +! + REAL(r_kind), intent(inout) :: ref_3d(nx,ny,nz)! radar reflectivity (dBZ) + REAL(r_single), intent(in) :: t_3d(nx,ny,nz) ! Temperature (deg. Kelvin) + REAL(r_single), intent(in) :: p_3d(nx,ny,nz) ! Pressure (Pascal) + + INTEGER(i_kind),intent(in) :: cldpcp_type_3d(nx,ny,nz) ! cloud/precip type field + INTEGER(i_kind),intent(in) :: mype +! +! OUTPUT: + INTEGER(i_kind),intent(out):: istatus +! + REAL(r_single),intent(out) :: qr_3d(nx,ny,nz) ! rain mixing ratio in (g/kg) + REAL(r_single),intent(out) :: qs_3d(nx,ny,nz) ! snow/sleet/frz-rain mixing ratio + ! in (g/kg) + REAL(r_single),intent(out) :: qg_3d(nx,ny,nz) ! graupel/hail mixing ratio + ! in (g/kg) +! + + REAL(r_kind),PARAMETER :: ki2 = 0.176_r_kind ! Dielectric factor for ice if other + ! than melted drop diameters are used. + REAL(r_kind),PARAMETER :: kw2=0.93_r_kind ! Dielectric factor for water. + + REAL(r_kind),PARAMETER :: m3todBZ=1.0E+18_r_kind ! Conversion factor from m**3 to + ! mm**6 m**-3. + REAL(r_kind),PARAMETER :: Zefact=720.0_r_kind ! Multiplier for Ze components. + REAL(r_kind),PARAMETER :: lg10div=0.10_r_kind ! Log10 multiplier (1/10) + + REAL(r_kind),PARAMETER :: pi=3.1415926_r_kind! Pi. + REAL(r_kind),PARAMETER :: N0r=8.0E+06_r_kind ! Intercept parameter in 1/(m^4) for rain. + REAL(r_kind),PARAMETER :: N0s=3.0E+06_r_kind ! Intercept parameter in 1/(m^4) for snow. + REAL(r_kind),PARAMETER :: N0h=4.0E+04_r_kind ! Intercept parameter in 1/(m^4) for graupel/hail. + + REAL(r_kind),PARAMETER :: N0xpowf=3.0/7.0_r_kind ! Power to which N0r,N0s & N0h are + ! raised. + REAL(r_kind),PARAMETER :: K2powf=4.0/7.0_r_kind ! Power to which K-squared + ! of ice, water are raised + REAL(r_kind),PARAMETER :: zkpowf=4.0/7.0_r_kind ! Power to which Zk is raised + REAL(r_kind),PARAMETER :: zepowf=4.0/7.0_r_kind ! Power to which Ze is raised + REAL(r_kind),PARAMETER :: zehpowf=(4.0/7.0)*1.0526_r_kind ! Power to which Zeh is raised + + REAL(r_kind),PARAMETER :: rhoi=917._r_kind ! Density of ice (kg m**-3) + REAL(r_kind),PARAMETER :: rhor=1000._r_kind ! Density of rain (kg m**-3) + REAL(r_kind),PARAMETER :: rhos=100._r_kind ! Density of snow (kg m**-3) + REAL(r_kind),PARAMETER :: rhoh=913._r_kind ! Density of graupel/hail (kg m**-3) + + REAL(r_kind),PARAMETER :: rhoipowf=8.0/7.0_r_kind ! Power to which rhoi is raised. + REAL(r_kind),PARAMETER :: rhospowf=1.0/7.0_r_kind ! Power to which rhos is raised. + + REAL(r_kind), PARAMETER :: rd=287.0_r_kind ! Gas constant for dry air (m**2/(s**2*K)) + REAL(r_kind), PARAMETER :: thresh_ref = 0.0_r_kind +! +!----------------------------------------------------------------------- +! +! Misc local variables +! +!----------------------------------------------------------------------- +! + INTEGER(i_kind) :: i,j,k, iarg + INTEGER(i_kind) :: pcptype + REAL(r_kind) :: zkconst,zerf,zesnegf,zesposf,zehf,rfract + REAL(r_kind) :: ze,zer,zeh,zes,rho,tc + +! +!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ +! +! Beginning of executable code... +! +!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ +! +! +!----------------------------------------------------------------------- +! +! Intiailize constant factors in the Ze terms for rain, snow and graupel/hail, +! respectively, in Ferrier. +! +! These are the inverse of those presented in the reflec_ferrier function. +! +!----------------------------------------------------------------------- +! + istatus=0 + + zkconst = (Zefact*m3todBZ) ** zkpowf + + zerf=1000._r_kind*(pi * (N0r**N0xpowf) * rhor )/zkconst + + zesnegf=1000._r_kind*(pi*(kw2**k2powf)*(N0s**N0xpowf)*(rhoi**rhoipowf)) / & + ( zkconst * (ki2**k2powf) * (rhos**rhospowf) ) + + zesposf=1000._r_kind*( pi * (N0s**N0xpowf) * rhos) / zkconst + + zehf=1000._r_kind*( pi * (N0h**N0xpowf) * rhoh) / zkconst + +!----------------------------------------------------------------------- +! +! Compute the precip mixing ratio in g/kg from radar reflectivity +! factor following Ferrier et al (1995). +! +!----------------------------------------------------------------------- +! + + DO k = 2,nz-1 + DO j = 2,ny-1 + DO i = 2,nx-1 + IF (ref_3d(i,j,k) >= thresh_ref) THEN ! valid radar refl. + rho = p_3d(i,j,k)/(rd*t_3d(i,j,k)) + ze = 10.0_r_kind**(0.1_r_kind*ref_3d(i,j,k)) + iarg = cldpcp_type_3d(i,j,k) + pcptype = iarg/16 ! precip. type + tc = t_3d(i,j,k) - 273.15_r_kind +!mhu temporal fix + IF (tc <= 0.0_r_kind) THEN + qs_3d(i,j,k) = zesnegf * (ze**zepowf) / rho + qr_3d(i,j,k) = 0.0_r_kind + ELSE IF (tc < 5.0_r_kind) THEN !wet snow + rfract=0.20_r_kind*tc + zer=rfract*ze + zes=(1.-rfract)*ze +! qs_3d(i,j,k) = zesposf * (zes**zepowf) / rho +! qr_3d(i,j,k) = zerf * (zer**zepowf) / rho + qs_3d(i,j,k) = zesnegf * (zes**zepowf) / rho + qr_3d(i,j,k) = zerf * (zer**zepowf) / rho + else + qr_3d(i,j,k) = zerf * (ze**zepowf) / rho + qs_3d(i,j,k) = 0.0_r_kind + ENDIF + cycle +!mhu + IF (pcptype == 1) THEN ! rain + qr_3d(i,j,k) = zerf * (ze**zepowf) / rho + ELSE IF (pcptype == 2) THEN ! snow + IF (tc <= 0.0_r_kind) THEN !dry snow + qs_3d(i,j,k) = zesnegf * (ze**zepowf) / rho + ELSE IF (tc < 5.0_r_kind) THEN !wet snow + rfract=0.20_r_kind*tc + zer=rfract*ze + zes=(1.-rfract)*ze + qs_3d(i,j,k) = zesposf * (zes**zepowf) / rho + qr_3d(i,j,k) = zerf * (zer**zepowf) / rho + ELSE + qr_3d(i,j,k) = zerf * (ze**zepowf) / rho + END IF + ELSE IF (pcptype == 3) THEN ! ZR + qr_3d(i,j,k) = zerf * (ze**zepowf) / rho + ELSE IF (pcptype == 4) THEN ! sleet + IF (tc <= 0.0_r_kind) THEN ! graupel/hail category + qg_3d(i,j,k) = zehf * (ze**zehpowf) / rho + ELSE IF( tc < 10._r_kind ) THEN + rfract=0.10_r_kind*tc + zer=rfract*ze + zeh=(1.-rfract)*ze + qr_3d(i,j,k) = zerf * (zer**zepowf) / rho + qg_3d(i,j,k) = zehf * (zeh**zehpowf) / rho + ELSE + qr_3d(i,j,k) = zerf * (ze**zepowf) / rho + END IF + ELSE IF (pcptype == 5) THEN ! graupel/hail + qg_3d(i,j,k) = zehf * (ze**zehpowf) / rho + ELSE ! unknown + IF (tc <= 0.0_r_kind) THEN !dry snow + qs_3d(i,j,k) = zesnegf * (ze**zepowf) / rho + ELSE IF ( tc < 5.0_r_kind ) THEN !wet snow + rfract=0.20_r_kind*tc + zer=rfract*ze + zes=(1.-rfract)*ze + qs_3d(i,j,k) = zesposf * (zes**zepowf) / rho + qr_3d(i,j,k) = zerf * (zer**zepowf) / rho + ELSE ! rain + qr_3d(i,j,k) = zerf * (ze**zepowf) / rho + END IF + END IF + ELSE + qr_3d(i,j,k) = -999._r_kind + qs_3d(i,j,k) = -999._r_kind + qg_3d(i,j,k) = -999._r_kind + END IF + END DO ! k + END DO ! i + END DO ! j +! PRINT*,'Finish Ferrier ...' +! +!----------------------------------------------------------------------- +! + istatus = 1 +! + RETURN +END SUBROUTINE pcp_mxr_ferrier diff --git a/src/GSD/gsdcloud/radar_ref2tten.f90 b/src/GSD/gsdcloud/radar_ref2tten.f90 new file mode 100644 index 0000000000..0acca7ce2f --- /dev/null +++ b/src/GSD/gsdcloud/radar_ref2tten.f90 @@ -0,0 +1,334 @@ +SUBROUTINE radar_ref2tten(mype,istat_radar,istat_lightning,nlon,nlat,nsig,ref_mos_3d, & + cld_cover_3d,p_bk,t_bk,ges_tten,dfi_rlhtp,krad_bot_in,pblh,sat_ctp) +! +!$$$ subprogram documentation block +! . . . . +! subprogram: radar_ref2tten convert radar reflectivity to 3-d temperature tendency +! +! PRGMMR: Ming Hu ORG: GSD/AMB DATE: 2008-11-27 +! +! ABSTRACT: +! This subroutine converts radar observation (dBZ) to temperature tendency for DFI +! +! PROGRAM HISTORY LOG: +! 2009-01-02 Hu Add NCO document block +! +! +! input argument list: +! mype - processor ID +! istat_radar - radar data status: 0=no radar data; 1=use radar reflectivity +! nlon - no. of lons on subdomain (buffer points on ends) +! nlat - no. of lats on subdomain (buffer points on ends) +! nsig - no. of levels +! ref_mos_3d - 3D radar reflectivity (dBZ) +! cld_cover_3d - 3D cloud cover (0-1) +! p_bk - 3D background pressure (hPa) +! t_bk - 3D background potential temperature (K) +! sat_ctp - 2D NESDIS cloud top pressure (hPa) +! ges_tten - 3D radar temperature tendency +! dfi_rlhtp - dfi radar latent heat time period. DFI forward integration window in minutes +! krad_bot_in - radar bottome height +! pblh - PBL height in grid unit +! +! output argument list: +! ges_tten - 3D radar temperature tendency +! +! USAGE: +! INPUT FILES: +! +! OUTPUT FILES: +! +! REMARKS: +! +! ATTRIBUTES: +! LANGUAGE: FORTRAN 90 +! MACHINE: Linux cluster (WJET) +! +!$$$ +! +!_____________________________________________________________________ +! + use constants, only: rd_over_cp, h1000 + use gsd_kinds, only: r_kind,i_kind,r_single + implicit none + + INTEGER(i_kind),INTENT(IN) :: mype + INTEGER(i_kind),INTENT(IN) :: nlon,nlat,nsig + INTEGER(i_kind),INTENT(IN) :: istat_radar + INTEGER(i_kind),INTENT(IN) :: istat_lightning + real(r_kind),INTENT(IN) :: dfi_rlhtp + real(r_single),INTENT(IN) :: krad_bot_in + real(r_single),INTENT(IN) :: pblh(nlon,nlat) + + real(r_kind),INTENT(IN) :: ref_mos_3d(nlon,nlat,nsig) ! reflectivity in grid + real(r_single),INTENT(IN) :: cld_cover_3d(nlon,nlat,nsig) + real(r_single),INTENT(IN) :: p_bk(nlon,nlat,nsig) + real(r_single),INTENT(IN) :: t_bk(nlon,nlat,nsig) ! potential temperature + real(r_kind), INTENT(INOUT):: ges_tten(nlat,nlon,nsig,1) + real(r_single),INTENT(IN),OPTIONAL :: sat_ctp(nlon,nlat) + + real (r_single) :: tbk_k + + real(r_kind), allocatable :: tten_radar(:,:,:) ! + real(r_kind), allocatable :: dummy(:,:) ! + + integer krad_bot ! RUC bottom level for TTEN_RAD +! +! convection suppression +! + real(r_kind), allocatable :: radyn(:,:) + real(r_kind) :: radmax, dpint + integer(i_kind) :: nrad + real(r_kind) :: radmaxall, dpintmax + +! adopted from: METCON of RUC (/ihome/rucdev/code/13km/hybfront_code) +! CONTAINS ATMOSPHERIC/METEOROLOGICAL/PHYSICAL CONSTANTS +!** R_P R J/(MOL*K) UNIVERSAL GAS CONSTANT +!** R* = 8.31451 +!** MD_P R KG/MOL MEAN MOLECULAR WEIGHT OF DRY AIR +!** MD = 0.0289645 +!jmb--Old value MD = 0.0289644 +!** RD_P R J/(KG*K) SPECIFIC GAS CONSTANT FOR DRY AIR +!** RD = R*>/-100) then ! no echo + tten_radar(i,j,k) = 0._r_kind + else if (ref_mos_3d(i,j,k)>=0.001_r_kind) then ! echo + iskip=0 + if (PRESENT(sat_ctp) ) then + if (sat_ctp(i,j)>1010._r_kind .and. sat_ctp(i,j)<1100._r_kind) then + iskip=iskip+1 +! write (6,*)' Radar ref > 5 dbZ, GOES indicates clear' +! write (6,*)' i,j,k / refl / lat-lon',i,j,k,ref_mos_3d(i,j,k) +! Therefore, if GOES indicates clear, tten_radar +! will retain the zero value + endif + endif + if (tbk_k>277.15_r_kind .and. ref_mos_3d(i,j,k)<28._r_kind) then + iskip=iskip+1 +! write (6,*)' t is over 277 ',i,j,k,ref_mos_3d(i,j,k) +! ALSO, if T > 4C and refl < 28dBZ, again +! tten_radar = 0. + endif + if(iskip == 0 ) then +! tten_radar set as non-zero ONLY IF +! - not contradicted by GOES clear, and +! - ruc_refl > 28 dbZ for temp > 4K, and +! - for temp < 4K, any ruc_refl dbZ is OK. +! - cloudy and under GOES cloud top +! - dfi_rlhtp in minutes + if (k>=krad_bot) then +! can not use cld_cover_3d because we don't use reflectivity to build cld_cover_3d +! if (abs(cld_cover_3d(i,j,k))<=0.5_r_kind .and. (sat_ctp(i,j)>p_bk(i,j,k))) then + addsnow = 10**(ref_mos_3d(i,j,k)/17.8_r_kind)/264083._r_kind*1.5_r_kind + if (PRESENT(sat_ctp) ) then + if ( (sat_ctp(i,j) > 1.0_r_kind .and. sat_ctp(i,j) < 1100.0_r_kind) & + .and. sat_ctp(i,j)>p_bk(i,j,k)) then + addsnow=0.0_r_kind + endif + endif + tten = ((1000.0_r_kind/p_bk(i,j,k))**(1._r_kind/cpovr_p)) & + *(((LV_P+LF0_P)*addsnow)/ & + (dfi_rlhtp*60.0_r_kind*CPD_P)) + tten_radar(i,j,k)= min(0.01_r_kind,max(-0.01_r_kind,tten)) + end if + end if + end if ! ref_mos_3d + + ENDDO + ENDDO + ENDDO + +! DO k=1,nsig +! call smooth(tten_radar(1,1,k),dummy,nlon,nlat,0.5) +! call smooth(tten_radar(1,1,k),dummy,nlon,nlat,0.5) +! ENDDO + +!================================================================================ +! At this point +! 1. put tten_radar into ges_tten array +! for use as tten_radar in subsequent model DFI. +! 2. calculate convection suppression array (RADYN), by +! first smoothing further the tten_radar array +! (available since it is already copied to ges_tten) +! and with adding clear areas from GOES cloud data. + +! KEY element -- Set tten_radar to no-coverage AFTER smoothing +! where ref_mos_3d had been previously set to no-coverage (-99.0 dbZ) +!================================================================================ + + DO k=1,nsig + DO j=1,nlat + DO i=1,nlon + ges_tten(j,i,k,1)=tten_radar(i,j,k) + if(ref_mos_3d(i,j,k)<=-200.0_r_kind ) ges_tten(j,i,k,1)=-spval_p ! no obs + ENDDO + ENDDO + ENDDO +! DO k=1,nsig +! write(6,*)' k,max,min check=',mype,k,maxval(ges_tten(:,:,k,1)),minval(ges_tten(:,:,k,1)) +! enddo + +! -- Whack (smooth) the tten_radar array some more. +! for convection suppression in the radyn array. + DO k=1,nsig + call smooth(tten_radar(1,1,k),dummy,nlon,nlat,0.5_r_kind) + call smooth(tten_radar(1,1,k),dummy,nlon,nlat,0.5_r_kind) + call smooth(tten_radar(1,1,k),dummy,nlon,nlat,0.5_r_kind) + ENDDO + + deallocate(dummy) + +! RADYN array = convection suppression array +! Definition of RADYN values +! -10 -> no information +! 0 -> no convection +! 1 -> there might be convection nearby +! NOTE: 0,1 values are only possible if +! deep radar coverage is available (i.e., > 300 hPa deep) + +! RADYN is read into RUC model as array PCPPREV, +! where it is used to set the cap_depth (cap_max) +! in the Grell-Devenyi convective scheme +! to a near-zero value, effectively suppressing convection +! during DFI and first 30 min of the forward integration. + + allocate(radyn(nlon,nlat)) + radyn = -10._r_kind + + radmaxall=-999 + dpintmax=-999 + DO j=1,nlat + DO i=1,nlon + + nrad = 0 + radmax = 0._r_kind + dpint = 0._r_kind + DO k=2,nsig-1 + if ((ref_mos_3d(i,j,k))<=-200.0_r_kind) tten_radar(i,j,k) = -spval_p + if (tten_radar(i,j,k)>-15._r_kind) then + nrad=nrad+1 + dpint = dpint + 0.5_r_kind*(p_bk(i,j,k-1)-p_bk(i,j,k+1)) + radmax = max(radmax,tten_radar(i,j,k)) + end if + ENDDO + if (dpint>=300._r_kind ) then + radyn(i,j) = 0._r_kind + if (radmax>0.00002_r_kind) radyn(i,j) = 1. + if( abs(radyn(i,j)) < 0.00001_r_kind ) then + krad_bot= int( max(krad_bot_in,pblh(i,j)) + 0.5_r_single ) ! consider PBL height + do k=krad_bot,nsig-1 + ges_tten(j,i,k,1) = 0._r_kind + end do + endif + else +! outside radar coverage area where satellite shows clear conditions, +! then add this area to the convection suppress area. + if (PRESENT(sat_ctp) ) then + if (sat_ctp(i,j)>1010._r_kind .and. sat_ctp(i,j)<1100._r_kind) then + radyn(i,j) = 0._r_kind + endif + endif + endif + +! 2. Extend depth of no-echo zone from dpint zone down to PBL top, +! similarly to how lowest echo (with convection) is extended down to PBL top +! 5/27/2010 - Stan B. +! if (dpint >= 300. .and. radmax<=0.001) then +! krad_bot= int( max(krad_bot_in,pblh(i,j)) + 0.5_r_single ) ! consider PBL height +! do k=krad_bot,nsig-1 +! ges_tten(j,i,k,1) = 0._r_kind +! end do +! end if + + if(dpintmax < dpint ) dpintmax=dpint + if(radmaxall< radmax) radmaxall=radmax + ENDDO + ENDDO + + DO j=1,nlat + DO i=1,nlon + ges_tten(j,i,nsig,1)=radyn(i,j) + ENDDO + ENDDO + + deallocate(tten_radar) + deallocate(radyn) + + else ! no radar observation i this subdomain + + ges_tten=-spval_p + ges_tten(:,:,nsig,1)=-10.0_r_kind + + DO j=1,nlat + DO i=1,nlon + +! outside radar observation domain and satellite show clean, the suppress convection + if (PRESENT(sat_ctp) ) then + if (sat_ctp(i,j)>=1010._r_kind .and. sat_ctp(i,j)<=1100._r_kind) then + ges_tten(j,i,nsig,1) = 0. + endif + endif + ENDDO + ENDDO + + endif + + DO k=1,nsig + DO j=1,nlat + DO i=1,nlon + if(ges_tten(j,i,k,1) <= -200.0_r_kind ) ges_tten(j,i,k,1)=-20.0_r_kind ! no obs + ENDDO + ENDDO + ENDDO + +END SUBROUTINE radar_ref2tten diff --git a/src/GSD/gsdcloud/read_Lightning_cld.f90 b/src/GSD/gsdcloud/read_Lightning_cld.f90 new file mode 100644 index 0000000000..46b02a00d8 --- /dev/null +++ b/src/GSD/gsdcloud/read_Lightning_cld.f90 @@ -0,0 +1,93 @@ +SUBROUTINE read_Lightning2cld(mype,lunin,istart,jstart, & + nlon,nlat,numlight,lightning) +! +! +!$$$ subprogram documentation block +! . . . . +! subprogram: read_NESDIS read in lightning flash rate +! +! PRGMMR: Ming Hu ORG: GSD/AMB DATE: 2008-11-30 +! +! ABSTRACT: +! This subroutine read in lightning flash rate +! +! PROGRAM HISTORY LOG: +! 2009-01-20 Hu Add NCO document block +! +! +! input argument list: +! mype - processor ID +! lunin - unit in which data are read in +! jstart - start lon of the whole array on each pe +! istart - start lat of the whole array on each pe +! nlon - no. of lons on subdomain (buffer points on ends) +! nlat - no. of lats on subdomain (buffer points on ends) +! numlight - number of observation +! +! output argument list: +! lightning - lightning flash rate in analysis grid +! +! USAGE: +! INPUT FILES: +! +! OUTPUT FILES: +! +! REMARKS: +! +! ATTRIBUTES: +! LANGUAGE: FORTRAN 90 +! MACHINE: Linux cluster (WJET) +! +!$$$ +! +!_____________________________________________________________________ +! + + use gsd_kinds, only: r_kind,i_kind, r_single + implicit none + + integer(i_kind),intent(in) :: lunin + integer(i_kind),intent(in) :: mype + INTEGER(i_kind),intent(in) :: nlon,nlat + integer(i_kind),intent(in) :: istart + integer(i_kind),intent(in) :: jstart + INTEGER(i_kind),intent(in) :: numlight + + real(r_single), intent(out):: lightning(nlon,nlat) +! +! local +! + real(r_kind),allocatable :: light_in(:,:) + + character(10) :: obstype + integer(i_kind):: nreal,nchanl,ilat1s,ilon1s + character(20) :: isis + + INTEGER(i_kind) :: i,ii,jj + INTEGER(i_kind) :: ib,jb + +! + ib=jstart ! begin i point of this domain + jb=istart ! begin j point of this domain + + ilon1s=1 + ilat1s=2 + + read(lunin) obstype,isis,nreal,nchanl + + allocate( light_in(nreal,numlight) ) + light_in=-9999.0_r_kind + + read(lunin) light_in + DO i=1,numlight + ii=int(light_in(ilon1s,i)+0.001_r_kind) - ib + 2 + jj=int(light_in(ilat1s,i)+0.001_r_kind) - jb + 2 + if( ii < 1 .or. ii > nlon ) write(6,*) 'read_Lightning_cld: ', & + 'Error in read in lightning ii:',mype,ii,jj,i,ib,jb + if( jj < 1 .or. jj > nlat ) write(6,*) 'read_Lightning_cld:', & + 'Error in read in lightning jj:',mype,ii,jj,i,ib,jb + lightning(ii,jj)=light_in(3,i) + ENDDO + deallocate(light_in) + +END SUBROUTINE read_Lightning2cld diff --git a/src/GSD/gsdcloud/read_NESDIS.f90 b/src/GSD/gsdcloud/read_NESDIS.f90 new file mode 100644 index 0000000000..4d3dd9bf21 --- /dev/null +++ b/src/GSD/gsdcloud/read_NESDIS.f90 @@ -0,0 +1,124 @@ +SUBROUTINE read_NESDIS(mype,lunin,numobs,istart,jstart,nlon,nlat, & + sat_ctp,sat_tem,w_frac,npts_rad,ioption) +! +!$$$ subprogram documentation block +! . . . . +! subprogram: read_NESDIS read in NESDIS cloud products and map them into analysis grid +! +! PRGMMR: Ming Hu ORG: GSD/AMB DATE: 2006-10-30 +! +! ABSTRACT: +! This subroutine read in NESDIS cloud products and map them into analysis grid +! +! PROGRAM HISTORY LOG: +! 2009-01-20 Hu Add NCO document block +! +! +! input argument list: +! mype - processor ID +! lunin - unit in which data are read in +! numobs - number of observation +! jstart - start lon of the whole array on each pe +! istart - start lat of the whole array on each pe +! nlon - no. of lons on subdomain (buffer points on ends) +! nlat - no. of lats on subdomain (buffer points on ends) +! +! output argument list: +! sat_ctp - GOES cloud top pressure in analysis grid +! sat_tem - GOES cloud top temperature in analysis grid +! w_frac - GOES cloud coverage in analysis grid +! +! +! USAGE: +! INPUT FILES: +! +! OUTPUT FILES: +! +! REMARKS: +! +! ATTRIBUTES: +! LANGUAGE: FORTRAN 90 +! MACHINE: Linux cluster (WJET) +! +!$$$ +! +!_____________________________________________________________________ +! + + use gsd_kinds, only: r_single,i_kind,r_kind + + implicit none + + integer(i_kind),intent(in) :: mype + integer(i_kind),intent(in) :: lunin + INTEGER(i_kind),intent(in) :: numobs + INTEGER(i_kind),intent(in) :: nlon,nlat + integer(i_kind),intent(in) :: istart + integer(i_kind),intent(in) :: jstart + INTEGER(i_kind),intent(in) :: npts_rad + INTEGER(i_kind),intent(in) :: ioption + + real(r_single), intent(out):: sat_ctp(nlon,nlat) ! cloud top pressure + real(r_single), intent(out):: sat_tem(nlon,nlat) ! cloud top temperature + real(r_single), intent(out):: w_frac(nlon,nlat) ! cloud fraction +! + INTEGER(i_kind) :: nn_obs + real(r_kind),allocatable,dimension(:,:):: data_s + logical,allocatable,dimension(:):: luse +! +! misc. +! + character(10) :: obstype + integer(i_kind) :: mm1 + integer(i_kind) :: nreal,nchanl + character(20) :: isis + + INTEGER(i_kind) :: i, j + INTEGER(i_kind) :: ib, jb +! +! =============================================================== +! + + mm1=mype+1 + + read(lunin) obstype,isis,nreal,nchanl + nn_obs = nreal + nchanl + allocate(luse(numobs),data_s(nn_obs,numobs)) + read(lunin) data_s, luse +! + ib=jstart ! begin i point of this domain + jb=istart ! begin j point of this domain + call map_ctp (ib,jb,nlon,nlat,nn_obs,numobs,data_s,sat_ctp,sat_tem,w_frac,npts_rad,ioption) +!! +! filling boundarys +! + DO i=2,nlon-1 + sat_ctp(i,1) =sat_ctp(i,2) + sat_tem(i,1) =sat_tem(i,2) + w_frac(i,1) =w_frac(i,2) + sat_ctp(i,nlat)=sat_ctp(i,nlat-1) + sat_tem(i,nlat)=sat_tem(i,nlat-1) + w_frac(i,nlat) =w_frac(i,nlat-1) + enddo + DO j=2,nlat-1 + sat_ctp(1,j) =sat_ctp(2,j) + sat_tem(1,j) =sat_tem(2,j) + w_frac(1,j) =w_frac(2,j) + sat_ctp(nlon,j)=sat_ctp(nlon-1,j) + sat_tem(nlon,j)=sat_tem(nlon-1,j) + w_frac(nlon,j) =w_frac(nlon-1,j) + enddo + sat_ctp(1,1) =sat_ctp(2,2) + sat_tem(1,1) =sat_tem(2,2) + w_frac(1,1) =w_frac(2,2) + sat_ctp(1,nlat) =sat_ctp(2,nlat-1) + sat_tem(1,nlat) =sat_tem(2,nlat-1) + w_frac(1,nlat) =w_frac(2,nlat-1) + sat_ctp(nlon,1) =sat_ctp(nlon-1,2) + sat_tem(nlon,1) =sat_tem(nlon-1,2) + w_frac(nlon,1) =w_frac(nlon-1,2) + sat_ctp(nlon,nlat)=sat_ctp(nlon-1,nlat-1) + sat_tem(nlon,nlat)=sat_tem(nlon-1,nlat-1) + w_frac(nlon,nlat) =w_frac(nlon-1,nlat-1) + +END SUBROUTINE read_NESDIS diff --git a/src/GSD/gsdcloud/read_Surface.f90 b/src/GSD/gsdcloud/read_Surface.f90 new file mode 100644 index 0000000000..8fb56a8ffc --- /dev/null +++ b/src/GSD/gsdcloud/read_Surface.f90 @@ -0,0 +1,240 @@ +SUBROUTINE read_Surface(mype,lunin,istart,jstart,nlon,nlat,& + numsao,NVARCLD_P,OI,OJ,OCLD,OWX,Oelvtn,Odist,cstation, & + OIstation,OJstation) +! +!$$$ subprogram documentation block +! . . . . +! subprogram: read_Surface read in cloud observations in surface observation +! +! PRGMMR: Ming Hu ORG: GSD/AMB DATE: 2006-10-30 +! +! ABSTRACT: +! This subroutine read in cloud observations in surface observation +! +! PROGRAM HISTORY LOG: +! 2009-01-20 Hu Add NCO document block +! +! +! input argument list: +! mype - processor ID +! lunin - unit in which data are read in +! jstart - start lon of the whole array on each pe +! istart - start lat of the whole array on each pe +! nlon - no. of lons on subdomain (buffer points on ends) +! nlat - no. of lats on subdomain (buffer points on ends) +! numsao - maximum observation number (observation number) +! NVARCLD_P - first dimension of OLCD +! +! output argument list: +! +! OI - observation x location +! OJ - observation y location +! OLCD - cloud amount, cloud height, visibility +! OWX - weather observation +! Oelvtn - observation elevation +! Odist - distance from the nearest station +! cstation - station name + +! +! USAGE: +! INPUT FILES: +! +! OUTPUT FILES: +! +! +! REMARKS: +! +! ATTRIBUTES: +! LANGUAGE: FORTRAN 90 +! MACHINE: Linux cluster (WJET) +! +!$$$ +! + + use gsd_kinds, only: r_single,i_kind,r_kind,r_double + + implicit none + + integer(i_kind), intent(in) :: mype + integer(i_kind), intent(in) :: lunin + integer(i_kind), intent(in) :: istart + integer(i_kind), intent(in) :: jstart + INTEGER(i_kind), intent(in) :: nlon,nlat + INTEGER(i_kind), intent(in) :: numsao + INTEGER(i_kind), intent(in) :: NVARCLD_P + + real(r_single), intent(out) :: OI(numsao) ! x location, grid + real(r_single), intent(out) :: OJ(numsao) ! y location, grid + INTEGER(i_kind), intent(out) :: OCLD(NVARCLD_P,numsao) ! cloud amount, cloud height, + ! visibility + CHARACTER*10, intent(out) :: OWX(numsao) ! weather + real(r_single), intent(out) :: Oelvtn(numsao) ! elevation + real(r_single), intent(out) :: Odist(numsao) ! distance from the nearest station + character(8), intent(out) :: cstation(numsao) ! station name + real(r_single), intent(out) :: OIstation(numsao) ! x location, station + real(r_single), intent(out) :: OJstation(numsao) ! y location, station + +! +! temp. +! + real(r_single) :: VIS ! horizontal visibility +! +! misc. +! + real(r_kind),allocatable,dimension(:,:):: data_s + logical,allocatable,dimension(:):: luse + character(10) :: obstype + integer(i_kind):: nreal,nchanl + character(20) :: isis + + INTEGER(i_kind) :: nn_obs + real(r_kind) :: cldamt,awx,cldhgt + character*3 :: mwx + INTEGER(i_kind) :: i,j,jb,ib + integer(i_kind) :: start, end + + real(r_kind) :: spval_p + parameter (spval_p = 99999.) + + real(r_double) rstation_id + character(8) :: cstation1 + equivalence(cstation1,rstation_id) + + +!==================================================================== +! Begin + OWX='' + OCLD=-99999 + + ib=jstart ! begin i point of this domain + jb=istart ! begin j point of this domain + +! + read(lunin) obstype,isis,nreal,nchanl + + nn_obs = nreal + nchanl + allocate(luse(numsao),data_s(nn_obs,numsao)) + read(lunin) data_s, luse +! +! read in ruface observations: +! station name, x location, y location, longitude, latitude, elevation +! visibility, cloud amount, cloud height, weather +! + DO i=1,numsao + rstation_id=data_s(1,i) + cstation(i)=cstation1 + OI(i) = data_s(2,i) - ib + 2 ! covert it to the local grid + OJ(i) = data_s(3,i) - jb + 2 ! covert it to the local grid + if( OI(i) < 1 .or. OI(i) > nlon ) write(6,*) 'read_Surface: Error in reading ii:',mype,OI(i),ib,jb + if( OJ(i) < 1 .or. OJ(i) > nlat ) write(6,*) 'read_Surface: Error in reading jj:',mype,OJ(i),ib,jb + Oelvtn(i) = data_s(4,i) + Odist(i) = data_s(23,i) + OIstation(i) = data_s(24,i) + OJstation(i) = data_s(25,i) + if(data_s(22,i) > 50 ) cycle ! do not use this data + VIS = data_s(5,i) +! cloud amonut and base height +! C 020011 +! 0 0 oktas (0/10) +! 1 1 okta or less, but not zero (1/10 or less, but not zero) +! 2 2 oktas (2/10 - 3/10) +! 3 3 oktas (4/10) +! 4 4 oktas (5/10) +! 5 5 oktas (6/10) +! 6 6 oktas (7/10 - 8/10) +! 7 7 oktas or more, but not 8 oktas (9/10 or more, but not 10/10) +! 8 8 oktas (10/10) +! 9 Sky obscured by fog and/or other meteorological phenomena +! 10 Sky partially obscured by fog and/or other meteorological phenomena +! 11 Scattered +! 12 Broken +! 13 Few +! 14 Reserved +! 15 Cloud cover is indiscernible for reasons other than +! fog or other meteorological phenomena, or observation is not made + + DO j=1,3 + cldamt = data_s(5+j,i) ! cloud amount + cldhgt = int(data_s(11+j,i)) ! cloud bottom height + if(cldamt < spval_p .and. cldhgt < spval_p) then + if(abs(cldamt-0._r_kind) < 0.0001_r_kind) then + OCLD(j,i)=0 !msky='CLR' + cldhgt=spval_p + elseif(abs(cldamt-13._r_kind) < 0.0001_r_kind) then + OCLD(j,i)=1 !msky='FEW' + elseif(abs(cldamt-11._r_kind) < 0.0001_r_kind) then + OCLD(j,i)=2 !msky='SCT' + elseif(abs(cldamt-12._r_kind) < 0.0001_r_kind) then + OCLD(j,i)=3 !msky='BKN' + elseif((abs(cldamt-8._r_kind) < 0.0001_r_kind) .or. & + (abs(cldamt-9._r_kind) < 0.0001_r_kind)) then + OCLD(j,i)=4 ! msky='OVC' msky='VV ' + elseif(abs(cldamt-1._r_kind) < 0.0001_r_kind) then + OCLD(j,i)=1 + elseif(abs(cldamt-2._r_kind) < 0.0001_r_kind .or. & + abs(cldamt-3._r_kind) < 0.0001_r_kind ) then + OCLD(j,i)=2 + elseif(cldamt > 3.5_r_kind .and. cldamt < 6.5_r_kind ) then + OCLD(j,i)=3 + elseif(abs(cldamt-7._r_kind) < 0.0001_r_kind ) then + OCLD(j,i)=4 + else + OCLD(j,i) = spval_p ! wrong cloud observation type + cldhgt = spval_p + endif + if(cldhgt > 0.0_r_kind ) then + OCLD(6+j,i) = cldhgt + else + OCLD(j,i) = spval_p + OCLD(6+j,i) = spval_p + endif + else + OCLD(j,i) = 99 + OCLD(6+j,i) = spval_p + endif + enddo ! j +! weather + DO j=1,3 + awx = data_s(17+j,i) ! weather + mwx=' ' + if(awx>=10._r_kind .and.awx<=12._r_kind ) mwx='BR ' + if(awx>=110._r_kind.and.awx<=112._r_kind) mwx='BR ' + if(awx==5._r_kind .or. awx==105._r_kind) mwx='HZ ' + if(awx>=40._r_kind .and.awx<=49._r_kind ) mwx='FG ' + if(awx>=130._r_kind.and.awx<=135._r_kind) mwx='FG ' + if(awx>=50._r_kind .and.awx<=59._r_kind ) mwx='DZ ' + if(awx>=150._r_kind.and.awx<=159._r_kind) mwx='DZ ' + if(awx>=60._r_kind .and.awx<=69._r_kind ) mwx='RA ' + if(awx>=160._r_kind.and.awx<=169._r_kind) mwx='RA ' + if(awx>=70._r_kind .and.awx<=78._r_kind ) mwx='SN ' + if(awx>=170._r_kind.and.awx<=178._r_kind) mwx='SN ' + if(awx==79._r_kind .or. awx==179._r_kind) mwx='PE ' + + if(awx>=80._r_kind .and.awx<=90._r_kind ) mwx='SH ' + if(awx>=180._r_kind.and.awx<=187._r_kind) mwx='SH ' + if(awx>=91._r_kind .and.awx<=99._r_kind ) mwx='TH ' + if(awx>=190._r_kind.and.awx<=196._r_kind) mwx='TH ' + + if (j==1) start=1 + if (j==2) start=4 + if (j==3) start=7 + end=start+2 + OWX(i)(start:end)=mwx + enddo +! visiblity + IF(VIS > spval_P) then + OCLD(13,i)=spval_P + else + IF(VIS > 100.0_r_kind ) then + OCLD(13,i)=int(VIS) + elseif(VIS <=100.0_r_kind .and. VIS > 0.0_r_kind ) then + OCLD(13,i)=100 + write(6,*) 'read_Surface, Warning: change visibility to 100 m !!!' + ENDIF + endif + + ENDDO ! i = numsao +! + +END SUBROUTINE read_Surface + diff --git a/src/GSD/gsdcloud/read_nasalarc_cld.f90 b/src/GSD/gsdcloud/read_nasalarc_cld.f90 new file mode 100644 index 0000000000..efe69c927a --- /dev/null +++ b/src/GSD/gsdcloud/read_nasalarc_cld.f90 @@ -0,0 +1,301 @@ +SUBROUTINE read_NASALaRC(mype,lunin,numLaRC,istart,jstart, & + nlon,nlat,nasalarc) +! +! +!$$$ subprogram documentation block +! . . . . +! subprogram: read_NASALaRC read in nasalarc cloud +! +! PRGMMR: Ming Hu ORG: GSD/AMB DATE: 2009-09-21 +! +! ABSTRACT: +! This subroutine reads in nasalarc cloud products that are already mapped to +! analysis grid. +! +! PROGRAM HISTORY LOG: +! 2009-01-20 Hu Add NCO document block +! +! +! input argument list: +! mype - processor ID +! lunin - unit in which data are read in +! numLaRC - number of observation +! jstart - start lon of the whole array on each pe +! istart - start lat of the whole array on each pe +! nlon - no. of lons on subdomain (buffer points on ends) +! nlat - no. of lats on subdomain (buffer points on ends) +! +! output argument list: +! nasalarc - nasalarc cloud in analysis grid +! +! USAGE: +! INPUT FILES: +! +! OUTPUT FILES: +! +! REMARKS: +! +! ATTRIBUTES: +! LANGUAGE: FORTRAN 90 +! MACHINE: Linux cluster (WJET) +! +!$$$ +! +!_____________________________________________________________________ +! + + use gsd_kinds, only: r_kind,i_kind, r_single + implicit none + + integer(i_kind),intent(in) :: lunin + integer(i_kind),intent(in) :: mype + INTEGER(i_kind),intent(in) :: numLaRC + INTEGER(i_kind),intent(in) :: nlon,nlat + integer(i_kind),intent(in) :: istart + integer(i_kind),intent(in) :: jstart + + real(r_single), intent(out) :: nasalarc(nlon,nlat,5) +! +! local +! + real(r_kind),allocatable :: nasalarc_in(:,:) + + character(10) :: obstype + integer(i_kind):: nreal,nchanl,ilat1s,ilon1s + character(20) :: isis + + INTEGER(i_kind) :: i,j, ii,jj, k + INTEGER(i_kind) :: ib,jb + + REAL(r_kind) :: miss_obs_real + PARAMETER ( miss_obs_real = -99999.0_r_kind ) + +! + ib=jstart ! begin i point of this domain + jb=istart ! begin j point of this domain + + ilon1s=1 + ilat1s=2 + + read(lunin) obstype,isis,nreal,nchanl + + allocate( nasalarc_in(nreal,numLaRC) ) + nasalarc_in=miss_obs_real + + read(lunin) nasalarc_in + DO i=1,numLaRC + ii=int(nasalarc_in(ilon1s,i)+0.001_r_kind) - ib + 2 + jj=int(nasalarc_in(ilat1s,i)+0.001_r_kind) - jb + 2 + if( ii < 1 .or. ii > nlon ) write(6,*) 'read_nasalarc_cld: ', & + 'Error in read in nasa ii:',mype,ii,jj,i,ib,jb + if( jj < 1 .or. jj > nlat ) write(6,*) 'read_nasalarc_cld: ', & + 'Error in read in nasa jj:',mype,ii,jj,i,ib,jb + DO k=1,2 + if(nasalarc_in(k+2,i) > 8888.0_r_kind ) then + nasalarc(ii,jj,k)=miss_obs_real + else + nasalarc(ii,jj,k)=nasalarc_in(k+2,i) ! k=1 w_pcld, 2=w_tcld + endif + enddo ! k + + if(nasalarc_in(5,i) > 8888.0_r_kind ) then + nasalarc(ii,jj,3)=miss_obs_real + else + nasalarc(ii,jj,3)=nasalarc_in(5,i)/100.0_r_kind ! w_frac + endif + + if(nasalarc_in(6,i) > 8888.0_r_kind) then + nasalarc(ii,jj,4)=miss_obs_real + else + nasalarc(ii,jj,4)=nasalarc_in(6,i)/1000.0_r_kind ! w_lwp + endif + + if(nasalarc_in(7,i) > 8888.0_r_kind ) then + nasalarc(ii,jj,5)=miss_obs_real + else + nasalarc(ii,jj,5)=nasalarc_in(7,i) ! nlv_cld + endif + ENDDO + deallocate(nasalarc_in) +! +! filling boundarys +! + DO k=1,5 + DO i=2,nlon-1 + nasalarc(i,1,k)=nasalarc(i,2,k) + nasalarc(i,nlat,k)=nasalarc(i,nlat-1,k) + enddo + DO j=2,nlat-1 + nasalarc(1,j,k)=nasalarc(2,j,k) + nasalarc(nlon,j,k)=nasalarc(nlon-1,j,k) + enddo + nasalarc(1,1,k)=nasalarc(2,2,k) + nasalarc(1,nlat,k)=nasalarc(2,nlat-1,k) + nasalarc(nlon,1,k)=nasalarc(nlon-1,2,k) + nasalarc(nlon,nlat,k)=nasalarc(nlon-1,nlat-1,k) + ENDDO + + +END SUBROUTINE read_NASALaRC + +SUBROUTINE read_map_nasalarc(mype,lunin,numobs,istart,jstart,nlon,nlat, & + nasalarc,ioption) +! +!$$$ subprogram documentation block +! . . . . +! subprogram: read_map_nasalarc read in NASA LaRC cloud products and map them into analysis grid +! +! PRGMMR: Ming Hu & Terra Ladwig ORG: GSD/EMB DATE: 2015-04-30 +! +! ABSTRACT: +! This subroutine reads in global NASA LaRC cloud products and map them into analysis grid. +! +! PROGRAM HISTORY LOG: +! 2015-04-20 Hu This code is based on read_NESDIS +! +! +! input argument list: +! mype - processor ID +! lunin - unit in which data are read in +! numobs - number of observation +! jstart - start lon of the whole array on each pe +! istart - start lat of the whole array on each pe +! nlon - no. of lons on subdomain (buffer points on ends) +! nlat - no. of lats on subdomain (buffer points on ends) +! +! output argument list: +! nasalarc - nasalarc cloud in analysis grid +! +! USAGE: +! INPUT FILES: +! +! OUTPUT FILES: +! +! REMARKS: +! +! ATTRIBUTES: +! LANGUAGE: FORTRAN 90 +! MACHINE: Linux cluster (WJET) +! +!$$$ +! +!_____________________________________________________________________ +! + + use gsd_kinds, only: r_single,i_kind,r_kind + + implicit none + + integer(i_kind),intent(in) :: mype + integer(i_kind),intent(in) :: lunin + INTEGER(i_kind),intent(in) :: numobs + INTEGER(i_kind),intent(in) :: nlon,nlat + integer(i_kind),intent(in) :: istart + integer(i_kind),intent(in) :: jstart + integer(i_kind),intent(in) :: ioption + + real(r_single):: sat_ctp(nlon,nlat) ! cloud top pressure + real(r_single):: sat_tem(nlon,nlat) ! cloud top temperature + real(r_single):: w_frac(nlon,nlat) ! cloud fraction + real(r_single):: w_lwp(nlon,nlat) ! cloud fraction + integer(i_kind):: nlev_cld(nlon,nlat) ! cloud fraction + real(r_single):: nasalarc(nlon,nlat,5) +! + INTEGER(i_kind) :: nn_obs + real(r_kind),allocatable,dimension(:,:):: data_s + logical,allocatable,dimension(:):: luse +! +! misc. +! + character(10) :: obstype + integer(i_kind) :: mm1 + integer(i_kind) :: nreal,nchanl + character(20) :: isis + + INTEGER(i_kind) :: i, j + INTEGER(i_kind) :: ib, jb +! +! =============================================================== +! + + mm1=mype+1 + + read(lunin) obstype,isis,nreal,nchanl + nn_obs = nreal + nchanl + allocate(luse(numobs),data_s(nn_obs,numobs)) + read(lunin) data_s, luse + +! do i=1,numobs +! write(6,*)'sliu larcclddata::',mype,data_s(2,i),data_s(3,i) +! end do + +! write(6,*)'read_map_nasalarc::',mype, maxval(data_s(7,:)),numobs + + + ib=jstart ! begin i point of this domain + jb=istart ! begin j point of this domain + call map_ctp_lar(mype,ib,jb,nlon,nlat,nn_obs,numobs,data_s,sat_ctp,sat_tem,w_frac,w_lwp,nlev_cld,ioption) +!! +! filling boundarys +! + DO i=2,nlon-1 + sat_ctp(i,1) =sat_ctp(i,2) + sat_tem(i,1) =sat_tem(i,2) + w_frac(i,1) =w_frac(i,2) + w_lwp(i,1) =w_lwp(i,2) + nlev_cld(i,1) =nlev_cld(i,2) + sat_ctp(i,nlat)=sat_ctp(i,nlat-1) + sat_tem(i,nlat)=sat_tem(i,nlat-1) + w_frac(i,nlat) =w_frac(i,nlat-1) + w_lwp(i,nlat) =w_lwp(i,nlat-1) + nlev_cld(i,nlat) =nlev_cld(i,nlat-1) + enddo + DO j=2,nlat-1 + sat_ctp(1,j) =sat_ctp(2,j) + sat_tem(1,j) =sat_tem(2,j) + w_frac(1,j) =w_lwp(2,j) + w_lwp(1,j) =w_lwp(2,j) + nlev_cld(1,j) =nlev_cld(2,j) + sat_ctp(nlon,j)=sat_ctp(nlon-1,j) + sat_tem(nlon,j)=sat_tem(nlon-1,j) + w_frac(nlon,j) =w_frac(nlon-1,j) + w_lwp(nlon,j) =w_lwp(nlon-1,j) + nlev_cld(nlon,j) =nlev_cld(nlon-1,j) + enddo + sat_ctp(1,1) =sat_ctp(2,2) + sat_tem(1,1) =sat_tem(2,2) + w_frac(1,1) =w_frac(2,2) + w_lwp(1,1) =w_lwp(2,2) + nlev_cld(1,1) =nlev_cld(2,2) + + sat_ctp(1,nlat) =sat_ctp(2,nlat-1) + sat_tem(1,nlat) =sat_tem(2,nlat-1) + w_frac(1,nlat) =w_frac(2,nlat-1) + w_lwp(1,nlat) =w_lwp(2,nlat-1) + nlev_cld(1,nlat) =nlev_cld(2,nlat-1) + + sat_ctp(nlon,1) =sat_ctp(nlon-1,2) + sat_tem(nlon,1) =sat_tem(nlon-1,2) + w_frac(nlon,1) =w_frac(nlon-1,2) + w_lwp(nlon,1) =w_lwp(nlon-1,2) + nlev_cld(nlon,1) =nlev_cld(nlon-1,2) + + sat_ctp(nlon,nlat)=sat_ctp(nlon-1,nlat-1) + sat_tem(nlon,nlat)=sat_tem(nlon-1,nlat-1) + w_frac(nlon,nlat) =w_frac(nlon-1,nlat-1) + + do i=1,nlon + do j=1,nlat + nasalarc(i,j,1)=sat_ctp(i,j) + nasalarc(i,j,2)=sat_tem(i,j) + nasalarc(i,j,3)=w_frac(i,j) !/100.0 + nasalarc(i,j,4)=w_lwp(i,j) !/100.0 + nasalarc(i,j,5)=nlev_cld(i,j) +! if(abs(sat_tem(i,j))>0.and.abs(sat_tem(i,j))<400) then +! write(6,*)'sat_tem2 in read_cloud::',sat_ctp(i,j),sat_tem(i,j),nasalarc(i,j,1) +! end if + end do + end do + + +END SUBROUTINE read_map_nasalarc diff --git a/src/GSD/gsdcloud/read_radar_ref.f90 b/src/GSD/gsdcloud/read_radar_ref.f90 new file mode 100644 index 0000000000..a53274e2a8 --- /dev/null +++ b/src/GSD/gsdcloud/read_radar_ref.f90 @@ -0,0 +1,106 @@ +SUBROUTINE read_radar_ref(mype,lunin,istart,jstart, & + nlon,nlat,Nmsclvl,numref,ref_mosaic31) +! +! +! +!$$$ subprogram documentation block +! . . . . +! subprogram: read_NESDIS read in radar reflectivity +! +! PRGMMR: Ming Hu ORG: GSD/AMB DATE: 2006-11-30 +! +! ABSTRACT: +! This subroutine read in radar reflectivity +! +! PROGRAM HISTORY LOG: +! 2009-01-20 Hu Add NCO document block +! +! +! input argument list: +! mype - processor ID +! lunin - unit in which data are read in +! jstart - start lon of the whole array on each pe +! istart - start lat of the whole array on each pe +! nlon - no. of lons on subdomain (buffer points on ends) +! nlat - no. of lats on subdomain (buffer points on ends) +! numref - number of observation +! +! output argument list: +! Nmsclvl - vertical level of radar observation ref_mosaic31 +! ref_mosaic31- radar reflectivity horizontally in analysis grid and +! vertically in mosaic grid (height) +! +! USAGE: +! INPUT FILES: +! +! OUTPUT FILES: +! +! REMARKS: +! +! ATTRIBUTES: +! LANGUAGE: FORTRAN 90 +! MACHINE: Linux cluster (WJET) +! +!$$$ +! +!_____________________________________________________________________ +! + use gsd_kinds, only: r_kind,i_kind + implicit none + + INTEGER(i_kind),intent(in) :: mype + INTEGER(i_kind),intent(in) :: nlon,nlat + integer(i_kind),intent(in) :: lunin + integer(i_kind),intent(in) :: istart + integer(i_kind),intent(in) :: jstart + INTEGER(i_kind),intent(in) :: numref + + INTEGER(i_kind),intent(out):: Nmsclvl + real(r_kind), intent(out):: ref_mosaic31(nlon,nlat,31) +! +! local +! + real(r_kind),allocatable :: ref_in(:,:) + + character(10) :: obstype + integer(i_kind):: nreal,nchanl,ilat1s,ilon1s + character(20) :: isis + + INTEGER(i_kind) :: i, ii,jj, k + INTEGER(i_kind) :: ib,jb + +! + ib=jstart ! begin i point of this domain + jb=istart ! begin j point of this domain + + read(lunin) obstype,isis,nreal,nchanl + + ilon1s=1 + ilat1s=2 + Nmsclvl = nreal - 2 + IF( Nmsclvl .ne. 21 .and. Nmsclvl .ne.31) then + write(6,*) ' read_radar_ref: ', & + 'vertical dimesion inconsistent when read in reflectivty mosaic' + write(6,*) 'read in:',Nmsclvl + write(6,*) 'need:', 21, 'or', 31 + call stop2(114) + ENDIF + allocate( ref_in(nreal,numref) ) + ref_mosaic31=-9999.0_r_kind + + read(lunin) ref_in + DO i=1,numref + ii=int(ref_in(ilon1s,i)+0.001_r_kind) - ib + 2 + jj=int(ref_in(ilat1s,i)+0.001_r_kind) - jb + 2 + if( ( ii >= 1 .and. ii <= nlon ) .and. & + ( jj >= 1 .and. jj <= nlat ) ) then + DO k=1,Nmsclvl + ref_mosaic31(ii,jj,k)=ref_in(2+k,i) + ENDDO + else + write(6,*) 'read_radar_ref: Error ii or jj:',mype,ii,jj,i,ib,jb + endif + ENDDO + deallocate(ref_in) + +END SUBROUTINE read_radar_ref diff --git a/src/GSD/gsdcloud/smooth.f90 b/src/GSD/gsdcloud/smooth.f90 new file mode 100644 index 0000000000..19372bfdc5 --- /dev/null +++ b/src/GSD/gsdcloud/smooth.f90 @@ -0,0 +1,98 @@ + SUBROUTINE SMOOTH (FIELD,HOLD,IX,IY,SMTH) +!C$$$ SUBPROGRAM DOCUMENTATION BLOCK +!C . . . . +!C SUBPROGRAM: SMOOTH SMOOTH A METEOROLOGICAL FIELD +!C PRGMMR: STAN BENJAMIN ORG: FSL/PROFS DATE: 90-06-15 +!C +!C ABSTRACT: SHAPIRO SMOOTHER. +!C +!C PROGRAM HISTORY LOG: +!C 85-12-09 S. BENJAMIN ORIGINAL VERSION +!C +!C USAGE: CALL SMOOTH (FIELD,HOLD,IX,IY,SMTH) +!C INPUT ARGUMENT LIST: +!C FIELD - REAL ARRAY FIELD(IX,IY) +!C METEOROLOGICAL FIELD +!C HOLD - REAL ARRAY HOLD(IX,2) +!C HOLDING THE VALUE FOR FIELD +!C IX - INTEGER X COORDINATES OF FIELD +!C IY - INTEGER Y COORDINATES OF FIELD +!C SMTH - REAL +!C +!C OUTPUT ARGUMENT LIST: +!C FIELD - REAL ARRAY FIELD(IX,IY) +!C SMOOTHED METEOROLOGICAL FIELD +!C +!C REMARKS: REFERENCE: SHAPIRO, 1970: "SMOOTHING, FILTERING, AND +!C BOUNDARY EFFECTS", REV. GEOPHYS. SP. PHYS., 359-387. +!C THIS FILTER IS OF THE TYPE +!C Z(I) = (1-S)Z(I) + S(Z(I+1)+Z(I-1))/2 +!C FOR A FILTER WHICH IS SUPPOSED TO DAMP 2DX WAVES COMPLETELY +!C BUT LEAVE 4DX AND LONGER WITH LITTLE DAMPING, +!C IT SHOULD BE RUN WITH 2 PASSES USING SMTH (OR S) OF 0.5 +!C AND -0.5. +!C +!C ATTRIBUTES: +!C$$$ +!C********************************************************************** +!C********************************************************************** + + + use gsd_kinds, only: r_kind,i_kind,r_single + implicit none +!C********************************************************************** + INTEGER(i_kind),INTENT(IN) :: IX,IY + real(r_kind),intent(inout) :: FIELD(IX,IY) + real(r_kind),intent(inout) :: HOLD (IX,2) + real(r_kind),intent(in) :: SMTH +!C********************************************************************** + real(r_kind) :: SMTH1,SMTH2,SMTH3,SMTH4,SMTH5 + INTEGER(i_kind) :: I1,I2,I,J,IT + real(r_kind) :: SUM1,SUM2 + + SMTH1 = 0.25 * SMTH * SMTH + SMTH2 = 0.5 * SMTH * (1.-SMTH) + SMTH3 = (1.-SMTH) * (1.-SMTH) + SMTH4 = (1.-SMTH) + SMTH5 = 0.5 * SMTH + I1 = 2 + I2 = 1 + DO J=2,IY-1 + IT = I1 + I1 = I2 + I2 = IT + DO I = 2,IX-1 + SUM1 = FIELD (I-1,J+1) + FIELD (I-1,J-1) & + + FIELD (I+1,J+1) + FIELD (I+1,J-1) + SUM2 = FIELD (I ,J+1) + FIELD (I+1,J ) & + + FIELD (I ,J-1) + FIELD (I-1,J ) + HOLD(I,I1) = SMTH1*SUM1 + SMTH2*SUM2 + SMTH3*FIELD(I,J) + ENDDO + IF (J /= 2) THEN + DO I=2,IX-1 + FIELD(I,J-1) = HOLD(I,I2) + ENDDO + ENDIF + ENDDO + + + DO I = 2,IX-1 + FIELD (I,IY-1) = HOLD(I,I1) + ENDDO + + DO I = 2,IX-1 + FIELD(I,1) = SMTH4* FIELD(I,1) & + + SMTH5 * (FIELD(I-1,1) + FIELD(I+1,1)) + FIELD(I,IY) = SMTH4* FIELD(I,IY) & + + SMTH5 * (FIELD(I-1,IY) + FIELD(I+1,IY)) + ENDDO + + DO J = 2,IY-1 + FIELD(1,J) = SMTH4* FIELD(1,J) & + + SMTH5 * (FIELD(1,J-1) + FIELD(1,J+1)) + FIELD(IX,J) = SMTH4* FIELD(IX,J) & + + SMTH5 * (FIELD(IX,J-1) + FIELD(IX,J+1)) + ENDDO + + RETURN + END diff --git a/src/GSD/gsdcloud/vinterp_radar_ref.f90 b/src/GSD/gsdcloud/vinterp_radar_ref.f90 new file mode 100644 index 0000000000..6638885806 --- /dev/null +++ b/src/GSD/gsdcloud/vinterp_radar_ref.f90 @@ -0,0 +1,142 @@ +SUBROUTINE vinterp_radar_ref(mype,nlon,nlat,nsig,Nmsclvl,ref_mos_3d,ref_mosaic31,h_bk,zh) +! +! +!$$$ subprogram documentation block +! . . . . +! subprogram: interp_radar_ref radar observation vertical interpolation +! +! PRGMMR: Ming Hu ORG: GSD/AMB DATE: 2006-11-17 +! +! ABSTRACT: +! This subroutine interpolate radar reflectivity vertically +! +! PROGRAM HISTORY LOG: +! 2009-01-20 Hu Add NCO document block +! +! +! input argument list: +! mype - processor ID +! nlon - no. of lons on subdomain (buffer points on ends) +! nlat - no. of lats on subdomain (buffer points on ends) +! nsig - no. of levels +! Nmsclvl - vertical level of radar observation ref_mosaic31 +! ref_mosaic31- radar reflectivity horizontally in analysis grid and vertically +! in mosaic grid (height) +! h_bk - 3D background height +! zh - terrain +! +! output argument list: +! ref_mos_3d - 3D radar reflectivity in analysis grid +! +! USAGE: +! INPUT FILES: +! +! OUTPUT FILES: +! +! REMARKS: +! +! ATTRIBUTES: +! LANGUAGE: FORTRAN 90 +! MACHINE: Linux cluster (WJET) +! +!$$$ +! +!_____________________________________________________________________ +! + use gsd_kinds, only: r_kind,i_kind, r_single + implicit none + + INTEGER(i_kind), intent(in) :: mype + INTEGER(i_kind), intent(in) :: nlon + INTEGER(i_kind), intent(in) :: nlat + INTEGER(i_kind), intent(in) :: nsig + INTEGER(i_kind), intent(in) :: Nmsclvl + real(r_single), intent(in) :: h_bk(nlon,nlat,nsig) ! 3D height + real(r_single), intent(in) :: zh(nlon,nlat) ! terrain + real(r_kind), intent(in) :: ref_mosaic31(nlon,nlat,Nmsclvl) + real(r_kind), intent(out):: ref_mos_3d(nlon,nlat,nsig) ! reflectivity in grid +! +! local +! + real(r_kind) :: msclvl21(21),msclvlAll(31) + DATA msclvl21/1, 1.5, 2, 2.5, 3, 3.5, 4, 4.5, 5, 6, 7, & + 8, 9, 10, 11, 12, 13, 14, 15, 16, 17/ + DATA msclvlAll/0.5, 0.75, 1, 1.25, 1.5, 1.75, 2, 2.25, 2.5, 2.75, & + 3, 3.5, 4, 4.5, 5, 5.5, 6, 6.5, 7, 7.5, 8, 8.5, & + 9, 10, 11, 12, 13, 14, 15, 16, 18/ +! + REAL(r_kind) :: heightGSI,upref,downref,wght + INTEGER(i_kind) :: ilvl,numref + + real(r_kind) :: ref_mosaic + INTEGER(i_kind) :: i,j, k2, k + +! + if(Nmsclvl < -888 ) then + write(6,*) 'interp_radar_ref: No radar reflectivity data in this subdomain !' + return + endif +! + ref_mos_3d=-99999.0_r_kind + numref=0 + if (Nmsclvl == 31 ) then + DO k=1,Nmsclvl + msclvlAll(k)=msclvlAll(k)*1000.0_r_kind + ENDDO + elseif( Nmsclvl == 21 ) then + msclvlAll=0 + DO k=1,Nmsclvl + msclvlAll(k)=msclvl21(k)*1000.0_r_kind + ENDDO + else + write(6,*) 'interp_radar_ref: Wrong vertical radar mosaic levels' + write(6,*) ' the level read in is:', msclvlAll + call stop2(114) + endif + + DO k2=1,nsig + DO j=2,nlat-1 + DO i=2,nlon-1 + heightGSI=h_bk(i,j,k2)+zh(i,j) + if(heightGSI >= msclvlAll(1) .and. heightGSI < msclvlAll(Nmsclvl) ) then + do k=1,Nmsclvl-1 + if( heightGSI >=msclvlAll(k) .and. heightGSI < msclvlAll(k+1) ) ilvl=k + enddo + upref=ref_mosaic31(i,j,ilvl+1) + downref=ref_mosaic31(i,j,ilvl) + if(abs(upref) <90.0_r_kind .and. abs(downref) <90.0_r_kind ) then + wght=(heightGSI-msclvlAll(ilvl))/(msclvlAll(ilvl+1)-msclvlAll(ilvl)) + ref_mosaic=(1-wght)*downref + wght*upref + numref=numref+1 + elseif( abs(upref+99.0_r_kind) < 0.1_r_kind .or. & + abs(downref+99.0_r_kind) <0.1_r_kind ) then + ref_mosaic=-99.0_r_kind + else + ref_mosaic=-99999.0_r_kind + endif + ref_mos_3d(i,j,k2)=max(ref_mos_3d(i,j,k2),ref_mosaic) + else + ref_mos_3d(i,j,k2)=-99999.0_r_kind + endif + ENDDO + ENDDO + ENDDO + +! + DO k2=1,nsig + DO i=2,nlon-1 + ref_mos_3d(i,1,k2)=ref_mos_3d(i,2,k2) + ref_mos_3d(i,nlat,k2)=ref_mos_3d(i,nlat-1,k2) + ENDDO + DO j=2,nlat-1 + ref_mos_3d(1,j,k2)=ref_mos_3d(2,j,k2) + ref_mos_3d(nlon,j,k2)=ref_mos_3d(nlon-1,j,k2) + ENDDO + ref_mos_3d(nlon,nlat,k2)=ref_mos_3d(nlon-1,nlat-1,k2) + ref_mos_3d(nlon,1,k2)=ref_mos_3d(nlon-1,2,k2) + ref_mos_3d(1,nlat,k2)=ref_mos_3d(2,nlat-1,k2) + ref_mos_3d(1,j,k2)=ref_mos_3d(2,2,k2) + ENDDO + + +END SUBROUTINE vinterp_radar_ref diff --git a/src/GSD/gsdcloud4nmmb/ARPS_cldLib.f90 b/src/GSD/gsdcloud4nmmb/ARPS_cldLib.f90 new file mode 100755 index 0000000000..7017e9e80f --- /dev/null +++ b/src/GSD/gsdcloud4nmmb/ARPS_cldLib.f90 @@ -0,0 +1,1405 @@ +! +!$$$ subprogram documentation block +! . . . . +! subprogram: ARPS_cldLib +! +! PRGMMR: Ming Hu ORG: GSD/AMB DATE: +! +! ABSTRACT: +! This file include a collection of subroutines that are related to +! cloud analysis from ARPS cloud analysis +! +! PROGRAM HISTORY LOG: +! 2009-01-02 Hu Add NCO document block +! +! +! input argument list: +! +! output argument list: +! +! USAGE: +! INPUT FILES: +! +! OUTPUT FILES: +! +! REMARKS: +! +! ATTRIBUTES: +! LANGUAGE: FORTRAN 90 +! MACHINE: Linux cluster (WJET) +! +!$$$ +! +!_____________________________________________________________________ +! +! +! +!################################################################## +!################################################################## +!###### ###### +!###### SUBROUTINE GET_STABILITY ###### +!###### ###### +!###### Developed by ###### +!###### Center for Analysis and Prediction of Storms ###### +!###### University of Oklahoma ###### +!###### ###### +!################################################################## +!################################################################## +! + +SUBROUTINE get_stability (nz,t_1d,zs_1d,p_mb_1d,kbtm,ktop & + ,dte_dz_1d) +! +! +!----------------------------------------------------------------------- +! +! PURPOSE: +! This routine returns stability at a given level given +! 1D temperature and pressure array inputs +! +!----------------------------------------------------------------------- +! +! AUTHOR: Jian Zhang +! 05/96 Based on LAPS cloud analysis code of 07/95 +! +! MODIFICATION HISTORY: +! +! 05/11/96 (J. Zhang) +! Modified for ADAS format. Added full documentation. +! +!----------------------------------------------------------------------- +! +!----------------------------------------------------------------------- +! +! Variable Declarations. +! +!----------------------------------------------------------------------- +! + use kinds, only: r_single,i_kind,r_kind + IMPLICIT NONE +! +!----------------------------------------------------------------------- +! +! INPUT: + integer(i_kind),INTENT(IN) :: nz ! number of vertical model levels + REAL(r_single) ,INTENT(IN) :: t_1d(nz) ! temperature (degree Kelvin) profile + REAL(r_single) ,INTENT(IN) :: zs_1d(nz) ! heights (m MSL) of each level + REAL(r_single) ,INTENT(IN) :: p_mb_1d(nz)! pressure (mb) at each level + INTEGER(i_kind),INTENT(IN) :: kbtm,ktop ! indices of the bottom and top cloud layer +! +! OUTPUT: + REAL(r_single) ,INTENT(out):: dte_dz_1d(nz) ! stability array +! +! LOCAL: + REAL(r_single) :: thetae_1d(nz) ! (equivalent) potential temperature. +! +!----------------------------------------------------------------------- +! +! Misc local variables +! +!----------------------------------------------------------------------- +! + INTEGER(i_kind) :: k,km1,kp1,klow,khigh + REAL(r_single) :: os_fast +! +!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ +! +! Beginning of executable code... +! +!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ +! +! +!----------------------------------------------------------------------- +! +! Calculate Stability +! +!----------------------------------------------------------------------- +! + klow = MAX(kbtm-1,1) + khigh = MIN(ktop+1,nz-1) + + DO k = klow,khigh + thetae_1d(k) = os_fast(t_1d(k), p_mb_1d(k)) + END DO ! k + + dte_dz_1d=0._r_kind + + DO k = kbtm,ktop + km1 = MAX(k-1,1) + kp1 = MIN(k+1,nz-1) + + IF( (zs_1d(kp1) - zs_1d(km1)) <= 0._r_kind) THEN + write(6,*) 'GNRLCLD_mpi, get_stability: Error in get_stability ' + write(6,*) 'GNRLCLD_mpi, get_stability: k,kp1,km1 = ',k,kp1,km1 + write(6,*) 'GNRLCLD_mpi, get_stability: zs_1d(kp1),zs_1d(km1)= ',zs_1d(kp1),zs_1d(km1), & + (zs_1d(kp1) - zs_1d(km1)) + call STOP2(114) + ELSE + dte_dz_1d(k) = (thetae_1d(kp1) - thetae_1d(km1)) & + / (zs_1d(kp1) - zs_1d(km1)) + END IF + END DO ! k + + RETURN +END SUBROUTINE get_stability + + +! +!################################################################## +!################################################################## +!###### ###### +!###### FUNCTION OS_FAST ###### +!###### ###### +!################################################################## +!################################################################## +! + + FUNCTION os_fast(tk,p) +! +!----------------------------------------------------------------------- +! +! PURPOSE: +! +! THIS FUNCTION RETURNS THE EQUIVALENT POTENTIAL TEMPERATURE OS +! (K) FOR A PARCEL OF AIR SATURATED AT TEMPERATURE T (K) +! AND PRESSURE P (MILLIBARS). +! +! +!----------------------------------------------------------------------- +! +! AUTHOR: (BAKER,SCHLATTER) +! 05/17/1982 +! +! +! MODIFICATION HISTORY: +! 05/11/96 (Jian Zhang) +! Modified for ADAS grid. Add document stuff. +! +!----------------------------------------------------------------------- +! +! Variables declaration +! +!----------------------------------------------------------------------- +! + use kinds, only: r_single,i_kind,r_kind + IMPLICIT NONE +! +!----------------------------------------------------------------------- +! +! INPUT: + REAL(r_single) ,INTENT(IN) :: tk ! temperature in kelvin + REAL(r_single) ,INTENT(IN) :: p ! pressure in mb +! +! OUTPUT: + REAL(r_single) :: os_fast ! equivalent potential temperature +! +! LOCAL: + REAL(r_kind) :: b ! empirical const. approx.= latent heat of + ! vaporiz'n for water devided by the specific + ! heat at const. pressure for dry air. + DATA b/2.6518986_r_kind/ + + REAL(r_kind) :: tc,x,w + REAL(r_kind) :: eslo +! +!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ +! +! Beginning of executable code... +! +!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ +! + tc = tk - 273.15_r_kind +! +!----------------------------------------------------------------------- +! +! From W routine +! +!----------------------------------------------------------------------- +! + x= eslo(tc) + w= 622._r_kind*x/(p-x) + + os_fast= tk*((1000._r_kind/p)**.286_r_kind)*(EXP(b*w/tk)) + + RETURN + END FUNCTION os_fast + + + +! +! +!################################################################## +!################################################################## +!###### ###### +!###### SUBROUTINE GET_CLOUDTYPE ###### +!###### ###### +!###### Developed by ###### +!###### Center for Analysis and Prediction of Storms ###### +!###### University of Oklahoma ###### +!###### ###### +!################################################################## +!################################################################## +! + +SUBROUTINE get_cloudtype(temp_k,dte_dz,cbase_m,ctop_m & + ,itype,c2_type) +! +!----------------------------------------------------------------------- +! +! PURPOSE: +! This routine returns cloud type at a given point given +! temperature and stability inputs +! +!----------------------------------------------------------------------- +! +! AUTHOR: Jian Zhang +! 05/96 Based on the LAPS cloud analysis code of 05/1995 +! +! MODIFICATION HISTORY: +! +! 05/11/96 (J. Zhang) +! Modified for ADAS format. Added full documentation. +! +!----------------------------------------------------------------------- +! +!----------------------------------------------------------------------- +! +! Variable Declarations. +! +!----------------------------------------------------------------------- +! + use kinds, only: r_single,i_kind,r_kind + IMPLICIT NONE +! +!----------------------------------------------------------------------- +! +! INPUT: + REAL(r_single),INTENT(IN) :: temp_k ! temperature + REAL(r_single),INTENT(IN) :: dte_dz ! stability factor + REAL(r_single),INTENT(IN) :: cbase_m ! height at cloud base level + REAL(r_single),INTENT(IN) :: ctop_m ! height at cloud top level +! +! OUTPUT: + INTEGER(i_kind),INTENT(out):: itype ! cloud type index + CHARACTER (LEN=2) :: c2_type +! +! LOCAL: + CHARACTER (LEN=2) :: c2_cldtyps(10) + + DATA c2_cldtyps /'St','Sc','Cu','Ns','Ac' & + ,'As','Cs','Ci','Cc','Cb'/ +! +!----------------------------------------------------------------------- +! +! Misc local variables +! +!----------------------------------------------------------------------- +! + REAL(r_kind) :: depth_m,temp_c +! +!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ +! +! Beginning of executable code... +! +!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ +! + temp_c = temp_k - 273.15_r_kind + depth_m = ctop_m - cbase_m +! +!----------------------------------------------------------------------- +! +! Go from Stability to Cloud Type +! +!----------------------------------------------------------------------- +! + IF ( temp_c >= -10._r_kind) THEN + IF (dte_dz >= +.001_r_kind) THEN + itype = 1 ! St + ELSE IF (dte_dz < +.001_r_kind .AND. dte_dz >= -.001_r_kind) THEN + itype = 2 ! Sc + ELSE IF (dte_dz < -.001_r_kind .AND. dte_dz >= -.005_r_kind) THEN + itype = 3 ! Cu + ELSE ! dte_dz .lt. -.005 + IF(depth_m > 5000) THEN + itype = 10 ! Cb + ELSE ! depth < 5km + itype = 3 ! Cu + END IF + END IF + + ELSE IF (temp_c < -10._r_kind .AND. temp_c >= -20._r_kind) THEN + + IF (dte_dz < 0._r_kind) THEN + IF(depth_m > 5000) THEN + itype = 10 ! Cb + ELSE + itype = 5 ! Ac + END IF + ELSE + itype = 6 ! As + END IF + + ELSE ! temp_c.lt.-20. + + IF (dte_dz >= +.0005_r_kind) THEN + itype = 7 ! Cs + ELSE IF (dte_dz < +.0005_r_kind .AND. dte_dz >= -.0005_r_kind) THEN + itype = 8 ! Ci + ELSE ! dte_dz .lt. -.0005 + itype = 9 ! Cc + END IF + + IF(depth_m > 5000 .AND. dte_dz < -.0000_r_kind) THEN + itype = 10 ! Cb + END IF + + END IF + + c2_type = c2_cldtyps(itype) + + RETURN +END SUBROUTINE get_cloudtype + +! +!################################################################## +!################################################################## +!###### ###### +!###### SUBROUTINE GET_SFM_1D ###### +!###### ###### +!###### Developed by ###### +!###### Center for Analysis and Prediction of Storms ###### +!###### University of Oklahoma ###### +!###### ###### +!################################################################## +!################################################################## +! + +SUBROUTINE get_sfm_1d (nz,zcb,zctop,zs_1d,p_mb_1d,t_1d,ql,qi,cldt, & + l_prt) +! +!----------------------------------------------------------------------- +! +! PURPOSE: +!c----------------------------------------------------------------- +!c +!c This is the streamlined version of the Smith-Feddes +!c and Temperature Adjusted LWC calculation methodologies +!c produced at Purdue University under sponsorship +!c by the FAA Technical Center. +!c +!c Currently, this subroutine will only use the Smith- +!c Feddes and will only do so as if there are solely +!c stratiform clouds present, however, it is very easy +!c to switch so that only the Temperature Adjusted +!c method is used. +!c +!c Dilution by glaciation is also included, it is a +!c linear function of in cloud temperature going from +!c all liquid water at -10 C to all ice at -30 C +!c as such the amount of ice is also calculated +! +!----------------------------------------------------------------------- +! +! AUTHOR: Jian Zhang +! 05/96 Based on the LAPS cloud analysis code of 07/1995 +! +! MODIFICATION HISTORY: +! +! 05/16/96 (Jian Zhang) +! Modified for ADAS format. Added full documentation. +! +!----------------------------------------------------------------------- +! +!----------------------------------------------------------------------- +! +! Variable Declarations. +! +!----------------------------------------------------------------------- +! + use kinds, only: r_single,i_kind + IMPLICIT NONE +! +! +!----------------------------------------------------------------------- +! +! INPUT: + INTEGER(i_kind),intent(in) :: nz ! number of model vertical levels + REAL(r_single),intent(in) :: zs_1d(nz) ! physical height (m) at each scalar level + REAL(r_single),intent(in) :: p_mb_1d(nz)! pressure (mb) at each level + REAL(r_single),intent(in) :: t_1d(nz) ! temperature (K) at each level + + REAL(r_single),intent(in) :: zcb ! cloud base height (m) + REAL(r_single),intent(in) :: zctop ! cloud top height (m) +! +! OUTPUT: + REAL(r_single),intent(out) :: ql(nz) ! liquid water content (g/kg) + REAL(r_single),intent(out) :: qi(nz) ! ice water content (g/kg) + REAL(r_single),intent(out) :: cldt(nz) +! +! LOCAL: + REAL(r_single) :: calw(200) + REAL(r_single) :: cali(200) + REAL(r_single) :: catk(200) + REAL(r_single) :: entr(200) +! +!----------------------------------------------------------------------- +! +! Misc local variables +! +!----------------------------------------------------------------------- +! + REAL(r_single) :: dz,rv,rair,grav,cp,rlvo,rlso,dlvdt,eso + REAL(r_single) :: c,a1,b1,c1,a2,b2,c2 + REAL(r_single) :: delz,delt,cldbtm,cldbp,cldtpt,tbar + REAL(r_single) :: arg,fraclw,tlwc + REAL(r_single) :: temp,press,zbase,alw,zht,ht,y + REAL(r_single) :: rl,es,qvs1,p,des,dtz,es2,qvs2 + INTEGER(i_kind):: i,j,k,nlevel,nlm1,ip,kctop,kctop1,kcb,kcb1 + REAL(r_single) :: dtdz,dttdz,zcloud,entc,tmpk + LOGICAL :: l_prt +! +!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ +! +! Beginning of executable code... +! +!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ +! +! +!----------------------------------------------------------------------- +! +! Initialize 1d liquid water and ice arrays (for 100m layers) +! +!----------------------------------------------------------------------- +! + DO i=1,200 + calw(i)=0.0_r_single + cali(i)=0.0_r_single + END DO +! if(i_prt.le.20) then +! i_prt=i_prt+1 +! l_prt=.true. +! else +! l_prt=.false. +! endif +! +!----------------------------------------------------------------------- +! +! Preset some constants and coefficients. +! +!----------------------------------------------------------------------- +! + dz=100.0_r_single ! m + rv=461.5_r_single ! J/deg/kg + rair=287.04_r_single ! J/deg/kg + grav=9.81_r_single ! m/s2 + cp=1004._r_single ! J/deg/kg + rlvo=2.5003E+6_r_single ! J/kg + rlso=2.8339E+6_r_single ! J/kg + dlvdt=-2.3693E+3_r_single ! J/kg/K + eso=610.78_r_single ! pa + c=0.01_r_single + a1=8.4897_r_single + b1=-13.2191_r_single + c1=4.7295_r_single + a2=10.357_r_single + b2=-28.2416_r_single + c2=8.8846_r_single +! +!----------------------------------------------------------------------- +! +! Calculate indices of cloud top and base +! +!----------------------------------------------------------------------- +! + DO k=1,nz-1 + IF(zs_1d(k) < zcb .AND. zs_1d(k+1) > zcb) THEN + kcb=k + kcb1=kcb+1 + END IF + IF(zs_1d(k) < zctop .AND. zs_1d(k+1) > zctop) THEN + kctop=k + kctop1=kctop+1 + END IF + END DO +! +!----------------------------------------------------------------------- +! +! Obtain cloud base and top conditions +! +!----------------------------------------------------------------------- +! + delz = zs_1d(kcb+1)-zs_1d(kcb) + delt = t_1d(kcb+1)-t_1d(kcb) + cldbtm = delt*(zcb-zs_1d(kcb))/delz+t_1d(kcb) + tbar = (cldbtm+t_1d(kcb))/2._r_single + arg = -grav*(zcb-zs_1d(kcb))/rair/tbar + cldbp = p_mb_1d(kcb)*EXP(arg) + delz = zs_1d(kctop+1)-zs_1d(kctop) + delt = t_1d(kctop+1)-t_1d(kctop) + cldtpt = delt*(zctop-zs_1d(kctop))/delz+t_1d(kctop) +! +!----------------------------------------------------------------------- +! +! Calculate cloud lwc profile for cloud base/top pair +! +!----------------------------------------------------------------------- +! + temp = cldbtm + press = cldbp*100.0_r_single + zbase = zcb + nlevel = ((zctop-zcb)/100.0_r_single)+1 + IF(nlevel <= 0) nlevel=1 + alw = 0.0_r_single + calw(1)= 0.0_r_single + cali(1)= 0.0_r_single + catk(1)= temp + entr(1)= 1.0_r_single + nlm1 = nlevel-1 + IF(nlm1 < 1) nlm1=1 + zht = zbase + + DO j=1,nlm1 + rl = rlvo+(273.15_r_single-temp)*dlvdt + arg = rl*(temp-273.15_r_single)/273.15_r_single/temp/rv + es = eso*EXP(arg) + qvs1 = 0.622_r_single*es/(press-es) +! rho1 = press/(rair*temp) + arg = -grav*dz/rair/temp + p = press*EXP(arg) +! +!----------------------------------------------------------------------- +! +! Calculate saturated adiabatic lapse rate +! +!----------------------------------------------------------------------- +! + des = es*rl/temp/temp/rv + dtz = -grav*((1.0_r_single+0.621_r_single*es*rl/(press*rair*temp))/ & + (cp+0.621_r_single*rl*des/press)) + zht = zht+dz + press = p + temp = temp+dtz*dz + rl = rlvo+(273.15_r_single-temp)*dlvdt + arg = rl*(temp-273.15_r_single)/273.15_r_single/temp/rv + es2 = eso*EXP(arg) + qvs2 = 0.622_r_single*es2/(press-es2) + + alw = alw+(qvs1-qvs2) ! kg/kg + calw(j+1) = alw +! +!----------------------------------------------------------------------- +! +! Reduction of lwc by entrainment +! +!----------------------------------------------------------------------- +! + ht = (zht-zbase)*.001_r_single +! +!c ------------------------------------------------------------------ +!c +!c skatskii's curve(convective) +!c +!c ------------------------------------------------------------------ +!c if(ht.lt.0.3) then +!c y = -1.667*(ht-0.6) +!c elseif(ht.lt.1.0) then +!c arg1 = b1*b1-4.0*a1*(c1-ht) +!c y = (-b1-sqrt(arg1))/(2.0*a1) +!c elseif(ht.lt.2.9) then +!c arg2 = b2*b2-4.0*a2*(c2-ht) +!c y = (-b2-sqrt(arg2))/(2.0*a2) +!c else +!c y = 0.26 +!c endif +!c +!c ------------------------------------------------------------------ +!c +!c warner's curve(stratiform) +!c +!c ------------------------------------------------------------------ + IF(ht < 0.032_r_single) THEN + y = -11.0_r_single*ht+1.0_r_single ! y(ht=0.032) = 0.648 + ELSE IF(ht <= 0.177_r_single) THEN + y = -1.4_r_single*ht+0.6915_r_single ! y(ht=0.177) = 0.4437 + ELSE IF(ht <= 0.726_r_single) THEN + y = -0.356_r_single*ht+0.505_r_single ! y(ht=0.726) = 0.2445 + ELSE IF(ht <= 1.5_r_single) THEN + y = -0.0608_r_single*ht+0.2912_r_single ! y(ht=1.5) = 0.2 + ELSE + y = 0.20_r_single + END IF +! +!----------------------------------------------------------------------- +! +! Calculate reduced lwc by entrainment and dilution +! +! Note at -5 C and warmer, all liquid. ! changed from -10 KB +! at -25 C and colder, all ice ! changed from -30 KB +! Linear ramp between. +! +!----------------------------------------------------------------------- +! + IF(temp < 268.15_r_single) THEN + IF(temp > 248.15_r_single) THEN + fraclw=0.05*(temp-248.15_r_single) + ELSE + fraclw=0.0_r_single + END IF + ELSE + fraclw=1.0_r_single + END IF + + tlwc=1000._r_single*y*calw(j+1) ! g/kg + calw(j+1)=tlwc*fraclw + cali(j+1)=tlwc*(1._r_single-fraclw) + catk(j+1)=temp + entr(j+1)=y + + END DO +! +!----------------------------------------------------------------------- +! +! Obtain profile of LWCs at the given grid point +! +!----------------------------------------------------------------------- +! + DO ip=2,nz-1 + IF(zs_1d(ip) <= zcb .OR. zs_1d(ip) > zctop) THEN + ql(ip)=0.0_r_single + qi(ip)=0.0_r_single + cldt(ip)=t_1d(ip) + ELSE + DO j=2,nlevel + zcloud = zcb+(j-1)*dz + IF(zcloud >= zs_1d(ip)) THEN + ql(ip) = (zs_1d(ip)-zcloud+100._r_single)* & + (calw(j)-calw(j-1))*0.01_r_single+calw(j-1) + qi(ip) = (zs_1d(ip)-zcloud+100._r_single)* & + (cali(j)-cali(j-1))*0.01_r_single+cali(j-1) + tmpk = (zs_1d(ip)-zcloud+100._r_single)* & + (catk(j)-catk(j-1))*0.01_r_single & + +catk(j-1) + entc = (zs_1d(ip)-zcloud+100._r_single)* & + (entr(j)-entr(j-1))*0.01_r_single & + +entr(j-1) + cldt(ip) = (1.-entc)*t_1d(ip) + entc*tmpk + + EXIT + END IF + END DO + END IF + END DO +! + RETURN +END SUBROUTINE get_sfm_1d + + +! +! +!################################################################## +!################################################################## +!###### ###### +!###### SUBROUTINE PCP_TYPE_3D ###### +!###### ###### +!###### Developed by ###### +!###### Center for Analysis and Prediction of Storms ###### +!###### University of Oklahoma ###### +!###### ###### +!################################################################## +!################################################################## +! + +SUBROUTINE pcp_type_3d (nx,ny,nz,temp_3d,rh_3d,p_pa_3d & + ,radar_3d,l_mask,cldpcp_type_3d,istatus) + +! +!----------------------------------------------------------------------- +! +! PURPOSE: +! This routine returns 3D cloud and precipitation type field. +! +!----------------------------------------------------------------------- +! +! AUTHOR: Jian Zhang +! 05/1996 Based on the LAPS cloud analysis code developed by +! Steve Albers. +! +! This program modifies the most significant 4 bits of the integer +! array by inserting multiples of 16. +! +! MODIFICATION HISTORY: +! +! 05/16/96 (J. Zhang) +! Modified for ADAS format. Added full documentation. +! 01/20/98 (J. Zhang) +! Fixed a bug that no precip. type was assigned for a +! grid point at the top of the radar echo with Tw +! falling in the range of 0 to 1.3 degree C. +! 01/21/98 (J. Zhang) +! Fixed a bug that does the freezing/refreezing test +! on ice precipitates. +! 02/17/98 (J. Zhang) +! Change the hail diagnose procedure. +! +!----------------------------------------------------------------------- +! +!----------------------------------------------------------------------- +! +! Variable Declarations. +! +!----------------------------------------------------------------------- +! + use kinds, only: r_single,i_kind, r_kind + IMPLICIT NONE +! +!----------------------------------------------------------------------- +! +! INPUT: + INTEGER(i_kind), intent(in) :: nx,ny,nz ! Model grid size + REAL(r_single), intent(in) :: temp_3d(nx,ny,nz) ! temperature (K) + REAL(r_single), intent(in) :: rh_3d(nx,ny,nz) ! relative humudity + REAL(r_single), intent(in) :: p_pa_3d(nx,ny,nz) ! pressure (Pascal) + REAL(r_kind), intent(in) :: radar_3d(nx,ny,nz) ! radar refl. (dBZ) +! +! OUTPUT: + INTEGER(i_kind), intent(out) :: istatus + INTEGER(i_kind), intent(out) :: cldpcp_type_3d(nx,ny,nz)! cld/precip type + LOGICAL :: l_mask(nx,ny) ! "Potential" Precip Type +! +! LOCAL functions: + REAL(r_kind) :: wb_melting_thres ! define melting temp. thresh. + REAL(r_kind) :: tw ! for wet-bulb temp calcl'n +! +!----------------------------------------------------------------------- +! +! Misc local variables +! +!----------------------------------------------------------------------- +! + INTEGER(i_kind) :: itype ! cld/precip type index + INTEGER(i_kind) :: i,j,k,k_upper + REAL(r_kind) :: t_c,td_c,t_wb_c,temp_lower_c,temp_upper_c,tbar_c & + ,p_mb,thickns,frac_below_zero + INTEGER(i_kind) :: iprecip_type,iprecip_type_last,iflag_melt & + ,iflag_refreez + REAL(r_kind) :: zero_c,rlayer_refreez_max,rlayer_refreez + INTEGER(i_kind) :: n_zr,n_sl,n_last + REAL(r_kind) :: tmelt_c,x +! +!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ +! +! Beginning of executable code... +! +!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ +! +!----------------------------------------------------------------------- +! + return + istatus=0 + wb_melting_thres = 1.3 ! Units are C +! +!----------------------------------------------------------------------- +! +! Stuff precip type into cloud type array +! 0 - No Precip +! 1 - Rain +! 2 - Snow +! 3 - Freezing Rain +! 4 - Sleet +! 5 - Hail +! +!----------------------------------------------------------------------- +! + zero_c = 273.15_r_kind + rlayer_refreez_max = 0.0_r_kind + + n_zr = 0 + n_sl = 0 + n_last = 0 + + DO j = 1,ny-1 + DO i = 1,nx-1 + + iflag_melt = 0 + iflag_refreez = 0 + rlayer_refreez = 0.0_r_kind + + iprecip_type_last = 0 + + DO k = nz-1,1,-1 + + IF(radar_3d(i,j,k) >= 0._r_kind.OR. l_mask(i,j)) THEN +! +!----------------------------------------------------------------------- +! +! Set refreezing flag +! +!----------------------------------------------------------------------- +! + t_c = temp_3d(i,j,k) - zero_c +! compute dew point depression. +! td_c = dwpt(t_c,rh_3d(i,j,k)) + x = 1._r_kind-0.01_r_kind*rh_3d(i,j,k) + td_c =t_c-(14.55_r_kind+0.114_r_kind*t_c)*x+ & + ((2.5_r_kind+0.007_r_kind*t_c)*x)**3+ & + (15.9_r_kind+0.117_r_kind*t_c)*x**14 + + p_mb = 0.01_r_kind*p_pa_3d(i,j,k) + + tmelt_c = wb_melting_thres + t_wb_c = tw(t_c,td_c,p_mb) + + IF(t_wb_c < 0._r_kind) THEN + IF(iflag_melt == 1) THEN +! +!----------------------------------------------------------------------- +! +! Integrate below freezing temperature times column thickness +! - ONLY for portion of layer below freezing +! +!----------------------------------------------------------------------- +! + temp_lower_c = t_wb_c + k_upper = MIN(k+1,nz-1) +! +!----------------------------------------------------------------------- +! +! For simplicity and efficiency, the assumption is here made that +! the wet bulb depression is constant throughout the level. +! +!----------------------------------------------------------------------- +! + temp_upper_c = t_wb_c + ( temp_3d(i,j,k_upper) & + - temp_3d(i,j,k)) + IF(temp_upper_c <= 0._r_kind) THEN + frac_below_zero = 1.0_r_kind + tbar_c = 0.5_r_kind * (temp_lower_c + temp_upper_c) + + ELSE ! Layer straddles the freezing level + frac_below_zero = temp_lower_c & + / (temp_lower_c - temp_upper_c) + tbar_c = 0.5_r_kind * temp_lower_c + + END IF + + thickns = p_pa_3d(i,j,k_upper) - p_pa_3d(i,j,k) + rlayer_refreez = rlayer_refreez & + + ABS(tbar_c * thickns * frac_below_zero) + + IF(rlayer_refreez >= 25000._r_kind) THEN + iflag_refreez = 1 + END IF + + rlayer_refreez_max = & + MAX(rlayer_refreez_max,rlayer_refreez) + + END IF ! iflag_melt = 1 + + ELSE ! Temp > 0C + iflag_refreez = 0 + rlayer_refreez = 0.0 + + END IF ! T < 0.0c, Temp is below freezing +! +!----------------------------------------------------------------------- +! +! Set melting flag +! +!----------------------------------------------------------------------- +! + IF(t_wb_c >= tmelt_c) THEN + iflag_melt = 1 + END IF + + IF(t_wb_c >= tmelt_c) THEN ! Melted to Rain + iprecip_type = 1 + + ELSE ! Check if below zero_c (Refrozen Precip or Snow) + IF(t_wb_c < 0.0_r_kind) THEN + IF(iflag_melt == 1) THEN + IF(iprecip_type_last == 1 .OR.iprecip_type_last == 3) THEN + ! test if rain or zr freeze + IF(iflag_refreez == 0) THEN ! Freezing Rain + n_zr = n_zr + 1 + IF(n_zr < 30) THEN +! WRITE(6,5)i,j,k,t_wb_c,temp_3d(i,j,k) & +! ,rh_3d(i,j,k) + 5 FORMAT('zr',3I3,2F8.2,f8.1) + END IF + iprecip_type = 3 + + ELSE ! (iflag_refreez = 1) ! Sleet + n_sl = n_sl + 1 + iprecip_type = 4 + END IF ! iflag_refreez .eq. 0 + ELSE + iprecip_type = iprecip_type_last ! Unchanged + n_last = n_last + 1 + IF(n_last < 5) THEN +! WRITE(6,*)'Unchanged Precip',i,j,k,t_wb_c + END IF + END IF ! liquid precip. at upper level? + + ELSE ! iflag_melt =0 ! Snow + iprecip_type = 2 + + END IF ! iflag_melt = 1? + ELSE ! t_wb_c >= 0c, and t_wb_c < tmelt_c + + IF (iprecip_type_last == 0) THEN ! 1/20/98 + iprecip_type = 1 ! rain:at echo top and 0= tmelt_c + + ELSE ! radar_3d < 0dBZ; No Radar Echo + iprecip_type = 0 + iflag_melt = 0 + iflag_refreez = 0 + rlayer_refreez = 0.0_r_kind + + END IF ! radar_3d(i,j,k).ge.0. .or. l_mask(i,j); Radar Echo? +! +!----------------------------------------------------------------------- +! +! Insert most sig 4 bits into array +! +!----------------------------------------------------------------------- +! + itype = cldpcp_type_3d(i,j,k) + itype = itype - (itype/16)*16 ! Initialize the 4 bits + itype = itype + iprecip_type * 16 ! Add in the new value + cldpcp_type_3d(i,j,k) = itype + + iprecip_type_last = iprecip_type + + END DO ! k + END DO ! j + END DO ! i + + DO j = 1,ny-1 + DO i = 1,nx-1 + DO k = 1,nz-1 + IF(radar_3d(i,j,k) >= 50._r_kind) THEN + iprecip_type = 5 + itype = cldpcp_type_3d(i,j,k) + itype = itype - (itype/16)*16 ! Initialize the 4 bits + itype = itype + iprecip_type * 16 ! Add in the new value + cldpcp_type_3d(i,j,k) = itype + END IF + END DO ! k + END DO ! j + END DO ! i + + istatus=1 + + RETURN +END SUBROUTINE pcp_type_3d + +! +! +!################################################################## +!################################################################## +!###### ###### +!###### SUBROUTINE GET_SLWC1D ###### +!###### ###### +!###### Developed by ###### +!###### Center for Analysis and Prediction of Storms ###### +!###### University of Oklahoma ###### +!###### ###### +!################################################################## +!################################################################## +! + +SUBROUTINE get_slwc1d (nk,cbase_m,ctop_m,kbase,ktop & + ,zs_1d,t_1d,p_pa_1d,iflag_slwc,slwc_1d) + +! +!----------------------------------------------------------------------- +! +! PURPOSE: +! This routine calls a subroutine "lwc_rep" which calculates +! the adiabatic liquid water content. +! +!----------------------------------------------------------------------- +! +! AUTHOR: Jian Zhang +! 05/96 Based on the LAPS cloud analysis code of 07/1995 +! +! MODIFICATION HISTORY: +! +! 05/13/96 (Jian Zhang) +! Modified for ADAS format. Added full documentation. +! +!----------------------------------------------------------------------- +! +!----------------------------------------------------------------------- +! +! Variable Declarations. +! +!----------------------------------------------------------------------- +! + use kinds, only: r_single,i_kind,r_kind + IMPLICIT NONE +! +!----------------------------------------------------------------------- +! +! INPUT: + INTEGER(i_kind),intent(in) :: iflag_slwc ! indicator for LWC scheme option + INTEGER(i_kind),intent(in) :: nk ! number of model vertical levels + REAL(r_single),intent(in) :: t_1d(nk) ! temperature (k) in one model column + REAL(r_single),intent(in) :: zs_1d(nk) ! heights (m) at grd pts in one model column + REAL(r_single),intent(in) :: p_pa_1d(nk) ! pressure (pa) in one model column + REAL(r_single),intent(in) :: cbase_m,ctop_m ! heights (m) of cloud base and top levels + INTEGER(i_kind),intent(in) :: kbase,ktop ! vertical index of cloud base and top levels +! +! OUTPUT: + REAL(r_single),intent(out) :: slwc_1d(nk) ! estimated adiabatic liquid water +! +! LOCAL: + INTEGER(i_kind) :: i_status1,i_status2 ! flag for subroutine calling +! +!----------------------------------------------------------------------- +! +! Misc local variables +! +!----------------------------------------------------------------------- +! + INTEGER(i_kind):: k + REAL(r_single) :: p_low,p_high,cbase_pa,cbase_k,ctop_k,frac_k & + ,grid_top_pa,grid_top_k + REAL(r_single) :: fraction,thickness,dlog_space + REAL(r_single) :: adiabatic_lwc,adjusted_lwc,adjusted_slwc +! +!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ +! +! Beginning of executable code... +! +!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ +! +! +!----------------------------------------------------------------------- +! +! Initialize +! +!----------------------------------------------------------------------- +! + DO k = 1,nk + slwc_1d(k) = 0.0_r_single + END DO + + IF(ctop_m > cbase_m) THEN +! +!----------------------------------------------------------------------- +! +! Determine Lowest and Highest Grid Points within the cloud +! +!----------------------------------------------------------------------- +! + IF(ktop >= kbase .AND. kbase >= 2) THEN +! +!----------------------------------------------------------------------- +! +! Get cloud base pressure and temperature +! +!----------------------------------------------------------------------- +! + cbase_pa = -999._r_single ! Default value is off the grid + DO k = 1,nk-2 + IF(zs_1d(k+1) > cbase_m .AND. zs_1d(k) <= cbase_m) THEN + thickness = zs_1d(k+1) - zs_1d(k) + fraction = (cbase_m - zs_1d(k))/thickness + p_low = p_pa_1d(k) + p_high = p_pa_1d(k+1) + dlog_space = LOG(p_high/p_low) + cbase_pa = p_low * EXP(dlog_space*fraction) + END IF + END DO ! k + + frac_k=(cbase_m-zs_1d(kbase-1))/(zs_1d(kbase)-zs_1d(kbase-1)) + IF(frac_k /= fraction) & + PRINT*,' **GET_SLWC1D** frac=',fraction,' frac_k=',frac_k + + cbase_k = t_1d(kbase-1)*(1.0_r_single-frac_k) + t_1d(kbase)*frac_k +! +!----------------------------------------------------------------------- +! +! Get cloud top temperature +! +!----------------------------------------------------------------------- +! + frac_k = (ctop_m-zs_1d(ktop-1)) / (zs_1d(ktop)-zs_1d(ktop-1)) + ctop_k = t_1d(ktop-1)*(1.0_r_single - frac_k) + t_1d(ktop) * frac_k +! +!----------------------------------------------------------------------- +! +! Calculate SLWC at each vertical grid point. For each level +! we use an assumed cloud extending from the actual cloud base +! to the height of the grid point in question. +! +!----------------------------------------------------------------------- +! + DO k=kbase,ktop + grid_top_pa = p_pa_1d(k) + grid_top_k = t_1d(k) + + CALL slwc_revb(cbase_pa,cbase_k & + ,grid_top_pa,grid_top_k,ctop_k & + ,adiabatic_lwc,adjusted_lwc,adjusted_slwc & + ,i_status1,i_status2) +! + IF(i_status2 == 1) THEN + IF(iflag_slwc == 1) THEN + slwc_1d(k) = adiabatic_lwc + ELSE IF(iflag_slwc == 2) THEN + slwc_1d(k) = adjusted_lwc + ELSE IF(iflag_slwc == 3) THEN + slwc_1d(k) = adjusted_slwc + END IF + ELSE + WRITE(6,*)' Error Detected in SLWC' + END IF + END DO ! k + END IF ! ktop > kbase & kbase > 2, thick enough cloud exists + END IF ! ctop_m > cbase_m, cloud exists + + RETURN +END SUBROUTINE get_slwc1d + +SUBROUTINE slwc_revb(cb_pa,cb_k,gt_pa,gt_k,ct_k, & + adiabatic_lwc,adjusted_lwc,adjusted_slwc, & + i_status1,i_status2) +! +!.......................HISTORY............................. +! +! WRITTEN: CA. 1982 BY W. A. COOPER IN HP FORTRAN 4 +! +!....... CALCULATES TEMPERATURE T AND LIQUID WATER CONTENT FROM +!.. CLOUD BASE PRESSURE P0 AND TEMPERATURE T0, FOR ADIABATIC +!.. ASCENT TO THE PRESSURE P. +!.. -> INPUT: CLOUD BASE PRESSURE P0 AND TEMPERATURE T0 +!.. PRESSURE AT OBSERVATION LEVEL P +!.. -> OUTPUT: "ADIABATIC" TEMPERATURE T AND LIQUID WATER CONTENT +! +! MODIFIED: November 1989 by Paul Lawson for LAPS/WISP. Routine +! now calculates adiabatic liquid water content +! (ADIABATIC_LWC) using cloud base pressure and grid-top +! temperature and pressure. Also calculated are ADJUSTED_LWC, +! which adjusts ADIABATIC_LWC using an empirical cloud +! water depletion algorithm, and ADJUSTED_SLWC, which is +! ADIABATIC_LWC in regions where T < 0 C adjusted +! using an empirical algorithm by Marcia Politovich. +! +! Subroutine is now hardwired for stratiform cloud only. +! Can be modified to include Cu with input from LAPS main. +! +! revb: ca 12/89 Calculate adiabatic lwc by going from cloud +! base to LAPS grid level instead to cloud top, thus +! helping to better calculate in layer clouds. +! Add TG (grid temperature) to calcualtion. +! +! revc: 2/27/90 Correct error in code. Zero-out slwc when grid +! temperature (GT) > 0. +! +! J.Z.: 4/7/97 Correct error in code +! Grid temperature should be TG, not GT. +! +! +! OUTPUTS: ADIABATIC_LWC +! ADJUSTED_LWC +! ADJUSTED_SLWC +! I_STATUS1 - 1 when -20 < cld_top_temp < 0 for Stratus +! 0 Otherwise +! I_STATUS2 - 1 when valid input data provided from main +! + use kinds, only: r_single,i_kind,r_kind + IMPLICIT NONE + + real(r_single), intent(in) :: cb_pa,cb_k,gt_pa,gt_k,ct_k + real(r_single), intent(out) :: adiabatic_lwc,adjusted_lwc,adjusted_slwc + INTEGER(i_kind),intent(out) :: i_status1,i_status2 + + real(r_kind) :: eps,cpd,cw,rd,alhv + DATA eps/0.622_r_kind/,cpd/1.0042E3_r_kind/,cw/4.218E3_r_kind/,rd/287.05_r_kind/,alhv/2.501E6_r_kind/ + INTEGER(i_kind) :: cty,i + real(r_kind) :: p0,p,t0,tg,ctt,tk,e,r,cpt,t1,thetaq,rv,t,tw + real(r_kind) :: vapor +! +! + i_status1=1 + i_status2=1 +! 2 Print *,'ENTER: P-BASE(mb), T-BASE(C), P-TOP, T-TOP, CLD TYPE' +! READ(5,*) P0, T0, P, CTT, CTY +! If(CTY.ne.0.and.CTY.ne.1) Go to 2 +! +! Hardwire cloud type (CTY) for stratus for now +! + cty=0 +! +!.....Convert Pa to mb and Kelvin to Celcius +! + p0 = cb_pa/100._r_kind + p = gt_pa/100._r_kind + t0 = cb_k - 273.15_r_kind + tg = gt_k - 273.15_r_kind + ctt= ct_k - 273.15_r_kind +! Print *, 'CTT in Sub = ', CTT +! +! Check for valid input data... +! + IF(p0 > 1013._r_kind.OR.p0 < 50._r_kind) THEN + i_status2=0 + RETURN + ELSE + END IF +! +! + IF(t0 > 50._r_kind.OR.t0 < -70._r_kind) THEN + i_status2=0 + RETURN + ELSE + END IF +! +! + IF(p > 1013._r_kind.OR.p < 50._r_kind) THEN + i_status2=0 + RETURN + ELSE + END IF +! +! Set I_STATUS1 = F if 0 < cld top < -20 C (for stratus). +! + IF(tg >= 0._r_kind.OR.ctt < -20._r_kind) i_status1=0 +! + tk=t0+273.15_r_kind + e=vapor(t0) + r=eps*e/(p0-e) + cpt=cpd+r*cw + thetaq=tk*(1000._r_kind/(p0-e))**(rd/cpt)*EXP(alhv*r/(cpt*tk)) +! 1ST APPROX + t1=tk + e=vapor(t1-273.15_r_kind) + rv=eps*e/(p-e) + t1=thetaq/((1000._r_kind/(p-e))**(rd/cpt)*EXP(alhv*rv/(cpt*t1))) +! SUCCESSIVE APPROXIMATIONS + DO i=1,10 + e=vapor(t1-273.15_r_kind) + rv=eps*e/(p-e) + t1=(thetaq/((1000._r_kind/(p-e))**(rd/cpt)*EXP(alhv*rv/(cpt*t1))) & + +t1)/2._r_kind + t=t1-273.15_r_kind +! Print *, P0,T0,P,T,E,RV,THETAQ + END DO +! GET LWC + e=vapor(t) + rv=eps*e/(p-e) + tw=r-rv + adiabatic_lwc=tw*p*28.9644_r_kind/(8.314E7_r_kind*t1)*1.e9_r_kind + IF(adiabatic_lwc < 0._r_kind) adiabatic_lwc=0._r_kind +! Print *, 'Adiabtic LWC = ', ADIABATIC_LWC + IF(tg >= 0._r_kind) THEN +! + adjusted_slwc=0._r_kind ! Added 2/27/90 +! + + IF(cty == 0._r_kind) THEN + IF(ctt < -20._r_kind) THEN + adjusted_lwc=0._r_kind + ELSE IF(ctt < -15._r_kind.AND.ctt >= -20._r_kind) THEN + adjusted_lwc=adiabatic_lwc/8._r_kind + ELSE IF(ctt < -10._r_kind.AND.ctt >= -15._r_kind) THEN + adjusted_lwc=adiabatic_lwc/4._r_kind + ELSE + adjusted_lwc=adiabatic_lwc/2._r_kind + END IF + ELSE + IF(ctt < -25._r_kind) THEN + adjusted_lwc=0._r_kind + ELSE IF(ctt < -15._r_kind.AND.ctt >= -25._r_kind) THEN + adjusted_lwc=adiabatic_lwc/8._r_kind + ELSE IF(ctt < -10._r_kind.AND.ctt >= -15._r_kind) THEN + adjusted_lwc=adiabatic_lwc/4._r_kind + ELSE + adjusted_lwc=adiabatic_lwc/2._r_kind + END IF + END IF + ELSE + IF(cty == 0._r_kind) THEN + IF(ctt < -20._r_kind) THEN + adjusted_lwc=0._r_kind + adjusted_slwc=0._r_kind + ELSE IF(ctt < -15._r_kind.AND.ctt >= -20._r_kind) THEN + adjusted_lwc=adiabatic_lwc/8._r_kind + adjusted_slwc=adiabatic_lwc/8._r_kind + ELSE IF(ctt < -10._r_kind.AND.ctt >= -15._r_kind) THEN + adjusted_lwc=adiabatic_lwc/4._r_kind + adjusted_slwc=adiabatic_lwc/4._r_kind + ELSE + adjusted_lwc=adiabatic_lwc/2._r_kind + adjusted_slwc=adiabatic_lwc/2._r_kind + END IF + ELSE + IF(ctt < -25._r_kind) THEN + adjusted_lwc=0._r_kind + adjusted_slwc=0._r_kind + ELSE IF(ctt < -15._r_kind.AND.ctt >= -25._r_kind) THEN + adjusted_lwc=adiabatic_lwc/8._r_kind + adjusted_slwc=adiabatic_lwc/8._r_kind + ELSE IF(ctt < -10._r_kind.AND.ctt >= -15._r_kind) THEN + adjusted_lwc=adiabatic_lwc/4._r_kind + adjusted_slwc=adiabatic_lwc/4._r_kind + ELSE + adjusted_lwc=adiabatic_lwc/2._r_kind + adjusted_slwc=adiabatic_lwc/2._r_kind + END IF + END IF + END IF +! Print *,'Adjusted LWC = ', ADJUSTED_LWC +! Print *,'Adjusted SLWC = ', ADJUSTED_SLWC +END SUBROUTINE slwc_revb + +! FUNCTION TO CALCULATE VAPOR PRESSURE: +! + + FUNCTION vapor(tfp) +! INPUT IS IN DEGREES C. IF GT 0, ASSUMED TO BE DEW POINT. IF +! LESS THAN 0, ASSUMED TO BE FROST POINT. +! ROUTINE CODES GOFF-GRATCH FORMULA + use kinds, only: i_kind,r_kind + IMPLICIT NONE + + real(r_kind), intent(in) :: tfp + real(r_kind) :: vapor + +! + real(r_kind) :: tvap, e + + tvap=273.16_r_kind+tfp + IF(tfp > 0.) GO TO 1 +! THIS IS ICE SATURATION VAPOR PRESSURE + IF(tvap <= 0) tvap=1E-20_r_kind + e=-9.09718_r_kind*(273.16_r_kind/tvap-1._r_kind)- & + 3.56654_r_kind*LOG10(273.16_r_kind/tvap) & + +0.876793_r_kind*(1.-tvap/273.16_r_kind) + vapor=6.1071_r_kind*10._r_kind**e + RETURN + 1 CONTINUE +! THIS IS WATER SATURATION VAPOR PRESSURE + IF(tvap <= 0) tvap=1E-20_r_kind + e=-7.90298_r_kind*(373.16_r_kind/tvap-1._r_kind)+ & + 5.02808_r_kind*LOG10(373.16_r_kind/tvap) & + -1.3816E-7_r_kind*(10._r_kind**(11.344_r_kind*& + (1._r_kind-tvap/373.16_r_kind))-1._r_kind) & + +8.1328E-3_r_kind*(10._r_kind**(3.49149_r_kind& + *(1-373.16_r_kind/tvap))-1) + vapor=1013.246_r_kind*10._r_kind**e + RETURN + END FUNCTION vapor diff --git a/src/GSD/gsdcloud4nmmb/BackgroundCld.f90 b/src/GSD/gsdcloud4nmmb/BackgroundCld.f90 new file mode 100755 index 0000000000..96857711db --- /dev/null +++ b/src/GSD/gsdcloud4nmmb/BackgroundCld.f90 @@ -0,0 +1,193 @@ +SUBROUTINE BackgroundCld(mype,lon2,lat2,nsig,tbk,pbk,psbk,q,hbk, & + zh,pt_ll,eta1_ll,aeta1_ll,regional,wrf_mass_regional) +! +!$$$ subprogram documentation block +! . . . . +! subprogram: BackgroundCld Ingest background fields for cloud analysis +! +! PRGMMR: Ming Hu ORG: GSD/AMB DATE: 2006-10-27 +! +! ABSTRACT: +! This subroutine reads in background hydrometeor fields for cloud analysis +! +! PROGRAM HISTORY LOG: +! 2009-01-02 Hu Add NCO document block +! 2010-04-26 Hu delete the module gridmod and guess_grids. +! transfer information subroutine dummy variables +! +! +! input argument list: +! mype - processor ID +! lon2 - no. of lons on subdomain (buffer points on ends) +! lat2 - no. of lats on subdomain (buffer points on ends) +! nsig - no. of vertical levels +! tbk - 3D background potential temperature (K) +! psbk - 2D background surface pressure (hPa) +! q - 3D moisture (water vapor mixing ratio kg/kg) +! zh - terrain +! pt_ll - vertical coordinate +! eta1_ll - vertical coordinate +! aeta1_ll - vertical coordinate +! regional - if regional +! wrf_mass_regional - if mass core +! +! output argument list: +! pbk - 3D background pressure (hPa) +! hbk - 3D height above the ground (not the sea level) +!!!! z_lcl - lifting condensation level +! +! USAGE: +! INPUT FILES: +! +! OUTPUT FILES: +! +! REMARKS: +! +! ATTRIBUTES: +! LANGUAGE: FORTRAN 90 +! MACHINE: Linux cluster (WJET) +! +!$$$ +! +!_____________________________________________________________________ +! + + use kinds, only: r_single,i_kind,r_kind + use constants, only: rd_over_cp, h1000 + use constants, only: rd, grav, half, rad2deg + + implicit none + + integer(i_kind),intent(in):: mype + integer(i_kind),intent(in):: lon2 + integer(i_kind),intent(in):: lat2 + integer(i_kind),intent(in):: nsig + + real(r_kind), intent(in) :: pt_ll + real(r_kind), intent(in) :: eta1_ll(nsig+1) ! + real(r_kind), intent(in) :: aeta1_ll(nsig) ! + logical, intent(in) :: regional ! .t. for regional background/analysis + logical, intent(in) :: wrf_mass_regional ! + + +! background +! +! read in from WRF +! + real(r_single),intent(inout) :: tbk(lon2,lat2,nsig) ! temperature + real(r_single),intent(inout) :: psbk(lon2,lat2) ! surface pressure + real(r_single),intent(in) :: zh(lon2,lat2) ! terrain elevation + real(r_single),intent(inout) :: q(lon2,lat2,nsig) ! moisture +! +! derived fields +! + real(r_single),intent(out) :: hbk(lon2,lat2,nsig)! height + real(r_single),intent(out) :: pbk(lon2,lat2,nsig)! pressure hPa +! real(r_single),intent(out) :: z_lcl(lon2,lat2) ! lifting condensation level +! + real(r_single) :: cv_bk(lon2,lat2,nsig) ! cloud cover + real(r_single) :: t_k(lon2,lat2,nsig) ! temperature in C + +! +! misc. +! + INTEGER :: i,j,k + + REAL(r_single) :: rdog, h, dz, rl + REAL(r_single) :: height(nsig+1) + real(r_single) :: q_integral(lon2,lat2) + real(r_single) :: deltasigma, psfc_this + +! +!================================================================ +! + q_integral=1 + do k=1,nsig + deltasigma=eta1_ll(k)-eta1_ll(k+1) + do j=1,lat2 + do i=1,lon2 + q(i,j,k) = q(i,j,k)/(1.0_r_kind-q(i,j,k)) ! water vapor mixing ratio (kg/kg) + q_integral(i,j)=q_integral(i,j)+deltasigma*q(i,j,k) + enddo + enddo + enddo + do j=1,lat2 + do i=1,lon2 + psfc_this=pt_ll+(psbk(i,j)-pt_ll)/q_integral(i,j) + psbk(i,j)= psfc_this + enddo + enddo + +! +! assign CAPE as 0, this part needs more work +! +! gsfc(:,:,3)=0.0 ! CAPE, we need but not included in wrf_inout +! 1: land use; 2: sfc soil T; 3: CAPE +! +! get land use and convert latitude and longitude back to degree +! xland=gsfc(:,:,1) +! soil_tbk=gsfc(:,:,2) +! +! get virtual potential temperature (thv) +! +! thv=0.0 +! do k=1,nsig +! do j=1,nlat +! do i=1,nlon +! rl=qr(i,j,k)+qs(i,j,k)+qg(i,j,k)+qc(i,j,k)+qi(i,j,k) +! thv(i,j,k)=tbk(i,j,k)*(1.0+0.61*q(i,j,k)-rl) +! ENDDO +! ENDDO +! ENDDO +!! +! +! now get pressure (pbk) and height (hbk) at each grid point +! + if(regional .and. wrf_mass_regional ) then + + do k=1,nsig + do j=1,lat2 + do i=1,lon2 + pbk(i,j,k)=aeta1_ll(k)*(psbk(i,j)-pt_ll)+pt_ll + end do + end do + end do + +! Compute geopotential height at midpoint of each layer + rdog = rd/grav + do j=1,lat2 + do i=1,lon2 + k = 1 + h = rdog * tbk(i,j,k) + dz = h * log(psbk(i,j)/pbk(i,j,k)) + height(k) = zh(i,j) + dz + + do k=2,nsig + h = rdog * half * (tbk(i,j,k-1)+tbk(i,j,k)) + dz = h * log(pbk(i,j,k-1)/pbk(i,j,k)) + height(k) = height(k-1) + dz + end do + + do k=1,nsig + hbk(i,j,k)=height(k) - zh(i,j) + end do + end do + end do + else + write(6,*) ' Only wrf mass grid is done for cloud analysis ' + write(6,*) ' You are choosing grid that is not recoginzed by cloud analysis' + call stop2(114) + endif + + do k=1,nsig + do j=1,lat2 + do i=1,lon2 + tbk(i,j,k)=tbk(i,j,k)*(h1000/pbk(i,j,k))**rd_over_cp + enddo + enddo + enddo + +!mhu call BckgrndCC(lon2,lat2,nsig,tbk,pbk,q,hbk,zh, & +!mhu cv_bk,t_k,z_lcl) ! out + +END SUBROUTINE BackgroundCld diff --git a/src/GSD/gsdcloud4nmmb/BckgrndCC.f90 b/src/GSD/gsdcloud4nmmb/BckgrndCC.f90 new file mode 100755 index 0000000000..0fefb28c7e --- /dev/null +++ b/src/GSD/gsdcloud4nmmb/BckgrndCC.f90 @@ -0,0 +1,159 @@ +SUBROUTINE BckgrndCC(nlon,nlat,nsig,tbk,pbk,q,hbk,zh, & + cv_bk,t_k,z_lcl) +! +!$$$ subprogram documentation block +! . . . . +! subprogram: BckgrndCC generate background field for +! fractional cloud cover based on RH +! +! PRGMMR: Ming Hu ORG: GSD/AMB DATE: 2006-10-27 +! +! ABSTRACT: +! This subroutine calculate cloud field based on background fields +! +! PROGRAM HISTORY LOG: +! 2009-01-20 Hu Add NCO document block +! 2016-02-10 S.Liu Change subdomain boundary to cover full subdomain +! +! +! input argument list: +! nlon - no. of lons on subdomain (buffer points on ends) +! nlat - no. of lats on subdomain (buffer points on ends) +! nsig - no. of levels +! tbk - 3D background potentional temperature (K) +! pbk - 3D background pressure (hPa) +! q - 3D moisture (kg/kg) +! hbk - 3D height +! zh - terrain +! +! output argument list: +! cv_bk - 3D background cloud cover +! t_k - 3D temperature in K +! z_lcl - lifting condensation level +! +! USAGE: +! INPUT FILES: +! +! OUTPUT FILES: +! +! REMARKS: +! +! ATTRIBUTES: +! LANGUAGE: FORTRAN 90 +! MACHINE: Linux cluster (WJET) +! +!$$$ +! +!_____________________________________________________________________ +! + use kinds, only: r_single,i_kind,r_kind + use constants, only: h1000, rd_over_cp, g_over_rd + + implicit none + + integer(i_kind),intent(in):: nlon,nlat,nsig +! background +! +! read in from WRF +! + real(r_single),intent(in) :: tbk(nlon,nlat,nsig) ! potential temperature + real(r_single),intent(in) :: zh(nlon,nlat) ! terrain elevation + real(r_single),intent(in) :: q(nlon,nlat,nsig) ! moisture + real(r_single),intent(in) :: hbk(nlon,nlat,nsig) ! height + real(r_single),intent(in) :: pbk(nlon,nlat,nsig) ! pressure + + real(r_single),intent(out) :: t_k(nlon,nlat,nsig) ! temperature in K + real(r_single),intent(out) :: z_lcl(nlon,nlat) ! lifting condensation level + real(r_single),intent(out) :: cv_bk(nlon,nlat,nsig)! cloud cover + +! CONSTANTS: + real(r_single) :: gamma_d ! dry adiabatic lapse rate (K/m) + real(r_single) :: z_ref_lcl + PARAMETER(z_ref_lcl = 180.0_r_single) + +! misc. +! + real(r_single) :: rhbk(nlon,nlat,nsig) ! rh + + INTEGER :: i,j,k + + + REAL(r_kind) :: f_qvsat + REAL(r_kind) :: qvsat + REAL(r_kind) :: rh_to_cldcv + + REAL(r_kind) :: z_ref,x + REAL(r_kind) :: arg,arg2, t_ref_c, td_ref_c + REAL(r_kind) :: frac_z, t_ref_k,rh_ref + +! +!================================================================ +! + gamma_d = g_over_rd/rd_over_cp +! +! get the RH +! + do k=1,nsig + do j=1,nlat + do i=1,nlon + t_k(i,j,k)=tbk(i,j,k)*(pbk(i,j,k)/h1000)**rd_over_cp + qvsat=f_qvsat(pbk(i,j,k)*100.0_r_kind,t_k(i,j,k)) + ! Saturation water vapor specific humidity + qvsat = qvsat/(1.0 - qvsat) ! convert to saturation mixing ratio (kg/kg) + rhbk(i,j,k)=100._r_kind*MIN(1._r_kind,MAX(0._r_kind,(q(i,j,k)/qvsat))) + ! q is mixing ration kg/kg + enddo + enddo + enddo +! +! Find the lifting condensation level +! + z_lcl = -99999.0_r_kind + do j=2,nlat + do i=2,nlon + z_ref = z_ref_lcl + zh(i,j) + IF (z_ref <= hbk(i,j,2) .OR. z_ref > hbk(i,j,nsig-1)) THEN + write(6,*) 'Error, ref.level is out of bounds at pt:' & + ,i,j,z_ref,hbk(i,j,2),hbk(i,j,nsig-1) + call STOP2(114) + END IF + + DO k = 3,nsig-1 + IF ( z_ref < hbk(i,j,k) .and. z_ref >= hbk(i,j,k-1)) THEN + frac_z = (z_ref-hbk(i,j,k-1))/(hbk(i,j,k)-hbk(i,j,k-1)) + t_ref_k = t_k(i,j,k-1)+ frac_z*(t_k(i,j,k)-t_k(i,j,k-1)) + t_ref_c = t_ref_k - 273.15_r_kind +! + rh_ref = rhbk(i,j,k-1)+ frac_z*(rhbk(i,j,k)-rhbk(i,j,k-1)) +! compute dew point depression. +! td_ref_c = dwpt(t_ref_c,rh_ref) + x = 1._r_kind-0.01_r_kind*rh_ref + td_ref_c =t_ref_c-(14.55_r_kind+0.114_r_kind*t_ref_c)*x+ & + ((2.5_r_kind+0.007_r_kind*t_ref_c)*x)**3+ & + (15.9_r_kind+0.117_r_kind*t_ref_c)*x**14 + + END IF + END DO ! k = 2,nz-1 +! + z_lcl(i,j) = z_ref + (t_ref_c - td_ref_c)/gamma_d + z_lcl(i,j) = min(hbk(i,j,nsig-1),max(z_lcl(i,j),hbk(i,j,2))) + enddo + enddo +! +! get background cloud cover +! + cv_bk=0.0_r_kind + do k=1,nsig + do j=1,nlat + do i=1,nlon + IF (hbk(i,j,k) >= z_lcl(i,j)) THEN + arg = hbk(i,j,k) - zh(i,j) + arg2=rhbk(i,j,k)*0.01_r_kind + cv_bk(i,j,k) = rh_to_cldcv(arg2,arg) + ENDIF + enddo + enddo + enddo +! + +END SUBROUTINE BckgrndCC diff --git a/src/GSD/gsdcloud4nmmb/CheckCld.f90 b/src/GSD/gsdcloud4nmmb/CheckCld.f90 new file mode 100755 index 0000000000..795eaa9972 --- /dev/null +++ b/src/GSD/gsdcloud4nmmb/CheckCld.f90 @@ -0,0 +1,292 @@ +SUBROUTINE check_cloud(mype,nlat,nlon,nsig,q,qr,qs,qg,qc,qi,tcld,pbk,h_bk, & + mxst_p,NVARCLD_P,numsao,OI,OJ,OCLD,OWX,Oelvtn,cstation,& + sat_ctp,cld_cover_3d,xland) +! +!$$$ subprogram documentation block +! . . . . +! subprogram: save_cloudResults writes out diagnostics on cloud/hydrometeor analysis +! +! PRGMMR: Ming Hu ORG: GSD/AMB DATE: 2006-11-27 +! +! ABSTRACT: +! This subroutine writes out diagnostics on cloud analysis results +! +! PROGRAM HISTORY LOG: +! 2009-01-20 Hu Add NCO document block +! +! +! input argument list: +! mype - processor ID +! nlon - no. of lons on subdomain (buffer points on ends) +! nlat - no. of lats on subdomain (buffer points on ends) +! nsig - no. of levels +! pbk - 3D background pressure (hPa) +! q - 3D moisture (water vapor mixing ratio) +! qr - 3D rain mixing ratio (kg/kg) +! qs - 3D snow mixing ratio (kg/kg) +! qg - 3D graupel mixing ratio (kg/kg) +! qc - 3D cloud water mixing ratio (kg/kg) +! qi - 3D cloud ice mixing ratio (kg/kg) +! tcld - 3D in-cloud temperature (K) +! +! mxst_p - maximum observation number +! NVARCLD_P - first dimension of OLCD +! numsao - observation number +! OI - observation x location +! OJ - observation y location +! OLCD - cloud amount, cloud height, visibility +! OWX - weather observation +! Oelvtn - observation elevation +! output argument list: +! +! USAGE: +! INPUT FILES: +! +! OUTPUT FILES: +! +! REMARKS: +! +! ATTRIBUTES: +! LANGUAGE: FORTRAN 90 +! MACHINE: Linux cluster (WJET) +! +!$$$ +! +!_____________________________________________________________________ +! + + use kinds, only: r_single,i_kind, r_double + use guess_grids, only: ges_tv,ges_q + use guess_grids, only: ges_qc,ges_qi,ges_qr,ges_qs,ges_qg,ges_tten + use constants, only: rd_over_cp, h1000 + use gridmod, only: jlon1,ilat1,istart,jstart + + implicit none + + integer (i_kind),intent(in) :: nlat,nlon,nsig + integer (i_kind),intent(in) :: mype + +! background +! +! read in from WRF +! + real(r_single),intent(in) :: q(nlon,nlat,nsig) ! moisture, mixing ratio (kg/kg) + real(r_single),intent(in) :: qr(nlon,nlat,nsig) ! rain + real(r_single),intent(in) :: qs(nlon,nlat,nsig) ! snow + real(r_single),intent(in) :: qg(nlon,nlat,nsig) ! graupel + real(r_single),intent(in) :: qc(nlon,nlat,nsig) ! cloud water + real(r_single),intent(in) :: qi(nlon,nlat,nsig) ! cloud ice + real(r_single),intent(in) :: tcld(nlon,nlat,nsig) ! cloud temperature (potential temperature) + + real(r_single),intent(in) :: pbk(nlon,nlat,nsig) ! pressure , pa + real(r_single),intent(in) :: h_bk(nlon,nlat,nsig) ! height +! +! cloud observation from METAR + + INTEGER(i_kind), intent(in) :: mxst_p,NVARCLD_P +! PARAMETER (LSTAID_P=9) + + INTEGER,intent(in) :: numsao + real(r_single),intent(in) :: OI(mxst_p) ! x location + real(r_single),intent(in) :: OJ(mxst_p) ! y location + INTEGER(i_kind),intent(in):: OCLD(NVARCLD_P,mxst_p) ! cloud amount, cloud height, + ! visibility + CHARACTER*10,intent(in) :: OWX(mxst_p) ! weather + real(r_single),intent(in) :: Oelvtn(mxst_p) ! elevation + character(8),intent(in) :: cstation(mxst_p) ! station name + real(i_kind), intent(in) :: xland(nlon,nlat) ! surface +! + real(r_single),intent(in) :: sat_ctp(nlon,nlat) +! + real (r_single),intent(in) :: cld_cover_3d(nlon,nlat,nsig) +! +! misc. +! + INTEGER :: ista,idw,ids + INTEGER :: i,j,k, iunit + character*3 :: cmype +! +!================================================================ +! + idw=jstart(mype+1)-2 + ids=istart(mype+1)-2 + iunit=68 + write(cmype,'(I3.3)') mype + open(iunit,file='checkCloud_'//trim(cmype)//'.txt') + write(iunit,*) idw,ids,jstart(mype+1),istart(mype+1),mype + + if(mype==22 ) then + DO i=54, 58 + DO j=96, 100 + write(*,*) 'radar=',i,j,k + DO k=1,nsig + write(*,*) 'radar=',ges_tten(j,i,k,1) ,pbk(i,j,k) + enddo + enddo + enddo + endif + + return +if(mype==5 ) then + DO i=100, 102 + DO j=44, 46 +! DO i=2, nlon-1 +! DO j=2, nlat-1 + +! if(sat_ctp(i,j) > 900 .and. sat_ctp(i,j) < 1014) then + write(iunit,'(a,f8.1,2i8,f8.1)') 'cloud top pressure=',sat_ctp(i,j),i,j,xland(i,j) + write(iunit,'(a10,3a10,a12,3a10)') 'level','cover','qc', 'qi', 'h_bk', 'pbk','tcld' + DO k=1,nsig + write(iunit,'(i10,f10.2,2f10.5,f12.1,3f10.1)') & + k,cld_cover_3d(i,j,k),qc(i,j,k)*1000.0,qi(i,j,k)*1000.0, & + h_bk(i,j,k),pbk(i,j,k),tcld(i,j,k) + enddo +! endif + END DO + END DO + + + if(numsao > 0 ) then + do ista = 1,numsao + if(abs(OCLD(1,ista)) <10 ) then + write(iunit,'(a10,I10,2f8.2,20I10)') cstation(ista),ista,oi(ista),oj(ista),(OCLD(k,ista),k=1,3),(OCLD(k,ista),k=7,10) + endif + enddo + endif + +endif + +! do k=1,nsig +! do j=1,nlat +! do i=1,nlon +! tcld(i,j,k)=tcld(i,j,k)*(pbk(i,j,k)/h1000/100.0)**rd_over_cp +! ENDDO +! ENDDO +! ENDDO + + if(mype == 130 ) then + + + if(numsao > 0 ) then + write(cmype,'(I3.3)') mype + open(iunit,file='checkCloud_'//trim(cmype)//'.txt') + write(iunit,*) 'mype,idw,ids',mype,idw,ids,nlon,nlat + do ista = 1,numsao + if(abs(OCLD(1,ista)) <10 ) then + write(iunit,'(a10,I10,2f8.2)') cstation(ista),ista,oi(ista),oj(ista) + write(iunit,'(20I10)') (OCLD(k,ista),k=1,6) + write(iunit,'(20I10)') (OCLD(k,ista),k=7,NVARCLD_P) + endif + enddo + + + do ista = 1,numsao + i = int(oi(ista)+0.0001) + j = int(oj(ista)+0.0001) + + write(iunit,*) + write(iunit,'(a10,I10,a10,2I10,3f8.2)') 'ista=',ista,cstation(ista),i,j,oi(ista),oj(ista),Oelvtn(ista) + write(iunit,'(20I10)') (OCLD(k,ista),k=1,6) + write(iunit,'(20I10)') (OCLD(k,ista),k=7,NVARCLD_P) + + if( i >= 2 .and. i <=nlon-1 ) then + if( j >= 2 .and. j <=nlat-1 ) then + + write(iunit,'(a,f8.1)') 'cloud top pressure=',sat_ctp(i,j) + write(iunit,'(a10,3a10,a12,3a10)') 'level','cover','qc', 'qi', 'h_bk', 'pbk','tcld' + DO k=1,nsig + write(iunit,'(i10,f10.2,2f10.5,f12.1,3f10.1)') & + k,cld_cover_3d(i,j,k),qc(i,j,k)*1000.0,qi(i,j,k)*1000.0, & + h_bk(i,j,k),pbk(i,j,k),tcld(i,j,k) + enddo + + endif + endif + ENDDO + close(iunit) + + endif + endif +! + +END SUBROUTINE check_cloud +SUBROUTINE FindCloumn(mype,ifindomain,iglobal,jglobal,ilocal,jlocal) +! +!$$$ subprogram documentation block +! . . . . +! subprogram: CheckCloumn find local i,j from certain global i,j +! +! PRGMMR: Ming Hu ORG: GSD/AMB DATE: 2011-05-02 +! +! ABSTRACT: +! This subroutine print the column information for certain i,j +! +! PROGRAM HISTORY LOG: +! 2011-05-02 Hu Add NCO document block +! +! +! input argument list: +! mype - processor ID +! iglobal - i grid for whole domain +! jglobal - j grid for whole domain +! +! output argument list: +! ilocal - i grid for subdomain domain +! jlocal - j grid for subdomain domain +! ifindomain - if in this sub-domain +! +! +! USAGE: +! INPUT FILES: +! +! OUTPUT FILES: +! +! +! REMARKS: +! +! ATTRIBUTES: +! LANGUAGE: FORTRAN 90 +! MACHINE: Linux cluster (WJET) +! +!$$$ +! + + use kinds, only: r_single,i_kind,r_kind,r_double + use gridmod, only: jlon1,ilat1,istart,jstart + + implicit none + + integer(i_kind), intent(in) :: mype + integer(i_kind), intent(in) :: iglobal + integer(i_kind), intent(in) :: jglobal + integer(i_kind), intent(out) :: ilocal + integer(i_kind), intent(out) :: jlocal + logical, intent(out) :: ifindomain + +! +! misc. +! + + integer(i_kind) :: ib,jb + +!==================================================================== +! Begin + + ifindomain=.false. + ib=jstart(mype+1) ! begin i point of this domain + jb=istart(mype+1) ! begin j point of this domain + +! + ilocal = iglobal - ib + 2 ! covert it to the local grid + jlocal = jglobal - jb + 2 ! covert it to the local grid + + if(ilocal > 0 .and. jlocal > 0 ) then + if(ilocal <= jlon1(mype+1) .and. jlocal <= ilat1(mype+1) ) then + ifindomain=.true. + endif + endif +! write(*,*) 'find the location',mype,ilocal,jlocal,iglobal,jglobal +! write(*,*) mype,ib,jb,jlon1(mype+1),ilat1(mype+1),ifindomain + +END SUBROUTINE FindCloumn + diff --git a/src/GSD/gsdcloud4nmmb/PrecipMxr_radar.f90 b/src/GSD/gsdcloud4nmmb/PrecipMxr_radar.f90 new file mode 100755 index 0000000000..e4f9cd96dd --- /dev/null +++ b/src/GSD/gsdcloud4nmmb/PrecipMxr_radar.f90 @@ -0,0 +1,167 @@ +SUBROUTINE PrecipMxR_radar(mype,nlat,nlon,nsig, & + t_bk,p_bk,ref_mos_3d, & + cldpcp_type_3d,q_bk,qr_cld,qnr_3d,qs_cld,qg_cld,cldqropt) +! +!$$$ subprogram documentation block +! . . . . +! subprogram: PrecipMxR_radar find cloud liquid water content +! +! PRGMMR: Ming Hu ORG: GSD/AMB DATE: 2006-11-20 +! +! ABSTRACT: +! This is the driver to call subroutines that calculate liquid water content based on +! radar reflectivity and hydrometeor type diagnosed from radar +! and background 3-D temperature fields +! +! PROGRAM HISTORY LOG: +! 2009-01-20 Hu Add NCO document block +! +! +! input argument list: +! mype - processor ID +! nlon - no. of lons on subdomain (buffer points on ends) +! nlat - no. of lats on subdomain (buffer points on ends) +! nsig - no. of levels +! +! t_bk - 3D background potential temperature (K) +! p_bk - 3D background pressure (hPa) +! ref_mos_3d - 3D reflectivity in analysis grid (dBZ) +! cldpcp_type_3d - 3D hydrometeor type +! cldqropt - scheme used to retrieve +! mixing ratios for hydrometeors related to precipitation (qr, qs, qg) +! 1=Kessler 2=Lin 3=Thompson +! +! output argument list: +! qr_cld - rain mixing ratio (g/kg) +! qnr_3d - rain number concentration +! qs_cld - snow mixing ratio (g/kg) +! qg_cld - graupel mixing ratio (g/kg) +! +! USAGE: +! INPUT FILES: +! +! OUTPUT FILES: +! +! REMARKS: +! +! ATTRIBUTES: +! LANGUAGE: FORTRAN 90 +! MACHINE: Linux cluster (WJET) +! +!$$$ +! +!_____________________________________________________________________ +! + + use constants, only: rd_over_cp, h1000 + use kinds, only: r_single,i_kind,r_kind + + implicit none + integer(i_kind),intent(in):: nlat,nlon,nsig + integer(i_kind),intent(in):: mype +! +! background +! + real(r_single),intent(in) :: t_bk(nlon,nlat,nsig) ! potential temperature + real(r_single),intent(in) :: p_bk(nlon,nlat,nsig) ! height + real(r_single),intent(in) :: q_bk(nlon,nlat,nsig) ! mixing ratio +! + real(r_kind),intent(in) :: ref_mos_3d(nlon,nlat,nsig) +! +! Variables for cloud analysis +! + integer(i_kind),intent(in) :: cldpcp_type_3d(nlon,nlat,nsig) +! +! hydrometeors +! + REAL(r_single),intent(out) :: qr_cld(nlon,nlat,nsig) ! rain + REAL(r_single),intent(out) :: qnr_3d(nlon,nlat,nsig) ! rain number concentration(/kg) + REAL(r_single),intent(out) :: qs_cld(nlon,nlat,nsig) ! snow + REAL(r_single),intent(out) :: qg_cld(nlon,nlat,nsig) ! graupel + +!----------------------------------------------------------- +! +! temp. +! + + REAL(r_single) :: t_3d(nlon,nlat,nsig) + REAL(r_single) :: p_3d(nlon,nlat,nsig) + REAL(r_kind) :: qs_max + + INTEGER(i_kind) :: cldqropt + INTEGER(i_kind) :: istatus_pcp + INTEGER(i_kind) :: i,j,k + INTEGER(i_kind) :: k_qs_max + REAL(r_kind) :: threshold_t_1st + +! +!==================================================================== +! Begin +! +! cldqropt = 2 + + DO j = 2,nlat-1 + DO i = 2,nlon-1 + DO k = 1,nsig + t_3d(i,j,k) = t_bk(i,j,k)*(p_bk(i,j,k)/h1000)**rd_over_cp + p_3d(i,j,k) = p_bk(i,j,k)*100.0_r_single + END DO + END DO + END DO + +!----------------------------------------------------------------------- +! +! Calculate 3D precipitation hydrometeor mixing ratios +! from radar reflectivity in g/kg. +! Note that qr_cld, qs_cld, and qg_cld are diagnosed +! qr, qs and qg in g/kg, respectively. +! +!----------------------------------------------------------------------- +! + IF (cldqropt == 1) THEN +! +! Kessler's scheme +! + if(mype==0) then + WRITE(6,'(a)') 'PrecipMxR_radar: Computing Precip mixing ratio.' + WRITE(6,'(a)') & + ' Using Kessler radar reflectivity equations...' + endif + CALL pcp_mxr (nlon,nlat,nsig,t_3d,p_3d,ref_mos_3d, & + cldpcp_type_3d, & + qr_cld,qs_cld,qg_cld, & + istatus_pcp) + + ELSE IF (cldqropt == 2) THEN +! +! Ferrier's scheme +! + if(mype==0) then + WRITE(6,'(a)') 'PrecipMxR_radar: Computing Precip mixing ratio.' + WRITE(6,'(a)') & + ' Using Ferrier radar reflectivity equations...' + endif + CALL pcp_mxr_ferrier_new (nlon,nlat,nsig,t_3d,p_3d,ref_mos_3d, & + cldpcp_type_3d,q_bk, & + qr_cld,qs_cld,qg_cld, & + istatus_pcp) + + ELSE IF (cldqropt == 3) THEN +! +! Thompson's scheme +! + if(mype==0) then + WRITE(6,'(a)') ' PrecipMxR_radar: Computing Precip mixing ratio.' + WRITE(6,'(a)') & + ' Using Thompson RUC radar reflectivity equations...' + endif +! call pcp_mxr_thompsonRUC(qr_cld,qs_cld,qg_cld, & +! p_3d,t_3d, & +! ref_mos_3d,nlon,nlat,nsig,cldpcp_type_3d) + call hydro_mxr_thompson (nlon,nlat,nsig, t_3d, p_3d, ref_mos_3d, & + qr_cld,qnr_3d,qs_cld, istatus_pcp,mype) + + END IF !cldqropt=1 or 2 or 3 + +END SUBROUTINE PrecipMxR_radar + diff --git a/src/GSD/gsdcloud4nmmb/PrecipType.f90 b/src/GSD/gsdcloud4nmmb/PrecipType.f90 new file mode 100755 index 0000000000..51f83ddb07 --- /dev/null +++ b/src/GSD/gsdcloud4nmmb/PrecipType.f90 @@ -0,0 +1,118 @@ +SUBROUTINE PrecipType(nlat,nlon,nsig,t_bk,p_bk,q_bk,radar_3d, & + wthr_type,cldpcp_type_3d) +! +!$$$ subprogram documentation block +! . . . . +! subprogram: PrecipType decide precipitation type +! +! PRGMMR: Ming Hu ORG: GSD/AMB DATE: 2006-11-20 +! +! ABSTRACT: +! This subroutine calculates precipitation type +! +! PROGRAM HISTORY LOG: +! 2009-01-20 Hu Add NCO document block +! +! +! input argument list: +! nlon - no. of lons on subdomain (buffer points on ends) +! nlat - no. of lats on subdomain (buffer points on ends) +! nsig - no. of levels +! t_bk - 3D background potential temperature (K) +! p_bk - 3D background pressure (hPa) +! q_bk - 3D moisture +! radar_3d - 3D radar reflectivity in analysis grid (dBZ) +! wthr_type - weather type +! +! output argument list: +! cldpcp_type_3d - 3D precipitation type +! +! USAGE: +! INPUT FILES: +! +! OUTPUT FILES: +! +! REMARKS: +! +! ATTRIBUTES: +! LANGUAGE: FORTRAN 90 +! MACHINE: Linux cluster (WJET) +! +!$$$ +! +!_____________________________________________________________________ +! + + use constants, only: rd_over_cp, h1000 + use kinds, only: r_single,i_kind,r_kind + + implicit none + integer(i_kind),INTENT(IN):: nlat,nlon,nsig +! +! surface observation +! +! +! background +! + real(r_single),INTENT(IN) :: t_bk(nlon,nlat,nsig) ! potential temperature + real(r_single),INTENT(IN) :: p_bk(nlon,nlat,nsig) ! pressure + real(r_single),INTENT(IN) :: q_bk(nlon,nlat,nsig) ! moisture +! +! observation +! + real(r_kind),INTENT(IN) :: radar_3d(nlon,nlat,nsig) ! reflectivity +! +! +! Variables for cloud analysis +! + integer(i_kind),INTENT(out) :: cldpcp_type_3d(nlon,nlat,nsig) + integer(i_kind),INTENT(in) :: wthr_type(nlon,nlat) + LOGICAL :: l_mask(nlon,nlat) ! "Potential" Precip Type + +! +!----------------------------------------------------------- +! +! temp. +! + INTEGER(i_kind):: i,j,k,ilvl,nlvl + real(r_single) :: temp_3d(nlon,nlat,nsig) ! temperature (C) + real(r_single) :: rh_3d(nlon,nlat,nsig) ! relative humidity + real(r_single) :: p_pa_3d(nlon,nlat,nsig) ! + REAL(r_single) :: qvsat + REAL(r_single) :: f_qvsat + INTEGER :: istatus +! +!==================================================================== +! Begin +! +!----------------------------------------------------------------------- +! +! Find Cloud Layers and Computing Output Field(s) +! The procedure works column by column. +! +!----------------------------------------------------------------------- +! + + DO j = 1,nlat + DO i = 1,nlon +! + DO k = 1,nsig ! Initialize + temp_3d(i,j,k)=t_bk(i,j,k)*(p_bk(i,j,k)/h1000)**rd_over_cp ! convert to K + qvsat=f_qvsat(p_bk(i,j,k)*100.0_r_single,temp_3d(i,j,k)) + qvsat = qvsat/(1.0_r_single-qvsat) ! convert to mixing ratio (kg/kg) + rh_3d(i,j,k)=100._r_single*MIN(1.,MAX(0._r_single,(q_bk(i,j,k)/qvsat))) + p_pa_3d(i,j,k) = p_bk(i,j,k)*100.0_r_single + END DO +!----------------------------------------------------------------------- + + ENDDO ! i + ENDDO ! j + + l_mask = .false. + + call pcp_type_3d (nlon,nlat,nsig,temp_3d,rh_3d,p_pa_3d & + ,radar_3d,l_mask,cldpcp_type_3d,istatus) + + +END SUBROUTINE precipType + diff --git a/src/GSD/gsdcloud4nmmb/TempAdjust.f90 b/src/GSD/gsdcloud4nmmb/TempAdjust.f90 new file mode 100755 index 0000000000..a7f0802750 --- /dev/null +++ b/src/GSD/gsdcloud4nmmb/TempAdjust.f90 @@ -0,0 +1,199 @@ +SUBROUTINE TempAdjust(mype,nlat,nlon,nsig,cldptopt, t_bk, p_bk,w_bk,q_bk, & + qc,qi,ctmp_bk) + +! +!$$$ subprogram documentation block +! . . . . +! subprogram: TempAdjust temperature adjustment +! +! PRGMMR: Ming Hu ORG: GSD/AMB DATE: 2006-11-26 +! +! ABSTRACT: +! This subroutine adjusts the perturbation potential temperature field to account +! for the latent heating release. +! +! PROGRAM HISTORY LOG: +! 2009-01-20 Hu Add NCO document block +! +! +! input argument list: +! mype - processor ID +! nlon - no. of lons on subdomain (buffer points on ends) +! nlat - no. of lats on subdomain (buffer points on ends) +! nsig - no. of levels +! cldptopt - schemes of adjustment +! 3=latent heat, 4,5,6 = adiabat profile +! t_bk - 3D background potential temperature (K) +! p_bk - 3D background pressure (hPa) +! w_bk - 3D background vertical velocity +! q_bk - 3D moisture (water vapor mixing ratio) +! qc - 3D cloud water mixing ratio (kg/kg) +! qi - 3D cloud ice mixing ratio (kg/kg) +! ctmp_bk - 3D cloud temperature +! +! output argument list: +! t_bk - 3D background potential temperature (K) +! +! USAGE: +! INPUT FILES: +! +! OUTPUT FILES: +! +! REMARKS: +! +! ATTRIBUTES: +! LANGUAGE: FORTRAN 90 +! MACHINE: Linux cluster (WJET) +! +!$$$ +! +!_____________________________________________________________________ +! + + use constants, only: cp,rd_over_cp, h1000, hvap + use kinds, only: r_single,i_kind + + implicit none + integer(i_kind),intent(in):: nlat,nlon,nsig + integer(i_kind),intent(in):: mype + +! +! background +! + real(r_single),intent(inout) :: t_bk(nlon,nlat,nsig) ! temperature + real(r_single),intent(in) :: p_bk(nlon,nlat,nsig) ! pressure + real(r_single),intent(in) :: w_bk(nlon,nlat,nsig) ! terrain + real(r_single),intent(in) :: q_bk(nlon,nlat,nsig) ! moisture - water vapor mixing ratio +! +! real(r_single) :: t_bk_check(nlon,nlat,nsig) ! temperature +! +! +! cloud water and cloud ice mixing ratios +! + real (r_single),intent(in) :: qc(nlon,nlat,nsig) + real (r_single),intent(in) :: qi(nlon,nlat,nsig) + real (r_single),intent(in) :: ctmp_bk(nlon,nlat,nsig) +! +! constant + REAL :: p0 +! +! +! temp. +! + INTEGER :: i,j,k + INTEGER(i_kind),intent(in) :: cldptopt + REAL :: frac_qc_2_lh, max_lh_2_pt + REAL :: max_pt_adj + REAL :: p0inv,arg,ptdiff + REAL :: ppi,wratio,ptcld +! +! +!----------------------------------------------------------- +! +! t_bk_check=0.0 + + p0=h1000 +! + wratio=1.0 +! cldptopt=3 + frac_qc_2_lh =1.0 + max_lh_2_pt=20.0 +! + IF (cldptopt == 3) THEN +if(mype==0) then + WRITE(6,'(a)')'TempAdjust: Adjusting t_bk to account for latent heating.' + WRITE(6,'(a,f10.4,a,f10.4)') & + 'TempAdjust: frac of qc:',frac_qc_2_lh,' adj_lim:',max_lh_2_pt +endif + p0inv=1./p0 + max_pt_adj = 0.0 + DO k=2,nsig + DO j=2,nlat-1 + DO i=2,nlon-1 + arg=max(0.0,qc(i,j,k)) + max(0.0,qi(i,j,k)) + if( arg > 0.0 ) then + ppi = (p_bk(i,j,k)*p0inv) ** rd_over_cp + arg = hvap*frac_qc_2_lh*arg*0.001/(cp*ppi) + max_pt_adj = MAX(max_pt_adj,arg) + t_bk(i,j,k) = t_bk(i,j,k) + MIN(arg,max_lh_2_pt) + endif + END DO + END DO + END DO + if(mype==0) PRINT*,'max_adj=',max_pt_adj + ELSE IF (cldptopt == 4) THEN +if(mype==0) then + WRITE(6,'(a)')'TempAdjust: Adjusting t_bk to account for latent heating in w.' + PRINT*,'frac of qc:',frac_qc_2_lh,' adj_lim:',max_lh_2_pt +endif + max_pt_adj = 0.0 + DO k=2,nsig + DO j=2,nlat-1 + DO i=2,nlon-1 + IF(w_bk(i,j,k) > 0. .and. ctmp_bk(i,j,k) > 0.0) THEN + wratio=1.0 + ptcld=ctmp_bk(i,j,k)*(p0/p_bk(i,j,k))**rd_over_cp + ptdiff=ptcld-t_bk(i,j,k) + IF(ptdiff > 0.) THEN + arg = frac_qc_2_lh*wratio*ptdiff + t_bk(i,j,k) = t_bk(i,j,k) + MIN(arg,max_lh_2_pt) + max_pt_adj = MAX(max_pt_adj,arg) + END IF + END IF + END DO + END DO + END DO + if(mype==0) PRINT*,'max_adj=',max_pt_adj + ELSE IF (cldptopt == 5) THEN +if(mype==0) then + WRITE(6,'(a)')'TempAdjust: Adjusting t_bk to moist-adiab cloud temp for w>-0.2' + PRINT*,'frac of qc:',frac_qc_2_lh,' adj_lim:',max_lh_2_pt +endif + max_pt_adj = 0.0 + DO k=2,nsig + DO j=2,nlat-1 + DO i=2,nlon-1 + IF( ctmp_bk(i,j,k) > 0.0) THEN + wratio=min(max(0.,(5.0*(w_bk(i,j,k)+0.2))),1.0) + ptcld=ctmp_bk(i,j,k)*(p0/p_bk(i,j,k))**rd_over_cp + ptdiff=ptcld-t_bk(i,j,k) + IF(ptdiff > 0.) THEN + arg = frac_qc_2_lh*wratio*ptdiff + t_bk(i,j,k) = t_bk(i,j,k) + MIN(arg,max_lh_2_pt) + max_pt_adj = MAX(max_pt_adj,arg) + END IF + ENDIF + END DO + END DO + END DO + if(mype==0) PRINT*,'max_adj=',max_pt_adj + + ELSE IF (cldptopt == 6) THEN +if(mype==0) then + WRITE(6,'(a)')'TempAdjust: Adjusting t_bk to moist-adiab cloud temp for w>0.0' + PRINT*,'frac of qc:',frac_qc_2_lh,' adj_lim:',max_lh_2_pt +endif + max_pt_adj = 0.0 + DO k=2,nsig + DO j=2,nlat-1 + DO i=2,nlon-1 + IF(w_bk(i,j,k) > 0. .and. ctmp_bk(i,j,k)>0.0 ) THEN + ptcld=ctmp_bk(i,j,k)*(p0/p_bk(i,j,k))**rd_over_cp + ptdiff=ptcld-t_bk(i,j,k) + IF(ptdiff > 0.) THEN + arg = frac_qc_2_lh*ptdiff + t_bk(i,j,k) = t_bk(i,j,k) + MIN(arg,max_lh_2_pt) +! t_bk_check(i,j,k) = MIN(arg,max_lh_2_pt) + max_pt_adj = MAX(max_pt_adj,arg) + END IF + END IF + END DO + END DO + END DO + if(mype==0) PRINT*,'max_adj=',max_pt_adj + + END IF ! cldptopt=3? + +! t_bk = t_bk_check + +END SUBROUTINE TempAdjust diff --git a/src/GSD/gsdcloud4nmmb/adaslib.f90 b/src/GSD/gsdcloud4nmmb/adaslib.f90 new file mode 100755 index 0000000000..555e7ec6a0 --- /dev/null +++ b/src/GSD/gsdcloud4nmmb/adaslib.f90 @@ -0,0 +1,474 @@ +! +!$$$ subprogram documentation block +! . . . . +! ABSTRACT: +! This file collects subroutines related to cloud analysis in ADAS (CAPS) +! +! PROGRAM HISTORY LOG: +! 2009-01-20 Hu Add NCO document block +! +! +! input argument list: +! +! output argument list: +! +! USAGE: +! INPUT FILES: +! +! OUTPUT FILES: +! +! REMARKS: +! +! ATTRIBUTES: +! LANGUAGE: FORTRAN 90 +! MACHINE: Linux cluster (WJET) +! +!$$$ +! +!_____________________________________________________________________ +! +! +!################################################################## +!################################################################## +!###### ###### +!###### FUNCTION RH_TO_CLDCV ###### +!###### ###### +!################################################################## +!################################################################## +! + + FUNCTION rh_to_cldcv(rh,hgt) +! +!----------------------------------------------------------------------- +! +! PURPOSE: +! +! Obtain first guess cloud cover field from relative humidity. +! +! +! AUTHOR: Jian Zhang +! 07/95 +! +! MODIFICATION HISTORY +! +! 04/08/97 J. Zhang +! Added the empirical relationship between RH and +! cloud cover used by Koch et al. (1997). +! Reference: +! Reference: +! Koch, S.E., A. Aksakal, and J.T. McQueen, 1997: +! The influence of mesoscale humidity and evapotranspiration +! fields on a model forecast of a cold-frontal squall line. +! Mon. Wea. Rev., Vol.125, 384-409 +! 09/10/97 J. Zhang +! Modified the empirical relationship between cloud +! fraction and relative humidity from quadratic +! to one-fourth-power. +! +! +!----------------------------------------------------------------------- +! +! INPUT: +! rh ! relative humidity +! hgt ! height (AGL) +! +! OUTPUT: +! rh_to_cld_cv ! cloud fractional cover value +! +! LOCAL: +! rh0 ! the critical RH value that seperate clear + ! air condition and cloudy condition +! +!----------------------------------------------------------------------- +! +! Variable Declarations. +! +!----------------------------------------------------------------------- +! + use kinds, only: r_single,i_kind,r_kind + + IMPLICIT NONE + + INTEGER(i_kind) :: rh2cform + PARAMETER (rh2cform=2) + + REAL(r_kind), intent(in) :: rh,hgt + REAL(r_kind) :: rh_to_cldcv + REAL(r_kind) :: rh0 + +! +!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ +! +! Beginning of executable code... +! +!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ +! +! + IF(rh2cform == 1) THEN +! +!----------------------------------------------------------------------- +! +! A quadratic relationship between relative humidity and cloud +! fractional cover. +! +!----------------------------------------------------------------------- +! + IF (hgt < 600.0_r_kind) THEN + rh0 = 0.9_r_kind + ELSE IF (hgt < 1500.0_r_kind) THEN + rh0 = 0.8_r_kind + ELSE IF (hgt < 2500.0_r_kind) THEN + rh0 = 0.6_r_kind + ELSE + rh0 = 0.5_r_kind + END IF + + IF (rh < rh0) THEN + rh_to_cldcv = 0.0_r_kind + ELSE + rh_to_cldcv = (rh - rh0)/(1.0_r_kind - rh0) + rh_to_cldcv = rh_to_cldcv*rh_to_cldcv + END IF + + ELSE IF(rh2cform == 2) THEN +! +!----------------------------------------------------------------------- +! +! A quadratic relationship between relative humidity and cloud +! fractional cover with fixed rh0=0.75 +! +!----------------------------------------------------------------------- +! +! + IF (rh < 0.75_r_kind) THEN + rh_to_cldcv = 0.0_r_kind + ELSE + rh_to_cldcv = 16._r_kind*(rh - 0.75_r_kind)*(rh - 0.75_r_kind) + END IF + + ELSE +! +!-----------------------------------------------------------------------! +! A modified version of the sqrt relationship between +! relative humidity and cloud fractional cover used in Eta model. +! +!----------------------------------------------------------------------- +! + IF (hgt < 600._r_kind) THEN + rh0 = 0.8_r_kind + ELSE + rh0 = 0.75_r_kind + END IF + + IF (rh < rh0) THEN + rh_to_cldcv = 0.0_r_kind + ELSE + rh_to_cldcv = 1.0_r_kind - SQRT((1.0_r_kind - rh)/(1.0_r_kind - rh0)) + END IF + + END IF + + RETURN + END FUNCTION rh_to_cldcv +! +! +!################################################################## +!################################################################## +!###### ###### +!###### FUNCTION F_ES ###### +!###### ###### +!###### Developed by ###### +!###### Center for Analysis and Prediction of Storms ###### +!###### University of Oklahoma ###### +!###### ###### +!################################################################## +!################################################################## +! + +FUNCTION f_es( p, t ) +! +!----------------------------------------------------------------------- +! +! PURPOSE: +! +! Calculate the saturation specific humidity using enhanced Teten's +! formula. +! +!----------------------------------------------------------------------- +! +! AUTHOR: Yuhe Liu +! 01/08/1998 +! +! MODIFICATION HISTORY: +! +!----------------------------------------------------------------------- +! +! INPUT : +! +! p Pressure (Pascal) +! t Temperature (K) +! +! OUTPUT: +! +! f_es Saturation water vapor pressure (Pa) +! +!----------------------------------------------------------------------- +! + +! +!----------------------------------------------------------------------- +! +! Variable Declarations. +! +!----------------------------------------------------------------------- +! + IMPLICIT NONE + + REAL :: p ! Pressure (Pascal) + REAL :: t ! Temperature (K) + REAL :: f_es ! Saturation water vapor pressure (Pa) +! +!----------------------------------------------------------------------- +! +! Function f_es and inline directive for Cray PVP +! +!----------------------------------------------------------------------- +! + REAL :: f_esl, f_esi + +!fpp$ expand (f_esl) +!fpp$ expand (f_esi) +!!dir$ inline always f_esl, f_esi +!*$* inline routine (f_esl, f_esi) + +! +!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ +! +! Beginning of executable code... +! +!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ +! + IF ( t >= 273.15 ) THEN ! for water + f_es = f_esl( p,t ) + ELSE ! for ice + f_es = f_esi( p,t ) + END IF + + RETURN +END FUNCTION f_es + +! +!----------------------------------------------------------------------- +! +! Calculate the saturation water vapor over liquid water using +! enhanced Teten's formula. +! +!----------------------------------------------------------------------- +! + +FUNCTION f_esl( p, t ) + + IMPLICIT NONE + +! constant + REAL :: satfwa, satfwb + PARAMETER ( satfwa = 1.0007 ) + PARAMETER ( satfwb = 3.46E-8 ) ! for p in Pa + + REAL :: satewa, satewb, satewc + PARAMETER ( satewa = 611.21 ) ! es in Pa + PARAMETER ( satewb = 17.502 ) + PARAMETER ( satewc = 32.18 ) + + REAL :: p ! Pressure (Pascal) + REAL :: t ! Temperature (K) + REAL :: f_esl ! Saturation water vapor pressure over liquid water + + REAL :: f + +! +!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ +! +! Beginning of executable code... +! +!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ +! + f = satfwa + satfwb * p + f_esl = f * satewa * EXP( satewb*(t-273.15)/(t-satewc) ) + + RETURN +END FUNCTION f_esl +! +!----------------------------------------------------------------------- +! +! Calculate the saturation water vapor over ice using enhanced +! Teten's formula. +! +!----------------------------------------------------------------------- +! + +FUNCTION f_esi( p, t ) + + IMPLICIT NONE + +! + REAL :: satfia, satfib + PARAMETER ( satfia = 1.0003 ) + PARAMETER ( satfib = 4.18E-8 ) ! for p in Pa + + REAL :: sateia, sateib, sateic + PARAMETER ( sateia = 611.15 ) ! es in Pa + PARAMETER ( sateib = 22.452 ) + PARAMETER ( sateic = 0.6 ) + + REAL :: p ! Pressure (Pascal) + REAL :: t ! Temperature (K) + REAL :: f_esi ! Saturation water vapor pressure over ice (Pa) + + REAL :: f + +! +!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ +! +! Beginning of executable code... +! +!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ +! + f = satfia + satfib * p + f_esi = f * sateia * EXP( sateib*(t-273.15)/(t-sateic) ) + + RETURN +END FUNCTION f_esi +! +! +!################################################################## +!################################################################## +!###### ###### +!###### FUNCTION F_QVSAT ###### +!###### ###### +!###### Developed by ###### +!###### Center for Analysis and Prediction of Storms ###### +!###### University of Oklahoma ###### +!###### ###### +!################################################################## +!################################################################## +! + +FUNCTION f_qvsat( p, t ) +! +!----------------------------------------------------------------------- +! +! PURPOSE: +! +! Calculate the saturation specific humidity using enhanced Teten's +! formula. +! +!----------------------------------------------------------------------- +! +! AUTHOR: Yuhe Liu +! 01/08/1998 +! +! MODIFICATION HISTORY: +! +!----------------------------------------------------------------------- +! +! INPUT : +! +! p Pressure (Pascal) +! t Temperature (K) +! +! OUTPUT: +! +! f_qvsat Saturation water vapor specific humidity (kg/kg). +! +!----------------------------------------------------------------------- +! + +! +!----------------------------------------------------------------------- +! +! Variable Declarations. +! +!----------------------------------------------------------------------- +! + IMPLICIT NONE + + REAL :: p ! Pressure (Pascal) + REAL :: t ! Temperature (K) + REAL :: f_qvsat ! Saturation water vapor specific humidity (kg/kg) +! +!----------------------------------------------------------------------- +! +! Include files: +! +!----------------------------------------------------------------------- +! +! + + REAL :: rd ! Gas constant for dry air (m**2/(s**2*K)) + PARAMETER( rd = 287.0 ) + + REAL :: rv ! Gas constant for water vapor (m**2/(s**2*K)). + PARAMETER( rv = 461.0 ) + + REAL :: rddrv + PARAMETER( rddrv = rd/rv ) + +! +!----------------------------------------------------------------------- +! +! Function f_es and inline directive for Cray PVP +! +!----------------------------------------------------------------------- +! + REAL :: f_es +! +!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ +! +! Beginning of executable code... +! +!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ +! + f_qvsat = rddrv * f_es(p,t) / (p-(1.0-rddrv)*f_es(p,t)) + + RETURN +END FUNCTION f_qvsat + +SUBROUTINE getdays(nday,iyear,imonth,iday) + + use kinds, only: i_kind + implicit none +! + INTEGER(i_kind), intent(in) :: iyear,imonth,iday + INTEGER(i_kind), intent(out) :: nday +! + + nday=0 + if(imonth==1) then + nday=iday + elseif(imonth==2) then + nday=31+iday + elseif(imonth==3) then + nday=59+iday + elseif(imonth==4) then + nday=90+iday + elseif(imonth==5) then + nday=120+iday + elseif(imonth==6) then + nday=151+iday + elseif(imonth==7) then + nday=181+iday + elseif(imonth==8) then + nday=212+iday + elseif(imonth==9) then + nday=243+iday + elseif(imonth==10) then + nday=273+iday + elseif(imonth==11) then + nday=304+iday + elseif(imonth==12) then + nday=334+iday + endif + if(mod(iyear,4) == 0 .and. imonth > 2 ) nday=nday+1 + +END SUBROUTINE getdays diff --git a/src/GSD/gsdcloud4nmmb/build_missing_REFcone.f90 b/src/GSD/gsdcloud4nmmb/build_missing_REFcone.f90 new file mode 100755 index 0000000000..fd153a99db --- /dev/null +++ b/src/GSD/gsdcloud4nmmb/build_missing_REFcone.f90 @@ -0,0 +1,245 @@ +SUBROUTINE build_missing_REFcone(mype,nlon,nlat,nsig,krad_bot_in,ref_mos_3d,h_bk,pblh) +! +! radar observation +! +! +!$$$ subprogram documentation block +! . . . . +! subprogram: build_missing_REFcone build missing reflectivity area +! below cone down to assumed cloud base +! +! PRGMMR: Ming Hu ORG: GSD/AMB DATE: 2008-11-26 +! +! ABSTRACT: +! This subroutine sets reflectivity values at missing reflectivity volumes +! below the radar "data cone" down to an assumed cloud base +! As of March 2010, this code code not yet use the local PBL base +! as used in the RUC cloud/hydrometeor analysis since summer 2009. +! +! PROGRAM HISTORY LOG: +! 2009-01-20 Hu Add NCO document block +! 2011-04-08 Hu Clean the reflectivity below PBL height or level 7 +! +! +! input argument list: +! mype - processor ID +! nlon - no. of lons on subdomain (buffer points on ends) +! nlat - no. of lats on subdomain (buffer points on ends) +! nsig - no. of levels +! krad_bot - radar bottom level +! ref_mos_3d - 3D radar reflectivity +! h_bk - 3D background height +! pblh - PBL height in grid +! +! output argument list: +! ref_mos_3d - 3D radar reflectivity +! +! USAGE: +! INPUT FILES: +! +! OUTPUT FILES: +! +! REMARKS: +! +! ATTRIBUTES: +! LANGUAGE: FORTRAN 90 +! MACHINE: Linux cluster (WJET) +! +!$$$ +! +!_____________________________________________________________________ +! + + use kinds, only: r_kind,i_kind,r_single + implicit none + + INTEGER(i_kind), intent(in) :: mype + INTEGER(i_kind), intent(in) :: nlon,nlat,nsig + real(r_single), intent(in) :: h_bk(nlon,nlat,nsig) ! 3D height + real(r_kind), intent(inout):: ref_mos_3d(nlon,nlat,nsig) ! reflectivity in grid + real(r_single), intent(in) :: pblh(nlon,nlat) ! PBL height + real(r_single), intent(in) :: krad_bot_in +! + integer(i_kind) :: krad_bot,ifmissing +! + integer(i_kind) :: maxlvl + parameter (maxlvl=31) + real(r_kind) :: newlvlAll(maxlvl) ! vertical levels of reflectivity statistic profile(km) + DATA newlvlAll/0.2, 0.5, 0.75, 1, 1.25, 1.5, 1.75, 2, 2.25, 2.5, 2.75, & + 3, 3.5, 4, 4.5, 5, 5.5, 6, 6.5, 7, 7.5, 8, 8.5, & + 9, 10, 11, 12, 13, 14, 15, 16/ + + real(r_kind) :: refprofile_winter(maxlvl,6) ! statistic reflectivity profile used to + ! retrieve vertical ref based on lightning +! max reflectivity 20-35 dbz + DATA refprofile_winter(:,1) / & + 0.999,0.938,0.957,0.975,0.983,0.990,0.995,0.999,1.000,1.000, & + 0.994,0.985,0.957,0.926,0.892,0.854,0.819,0.791,0.770,0.747, & + 0.729,0.711,0.705,0.685,0.646,0.631,0.649,0.711,0.828,0.931, & + 0.949/ +! max reflectivity 25-30 dbz + DATA refprofile_winter(:,2) / & + 0.965,0.937,0.954,0.970,0.984,0.991,0.996,1.000,0.997,0.988, & + 0.973,0.954,0.908,0.856,0.808,0.761,0.718,0.684,0.659,0.631, & + 0.607,0.586,0.570,0.550,0.523,0.512,0.531,0.601,0.711,0.813, & + 0.870/ +! max reflectivity 30-35 dbz + DATA refprofile_winter(:,3) / & + 0.966,0.958,0.977,0.989,0.998,1.000,0.997,0.992,0.981,0.962, & + 0.933,0.898,0.826,0.752,0.687,0.626,0.578,0.547,0.522,0.526, & + 0.519,0.501,0.482,0.464,0.437,0.430,0.454,0.539,0.662,0.742, & + 0.793/ +! max reflectivity 35-40 dbz + DATA refprofile_winter(:,4) / & + 0.947,0.953,0.980,0.994,1.000,0.996,0.987,0.974,0.956,0.928, & + 0.891,0.848,0.761,0.679,0.613,0.559,0.522,0.491,0.473,0.462, & + 0.451,0.433,0.415,0.403,0.382,0.380,0.406,0.482,0.603,0.707, & + 0.723/ +! max reflectivity 40-45 dbz + DATA refprofile_winter(:,5) / & + 0.937,0.955,0.986,1.000,0.997,0.995,0.988,0.978,0.957,0.920, & + 0.871,0.824,0.735,0.654,0.584,0.518,0.465,0.442,0.435,0.412, & + 0.398,0.385,0.376,0.360,0.340,0.350,0.377,0.446,0.551,0.625, & + 0.656/ +! max reflectivity 45-50 dbz + DATA refprofile_winter(:,6) / & + 0.900,0.949,0.982,0.995,1.000,0.998,0.983,0.954,0.914,0.874, & + 0.834,0.793,0.721,0.664,0.612,0.565,0.530,0.496,0.460,0.431, & + 0.402,0.383,0.370,0.354,0.335,0.321,0.347,0.342,0.441,0.510, & + 0.548/ + + + real(r_kind) :: refprofile_summer(maxlvl,6) ! statistic reflectivity profile used to + ! retrieve vertical ref based on lightning +! max reflectivity 20-25 dbz + DATA refprofile_summer(:,1) / & + 0.883,0.870,0.879,0.892,0.904,0.912,0.913,0.915,0.924,0.936, & + 0.946,0.959,0.984,0.999,1.000,0.995,0.988,0.978,0.962,0.940, & + 0.916,0.893,0.865,0.839,0.778,0.708,0.666,0.686,0.712,0.771, & + 0.833/ +! max reflectivity 25-30 dbz + DATA refprofile_summer(:,2) / & + 0.836,0.874,0.898,0.915,0.927,0.938,0.945,0.951,0.960,0.970, & + 0.980,0.989,1.000,0.995,0.968,0.933,0.901,0.861,0.822,0.783, & + 0.745,0.717,0.683,0.661,0.614,0.564,0.538,0.543,0.578,0.633, & + 0.687/ +! max reflectivity 30-35 dbz + DATA refprofile_summer(:,3) / & + 0.870,0.885,0.914,0.931,0.943,0.954,0.967,0.975,0.982,0.989, & + 0.995,1.000,0.998,0.973,0.918,0.850,0.791,0.735,0.690,0.657, & + 0.625,0.596,0.569,0.544,0.510,0.479,0.461,0.460,0.477,0.522, & + 0.570/ +! max reflectivity 35-40 dbz + DATA refprofile_summer(:,4) / & + 0.871,0.895,0.924,0.948,0.961,0.971,0.978,0.983,0.988,0.992, & + 0.997,1.000,0.995,0.966,0.913,0.848,0.781,0.719,0.660,0.611, & + 0.576,0.542,0.523,0.513,0.481,0.448,0.416,0.402,0.417,0.448, & + 0.491/ +! max reflectivity 40-45 dbz + DATA refprofile_summer(:,5) / & + 0.875,0.895,0.914,0.936,0.942,0.951,0.964,0.979,0.990,0.998, & + 1.000,0.992,0.961,0.905,0.834,0.772,0.722,0.666,0.618,0.579, & + 0.545,0.518,0.509,0.483,0.419,0.398,0.392,0.403,0.423,0.480, & + 0.440/ +! max reflectivity 45-50 dbz + DATA refprofile_summer(:,6) / & + 0.926,0.920,0.948,0.975,0.988,0.989,0.995,0.997,1.000,1.000, & + 0.997,0.991,0.970,0.939,0.887,0.833,0.788,0.741,0.694,0.655, & + 0.611,0.571,0.551,0.537,0.507,0.470,0.432,0.410,0.420,0.405, & + 0.410/ + + INTEGER(i_kind) :: season ! 1= summer, 2=winter + + REAL(r_kind) :: heightGSI,upref,downref,wght + INTEGER(i_kind) :: ilvl,numref + REAL(r_kind) :: lowest,highest,tempref(nsig), tempprofile(maxlvl) + REAL(r_kind) :: maxref + + INTEGER(i_kind) :: i,j, k2, k, mref + +! +! vertical reflectivity distribution +! + season=1 + DO k=1,maxlvl + newlvlAll(k)=newlvlAll(k)*1000.0_r_kind + ENDDO +! + DO j=2,nlat-1 + DO i=2,nlon-1 + ifmissing=0 + maxref=-9999.0_r_kind +!mhu krad_bot= int( max(krad_bot_in,pblh(i,j)) + 0.5_r_single ) ! consider PBL height +! Here, we only use PBL height to build missing corn and clean the reflectivity lower than +! PBL height. The krad_bot_in will be used when calculate the radar tten but not the hydrometer retrieval. +! Nov 21, 2011. Ming Hu + krad_bot= int( pblh(i,j) + 0.5_r_single ) ! consider PBL height +! +! in our case, -99 is no echo +! + DO k2=int(nsig/2),krad_bot,-1 + if(ref_mos_3d(i,j,k2+1)>=20._r_kind .and. & + ref_mos_3d(i,j,k2) < -100._r_kind ) ifmissing=k2 + if(ref_mos_3d(i,j,k2)>=maxref) maxref=ref_mos_3d(i,j,k2) + ENDDO + IF(ifmissing > 1 ) then + DO k2=krad_bot,1,-1 + if(ref_mos_3d(i,j,k2) >maxref) maxref=ref_mos_3d(i,j,k2) + ENDDO +! if(maxref < 19.0_r_kind) then +! write(6,*) 'build_missing_REFcone:',ifmissing,i,j,ifmissing +! write(6,*) (ref_mos_3d(i,j,k2),k2=1,nsig) +! endif + endif + IF(ifmissing > 1 .and. maxref > 19.0_r_kind ) then + mref = min(6,(int((maxref - 20.0_r_kind)/5.0_r_kind) + 1 )) + if(season== 2 ) then + DO k=1,maxlvl + tempprofile(k)=refprofile_winter(k,mref)*maxref + enddo + lowest=newlvlAll(2) + highest=7000.0_r_kind + else if(season== 1 ) then + DO k=1,maxlvl + tempprofile(k)=refprofile_summer(k,mref)*maxref + enddo + lowest=newlvlAll(3) + highest=12000.0_r_kind + endif +! make a ref profile + tempref=-9999.9_r_kind + DO k2=1,nsig + heightGSI=h_bk(i,j,k2) + if(heightGSI >= lowest .and. heightGSI < highest) then ! lower 12km ? + do k=1,maxlvl-1 + if( heightGSI >=newlvlAll(k) .and. & + heightGSI < newlvlAll(k+1) ) ilvl=k + enddo + upref=tempprofile(ilvl+1) + downref=tempprofile(ilvl) + wght=(heightGSI-newlvlAll(ilvl))/(newlvlAll(ilvl+1)-newlvlAll(ilvl)) + tempref(k2)=(1-wght)*downref + wght*upref + endif + ENDDO +! build missing volumes down to krad_bot level +! NOTE: no use of PBL base yet, as done in RUC analysis since summer 2009 + maxref=ref_mos_3d(i,j,ifmissing+1)-tempref(ifmissing+1) + if(abs(maxref) < 10.0_r_kind ) then + DO k2=ifmissing,krad_bot,-1 + ref_mos_3d(i,j,k2) = tempref(k2) + maxref + ENDDO + else + DO k2=ifmissing,krad_bot,-1 + ref_mos_3d(i,j,k2) = ref_mos_3d(i,j,ifmissing+1) + ENDDO + endif +! + ENDIF +! clean echo less than PBL height and level 7 + DO k2=1,krad_bot + ref_mos_3d(i,j,k2) = -99999.0_r_kind + ENDDO + ENDDO + ENDDO + +END SUBROUTINE build_missing_REFcone diff --git a/src/GSD/gsdcloud4nmmb/cloudCover_NESDIS.f90 b/src/GSD/gsdcloud4nmmb/cloudCover_NESDIS.f90 new file mode 100755 index 0000000000..24e89e0115 --- /dev/null +++ b/src/GSD/gsdcloud4nmmb/cloudCover_NESDIS.f90 @@ -0,0 +1,697 @@ +SUBROUTINE cloudCover_NESDIS(mype,regional_time,nlat,nlon,nsig,& + xlong,xlat,t_bk,p_bk,h_bk,zh,xland, & + soil_tbk,sat_ctp,sat_tem,w_frac,& + l_cld_bld,cld_bld_hgt,build_cloud_frac_p,clear_cloud_frac_p,nlev_cld, & + cld_cover_3d,cld_type_3d,wthr_type) +! +! +!$$$ subprogram documentation block +! . . . . +! subprogram: cloudCover_NESDIS cloud cover analysis using NESDIS cloud products +! +! PRGMMR: Ming Hu ORG: GSD/AMB DATE: 2006-11-10 +! +! ABSTRACT: +! This subroutine determines cloud_cover (fractional) field using NESDIS cloud products +! Based on RUC assimilation code - (Benjamin, Weygandt, Kim, Brown) +! +! PROGRAM HISTORY LOG: +! 2009-01-20 Hu Add NCO document block +! 2016-02-10 S.Liu use r_single type for xland +! +! +! input argument list: +! mype - processor ID +! regional_time - analysis time +! nlon - no. of lons on subdomain (buffer points on ends) +! nlat - no. of lats on subdomain (buffer points on ends) +! nsig - no. of levels +! xlong - 2D longitude in each grid +! xlat - 2D latitude in each grid +! +! t_bk - 3D background potential temperature (K) +! p_bk - 3D background pressure (hPa) +! h_bk - 3D background height +! zh - terrain +! xland - surface type (water, land) +! soil_tbk - background soil temperature +! sat_ctp - GOES cloud top pressure in analysis grid +! sat_tem - GOES cloud top temperature in analysis grid +! w_frac - GOES cloud coverage in analysis grid +! l_cld_bld - logical for turning on GOES cloud building +! cld_bld_hgt - Height below which cloud building is done +! build_cloud_frac_p - Threshold above which we build clouds +! clear_cloud_frac_p - Threshold below which we clear clouds +! +! output argument list: +! nlev_cld - cloud status +! cld_cover_3d- 3D cloud cover (fractional cloud) +! cld_type_3d - 3D cloud type +! wthr_type - 3D weather type +! +! USAGE: +! INPUT FILES: +! +! OUTPUT FILES: +! +! REMARKS: +! +! ATTRIBUTES: +! LANGUAGE: FORTRAN 90 +! MACHINE: Linux cluster (WJET) +! +!$$$ +! +!_____________________________________________________________________ +! + + use constants, only: rd_over_cp, h1000 + use constants, only: deg2rad, rad2deg, pi + use kinds, only: r_single,i_kind,r_kind + + implicit none + + integer(i_kind),intent(in) :: mype + integer(i_kind),intent(in) :: regional_time(6) + integer(i_kind),intent(in) :: nlat,nlon,nsig +! +! background +! + real(r_single),intent(in) :: xlong(nlon,nlat) ! longitude + real(r_single),intent(in) :: xlat(nlon,nlat) ! latitude + real(r_single),intent(in) :: t_bk(nlon,nlat,nsig) ! potentional temperature + real(r_single),intent(inout) :: p_bk(nlon,nlat,nsig) ! pressure + real(r_single),intent(in) :: h_bk(nlon,nlat,nsig) ! height + real(r_single),intent(in) :: zh(nlon,nlat) ! terrain + real(r_single), intent(in) :: xland(nlon,nlat) ! surface + real(r_single),intent(in) :: soil_tbk(nlon,nlat) ! soil tmperature +! real(r_single),intent(in) :: q_bk(nlon,nlat,nsig) ! moisture, water vapor mixing ratio (kg/kg) +! +! Observation +! + real(r_single),intent(inout) :: sat_ctp(nlon,nlat) + real(r_single),intent(inout) :: sat_tem(nlon,nlat) + real(r_single),intent(inout) :: w_frac(nlon,nlat) + integer(i_kind),intent(out) :: nlev_cld(nlon,nlat) +! +! Turn on cloud building and height limit + logical, intent(in) :: l_cld_bld + real(r_kind), intent(in) :: cld_bld_hgt + real(r_kind), intent(in) :: build_cloud_frac_p + real(r_kind), intent(in) :: clear_cloud_frac_p +! +! Variables for cloud analysis +! + real (r_single),intent(inout) :: cld_cover_3d(nlon,nlat,nsig) + integer(i_kind),intent(inout) :: cld_type_3d(nlon,nlat,nsig) + integer(i_kind),intent(inout) :: wthr_type(nlon,nlat) +! +!------------------------------------------------------------------------- +! --- Key parameters +! Cloud_def_p = 0.000001 g/g cloud top threshold for model +! Min_cloud_lev_p = 3 Lowest model level to check for cloud +! Rh_clear_p = 0.80 RH to use when clearing cloud +! Sat_cloud_pthick_p= 50. Depth (mb) of new sat-sensed cloud layer +! cloud_zthick_p = 300. Depth (m) of new cloud layer +! Cloud_q_qvis_rat_p= 0.10 Ratio of cloud water to water/ice +! saturation mixing ratio for new cloud +! Max_cloud_top_p = 150. Max cloud top (mb) +! RH_makecloud_p = 0.90 RH threshold for making cloud if bkg +! rh is at least this high at +! neighboring points +! Cloud_up_p = 10 Pressure thickness for +! Upward extrapolation of cloud +! (if model level is within cloud_up_p +! mb of sat cloud level) +! min_cloud_p_p = 960. Max pressure at which NESDIS cloud +! info is considered reliable +! (i.e., not reliable at low levels) + +! zen_limit = 0.20 Solar zenith angle - lower limit +! at which sun is considered +! high enough to trust the +! GOES cloud data + + real(r_kind) :: Cloud_def_p + integer(i_kind) :: min_cloud_lev_p + real(r_kind) :: Rh_clear_p + real(r_kind) :: sat_cloud_pthick_p + real(r_kind) :: cloud_zthick_p + real(r_kind) :: Cloud_q_qvis_rat_p + real(r_kind) :: Max_cloud_top_p + real(r_kind) :: RH_makecloud_p + real(r_kind) :: cloud_up_p + real(r_kind) :: min_cloud_p_p + real(r_kind) :: co2_preslim_p + real(r_kind) :: auto_conver + real(r_kind) :: zen_limit + real(r_kind) :: dt_remap_pcld_limit_p + +! --- Key parameters + data Cloud_def_p / 0.000001_r_kind/ + data Min_cloud_lev_p / 1_i_kind / ! w/ sfc cld assim +! data Min_cloud_lev_p / 3_i_kind / ! w/ sfc cld assim + data Rh_clear_p / 0.80_r_kind/ + data Sat_cloud_pthick_p / 30._r_kind/ +! data Sat_cloud_pthick_p / 50._r_kind/ + data cloud_zthick_p / 300._r_kind/ + data Cloud_q_qvis_rat_p / 0.05_r_kind/ + data Max_cloud_top_p / 150._r_kind/ + data RH_makecloud_p / 0.90_r_kind/ + data cloud_up_p / 0._r_kind / + data min_cloud_p_p / 1080._r_kind/ ! w/ sfc cld assim + data co2_preslim_p / 620._r_kind/ + data auto_conver / 0.0002_r_kind/ +! -- change to 82 deg per Patrick Minnis - 4 Nov 09 + data zen_limit / 0.14_r_kind/ +! data zen_limit / 0.20_r_kind / + data dt_remap_pcld_limit_p / 3.5_r_kind / +!----------------------------------------------------------- +! +! temp. +! + INTEGER(i_kind) :: null_p + REAL(r_kind) :: spval_p + PARAMETER ( null_p = -1 ) + PARAMETER ( spval_p = 99999.0 ) + + INTEGER(i_kind) :: i,j,k,k1,i1,j1,jp1,jm1,ip1,im1 + REAL(r_kind) :: ri, rj + INTEGER(i_kind) :: gmt,nday,iyear,imonth,iday + REAL(r_kind) :: declin + real(r_kind) :: hrang,xxlat + real(r_single) :: csza(nlon,nlat) + + INTEGER(i_kind) :: ndof_tot, npts_clear, npts_build, npts_bel650 + INTEGER(i_kind) :: npts_warm_cld_flag, npts_tskin_flag, npts_stab_flag, npts_ptly_cloudy + real (r_single) :: tbk_k(nlon,nlat,nsig) + + INTEGER(i_kind) :: npts_ctp_change, npts_ctp_delete, npts_ctp_nobuddy + INTEGER(i_kind) :: npts_clr_nobuddy,npts_ctp_marine_remap + real (r_single) :: dctp, dctpabs + + real(r_single) :: tsmin + + INTEGER(i_kind) :: kisotherm, ibuddy, ktempmin + real(r_kind) :: tempmin,dth2dp2, stab, stab_threshold + + real(r_kind) :: firstcloud, pdiff,pdiffabove + + INTEGER(i_kind) :: ista, k_closest, cld_warm_strat(nlon,nlat) + REAL(r_kind) :: dist, tdiff + +! +!==================================================================== +! Begin +! +! calculation solar declination +! + iyear=regional_time(1) + imonth=regional_time(2) + iday=regional_time(3) + call getdays(nday,iyear,imonth,iday) + declin=deg2rad*23.45_r_kind*sin(2.0_r_kind*pi*(284+nday)/365.0_r_kind) + + cld_warm_strat=-1 +! +! from mb to Pa +! + do k = 1,nsig + do j = 1,nlat + do i = 1,nlon +! qw=q_bk(i,j,k)/(1. + q_bk(i,j,k)) ! convert to specific humidity + tbk_k(i,j,k)=t_bk(i,j,k)*(p_bk(i,j,k)/h1000)**rd_over_cp ! convert to temperature(K) + p_bk(i,j,k) = p_bk(i,j,k)*100._r_kind + end do + end do + end do + + if( p_bk(nlon/2,nlat/2,2) < 5000.0_r_kind ) then + write(6,*) 'cloudCover_NESDIS: pressure unit check failed', p_bk(nlon/2,nlat/2,2) + call stop2(114) + endif + if( tbk_k(nlon/2,nlat/2,nsig-2) > 300._r_kind) then + write(6,*) 'cloudCover_NESDIS: temperature unit check failed', & + tbk_k(nlon/2,nlat/2,nsig-2) + call stop2(114) + endif + +! +! csza = fraction of solar constant (cos of zenith angle) + gmt = regional_time(4) ! UTC + do j=2,nlat-1 + do i=2,nlon-1 + hrang= (15._r_kind*gmt + xlong(i,j) - 180._r_kind )*deg2rad + xxlat=xlat(i,j)*deg2rad + csza(i,j)=sin(xxlat)*sin(declin) & + +cos(xxlat)*cos(declin)*cos(hrang) + end do + end do + +! +! start checking the data +! + ndof_tot = 0 !counting total number of grids of sat info + npts_clear = 0 + npts_build = 0 + npts_bel650 = 0 + npts_tskin_flag = 0 + npts_stab_flag = 0 + npts_ptly_cloudy = 0 + + do j=2,nlat-1 + do i=2,nlon-1 + jp1 = min(j+1,nlat) + jm1 = max(j-1,1 ) + ip1 = min(i+1,nlon) + im1 = max(i-1,1 ) + tsmin = soil_tbk(i,j) +! --- Determine min skin temp in 3x3 around grid point. +! This is to detect nearby presence of coastline. + do j1 = jm1,jp1 + do i1 = im1,ip1 + tsmin = min(tsmin,soil_tbk(i1,j1) ) + end do + end do + + if ( w_frac(i,j) > -1._r_kind & + .and. (sat_tem(i,j)-soil_tbk(i,j)) > 4._r_kind & + .and. soil_tbk(i,j) < 263._r_kind & + .and. sat_ctp(i,j) > co2_preslim_p & + .and. sat_ctp(i,j) < 1010._r_kind & + .and. xland(i,j) /=0.0 & + .and. p_bk(i,j,1)/100. >=850._r_kind ) then +! w_frac(i,j) = -99999._r_kind +! sat_tem(i,j) = 99999._r_kind +! sat_ctp(i,j) = 0._r_kind +! nlev_cld(i,j) = -999 + npts_warm_cld_flag = npts_warm_cld_flag + 1 + cld_warm_strat(i,j)=5 + end if +! PH changed condition to match RUC: Tcld-Tskin(bkg) < 4, > -2 + if ( w_frac(i,j) > -1._r_kind & + .and. (sat_tem(i,j)-tsmin) > -2._r_kind & + .and. (sat_tem(i,j)-tsmin) <= 4._r_kind & + .and. sat_ctp(i,j) > co2_preslim_p & + .and. sat_ctp(i,j) < 1010._r_kind & + .and. xland(i,j) /=0.0 & + .and. p_bk(i,j,1)/100._r_kind>= 950._r_kind ) then + w_frac(i,j) = -99999._r_kind + sat_tem(i,j) = 99999._r_kind + sat_ctp(i,j) = 0._r_kind + nlev_cld(i,j)= -999 + npts_tskin_flag = npts_tskin_flag + 1 + cld_warm_strat(i,j)=4 + end if + if (w_frac(i,j)<=clear_cloud_frac_p .and. & + w_frac(i,j)>-1._r_kind) then + sat_ctp(i,j) = 1013.0_r_kind + npts_clear = npts_clear + 1 + cld_warm_strat(i,j)=0 + end if + if (w_frac(i,j) > clear_cloud_frac_p.and. & + w_frac(i,j) < build_cloud_frac_p) then +! w_frac(i,j) = -99999._r_kind + sat_tem(i,j)= 99999._r_kind +! mhu: this can cause problem: a miss line between cloud and clean, set it to clean +! PH: for CLAVR data, just set sat_ctp = 0. + sat_ctp(i,j) = 0._r_kind + nlev_cld(i,j)= -999 + npts_ptly_cloudy = npts_ptly_cloudy + 1 + cld_warm_strat(i,j)=1 + end if + if (w_frac(i,j) >= build_cloud_frac_p.and. & + sat_ctp(i,j) < 1050) then + npts_build = npts_build + 1 + cld_warm_strat(i,j)=2 + end if + if (sat_ctp(i,j)>co2_preslim_p .and. sat_ctp(i,j)<1010._r_kind) & + npts_bel650 = npts_bel650 + 1 + +! -- nlev_cld = 1 if cloud info is present +! -- nlev_cld = 0 if no cloud info is at this grid point + + if(nlev_cld(i,j) >= 1) ndof_tot = ndof_tot + 1 + end do ! i + end do ! j +! + if(mype==0) then + write(6,*) 'cloudCover_NESDIS: TOTAL NUMBER OF GRID pts w/ GOES CLOUD data =',ndof_tot + write(6,*) 'cloudCover_NESDIS: CLEAR NUMBER OF GRID pts w/ GOES CLOUD data =',npts_clear + write(6,*) 'cloudCover_NESDIS: BUILD NUMBER OF GRID pts w/ GOES CLOUD data =',npts_build + write(6,*) 'cloudCover_NESDIS: PTCLDY NUMBER OF GRID pts w/ GOES CLOUD data =',npts_ptly_cloudy + write(6,*) 'cloudCover_NESDIS: > 650mb - no OF GRID pts w/ GOES CLOUD data =',npts_bel650 + write(6,*) 'cloudCover_NESDIS: Flag CTP - skin temp too close to TB, no=',npts_tskin_flag + write(6,*) 'cloudCover_NESDIS: Clear -> cloud frac < clear frac' + write(6,*) 'cloudCover_NESDIS: Build -> cloud frac > build frac' + endif + +! +!! +! + npts_ctp_change = 0 + npts_ctp_delete = 0 + npts_ctp_nobuddy = 0 + npts_clr_nobuddy = 0 + npts_ctp_marine_remap = 0 + dctp = 0. + dctpabs = 0. + +! - stability threshold for building cloud - 3K / 100 mb (10000 Pa) + + stab_threshold = 3._r_kind/10000._r_kind + do j=2,nlat-1 + do i=2,nlon-1 + +! -- GOES indicates clouds in the lower troposphere + if (sat_ctp(i,j) < 1010._r_kind .and. sat_ctp(i,j) > co2_preslim_p) then + + tdiff = 999. + k_closest = -1 + do k=3,nsig-1 +! Attempt remapping if within 75 hPa (arbitrary) + if ((sat_ctp(i,j)-p_bk(i,j,k)/100._r_kind)< 75._r_kind) then + if (abs(sat_tem(i,j)-tbk_k(i,j,k)) < tdiff) then + k_closest = k + tdiff = abs(sat_tem(i,j)-tbk_k(i,j,k)) + end if + end if + end do ! k loop + + if (k_closest <= 0 .and. xland(i,j) /= 0.0) then + npts_ctp_delete = npts_ctp_delete + 1 + write (6,*) i,j,sat_tem(i,j),tdiff,k_closest,xland(i,j) + go to 111 + end if + + k = k_closest + + if( xland(i,j) /=0.0 ) then +! PH: dt_limit was hardwired to 1.5K, changed it to 3.5K to match RUC + if ((tdiff < dt_remap_pcld_limit_p) .or. & + (cld_warm_strat(i,j) == 5 .and. tdiff < 4._r_kind )) then + dctpabs = dctpabs + abs(sat_ctp(i,j)-p_bk(i,j,k)/100._r_kind) + dctp = dctp+ (sat_ctp(i,j)-p_bk(i,j,k)/100._r_kind) + k1 = k + +1115 continue + +! --- This stability check only for reassigining CTP using RUC bkg profile. +! There is a later general check also. + stab = (t_bk(i,j,k1+1)-t_bk(i,j,k1)) & + /(p_bk(i,j,k1)-p_bk(i,j,k1+1)) + if (stab < stab_threshold) then + k1 = k1 + 1 + if ((p_bk(i,j,k)-p_bk(i,j,k1)) > 5000._r_kind) then + w_frac(i,j) = -99999._r_kind + sat_tem(i,j) = 99999._r_kind + sat_ctp(i,j) = 99999._r_kind + nlev_cld(i,j) = -999 + npts_stab_flag= npts_stab_flag + 1 + go to 111 + end if + go to 1115 + end if + + sat_ctp(i,j) = p_bk(i,j,k)/100._r_kind + npts_ctp_change = npts_ctp_change + 1 + go to 111 + else + npts_ctp_delete = npts_ctp_delete + 1 +! write (6,*) i,j,sat_tem(i,j),tdiff + go to 111 + end if + + else ! xland==0: over water + +! --- Remap marine cloud to min temp level below 880 mb +! if no matching RUC temp already found + + if (sat_ctp(i,j)>880._r_kind)then + tempmin = -500._r_kind + +! --- Look thru lowest 15 levels for lowest temp for +! level to put marine cloud at. +! --- Start at level 3 + kisotherm = 20 + ktempmin = 20 + do k=min_cloud_lev_p+2,15 + if (p_bk(i,j,k)/100._r_kind .lt. 880._r_kind) go to 1101 + dth2dp2 = t_bk(i,j,k+1)+t_bk(i,j,k-1)-2._r_kind*t_bk(i,j,k) + if (kisotherm==0 .and. & + tbk_k(i,j,k) < tbk_k(i,j,k+1)) kisotherm = k + if (dth2dp2>tempmin) then + ktempmin = k + tempmin = max(dth2dp2,tempmin) + end if + end do +1101 continue + ktempmin = min(ktempmin,kisotherm) + sat_ctp(i,j) = p_bk(i,j,ktempmin)/100._r_kind + npts_ctp_marine_remap = npts_ctp_marine_remap + 1 + end if ! sat_ctp(i,j)>880._r_kind + endif ! xland == 0 + end if +111 continue + enddo ! i + enddo ! j + + if(mype==0) then + write(6,*) 'cloudCover_NESDIS: Flag CTP - unstable w/i 50mb of CTP, no=', npts_stab_flag + write(6,*) 'cloudCover_NESDIS: Flag CTP - can''t remap CTP, no=', npts_ctp_delete + write(6,*) 'cloudCover_NESDIS: Flag CTP -remap marine cloud, no=', npts_ctp_marine_remap + endif + + if (npts_ctp_change > 0) then + if(mype==0) write (6,1121) npts_ctp_change, dctp/float(npts_ctp_change), & + dctpabs/float(npts_ctp_change) +1121 format (/'No. of pts w/ cloud-top pres change = ',i6 & + /'Mean cloud-top pres change (old-new)= ',f8.1 & + /'Mean abs cloud-top pres change = ',f8.1/) + end if +! +! --- Make sure that any cloud point has another cloud point nearby. +! Otherwise, get rid of it. + do j=2,nlat-1 + do i=2,nlon-1 + if (sat_ctp(i,j)< 1010._r_kind .and. sat_ctp(i,j)>50._r_kind) then + ibuddy = 0 + do j1=j-1,j+1 + do i1=i-1,i+1 + if (sat_ctp(i1,j1)<1010._r_kind .and. sat_ctp(i1,j1)>50._r_kind) ibuddy = 1 + end do + end do + if (ibuddy==0) then + w_frac(i,j) = -99999._r_kind + sat_tem(i,j) = 99999._r_kind + sat_ctp(i,j) = 99999._r_kind + nlev_cld(i,j) = -999 + npts_ctp_nobuddy = npts_ctp_nobuddy + 1 + end if + end if + if (sat_ctp(i,j)>1010._r_kind .and. sat_ctp(i,j) <1100._r_kind) then + ibuddy = 0 + do j1=j-1,j+1 + do i1=i-1,i+1 + if (sat_ctp(i1,j1) > 1010._r_kind .and. sat_ctp(i1,j1) <1100._r_kind) ibuddy = 1 + end do + end do + if (ibuddy == 0) then + w_frac(i,j) = -99999._r_kind + sat_tem(i,j) = 99999._r_kind + sat_ctp(i,j) = 99999._r_kind + nlev_cld(i,j) = -999 + npts_clr_nobuddy = npts_clr_nobuddy + 1 + end if + end if + enddo + enddo + + if(mype==0) then + write(6,*) 'cloudCover_NESDIS: Flag CTP - no contiguous points also w/ cloud, no=', & + npts_ctp_nobuddy + + write(6,*) 'cloudCover_NESDIS: Flag CTP - no contiguous points also w/ clear, no=', & + npts_clr_nobuddy + endif + +! +! ***************************************************************** +! ***************************************************************** +! Start to adjust to GOES cloud top pressure +! ***************************************************************** +! ***************************************************************** + +! --- clear where GOES shows clear down to the surface +! or down to the GOES cloud top level + +! ============================================= +! - clear down to surface in fully clear column (according to GOES) +! ============================================= +! Only trust 'clear' indication under following conditions +! - over ocean +! - or over land only if p<620 mb overnight +! - or at any level in daytime (zenith angle +! greater than zen_limit threshold) +! ============================================= + do j=2,nlat-1 + do i=2,nlon-1 + if (sat_ctp(i,j) >=1010.0_r_kind .and. sat_ctp(i,j) <1050._r_kind) then !clear + do k=1,nsig + if (csza(i,j)=zen_limit) then + cld_cover_3d(i,j,k) = 0 + wthr_type(i,j) = 0 + end if + end do +!mhu: use 1060hps cloud top pressure to clean above the low cloud top + elseif (abs(sat_ctp(i,j)-1060.0_r_kind) < 1.0_r_kind) then !clear since the low cloud top + do k=1,nsig + if (csza(i,j)=zen_limit) then + if( abs(cld_cover_3d(i,j,k)) > 2 ) then + cld_cover_3d(i,j,k) = 0 + wthr_type(i,j) = 0 + endif + end if + end do + end if + enddo + enddo +! ============================================= +! - clearing above cloud top +! ============================================= + + do j=2,nlat-1 + do i=2,nlon-1 + do k=1,nsig-1 +! - return to previous (but experimental) version - 12 Oct 04 + if (csza(i,j) < zen_limit & + .and. p_bk(i,j,k)/100._r_kind=zen_limit) then +! --- since we set GOES to nearest RUC level, only clear at least +! 1 RUC level above cloud top + if (sat_ctp(i,j)<1010._r_kind .and. & + sat_ctp(i,j)>p_bk(i,j,k)/100._r_kind) then +! +! mhu, some low cloud top press (> 800 hpa) over clean the cloud that observed by METAR +! so add these check to keep cloud base correct +! + if(sat_ctp(i,j) >= 800.0_r_kind ) then + cld_cover_3d(i,j,k+1) = & + max(0.0_r_single, cld_cover_3d(i,j,k+1)) + else + cld_cover_3d(i,j,k+1) = 0 + endif + endif + end if + end do + enddo + enddo + +! print *, 'h_bk max: ', maxval(h_bk(:,:,1)), ' min: ', minval(h_bk(:,:,1)) + +! ============================================= +! - start building where GOES indicates so +! ============================================= + do j=2,nlat-1 + do i=2,nlon-1 + + if ((w_frac(i,j)>= build_cloud_frac_p) .and. & + (w_frac(i,j)< 99999._r_kind) )then !Dongsoo added + +! --- Cloud info below MIN_CLOUD_P not reliable + firstcloud = 0 +! - pdiff (diff between sat cloud top and model sfc pres) in mb + do k=nsig-1,min_cloud_lev_p,-1 + pdiff = (sat_ctp(i,j)-p_bk(i,j,k)/100._r_kind) +! --- set closest RUC level w/ cloud + if (pdiff<=0. .and. firstcloud==0) then + pdiffabove = sat_ctp(i,j)-p_bk(i,j,k+1)/100._r_kind + if (abs(pdiffabove) 800 hpa) over clean the cloud that observed by METAR +! so add these check to keep cloud base correct +! + if(sat_ctp(i,j) >= 800.0_r_kind ) then + cld_cover_3d(i,j,k+1) = max(0.0_r_single, cld_cover_3d(i,j,k+1)) + else + cld_cover_3d(i,j,k+1) = 0 + endif + firstcloud = 1 + end if + end if + +! no cloud above cloud top + +! +! --- Add 50mb thick (at least 1 level) of cloud where GOES +! indicates cloud top + if (xland(i,j)/=0._r_single) then + if (sat_ctp(i,j)< min_cloud_p_p .and. & + pdiff<=cloud_up_p ) then + if (firstcloud==0.or. firstcloud==1 & + .and.pdiff >= -1.*sat_cloud_pthick_p) then +! sgb - 2/7/2012 - remove this condition +! Allow cloud building below CO2_preslim and at night and over land +! if (p_bk(i,j,k)/100._r_kind= -1.*sat_cloud_pthick_p) then +! xland ==0 if (p_bk(i,j,k)/100..lt.co2_preslim_p) then + if (l_cld_bld .and. h_bk(i,j,k+1) < cld_bld_hgt) then + cld_cover_3d(i,j,k)=1 + else + cld_cover_3d(i,j,k)=-99998 + end if + firstcloud = 1 + end if + end if + end if + + end do + end if + enddo ! j + enddo + +! go from pa to mb + do k = 1,nsig + do j = 2,nlat-1 + do i = 2,nlon-1 + p_bk(i,j,k) = p_bk(i,j,k)/100._r_kind + end do + end do + end do +! +END SUBROUTINE cloudCover_NESDIS + diff --git a/src/GSD/gsdcloud4nmmb/cloudCover_Surface.f90 b/src/GSD/gsdcloud4nmmb/cloudCover_Surface.f90 new file mode 100755 index 0000000000..2f350c2717 --- /dev/null +++ b/src/GSD/gsdcloud4nmmb/cloudCover_Surface.f90 @@ -0,0 +1,411 @@ +SUBROUTINE cloudCover_Surface(mype,nlat,nlon,nsig,r_radius,thunderRadius,& + t_bk,p_bk,q,h_bk,zh, & + mxst_p,NVARCLD_P,numsao,OI,OJ,OCLD,OWX,Oelvtn,Odist,& + cld_cover_3d,cld_type_3d,wthr_type,pcp_type_3d, & + watericemax, kwatericemax) +! +!$$$ subprogram documentation block +! . . . . +! subprogram: cloudCover_Surface cloud cover analysis using surface observation +! +! PRGMMR: Ming Hu ORG: GSD/AMB DATE: 2006-10-30 +! +! ABSTRACT: +! This subroutine determines 3D cloud fractional cover using surface observations +! Code based on RUC assimilation code (hybfront/hybcloud.f) +! +! PROGRAM HISTORY LOG: +! 2009-01-20 Hu Add NCO document block +! +! +! input argument list: +! mype - processor ID +! nlon - no. of lons on subdomain (buffer points on ends) +! nlat - no. of lats on subdomain (buffer points on ends) +! nsig - no. of levels +! r_radius - influence radius of the cloud observation +! thunderRadius - +! +! t_bk - 3D background potentional temperature (K) +! p_bk - 3D background pressure (hPa) +! q - 3D moisture (water vapor mixing ratio) +! h_bk - 3D background height (m) +! zh - terrain (m) +! +! mxst_p - maximum observation number +! NVARCLD_P - first dimension of OLCD +! numsao - observation number +! OI - observation x location +! OJ - observation y location +! OLCD - cloud amount, cloud height, visibility +! OWX - weather observation +! Oelvtn - observation elevation +! Odist - distance from the nearest station +! +! output argument list: +! cld_cover_3d- 3D cloud cover +! cld_type_3d - 3D cloud type +! wthr_type - 3D weather type +! pcp_type_3d - 3D weather precipitation type +! +! USAGE: +! INPUT FILES: +! +! OUTPUT FILES: +! +! +! REMARKS: +! +! ATTRIBUTES: +! LANGUAGE: FORTRAN 90 +! MACHINE: Linux cluster (WJET) +! +!$$$ +! +!_____________________________________________________________________ +! + + use kinds, only: r_single,i_kind,r_kind + + implicit none + + integer(i_kind),intent(in) :: mype + REAL(r_single), intent(in) :: r_radius + integer(i_kind),intent(in) :: nlat,nlon,nsig + real(r_single), intent(in) :: thunderRadius +! +! surface observation +! + INTEGER(i_kind),intent(in) :: mxst_p,NVARCLD_P + +! PARAMETER (LSTAID_P=9) + + INTEGER(i_kind),intent(in) :: numsao + real(r_single), intent(in) :: OI(mxst_p) ! x location + real(r_single), intent(in) :: OJ(mxst_p) ! y location + INTEGER(i_kind),intent(in) :: OCLD(NVARCLD_P,mxst_p) ! cloud amount, cloud height, + ! visibility + CHARACTER*10, intent(in) :: OWX(mxst_p) ! weather + real(r_single), intent(in) :: Oelvtn(mxst_p) ! elevation + real(r_single), intent(in) :: Odist(mxst_p) ! distance from the nearest station + +! +! background +! + real(r_single),intent(in) :: t_bk(nlon,nlat,nsig) ! temperature + real(r_single),intent(in) :: p_bk(nlon,nlat,nsig) ! pressure + real(r_single),intent(in) :: zh(nlon,nlat) ! terrain + real(r_single),intent(in) :: q(nlon,nlat,nsig) ! moisture, water vapor mixing ratio (kg/kg) + real(r_single),intent(in) :: h_bk(nlon,nlat,nsig) ! height +! + REAL(r_single),intent(in) :: watericemax(mxst_p) ! max of background total liquid water in station + INTEGER(i_kind),intent(in):: kwatericemax(nlon,nlat) ! lowest level of background total liquid water in grid +! +! Variables for cloud analysis +! + real (r_single),intent(inout) :: cld_cover_3d(nlon,nlat,nsig) + integer(i_kind),intent(inout) :: cld_type_3d(nlon,nlat,nsig) + integer(i_kind),intent(inout) :: wthr_type(nlon,nlat) + integer(i_kind),intent(inout) :: pcp_type_3d(nlon,nlat,nsig) +! +! local +! + real (r_single) :: vis2qc(nlon,nlat) + real (r_single) :: cloud_zthick_p + data cloud_zthick_p /300._r_kind/ +! + REAL (r_kind) :: spval_p + PARAMETER ( spval_p = 99999.0_r_kind ) + + INTEGER(i_kind) :: i,j,k,k1 + INTEGER(i_kind) :: i1,j1,ic + INTEGER(i_kind) :: nx_p, ny_p, nztn_p + INTEGER(i_kind) :: ista + INTEGER(i_kind) :: ich, iob,job + + REAL(r_kind) :: min_dist, dist + REAL(r_kind) :: zdiff + REAL(r_kind) :: zlev_clr,cloud_dz,cl_base_ista,betav +! +! +! + real(r_single):: tbk_k(nlon,nlat,nsig) + real(r_single):: cv_bk(nlon,nlat,nsig) + real(r_single):: z_lcl(nlon,nlat) + REAL(r_kind) :: cf_model_base,t_model_base, ht_base + REAL(r_kind) :: t_dry_adiabat,t_inversion_strength + + LOGICAL :: l_cf,l_inversion + LOGICAL :: if_cloud_exist + + integer(i_kind) :: firstcloud,cl_base_broken_k + real(r_single) :: underlim + integer(i_kind) :: npts_near_clr + + +!==================================================================== +! Begin +! +! set constant names consistent with original RUC code +! + nx_p=nlon + ny_p=nlat + nztn_p=nsig + + vis2qc=-9999.0_r_kind + npts_near_clr=0 +! +! +!***************************************************************** +! analysis of surface/METAR cloud observations +! ***************************************************************** + + DO ista=1,numsao + i1 = int(oi(ista)+0.0001_r_kind) + j1 = int(oj(ista)+0.0001_r_kind) + min_dist = Odist(ista) + +!mh - grid point has the closest cloud station + +! -- find out if any precip is present + do ich=1,1 + if ( owx(ista)(ich:ich+1)=='SH' ) wthr_type(i1,j1)=16 + if ( owx(ista)(ich:ich+1)=='TH' .and. & + min_dist < thunderRadius) wthr_type(i1,j1)=1 + if ( owx(ista)(ich:ich+1)=='RA' ) wthr_type(i1,j1)=11 + if ( owx(ista)(ich:ich+1)=='SN' ) wthr_type(i1,j1)=12 + if ( owx(ista)(ich:ich+1)=='PL' ) wthr_type(i1,j1)=13 + if ( owx(ista)(ich:ich+1)=='DZ' ) wthr_type(i1,j1)=14 + if ( owx(ista)(ich:ich+1)=='UP' ) wthr_type(i1,j1)=15 + if ( owx(ista)(ich:ich+1)=='BR' ) wthr_type(i1,j1)=21 + if ( owx(ista)(ich:ich+1)=='FG' ) wthr_type(i1,j1)=22 + enddo + +! Consider clear condition case +! ----------------------------- + if (ocld(1,ista)==0) then + + do ic=1,6 + if(float(abs(ocld(6+ic,ista))) < 55555) then + write(6,*) 'cloudCover_Surface: Observed cloud above the clear level !!!' + write(6,*) 'cloudCover_Surface: some thing is wrong in surface cloud observation !' + write(6,*) 'cloudCover_Surface: check the station no.', ista, 'at process ', mype + write(6,*) ic,OI(ista),OJ(ista) + write(6,*) (ocld(k,ista),k=1,12) + call stop2(114) + endif + enddo +! clean the whole column up to ceilometer height (12 kft) if ob is CLR +! h_bk is AGL, not ASL (per Ming Hu's notes below +! +! zlev_clr = Oelvtn(ista)+3650. +! Upcoming mods commented out below for this commit - 4/3/2010 +! PH: added in column cleaning up to ceilometer height if ob is CLR + zlev_clr = 3650. + + do k=1,nztn_p + if (h_bk(i1,j1,k) < zlev_clr) then + cld_cover_3d(i1,j1,k)=0.0_r_kind + pcp_type_3d(i1,j1,k)=0 + endif + end do + + wthr_type(i1,j1)=0 + +! -- Now consider non-clear obs +! -------------------------- + else + +! increase zthick by 1.5x factor for ceiling < 900 m (~3000 ft - MVFR) + cloud_dz = cloud_zthick_p + cl_base_broken_k = -9 +! ????? check with Stan O(h_p) if (Oelvtn(ista).lt.900.) cloud_dz = cloud_zthick_p * 2 + + do ic = 1,6 + if (ocld(ic,ista)>0 .and. ocld(ic,ista)<50) then +! if ( csza(i,j)>=0.10 .and. sat_ctp(i1,j1)>1010.0 & +! .and. sat_ctp(i1,j1)<1050.) go to 1850 +! +! New tweak - 11/07/2009 +! If there was cloud in background over station but if there +! was partial cloudiness within volume and this is one of the +! clear columns within the polygonal area for this METAR, +! then leave it that way and skip. +! if (watericemax(iob,job).gt.0. .and. +! 1 kwatericemax(iob,job).gt.0 .and. +! 1 kwatericemax(iob,job).le.12) then +! npts_cld_match = npts_cld_match + 1 +! dzbase = cl_base_ista - g3(iob,job,kwatericemax(iob,job),h_p) +! sum_dzbase = sum_dzbase + dzbase +! sum_dzbase_abs = sum_dzbase_abs + abs(dzbase) +! end if + +! if (watericemax(ista) > 0._r_single .and. kwatericemax(i1,j1)==-1) then +! npts_near_clr = npts_near_clr + 1 +! cycle ! skip cloud build at point (i,j) because background is clear +! end if + + if(ocld(ic,ista) == 4) then + if(wthr_type(i1,j1) > 10 .and. wthr_type(i1,j1) < 20) cloud_dz = 1000._r_kind + ! precipitation + highest level + if(wthr_type(i1,j1) == 1) cloud_dz = 10000._r_kind ! thunderstorm + endif + +! --- calculate cloud ceiling level, not exactly, FEW SCT are also considered now +! iob = int(oi(ista)-idw+0.5) +! job = int(oj(ista)-ids+0.5) +! cl_base_ista = (float(ocld(6+ic,ista))+zh(iob,job)) +! cl_base_ista = (float(ocld(6+ic,ista))+Oelvtn(ista)) +! the h_bk is AGL. So observation cloud base should be AGL too, delete Oelvtn(ista) +! cover cloud base observation from AGL to ASL + cl_base_ista = float(ocld(6+ic,ista)) + Oelvtn(ista) - zh(i1,j1) + if(zh(i1,j1) < 1.0_r_kind .and. Oelvtn(ista) > 20.0_r_kind & + .and. float(ocld(6+ic,ista)) < 250.0_r_kind) then + cycle ! limit the use of METAR station over oceas for low cloud base + endif + + firstcloud = 0 + underlim = 10._r_kind ! + + do k=1,nztn_p + zdiff = cl_base_ista - h_bk(i1,j1,k) +! Must be within cloud_dz meters (300 or 1000 currently) +! ------------------------------------------------------------------- +! -- Bring in the clouds if model level is within 10m under cloud level. + if(k==1) underlim=(h_bk(i1,j1,k+1)-h_bk(i1,j1,k))*0.5_r_kind + if(k==2) underlim=10.0_r_kind ! 100 feet + if(k==3) underlim=20.0_r_kind ! 300 feet + if(k==4) underlim=15.0_r_kind ! 500 feet + if(k==5) underlim=33.0_r_kind ! 1000 feet + if (k>=6 .and. k <= 7) underlim = (h_bk(i1,j1,k+1)-h_bk(i1,j1,k))*0.6_r_kind + if(k==8) underlim=95.0_r_kind ! 3000 feet + if(k>=9 .and. k= 1.0 .and. (firstcloud==0 .or. abs(zdiff) 10 .and. wthr_type(i1,j1) < 20) then +! cld_type_3d(i1,j1,k)=5 + pcp_type_3d(i1,j1,k)=1 + endif + else + write(6,*) 'cloudCover_Surface: wrong cloud coverage observation!' + call stop2(114) + endif + firstcloud = firstcloud + 1 + end if ! zdiff < cloud_dz + else +! ---- Clear up to cloud base of first cloud level + if (ic==1) cld_cover_3d(i1,j1,k)=0 + if (ocld(ic,ista) == 1) pcp_type_3d(i1,j1,k)=0 + if (ocld(ic,ista) == 3 .or. ocld(ic,ista) == 4) then + if( (wthr_type(i1,j1) > 10 .and. wthr_type(i1,j1) < 20) & + .or. wthr_type(i1,j1) == 1 ) then + pcp_type_3d(i1,j1,k)=1 + endif + endif + end if ! underlim + end do ! end K loop +! ----clean cloud above stratusphere + do k=1,nztn_p + if( h_bk(i1,j1,k) > 18000 ) cld_cover_3d(i1,j1,k)=0 + enddo +! + end if ! end if ocld > 0 + end do ! end IC loop +! +! clean up to broken (3) or if cloud cover less than 2, clean to cloud top +! + if(cl_base_broken_k > 0 .and. cl_base_broken_k < nztn_p) then + do k=1, cl_base_broken_k + if( cld_cover_3d(i1,j1,k) < -0.001_r_kind ) cld_cover_3d(i1,j1,k)=0 + enddo + else + if(ocld(1,ista) == 1 .or. ocld(1,ista) == 2 ) then + do k=1, nztn_p + if( cld_cover_3d(i1,j1,k) < -0.001_r_kind ) cld_cover_3d(i1,j1,k)=0 + enddo + endif + endif + + end if ! end if cloudy ob ocld(1,ista) > 0 + +! -- Use visibility for low-level cloud whether + if (wthr_type(i1,j1) < 30 .and. wthr_type(i1,j1) > 20 .and. & + ocld(13,ista) < 5000 .and. ocld(13,ista) > 1) then + cld_type_3d(i1,j1,1) = 2 + cld_type_3d(i1,j1,2) = 2 + betav = 3.912_r_kind / (float(ocld(13,ista)) / 1000._r_kind) + vis2qc(i1,j1) = ( (betav/144.7_r_kind) ** 1.14_r_kind) / 1000._r_kind + endif ! cloud or clear + + ENDDO ! ista + + +! Determine if the layer is dry or it has inversion. +! (in either case, the cloud will be cleared out) +! + IF(.false.) THEN ! Set inversion strength flag + call BckgrndCC(nlon,nlat,nsig, & + t_bk,p_bk,q,h_bk,zh, & + cv_bk,tbk_k,z_lcl) ! out + + DO j = 1,nlat + DO i = 1,nlon + + if_cloud_exist=.false. + do k=nsig-1,2,-1 + if(cld_cover_3d(i,j,k) > 0.01_r_kind) then + cf_model_base = cv_bk(i,j,k) + t_model_base = tbk_k(i,j,k) + ht_base=h_bk(i,j,k) + if_cloud_exist=.true. + endif + enddo +! +! note, do we need to consider cloud base from background + if(if_cloud_exist) then + do k=2, nsig-1 + if(cld_cover_3d(i,j,k) > 0.01_r_kind) then + l_cf=.false. + l_inversion=.false. + t_dry_adiabat = tbk_k(i,j,2) -.0098_r_kind * (h_bk(i,j,k) - h_bk(i,j,2)) + t_inversion_strength = tbk_k(i,j,k) - t_dry_adiabat + + IF( (tbk_k(i,j,k) > t_model_base) .and. & + (tbk_k(i,j,k) > 283.15_r_kind) .and. & ! temp check + (t_inversion_strength > 4._r_kind) ) then ! delta theta chk + l_inversion = .true. ! Inversion exists + endif + IF( (cv_bk(i,j,k) < cf_model_base - 0.3_r_kind) .and. & + (h_bk(i,j,k) - ht_base >= 500._r_kind) ) THEN + l_cf = .true. ! Dry layer exists + ENDIF + if(l_inversion) then + cld_cover_3d(i,j,k) =0.0_r_kind + endif + endif ! in cloud + enddo ! k + endif ! if_cloud_exist = true + + ENDDO ! i + ENDDO ! j + + END IF ! .true. for dry-inversion check. + +END SUBROUTINE cloudCover_Surface + diff --git a/src/GSD/gsdcloud4nmmb/cloudCover_radar.f90 b/src/GSD/gsdcloud4nmmb/cloudCover_radar.f90 new file mode 100755 index 0000000000..b38419e812 --- /dev/null +++ b/src/GSD/gsdcloud4nmmb/cloudCover_radar.f90 @@ -0,0 +1,137 @@ +SUBROUTINE cloudCover_radar(mype,nlat,nlon,nsig,h_bk,zh,grid_ref, & + cld_cover_3d,cld_type_3d,wthr_type) +! +!$$$ subprogram documentation block +! . . . . +! subprogram: cloudCover_radar cloud cover analysis using radar reflectivity +! +! PRGMMR: Ming Hu ORG: GSD/AMB DATE: 2006-11-10 +! +! ABSTRACT: +! This subroutine find cloud cover using radar reflectivity +! +! PROGRAM HISTORY LOG: +! 2009-01-20 Hu Add NCO document block +! 2015-02-24 S.Liu adjust cloud cover based on reflectivity observations +! +! +! input argument list: +! mype - processor ID +! nlon - no. of lons on subdomain (buffer points on ends) +! nlat - no. of lats on subdomain (buffer points on ends) +! nsig - no. of levels +! h_bk - 3D background height +! zh - terrain +! grid_ref - radar reflectivity in analysis grid +! +! output argument list: +! cld_cover_3d- 3D cloud cover +! cld_type_3d - 3D cloud type +! wthr_type - 3D weather type +! +! USAGE: +! INPUT FILES: +! +! OUTPUT FILES: +! +! REMARKS: +! +! ATTRIBUTES: +! LANGUAGE: FORTRAN 90 +! MACHINE: Linux cluster (WJET) +! +!$$$ +! +!_____________________________________________________________________ +! + + use constants, only: rd_over_cp, h1000 + use constants, only: deg2rad, rad2deg, pi + use kinds, only: r_single,i_kind,r_kind + + implicit none + + integer(i_kind),intent(in) :: mype + integer(i_kind),intent(in) :: nlat,nlon,nsig +! +! background +! + real(r_single), intent(in) :: zh(nlon,nlat) ! terrain + real(r_single), intent(in) :: h_bk(nlon,nlat,nsig+1) ! height +! +! Observation +! + real(r_kind), intent(in) :: grid_ref(nlon,nlat,nsig) +! +! Variables for cloud analysis +! + real (r_single),intent(inout) :: cld_cover_3d(nlon,nlat,nsig) + integer(i_kind),intent(inout) :: cld_type_3d(nlon,nlat,nsig) + integer(i_kind),intent(inout) :: wthr_type(nlon,nlat) +! + REAL(r_kind) :: ref_base ! "significant" radar echo at upper levels +! + REAL(r_kind) :: cloud_base +! +!----------------------------------------------------------- +! +! threshold +! + + REAL(r_kind) :: radar_cover + PARAMETER(radar_cover=1.02) + REAL(r_kind) :: thresh_cvr ! lower radar echo threshold for cloud filling + PARAMETER (thresh_cvr = 0.9) +! +! temp. +! + INTEGER(i_kind) :: i,j,k,k1 + REAL(r_kind) :: zs_1d(nsig) + +! +!==================================================================== +! Begin +! +! ref_base = 15.0 +! set ref_base is 35.0 dbz, assuming cloud water will coexist with rain/snow +! based on discussion with Eric Aligo + ref_base = 35.0 +! +!----------------------------------------------------------------------- +! +! Essentially, this go downward to detect radar tops in time +! to search for a new cloud base +! +!----------------------------------------------------------------------- +! + + DO i = 2,nlon-1 + DO j = 2,nlat-1 + + DO k=1,nsig + zs_1d(k) = h_bk(i,j,k) + END DO + + cloud_base = 200000._r_kind +! + DO k = nsig-1,1,-1 + IF( (cld_cover_3d(i,j,k) < thresh_cvr) .and. & + (cld_cover_3d(i,j,k+1) >= thresh_cvr .and. & + cld_cover_3d(i,j,k+1) < 2.0_r_kind) ) THEN + cloud_base = 0.5_r_kind * (zs_1d(k) + zs_1d(k+1)) + END IF + END DO ! k + + + DO k = 6, nsig-1 + if(grid_ref(i,j,k) > ref_base ) then + cld_cover_3d(i,j,k)=radar_cover + endif + ENDDO ! k + + ENDDO ! i + ENDDO ! j +! + +END SUBROUTINE cloudCover_radar + diff --git a/src/GSD/gsdcloud4nmmb/cloudLWC.f90 b/src/GSD/gsdcloud4nmmb/cloudLWC.f90 new file mode 100755 index 0000000000..dd636206d1 --- /dev/null +++ b/src/GSD/gsdcloud4nmmb/cloudLWC.f90 @@ -0,0 +1,418 @@ +SUBROUTINE cloudLWC_stratiform(mype,nlat,nlon,nsig,q_bk,t_bk,p_bk, & + cld_cover_3d,cld_type_3d,wthr_type,cloudlayers_i, & + cldwater_3d,cldice_3d) +! +! find cloud liquid water content +! +!$$$ subprogram documentation block +! . . . . +! subprogram: cloudLWC_stratiform find cloud liquid water content +! +! PRGMMR: Ming Hu ORG: GSD/AMB DATE: 2006-11-20 +! +! ABSTRACT: +! This subroutine calculate liquid water content for stratiform cloud +! +! PROGRAM HISTORY LOG: +! 2009-01-20 Hu Add NCO document block +! +! +! input argument list: +! nlon - no. of lons on subdomain (buffer points on ends) +! nlat - no. of lats on subdomain (buffer points on ends) +! nsig - no. of levels +! q_bk - 3D moisture +! t_bk - 3D background potential temperature (K) +! p_bk - 3D background pressure (hPa) +! cld_cover_3d- 3D cloud cover +! cld_type_3d - 3D cloud type +! wthr_type - 3D weather type +! cloudlayers_i - 3D cloud layer index +! +! output argument list: +! cldwater_3d - 3D cloud water mixing ratio (g/kg) +! cldice_3d - 3D cloud ice mixing ratio (g/kg) +! +! USAGE: +! INPUT FILES: +! +! OUTPUT FILES: +! +! REMARKS: +! +! ATTRIBUTES: +! LANGUAGE: FORTRAN 90 +! MACHINE: Linux cluster (WJET) +! +!$$$ +! +!_____________________________________________________________________ +! + + use constants, only: rd_over_cp, h1000 + use kinds, only: r_single,i_kind, r_kind + + implicit none + + integer(i_kind),intent(in):: mype + integer(i_kind),intent(in):: nlat,nlon,nsig +! +! background +! + real(r_single),intent(in) :: t_bk(nlon,nlat,nsig) ! potential temperature + real(r_single),intent(inout) :: q_bk(nlon,nlat,nsig) ! mixing ratio (kg/kg) + real(r_single),intent(in) :: p_bk(nlon,nlat,nsig) ! pressure +! +! +! Variables for cloud analysis +! + real (r_single),intent(inout) :: cld_cover_3d(nlon,nlat,nsig) + integer(i_kind),intent(in) :: cld_type_3d(nlon,nlat,nsig) + integer(i_kind),intent(in) :: wthr_type(nlon,nlat) +! +! cloud layers +! + integer(i_kind),intent(in) :: cloudlayers_i(nlon,nlat,21) ! 5 =different layers +! 1= the number of layers +! 2,4,... bottom +! 3,5,... top +! +! cloud water and cloud ice +! + real (r_single),intent(out) :: cldwater_3d(nlon,nlat,nsig) + real (r_single),intent(out) :: cldice_3d(nlon,nlat,nsig) + real (r_single) :: cloudtmp_3d(nlon,nlat,nsig) +!----------------------------------------------------------- +! +! temp. +! + INTEGER(i_kind) :: i,j,k,ilvl,nlvl + INTEGER(i_kind) :: kb,kt,k1 + real(r_single) :: p_pa_1d(nsig), thv(nsig) + real(r_single) :: cld_base_m, cld_top_m + real(r_single) :: cld_base_qc_m, cld_top_qc_m + real(r_single) :: cloudqvis(nlon,nlat,nsig) + real(r_single) :: rh(nlon,nlat,nsig) + +! --- Key parameters +! Rh_clear_p = 0.80 RH to use when clearing cloud +! Cloud_q_qvis_rat_p= 0.10 Ratio of cloud water to water/ice + + real(r_single) Cloud_q_qvis_rat_p, cloud_q_qvis_ratio + real(r_single) auto_conver + real(r_single) cloud_def_p + real(r_single) rh_cld3_p + real(r_single) rh_clear_p + data Cloud_q_qvis_rat_p/ 0.05_r_single/ + data auto_conver /0.0002_r_single/ + data cloud_def_p /0.000001_r_single/ + data rh_cld3_p /0.98_r_single/ ! mhu, do we need to adjust this number to 0.94, WPP has PBL top set as 0.95 + data rh_clear_p /0.8_r_single/ + + real(r_kind) :: es0_p + parameter (es0_p=6.1121_r_kind) ! saturation vapor pressure (mb) + real(r_kind) SVP1,SVP2,SVP3 + data SVP1,SVP2,SVP3/es0_p,17.67_r_kind,29.65_r_kind/ + + real(r_kind) :: temp_qvis1, temp_qvis2 + data temp_qvis1, temp_qvis2 /268.15_r_kind, 263.15_r_kind/ + + REAL(r_kind) stab, stab_threshold + LOGICAL :: l_prt + INTEGER(i_kind) :: iflag_slwc + INTEGER(i_kind) :: kp3,km3 + + REAL(r_kind) :: q, Temp, tv, evs, qvs1, eis, qvi1, watwgt, qavail +! +!==================================================================== +! Begin +! + cldwater_3d=-99999.9_r_kind + cldice_3d=-99999.9_r_kind + cloudtmp_3d=-99999.9_r_kind +!----------------------------------------------------------------------- +! +! Find Cloud Layers and Computing Output Field(s) +! The procedure works column by column. +! +!----------------------------------------------------------------------- +! + rh=0.0 + DO j = 2,nlat-1 + DO i = 2,nlon-1 +! + DO k = 2,nsig-1 + p_pa_1d(k) = p_bk(i,j,k)*100.0_r_single + q = q_bk(i,j,k)/(1._r_single+q_bk(i,j,k)) ! Q = water vapor specific humidity + ! q_bk = water vapor mixing ratio + tv = t_bk(i,j,k)*(p_bk(i,j,k)/h1000)**rd_over_cp +! now, tmperature from GSI s potential temperature + Temp = tv ! temperature +! evs, eis in mb + evs = svp1*exp(SVP2*(Temp-273.15_r_kind)/(Temp-SVP3)) + qvs1 = 0.62198_r_kind*evs*100._r_kind/(p_pa_1d(k)-100._r_kind*evs) ! qvs1 is mixing ratio kg/kg, so no need next line +! qvs1 = qvs1/(1.0-qvs1) + eis = svp1 *exp(22.514_r_kind - 6.15e3_r_kind/Temp) + qvi1 = 0.62198_r_kind*eis*100._r_kind/(p_pa_1d(k)-100._r_kind*eis) ! qvi1 is mixing ratio kg/kg, so no need next line +! qvi1 = qvi1/(1.0-qvi1) +! watwgt = max(0.,min(1.,(Temp-233.15)/(263.15-233.15))) +! ph - 2/7/2012 - use ice mixing ratio only for temp < 263.15 + watwgt = max(0._r_kind,min(1._r_kind,(Temp-temp_qvis2)/& + (temp_qvis1-temp_qvis2))) + cloudtmp_3d(i,j,k)= Temp + cloudqvis(i,j,k)= (watwgt*qvs1 + (1._r_kind-watwgt)*qvi1) +! qvis(i,j,k)= (watwgt*qvs1 + (1.-watwgt)*qvi1) + rh(i,j,k) = q_bk(i,j,k)/cloudqvis(i,j,k) + enddo + enddo ! i + enddo ! j + + stab_threshold = 3._r_kind/10000._r_kind + DO j = 2,nlat-1 + DO i = 2,nlon-1 + DO k = 1,nsig + p_pa_1d(k) = p_bk(i,j,k)*100.0_r_kind + thv(k) = t_bk(i,j,k)*(1.0_r_kind + 0.6078_r_kind*q_bk(i,j,k)) + ENDDO + nlvl=cloudlayers_i(i,j,1) + if(nlvl > 0 ) then + DO ilvl = 1, nlvl ! loop through cloud layers + kb=cloudlayers_i(i,j,2*ilvl) + kt=cloudlayers_i(i,j,2*ilvl+1) + DO k = kb,kt + +! -- change these to +/- 3 vertical levels + kp3 = min(nsig,k+5) + km3 = max(1 ,k) + stab = (thv(kp3)-thv(km3))/(p_pa_1d(km3)-p_pa_1d(kp3)) + +! -- stability check. Use 2K/100 mb above 600 mb and +! 3K/100mb below (nearer sfc) + if ((stab600._r_kind) & + .or. stab<0.66_r_kind*stab_threshold ) then +! write(*,'(a,3i4,f8.3)') 'skip building cloud in stable layer',i,j,k,stab*10000.0 + cld_cover_3d(i,j,k)=-99999.0 + elseif(rh(i,j,k) < 0.40 .and. ((cloudqvis(i,j,k)-q_bk(i,j,k)) > 0.003_r_kind)) then +! write(*,'(a,3i4,2f6.2)') 'skip building cloud in too-dry layer',i,j,k,& +! rh(i,j,k),(cloudqvis(i,j,k)-q_bk(i,j,k))*1000.0 + cld_cover_3d(i,j,k)=-99999.0_r_single + else +!dk * we need to avoid adding cloud if sat_ctp is lower than 650mb +! ph - 2/7/2012 - use a temperature-dependent cloud_q_qvis_ratio +! and with 0.1 smaller condensate mixing ratio building also for temp < 263.15 + Temp = cloudtmp_3d(i,j,k) + watwgt = max(0._r_kind,min(1._r_kind,(Temp-temp_qvis2)/& + (temp_qvis1-temp_qvis2))) + cloud_q_qvis_ratio = watwgt*cloud_q_qvis_rat_p & + + (1.0-watwgt)*0.1*cloud_q_qvis_rat_p + qavail = min(0.5_r_single*auto_conver,cloud_q_qvis_ratio*cloudqvis(i,j,k)) + +! ------------------------------------------------------------------- +! - set cloud water mixing ratio - no more than 0.1 g/kg, +! which is the current autoconversion mixing ratio set in exmoisg +! according to John Brown - 14 May 99 +! ------------------------------------------------------------------- + cldwater_3d(i,j,k) = watwgt*qavail*1000.0_r_kind ! g/kg +! - set ice mixing ratio + cldice_3d(i,j,k)= (1.-watwgt)*qavail*1000.0_r_kind ! g/kg +! end if + end if + enddo ! k + enddo ! ilvl + endif ! nlvl > 1 + enddo ! i + enddo ! j + +END SUBROUTINE cloudLWC_stratiform + +SUBROUTINE cloudLWC_Cumulus(nlat,nlon,nsig,h_bk,t_bk,p_bk, & + cld_cover_3d,cld_type_3d,wthr_type,cloudlayers_i, & + cldwater_3d,cldice_3d,cloudtmp_3d) +! +! find cloud liquid water content +! +!$$$ subprogram documentation block +! . . . . +! subprogram: cloudLWC_Cumulus find cloud liquid water content for cumulus cloud +! +! PRGMMR: Ming Hu ORG: GSD/AMB DATE: 2006-11-20 +! +! ABSTRACT: +! This subroutine calculates liquid water content for cumulus cloud +! +! PROGRAM HISTORY LOG: +! 2009-01-20 Hu Add NCO document block +! +! +! input argument list: +! nlon - no. of lons on subdomain (buffer points on ends) +! nlat - no. of lats on subdomain (buffer points on ends) +! nsig - no. of levels +! h_bk - 3D height +! t_bk - 3D background potentional temperature (K) +! p_bk - 3D background pressure (hPa) +! cld_cover_3d- 3D cloud cover +! cld_type_3d - 3D cloud type +! wthr_type - 3D weather type +! cloudlayers_i - 3D cloud layer index +! +! output argument list: +! cldwater_3d - 3D cloud water mixing ratio (g/kg) +! cldice_3d - 3D cloud ice mixing ratio (g/kg) +! cloudtmp_3d - 3D cloud temperature +! +! USAGE: +! INPUT FILES: +! +! OUTPUT FILES: +! +! REMARKS: +! +! ATTRIBUTES: +! LANGUAGE: FORTRAN 90 +! MACHINE: Linux cluster (WJET) +! +!$$$ +! +!_____________________________________________________________________ +! + + use constants, only: rd_over_cp, h1000 + use kinds, only: r_single,i_kind,r_kind + + implicit none + integer(i_kind),intent(in) :: nlat,nlon,nsig +! +! surface observation +! +! +! background +! + real(r_single),intent(in) :: t_bk(nlon,nlat,nsig) ! temperature + real(r_single),intent(in) :: h_bk(nlon,nlat,nsig) ! height + real(r_single),intent(in) :: p_bk(nlon,nlat,nsig) ! pressure +! +! +! Variables for cloud analysis +! + real (r_single),intent(in) :: cld_cover_3d(nlon,nlat,nsig) + integer(i_kind),intent(in) :: cld_type_3d(nlon,nlat,nsig) + integer(i_kind),intent(in) :: wthr_type(nlon,nlat) +! +! cloud layers +! + integer(i_kind),intent(in) :: cloudlayers_i(nlon,nlat,21) ! 5 =different layers +! 1= the number of layers +! 2,4,... bottom +! 3,5,... top +! +! cloud water and cloud ice +! + real (r_single),intent(out) :: cldwater_3d(nlon,nlat,nsig) + real (r_single),intent(out) :: cldice_3d(nlon,nlat,nsig) + real (r_single),intent(out) :: cloudtmp_3d(nlon,nlat,nsig) +!----------------------------------------------------------- +! +! temp. +! + INTEGER(i_kind) :: i,j,k,ilvl,nlvl + INTEGER(i_kind) :: kb,kt,k1 + real (r_single) :: zs_1d(nsig) + real (r_single) :: cv_1d(nsig) + real (r_single) :: t_1d(nsig) + real (r_single) :: p_pa_1d(nsig) + real (r_single) :: p_mb_1d(nsig) + real (r_single) :: cld_base_m, cld_top_m + real (r_single) :: cld_base_qc_m, cld_top_qc_m + + real (r_single) :: slwc_1d(nsig) + real (r_single) :: cice_1d(nsig) + real (r_single) :: ctmp_1d(nsig) + + LOGICAL :: l_prt + INTEGER(i_kind) :: iflag_slwc +! +!==================================================================== +! Begin +! + l_prt =.false. + iflag_slwc = 11 + cldwater_3d=-99999.9_r_single + cldice_3d =-99999.9_r_single + cloudtmp_3d=-99999.9_r_single +!----------------------------------------------------------------------- +! +! Find Cloud Layers and Computing Output Field(s) +! The procedure works column by column. +! +!----------------------------------------------------------------------- +! + DO j = 2,nlat-1 + DO i = 2,nlon-1 +! + DO k = 1,nsig ! Initialize + t_1d(k) = t_bk(i,j,k)*(p_bk(i,j,k)/h1000)**rd_over_cp + zs_1d(k) = h_bk(i,j,k) + p_pa_1d(k) = p_bk(i,j,k)*100.0_r_single + p_mb_1d(k) = p_bk(i,j,k) + END DO +!----------------------------------------------------------------------- + nlvl=cloudlayers_i(i,j,1) + if(nlvl > 0 ) then + DO ilvl = 1, nlvl ! loop through cloud layers + + kb=cloudlayers_i(i,j,2*ilvl) + kt=cloudlayers_i(i,j,2*ilvl+1) + + cld_base_m = 0.5_r_single * (zs_1d(kb-1) + zs_1d(kb)) + cld_top_m = 0.5_r_single * (zs_1d(kt) + zs_1d(kt+1)) +! + IF(iflag_slwc /= 0) THEN + IF(iflag_slwc < 10) THEN ! simple adiabatc scheme + CALL get_slwc1d (nsig,cld_base_m,cld_top_m,kb,kt & + ,zs_1d,t_1d,p_pa_1d,iflag_slwc,slwc_1d) + + ELSE ! iflag_slwc > 10, new Smith-Feddes scheme + DO k1 = 1,nsig ! Initialize + slwc_1d(k1) = 0.0_r_single + cice_1d(k1) = 0.0_r_single + ctmp_1d(k1) = t_bk(i,j,k1) + END DO +! +!----------------------------------------------------------------------- +! +! QC the data going into SMF +! +!----------------------------------------------------------------------- +! + IF(cld_top_m > zs_1d(nsig-1) - 110._r_single) THEN + cld_top_qc_m = zs_1d(nsig-1) - 110._r_single + cld_base_qc_m = & + MIN(cld_base_m,cld_top_qc_m - 110._r_single) + ELSE ! normal case + cld_top_qc_m = cld_top_m + cld_base_qc_m = cld_base_m + END IF +! + CALL get_sfm_1d(nsig,cld_base_qc_m,cld_top_qc_m & + ,zs_1d,p_mb_1d,t_1d & + ,slwc_1d,cice_1d,ctmp_1d,l_prt) +! + END IF ! iflag_slwc < 10 + END IF ! iflag_slwc .ne. 0 +! + DO k1 = kb,kt ! Loop through the cloud layer + IF(iflag_slwc /= 0) THEN + IF(slwc_1d(k1) > 0._r_single) cldwater_3d(i,j,k1)=slwc_1d(k1) + IF(cice_1d(k1) > 0._r_single) cldice_3d(i,j,k1)=cice_1d(k1) + cloudtmp_3d(i,j,k1)=ctmp_1d(k1) + END IF ! iflag_slwc .ne. 0 + END DO ! k1 + + enddo ! ilvl + endif ! nlvl > 0 + + ENDDO ! i + ENDDO ! j + +END SUBROUTINE cloudLWC_Cumulus diff --git a/src/GSD/gsdcloud4nmmb/cloudLayers.f90 b/src/GSD/gsdcloud4nmmb/cloudLayers.f90 new file mode 100755 index 0000000000..ac63b99d92 --- /dev/null +++ b/src/GSD/gsdcloud4nmmb/cloudLayers.f90 @@ -0,0 +1,167 @@ +SUBROUTINE cloudLayers(nlat,nlon,nsig,h_bk,zh,cld_cover_3d,cld_type_3d, & + cloudlayers_i) +! +! +!$$$ subprogram documentation block +! . . . . +! subprogram: cloudLayers find cloud layers +! +! PRGMMR: Ming Hu ORG: GSD/AMB DATE: 2006-11-17 +! +! ABSTRACT: +! This subroutine find cloud layer based on cloud cover +! +! PROGRAM HISTORY LOG: +! 2009-01-20 Hu Add NCO document block +! +! +! input argument list: +! nlon - no. of lons on subdomain (buffer points on ends) +! nlat - no. of lats on subdomain (buffer points on ends) +! nsig - no. of levels +! h_bk - 3D background height +! zh - terrain +! cld_cover_3d- 3D cloud cover +! cld_type_3d - 3D cloud type +! +! output argument list: +! cloudlayers_i - 3D cloud layer index +! +! USAGE: +! INPUT FILES: +! +! OUTPUT FILES: +! +! REMARKS: +! +! ATTRIBUTES: +! LANGUAGE: FORTRAN 90 +! MACHINE: Linux cluster (WJET) +! +!$$$ +! +!_____________________________________________________________________ +! + + use kinds, only: r_single,i_kind + + implicit none + + integer(i_kind),intent(in) :: nlat,nlon,nsig +! +! background +! + real(r_single), intent(in) :: zh(nlon,nlat) ! terrain + real(r_single), intent(in) :: h_bk(nlon,nlat,nsig) ! height +! +! Variables for cloud analysis +! + real (r_single),intent(in) :: cld_cover_3d(nlon,nlat,nsig) + integer(i_kind),intent(in) :: cld_type_3d(nlon,nlat,nsig) +! +! output +! + integer(i_kind),intent(out):: cloudlayers_i(nlon,nlat,21) ! 5 different layers +! 1= the number of layers +! 2,4,... bottom +! 3,5,... top +! +! threshold + real (r_single) :: thresh_cvr + parameter ( thresh_cvr = 0.1 ) +!----------------------------------------------------------- +! +! temp. +! + INTEGER :: i,j,k,k1,nlvl + INTEGER :: k_top,k_base + real (r_single) :: zs_1d(nsig) + real (r_single) :: cv_1d(nsig) +! +!==================================================================== +! Begin +! + cloudlayers_i=-99999 +!----------------------------------------------------------------------- +! +! Find Cloud Layers and Computing Output Field(s) +! The procedure works column by column. +! +!----------------------------------------------------------------------- +! + + DO j = 2,nlat-1 + DO i = 2,nlon-1 +! Initialize + DO k = 1,nsig + zs_1d(k) = h_bk(i,j,k) + cv_1d(k) = cld_cover_3d(i,j,k) + END DO +! +!----------------------------------------------------------------------- +! +! Get Base and Top +! +!----------------------------------------------------------------------- +! + k=1 + nlvl=0 + DO WHILE (k <= nsig-1) + + IF((cv_1d(k+1) >= thresh_cvr .and. cv_1d(k)= thresh_cvr) ) THEN + k_base = k + 1 + + k = k + 1 + DO WHILE (cv_1d(k) >= thresh_cvr .and. k < nsig) + k_top = k +! +!----------------------------------------------------------------------- +! +! We have now defined a cloud base and top +! +!----------------------------------------------------------------------- +! + k=k+1 + enddo + k=k-1 +!----------------------------------------------------------------------- +! +! Make sure cloud base and top stay in the model domain +! +!----------------------------------------------------------------------- +! + nlvl=nlvl+2 + if(nlvl > 20 ) then + write(6,*) 'cloudLayers: Too many cloud layers in grid point:' + write(6,*) i,j + call stop2(114) + endif + cloudlayers_i(i,j,nlvl) = MIN(k_base,nsig-1) + cloudlayers_i(i,j,nlvl+1) = MIN(k_top,nsig-1) + endif +! + k=k+1 + ENDDO ! k +! + cloudlayers_i(i,j,1) = nlvl/2 + ENDDO + ENDDO +! +! +! + DO j = 2,nlat-1 + DO i = 2,nlon-1 + if(cloudlayers_i(i,j,1) > 0 ) then + do k=1,cloudlayers_i(i,j,1) + if(cloudlayers_i(i,j,k) < 0 .or. cloudlayers_i(i,j,k) > 55555) then + write(6,*) 'cloudLayers: ckeck', i,j,k, cloudlayers_i(i,j,k) + endif + enddo + endif + enddo + enddo +! + +END SUBROUTINE cloudLayers + diff --git a/src/GSD/gsdcloud4nmmb/cloudType.f90 b/src/GSD/gsdcloud4nmmb/cloudType.f90 new file mode 100755 index 0000000000..2b97e72509 --- /dev/null +++ b/src/GSD/gsdcloud4nmmb/cloudType.f90 @@ -0,0 +1,147 @@ +SUBROUTINE cloudType(nlat,nlon,nsig,h_bk,t_bk,p_bk,radar_3d, & + cld_cover_3d,cld_type_3d,wthr_type,cloudlayers_i) +! +! +!$$$ subprogram documentation block +! . . . . +! subprogram: cloudType decide cloud type +! +! PRGMMR: Ming Hu ORG: GSD/AMB DATE: 2006-11-20 +! +! ABSTRACT: +! This subroutine decide cloud type +! +! PROGRAM HISTORY LOG: +! 2009-01-20 Hu Add NCO document block +! +! input argument list: +! nlon - no. of lons on subdomain (buffer points on ends) +! nlat - no. of lats on subdomain (buffer points on ends) +! nsig - no. of levels +! h_bk - 3D background height +! t_bk - 3D background potential temperature (K) +! p_bk - 3D background pressure (hPa) +! radar_3d - 3D radar reflectivity in analysis grid (dBZ) +! +! cld_cover_3d- 3D cloud cover +! wthr_type - 3D weather type +! cloudlayers_i - 3D cloud layer index +! +! output argument list: +! cld_type_3d - 3D cloud type +! +! USAGE: +! INPUT FILES: +! +! OUTPUT FILES: +! +! REMARKS: +! +! ATTRIBUTES: +! LANGUAGE: FORTRAN 90 +! MACHINE: Linux cluster (WJET) +! +!$$$ +! +!_____________________________________________________________________ +! + + use constants, only: rd_over_cp, h1000, half + use kinds, only: r_single,i_kind,r_kind + + implicit none + integer(i_kind),INTENT(IN) :: nlat,nlon,nsig +! +! background +! + real(r_single),INTENT(IN) :: h_bk(nlon,nlat,nsig) ! height + real(r_single),INTENT(IN) :: t_bk(nlon,nlat,nsig) ! temperature + real(r_single),INTENT(IN) :: p_bk(nlon,nlat,nsig) ! pressure +! +! observation +! + real(r_kind),INTENT(IN) :: radar_3d(nlon,nlat,nsig) ! reflectivity +! +! Variables for cloud analysis +! + real (r_single), INTENT(IN) :: cld_cover_3d(nlon,nlat,nsig) + integer(i_kind), INTENT(IN) :: wthr_type(nlon,nlat) + integer(i_kind),INTENT(OUT) :: cld_type_3d(nlon,nlat,nsig) +! +! cloud layers +! + integer(i_kind), INTENT(IN) :: cloudlayers_i(nlon,nlat,21) ! 5 =different layers +! 1= the number of layers +! 2,4,... bottom +! 3,5,... top +! +!----------------------------------------------------------- +! +! temp. +! + INTEGER(i_kind) :: i,j,k,ilvl,nlvl + INTEGER(i_kind) :: itype + INTEGER(i_kind) :: kb,kt,k1 + real(r_single) :: cld_base_m, cld_top_m + + real (r_single) :: zs_1d(nsig) + real (r_single) :: dte_dz_1d(nsig) + real (r_single) :: t_1d(nsig) + real (r_single) :: p_mb_1d(nsig) +! + CHARACTER (LEN=2) :: c2_type +! +!==================================================================== +! Begin +! +!----------------------------------------------------------------------- +! +! Find Cloud Layers and Computing Output Field(s) +! The procedure works column by column. +! +!----------------------------------------------------------------------- +! + return + + DO j = 2,nlat-1 + DO i = 2,nlon-1 +! + DO k = 1,nsig ! Initialize + t_1d(k) = t_bk(i,j,k)*(p_bk(i,j,k)/h1000)**rd_over_cp !K + zs_1d(k) = h_bk(i,j,k) + p_mb_1d(k) = p_bk(i,j,k) + END DO +!----------------------------------------------------------------------- + nlvl=cloudlayers_i(i,j,1) + if(nlvl > 10 ) then + write(*,*) 'warning: too many cloud levels' + nlvl=10 + endif + if(nlvl > 0 ) then + DO ilvl = 1, nlvl ! loop through cloud layers + kb=cloudlayers_i(i,j,2*ilvl) + kt=cloudlayers_i(i,j,2*ilvl+1) + + CALL get_stability (nsig,t_1d,zs_1d,p_mb_1d & + ,kb,kt,dte_dz_1d) + + cld_base_m = half * (zs_1d(kb-1) + zs_1d(kb)) + cld_top_m = half * (zs_1d(kt) + zs_1d(kt+1)) + DO k1 = kb,kt + CALL get_cloudtype(t_1d(k1),dte_dz_1d(k1) & + ,cld_base_m,cld_top_m,itype,c2_type) +! + IF(radar_3d(i,j,k1) > 45._r_kind) THEN + itype = 10 ! CB + END IF + + cld_type_3d(i,j,k1) = itype + END DO !k1 + enddo ! ilvl + endif ! nlvl > 0 + + ENDDO ! i + ENDDO ! j + +END SUBROUTINE cloudType + diff --git a/src/GSD/gsdcloud4nmmb/cloud_saturation.f90 b/src/GSD/gsdcloud4nmmb/cloud_saturation.f90 new file mode 100755 index 0000000000..17ffe84670 --- /dev/null +++ b/src/GSD/gsdcloud4nmmb/cloud_saturation.f90 @@ -0,0 +1,315 @@ +SUBROUTINE cloud_saturation(mype,l_conserve_thetaV,i_conserve_thetaV_iternum, & + nlat,nlon,nsig,q_bk,t_bk,p_bk, & + cld_cover_3d,wthr_type, & + cldwater_3d,cldice_3d,sumqci) +! +!$$$ subprogram documentation block +! . . . . +! subprogram: cloud_saturation to ensure water vapor saturation at all cloudy grid points +! also to ensure sub saturation in clear point +! +! PRGMMR: Ming Hu ORG: GSD/AMB DATE: 2006-11-20 +! +! ABSTRACT: +! This subroutine calculate liquid water content for stratiform cloud +! +! PROGRAM HISTORY LOG: +! 2010-10-06 Hu check whole 3D mositure field and get rid of supersaturation +! 2009-01-20 Hu Add NCO document block +! +! +! input argument list: +! nlon - no. of lons on subdomain (buffer points on ends) +! nlat - no. of lats on subdomain (buffer points on ends) +! nsig - no. of levels +! q_bk - 3D moisture +! t_bk - 3D background potential temperature (K) +! p_bk - 3D background pressure (hPa) +! cldwater_3d - 3D analysis cloud water mixing ratio (g/kg) +! cldice_3d - 3D analysis cloud ice mixing ratio (g/kg) +! cld_cover_3d- 3D cloud cover +! wthr_type - 3D weather type +! l_conserve_thetaV - if .true. conserving thetaV +! i_conserve_thetaV_iternum - iteration number for conserving thetaV +! +! output argument list: +! q_bk - 3D moisture +! +! USAGE: +! INPUT FILES: +! +! OUTPUT FILES: +! +! REMARKS: +! +! ATTRIBUTES: +! LANGUAGE: FORTRAN 90 +! MACHINE: Linux cluster (WJET) +! +!$$$ +! +!_____________________________________________________________________ +! + + use constants, only: rd_over_cp, h1000,one,zero,fv + use kinds, only: r_single,i_kind, r_kind + + implicit none + + integer(i_kind),intent(in):: mype + integer(i_kind),intent(in):: nlat,nlon,nsig + logical,intent(in):: l_conserve_thetaV + integer(i_kind),intent(in):: i_conserve_thetaV_iternum +! +! background +! + real(r_single),intent(inout) :: t_bk(nlon,nlat,nsig) ! potential temperature (K) + real(r_single),intent(inout) :: q_bk(nlon,nlat,nsig) ! mixing ratio (kg/kg) + real(r_single),intent(in) :: p_bk(nlon,nlat,nsig) ! pressure (hpa) + REAL(r_kind),intent(in) :: sumqci(nlon,nlat,nsig) ! total liquid water +! +! Variables for cloud analysis +! + real (r_single),intent(in) :: cld_cover_3d(nlon,nlat,nsig) + integer(i_kind),intent(in) :: wthr_type(nlon,nlat) +! +! cloud water and cloud ice +! + real (r_single),intent(in) :: cldwater_3d(nlon,nlat,nsig) ! kg/kg + real (r_single),intent(in) :: cldice_3d(nlon,nlat,nsig) ! kg/kg +!----------------------------------------------------------- +! +! temp. +! + INTEGER(i_kind) :: i,j,k,ilvl,nlvl + INTEGER(i_kind) :: kb,kt,k1 + real(r_single) :: thv(nsig) + real(r_single) :: cloudqvis,cloudqvis2,ruc_saturation + +! --- Key parameters +! Rh_clear_p = 0.80 RH to use when clearing cloud + + real(r_single) rh_cld3_p + real(r_single) rh_clear_p + data rh_cld3_p /0.98_r_single/ ! mhu, do we need to adjust this number to 0.94, WPP has PBL top set as 0.95 + data rh_clear_p /0.8_r_single/ + + real(r_kind) :: es0_p + parameter (es0_p=6.1121_r_kind) ! saturation vapor pressure (mb) + real(r_kind) SVP1,SVP2,SVP3 + data SVP1,SVP2,SVP3/es0_p,17.67_r_kind,29.65_r_kind/ + + INTEGER(i_kind) :: kp3,km3,miter,nnn + + REAL(r_kind) :: constantTv, Temp, evs, qvs1, eis, qvi1, watwgt,Temp1 + real(r_single) :: qtemp, qinc,qtemp1 +! +!==================================================================== +! Begin +! +! + miter=i_conserve_thetaV_iternum ! iteration number for conserving Tv + + DO j = 2,nlat-1 + DO i = 2,nlon-1 + DO k = 2,nsig-1 + +!mhu p_pa_1d(k) = p_bk(i,j,k)*100.0_r_single +! qv= q_bk(i,j,k)/(one+q_bk(i,j,k)) ! qv = water vapor specific humidity +! ! q_bk = water vapor mixing ratio +! now, tmperature from GSI s potential temperature. get temperature + Temp = t_bk(i,j,k)*(p_bk(i,j,k)/h1000)**rd_over_cp + Temp1=Temp + +! now, calculate saturation +! + cloudqvis= ruc_saturation(Temp,p_bk(i,j,k)) +! +! moisture adjustment based on cloud +! +! +! check each grid point to make sure no supersaturation + q_bk(i,j,k) = min(q_bk(i,j,k), cloudqvis * 1.00_r_single) +! now, calculate constant virtual temperature + constantTv=Temp*(one + fv*q_bk(i,j,k)) +! + if(cld_cover_3d(i,j,k) > -0.0001_r_kind .and. & + cld_cover_3d(i,j,k) < 2.0_r_kind) then + if(cld_cover_3d(i,j,k) <= 0.0001_r_kind) then +! adjust RH to be below 85 percent(50%?) if +! 1) cloudyn = 0 +! 2) at least 100 mb above sfc +! 3) no precip from sfc obs +!make sure that clear volumes are no more than rh_clear_p RH. + if( (sumqci(i,j,k))>0.0_r_kind .and. & + (p_bk(i,j,1) - p_bk(i,j,k))>100._r_kind .and. & + wthr_type(i,j) <=0 ) then + if( q_bk(i,j,k) > cloudqvis * rh_clear_p) then + qtemp = cloudqvis * rh_clear_p + if(l_conserve_thetaV) then + do nnn=1,miter + Temp=constantTv/(one + fv*qtemp) + cloudqvis= ruc_saturation(Temp,p_bk(i,j,k)) + qtemp = cloudqvis * rh_clear_p + enddo + t_bk(i,j,k) = Temp*(h1000/p_bk(i,j,k))**rd_over_cp + endif + q_bk(i,j,k) = qtemp + endif + endif +!C - moisten layers above and below cloud layer + if(cld_cover_3d(i,j,k+1) > 0.6_r_kind .or. & + cld_cover_3d(i,j,k-1) > 0.6_r_kind ) then + if( cloudqvis > q_bk(i,j,k) ) then + qtemp = q_bk(i,j,k) + 0.7_r_single* (cloudqvis-q_bk(i,j,k)) + if(l_conserve_thetaV) then + do nnn=1,miter + Temp=constantTv/(one + fv*qtemp) + cloudqvis= ruc_saturation(Temp,p_bk(i,j,k)) + qtemp = q_bk(i,j,k) + 0.7_r_single* (cloudqvis-q_bk(i,j,k)) + enddo + t_bk(i,j,k) = Temp*(h1000/p_bk(i,j,k))**rd_over_cp + endif + q_bk(i,j,k)=qtemp + endif + endif +! -- If SCT/FEW present, reduce RH only down to rh_cld3_p (0.98) +! corresponding with cloudyn=3 + elseif(cld_cover_3d(i,j,k) > 0.0001_r_kind .and. & + cld_cover_3d(i,j,k) < 0.6_r_kind ) then + if( q_bk(i,j,k) > cloudqvis * rh_cld3_p) then + qtemp = cloudqvis * rh_cld3_p + if(l_conserve_thetaV) then + do nnn=1,miter + Temp=constantTv/(one + fv*qtemp) + cloudqvis= ruc_saturation(Temp,p_bk(i,j,k)) + qtemp = cloudqvis * rh_cld3_p + enddo + t_bk(i,j,k) = Temp*(h1000/p_bk(i,j,k))**rd_over_cp + endif + q_bk(i,j,k) = qtemp + endif + else ! set qv at 102%RH + if( q_bk(i,j,k) < cloudqvis * 1.02_r_single ) then + qtemp = cloudqvis * 1.02_r_single + q_bk(i,j,k) = q_bk(i,j,k)+0.5*(qtemp-q_bk(i,j,k)) +! q_bk(i,j,k) = qtemp + if(l_conserve_thetaV) then + do nnn=1,miter + Temp=constantTv/(one + fv*qtemp) + cloudqvis= ruc_saturation(Temp,p_bk(i,j,k)) + qtemp = q_bk(i,j,k)+0.5*(qtemp-q_bk(i,j,k)) +! qtemp = cloudqvis * 1.02_r_single + enddo +! t_bk(i,j,k) = Temp*(h1000/p_bk(i,j,k))**rd_over_cp + t_bk(i,j,k) = t_bk(i,j,k)+ 0.5*(Temp*(h1000/p_bk(i,j,k))**rd_over_cp-t_bk(i,j,k)) + endif +! q_bk(i,j,k) = qtemp + endif + endif +! if(abs(temp1-temp)>0)then +! write(6,*)'check temp::',temp1,temp +! end if + else ! cloud cover is missing +! Ensure saturation in all cloudy volumes. +! Since saturation has already been ensured for new cloudy areas (cld_cover_3d > 0.6) +! we now ensure saturation for all cloud 3-d points, whether cloudy from background +! (and not changed - cld_cover_3d < 0) +! If cloud cover is missing, (cldwater_3d(i,j,k)+cldice_3d(i,j,k) = sumqci(i,j,k), +! which is background cloud liquid water. + cloudqvis2 = min (cloudqvis, 0.018_r_single) ! Limit new water vapor mixing ratio + ! in cloud to 18 g/kg + if ((cldwater_3d(i,j,k)+cldice_3d(i,j,k))>1.0e-5_r_kind) & + q_bk(i,j,k) = max(cloudqvis2,q_bk(i,j,k)) + endif +! +! check each grid point to make sure no supersaturation +! +! q_bk(i,j,k) = min(q_bk(i,j,k), cloudqvis * 1.00_r_single) +! + + enddo ! k + enddo ! i + enddo ! j + +END SUBROUTINE cloud_saturation + +function ruc_saturation(Temp,pressure) +! +!$$$ subprogram documentation block +! . . . . +! subprogram: ruc_saturation calculate saturation +! +! PRGMMR: Ming Hu ORG: GSD/AMB DATE: 2011-11-28 +! +! ABSTRACT: +! This subroutine calculate saturation +! +! PROGRAM HISTORY LOG: +! 2011-11-28 Hu Initial +! +! +! input argument list: +! pressure - background pressure (hPa) +! Temp - temperature (K) +! +! output argument list: +! ruc_saturation +! +! USAGE: +! INPUT FILES: +! +! OUTPUT FILES: +! +! REMARKS: +! +! ATTRIBUTES: +! LANGUAGE: FORTRAN 90 +! MACHINE: Linux cluster (WJET) +! +!$$$ +! +!_____________________________________________________________________ + + use constants, only: rd_over_cp, h1000,one,zero + use kinds, only: r_single,i_kind, r_kind +! + implicit none + real(r_single) :: ruc_saturation + + REAL(r_kind), intent(in) :: Temp ! temperature in K + real(r_single),intent(in) :: pressure ! pressure (hpa) + + real(r_kind) :: es0_p + parameter (es0_p=6.1121_r_kind) ! saturation vapor pressure (mb) + real(r_kind) SVP1,SVP2,SVP3 + data SVP1,SVP2,SVP3/es0_p,17.67_r_kind,29.65_r_kind/ + + real(r_kind) :: temp_qvis1, temp_qvis2 + data temp_qvis1, temp_qvis2 /268.15_r_kind, 263.15_r_kind/ + + REAL(r_kind) :: evs, qvs1, eis, qvi1, watwgt +! + +! +! evs, eis in mb +! For this part, must use the water/ice saturation as f(temperature) + evs = svp1*exp(SVP2*(Temp-273.15_r_kind)/(Temp-SVP3)) + qvs1 = 0.62198_r_kind*evs/(pressure-evs) ! qvs1 is mixing ratio kg/kg + ! so no need next line +! qvs1 = qvs1/(1.0-qvs1) +! Get ice saturation and weighted ice/water saturation ready to go +! for ensuring cloud saturation below. + eis = svp1 *exp(22.514_r_kind - 6.15e3_r_kind/Temp) + qvi1 = 0.62198_r_kind*eis/(pressure-eis) ! qvi1 is mixing ratio kg/kg, + ! so no need next line +! qvi1 = qvi1/(1.0-qvi1) +! watwgt = max(0.,min(1.,(Temp-233.15)/(263.15-233.15))) +! watwgt = max(zero,min(one,(Temp-251.15_r_kind)/& +! (263.15_r_kind-251.15_r_kind))) +! ph - 2/7/2012 - use ice mixing ratio only for temp < 263.15 + watwgt = max(zero,min(one,(Temp-temp_qvis2)/& + (temp_qvis1-temp_qvis2))) + ruc_saturation= (watwgt*qvs1 + (one-watwgt)*qvi1) ! kg/kg +! +end function ruc_saturation diff --git a/src/GSD/gsdcloud4nmmb/constants.f90 b/src/GSD/gsdcloud4nmmb/constants.f90 new file mode 100755 index 0000000000..9d4263197e --- /dev/null +++ b/src/GSD/gsdcloud4nmmb/constants.f90 @@ -0,0 +1,324 @@ +module constants +!$$$ module documentation block +! . . . . +! module: constants +! prgmmr: treadon org: np23 date: 2003-09-25 +! +! abstract: This module contains the definition of various constants +! used in the gsi code +! +! program history log: +! 2003-09-25 treadon - original code +! 2004-03-02 treadon - allow global and regional constants to differ +! 2004-06-16 treadon - update documentation +! 2004-10-28 treadon - replace parameter tiny=1.e-12 with tiny_r_kind +! and tiny_single +! 2004-11-16 treadon - add huge_single, huge_r_kind parameters +! 2005-01-27 cucurull - add ione +! 2005-08-24 derber - move cg_term to constants from qcmod +! 2006-03-07 treadon - add rd_over_cp_mass +! 2006-05-18 treadon - add huge_i_kind +! 2006-06-06 su - add var-qc wgtlim, change value to 0.25 (ECMWF) +! 2006-07-28 derber - add r1000 +! 2007-03-20 rancic - add r3600 +! 2009-02-05 cucurull - modify refractive indexes for gpsro data +! +! Subroutines Included: +! sub init_constants_derived - compute derived constants +! sub init_constants - set regional/global constants +! +! Variable Definitions: +! see below +! +! attributes: +! language: f90 +! machine: ibm RS/6000 SP +! +!$$$ end documentation block + + use kinds, only: r_single,r_kind,i_kind,r_quad,i_long + implicit none + +! set default as private + private +! set subroutines as public + public :: init_constants_derived + public :: init_constants +! set passed variables to public + public :: one,two,ione,half,zero,izero,deg2rad,pi,three,quarter,one_tenth + public :: rad2deg,zero_quad,r3600,r1000,r60inv,five,four,rd_over_cp,grav + public :: rd,rozcon,rearth_equator,zero_single,tiny_r_kind,tiny_single + public :: omega,rcp,rearth,fv,h300,cp,cg_term,tpwcon,xb,ttp,psatk,xa,tmix + public :: xai,xbi,psat,eps,omeps,wgtlim,one_quad,epsq,climit,epsm1,hvap + public :: hsub,cclimit,el2orc,elocp,h1000,cpr,pcpeff0,pcpeff2,delta,pcpeff1 + public :: factor1,c0,pcpeff3,factor2,dx_inv,dx_min,rhcbot,rhctop,hfus,ke2 + public :: rrow,cmr,cws,r60,huge_i_kind,huge_r_kind,t0c,rd_over_cp_mass + public :: somigliana,grav_equator,grav_ratio,flattening,semi_major_axis + public :: n_b,n_a,eccentricity,huge_single,constoz,g_over_rd,amsua_clw_d2 + public :: amsua_clw_d1,n_c,rd_over_g,zero_ilong + +! Declare derived constants + integer(i_kind):: huge_i_kind + real(r_single):: tiny_single, huge_single + real(r_kind):: xai, xa, xbi, xb, dldt, rozcon,ozcon,fv, tpwcon,eps, rd_over_g + real(r_kind):: el2orc, g_over_rd, rd_over_cp, cpr, omeps, epsm1, factor2 + real(r_kind):: factor1, huge_r_kind, tiny_r_kind, deg2rad, pi, rad2deg, cg_term + real(r_kind):: eccentricity_linear, cv, rv, rd_over_cp_mass, cliq, rd, cp_mass + real(r_kind):: eccentricity, grav, rearth, r60inv + + +! Define constants common to global and regional applications + real(r_kind),parameter:: rearth_equator= 6.37813662e6_r_kind ! equatorial earth radius (m) + real(r_kind),parameter:: omega = 7.2921e-5_r_kind ! angular velocity of earth (1/s) + real(r_kind),parameter:: cp = 1.0046e+3_r_kind ! specific heat of air @pressure (J/kg/K) + real(r_kind),parameter:: cvap = 1.8460e+3_r_kind ! specific heat of h2o vapor (J/kg/K) + real(r_kind),parameter:: csol = 2.1060e+3_r_kind ! specific heat of solid h2o (ice)(J/kg/K) + real(r_kind),parameter:: hvap = 2.5000e+6_r_kind ! latent heat of h2o condensation (J/kg) + real(r_kind),parameter:: hfus = 3.3358e+5_r_kind ! latent heat of h2o fusion (J/kg) + real(r_kind),parameter:: psat = 6.1078e+2_r_kind ! pressure at h2o triple point (Pa) + real(r_kind),parameter:: t0c = 2.7315e+2_r_kind ! temperature at zero celsius (K) + real(r_kind),parameter:: ttp = 2.7316e+2_r_kind ! temperature at h2o triple point (K) + real(r_kind),parameter:: jcal = 4.1855e+0_r_kind ! joules per calorie () + real(r_kind),parameter:: stndrd_atmos_ps = 1013.25e2_r_kind ! 1976 US standard atmosphere ps (Pa) + +! Numeric constants + integer(i_kind),parameter:: izero = 0_i_kind + integer(i_kind),parameter:: ione = 1_i_kind + + integer(i_long),parameter:: zero_ilong = 0_i_long + + real(r_single),parameter:: zero_single= 0.0_r_single + + real(r_kind),parameter:: zero = 0.0_r_kind + real(r_kind),parameter:: one_tenth = 0.10_r_kind + real(r_kind),parameter:: quarter = 0.25_r_kind + real(r_kind),parameter:: one = 1.0_r_kind + real(r_kind),parameter:: two = 2.0_r_kind + real(r_kind),parameter:: three = 3.0_r_kind + real(r_kind),parameter:: four = 4.0_r_kind + real(r_kind),parameter:: five = 5.0_r_kind + real(r_kind),parameter:: r60 = 60._r_kind + real(r_kind),parameter:: r1000 = 1000.0_r_kind + real(r_kind),parameter:: r3600 = 3600.0_r_kind + + real(r_quad),parameter:: zero_quad = 0.0_r_quad + real(r_quad),parameter:: one_quad = 1.0_r_quad + + +! Constants for gps refractivity (Bevis et al 1994) + real(r_kind),parameter:: n_a = 77.60_r_kind ! K/mb + real(r_kind),parameter:: n_b = 3.739e+5_r_kind ! K^2/mb + real(r_kind),parameter:: n_c = 70.4_r_kind ! K/mb + +! Parameters below from WGS-84 model software inside GPS receivers. + real(r_kind),parameter:: semi_major_axis = 6378.1370e3_r_kind ! (m) + real(r_kind),parameter:: semi_minor_axis = 6356.7523142e3_r_kind ! (m) + real(r_kind),parameter:: grav_polar = 9.8321849378_r_kind ! (m/s2) + real(r_kind),parameter:: grav_equator = 9.7803253359_r_kind ! (m/s2) + real(r_kind),parameter:: earth_omega = 7.292115e-5_r_kind ! (rad/s) + real(r_kind),parameter:: grav_constant = 3.986004418e14_r_kind ! (m3/s2) + +! Derived geophysical constants + real(r_kind),parameter:: flattening = (semi_major_axis-semi_minor_axis)/semi_major_axis + real(r_kind),parameter:: somigliana = & + (semi_minor_axis/semi_major_axis) * (grav_polar/grav_equator) - one + real(r_kind),parameter:: grav_ratio = (earth_omega*earth_omega * & + semi_major_axis*semi_major_axis * semi_minor_axis) / grav_constant + +! Derived thermodynamic constants + real(r_kind),parameter:: dldti = cvap-csol + real(r_kind),parameter:: hsub = hvap+hfus + real(r_kind),parameter:: psatk = psat*0.001_r_kind + real(r_kind),parameter:: tmix = ttp-20._r_kind + real(r_kind),parameter:: elocp = hvap/cp + real(r_kind),parameter:: rcp = one/cp + +! Constants used in GFS moist physics + real(r_kind),parameter:: h300 = 300._r_kind + real(r_kind),parameter:: half = 0.5_r_kind + real(r_kind),parameter:: cclimit = 0.001_r_kind + real(r_kind),parameter:: climit = 1.e-20_r_kind + real(r_kind),parameter:: epsq = 2.e-12_r_kind + real(r_kind),parameter:: h1000 = r1000 + real(r_kind),parameter:: rhcbot=0.85_r_kind + real(r_kind),parameter:: rhctop=0.85_r_kind + real(r_kind),parameter:: dx_max=-8.8818363_r_kind + real(r_kind),parameter:: dx_min=-5.2574954_r_kind + real(r_kind),parameter:: dx_inv=one/(dx_max-dx_min) + real(r_kind),parameter:: c0=0.002_r_kind + real(r_kind),parameter:: delta=0.6077338_r_kind + real(r_kind),parameter:: pcpeff0=1.591_r_kind + real(r_kind),parameter:: pcpeff1=-0.639_r_kind + real(r_kind),parameter:: pcpeff2=0.0953_r_kind + real(r_kind),parameter:: pcpeff3=-0.00496_r_kind + real(r_kind),parameter:: cmr = one/0.0003_r_kind + real(r_kind),parameter:: cws = 0.025_r_kind + real(r_kind),parameter:: ke2 = 0.00002_r_kind + real(r_kind),parameter:: row = r1000 + real(r_kind),parameter:: rrow = one/row + +! Constant used to process ozone + real(r_kind),parameter:: constoz = 604229.0_r_kind + +! Constants used in cloud liquid water correction for AMSU-A +! brightness temperatures + real(r_kind),parameter:: amsua_clw_d1 = 0.754_r_kind + real(r_kind),parameter:: amsua_clw_d2 = -2.265_r_kind + +! Constants used for variational qc + real(r_kind),parameter:: wgtlim = quarter ! Cutoff weight for concluding that obs has been + ! rejected by nonlinear qc. This limit is arbitrary + ! and DOES NOT affect nonlinear qc. It only affects + ! the printout which "counts" the number of obs that + ! "fail" nonlinear qc. Observations counted as failing + ! nonlinear qc are still assimilated. Their weight + ! relative to other observations is reduced. Changing + ! wgtlim does not alter the analysis, only + ! the nonlinear qc data "count" + +contains + + subroutine init_constants_derived +!$$$ subprogram documentation block +! . . . . +! subprogram: init_constants_derived set derived constants +! prgmmr: treadon org: np23 date: 2004-12-02 +! +! abstract: This routine sets derived constants +! +! program history log: +! 2004-12-02 treadon +! 2005-03-03 treadon - add implicit none +! 2008-06-04 safford - rm unused vars +! +! input argument list: +! +! output argument list: +! +! attributes: +! language: f90 +! machine: ibm rs/6000 sp +! +!$$$ + implicit none + +! Trigonometric constants + pi = acos(-one) + deg2rad = pi/180.0_r_kind + rad2deg = one/deg2rad + cg_term = (sqrt(two*pi))/two ! constant for variational qc + tiny_r_kind = tiny(zero) + huge_r_kind = huge(zero) + tiny_single = tiny(zero_single) + huge_single = huge(zero_single) + huge_i_kind = huge(izero) + r60inv=one/r60 + +! Geophysical parameters used in conversion of geopotential to +! geometric height + eccentricity_linear = sqrt(semi_major_axis**2 - semi_minor_axis**2) + eccentricity = eccentricity_linear / semi_major_axis + + return + end subroutine init_constants_derived + + subroutine init_constants(regional) +!$$$ subprogram documentation block +! . . . . +! subprogram: init_constants set regional or global constants +! prgmmr: treadon org: np23 date: 2004-03-02 +! +! abstract: This routine sets constants specific to regional or global +! applications of the gsi +! +! program history log: +! 2004-03-02 treadon +! 2004-06-16 treadon, documentation +! 2004-10-28 treadon - use intrinsic TINY function to set value +! for smallest machine representable positive +! number +! 2004-12-03 treadon - move derived constants to init_constants_derived +! 2005-03-03 treadon - add implicit none +! +! input argument list: +! regional - if .true., set regional gsi constants; +! otherwise (.false.), use global constants +! +! output argument list: +! +! attributes: +! language: f90 +! machine: ibm rs/6000 sp +! +!$$$ + implicit none + + logical,intent(in ) :: regional + + real(r_kind) reradius,g,r_d,r_v,cliq_wrf + +! Define regional constants here + if (regional) then + +! Name given to WRF constants + reradius = one/6370.e03_r_kind + g = 9.81_r_kind + r_d = 287.04_r_kind + r_v = 461.6_r_kind + cliq_wrf = 4190.0_r_kind + cp_mass = 1004.67_r_kind + +! Transfer WRF constants into unified GSI constants + rearth = one/reradius + grav = g + rd = r_d + rv = r_v + cv = cp-r_d + cliq = cliq_wrf + rd_over_cp_mass = rd / cp_mass + +! Define global constants here + else + rearth = 6.3712e+6_r_kind + grav = 9.80665e+0_r_kind + rd = 2.8705e+2_r_kind + rv = 4.6150e+2_r_kind + cv = 7.1760e+2_r_kind + cliq = 4.1855e+3_r_kind + cp_mass= zero + rd_over_cp_mass = zero + endif + + +! Now define derived constants which depend on constants +! which differ between global and regional applications. + +! Constants related to ozone assimilation + ozcon = grav*21.4e-9_r_kind + rozcon= one/ozcon + +! Constant used in vertical integral for precipitable water + tpwcon = 100.0_r_kind/grav + +! Derived atmospheric constants + fv = rv/rd-one ! used in virtual temperature equation + dldt = cvap-cliq + xa = -(dldt/rv) + xai = -(dldti/rv) + xb = xa+hvap/(rv*ttp) + xbi = xai+hsub/(rv*ttp) + eps = rd/rv + epsm1 = rd/rv-one + omeps = one-eps + factor1 = (cvap-cliq)/rv + factor2 = hvap/rv-factor1*t0c + cpr = cp*rd + el2orc = hvap*hvap/(rv*cp) + rd_over_g = rd/grav + rd_over_cp = rd/cp + g_over_rd = grav/rd + + return + end subroutine init_constants + +end module constants diff --git a/src/GSD/gsdcloud4nmmb/convert_lghtn2ref.f90 b/src/GSD/gsdcloud4nmmb/convert_lghtn2ref.f90 new file mode 100755 index 0000000000..2c1eb065d9 --- /dev/null +++ b/src/GSD/gsdcloud4nmmb/convert_lghtn2ref.f90 @@ -0,0 +1,245 @@ +SUBROUTINE convert_lghtn2ref(mype,nlon,nlat,nsig,ref_mos_3d,lightning, & + lghtn_region_mask,lghtn_ref_bias,h_bk) +! +!$$$ subprogram documentation block +! . . . . +! subprogram: convert_lghtn2ref convert lightning stroke rate to radar reflectivity +! +! PRGMMR: Ming Hu ORG: GSD/AMB DATE: 2012-10-16 +! +! ABSTRACT: +! This subroutine converts lightning flash density to radar reflectivity based +! on Jing's statistic analysis + +! PROGRAM HISTORY LOG: +! 2015-10-06 s.Liu Add NCO document block +! 2015-10-06 s.liu -add new algorithm from Jing Her to retrieve REF from lghtn for NMMB +! 2015-10-26 s.liu -reduce estimated reflectivity, appears the current +! algorithm overestimated ref (5dBz) +! 2016-05-05 s.liu -add region adjustment parameter. +! 2016-05-08 s.liu -add parameter to control the layers for adjustment based on region. + +! +! +! +! input argument list: +! mype - processor ID +! nlon - no. of lons on subdomain (buffer points on ends) +! nlat - no. of lats on subdomain (buffer points on ends) +! nsig - no. of levels +! ref_mos_3d - 3D reflectivity in analysis grid +! lightning - 2D lightning flash rate in analysis grid +! h_bk - 3D height +! +! output argument list: +! ref_mos_3d - 3D reflectivity in analysis grid +! +! USAGE: +! INPUT FILES: +! +! OUTPUT FILES: +! +! REMARKS: +! +! ATTRIBUTES: +! LANGUAGE: FORTRAN 90 +! MACHINE: Linux cluster (WJET) +! +!$$$ +! +!_____________________________________________________________________ +! + use kinds, only: r_kind,i_kind,r_single + implicit none + + INTEGER(i_kind),intent(in) :: mype + INTEGER(i_kind),intent(in) :: nlon,nlat,nsig + real(r_single), intent(in) :: h_bk(nlon,nlat,nsig) ! height + real(r_kind), intent(inout) :: lightning(nlon,nlat) + real(r_kind), intent(inout):: ref_mos_3d(nlon,nlat,nsig) ! reflectivity in grid +! +! local +! + real(r_kind) :: dbz_lightning(nlon,nlat) + real(r_kind) :: lghtn_region_mask(nlon,nlat) + real(r_kind) :: lghtn_ref_bias(nlon,nlat) + + real(r_kind) :: table_lghtn2ref_winter(30) ! table content the map from lightning strakes + ! to maximum reflectivity + DATA table_lghtn2ref_winter/ & + 32.81,33.98,34.93,36.26,36.72,37.07,37.93,38.79,39.65,40.10, & + 40.42,41.42,41.90,42.04,42.19,42.45,42.90,43.20,43.50,43.80, & + 44.10,44.66,44.84,45.56,45.64,45.80,45.95,46.11,46.32,46.50/ + + real(r_kind) :: table_lghtn2ref_summer(30) ! table content the map from lightning strakes + ! to maximum reflectivity + DATA table_lghtn2ref_summer/ & + 30.13,31.61,32.78,33.86,34.68,35.34,36.13,36.15,37.02,37.04, & + 37.74,38.00,38.56,38.85,39.10,39.37,39.78,39.98,40.64,41.33, & + 41.50,41.65,41.85,42.08,42.77,43.03,43.26,43.53,43.74,43.73/ + + integer(i_kind) :: maxlvl + parameter (maxlvl=31) + real(r_kind) :: newlvlAll(maxlvl) ! vertical levels of reflectivity statistic profile + DATA newlvlAll/0.2, 0.5, 0.75, 1, 1.25, 1.5, 1.75, 2, 2.25, 2.5, 2.75, & + 3, 3.5, 4, 4.5, 5, 5.5, 6, 6.5, 7, 7.5, 8, 8.5, & + 9, 10, 11, 12, 13, 14, 15, 16/ + + real(r_kind) :: refprofile_winter(maxlvl,4) ! statistic reflectivity profile used to + ! retrieve vertical ref based on lightning +! max reflectivity 30-35 dbz + DATA refprofile_winter(:,1) / & + 0.966,0.958,0.977,0.989,0.998,1.000,0.997,0.992,0.981,0.962, & + 0.933,0.898,0.826,0.752,0.687,0.626,0.578,0.547,0.522,0.526, & + 0.519,0.501,0.482,0.464,0.437,0.430,0.454,0.539,0.662,0.742, & + 0.793/ +! max reflectivity 35-40 dbz + DATA refprofile_winter(:,2) / & + 0.947,0.953,0.980,0.994,1.000,0.996,0.987,0.974,0.956,0.928, & + 0.891,0.848,0.761,0.679,0.613,0.559,0.522,0.491,0.473,0.462, & + 0.451,0.433,0.415,0.403,0.382,0.380,0.406,0.482,0.603,0.707, & + 0.723/ +! max reflectivity 40-45 dbz + DATA refprofile_winter(:,3) / & + 0.937,0.955,0.986,1.000,0.997,0.995,0.988,0.978,0.957,0.920, & + 0.871,0.824,0.735,0.654,0.584,0.518,0.465,0.442,0.435,0.412, & + 0.398,0.385,0.376,0.360,0.340,0.350,0.377,0.446,0.551,0.625, & + 0.656/ +! max reflectivity 45-50 dbz + DATA refprofile_winter(:,4) / & + 0.900,0.949,0.982,0.995,1.000,0.998,0.983,0.954,0.914,0.874, & + 0.834,0.793,0.721,0.664,0.612,0.565,0.530,0.496,0.460,0.431, & + 0.402,0.383,0.370,0.354,0.335,0.321,0.347,0.342,0.441,0.510, & + 0.548/ + + real(r_kind) :: refprofile_summer(maxlvl,4) ! statistic reflectivity profile used to + ! retrieve vertical ref based on lightning +! max reflectivity 30-35 dbz + DATA refprofile_summer(:,1) / & + 0.870,0.885,0.914,0.931,0.943,0.954,0.967,0.975,0.982,0.989, & + 0.995,1.000,0.998,0.973,0.918,0.850,0.791,0.735,0.690,0.657, & + 0.625,0.596,0.569,0.544,0.510,0.479,0.461,0.460,0.477,0.522, & + 0.570/ +! max reflectivity 35-40 dbz + DATA refprofile_summer(:,2) / & + 0.871,0.895,0.924,0.948,0.961,0.971,0.978,0.983,0.988,0.992, & + 0.997,1.000,0.995,0.966,0.913,0.848,0.781,0.719,0.660,0.611, & + 0.576,0.542,0.523,0.513,0.481,0.448,0.416,0.402,0.417,0.448, & + 0.491/ +! max reflectivity 40-45 dbz + DATA refprofile_summer(:,3) / & + 0.875,0.895,0.914,0.936,0.942,0.951,0.964,0.979,0.990,0.998, & + 1.000,0.992,0.961,0.905,0.834,0.772,0.722,0.666,0.618,0.579, & + 0.545,0.518,0.509,0.483,0.419,0.398,0.392,0.403,0.423,0.480, & + 0.440/ +! max reflectivity 45-50 dbz + DATA refprofile_summer(:,4) / & + 0.926,0.920,0.948,0.975,0.988,0.989,0.995,0.997,1.000,1.000, & + 0.997,0.991,0.970,0.939,0.887,0.833,0.788,0.741,0.694,0.655, & + 0.611,0.571,0.551,0.537,0.507,0.470,0.432,0.410,0.420,0.405, & + 0.410/ + + INTEGER(i_kind) :: season ! 1= summer, 2=winter + INTEGER(i_kind) :: num_lightning + INTEGER(i_kind) :: i,j, k2, k, mref + REAL(r_kind) :: heightGSI,upref,downref,wght + INTEGER(i_kind) :: ilvl,numref + REAL(r_kind) :: lowest,highest,tempref, tempprofile(maxlvl) + real(r_kind) :: profile_wgt + + +! +! map lightning strokes to maximum reflectiivty +! +!* lghtn_region_mask=1.0 outside of radar coverage + Do j=2,nlat-1 + Do i=2,nlon-1 + if(lghtn_region_mask(i,j)==0.0) then + lghtn_ref_bias(i,j)=lghtn_ref_bias(i,j)+16.0 + else + lghtn_ref_bias(i,j)=lghtn_ref_bias(i,j)+8.0 + end if + End do + End do + + season=1 + dbz_lightning = -9999.0_r_kind + DO j=2,nlat-1 + DO i=2,nlon-1 + if(lightning(i,j) > 1.0_r_kind ) then + num_lightning = max(1,min(30,int(lightning(i,j)))) + if(season== 2 ) then + dbz_lightning(i,j) = & + 7.62*log10(lightning(i,j))+30.0-lghtn_ref_bias(i,j) + else if(season== 1 ) then + dbz_lightning(i,j) = & + 7.62*log10(lightning(i,j))+30.0-lghtn_ref_bias(i,j) + endif + endif + ENDDO + ENDDO + + lightning = -999.0 + DO j=2,nlat-1 + DO i=2,nlon-1 + lightning(i,j) = dbz_lightning(i,j) + ENDDO + ENDDO + +! +! vertical reflectivity distribution +! + DO k=1,maxlvl + newlvlAll(k)=newlvlAll(k)*1000.0_r_kind + ENDDO + +! ref_mos_3d=-9999.0 + DO j=2,nlat-1 + DO i=2,nlon-1 + if( dbz_lightning(i,j) > 30 ) then + mref = min(4,(int((dbz_lightning(i,j) - 30.0_r_kind)/5.0_r_kind) + 1 )) + if(season== 2 ) then + DO k=1,maxlvl + if(lghtn_region_mask(i,j)==0.0.and.refprofile_winter(k,mref)<0.995) then + profile_wgt=0.0 + else if(lghtn_region_mask(i,j)==1.0.and.refprofile_winter(k,mref)<0.993) then + profile_wgt=0.0 + else + profile_wgt=refprofile_winter(k,mref) + end if + tempprofile(k)=profile_wgt*dbz_lightning(i,j) + enddo + lowest=newlvlAll(2) + highest=7000.0_r_kind + else if(season== 1 ) then + DO k=1,maxlvl + if(lghtn_region_mask(i,j)==0.0.and.refprofile_summer(k,mref)<0.995) then + profile_wgt=0.0 + else if(lghtn_region_mask(i,j)==1.0.and.refprofile_summer(k,mref)<0.993) then + profile_wgt=0.0 + else + profile_wgt=refprofile_summer(k,mref) + end if + tempprofile(k)=profile_wgt*dbz_lightning(i,j) + enddo + lowest=newlvlAll(3) + highest=12000.0_r_kind + endif + DO k2=1,nsig + heightGSI=h_bk(i,j,k2) + if(heightGSI >= lowest .and. heightGSI < highest) then ! lower 12km ? + do k=1,maxlvl-1 + if( heightGSI >=newlvlAll(k) .and. heightGSI < newlvlAll(k+1) ) ilvl=k + enddo + upref=tempprofile(ilvl+1) + downref=tempprofile(ilvl) + wght=(heightGSI-newlvlAll(ilvl))/(newlvlAll(ilvl+1)-newlvlAll(ilvl)) + tempref=(1-wght)*downref + wght*upref + ref_mos_3d(i,j,k2) = max(ref_mos_3d(i,j,k2),tempref) + endif + ENDDO + endif + ENDDO + ENDDO + +END SUBROUTINE convert_lghtn2ref diff --git a/src/GSD/gsdcloud4nmmb/convert_lghtn2ref_nmmb.f90 b/src/GSD/gsdcloud4nmmb/convert_lghtn2ref_nmmb.f90 new file mode 100755 index 0000000000..4d44226dae --- /dev/null +++ b/src/GSD/gsdcloud4nmmb/convert_lghtn2ref_nmmb.f90 @@ -0,0 +1,211 @@ +SUBROUTINE convert_lghtn2ref_nmmb(mype,nlon,nlat,nsig,ref_mos_3d,lightning,h_bk) +! +!$$$ subprogram documentation block +! . . . . +! subprogram: convert_lghtn2ref convert lightning stroke rate to radar reflectivity +! +! PRGMMR: Ming Hu ORG: GSD/AMB DATE: 2012-10-16 +! +! ABSTRACT: +! This subroutine converts lightning flash density to radar reflectivity based +! on Jing's statistic analysis + +! PROGRAM HISTORY LOG: +! 2015-10-06 S.Liu Add NCO document block +! 2015-10-06 s.liu -add new algorithm from Jing Her to retrieve REF from lghtn for NMMB +! 2015-10-26 s.liu -reduce estimated reflectivity, appears the current +! algorithm overestimated ref (5dBz) + +! +! +! +! input argument list: +! mype - processor ID +! nlon - no. of lons on subdomain (buffer points on ends) +! nlat - no. of lats on subdomain (buffer points on ends) +! nsig - no. of levels +! ref_mos_3d - 3D reflectivity in analysis grid +! lightning - 2D lightning flash rate in analysis grid +! h_bk - 3D height +! +! output argument list: +! ref_mos_3d - 3D reflectivity in analysis grid +! +! USAGE: +! INPUT FILES: +! +! OUTPUT FILES: +! +! REMARKS: +! +! ATTRIBUTES: +! LANGUAGE: FORTRAN 90 +! MACHINE: Linux cluster (WJET) +! +!$$$ +! +!_____________________________________________________________________ +! + use kinds, only: r_kind,i_kind,r_single + implicit none + + INTEGER(i_kind),intent(in) :: mype + INTEGER(i_kind),intent(in) :: nlon,nlat,nsig + real(r_single), intent(in) :: h_bk(nlon,nlat,nsig) ! height + real(r_kind), intent(inout) :: lightning(nlon,nlat) + real(r_kind), intent(inout):: ref_mos_3d(nlon,nlat,nsig) ! reflectivity in grid +! +! local +! + real(r_kind) :: dbz_lightning(nlon,nlat) + real(r_kind) :: table_lghtn2ref_winter(30) ! table content the map from lightning strakes + ! to maximum reflectivity + DATA table_lghtn2ref_winter/ & + 32.81,33.98,34.93,36.26,36.72,37.07,37.93,38.79,39.65,40.10, & + 40.42,41.42,41.90,42.04,42.19,42.45,42.90,43.20,43.50,43.80, & + 44.10,44.66,44.84,45.56,45.64,45.80,45.95,46.11,46.32,46.50/ + + real(r_kind) :: table_lghtn2ref_summer(30) ! table content the map from lightning strakes + ! to maximum reflectivity + DATA table_lghtn2ref_summer/ & + 30.13,31.61,32.78,33.86,34.68,35.34,36.13,36.15,37.02,37.04, & + 37.74,38.00,38.56,38.85,39.10,39.37,39.78,39.98,40.64,41.33, & + 41.50,41.65,41.85,42.08,42.77,43.03,43.26,43.53,43.74,43.73/ + + integer(i_kind) :: maxlvl + parameter (maxlvl=31) + real(r_kind) :: newlvlAll(maxlvl) ! vertical levels of reflectivity statistic profile + DATA newlvlAll/0.2, 0.5, 0.75, 1, 1.25, 1.5, 1.75, 2, 2.25, 2.5, 2.75, & + 3, 3.5, 4, 4.5, 5, 5.5, 6, 6.5, 7, 7.5, 8, 8.5, & + 9, 10, 11, 12, 13, 14, 15, 16/ + + real(r_kind) :: refprofile_winter(maxlvl,4) ! statistic reflectivity profile used to + ! retrieve vertical ref based on lightning +! max reflectivity 30-35 dbz + DATA refprofile_winter(:,1) / & + 0.966,0.958,0.977,0.989,0.998,1.000,0.997,0.992,0.981,0.962, & + 0.933,0.898,0.826,0.752,0.687,0.626,0.578,0.547,0.522,0.526, & + 0.519,0.501,0.482,0.464,0.437,0.430,0.454,0.539,0.662,0.742, & + 0.793/ +! max reflectivity 35-40 dbz + DATA refprofile_winter(:,2) / & + 0.947,0.953,0.980,0.994,1.000,0.996,0.987,0.974,0.956,0.928, & + 0.891,0.848,0.761,0.679,0.613,0.559,0.522,0.491,0.473,0.462, & + 0.451,0.433,0.415,0.403,0.382,0.380,0.406,0.482,0.603,0.707, & + 0.723/ +! max reflectivity 40-45 dbz + DATA refprofile_winter(:,3) / & + 0.937,0.955,0.986,1.000,0.997,0.995,0.988,0.978,0.957,0.920, & + 0.871,0.824,0.735,0.654,0.584,0.518,0.465,0.442,0.435,0.412, & + 0.398,0.385,0.376,0.360,0.340,0.350,0.377,0.446,0.551,0.625, & + 0.656/ +! max reflectivity 45-50 dbz + DATA refprofile_winter(:,4) / & + 0.900,0.949,0.982,0.995,1.000,0.998,0.983,0.954,0.914,0.874, & + 0.834,0.793,0.721,0.664,0.612,0.565,0.530,0.496,0.460,0.431, & + 0.402,0.383,0.370,0.354,0.335,0.321,0.347,0.342,0.441,0.510, & + 0.548/ + + real(r_kind) :: refprofile_summer(maxlvl,4) ! statistic reflectivity profile used to + ! retrieve vertical ref based on lightning +! max reflectivity 30-35 dbz + DATA refprofile_summer(:,1) / & + 0.870,0.885,0.914,0.931,0.943,0.954,0.967,0.975,0.982,0.989, & + 0.995,1.000,0.998,0.973,0.918,0.850,0.791,0.735,0.690,0.657, & + 0.625,0.596,0.569,0.544,0.510,0.479,0.461,0.460,0.477,0.522, & + 0.570/ +! max reflectivity 35-40 dbz + DATA refprofile_summer(:,2) / & + 0.871,0.895,0.924,0.948,0.961,0.971,0.978,0.983,0.988,0.992, & + 0.997,1.000,0.995,0.966,0.913,0.848,0.781,0.719,0.660,0.611, & + 0.576,0.542,0.523,0.513,0.481,0.448,0.416,0.402,0.417,0.448, & + 0.491/ +! max reflectivity 40-45 dbz + DATA refprofile_summer(:,3) / & + 0.875,0.895,0.914,0.936,0.942,0.951,0.964,0.979,0.990,0.998, & + 1.000,0.992,0.961,0.905,0.834,0.772,0.722,0.666,0.618,0.579, & + 0.545,0.518,0.509,0.483,0.419,0.398,0.392,0.403,0.423,0.480, & + 0.440/ +! max reflectivity 45-50 dbz + DATA refprofile_summer(:,4) / & + 0.926,0.920,0.948,0.975,0.988,0.989,0.995,0.997,1.000,1.000, & + 0.997,0.991,0.970,0.939,0.887,0.833,0.788,0.741,0.694,0.655, & + 0.611,0.571,0.551,0.537,0.507,0.470,0.432,0.410,0.420,0.405, & + 0.410/ + + INTEGER(i_kind) :: season ! 1= summer, 2=winter + INTEGER(i_kind) :: num_lightning + INTEGER(i_kind) :: i,j, k2, k, mref + REAL(r_kind) :: heightGSI,upref,downref,wght + INTEGER(i_kind) :: ilvl,numref + REAL(r_kind) :: lowest,highest,tempref, tempprofile(maxlvl) + + +! +! map lightning strokes to maximum reflectiivty +! + season=1 + dbz_lightning = -9999.0_r_kind + DO j=2,nlat-1 + DO i=2,nlon-1 + if(lightning(i,j) > 1.0_r_kind ) then + num_lightning = max(1,min(30,int(lightning(i,j)))) + if(season== 2 ) then + dbz_lightning(i,j) = 7.62*log10(lightning(i,j))+30.0 + else if(season== 1 ) then + dbz_lightning(i,j) = 7.62*log10(lightning(i,j))+30.0 + endif + endif + ENDDO + ENDDO + + lightning = -999.0 + DO j=2,nlat-1 + DO i=2,nlon-1 + lightning(i,j) = dbz_lightning(i,j) + ENDDO + ENDDO + +! +! vertical reflectivity distribution +! + DO k=1,maxlvl + newlvlAll(k)=newlvlAll(k)*1000.0_r_kind + ENDDO + +! ref_mos_3d=-9999.0 + DO j=2,nlat-1 + DO i=2,nlon-1 + if( dbz_lightning(i,j) > 30 ) then + mref = min(4,(int((dbz_lightning(i,j) - 30.0_r_kind)/5.0_r_kind) + 1 )) + if(season== 2 ) then + DO k=1,maxlvl + tempprofile(k)=refprofile_winter(k,mref)*dbz_lightning(i,j) + enddo + lowest=newlvlAll(2) + highest=7000.0_r_kind + else if(season== 1 ) then + DO k=1,maxlvl + tempprofile(k)=refprofile_summer(k,mref)*dbz_lightning(i,j) + enddo + lowest=newlvlAll(3) + highest=12000.0_r_kind + endif + DO k2=1,nsig + heightGSI=h_bk(i,j,k2) + if(heightGSI >= lowest .and. heightGSI < highest) then ! lower 12km ? + do k=1,maxlvl-1 + if( heightGSI >=newlvlAll(k) .and. heightGSI < newlvlAll(k+1) ) ilvl=k + enddo + upref=tempprofile(ilvl+1) + downref=tempprofile(ilvl) + wght=(heightGSI-newlvlAll(ilvl))/(newlvlAll(ilvl+1)-newlvlAll(ilvl)) + tempref=(1-wght)*downref + wght*upref + ref_mos_3d(i,j,k2) = max(ref_mos_3d(i,j,k2),tempref) + endif + ENDDO + endif + ENDDO + ENDDO + +END SUBROUTINE convert_lghtn2ref_nmmb diff --git a/src/GSD/gsdcloud4nmmb/diff.sh b/src/GSD/gsdcloud4nmmb/diff.sh new file mode 100755 index 0000000000..9cd06f644c --- /dev/null +++ b/src/GSD/gsdcloud4nmmb/diff.sh @@ -0,0 +1,11 @@ + +set -x +rm -f ttt +flnm=`ls *90` +for iflnm in $flnm +do + echo "**********" >> ttt + echo $iflnm >> ttt + diff $iflnm ../gsdcloud_old/$iflnm >> ttt + echo >> ttt +done diff --git a/src/GSD/gsdcloud4nmmb/get_sfm_1d_gnl.f90 b/src/GSD/gsdcloud4nmmb/get_sfm_1d_gnl.f90 new file mode 100755 index 0000000000..ca2703ae4f --- /dev/null +++ b/src/GSD/gsdcloud4nmmb/get_sfm_1d_gnl.f90 @@ -0,0 +1,384 @@ +! +! +! +!$$$ subprogram documentation block +! . . . . +! subprogram: get_sfm_1d_gnl +! +! PRGMMR: ORG: DATE: +! +! ABSTRACT: +! This subroutine calculate liquid water content for convection cloud +! This subroutine is from ARPS cloud analysis package +! +! PROGRAM HISTORY LOG: +! 2009-01-20 Hu Add NCO document block +! +! +! input argument list: +! +! output argument list: +! +! USAGE: +! INPUT FILES: +! +! OUTPUT FILES: +! +! REMARKS: +! +! ATTRIBUTES: +! LANGUAGE: FORTRAN 90 +! MACHINE: Linux cluster (WJET) +! +!$$$ +! +!_____________________________________________________________________ +! + +!################################################################## +!################################################################## +!###### ###### +!###### SUBROUTINE GET_SFM_1D ###### +!###### ###### +!###### Developed by ###### +!###### Center for Analysis and Prediction of Storms ###### +!###### University of Oklahoma ###### +!###### ###### +!################################################################## +!################################################################## +! + +SUBROUTINE get_sfm_1d_gnl (nz,zcb,zctop,zs_1d,p_mb_1d,t_1d,ql,qi,cldt, & + l_prt) +! +!----------------------------------------------------------------------- +! +! PURPOSE: +!c----------------------------------------------------------------- +!c +!c This is the streamlined version of the Smith-Feddes +!c and Temperature Adjusted LWC calculation methodologies +!c produced at Purdue University under sponsorship +!c by the FAA Technical Center. +!c +!c Currently, this subroutine will only use the Smith- +!c Feddes and will only do so as if there are solely +!c stratiform clouds present, however, it is very easy +!c to switch so that only the Temperature Adjusted +!c method is used. +!c +!c Dilution by glaciation is also included, it is a +!c linear function of in cloud temperature going from +!c all liquid water at -10 C to all ice at -30 C +!c as such the amount of ice is also calculated +! +!----------------------------------------------------------------------- +! +! AUTHOR: Jian Zhang +! 05/96 Based on the LAPS cloud analysis code of 07/1995 +! +! MODIFICATION HISTORY: +! +! 05/16/96 (Jian Zhang) +! Modified for ADAS format. Added full documentation. +! +!----------------------------------------------------------------------- +! +!----------------------------------------------------------------------- +! +! Variable Declarations. +! +!----------------------------------------------------------------------- +! + IMPLICIT NONE +! +! +!----------------------------------------------------------------------- +! +! INPUT: + INTEGER :: nz ! number of model vertical levels + REAL :: zs_1d(nz) ! physical height (m) at each scalar level + REAL :: p_mb_1d(nz) ! pressure (mb) at each level + REAL :: t_1d(nz) ! temperature (K) at each level + + REAL :: zcb ! cloud base height (m) + REAL :: zctop ! cloud top height (m) +! +! OUTPUT: + REAL :: ql(nz) ! liquid water content (g/kg) + REAL :: qi(nz) ! ice water content (g/kg) + REAL :: cldt(nz) +! +! LOCAL: + REAL :: calw(200) + REAL :: cali(200) + REAL :: catk(200) + REAL :: entr(200) +! +!----------------------------------------------------------------------- +! +! Misc local variables +! +!----------------------------------------------------------------------- +! + REAL :: dz,rv,rair,grav,cp,rlvo,rlso,dlvdt,eso + REAL :: c,a1,b1,c1,a2,b2,c2 + REAL :: delz,delt,cldbtm,cldbp,cldtpt,tbar + REAL :: arg,fraclw,tlwc + REAL :: temp,press,zbase,alw,zht,ht,y + REAL :: rl,es,qvs1,p,des,dtz,es2,qvs2 + INTEGER :: i,j,k,nlevel,nlm1,ip,kctop,kctop1,kcb,kcb1 + REAL :: dtdz,dttdz,zcloud,entc,tmpk + LOGICAL :: l_prt +! +!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ +! +! Beginning of executable code... +! +!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ +! +! +!----------------------------------------------------------------------- +! +! Initialize 1d liquid water and ice arrays (for 100m layers) +! +!----------------------------------------------------------------------- +! + DO i=1,200 + calw(i)=0.0 + cali(i)=0.0 + END DO +! +!----------------------------------------------------------------------- +! +! Preset some constants and coefficients. +! +!----------------------------------------------------------------------- +! + dz=100.0 ! m + rv=461.5 ! J/deg/kg + rair=287.04 ! J/deg/kg + grav=9.81 ! m/s2 + cp=1004. ! J/deg/kg + rlvo=2.5003E+6 ! J/kg + rlso=2.8339E+6 ! J/kg + dlvdt=-2.3693E+3 ! J/kg/K + eso=610.78 ! pa + c=0.01 + a1=8.4897 + b1=-13.2191 + c1=4.7295 + a2=10.357 + b2=-28.2416 + c2=8.8846 +! +!----------------------------------------------------------------------- +! +! Calculate indices of cloud top and base +! +!----------------------------------------------------------------------- +! + DO k=1,nz-1 + IF(zs_1d(k) < zcb .AND. zs_1d(k+1) > zcb) THEN + kcb=k + kcb1=kcb+1 + END IF + IF(zs_1d(k) < zctop .AND. zs_1d(k+1) > zctop) THEN + kctop=k + kctop1=kctop+1 + END IF + END DO +! +!----------------------------------------------------------------------- +! +! Obtain cloud base and top conditions +! +!----------------------------------------------------------------------- +! + delz = zs_1d(kcb+1)-zs_1d(kcb) + delt = t_1d(kcb+1)-t_1d(kcb) + cldbtm = delt*(zcb-zs_1d(kcb))/delz+t_1d(kcb) + tbar = (cldbtm+t_1d(kcb))/2. + arg = -grav*(zcb-zs_1d(kcb))/rair/tbar + cldbp = p_mb_1d(kcb)*EXP(arg) + delz = zs_1d(kctop+1)-zs_1d(kctop) + delt = t_1d(kctop+1)-t_1d(kctop) + cldtpt = delt*(zctop-zs_1d(kctop))/delz+t_1d(kctop) +! +!----------------------------------------------------------------------- +! +! Calculate cloud lwc profile for cloud base/top pair +! +!----------------------------------------------------------------------- +! + temp = cldbtm + press = cldbp*100.0 + zbase = zcb + nlevel = ((zctop-zcb)/100.0)+1 + IF(nlevel <= 0) nlevel=1 + alw = 0.0 + calw(1)= 0.0 + cali(1)= 0.0 + catk(1)= temp + entr(1)= 1.0 + nlm1 = nlevel-1 + IF(nlm1 < 1) nlm1=1 + zht = zbase + + DO j=1,nlm1 + rl = rlvo+(273.15-temp)*dlvdt + arg = rl*(temp-273.15)/273.15/temp/rv + es = eso*EXP(arg) + qvs1 = 0.622*es/(press-es) +! rho1 = press/(rair*temp) + arg = -grav*dz/rair/temp + p = press*EXP(arg) + + IF(l_prt) THEN + WRITE(6,605) j,zht,temp,press,1000.0*qvs1,es,rl + 605 FORMAT('get_sfm_1d_gnl:',1X,i2,' ht=',f8.0,' T=',f6.1,' P=',f9.1,' qvs=', & + f7.3,' es=',f6.1,' Lv=',e10.3) + END IF +! +!----------------------------------------------------------------------- +! +! Calculate saturated adiabatic lapse rate +! +!----------------------------------------------------------------------- +! + des = es*rl/temp/temp/rv + dtz = -grav*((1.0+0.621*es*rl/(press*rair*temp))/ & + (cp+0.621*rl*des/press)) + zht = zht+dz + press = p + temp = temp+dtz*dz + rl = rlvo+(273.15-temp)*dlvdt + arg = rl*(temp-273.15)/273.15/temp/rv + es2 = eso*EXP(arg) + qvs2 = 0.622*es2/(press-es2) + + alw = alw+(qvs1-qvs2) ! kg/kg + calw(j+1) = alw + + IF (l_prt) THEN + WRITE(6,9015) j,1000.0*calw(j+1),zht + 9015 FORMAT('get_sfm_1d_gnl',1X,'j=',i3,' adiab.lwc =',f7.3,' alt =',f8.0) + END IF +! +!----------------------------------------------------------------------- +! +! Reduction of lwc by entrainment +! +!----------------------------------------------------------------------- +! + ht = (zht-zbase)*.001 +! +!c ------------------------------------------------------------------ +!c +!c skatskii's curve(convective) +!c +!c ------------------------------------------------------------------ +!c if(ht.lt.0.3) then +!c y = -1.667*(ht-0.6) +!c elseif(ht.lt.1.0) then +!c arg1 = b1*b1-4.0*a1*(c1-ht) +!c y = (-b1-sqrt(arg1))/(2.0*a1) +!c elseif(ht.lt.2.9) then +!c arg2 = b2*b2-4.0*a2*(c2-ht) +!c y = (-b2-sqrt(arg2))/(2.0*a2) +!c else +!c y = 0.26 +!c endif +!c +!c ------------------------------------------------------------------ +!c +!c warner's curve(stratiform) +!c +!c ------------------------------------------------------------------ + IF(ht < 0.032) THEN + y = -11.0*ht+1.0 ! y(ht=0.032) = 0.648 + ELSE IF(ht <= 0.177) THEN + y = -1.4*ht+0.6915 ! y(ht=0.177) = 0.4437 + ELSE IF(ht <= 0.726) THEN + y = -0.356*ht+0.505 ! y(ht=0.726) = 0.2445 + ELSE IF(ht <= 1.5) THEN + y = -0.0608*ht+0.2912 ! y(ht=1.5) = 0.2 + ELSE + y = 0.20 + END IF +! +!----------------------------------------------------------------------- +! +! Calculate reduced lwc by entrainment and dilution +! +! Note at -5 C and warmer, all liquid. ! changed from -10 KB +! at -25 C and colder, all ice ! changed from -30 KB +! Linear ramp between. +! +!----------------------------------------------------------------------- +! + IF(temp < 268.15) THEN + IF(temp > 248.15) THEN + fraclw=0.05*(temp-248.15) + ELSE + fraclw=0.0 + END IF + ELSE + fraclw=1.0 + END IF + + tlwc=1000.*y*calw(j+1) ! g/kg + calw(j+1)=tlwc*fraclw + cali(j+1)=tlwc*(1.-fraclw) + catk(j+1)=temp + entr(j+1)=y + + END DO +! +!----------------------------------------------------------------------- +! +! Alternative calculation procedure using the observed or +! inferred in cloud temperature profile +! +!----------------------------------------------------------------------- +! +!----------------------------------------------------------------------- +! +! Obtain profile of LWCs at the given grid point +! +!----------------------------------------------------------------------- +! + + DO ip=2,nz-1 + IF(zs_1d(ip) <= zcb .OR. zs_1d(ip) > zctop) THEN + ql(ip)=0.0 + qi(ip)=0.0 + cldt(ip)=t_1d(ip) + ELSE + DO j=2,nlevel + zcloud = zcb+(j-1)*dz + IF(zcloud >= zs_1d(ip)) THEN + ql(ip) = (zs_1d(ip)-zcloud+100.)*(calw(j)-calw(j-1))*0.01 & + +calw(j-1) + qi(ip) = (zs_1d(ip)-zcloud+100.)*(cali(j)-cali(j-1))*0.01 & + +cali(j-1) + tmpk = (zs_1d(ip)-zcloud+100.)*(catk(j)-catk(j-1))*0.01 & + +catk(j-1) + entc = (zs_1d(ip)-zcloud+100.)*(entr(j)-entr(j-1))*0.01 & + +entr(j-1) + cldt(ip) = (1.-entc)*t_1d(ip) + entc*tmpk + + EXIT + END IF + END DO + END IF + END DO +! +!----------------------------------------------------------------------- +! +! Write out file of lwc comparisons +! +!----------------------------------------------------------------------- +! + RETURN +END SUBROUTINE get_sfm_1d_gnl diff --git a/src/GSD/gsdcloud4nmmb/hydro_mxr_thompson.f90 b/src/GSD/gsdcloud4nmmb/hydro_mxr_thompson.f90 new file mode 100755 index 0000000000..bd1c8f5bd9 --- /dev/null +++ b/src/GSD/gsdcloud4nmmb/hydro_mxr_thompson.f90 @@ -0,0 +1,198 @@ +SUBROUTINE hydro_mxr_thompson (nx, ny, nz, t_3d, p_3d, ref_3d, qr_3d, qnr_3d, qs_3d, istatus, mype ) +! +! PURPOSE: +! Calculate (1) snow mixing ratio, (2) rain mixing ratio, and (3) rain number concentration +! from reflectivity for Thompson microphysics scheme. A Marshall-Palmer drop-size distribution +! is assumed for rain. +! +! HISTORY: +! 2013-01-30: created by David Dowell, Greg Thompson, Ming Hu +! +! ACKNOWLEDGMENTS: +! Donghai Wang and Eric Kemp (code template from pcp_mxr_ferrier) +! +! input argument list: +! nx - no. of lons on subdomain (buffer points on ends) +! ny - no. of lats on subdomain (buffer points on ends) +! nz - no. of levels +! t_3d - 3D background temperature (K) +! p_3d - 3D background pressure (hPa) +! ref_3d - 3D reflectivity in analysis grid (dBZ) +! +! output argument list: +! qr_3d - rain mixing ratio (g/kg) +! qnr_3d - rain number concentration (/kg) +! qs_3d - snow mixing ratio (g/kg) +! istatus - +! + + +!----------------------------------------------------------------------- +! +! Variable Declarations. +! +!----------------------------------------------------------------------- +! + use kinds, only: r_single, i_kind, r_kind + IMPLICIT NONE +! +!----------------------------------------------------------------------- +! +! INPUT: + INTEGER(i_kind),intent(in) :: nx,ny,nz ! Model grid size + REAL(r_kind), intent(inout) :: ref_3d(nx,ny,nz) ! radar reflectivity (dBZ) + REAL(r_single), intent(in) :: t_3d(nx,ny,nz) ! Temperature (deg. Kelvin) + REAL(r_single), intent(in) :: p_3d(nx,ny,nz) ! Pressure (Pascal) + INTEGER(i_kind),intent(in) :: mype +! +! OUTPUT: + INTEGER(i_kind),intent(out):: istatus + REAL(r_single),intent(out) :: qs_3d(nx,ny,nz) ! snow mixing ratio (g/kg) + REAL(r_single),intent(out) :: qr_3d(nx,ny,nz) ! rain mixing ratio (g/kg) + REAL(r_single),intent(out) :: qnr_3d(nx,ny,nz) ! rain number concentration (/kg) +! +! PARAMETERS: + REAL(r_kind), PARAMETER :: min_ref = 0.0_r_kind ! minimum reflectivity (dBZ) for converting to qs and qr + REAL(r_kind), PARAMETER :: max_ref_snow = 28.0_r_kind ! maximum reflectivity (dBZ) for converting to qs + ! (values above max_ref are treated as max_ref) + REAL(r_kind), PARAMETER :: max_ref_rain = 55.0_r_kind ! maximum reflectivity (dBZ) for converting to qr + ! (values above max_ref are treated as max_ref) + REAL(r_kind), PARAMETER :: n0r_mp = 8.0e6_r_kind ! Marshall-Palmer intercept parameter for rain (m**-4) + REAL(r_kind), PARAMETER :: rd= 287.0_r_kind ! Gas constant for dry air (m**2/(s**2*K)) + REAL(r_kind), PARAMETER :: am_s = 0.069_r_kind + REAL(r_kind), PARAMETER :: bm_s = 2.0_r_kind + REAL(r_kind), PARAMETER :: PI = 3.1415926536_r_kind + REAL(r_kind), PARAMETER :: rho_i = 890.0_r_kind + REAL(r_kind), PARAMETER :: rho_w = 1000.0_r_kind +! +! LOCAL VARIABLES: + INTEGER(i_kind) :: i,j,k + REAL(r_kind) :: rho ! air density (kg m**-3) + REAL(r_kind) :: zes ! reflectivity (m**6 m**-3) associated with snow + REAL(r_kind) :: zer ! reflectivity (m**6 m**-3) associated with rain + REAL(r_kind) :: tc ! temperature (Celsius) + REAL(r_kind) :: rfract ! rain fraction + REAL(r_kind) :: tc0 + REAL(r_kind) :: smo2 + REAL(r_kind) :: rs + REAL(r_kind) :: f + REAL(r_kind) :: loga_ + REAL(r_kind) :: a_ + REAL(r_kind), PARAMETER :: a_min = 1.0e-5_r_kind ! lower bound for a_, to avoid large mixing ratios retrieved + ! for tiny particles sizes in cold temperatures + REAL(r_kind) :: b_ + REAL(r_kind) :: sa(10) + REAL(r_kind) :: sb(10) + REAL(r_kind) :: cse(3) + REAL(r_kind) :: crg(4) + REAL(r_kind) :: am_r + REAL(r_kind) :: oams + REAL(r_kind) :: qs ! snow mixing ratio in kg / kg + REAL(r_kind) :: qr ! rain mixing ratio in kg / kg +! +! for snow moments conversions (from Field et al. 2005) + DATA sa / 5.065339, -0.062659, -3.032362, 0.029469, -0.000285, & + 0.31255, 0.000204, 0.003199, 0.0, -0.015952/ + DATA sb / 0.476221, -0.015896, 0.165977, 0.007468, -0.000141, & + 0.060366, 0.000079, 0.000594, 0.0, -0.003577/ + +!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ +! +! Beginning of executable code... +! +!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ + + istatus=0 + + f = (0.176_r_kind/0.93_r_kind) * (6.0_r_kind/PI)*(6.0_r_kind/PI) * (am_s/rho_i)*(am_s/rho_i) + cse(1) = bm_s + 1.0_r_kind + cse(2) = bm_s + 2.0_r_kind + cse(3) = bm_s * 2.0_r_kind + oams = 1.0_r_kind / am_s + + crg(1) = 24.0_r_kind + crg(2) = 1.0_r_kind + crg(3) = 24.0_r_kind + crg(4) = 5040.0_r_kind + am_r = PI * rho_w / 6.0_r_kind + + DO k = 2,nz-1 + DO j = 2,ny-1 + DO i = 2,nx-1 + + IF (ref_3d(i,j,k) >= min_ref) THEN + + rho = p_3d(i,j,k) / (rd*t_3d(i,j,k)) + tc = t_3d(i,j,k) - 273.15_r_kind + + IF (tc <= 0.0_r_kind) THEN + rfract = 0.0_r_kind + ELSE IF (tc >= 5.0_r_kind) THEN + rfract = 1.0_r_kind + ELSE + rfract = 0.20_r_kind*tc + ENDIF + + zes = ( 10.0_r_kind**( 0.1_r_kind * min(ref_3d(i,j,k), max_ref_snow) ) ) & + * (1.0_r_kind-rfract) & + * 1.0e-18_r_kind ! conversion from (mm**6 m**-3) to (m**6 m**-3) + + zer = ( 10.0_r_kind**( 0.1_r_kind * min(ref_3d(i,j,k), max_ref_rain) ) ) & + * rfract & + * 1.0e-18_r_kind ! conversion from (mm**6 m**-3) to (m**6 m**-3) + + tc0 = MIN(-0.1, tc) + IF (bm_s.lt.(1.999_r_kind) .or. bm_s.gt.(2.001_r_kind)) THEN + PRINT*, 'ABORT (hydro_mxr_thompson): bm_s = ', bm_s + STOP + ENDIF + + ! Calculate bm_s*2 (th) moment. Useful for reflectivity. + loga_ = sa(1) + sa(2)*tc0 + sa(3)*cse(3) & + + sa(4)*tc0*cse(3) + sa(5)*tc0*tc0 & + + sa(6)*cse(3)*cse(3) + sa(7)*tc0*tc0*cse(3) & + + sa(8)*tc0*cse(3)*cse(3) + sa(9)*tc0*tc0*tc0 & + + sa(10)*cse(3)*cse(3)*cse(3) + a_ = max( 10.0_r_kind ** loga_, a_min ) + b_ = sb(1) + sb(2)*tc0 + sb(3)*cse(3) + sb(4)*tc0*cse(3) & + + sb(5)*tc0*tc0 + sb(6)*cse(3)*cse(3) & + + sb(7)*tc0*tc0*cse(3) + sb(8)*tc0*cse(3)*cse(3) & + + sb(9)*tc0*tc0*tc0 + sb(10)*cse(3)*cse(3)*cse(3) + + qs = ( (zes / (f*a_)) ** (1.0_r_kind / b_) ) / (rho*oams) + qs_3d(i,j,k) = 1000.0_r_kind * qs ! convert from kg / kg to g / kg + + qr = n0r_mp * am_r * crg(3) / rho * (zer / (n0r_mp*crg(4)))**(4.0_r_kind/7.0_r_kind) + qnr_3d(i,j,k) = (n0r_mp/rho)**(3.0_r_kind/4.0_r_kind) & + * (qr / (am_r * crg(3)))**(1.0_r_kind/4.0_r_kind) + + qnr_3d(i,j,k) = max(1.0_r_kind, qnr_3d(i,j,k)) + qr_3d(i,j,k) = 1000.0_r_kind * qr ! convert from kg / kg to g / kg + + +! if(mype==51 ) then +! write(*,'(a10,3i5,2f10.5,3f8.2)') 'b=',i,j,k,qs_3d(i,j,k),qr_3d(i,j,k),ref_3d(i,j,k),& +! p_3d(i,j,k)/100.0,tc +! endif + + + ELSE + + qs_3d(i,j,k) = -999._r_kind + qr_3d(i,j,k) = -999._r_kind + qnr_3d(i,j,k) = -999._r_kind + + END IF + + END DO ! k + END DO ! i + END DO ! j +! +! PRINT*,'finish hydro_mxr_thompson...' +! +!----------------------------------------------------------------------- +! + istatus = 1 +! + RETURN +END SUBROUTINE hydro_mxr_thompson diff --git a/src/GSD/gsdcloud4nmmb/make.dependencies b/src/GSD/gsdcloud4nmmb/make.dependencies new file mode 100755 index 0000000000..64f49a7346 --- /dev/null +++ b/src/GSD/gsdcloud4nmmb/make.dependencies @@ -0,0 +1,35 @@ +kinds.o : kinds.f90 +constants.o : constants.f90 kinds.o + +ARPS_cldLib.o : ARPS_cldLib.f90 kinds.o constants.o +BackgroundCld.o : BackgroundCld.f90 kinds.o constants.o +BckgrndCC.o : BckgrndCC.f90 kinds.o constants.o +CheckCld.o : CheckCld.f90 kinds.o constants.o +radar_ref2tten.o : radar_ref2tten.f90 kinds.o constants.o +PrecipMxr_radar.o : PrecipMxr_radar.f90 kinds.o constants.o +PrecipType.o : PrecipType.f90 kinds.o constants.o +TempAdjust.o : TempAdjust.f90 kinds.o constants.o +adaslib.o : adaslib.f90 kinds.o constants.o +build_missing_REFcone.o : build_missing_REFcone.f90 kinds.o constants.o +cloudCover_NESDIS.o : cloudCover_NESDIS.f90 kinds.o constants.o +cloudCover_Surface.o : cloudCover_Surface.f90 kinds.o constants.o +cloudCover_radar.o : cloudCover_radar.f90 kinds.o constants.o +cloudLWC.o : cloudLWC.f90 kinds.o constants.o +cloudLayers.o : cloudLayers.f90 kinds.o constants.o +cloudType.o : cloudType.f90 kinds.o constants.o +convert_lghtn2ref.o : convert_lghtn2ref.f90 kinds.o constants.o +cloud_saturation.o : cloud_saturation.f90 kinds.o +get_sfm_1d_gnl.o : get_sfm_1d_gnl.f90 kinds.o constants.o +vinterp_radar_ref.o : vinterp_radar_ref.f90 kinds.o constants.o +map_ctp.o : map_ctp.f90 kinds.o constants.o +map_ctp_lar.o : map_ctp_lar.f90 kinds.o constants.o +mthermo.o : mthermo.f90 kinds.o constants.o +pcp_mxr_ARPSlib.o : pcp_mxr_ARPSlib.f90 kinds.o constants.o +## q_adjust.o : q_adjust.f90 kinds.o constants.o +read_Lightning_cld.o : read_Lightning_cld.f90 kinds.o constants.o +read_Lightningbufr_cld.o : read_Lightningbufr_cld.f90 kinds.o constants.o +read_NESDIS.o : read_NESDIS.f90 kinds.o constants.o +read_radar_ref.o : read_radar_ref.f90 kinds.o constants.o +read_Surface.o :read_Surface.f90 kinds.o constants.o +read_nasalarc_cld.o : read_nasalarc_cld.f90 kinds.o constants.o +smooth.o : smooth.f90 kinds.o constants.o diff --git a/src/GSD/gsdcloud4nmmb/make.filelist b/src/GSD/gsdcloud4nmmb/make.filelist new file mode 100755 index 0000000000..e268baf513 --- /dev/null +++ b/src/GSD/gsdcloud4nmmb/make.filelist @@ -0,0 +1,36 @@ +SRC_FILES = ARPS_cldLib.f90 \ + BackgroundCld.f90 \ + BckgrndCC.f90 \ + radar_ref2tten.f90 \ + PrecipMxr_radar.f90 \ + PrecipType.f90 \ + TempAdjust.f90 \ + adaslib.f90 \ + build_missing_REFcone.f90 \ + cloudCover_NESDIS.f90 \ + cloudCover_Surface.f90 \ + cloudCover_radar.f90 \ + cloudLWC.f90 \ + cloudLayers.f90 \ + cloudType.f90 \ + cloud_saturation.f90 \ + convert_lghtn2ref.f90 \ + get_sfm_1d_gnl.f90 \ + vinterp_radar_ref.f90 \ + map_ctp.f90 \ + map_ctp_lar.f90 \ + mthermo.f90 \ + pcp_mxr_ARPSlib.f90 \ + read_Lightning_cld.f90 \ + read_Lightningbufr_cld.f90 \ + read_NESDIS.f90 \ + read_radar_ref.f90 \ + read_Surface.f90 \ + read_nasalarc_cld.f90 \ + smooth.f90 \ + constants.f90 \ + kinds.f90 \ + pbl_height.f90 \ + hydro_mxr_thompson.f90 + +OBJ_FILES =${SRC_FILES:.f90=.o} diff --git a/src/GSD/gsdcloud4nmmb/makefile b/src/GSD/gsdcloud4nmmb/makefile new file mode 100755 index 0000000000..7f2808fff5 --- /dev/null +++ b/src/GSD/gsdcloud4nmmb/makefile @@ -0,0 +1,36 @@ +SHELL=/bin/sh + +LIB = ./libgsdcloud.a + +include make.filelist + +FFLAGS = -O3 -g -fp-model strict -convert big_endian -assume byterecl -implicitnone -traceback # -I../../../include +.SUFFIXES: .f90 .o + +.f90.o: +## $(RM) $@ $*.mod + ifort $(FFLAGS) -c $< + + +all: $(LIB) + +$(LIB): $(OBJ_FILES) + $(AR) -ruv $(LIB) $(OBJ_FILES) + +.f90.a: + ifort -c $(FFLAGS) $< +# ar -ruv $(AFLAGS) $@ $*.o +# rm -f $*.o + +.c.a: + $(CC) -c $(CFLAGS) $< +# ar -ruv $(AFLAGS) $@ $*.o +# rm -f $*.o + +# DEPENDENCIES : only dependencies after this line (don't remove the word DEPENDENCIES) + +include make.dependencies + +clean: + rm -f *.o *.mod $(LIB) + diff --git a/src/GSD/gsdcloud4nmmb/map_ctp.f90 b/src/GSD/gsdcloud4nmmb/map_ctp.f90 new file mode 100755 index 0000000000..139d46153a --- /dev/null +++ b/src/GSD/gsdcloud4nmmb/map_ctp.f90 @@ -0,0 +1,291 @@ +subroutine map_ctp (ib,jb,nx,ny,nn_obs,numsao,data_s,sat_ctp,sat_tem,w_frac) + +! +!$$$ subprogram documentation block +! . . . . +! subprogram: map_ctp map GOES cloud product to analysis grid +! +! PRGMMR: Ming Hu ORG: GSD/AMB DATE: 2006-03_10 +! +! ABSTRACT: +! This subroutine map GOES cloud product to analysis grid +! +! PROGRAM HISTORY LOG: +! 2009-01-20 Hu Add NCO document block +! +! +! input argument list: +! ib - begin i point of this domain +! jb - begin j point of this domain +! nx - no. of lons on subdomain (buffer points on ends) +! ny - no. of lats on subdomain (buffer points on ends) +! nn_obs - 1st dimension of observation arry data_s +! numsao - number of observation +! data_s - observation array for GOES cloud products +! +! output argument list: +! sat_ctp - GOES cloud top pressure in analysis grid +! sat_tem - GOES cloud top temperature in analysis grid +! w_frac - GOES cloud coverage in analysis grid +! +! USAGE: +! INPUT FILES: +! +! OUTPUT FILES: +! +! REMARKS: +! +! adapted according to RUC subroutine rd_cld +! * +! * This routine reads NESDIS (Madison, WI) cloud product produced +! * from GOES sounder data. The original product is reprocessed onto +! * MAPS40 grid boxes. There could be more than one cloud product +! * in a grid-box, so we use the nearest one that falls in the +! * grid. The routine combines GOES-8 and 10 products. +! +! ===== History ===== +! +! * Internal variables: +! CTP_E, CTP_W Soft-linked filename for ascii GOES Clouds +! +! * Working variables: +! +! * Working variables used for sorting max size of 10: +! Pxx, Txx, xdist,xxxdist (R4) +! Fxx, Nxx, index, jndex (I4) +! ioption (I4) = 1 if selection is nearest neighbor +! = 2 if selection is median of samples +! +! +! * Output variables on gridpoint (Nx,Ny): +! sat_ctp, sat_tem (R4) Cloud-top pressure and temperature +! w_frac (R4) Effective fractional cloud coverage, option=1 +! fractional coverage within RUC grid, option=2 +! w_eca (R4) Effective fractional cloud regardless option +! (effective cloud amount - eca) +! nlev_cld (I4) Number of cloud levels. TO BE USED LATER +! to incorporate multi-level cloud +! +! * Calling routines +! sorting +! sortmed +! +! * +! +! ATTRIBUTES: +! LANGUAGE: FORTRAN 90 +! MACHINE: Linux cluster (WJET) +! +!$$$ +! +!_____________________________________________________________________ +! + + use kinds, only: r_kind,r_single,i_kind + use constants, only: zero,one_tenth,one,deg2rad + + implicit none + +! input-file variables: + INTEGER(i_kind),intent(in) :: Nx, Ny + INTEGER(i_kind),intent(in) :: ib, jb + INTEGER(i_kind),intent(in) :: numsao, nn_obs + real(r_kind),dimension(nn_obs,numsao):: data_s +! Output + real(r_single), intent(out) :: sat_ctp(Nx,Ny) + real(r_single), intent(out) :: sat_tem(Nx,Ny) + real(r_single), intent(out) :: w_frac(Nx,Ny) +! +! misc + integer(i_kind) :: nfov + parameter (nfov=60) + + character header*80 +! Working + real(r_kind) :: Pxx(Nx,Ny,nfov),Txx(Nx,Ny,nfov) + real(r_kind) :: xdist(Nx,Ny,nfov), xxxdist(nfov) + real(r_kind) :: fr,sqrt, qc, type + integer(i_kind) :: Nxx(Nx,Ny,nfov),index(Nx,Ny), jndex(nfov) + integer(i_kind) :: ioption + integer(i_kind) :: ipt,ixx,ii,jj,i,med_pt,igrid,jgrid & + ,ncount,ncount1,ncount2,ii1,jj1,nobs,n + + real(r_kind) :: xc + real(r_kind) :: yc + + real(r_single) :: w_eca(Nx,Ny) + integer(i_kind) :: nlev_cld(Nx,Ny) + integer(i_kind) :: ios + +! +! * Initialize outputs since GOES sounder do not scan all MAPS domain +! + do jj=1,Ny + do ii=1,Nx + w_eca (ii,jj) =-99999._r_kind + index(ii,jj) = 0 + enddo + enddo + +! -- set ios as failed unless valid data points are found below + ios = 0 + +! ----------------------------------------------------------- +! ----------------------------------------------------------- +! Map each FOV onto RR grid points +! ----------------------------------------------------------- +! ----------------------------------------------------------- + do ipt=1,numsao + + xc=data_s(2,ipt) - ib + 1.0_r_kind + yc=data_s(3,ipt) - jb + 1.0_r_kind + if(data_s(8,ipt) > 50 ) cycle + +! * XC,YC should be within subdomain boundary, i.e., XC,YC >0 + + if(XC >= 1._r_kind .and. XC < Nx .and. & + YC >= 1._r_kind .and. YC < Ny) then + ii1 = int(xc+0.5_r_kind) + jj1 = int(yc+0.5_r_kind) + + do jj = max(1,jj1-2), min(ny,jj1+2) + if (jj1-1 >= 1 .and. jj1+1 <= ny) then + do ii = max(1,ii1-2), min(nx,ii1+2) + if (ii1-1 >= 1 .and. ii1+1 <= nx) then + +! * We check multiple data within gridbox + + if (index(ii,jj) < nfov) then + index(ii,jj) = index(ii,jj) + 1 + + Pxx(ii,jj,index(ii,jj)) = data_s(4,ipt) + Txx(ii,jj,index(ii,jj)) = data_s(6,ipt) +!mhu Nxx(ii,jj,index(ii,jj)) = int(data_s(5,ipt)) +!mhu no cloud amount available, assign to 100 + Nxx(ii,jj,index(ii,jj)) = 100 + nlev_cld(ii,jj) = 1 + xdist(ii,jj,index(ii,jj)) = sqrt( & + (XC+1-ii)**2 + (YC+1-jj)**2) + end if + endif + enddo ! ii + endif + enddo ! jj + endif ! observation is in the domain + enddo ! ipt +! +! * ioption = 1 is nearest neighrhood +! * ioption = 2 is median of cloudy fov + ioption = 2 +! + do jj = 1,Ny + do ii = 1,Nx + if (index(ii,jj) < 3 ) then +! sat_ctp(ii,jj) = Pxx(ii,jj,1) +! sat_tem(ii,jj) = Txx(ii,jj,1) +! w_frac(ii,jj) = float(Nxx(ii,jj,1))/100. +! w_eca(ii,jj) = float(Nxx(ii,jj,1))/100. + + elseif(index(ii,jj) >= 3) then + +! * We decided to use nearest neighborhood for ECA values, +! * a kind of convective signal from GOES platform... + + do i=1,index(ii,jj) + jndex(i) = i + xxxdist(i) = xdist(ii,jj,i) + enddo + call sorting(xxxdist,index(ii,jj),jndex) + w_eca(ii,jj) = float(Nxx(ii,jj,jndex(1)))/100._r_kind +! * Sort to find closest distance if more than one sample + if(ioption == 1) then !nearest neighborhood + do i=1,index(ii,jj) + jndex(i) = i + xxxdist(i) = xdist(ii,jj,i) + enddo + call sorting(xxxdist,index(ii,jj),jndex) + sat_ctp(ii,jj) = Pxx(ii,jj,jndex(1)) + sat_tem(ii,jj) = Txx(ii,jj,jndex(1)) + w_frac(ii,jj) = float(Nxx(ii,jj,jndex(1)))/100._r_kind + endif +! * Sort to find median value + if(ioption == 2) then !pick median + do i=1,index(ii,jj) + jndex(i) = i + xxxdist(i) = Pxx(ii,jj,i) + enddo + call sortmed(xxxdist,index(ii,jj),jndex,fr) + med_pt = index(ii,jj)/2 + 1 + sat_ctp(ii,jj) = Pxx(ii,jj,jndex(med_pt)) + sat_tem(ii,jj) = Txx(ii,jj,jndex(med_pt)) + w_frac(ii,jj) = fr + endif + endif + enddo !ii + enddo !jj + + return +end subroutine map_ctp + +subroutine sorting(d,n,is) + use kinds, only: r_kind,i_kind + implicit none + + integer(i_kind), intent(in) :: n + real(r_kind) , intent(inout) :: d(n) + integer(i_kind), intent(inout) :: is(n) +! + integer(i_kind) :: nm1,ip1,iold,i,j + real(r_kind) :: temp +! +! + nm1 = n-1 + do 10 i=1,nm1 + ip1 = i+1 + do 10 j=ip1,n + if(d(i) <= d(j)) goto 10 + temp = d(i) + d(i) = d(j) + d(j) = temp + iold = is(i) + is(i) = is(j) + is(j) = iold + 10 continue + return +end subroutine sorting + +subroutine sortmed(p,n,is,f) + use kinds, only: r_kind,i_kind + implicit none + real(r_kind), intent(inout) :: p(n) + integer(i_kind), intent(in) :: n + integer(i_kind), intent(inout) :: is(n) +! * count cloudy fov + real(r_kind), intent(out) :: f + integer(i_kind) :: cfov +! + integer(i_kind) :: i,j,nm1,ip1,iold + real(r_kind) :: temp +! +! +! + cfov = 0 + do i=1,n + if(p(i) < 999._r_kind) cfov = cfov + 1 + enddo + f = float(cfov)/(max(1,n)) +! cloud-top pressure is sorted high cld to clear + nm1 = n-1 + do 10 i=1,nm1 + ip1 = i+1 + do 10 j=ip1,n + if(p(i)<=p(j)) goto 10 + temp = p(i) + p(i) = p(j) + p(j) = temp + iold = is(i) + is(i) = is(j) + is(j) = iold + 10 continue + return +end subroutine sortmed diff --git a/src/GSD/gsdcloud4nmmb/map_ctp_lar.f90 b/src/GSD/gsdcloud4nmmb/map_ctp_lar.f90 new file mode 100644 index 0000000000..329b4de0bd --- /dev/null +++ b/src/GSD/gsdcloud4nmmb/map_ctp_lar.f90 @@ -0,0 +1,256 @@ +subroutine map_ctp_lar(ib,jb,nx,ny,nn_obs,numsao,data_s,sat_ctp,sat_tem,w_frac,w_lwp,nlev_cld) + +! +!$$$ subprogram documentation block +! . . . . +! subprogram: map_ctp_lar map Langley cloud product to analysis grid +! +! PRGMMR: Shun Liu ORG: GSD/AMB DATE: 2006-03_10 +! +! ABSTRACT: +! This subroutine map Langley cloud product to analysis grid, copy from map_ctp +! +! PROGRAM HISTORY LOG: +! 2009-01-20 Hu Add NCO document block +! +! +! input argument list: +! ib - begin i point of this domain +! jb - begin j point of this domain +! nx - no. of lons on subdomain (buffer points on ends) +! ny - no. of lats on subdomain (buffer points on ends) +! nn_obs - 1st dimension of observation arry data_s +! numsao - number of observation +! data_s - observation array for GOES cloud products +! +! output argument list: +! sat_ctp - GOES cloud top pressure in analysis grid +! sat_tem - GOES cloud top temperature in analysis grid +! w_frac - GOES cloud coverage in analysis grid +! +! USAGE: +! INPUT FILES: +! +! OUTPUT FILES: +! +! REMARKS: +! +! adapted according to RUC subroutine rd_cld +! * +! * This routine reads NESDIS (Madison, WI) cloud product produced +! * from GOES sounder data. The original product is reprocessed onto +! * MAPS40 grid boxes. There could be more than one cloud product +! * in a grid-box, so we use the nearest one that falls in the +! * grid. The routine combines GOES-8 and 10 products. +! +! ===== History ===== +! +! * Internal variables: +! CTP_E, CTP_W Soft-linked filename for ascii GOES Clouds +! +! * Working variables: +! +! * Working variables used for sorting max size of 10: +! Pxx, Txx, xdist,xxxdist (R4) +! Fxx, Nxx, index, jndex (I4) +! ioption (I4) = 1 if selection is nearest neighbor +! = 2 if selection is median of samples +! +! +! * Output variables on gridpoint (Nx,Ny): +! sat_ctp, sat_tem (R4) Cloud-top pressure and temperature +! w_frac (R4) Effective fractional cloud coverage, option=1 +! fractional coverage within RUC grid, option=2 +! w_eca (R4) Effective fractional cloud regardless option +! (effective cloud amount - eca) +! nlev_cld (I4) Number of cloud levels. TO BE USED LATER +! to incorporate multi-level cloud +! +! * Calling routines +! sorting +! sortmed +! +! * +! +! ATTRIBUTES: +! LANGUAGE: FORTRAN 90 +! MACHINE: Linux cluster (WJET) +! +!$$$ +! +!_____________________________________________________________________ +! + + use kinds, only: r_kind,r_single,i_kind + use constants, only: zero,one_tenth,one,deg2rad + + implicit none + +! input-file variables: + INTEGER(i_kind),intent(in) :: Nx, Ny + INTEGER(i_kind),intent(in) :: ib, jb + INTEGER(i_kind),intent(in) :: numsao, nn_obs + real(r_kind),dimension(nn_obs,numsao):: data_s +! Output + real(r_single), intent(out) :: sat_ctp(Nx,Ny) + real(r_single), intent(out) :: sat_tem(Nx,Ny) + real(r_single), intent(out) :: w_lwp(Nx,Ny) + real(r_single), intent(out) :: w_frac(Nx,Ny) +! +! misc + integer(i_kind) :: nfov + parameter (nfov=650) + + character header*80 +! Working + real(r_kind) :: Pxx(Nx,Ny,nfov),Txx(Nx,Ny,nfov) + real(r_kind) :: PHxx(Nx,Ny,nfov),WPxx(Nx,Ny,nfov) + real(r_kind) :: xdist(Nx,Ny,nfov), xxxdist(nfov) + real(r_kind) :: fr,sqrt, qc, type + integer(i_kind) :: Nxx(Nx,Ny,nfov),index(Nx,Ny), jndex(nfov) + integer(i_kind) :: ioption + integer(i_kind) :: ipt,ixx,ii,jj,i,med_pt,igrid,jgrid & + ,ncount,ncount1,ncount2,ii1,jj1,nobs,n + + real(r_kind) :: xc + real(r_kind) :: yc + + real(r_single) :: w_eca(Nx,Ny) + integer(i_kind) :: nlev_cld(Nx,Ny) + integer(i_kind) :: ios,cfov + +! +! * Initialize outputs since GOES sounder do not scan all MAPS domain +! + do jj=1,Ny + do ii=1,Nx + sat_ctp (ii,jj) =-99999._r_kind + sat_tem (ii,jj) =-99999._r_kind + w_lwp (ii,jj) =-99999._r_kind + w_frac (ii,jj) =-99999._r_kind + nlev_cld (ii,jj) =-99999 + index(ii,jj) = 0 + enddo + enddo + +! -- set ios as failed unless valid data points are found below + ios = 0 + +! ----------------------------------------------------------- +! ----------------------------------------------------------- +! Map each FOV onto RR grid points +! ----------------------------------------------------------- +! ----------------------------------------------------------- + do ipt=1,numsao + + xc=data_s(2,ipt) - ib + 1.0_r_kind + yc=data_s(3,ipt) - jb + 1.0_r_kind +! write(6,*)'sat_tem::',data_s(2,ipt),data_s(3,ipt),ib,jb + if(data_s(8,ipt) > 650 ) cycle + +! * XC,YC should be within subdomain boundary, i.e., XC,YC >0 + + if(XC >= 1._r_kind .and. XC < Nx .and. & + YC >= 1._r_kind .and. YC < Ny) then + ii1 = int(xc+0.5_r_kind) + jj1 = int(yc+0.5_r_kind) + + do jj = max(1,jj1-2), min(ny,jj1+2) + if (jj1-1 >= 1 .and. jj1+1 <= ny) then + do ii = max(1,ii1-2), min(nx,ii1+2) + if (ii1-1 >= 1 .and. ii1+1 <= nx) then + +! * We check multiple data within gridbox + + if (index(ii,jj) < nfov) then + index(ii,jj) = index(ii,jj) + 1 + + Pxx(ii,jj,index(ii,jj)) = data_s(4,ipt) + Txx(ii,jj,index(ii,jj)) = data_s(5,ipt) + PHxx(ii,jj,index(ii,jj)) = data_s(6,ipt) + WPxx(ii,jj,index(ii,jj)) = data_s(7,ipt) +!mhu Nxx(ii,jj,index(ii,jj)) = int(data_s(5,ipt)) +!mhu no cloud amount available, assign to 100 +! Nxx(ii,jj,index(ii,jj)) = 100 + nlev_cld(ii,jj) = 1 +! write(6,*)'sat_tem1::',index(ii,jj),data_s(4,ipt),data_s(5,ipt),data_s(6,ipt),data_s(7,ipt) + xdist(ii,jj,index(ii,jj)) = sqrt( & + (XC+1-ii)**2 + (YC+1-jj)**2) + end if + endif + enddo ! ii + endif + enddo ! jj + endif ! observation is in the domain + enddo ! ipt +! +! * ioption = 1 is nearest neighrhood +! * ioption = 2 is median of cloudy fov + ioption = 2 +! + do jj = 1,Ny + do ii = 1,Nx + if (index(ii,jj) < 3 ) then +! sat_ctp(ii,jj) = Pxx(ii,jj,1) +! sat_tem(ii,jj) = Txx(ii,jj,1) +! w_frac(ii,jj) = float(Nxx(ii,jj,1))/100. +! w_eca(ii,jj) = float(Nxx(ii,jj,1))/100. + + elseif(index(ii,jj) >= 3) then + +! * We decided to use nearest neighborhood for ECA values, +! * a kind of convective signal from GOES platform... + + do i=1,index(ii,jj) + jndex(i) = i + xxxdist(i) = xdist(ii,jj,i) + enddo + call sorting(xxxdist,index(ii,jj),jndex) +! w_eca(ii,jj) = float(Nxx(ii,jj,jndex(1)))/100._r_kind +! * Sort to find closest distance if more than one sample +! if(ioption == 1) then !nearest neighborhood +! do i=1,index(ii,jj) +! jndex(i) = i +! xxxdist(i) = xdist(ii,jj,i) +! enddo +! call sorting(xxxdist,index(ii,jj),jndex) +! sat_ctp(ii,jj) = Pxx(ii,jj,jndex(1)) +! sat_tem(ii,jj) = Txx(ii,jj,jndex(1)) +! w_frac(ii,jj) = float(Nxx(ii,jj,jndex(1)))/100._r_kind +! endif +! * Sort to find median value + if(ioption == 2) then !pick median + do i=1,index(ii,jj) + jndex(i) = i + xxxdist(i) = Pxx(ii,jj,i) + enddo + call sortmed(xxxdist,index(ii,jj),jndex,fr) + med_pt = index(ii,jj)/2 + 1 + sat_ctp(ii,jj) = Pxx(ii,jj,jndex(med_pt)) + sat_tem(ii,jj) = Txx(ii,jj,jndex(med_pt)) + w_lwp(ii,jj) = WPxx(ii,jj,jndex(med_pt)) + if (sat_ctp(ii,jj).eq.-20) then + sat_ctp(ii,jj) = 1013. ! hPa - no cloud + w_frac(ii,jj)=0.0 + nlev_cld(ii,jj) = 0 + end if + +! +! cloud fraction based on phase (0 are clear), what about -9 ???? + if( sat_ctp(ii,jj) < 1012.99) then + cfov = 0 + do i=1,index(ii,jj) + if(PHxx(ii,jj,i) .gt. 0.1) cfov = cfov + 1 + enddo + w_frac(ii,jj) = float(cfov)/(max(1,index(ii,jj))) ! fraction + if( w_frac(ii,jj) > 0.01 ) nlev_cld(ii,jj) = 1 + endif + +! write(6,*)'sat_tem2::',index(ii,jj),sat_ctp(ii,jj),sat_tem(ii,jj) + endif + endif + enddo !ii + enddo !jj + + return +end subroutine map_ctp_lar diff --git a/src/GSD/gsdcloud4nmmb/mthermo.f90 b/src/GSD/gsdcloud4nmmb/mthermo.f90 new file mode 100755 index 0000000000..3388a5228a --- /dev/null +++ b/src/GSD/gsdcloud4nmmb/mthermo.f90 @@ -0,0 +1,229 @@ +! +!$$$ subprogram documentation block +! . . . . +! ABSTRACT: +! This file collects subroutines and functions related to thermodynamic calculations +! +! PROGRAM HISTORY LOG: +! 2009-01-20 Hu Add NCO document block +! 2010-05-03 Hu Clean the code +! +! +! input argument list: +! +! output argument list: +! +! USAGE: +! INPUT FILES: +! +! OUTPUT FILES: +! +! REMARKS: +! +! ATTRIBUTES: +! LANGUAGE: FORTRAN 90 +! MACHINE: Linux cluster (WJET) +! +!$$$ +! +!_____________________________________________________________________ +! + FUNCTION esat(t) +! +! this function returns the saturation vapor pressure over +! water (mb) given the temperature (celsius). +! the algorithm is due to nordquist, w.s.,1973: "numerical approxima- +! tions of selected meteorlolgical parameters for cloud physics prob- +! lems," ecom-5475, atmospheric sciences laboratory, u.s. army +! electronics command, white sands missile range, new mexico 88002. + use kinds, only: r_single,i_kind,r_kind + implicit none + real(r_kind),intent(in) :: t + real(r_single) :: tk,p1,p2,c1 + real(r_kind) :: esat + + tk = t+273.15 + p1 = 11.344-0.0303998*tk + p2 = 3.49149-1302.8844/tk + c1 = 23.832241-5.02808*ALOG10(tk) + esat = 10.**(c1-1.3816E-7*10.**p1+8.1328E-3*10.**p2-2949.076/tk) + RETURN + END FUNCTION esat + + FUNCTION eslo(t) +! +! this function returns the saturation vapor pressure over liquid +! water eslo (millibars) given the temperature t (celsius). the +! formula is due to lowe, paul r.,1977: an approximating polynomial +! for the computation of saturation vapor pressure, journal of applied +! meteorology, vol 16, no. 1 (january), pp. 100-103. +! the polynomial coefficients are a0 through a6. + use kinds, only: r_single,i_kind,r_kind + IMPLICIT NONE +! + real(r_kind), intent(in) :: t + real(r_kind) :: eslo + + real(r_kind) :: a0,a1,a2,a3,a4,a5,a6 + real(r_kind) :: es + + DATA a0,a1,a2,a3,a4,a5,a6 & + /6.107799961, 4.436518521E-01, 1.428945805E-02, & + 2.650648471E-04, 3.031240396E-06, 2.034080948E-08, & + 6.136820929E-11/ + es = a0+t*(a1+t*(a2+t*(a3+t*(a4+t*(a5+a6*t))))) + IF (es < 0.) es = 0. + eslo = es + RETURN + END FUNCTION eslo + + FUNCTION tda(o,p) +! +! this function returns the temperature tda (celsius) on a dry adiabat +! at pressure p (millibars). the dry adiabat is given by +! potential temperature o (celsius). the computation is based on +! poisson's equation. + use kinds, only: r_single,i_kind,r_kind + implicit none + real(r_kind), intent(in) :: o,p + real(r_kind) :: tda + + tda= (o+273.15)*((p*.001)**.286)-273.15 + RETURN + END FUNCTION tda + + FUNCTION tmr(w,p) +! +! this function returns the temperature (celsius) on a mixing +! ratio line w (g/kg) at pressure p (mb). the formula is given in +! table 1 on page 7 of stipanuk (1973). +! +! initialize constants + use kinds, only: r_single,i_kind,r_kind + implicit none + real(r_kind), intent(in) :: w,p + real(r_kind) :: tmr + + real(r_kind) :: c1,c2,c3,c4,c5,c6 + real(r_kind) :: x,tmrk + real(r_single) :: y + + DATA c1/.0498646455/,c2/2.4082965/,c3/7.07475/ + DATA c4/38.9114/,c5/.0915/,c6/1.2035/ + + y=w*p/(622.+w) + x= alog10(y) + tmrk= 10.**(c1*x+c2)-c3+c4*((10.**(c5*x)-c6)**2.) + tmr= tmrk-273.15 + RETURN + END FUNCTION tmr + + FUNCTION tsa(os,p) +! +! this function returns the temperature tsa (celsius) on a saturation +! adiabat at pressure p (millibars). os is the equivalent potential +! temperature of the parcel (celsius). sign(a,b) replaces the +! algebraic sign of a with that of b. +! b is an empirical constant approximately equal to 0.001 of the latent +! heat of vaporization for water divided by the specific heat at constant +! pressure for dry air. + use kinds, only: r_single,i_kind,r_kind + implicit none + real(r_kind), intent(in) :: os,p + real(r_kind) :: tsa + + real(r_kind) :: a,b,d,tq,x,tqk,w + integer :: i + + DATA b/2.6518986/ + a= os+273.15 + +! tq is the first guess for tsa. + + tq= 253.15 + +! d is an initial value used in the iteration below. + + d= 120. + +! iterate to obtain sufficient accuracy....see table 1, p.8 +! of stipanuk (1973) for equation used in iteration. + + DO i= 1,12 + tqk= tq-273.15 + d= d/2. + x= a*EXP(-b*w(tqk,p)/tq)-tq*((1000./p)**.286) + IF (ABS(x) < 1E-7) GOTO 2 + tq= tq+SIGN(d,x) + END DO +2 tsa= tq-273.15 + RETURN + END FUNCTION tsa + + FUNCTION tw(t,td,p) +! this function returns the wet-bulb temperature tw (celsius) +! given the temperature t (celsius), dew point td (celsius) +! and pressure p (mb). see p.13 in stipanuk (1973), referenced +! above, for a description of the technique. +! +! +! determine the mixing ratio line thru td and p. + use kinds, only: r_single,i_kind,r_kind + implicit none + real(r_kind), intent(in) :: t,td,p + real(r_kind) :: tw + + real(r_kind) :: aw,ao,pi,tmr,tda,ti,aos,tsa,w,x + integer :: i + + aw = w(td,p) +! +! determine the dry adiabat thru t and p. + + ao = (t+273.15)*((1000./p)**.286)-273.15 + pi = p + +! iterate to locate pressure pi at the intersection of the two +! curves . pi has been set to p for the initial guess. + + DO i= 1,10 + x= .02*(tmr(aw,pi)-tda(ao,pi)) + IF (ABS(x) < 0.01) EXIT + pi= pi*(2.**(x)) + END DO + +! find the temperature on the dry adiabat ao at pressure pi. + + ti= tda(ao,pi) + +! the intersection has been located...now, find a saturation +! adiabat thru this point. function os returns the equivalent +! potential temperature (c) of a parcel saturated at temperature +! ti and pressure pi. + + aos= (ti+273.15)*((1000./pi)**.286)*(EXP(2.6518986*w(ti,pi)/(ti+273.15)))-273.15 + +! function tsa returns the wet-bulb temperature (c) of a parcel at +! pressure p whose equivalent potential temperature is aos. + + tw = tsa(aos,p) + RETURN + END FUNCTION tw + + FUNCTION w(t,p) +! +! this function returns the mixing ratio (grams of water vapor per +! kilogram of dry air) given the dew point (celsius) and pressure +! (millibars). if the temperture is input instead of the +! dew point, then saturation mixing ratio (same units) is returned. +! the formula is found in most meteorological texts. + use kinds, only: r_single,i_kind,r_kind + implicit none + real(r_kind), intent(in) :: t,p + real(r_kind) :: w + + real(r_kind) :: esat + + w= 622.*esat(t)/(p-esat(t)) + RETURN + END FUNCTION w diff --git a/src/GSD/gsdcloud4nmmb/pbl_height.f90 b/src/GSD/gsdcloud4nmmb/pbl_height.f90 new file mode 100755 index 0000000000..6466899f01 --- /dev/null +++ b/src/GSD/gsdcloud4nmmb/pbl_height.f90 @@ -0,0 +1,103 @@ +SUBROUTINE calc_pbl_height(mype,nlat,nlon,nsig,q_bk,t_bk,p_bk,pblh) +! +!$$$ subprogram documentation block +! . . . . +! subprogram: pbl_height to calculate PBL height or level +! +! PRGMMR: Ming Hu ORG: GSD/AMB DATE: 2011-04-06 +! +! ABSTRACT: +! This subroutine calculate PBL height +! +! PROGRAM HISTORY LOG: +! +! +! input argument list: +! nlon - no. of lons on subdomain (buffer points on ends) +! nlat - no. of lats on subdomain (buffer points on ends) +! nsig - no. of levels +! q_bk - 3D moisture +! t_bk - 3D background potential temperature (K) +! p_bk - 3D background pressure (hPa) +! +! output argument list: +! pblh - 2D PBL height (level number) +! +! USAGE: +! INPUT FILES: +! +! OUTPUT FILES: +! +! REMARKS: +! +! ATTRIBUTES: +! LANGUAGE: FORTRAN 90 +! MACHINE: Linux cluster (WJET) +! +!$$$ +! +!_____________________________________________________________________ +! + + use kinds, only: r_single,i_kind, r_kind + + implicit none + + integer(i_kind),intent(in):: mype + integer(i_kind),intent(in):: nlat,nlon,nsig +! +! background +! + real(r_single),intent(in) :: t_bk(nlon,nlat,nsig) ! potential temperature (K) + real(r_single),intent(in) :: q_bk(nlon,nlat,nsig) ! mixing ratio (kg/kg) + real(r_single),intent(in) :: p_bk(nlon,nlat,nsig) ! pressure (hpa) +! +! Variables for cloud analysis +! + real (r_single),intent(out) :: pblh(nlon,nlat) +! +!----------------------------------------------------------- +! +! temp. +! + INTEGER(i_kind) :: i,j,k + real(r_single) :: thetav(nsig) + real(r_single) :: thsfc,qsp + +!==================================================================== +! Begin +! +! + DO j = 1,nlat + DO i = 1,nlon + + DO k = 1,nsig + qsp=q_bk(i,j,k)/(1.0+q_bk(i,j,k)) ! q_bk = water vapor mixing ratio + thetav(k) = t_bk(i,j,k)*(1.0 + 0.61 * qsp) ! qsp = spcific humidity +! if(mype==10.and.i==10.and.j==10) then +! write(*,*) 'cal PBL=',k,thetav(k),t_bk(i,j,k),q_bk(i,j,k) +! endif + ENDDO + + pblh(i,j) = 0.0_r_single + thsfc = thetav(1) + k=1 + DO while (abs(pblh(i,j)) < 0.0001_r_single) + if( thetav(k) > thsfc + 1.0_r_single ) then + pblh(i,j) = float(k) - (thetav(k) - (thsfc + 1.0_r_single))/ & + max((thetav(k)-thetav(k-1)),0.01_r_single) + endif + k=k+1 + ENDDO + if(abs(pblh(i,j)) < 0.0001) pblh(i,j)=2.0_r_single + +! if(mype==10.and.i==10.and.j==10) then +! write(*,*) 'cal PBL=',pblh(i,j),k +! endif + + + enddo ! i + enddo ! j + +END SUBROUTINE calc_pbl_height + diff --git a/src/GSD/gsdcloud4nmmb/pcp_mxr_ARPSlib.f90 b/src/GSD/gsdcloud4nmmb/pcp_mxr_ARPSlib.f90 new file mode 100755 index 0000000000..2548e943b7 --- /dev/null +++ b/src/GSD/gsdcloud4nmmb/pcp_mxr_ARPSlib.f90 @@ -0,0 +1,757 @@ + +SUBROUTINE pcp_mxr (nx,ny,nz,t_3d,p_3d ,ref_3d & + ,cldpcp_type_3d & + ,qr_3d,qs_3d,qg_3d,istatus ) + +! +!$$$ subprogram documentation block +! . . . . +! subprogram: pcp_mxr calculates hydrometeor mixing ratios based on Kessler radar reflectivity equations +! +! PRGMMR: ORG: DATE: +! +! ABSTRACT: +! This subroutine calculate precipitation based on Kessler radar reflectivity equations +! +! PROGRAM HISTORY LOG: +! 2009-01-20 Hu Add NCO document block +! +! +! input argument list: +! nx - no. of lons on subdomain (buffer points on ends) +! ny - no. of lats on subdomain (buffer points on ends) +! nz - no. of levels +! t_3d - 3D background temperature (K) +! p_3d - 3D background pressure (hPa) +! ref_3d - 3D reflectivity in analysis grid (dBZ) +! cldpcp_type_3d - 3D precipitation type +! +! output argument list: +! qr_3d - rain mixing ratio (g/kg) +! qs_3d - snow mixing ratio (g/kg) +! qg_3d - graupel/hail mixing ratio (g/kg) +! istatus - +! +! USAGE: +! INPUT FILES: +! +! OUTPUT FILES: +! +! REMARKS: +! Old documents from CAPS +! +!----------------------------------------------------------------------- +! +! PURPOSE: +! +! Perform 3D precipitation mixing ratio (in g/kg) analysis using +! radar reflectivity data. For rain water, using Kessler (1969) +! formula: +! qr(g/kg) = a*(rho*arg)**b (1) +! +! Here arg = Z (mm**6/m**3), and dBZ = 10log10 (arg). +! Coeffcients a=17300.0, and b=7/4. +! rho represents the air density. +! +! For snow and graupel/hail, using Rogers and Yau (1989) formula: +! +! qs(g/kg) = c*(rho*arg)**d (2) +! +! where, c=38000.0, d=2.2 +! +! +!----------------------------------------------------------------------- +! +! AUTHOR: (Jian Zhang) +! 06/13/96 +! +! MODIFICATION HISTORY: +! 07/30/97 (J. Zhang) +! Added precipitation type in the argument list so that +! mixing ratios of different precip. types can be computed. +! 09/04/97 (J. Zhang) +! Changed the radar echo thresholds for inserting precip. +! from radar reflectivities. +! +!----------------------------------------------------------------------- +! ATTRIBUTES: +! LANGUAGE: FORTRAN 90 +! MACHINE: Linux cluster (WJET) +! +!$$$ +! +!_____________________________________________________________________ +! + +! +!----------------------------------------------------------------------- +! +! Variable Declarations. +! +!----------------------------------------------------------------------- +! + use kinds, only: r_single,i_kind, r_kind + IMPLICIT NONE +! +!----------------------------------------------------------------------- +! +! INPUT: + integer(i_kind),intent(in) :: nx,ny,nz ! Model grid size +! + REAL(r_kind), intent(in) :: ref_3d(nx,ny,nz)! radar reflectivity (dBZ) + real(r_single),intent(in) :: t_3d(nx,ny,nz) ! Temperature (deg. Kelvin) + real(r_single),intent(in) :: p_3d(nx,ny,nz) ! Pressure (Pascal) + + integer(i_kind),intent(in):: cldpcp_type_3d(nx,ny,nz) ! cloud/precip type field +! +! OUTPUT: + INTEGER(i_kind),intent(out) :: istatus +! + REAL(r_single),intent(out) :: qr_3d(nx,ny,nz)! rain mixing ratio in (g/kg) + REAL(r_single),intent(out) :: qs_3d(nx,ny,nz)! snow/sleet/frz-rain mixing ratio + ! in (g/kg) + REAL(r_single),intent(out) :: qg_3d(nx,ny,nz)! graupel/hail mixing ratio in (g/kg) +! +! LOCAL: + REAL(r_kind) :: a,b,c,d ! Coef. for Z-qr relation. + PARAMETER (a=17300.0_r_kind, b=7.0/4.0_r_kind) + PARAMETER (c=38000.0_r_kind, d=2.2_r_kind) + REAL(r_kind) :: rair ! Gas constant (J/deg/kg) + PARAMETER (rair = 287.04_r_kind) + REAL(r_kind) :: thresh_ref + PARAMETER (thresh_ref = 0.0_r_kind) + INTEGER(i_kind) :: pcptype +! +!----------------------------------------------------------------------- +! +! Misc local variables +! +!----------------------------------------------------------------------- +! + INTEGER(i_kind) :: i,j,k, iarg + REAL(r_kind) :: arg,rhobar,br,dr + PARAMETER (br=1.0_r_kind/b, dr=1.0_r_kind/d) +! +!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ +! +! Beginning of executable code... +! +!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ +! +! +!----------------------------------------------------------------------- +! + istatus=0 +! +!----------------------------------------------------------------------- +! +! Compute the precip mixing ratio in g/kg from radar reflectivity +! factor following Kessler (1969) or Rogers and Yau (1989). +! +!----------------------------------------------------------------------- +! + DO k = 1,nz-1 + DO j = 2,ny-1 + DO i = 2,nx-1 + IF (ref_3d(i,j,k) >= thresh_ref) THEN ! valid radar refl. + rhobar = p_3d(i,j,k)/rair/t_3d(i,j,k) + arg = 10.0_r_kind**(0.1_r_kind*ref_3d(i,j,k)) + iarg = cldpcp_type_3d(i,j,k) + pcptype = iarg/16 ! precip. type + + IF (pcptype == 0) THEN ! no precip + PRINT*,'+++ NOTE: radar echo though no precip. +++' + ELSE IF (pcptype == 1.OR.pcptype == 3) THEN ! rain or Z R + qr_3d(i,j,k) = (arg/a)**br/rhobar + ELSE IF (pcptype == 2) THEN ! snow + qs_3d(i,j,k) = (arg/c)**dr/rhobar + ELSE IF (pcptype == 4.OR.pcptype == 5) THEN ! hail or sleet + qg_3d(i,j,k) = (arg/c)**dr/rhobar + ELSE ! unknown + PRINT*,'+++ NOTE: unknown precip type. +++' + END IF + ELSE + qr_3d(i,j,k) = 0._r_kind + qs_3d(i,j,k) = 0._r_kind + qg_3d(i,j,k) = 0._r_kind + END IF + END DO ! k + END DO ! i + END DO ! j +! +!----------------------------------------------------------------------- +! + istatus = 1 +! + RETURN +END SUBROUTINE pcp_mxr + +! +SUBROUTINE pcp_mxr_ferrier_new (nx,ny,nz,t_3d,p_3d ,ref_3d & + ,cldpcp_type_3d,q_3d & + ,qr_3d,qs_3d,qg_3d,istatus ) +! +!$$$ subprogram documentation block +! . . . . +! subprogram: pcp_mxr calculate hydrometeor type based on ferrier radar reflectivity equations +! from Carley's setup_dbz.f90 and old Hu's pcp_mxr_ferrier +! +! PRGMMR: Shun Liu ORG: EMC/NCEP DATE: +! +! ABSTRACT: +! This subroutine calculate precipitation based on ferrier radar reflectivity equations +! +! PROGRAM HISTORY LOG: +! 2014-12-01 Shun Liu create for new NMMB ferrier +! +! +! input argument list: +! nx - no. of lons on subdomain (buffer points on ends) +! ny - no. of lats on subdomain (buffer points on ends) +! nz - no. of levels +! t_3d - 3D background temperature (K) +! p_3d - 3D background pressure (hPa) +! ref_3d - 3D reflectivity in analysis grid (dBZ) +! cldpcp_type_3d - 3D precipitation type +! +! output argument list: +! qr_3d - rain mixing ratio (g/kg) +! qs_3d - snow mixing ratio (g/kg) +! istatus - +! +! USAGE: +! INPUT FILES: +! +! OUTPUT FILES: +! +! REMARKS: +! Old document from CAPS +!----------------------------------------------------------------------- +!----------------------------------------------------------------------- +! +! PURPOSE: +! +! Perform 3D precipitation mixing ratio (in g/kg) analysis using +! radar reflectivity data. For rain water, using Ferrier et al (1995) +! formulation: +! +! +! For rain water: +! +! 18 +! 10 * 720 1.75 +! Zer = --------------------------- * (rho * qr) +! 1.75 0.75 1.75 +! pi * N0r * rhor +! +! +! For dry snow (t <= 0 C): +! +! +! 18 +! 0.224 * 10 * 720 +! 2 +! Zes = ------------------------------------- * (rho * qs) +! 2 2 +! pi * rhol * N0s +! +! n(0)r -> intercept parameter for rain 8x10^-6 (m^-4) +! rho_l -> density of liquid water 1000 (kg/m^3) +! rho -> air density (kg/m^3) +! qr -> rain mixing ratio (kg/kg) +! qli -> precipitation ice mixing ratio (kg/kg) +! N_li -> precipitation ice number concentration 5x10^3 (m^-3) +! +! +! Plugging in the constants yields the following form: +! +! Zer = Cr * (rho*qr)^1.75 +! Zeli = Cli * (rho*qli)^2 +! +! where: +! Cr = 3.6308 * 10^9 +! Cli = 3.268 * 10^9 +! +! Which yields the forward model: +! +! Z = 10*log10(Zer+Zes) +! +! +! Here Zx (mm**6/m**3, x=r,s,h), and dBZ = 10log10 (Zx). +! rho represents the air density, rhor,rhos,rhoh are the density of +! rain, snow and hail respectively. Other variables are all constants +! for this scheme, see below. +! +! Zer = Cr * (rho*qr)^1.75 +! Zeli = Cli * (rho*qli)^2 +! +! where: +! Cr = 3.6308 * 10^9 +! Cli = 3.268 * 10^9 + +! (Zer)^(1/1.75)=(rho*qr) +! (Zer/Cr)^(1/1.75)=rho*qr +! [(Zer/Cr)^(1/1.75)]/rho=qr + +! [(Zeli/Cli)^(1/2)]/rho=qs + +! +!----------------------------------------------------------------------- +! +! AUTHOR: (Shun Liu) +! 01/20/2015 +! +! MODIFICATION HISTORY: +! +!----------------------------------------------------------------------- +! ATTRIBUTES: +! LANGUAGE: FORTRAN 90 +! MACHINE: Linux cluster (WJET) +! +!$$$ +! +!_____________________________________________________________________ +! + + +!----------------------------------------------------------------------- +! +! Variable Declarations. +! +!----------------------------------------------------------------------- +! + use kinds, only: r_single,i_kind, r_kind + IMPLICIT NONE +! +!----------------------------------------------------------------------- +! +! INPUT: + INTEGER(i_kind),intent(in) :: nx,ny,nz ! Model grid size +! + REAL(r_kind), intent(in) :: ref_3d(nx,ny,nz)! radar reflectivity (dBZ) + REAL(r_single), intent(in) :: t_3d(nx,ny,nz) ! Temperature (deg. Kelvin) + REAL(r_single), intent(in) :: p_3d(nx,ny,nz) ! Pressure (Pascal) + REAL(r_single), intent(in) :: q_3d(nx,ny,nz) ! mixing ratio in (g/g) + + INTEGER(i_kind),intent(in) :: cldpcp_type_3d(nx,ny,nz) ! cloud/precip type field +! +! OUTPUT: + INTEGER(i_kind),intent(out):: istatus +! + REAL(r_single),intent(out) :: qr_3d(nx,ny,nz) ! rain mixing ratio in (g/kg) + REAL(r_single),intent(out) :: qs_3d(nx,ny,nz) ! snow/sleet/frz-rain mixing ratio + ! in (g/kg) + REAL(r_single),intent(out) :: qg_3d(nx,ny,nz) ! graupel/hail mixing ratio + ! in (g/kg) +! + + + + REAL(r_kind), PARAMETER :: rd=287.0_r_kind ! Gas constant for dry air (m**2/(s**2*K)) + REAL(r_kind), PARAMETER :: thresh_ref = 0.0_r_kind + + REAL(r_kind), PARAMETER :: ze_qr_const=3.6308*1.0e9 + REAL(r_kind), PARAMETER :: ze_qs_const=3.268*1.0e9 + REAL(r_kind) :: ze_d_qrcon,ze_d_qscon + +! +!----------------------------------------------------------------------- +! +! Misc local variables +! +!----------------------------------------------------------------------- +! + INTEGER(i_kind) :: i,j,k, iarg + INTEGER(i_kind) :: pcptype + REAL(r_kind) :: zkconst,zerf,zesnegf,zesposf,zehf,rfract + REAL(r_kind) :: ze,zer,zeh,zes,rho,tc + +! +!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ +! +! Beginning of executable code... +! +!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ +! +! +!----------------------------------------------------------------------- +! +! Intiailize constant factors in the Ze terms for rain, snow and graupel/hail, +! respectively, in Ferrier. +! +! These are the inverse of those presented in the reflec_ferrier function. +! +!----------------------------------------------------------------------- +! +!----------------------------------------------------------------------- +! +! Compute the precip mixing ratio in g/kg from radar reflectivity +! factor following Ferrier et al (1995). +! +!----------------------------------------------------------------------- +! + +! qr_3d = -999._r_kind +! qs_3d = -999._r_kind + qg_3d = -999._r_kind + + DO k = 2,nz-1 + DO j = 2,ny-1 + DO i = 2,nx-1 + IF (ref_3d(i,j,k) >= thresh_ref) THEN ! valid radar refl. + rho = p_3d(i,j,k)/(rd*t_3d(i,j,k))*(1.0+0.608*(q_3d(i,j,k)/1.0+q_3d(i,j,k))) + ze = 10.0_r_kind**(0.1_r_kind*ref_3d(i,j,k)) + tc = t_3d(i,j,k) - 273.15_r_kind + IF (tc >= 0.0_r_kind) THEN + ze_d_qrcon=ze/ze_qr_const + qr_3d(i,j,k) = (ze_d_qrcon)**(1/1.75) !/ rho + else + ze_d_qscon=ze/ze_qs_const + qs_3d(i,j,k) = (ze_d_qscon)**(0.5) !/ rho + ENDIF + END IF + END DO ! k + END DO ! i + END DO ! j + +! qr_3d=qr_3d*1000.0 !kg/kg to g/kg +! qs_3d=qs_3d*1000.0 !kg/kg to g/kg + +! PRINT*,'Finish Ferrier ...' +! +!----------------------------------------------------------------------- +! + istatus = 1 +! + RETURN +END SUBROUTINE pcp_mxr_ferrier_new + +! +SUBROUTINE pcp_mxr_ferrier (nx,ny,nz,t_3d,p_3d ,ref_3d & + ,cldpcp_type_3d & + ,qr_3d,qs_3d,qg_3d,istatus,mype ) +! +!$$$ subprogram documentation block +! . . . . +! subprogram: pcp_mxr calculate hydrometeor type based on ferrier radar reflectivity equations +! +! PRGMMR: ORG: DATE: +! +! ABSTRACT: +! This subroutine calculate precipitation based on ferrier radar reflectivity equations +! +! PROGRAM HISTORY LOG: +! 2009-01-20 Hu Add NCO document block +! +! +! input argument list: +! nx - no. of lons on subdomain (buffer points on ends) +! ny - no. of lats on subdomain (buffer points on ends) +! nz - no. of levels +! t_3d - 3D background temperature (K) +! p_3d - 3D background pressure (hPa) +! ref_3d - 3D reflectivity in analysis grid (dBZ) +! cldpcp_type_3d - 3D precipitation type +! +! output argument list: +! qr_3d - rain mixing ratio (g/kg) +! qs_3d - snow mixing ratio (g/kg) +! qg_3d - graupel/hail mixing ratio (g/kg) +! istatus - +! +! USAGE: +! INPUT FILES: +! +! OUTPUT FILES: +! +! REMARKS: +! Old document from CAPS +!----------------------------------------------------------------------- +!----------------------------------------------------------------------- +! +! PURPOSE: +! +! Perform 3D precipitation mixing ratio (in g/kg) analysis using +! radar reflectivity data. For rain water, using Ferrier et al (1995) +! formulation: +! +! +! For rain water: +! +! 18 +! 10 * 720 1.75 +! Zer = --------------------------- * (rho * qr) +! 1.75 0.75 1.75 +! pi * N0r * rhor +! +! +! For dry snow (t <= 0 C): +! +! +! 18 2 0.25 +! 10 * 720 * |K| * rhos +! ice 1.75 +! Zes = ----------------------------------------- * (rho * qs) t <= 0 C +! 1.75 2 0.75 2 +! pi * |K| * N0s * rhoi +! water +! +! +! For wet snow (t >= 0 C): +! +! +! 18 +! 10 * 720 1.75 +! Zes = ---------------------------- * (rho * qs) t > 0 C +! 1.75 0.75 1.75 +! pi * N0s * rhos +! +! +! For hail water: +! +! +! / 18 \ 0.95 +! / 10 * 720 \ 1.6625 +! Zeh = | ---------------------------- | * (rho * qg) +! \ 1.75 0.75 1.75 / +! \ pi * N0h * rhoh / +! +! Here Zx (mm**6/m**3, x=r,s,h), and dBZ = 10log10 (Zx). +! rho represents the air density, rhor,rhos,rhoh are the density of +! rain, snow and hail respectively. Other variables are all constants +! for this scheme, see below. +! +! +!----------------------------------------------------------------------- +! +! AUTHOR: (Donghai Wang and Eric Kemp) +! 07/20/2000 +! +! MODIFICATION HISTORY: +! +! 11/09/2000 Keith Brewster +! Moved some parameters with real-valued exponentiation to be +! computed at runtime due to compiler complaint. +! +! 04/07/2003 Keith Brewster +! Restructured code to make more tractable.and consistent with +! the reflec_ferrier subroutine. +! +!----------------------------------------------------------------------- +! ATTRIBUTES: +! LANGUAGE: FORTRAN 90 +! MACHINE: Linux cluster (WJET) +! +!$$$ +! +!_____________________________________________________________________ +! + + +!----------------------------------------------------------------------- +! +! Variable Declarations. +! +!----------------------------------------------------------------------- +! + use kinds, only: r_single,i_kind, r_kind + IMPLICIT NONE +! +!----------------------------------------------------------------------- +! +! INPUT: + INTEGER(i_kind),intent(in) :: nx,ny,nz ! Model grid size +! + REAL(r_kind), intent(inout) :: ref_3d(nx,ny,nz)! radar reflectivity (dBZ) + REAL(r_single), intent(in) :: t_3d(nx,ny,nz) ! Temperature (deg. Kelvin) + REAL(r_single), intent(in) :: p_3d(nx,ny,nz) ! Pressure (Pascal) + + INTEGER(i_kind),intent(in) :: cldpcp_type_3d(nx,ny,nz) ! cloud/precip type field + INTEGER(i_kind),intent(in) :: mype +! +! OUTPUT: + INTEGER(i_kind),intent(out):: istatus +! + REAL(r_single),intent(out) :: qr_3d(nx,ny,nz) ! rain mixing ratio in (g/kg) + REAL(r_single),intent(out) :: qs_3d(nx,ny,nz) ! snow/sleet/frz-rain mixing ratio + ! in (g/kg) + REAL(r_single),intent(out) :: qg_3d(nx,ny,nz) ! graupel/hail mixing ratio + ! in (g/kg) +! + + REAL(r_kind),PARAMETER :: ki2 = 0.176_r_kind ! Dielectric factor for ice if other + ! than melted drop diameters are used. + REAL(r_kind),PARAMETER :: kw2=0.93_r_kind ! Dielectric factor for water. + + REAL(r_kind),PARAMETER :: m3todBZ=1.0E+18_r_kind ! Conversion factor from m**3 to + ! mm**6 m**-3. + REAL(r_kind),PARAMETER :: Zefact=720.0_r_kind ! Multiplier for Ze components. + REAL(r_kind),PARAMETER :: lg10div=0.10_r_kind ! Log10 multiplier (1/10) + + REAL(r_kind),PARAMETER :: pi=3.1415926_r_kind! Pi. + REAL(r_kind),PARAMETER :: N0r=8.0E+06_r_kind ! Intercept parameter in 1/(m^4) for rain. + REAL(r_kind),PARAMETER :: N0s=3.0E+06_r_kind ! Intercept parameter in 1/(m^4) for snow. + REAL(r_kind),PARAMETER :: N0h=4.0E+04_r_kind ! Intercept parameter in 1/(m^4) for graupel/hail. + + REAL(r_kind),PARAMETER :: N0xpowf=3.0/7.0_r_kind ! Power to which N0r,N0s & N0h are + ! raised. + REAL(r_kind),PARAMETER :: K2powf=4.0/7.0_r_kind ! Power to which K-squared + ! of ice, water are raised + REAL(r_kind),PARAMETER :: zkpowf=4.0/7.0_r_kind ! Power to which Zk is raised + REAL(r_kind),PARAMETER :: zepowf=4.0/7.0_r_kind ! Power to which Ze is raised + REAL(r_kind),PARAMETER :: zehpowf=(4.0/7.0)*1.0526_r_kind ! Power to which Zeh is raised + + REAL(r_kind),PARAMETER :: rhoi=917._r_kind ! Density of ice (kg m**-3) + REAL(r_kind),PARAMETER :: rhor=1000._r_kind ! Density of rain (kg m**-3) + REAL(r_kind),PARAMETER :: rhos=100._r_kind ! Density of snow (kg m**-3) + REAL(r_kind),PARAMETER :: rhoh=913._r_kind ! Density of graupel/hail (kg m**-3) + + REAL(r_kind),PARAMETER :: rhoipowf=8.0/7.0_r_kind ! Power to which rhoi is raised. + REAL(r_kind),PARAMETER :: rhospowf=1.0/7.0_r_kind ! Power to which rhos is raised. + + REAL(r_kind), PARAMETER :: rd=287.0_r_kind ! Gas constant for dry air (m**2/(s**2*K)) + REAL(r_kind), PARAMETER :: thresh_ref = 0.0_r_kind +! +!----------------------------------------------------------------------- +! +! Misc local variables +! +!----------------------------------------------------------------------- +! + INTEGER(i_kind) :: i,j,k, iarg + INTEGER(i_kind) :: pcptype + REAL(r_kind) :: zkconst,zerf,zesnegf,zesposf,zehf,rfract + REAL(r_kind) :: ze,zer,zeh,zes,rho,tc + +! +!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ +! +! Beginning of executable code... +! +!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ +! +! +!----------------------------------------------------------------------- +! +! Intiailize constant factors in the Ze terms for rain, snow and graupel/hail, +! respectively, in Ferrier. +! +! These are the inverse of those presented in the reflec_ferrier function. +! +!----------------------------------------------------------------------- +! + istatus=0 + + zkconst = (Zefact*m3todBZ) ** zkpowf + + zerf=1000._r_kind*(pi * (N0r**N0xpowf) * rhor )/zkconst + + zesnegf=1000._r_kind*(pi*(kw2**k2powf)*(N0s**N0xpowf)*(rhoi**rhoipowf)) / & + ( zkconst * (ki2**k2powf) * (rhos**rhospowf) ) + + zesposf=1000._r_kind*( pi * (N0s**N0xpowf) * rhos) / zkconst + + zehf=1000._r_kind*( pi * (N0h**N0xpowf) * rhoh) / zkconst + +!----------------------------------------------------------------------- +! +! Compute the precip mixing ratio in g/kg from radar reflectivity +! factor following Ferrier et al (1995). +! +!----------------------------------------------------------------------- +! +!mhu if(mype==51 ) then +!mhu write(*,*) 'c=',mype,zesnegf,zepowf,rd +!mhu ref_3d(10,10,:)=10.0 +!mhu ref_3d(11,11,:)=20.0 +!mhu ref_3d(12,12,:)=30.0 +!mhu ref_3d(13,13,:)=40.0 +!mhu ref_3d(14,14,:)=50.0 +!mhu endif + + DO k = 2,nz-1 + DO j = 2,ny-1 + DO i = 2,nx-1 + IF (ref_3d(i,j,k) >= thresh_ref) THEN ! valid radar refl. + rho = p_3d(i,j,k)/(rd*t_3d(i,j,k)) + ze = 10.0_r_kind**(0.1_r_kind*ref_3d(i,j,k)) + iarg = cldpcp_type_3d(i,j,k) + pcptype = iarg/16 ! precip. type + tc = t_3d(i,j,k) - 273.15_r_kind +!mhu temporal fix + IF (tc <= 0.0_r_kind) THEN + qs_3d(i,j,k) = zesnegf * (ze**zepowf) / rho + qr_3d(i,j,k) = 0.0_r_kind + ELSE IF (tc < 5.0_r_kind) THEN !wet snow + rfract=0.20_r_kind*tc + zer=rfract*ze + zes=(1.-rfract)*ze +! qs_3d(i,j,k) = zesposf * (zes**zepowf) / rho +! qr_3d(i,j,k) = zerf * (zer**zepowf) / rho + qs_3d(i,j,k) = zesnegf * (zes**zepowf) / rho + qr_3d(i,j,k) = zerf * (zer**zepowf) / rho + else + qr_3d(i,j,k) = zerf * (ze**zepowf) / rho + qs_3d(i,j,k) = 0.0_r_kind + ENDIF + cycle +!mhu + IF (pcptype == 1) THEN ! rain + qr_3d(i,j,k) = zerf * (ze**zepowf) / rho + ELSE IF (pcptype == 2) THEN ! snow + IF (tc <= 0.0_r_kind) THEN !dry snow + qs_3d(i,j,k) = zesnegf * (ze**zepowf) / rho + ELSE IF (tc < 5.0_r_kind) THEN !wet snow + rfract=0.20_r_kind*tc + zer=rfract*ze + zes=(1.-rfract)*ze + qs_3d(i,j,k) = zesposf * (zes**zepowf) / rho + qr_3d(i,j,k) = zerf * (zer**zepowf) / rho + ELSE + qr_3d(i,j,k) = zerf * (ze**zepowf) / rho + END IF + ELSE IF (pcptype == 3) THEN ! ZR + qr_3d(i,j,k) = zerf * (ze**zepowf) / rho + ELSE IF (pcptype == 4) THEN ! sleet + IF (tc <= 0.0_r_kind) THEN ! graupel/hail category + qg_3d(i,j,k) = zehf * (ze**zehpowf) / rho + ELSE IF( tc < 10._r_kind ) THEN + rfract=0.10_r_kind*tc + zer=rfract*ze + zeh=(1.-rfract)*ze + qr_3d(i,j,k) = zerf * (zer**zepowf) / rho + qg_3d(i,j,k) = zehf * (zeh**zehpowf) / rho + ELSE + qr_3d(i,j,k) = zerf * (ze**zepowf) / rho + END IF + ELSE IF (pcptype == 5) THEN ! graupel/hail + qg_3d(i,j,k) = zehf * (ze**zehpowf) / rho + ELSE ! unknown + IF (tc <= 0.0_r_kind) THEN !dry snow + qs_3d(i,j,k) = zesnegf * (ze**zepowf) / rho + ELSE IF ( tc < 5.0_r_kind ) THEN !wet snow + rfract=0.20_r_kind*tc + zer=rfract*ze + zes=(1.-rfract)*ze + qs_3d(i,j,k) = zesposf * (zes**zepowf) / rho + qr_3d(i,j,k) = zerf * (zer**zepowf) / rho + ELSE ! rain + qr_3d(i,j,k) = zerf * (ze**zepowf) / rho + END IF + END IF + ELSE + qr_3d(i,j,k) = -999._r_kind + qs_3d(i,j,k) = -999._r_kind + qg_3d(i,j,k) = -999._r_kind + END IF + END DO ! k + END DO ! i + END DO ! j +! PRINT*,'Finish Ferrier ...' +! +!----------------------------------------------------------------------- +! + istatus = 1 +! + RETURN +END SUBROUTINE pcp_mxr_ferrier diff --git a/src/GSD/gsdcloud4nmmb/radar_ref2tten.f90 b/src/GSD/gsdcloud4nmmb/radar_ref2tten.f90 new file mode 100755 index 0000000000..70570af91d --- /dev/null +++ b/src/GSD/gsdcloud4nmmb/radar_ref2tten.f90 @@ -0,0 +1,631 @@ +SUBROUTINE radar_ref2tten(mype,istat_radar,istat_lightning,nlon,nlat,nsig,ref_mos_3d, & + cld_cover_3d,p_bk,t_bk,ges_tten,dfi_rlhtp,krad_bot_in,pblh,sat_ctp) +! +!$$$ subprogram documentation block +! . . . . +! subprogram: radar_ref2tten convert radar reflectivity to 3-d temperature tendency +! +! PRGMMR: Ming Hu ORG: GSD/AMB DATE: 2008-11-27 +! +! ABSTRACT: +! This subroutine converts radar observation (dBZ) to temperature tendency for DFI +! +! PROGRAM HISTORY LOG: +! 2009-01-02 Hu Add NCO document block +! 2016-05-08 S.Liu tune the relation between ref and tten +! +! +! input argument list: +! mype - processor ID +! istat_radar - radar data status: 0=no radar data; 1=use radar reflectivity +! nlon - no. of lons on subdomain (buffer points on ends) +! nlat - no. of lats on subdomain (buffer points on ends) +! nsig - no. of levels +! ref_mos_3d - 3D radar reflectivity (dBZ) +! cld_cover_3d - 3D cloud cover (0-1) +! p_bk - 3D background pressure (hPa) +! t_bk - 3D background potential temperature (K) +! sat_ctp - 2D NESDIS cloud top pressure (hPa) +! ges_tten - 3D radar temperature tendency +! dfi_rlhtp - dfi radar latent heat time period. DFI forward integration window in minutes +! krad_bot_in - radar bottome height +! pblh - PBL height in grid unit +! +! output argument list: +! ges_tten - 3D radar temperature tendency +! +! USAGE: +! INPUT FILES: +! +! OUTPUT FILES: +! +! REMARKS: +! +! ATTRIBUTES: +! LANGUAGE: FORTRAN 90 +! MACHINE: Linux cluster (WJET) +! +!$$$ +! +!_____________________________________________________________________ +! + use constants, only: rd_over_cp, h1000 + use kinds, only: r_kind,i_kind,r_single + implicit none + + INTEGER(i_kind),INTENT(IN) :: mype + INTEGER(i_kind),INTENT(IN) :: nlon,nlat,nsig + INTEGER(i_kind),INTENT(IN) :: istat_radar + INTEGER(i_kind),INTENT(IN) :: istat_lightning + real(r_kind),INTENT(IN) :: dfi_rlhtp + real(r_single),INTENT(IN) :: krad_bot_in + real(r_single),INTENT(IN) :: pblh(nlon,nlat) + + real(r_kind),INTENT(IN) :: ref_mos_3d(nlon,nlat,nsig) ! reflectivity in grid + real(r_single),INTENT(IN) :: cld_cover_3d(nlon,nlat,nsig) + real(r_single),INTENT(IN) :: p_bk(nlon,nlat,nsig) + real(r_single),INTENT(IN) :: t_bk(nlon,nlat,nsig) ! potential temperature + real(r_kind), INTENT(INOUT):: ges_tten(nlat,nlon,nsig,1) + real(r_single),INTENT(IN),OPTIONAL :: sat_ctp(nlon,nlat) + + real (r_single) :: tbk_k + + real(r_kind), allocatable :: tten_radar(:,:,:) ! + real(r_kind), allocatable :: dummy(:,:) ! + + integer krad_bot ! RUC bottom level for TTEN_RAD +! +! convection suppression +! + real(r_kind), allocatable :: radyn(:,:) + real(r_kind) :: radmax, dpint + integer(i_kind) :: nrad + real(r_kind) :: radmaxall, dpintmax + +! adopted from: METCON of RUC (/ihome/rucdev/code/13km/hybfront_code) +! CONTAINS ATMOSPHERIC/METEOROLOGICAL/PHYSICAL CONSTANTS +!** R_P R J/(MOL*K) UNIVERSAL GAS CONSTANT +!** R* = 8.31451 +!** MD_P R KG/MOL MEAN MOLECULAR WEIGHT OF DRY AIR +!** MD = 0.0289645 +!jmb--Old value MD = 0.0289644 +!** RD_P R J/(KG*K) SPECIFIC GAS CONSTANT FOR DRY AIR +!** RD = R*>/-100) then ! no echo + tten_radar(i,j,k) = 0._r_kind + else if (ref_mos_3d(i,j,k)>=0.001_r_kind) then ! echo + iskip=0 + if (PRESENT(sat_ctp) ) then + if (sat_ctp(i,j)>1010._r_kind .and. sat_ctp(i,j)<1100._r_kind) then + iskip=iskip+1 +! write (6,*)' Radar ref > 5 dbZ, GOES indicates clear' +! write (6,*)' i,j,k / refl / lat-lon',i,j,k,ref_mos_3d(i,j,k) +! Therefore, if GOES indicates clear, tten_radar +! will retain the zero value + endif + endif + if (tbk_k>277.15_r_kind .and. ref_mos_3d(i,j,k)<28._r_kind) then + iskip=iskip+1 +! write (6,*)' t is over 277 ',i,j,k,ref_mos_3d(i,j,k) +! ALSO, if T > 4C and refl < 28dBZ, again +! tten_radar = 0. + endif + if(iskip == 0 ) then +! tten_radar set as non-zero ONLY IF +! - not contradicted by GOES clear, and +! - ruc_refl > 28 dbZ for temp > 4K, and +! - for temp < 4K, any ruc_refl dbZ is OK. +! - cloudy and under GOES cloud top +! - dfi_rlhtp in minutes + if (k>=krad_bot) then +! can not use cld_cover_3d because we don't use reflectivity to build cld_cover_3d +! if (abs(cld_cover_3d(i,j,k))<=0.5_r_kind .and. (sat_ctp(i,j)>p_bk(i,j,k))) then + if (sat_ctp(i,j)>p_bk(i,j,k)) then + addsnow=0.0_r_kind + else + addsnow = 10**(ref_mos_3d(i,j,k)/(17.8_r_kind*2.0))/264083._r_kind*9.0_r_kind + endif + tten = ((1000.0_r_kind/p_bk(i,j,k))**(1._r_kind/cpovr_p)) & + *(((LV_P+LF0_P)*addsnow)/ & + (2.0*dfi_rlhtp*60.0_r_kind*CPD_P)) + tten_radar(i,j,k)= min(0.01_r_kind,max(-0.01_r_kind,tten)) + end if + end if + end if ! ref_mos_3d + + ENDDO + ENDDO + ENDDO + +! DO k=1,nsig +! call smooth(tten_radar(1,1,k),dummy,nlon,nlat,0.5) +! call smooth(tten_radar(1,1,k),dummy,nlon,nlat,0.5) +! ENDDO + +!================================================================================ +! At this point +! 1. put tten_radar into ges_tten array +! for use as tten_radar in subsequent model DFI. +! 2. calculate convection suppression array (RADYN), by +! first smoothing further the tten_radar array +! (available since it is already copied to ges_tten) +! and with adding clear areas from GOES cloud data. + +! KEY element -- Set tten_radar to no-coverage AFTER smoothing +! where ref_mos_3d had been previously set to no-coverage (-99.0 dbZ) +!================================================================================ + + DO k=1,nsig + DO j=1,nlat + DO i=1,nlon + ges_tten(j,i,k,1)=tten_radar(i,j,k) + if(ref_mos_3d(i,j,k)<=-200.0_r_kind ) ges_tten(j,i,k,1)=-spval_p ! no obs + ENDDO + ENDDO + ENDDO +! DO k=1,nsig +! write(6,*)' k,max,min check=',mype,k,maxval(ges_tten(:,:,k,1)),minval(ges_tten(:,:,k,1)) +! enddo + +! -- Whack (smooth) the tten_radar array some more. +! for convection suppression in the radyn array. + DO k=1,nsig + call smooth(tten_radar(1,1,k),dummy,nlon,nlat,0.5_r_kind) + call smooth(tten_radar(1,1,k),dummy,nlon,nlat,0.5_r_kind) + call smooth(tten_radar(1,1,k),dummy,nlon,nlat,0.5_r_kind) + ENDDO + + deallocate(dummy) + +! RADYN array = convection suppression array +! Definition of RADYN values +! -10 -> no information +! 0 -> no convection +! 1 -> there might be convection nearby +! NOTE: 0,1 values are only possible if +! deep radar coverage is available (i.e., > 300 hPa deep) + +! RADYN is read into RUC model as array PCPPREV, +! where it is used to set the cap_depth (cap_max) +! in the Grell-Devenyi convective scheme +! to a near-zero value, effectively suppressing convection +! during DFI and first 30 min of the forward integration. + + allocate(radyn(nlon,nlat)) + radyn = -10._r_kind + + radmaxall=-999 + dpintmax=-999 + DO j=1,nlat + DO i=1,nlon + + nrad = 0 + radmax = 0._r_kind + dpint = 0._r_kind + DO k=2,nsig-1 + if ((ref_mos_3d(i,j,k))<=-200.0_r_kind) tten_radar(i,j,k) = -spval_p + if (tten_radar(i,j,k)>-15._r_kind) then + nrad=nrad+1 + dpint = dpint + 0.5_r_kind*(p_bk(i,j,k-1)-p_bk(i,j,k+1)) + radmax = max(radmax,tten_radar(i,j,k)) + end if + ENDDO + if (dpint>=300._r_kind ) then + radyn(i,j) = 0._r_kind + if (radmax>0.00002_r_kind) radyn(i,j) = 1. + if( abs(radyn(i,j)) < 0.00001_r_kind ) then + krad_bot= int( max(krad_bot_in,pblh(i,j)) + 0.5_r_single ) ! consider PBL height + do k=krad_bot,nsig-1 + ges_tten(j,i,k,1) = 0._r_kind + end do + endif + else +! outside radar coverage area where satellite shows clear conditions, +! then add this area to the convection suppress area. + if (PRESENT(sat_ctp) ) then + if (sat_ctp(i,j)>1010._r_kind .and. sat_ctp(i,j)<1100._r_kind) then + radyn(i,j) = 0._r_kind + endif + endif + endif + +! 2. Extend depth of no-echo zone from dpint zone down to PBL top, +! similarly to how lowest echo (with convection) is extended down to PBL top +! 5/27/2010 - Stan B. +! if (dpint >= 300. .and. radmax<=0.001) then +! krad_bot= int( max(krad_bot_in,pblh(i,j)) + 0.5_r_single ) ! consider PBL height +! do k=krad_bot,nsig-1 +! ges_tten(j,i,k,1) = 0._r_kind +! end do +! end if + + if(dpintmax < dpint ) dpintmax=dpint + if(radmaxall< radmax) radmaxall=radmax + ENDDO + ENDDO + + DO j=1,nlat + DO i=1,nlon +! ges_tten(j,i,nsig,1)=radyn(i,j) + ges_tten(j,i,nsig,1)=0.0 + ENDDO + ENDDO + + deallocate(tten_radar) + deallocate(radyn) + + else ! no radar observation i this subdomain + + ges_tten=-spval_p + ges_tten(:,:,nsig,1)=-10.0_r_kind + + DO j=1,nlat + DO i=1,nlon + +! outside radar observation domain and satellite show clean, the suppress convection + if (PRESENT(sat_ctp) ) then + if (sat_ctp(i,j)>=1010._r_kind .and. sat_ctp(i,j)<=1100._r_kind) then + ges_tten(j,i,nsig,1) = 0. + endif + endif + ENDDO + ENDDO + + endif + + DO k=1,nsig + DO j=1,nlat + DO i=1,nlon + if(ges_tten(j,i,k,1) <= -200.0_r_kind ) ges_tten(j,i,k,1)=-20.0_r_kind ! no obs + ENDDO + ENDDO + ENDDO + +END SUBROUTINE radar_ref2tten + +SUBROUTINE radar_ref2tten_nosat(mype,istat_radar,istat_lightning,nlon,nlat,nsig,ref_mos_3d,cld_cover_3d,& + p_bk,t_bk,ges_tten,dfi_rlhtp,krad_bot_in,pblh) +! +!$$$ subprogram documentation block +! . . . . +! subprogram: radar_ref2tten convert radar observation to temperature tedency +! +! PRGMMR: Ming Hu ORG: GSD/AMB DATE: 2008-11-27 +! +! ABSTRACT: +! This subroutine converts radar reflectivity (dBZ) to temperature tendency for DFI +! +! PROGRAM HISTORY LOG: +! 2009-01-02 Hu Add NCO document block +! 2016-05-08 S.Liu tune the relation between ref and tten +! +! +! input argument list: +! mype - processor ID +! istat_radar - radar data status: 0=no radar data; 1=use radar reflectivity +! nlon - no. of lons on subdomain (buffer points on ends) +! nlat - no. of lats on subdomain (buffer points on ends) +! nsig - no. of levels +! ref_mos_3d - 3D radar reflectivity (dBZ) +! cld_cover_3d - 3D cloud cover (0-1) +! p_bk - 3D background pressure (hPa) +! t_bk - 3D background potential temperature (K) +! ges_tten - 3D radar temperature tendency +! dfi_rlhtp - dfi radar latent heat time period +! krad_bot_in - radar bottome height +! pblh - PBL height in grid unit +! +! output argument list: +! ges_tten - 3D radar temperature tendency +! +! USAGE: +! INPUT FILES: +! +! OUTPUT FILES: +! +! REMARKS: +! +! ATTRIBUTES: +! LANGUAGE: FORTRAN 90 +! MACHINE: Linux cluster (WJET) +! +!$$$ +! +!_____________________________________________________________________ +! + use constants, only: rd_over_cp, h1000 + use kinds, only: r_kind,i_kind,r_single + implicit none + + INTEGER(i_kind),INTENT(IN) :: mype + INTEGER(i_kind),INTENT(IN) :: nlon,nlat,nsig + INTEGER(i_kind),INTENT(IN) :: istat_radar + INTEGER(i_kind),INTENT(IN) :: istat_lightning + real(r_kind),INTENT(IN) :: dfi_rlhtp + real(r_single),INTENT(IN) :: krad_bot_in + real(r_single),INTENT(IN) :: pblh(nlon,nlat) + + real(r_kind),INTENT(IN) :: ref_mos_3d(nlon,nlat,nsig) ! reflectivity in grid + real(r_single),INTENT(IN) :: cld_cover_3d(nlon,nlat,nsig) + real(r_single),INTENT(IN) :: p_bk(nlon,nlat,nsig) + real(r_single),INTENT(IN) :: t_bk(nlon,nlat,nsig) + real(r_kind), INTENT(INOUT):: ges_tten(nlat,nlon,nsig,1) + + real (r_single) :: tbk_k + + real(r_kind), allocatable :: tten_radar(:,:,:) ! + real(r_kind), allocatable :: dummy(:,:) ! + + integer(i_kind) :: krad_bot ! RUC bottom level for TTEN_RAD + ! and for filling from above +! +! convection suppression +! + real(r_kind), allocatable :: radyn(:,:) + real(r_kind) :: radmax, dpint + integer(i_kind) :: nrad + real(r_kind) :: radmaxall, dpintmax + +! adopted from: METCON of RUC (/ihome/rucdev/code/13km/hybfront_code) +! CONTAINS ATMOSPHERIC/METEOROLOGICAL/PHYSICAL CONSTANTS +!** R_P R J/(MOL*K) UNIVERSAL GAS CONSTANT +!** R* = 8.31451 +!** MD_P R KG/MOL MEAN MOLECULAR WEIGHT OF DRY AIR +!** MD = 0.0289645 +!jmb--Old value MD = 0.0289644 +!** RD_P R J/(KG*K) SPECIFIC GAS CONSTANT FOR DRY AIR +!** RD = R*>/-100) then ! no echo + tten_radar(i,j,k) = 0._r_kind + else if (ref_mos_3d(i,j,k)>=0.001_r_kind) then ! echo + iskip=0 + if (tbk_k>277.15_r_kind .and. ref_mos_3d(i,j,k)<28._r_kind) then + iskip=iskip+1 +! write (6,*)' t is over 277 ',i,j,k,ref_mos_3d(i,j,k) +! ALSO, if T > 4C and refl < 28dBZ, again +! tten_radar = 0. + endif + if(iskip == 0 ) then +! tten_radar set as non-zero ONLY IF +! - not contradicted by GOES clear, and +! - ruc_refl > 28 dbZ for temp > 4K, and +! - for temp < 4K, any ruc_refl dbZ is OK. +! - cloudy and under GOES cloud top + if (k>=krad_bot) then +! can not use cld_cover_3d because we don't use reflectivity to build cld_cover_3d +! if (abs(cld_cover_3d(i,j,k))<=0.5_r_kind) then +! addsnow=0.0_r_kind +! else + addsnow = 10**(ref_mos_3d(i,j,k)/(17.8_r_kind*2.0))/264083._r_kind*9.0_r_kind +! endif + tten = ((1000.0_r_kind/p_bk(i,j,k))**(1./cpovr_p)) & + *(((LV_P+LF0_P)*addsnow)/ & + (2.0*dfi_rlhtp*60.0_r_kind*CPD_P)) +! 60 = sec/min, and dfi_rlhtp is in minutes. +! NOTE: tten is in K/seconds + tten_radar(i,j,k)= min(0.01_r_kind,max(-0.01_r_kind,tten)) + end if + end if + end if ! ref_mos_3d + + ENDDO + ENDDO + ENDDO + + DO k=1,nsig + call smooth(tten_radar(1,1,k),dummy,nlon,nlat,0.5_r_kind) + call smooth(tten_radar(1,1,k),dummy,nlon,nlat,0.5_r_kind) + ENDDO + +! KEY element -- Set tten_radar to no-coverage AFTER smoothing +! where ref_mos_3d had been previously set to no-coverage (-99.0 dbZ) + + DO k=1,nsig + DO j=1,nlat + DO i=1,nlon + ges_tten(j,i,k,1)=tten_radar(i,j,k) + if(ref_mos_3d(i,j,k)<=-200.0_r_kind ) ges_tten(j,i,k,1)=-spval_p ! no obs + ENDDO + ENDDO + ENDDO + +! -- Whack (smooth) the tten_radar array some more. +! for convection suppression in the radyn array. + DO k=1,nsig + call smooth(tten_radar(1,1,k),dummy,nlon,nlat,0.5_r_kind) + call smooth(tten_radar(1,1,k),dummy,nlon,nlat,0.5_r_kind) + call smooth(tten_radar(1,1,k),dummy,nlon,nlat,0.5_r_kind) + ENDDO + + deallocate(dummy) + +! RADYN array = convection suppression array +! Definition of RADYN values +! -10 -> no information +! 0 -> no convection +! 1 -> there might be convection nearby +! NOTE: 0,1 values are only possible if +! deep radar coverage is available (i.e., > 300 hPa deep) + +! RADYN is read into RUC model as array PCPPREV, +! where it is used to set the cap_depth (cap_max) +! in the Grell-Devenyi convective scheme +! to a near-zero value, effectively suppressing convection +! during DFI and first 30 min of the forward integration. + + allocate(radyn(nlon,nlat)) + radyn = -10. + + radmaxall=-999 + dpintmax=-999 + DO j=1,nlat + DO i=1,nlon + + nrad = 0 + radmax = 0._r_kind + dpint = 0._r_kind + DO k=2,nsig-1 + if ((ref_mos_3d(i,j,k))<=-200.0_r_kind) tten_radar(i,j,k) = -spval_p + if (tten_radar(i,j,k)>-15._r_kind) then + nrad=nrad+1 + dpint = dpint + 0.5_r_kind*(p_bk(i,j,k-1)-p_bk(i,j,k+1)) + radmax = max(radmax,tten_radar(i,j,k)) + end if + ENDDO + if (dpint>=300._r_kind ) then + radyn(i,j) = 0._r_kind + if (radmax>0.00002_r_kind) radyn(i,j) = 1._r_kind + if( abs(radyn(i,j)) < 0.00001_r_kind ) then + krad_bot= int( max(krad_bot_in,pblh(i,j)) + 0.5_r_single ) ! consider PBL height + do k=krad_bot,nsig-1 + ges_tten(j,i,k,1) = 0._r_kind + end do + endif + endif + +! 2. Extend depth of no-echo zone from dpint zone down to PBL top, +! similarly to how lowest echo (with convection) is extended down to PBL top +! 5/27/2010 - Stan B. +! if (dpint.ge.300. .and. radmax.le.0.00001) then +! krad_bot= int( max(krad_bot_in,pblh(i,j)) + 0.5_r_single ) ! consider PBL height +! do k=krad_bot,nsig-1 +! ges_tten(j,i,k,1) = 0. +! end do +! end if + + if(dpintmax < dpint ) dpintmax=dpint + if(radmaxall< radmax) radmaxall=radmax + ENDDO + ENDDO + + DO j=1,nlat + DO i=1,nlon +! ges_tten(j,i,nsig,1)=radyn(i,j) + ges_tten(j,i,nsig,1)=0.0 + ENDDO + ENDDO + + deallocate(tten_radar) + deallocate(radyn) + + else + + ges_tten=-spval_p + ges_tten(:,:,nsig,1)=-10.0_r_kind + + endif + + DO k=1,nsig + DO j=1,nlat + DO i=1,nlon + if(ges_tten(j,i,k,1) <= -200.0_r_kind ) ges_tten(j,i,k,1)=-20.0_r_kind ! no obs + ENDDO + ENDDO + ENDDO + +END SUBROUTINE radar_ref2tten_nosat diff --git a/src/GSD/gsdcloud4nmmb/read_Lightning_cld.f90 b/src/GSD/gsdcloud4nmmb/read_Lightning_cld.f90 new file mode 100755 index 0000000000..9cf7c14539 --- /dev/null +++ b/src/GSD/gsdcloud4nmmb/read_Lightning_cld.f90 @@ -0,0 +1,95 @@ +SUBROUTINE read_Lightning2cld(mype,lunin,regional_time,istart,jstart, & + nlon,nlat,numlight,lightning) +! +! +!$$$ subprogram documentation block +! . . . . +! subprogram: read_NESDIS read in lightning flash rate +! +! PRGMMR: Ming Hu ORG: GSD/AMB DATE: 2008-11-30 +! +! ABSTRACT: +! This subroutine read in lightning flash rate +! +! PROGRAM HISTORY LOG: +! 2009-01-20 Hu Add NCO document block +! +! +! input argument list: +! mype - processor ID +! lunin - unit in which data are read in +! regional_time - analysis time +! jstart - start lon of the whole array on each pe +! istart - start lat of the whole array on each pe +! nlon - no. of lons on subdomain (buffer points on ends) +! nlat - no. of lats on subdomain (buffer points on ends) +! numlight - number of observation +! +! output argument list: +! lightning - lightning flash rate in analysis grid +! +! USAGE: +! INPUT FILES: +! +! OUTPUT FILES: +! +! REMARKS: +! +! ATTRIBUTES: +! LANGUAGE: FORTRAN 90 +! MACHINE: Linux cluster (WJET) +! +!$$$ +! +!_____________________________________________________________________ +! + + use kinds, only: r_kind,i_kind, r_single + implicit none + + integer(i_kind),intent(in) :: lunin + integer(i_kind),intent(in) :: mype + INTEGER(i_kind),intent(in) :: nlon,nlat + integer(i_kind),intent(in) :: regional_time(6) + integer(i_kind),intent(in) :: istart + integer(i_kind),intent(in) :: jstart + INTEGER(i_kind),intent(in) :: numlight + + real(r_single), intent(out):: lightning(nlon,nlat) +! +! local +! + real(r_kind),allocatable :: light_in(:,:) + + character(10) :: obstype + integer(i_kind):: nreal,nchanl,ilat1s,ilon1s + character(20) :: isis + + INTEGER(i_kind) :: i,j, ii,jj,k2, k + INTEGER(i_kind) :: ib,jb + +! + ib=jstart ! begin i point of this domain + jb=istart ! begin j point of this domain + + ilon1s=1 + ilat1s=2 + + read(lunin) obstype,isis,nreal,nchanl + + allocate( light_in(nreal,numlight) ) + light_in=-9999.0_r_kind + + read(lunin) light_in + DO i=1,numlight + ii=int(light_in(ilon1s,i)+0.001_r_kind) - ib + 2 + jj=int(light_in(ilat1s,i)+0.001_r_kind) - jb + 2 + if( ii < 1 .or. ii > nlon ) write(6,*) 'read_Lightning_cld: ', & + 'Error in read in lightning ii:',mype,ii,jj,i,ib,jb + if( jj < 1 .or. jj > nlat ) write(6,*) 'read_Lightning_cld:', & + 'Error in read in lightning jj:',mype,ii,jj,i,ib,jb + lightning(ii,jj)=light_in(3,i) + ENDDO + deallocate(light_in) + +END SUBROUTINE read_Lightning2cld diff --git a/src/GSD/gsdcloud4nmmb/read_Lightningbufr_cld.f90 b/src/GSD/gsdcloud4nmmb/read_Lightningbufr_cld.f90 new file mode 100755 index 0000000000..0be3482eac --- /dev/null +++ b/src/GSD/gsdcloud4nmmb/read_Lightningbufr_cld.f90 @@ -0,0 +1,109 @@ +SUBROUTINE read_Lightningbufr2cld(mype,lunin,regional_time,istart,jstart, & + nlon,nlat,numlight,lightning) +! +! +!$$$ subprogram documentation block +! . . . . +! subprogram: read_NESDIS read in lightning flash rate +! +! PRGMMR: Ming Hu ORG: GSD/AMB DATE: 2008-11-30 +! +! ABSTRACT: +! This subroutine read in lightning flash rate +! +! PROGRAM HISTORY LOG: +! 2009-01-20 Hu Add NCO document block +! 2015-10-04 S.Liu using Lightning density from bufr data +! +! +! input argument list: +! mype - processor ID +! lunin - unit in which data are read in +! regional_time - analysis time +! jstart - start lon of the whole array on each pe +! istart - start lat of the whole array on each pe +! nlon - no. of lons on subdomain (buffer points on ends) +! nlat - no. of lats on subdomain (buffer points on ends) +! numlight - number of observation +! +! output argument list: +! lightning - lightning density + +! USAGE: +! INPUT FILES: +! +! OUTPUT FILES: +! +! REMARKS: +! +! ATTRIBUTES: +! LANGUAGE: FORTRAN 90 +! MACHINE: Linux cluster (WJET) +! +!$$$ +! +!_____________________________________________________________________ +! + + use kinds, only: r_kind,i_kind, r_single + implicit none + + integer(i_kind),intent(in) :: lunin + integer(i_kind),intent(in) :: mype + INTEGER(i_kind),intent(in) :: nlon,nlat + integer(i_kind),intent(in) :: regional_time(6) + integer(i_kind),intent(in) :: istart + integer(i_kind),intent(in) :: jstart + INTEGER(i_kind),intent(in) :: numlight + + real(r_kind), intent(out):: lightning(nlon,nlat) +! +! local +! + real(r_kind),allocatable :: light_in(:,:) + + character(10) :: obstype + integer(i_kind):: nreal,nchanl,ilat1s,ilon1s + character(20) :: isis + + INTEGER(i_kind) :: i,j, ii,jj,k2, k + INTEGER(i_kind) :: ib,jb + +! + ib=jstart ! begin i point of this domain + jb=istart ! begin j point of this domain + + ilon1s=1 + ilat1s=2 + +! write(6,891)mype,ib,jb +! read(lunin) obstype,isis,nreal,nchanl + read(lunin) obstype,isis,nreal,nchanl +! write(6,*)obstype,isis,nreal,nchanl,numlight + lightning=-999.0 + + allocate( light_in(nreal,numlight) ) + light_in=-9999.0_r_kind + read(lunin) light_in + + DO i=1,numlight + ii=int(light_in(ilon1s,i)+0.001_r_kind) - ib + 2 + jj=int(light_in(ilat1s,i)+0.001_r_kind) - jb + 2 + + if( ii < 1 .or. ii > nlon ) write(6,*) 'read_Lightning_cld: ', & + 'Error in read in lightning ii:',mype,ii,jj,i,ib,jb + if( jj < 1 .or. jj > nlat ) write(6,*) 'read_Lightning_cld:', & + 'Error in read in lightning jj:',mype,ii,jj,i,ib,jb + lightning(ii,jj)=light_in(3,i) +! write(6,89)mype,light_in(ilon1s,i),light_in(ilat1s,i),light_in(3,i),light_in(ilon1s,i),ib,jb,ii,jj + ENDDO +! write(6,892)nreal,nchanl,numlight + + deallocate(light_in) +89 format('readLightningbufr0::',i8,4f12.2,4i6) +893 format('readLightningbufr0::',i8,3f9.2) +891 format('readLightningbufr0::',4i8) +892 format('readLightningbufr1::',3i8) + + +END SUBROUTINE read_Lightningbufr2cld diff --git a/src/GSD/gsdcloud4nmmb/read_NESDIS.f90 b/src/GSD/gsdcloud4nmmb/read_NESDIS.f90 new file mode 100755 index 0000000000..644a725a0a --- /dev/null +++ b/src/GSD/gsdcloud4nmmb/read_NESDIS.f90 @@ -0,0 +1,125 @@ +SUBROUTINE read_NESDIS(mype,lunin,numobs,regional_time,istart,jstart,nlon,nlat, & + sat_ctp,sat_tem,w_frac) +! +!$$$ subprogram documentation block +! . . . . +! subprogram: read_NESDIS read in NESDIS cloud products and map them into analysis grid +! +! PRGMMR: Ming Hu ORG: GSD/AMB DATE: 2006-10-30 +! +! ABSTRACT: +! This subroutine read in NESDIS cloud products and map them into analysis grid +! +! PROGRAM HISTORY LOG: +! 2009-01-20 Hu Add NCO document block +! +! +! input argument list: +! mype - processor ID +! lunin - unit in which data are read in +! numobs - number of observation +! regional_time - analysis time +! jstart - start lon of the whole array on each pe +! istart - start lat of the whole array on each pe +! nlon - no. of lons on subdomain (buffer points on ends) +! nlat - no. of lats on subdomain (buffer points on ends) +! +! output argument list: +! sat_ctp - GOES cloud top pressure in analysis grid +! sat_tem - GOES cloud top temperature in analysis grid +! w_frac - GOES cloud coverage in analysis grid +! +! +! USAGE: +! INPUT FILES: +! +! OUTPUT FILES: +! +! REMARKS: +! +! ATTRIBUTES: +! LANGUAGE: FORTRAN 90 +! MACHINE: Linux cluster (WJET) +! +!$$$ +! +!_____________________________________________________________________ +! + + use kinds, only: r_single,i_kind,r_kind + + implicit none + + integer(i_kind),intent(in) :: mype + integer(i_kind),intent(in) :: lunin + INTEGER(i_kind),intent(in) :: numobs + INTEGER(i_kind),intent(in) :: nlon,nlat + integer(i_kind),intent(in) :: regional_time(6) + integer(i_kind),intent(in) :: istart + integer(i_kind),intent(in) :: jstart + + real(r_single), intent(out):: sat_ctp(nlon,nlat) ! cloud top pressure + real(r_single), intent(out):: sat_tem(nlon,nlat) ! cloud top temperature + real(r_single), intent(out):: w_frac(nlon,nlat) ! cloud fraction +! + INTEGER(i_kind) :: nn_obs + real(r_kind),allocatable,dimension(:,:):: data_s + logical,allocatable,dimension(:):: luse +! +! misc. +! + character(10) :: obstype + integer(i_kind) :: mm1 + integer(i_kind) :: nreal,nchanl + character(20) :: isis + + INTEGER(i_kind) :: i, j, itmp, jtmp + INTEGER(i_kind) :: ib, jb + character*12 :: adate +! +! =============================================================== +! + + mm1=mype+1 + + read(lunin) obstype,isis,nreal,nchanl + nn_obs = nreal + nchanl + allocate(luse(numobs),data_s(nn_obs,numobs)) + read(lunin) data_s, luse +! + ib=jstart ! begin i point of this domain + jb=istart ! begin j point of this domain + call map_ctp (ib,jb,nlon,nlat,nn_obs,numobs,data_s,sat_ctp,sat_tem,w_frac) +!! +! filling boundarys +! + DO i=2,nlon-1 + sat_ctp(i,1) =sat_ctp(i,2) + sat_tem(i,1) =sat_tem(i,2) + w_frac(i,1) =w_frac(i,2) + sat_ctp(i,nlat)=sat_ctp(i,nlat-1) + sat_tem(i,nlat)=sat_tem(i,nlat-1) + w_frac(i,nlat) =w_frac(i,nlat-1) + enddo + DO j=2,nlat-1 + sat_ctp(1,j) =sat_ctp(2,j) + sat_tem(1,j) =sat_tem(2,j) + w_frac(1,j) =w_frac(2,j) + sat_ctp(nlon,j)=sat_ctp(nlon-1,j) + sat_tem(nlon,j)=sat_tem(nlon-1,j) + w_frac(nlon,j) =w_frac(nlon-1,j) + enddo + sat_ctp(1,1) =sat_ctp(2,2) + sat_tem(1,1) =sat_tem(2,2) + w_frac(1,1) =w_frac(2,2) + sat_ctp(1,nlat) =sat_ctp(2,nlat-1) + sat_tem(1,nlat) =sat_tem(2,nlat-1) + w_frac(1,nlat) =w_frac(2,nlat-1) + sat_ctp(nlon,1) =sat_ctp(nlon-1,2) + sat_tem(nlon,1) =sat_tem(nlon-1,2) + w_frac(nlon,1) =w_frac(nlon-1,2) + sat_ctp(nlon,nlat)=sat_ctp(nlon-1,nlat-1) + sat_tem(nlon,nlat)=sat_tem(nlon-1,nlat-1) + w_frac(nlon,nlat) =w_frac(nlon-1,nlat-1) + +END SUBROUTINE read_NESDIS diff --git a/src/GSD/gsdcloud4nmmb/read_Surface.f90 b/src/GSD/gsdcloud4nmmb/read_Surface.f90 new file mode 100755 index 0000000000..0a2d02bbea --- /dev/null +++ b/src/GSD/gsdcloud4nmmb/read_Surface.f90 @@ -0,0 +1,251 @@ +SUBROUTINE read_Surface(mype,lunin,regional_time,istart,jstart,nlon,nlat,& + numsao,NVARCLD_P,OI,OJ,OCLD,OWX,Oelvtn,Odist,cstation, & + OIstation,OJstation) +! +!$$$ subprogram documentation block +! . . . . +! subprogram: read_Surface read in cloud observations in surface observation +! +! PRGMMR: Ming Hu ORG: GSD/AMB DATE: 2006-10-30 +! +! ABSTRACT: +! This subroutine read in cloud observations in surface observation +! +! PROGRAM HISTORY LOG: +! 2009-01-20 Hu Add NCO document block +! +! +! input argument list: +! mype - processor ID +! lunin - unit in which data are read in +! regional_time - analysis time +! jstart - start lon of the whole array on each pe +! istart - start lat of the whole array on each pe +! nlon - no. of lons on subdomain (buffer points on ends) +! nlat - no. of lats on subdomain (buffer points on ends) +! numsao - maximum observation number (observation number) +! NVARCLD_P - first dimension of OLCD +! +! output argument list: +! +! OI - observation x location +! OJ - observation y location +! OLCD - cloud amount, cloud height, visibility +! OWX - weather observation +! Oelvtn - observation elevation +! Odist - distance from the nearest station +! cstation - station name + +! +! USAGE: +! INPUT FILES: +! +! OUTPUT FILES: +! +! +! REMARKS: +! +! ATTRIBUTES: +! LANGUAGE: FORTRAN 90 +! MACHINE: Linux cluster (WJET) +! +!$$$ +! + + use kinds, only: r_single,i_kind,r_kind,r_double + + implicit none + + integer(i_kind), intent(in) :: mype + integer(i_kind), intent(in) :: lunin + integer(i_kind), intent(in) :: regional_time(6) + integer(i_kind), intent(in) :: istart + integer(i_kind), intent(in) :: jstart + INTEGER(i_kind), intent(in) :: nlon,nlat + INTEGER(i_kind), intent(in) :: numsao + INTEGER(i_kind), intent(in) :: NVARCLD_P + + real(r_single), intent(out) :: OI(numsao) ! x location, grid + real(r_single), intent(out) :: OJ(numsao) ! y location, grid + INTEGER(i_kind), intent(out) :: OCLD(NVARCLD_P,numsao) ! cloud amount, cloud height, + ! visibility + CHARACTER*10, intent(out) :: OWX(numsao) ! weather + real(r_single), intent(out) :: Oelvtn(numsao) ! elevation + real(r_single), intent(out) :: Odist(numsao) ! distance from the nearest station + character(8), intent(out) :: cstation(numsao) ! station name + real(r_single), intent(out) :: OIstation(numsao) ! x location, station + real(r_single), intent(out) :: OJstation(numsao) ! y location, station + +! +! temp. +! + character*12 :: adate + character*9 :: STANAM ! stattion name + real(r_single) :: LAT ! latitude + real(r_single) :: LON ! longitude + + real(r_single) :: VIS ! horizontal visibility + real(r_single) :: CLD(3) ! cloud base height + character*10 :: WX ! weather + character*8 :: sky(3) ! cloud cover or amount + +! +! misc. +! + real(r_kind),allocatable,dimension(:,:):: data_s + logical,allocatable,dimension(:):: luse + character(10) :: obstype + integer(i_kind):: nreal,nchanl + character(20) :: isis + + INTEGER(i_kind) :: nn_obs + real(r_kind) :: cldamt,awx,cldhgt + character*3 :: msky,mwx + INTEGER(i_kind) :: i,j,k,k2,ic,jb,ib + integer(i_kind) :: start, end + + real(r_kind) :: spval_p + parameter (spval_p = 99999.) + + real(r_double) rstation_id + character(8) :: cstation1,cc,ci + equivalence(cstation1,rstation_id) + + +!==================================================================== +! Begin + OWX='' + OCLD=-99999 + + ib=jstart ! begin i point of this domain + jb=istart ! begin j point of this domain + +! + read(lunin) obstype,isis,nreal,nchanl + + nn_obs = nreal + nchanl + allocate(luse(numsao),data_s(nn_obs,numsao)) + read(lunin) data_s, luse +! +! read in ruface observations: +! station name, x location, y location, longitude, latitude, elevation +! visibility, cloud amount, cloud height, weather +! + DO i=1,numsao + rstation_id=data_s(1,i) + cstation(i)=cstation1 + OI(i) = data_s(2,i) - ib + 2 ! covert it to the local grid + OJ(i) = data_s(3,i) - jb + 2 ! covert it to the local grid + if( OI(i) < 1 .or. OI(i) > nlon ) write(6,*) 'read_Surface: Error in reading ii:',mype,OI(i),ib,jb + if( OJ(i) < 1 .or. OJ(i) > nlat ) write(6,*) 'read_Surface: Error in reading jj:',mype,OJ(i),ib,jb + Oelvtn(i) = data_s(4,i) + Odist(i) = data_s(23,i) + OIstation(i) = data_s(24,i) + OJstation(i) = data_s(25,i) + if(data_s(22,i) > 50 ) cycle ! do not use this data + VIS = data_s(5,i) +! cloud amonut and base height +! C 020011 +! 0 0 oktas (0/10) +! 1 1 okta or less, but not zero (1/10 or less, but not zero) +! 2 2 oktas (2/10 - 3/10) +! 3 3 oktas (4/10) +! 4 4 oktas (5/10) +! 5 5 oktas (6/10) +! 6 6 oktas (7/10 - 8/10) +! 7 7 oktas or more, but not 8 oktas (9/10 or more, but not 10/10) +! 8 8 oktas (10/10) +! 9 Sky obscured by fog and/or other meteorological phenomena +! 10 Sky partially obscured by fog and/or other meteorological phenomena +! 11 Scattered +! 12 Broken +! 13 Few +! 14 Reserved +! 15 Cloud cover is indiscernible for reasons other than +! fog or other meteorological phenomena, or observation is not made + + DO j=1,3 + cldamt = data_s(5+j,i) ! cloud amount + cldhgt = int(data_s(11+j,i)) ! cloud bottom height + if(cldamt < spval_p .and. cldhgt < spval_p) then + if(abs(cldamt-0._r_kind) < 0.0001_r_kind) then + OCLD(j,i)=0 !msky='CLR' + cldhgt=spval_p + elseif(abs(cldamt-13._r_kind) < 0.0001_r_kind) then + OCLD(j,i)=1 !msky='FEW' + elseif(abs(cldamt-11._r_kind) < 0.0001_r_kind) then + OCLD(j,i)=2 !msky='SCT' + elseif(abs(cldamt-12._r_kind) < 0.0001_r_kind) then + OCLD(j,i)=3 !msky='BKN' + elseif((abs(cldamt-8._r_kind) < 0.0001_r_kind) .or. & + (abs(cldamt-9._r_kind) < 0.0001_r_kind)) then + OCLD(j,i)=4 ! msky='OVC' msky='VV ' + elseif(abs(cldamt-1._r_kind) < 0.0001_r_kind) then + OCLD(j,i)=1 + elseif(abs(cldamt-2._r_kind) < 0.0001_r_kind .or. & + abs(cldamt-3._r_kind) < 0.0001_r_kind ) then + OCLD(j,i)=2 + elseif(cldamt > 3.5_r_kind .and. cldamt < 6.5_r_kind ) then + OCLD(j,i)=3 + elseif(abs(cldamt-7._r_kind) < 0.0001_r_kind ) then + OCLD(j,i)=4 + else + OCLD(j,i) = spval_p ! wrong cloud observation type + cldhgt = spval_p + endif + if(cldhgt > 0.0_r_kind ) then + OCLD(6+j,i) = cldhgt + else + OCLD(j,i) = spval_p + OCLD(6+j,i) = spval_p + endif + else + OCLD(j,i) = 99 + OCLD(6+j,i) = spval_p + endif + enddo ! j +! weather + DO j=1,3 + awx = data_s(17+j,i) ! weather + mwx=' ' + if(awx>=10._r_kind .and.awx<=12._r_kind ) mwx='BR ' + if(awx>=110._r_kind.and.awx<=112._r_kind) mwx='BR ' + if(awx==5._r_kind .or. awx==105._r_kind) mwx='HZ ' + if(awx>=40._r_kind .and.awx<=49._r_kind ) mwx='FG ' + if(awx>=130._r_kind.and.awx<=135._r_kind) mwx='FG ' + if(awx>=50._r_kind .and.awx<=59._r_kind ) mwx='DZ ' + if(awx>=150._r_kind.and.awx<=159._r_kind) mwx='DZ ' + if(awx>=60._r_kind .and.awx<=69._r_kind ) mwx='RA ' + if(awx>=160._r_kind.and.awx<=169._r_kind) mwx='RA ' + if(awx>=70._r_kind .and.awx<=78._r_kind ) mwx='SN ' + if(awx>=170._r_kind.and.awx<=178._r_kind) mwx='SN ' + if(awx==79._r_kind .or. awx==179._r_kind) mwx='PE ' + + if(awx>=80._r_kind .and.awx<=90._r_kind ) mwx='SH ' + if(awx>=180._r_kind.and.awx<=187._r_kind) mwx='SH ' + if(awx>=91._r_kind .and.awx<=99._r_kind ) mwx='TH ' + if(awx>=190._r_kind.and.awx<=196._r_kind) mwx='TH ' + + if (j==1) start=1 + if (j==2) start=4 + if (j==3) start=7 + end=start+2 + OWX(i)(start:end)=mwx + enddo +! visiblity + IF(VIS > spval_P) then + OCLD(13,i)=spval_P + else + IF(VIS > 100.0_r_kind ) then + OCLD(13,i)=int(VIS) + elseif(VIS <=100.0_r_kind .and. VIS > 0.0_r_kind ) then + OCLD(13,i)=100 +! write(6,*) 'read_Surface, Warning: change visibility to 100 m !!!' + ENDIF + endif + + ENDDO ! i = numsao +! + +END SUBROUTINE read_Surface + diff --git a/src/GSD/gsdcloud4nmmb/read_nasalarc_cld.f90 b/src/GSD/gsdcloud4nmmb/read_nasalarc_cld.f90 new file mode 100755 index 0000000000..8b26f7b284 --- /dev/null +++ b/src/GSD/gsdcloud4nmmb/read_nasalarc_cld.f90 @@ -0,0 +1,167 @@ +SUBROUTINE read_nasalarc(mype,lunin,numobs,regional_time,istart,jstart,nlon,nlat, & + nasalarc) +! +!$$$ subprogram documentation block +! . . . . +! subprogram: read_NESDIS read in NESDIS cloud products and map them into analysis grid +! +! PRGMMR: Ming Hu ORG: GSD/AMB DATE: 2006-10-30 +! +! ABSTRACT: +! This subroutine read in NESDIS cloud products and map them into analysis grid +! +! PROGRAM HISTORY LOG: +! 2009-01-20 Hu Add NCO document block +! 2013-12-20 S.Liu modify to read bufr file and do interpolation in GSI +! +! +! input argument list: +! mype - processor ID +! lunin - unit in which data are read in +! numobs - number of observation +! regional_time - analysis time +! jstart - start lon of the whole array on each pe +! istart - start lat of the whole array on each pe +! nlon - no. of lons on subdomain (buffer points on ends) +! nlat - no. of lats on subdomain (buffer points on ends) +! +! output argument list: +! sat_ctp - GOES cloud top pressure in analysis grid +! sat_tem - GOES cloud top temperature in analysis grid +! w_frac - GOES cloud coverage in analysis grid +! +! +! USAGE: +! INPUT FILES: +! +! OUTPUT FILES: +! +! REMARKS: +! +! ATTRIBUTES: +! LANGUAGE: FORTRAN 90 +! MACHINE: Linux cluster (WJET) +! +!$$$ +! +!_____________________________________________________________________ +! + + use kinds, only: r_single,i_kind,r_kind + + implicit none + + integer(i_kind),intent(in) :: mype + integer(i_kind),intent(in) :: lunin + INTEGER(i_kind),intent(in) :: numobs + INTEGER(i_kind),intent(in) :: nlon,nlat + integer(i_kind),intent(in) :: regional_time(6) + integer(i_kind),intent(in) :: istart + integer(i_kind),intent(in) :: jstart + + real(r_single):: sat_ctp(nlon,nlat) ! cloud top pressure + real(r_single):: sat_tem(nlon,nlat) ! cloud top temperature + real(r_single):: w_frac(nlon,nlat) ! cloud fraction + real(r_single):: w_lwp(nlon,nlat) ! cloud fraction + integer(i_kind):: nlev_cld(nlon,nlat) ! cloud fraction + real(r_single):: nasalarc(nlon,nlat,5) +! + INTEGER(i_kind) :: nn_obs + real(r_kind),allocatable,dimension(:,:):: data_s + logical,allocatable,dimension(:):: luse +! +! misc. +! + character(10) :: obstype + integer(i_kind) :: mm1 + integer(i_kind) :: nreal,nchanl + character(20) :: isis + + INTEGER(i_kind) :: i, j, itmp, jtmp + INTEGER(i_kind) :: ib, jb + character*12 :: adate +! +! =============================================================== +! + + mm1=mype+1 + + read(lunin) obstype,isis,nreal,nchanl + nn_obs = nreal + nchanl + allocate(luse(numobs),data_s(nn_obs,numobs)) + read(lunin) data_s, luse + +! do i=1,numobs +! write(6,*)'sliu larcclddata::',data_s(1,i),data_s(2,i),data_s(3,i) +! end do + +! write(6,*)'read_NESDIS::',mype, maxval(data_s(7,:)),numobs + + + ib=jstart ! begin i point of this domain + jb=istart ! begin j point of this domain + call map_ctp_lar(ib,jb,nlon,nlat,nn_obs,numobs,data_s,sat_ctp,sat_tem,w_frac,w_lwp,nlev_cld) +!! +! filling boundarys +! + DO i=2,nlon-1 + sat_ctp(i,1) =sat_ctp(i,2) + sat_tem(i,1) =sat_tem(i,2) + w_frac(i,1) =w_frac(i,2) + w_lwp(i,1) =w_lwp(i,2) + nlev_cld(i,1) =nlev_cld(i,2) + sat_ctp(i,nlat)=sat_ctp(i,nlat-1) + sat_tem(i,nlat)=sat_tem(i,nlat-1) + w_frac(i,nlat) =w_frac(i,nlat-1) + w_lwp(i,nlat) =w_lwp(i,nlat-1) + nlev_cld(i,nlat) =nlev_cld(i,nlat-1) + enddo + DO j=2,nlat-1 + sat_ctp(1,j) =sat_ctp(2,j) + sat_tem(1,j) =sat_tem(2,j) + w_frac(1,j) =w_lwp(2,j) + w_lwp(1,j) =w_lwp(2,j) + nlev_cld(1,j) =nlev_cld(2,j) + sat_ctp(nlon,j)=sat_ctp(nlon-1,j) + sat_tem(nlon,j)=sat_tem(nlon-1,j) + w_frac(nlon,j) =w_frac(nlon-1,j) + w_lwp(nlon,j) =w_lwp(nlon-1,j) + nlev_cld(nlon,j) =nlev_cld(nlon-1,j) + enddo + sat_ctp(1,1) =sat_ctp(2,2) + sat_tem(1,1) =sat_tem(2,2) + w_frac(1,1) =w_frac(2,2) + w_lwp(1,1) =w_lwp(2,2) + nlev_cld(1,1) =nlev_cld(2,2) + + sat_ctp(1,nlat) =sat_ctp(2,nlat-1) + sat_tem(1,nlat) =sat_tem(2,nlat-1) + w_frac(1,nlat) =w_frac(2,nlat-1) + w_lwp(1,nlat) =w_lwp(2,nlat-1) + nlev_cld(1,nlat) =nlev_cld(2,nlat-1) + + sat_ctp(nlon,1) =sat_ctp(nlon-1,2) + sat_tem(nlon,1) =sat_tem(nlon-1,2) + w_frac(nlon,1) =w_frac(nlon-1,2) + w_lwp(nlon,1) =w_lwp(nlon-1,2) + nlev_cld(nlon,1) =nlev_cld(nlon-1,2) + + sat_ctp(nlon,nlat)=sat_ctp(nlon-1,nlat-1) + sat_tem(nlon,nlat)=sat_tem(nlon-1,nlat-1) + w_frac(nlon,nlat) =w_frac(nlon-1,nlat-1) + + do i=1,nlon + do j=1,nlat + nasalarc(i,j,1)=sat_ctp(i,j) + nasalarc(i,j,2)=sat_tem(i,j) + nasalarc(i,j,3)=w_frac(i,j) !/100.0 + nasalarc(i,j,4)=w_lwp(i,j) !/100.0 + nasalarc(i,j,5)=nlev_cld(i,j) +! if(abs(sat_tem(i,j))>0.and.abs(sat_tem(i,j))<400) then +! write(6,*)'sat_tem2 in read_cloud::',sat_ctp(i,j),sat_tem(i,j),nasalarc(i,j,1) +! end if + end do + end do + + +END SUBROUTINE read_nasalarc diff --git a/src/GSD/gsdcloud4nmmb/read_radar_ref.f90 b/src/GSD/gsdcloud4nmmb/read_radar_ref.f90 new file mode 100755 index 0000000000..1a7931ae67 --- /dev/null +++ b/src/GSD/gsdcloud4nmmb/read_radar_ref.f90 @@ -0,0 +1,107 @@ +SUBROUTINE read_radar_ref(mype,lunin,regional_time,istart,jstart, & + nlon,nlat,Nmsclvl,numref,ref_mosaic31) +! +! +! +!$$$ subprogram documentation block +! . . . . +! subprogram: read_NESDIS read in radar reflectivity +! +! PRGMMR: Ming Hu ORG: GSD/AMB DATE: 2006-11-30 +! +! ABSTRACT: +! This subroutine read in radar reflectivity +! +! PROGRAM HISTORY LOG: +! 2009-01-20 Hu Add NCO document block +! +! +! input argument list: +! mype - processor ID +! lunin - unit in which data are read in +! regional_time - analysis time +! jstart - start lon of the whole array on each pe +! istart - start lat of the whole array on each pe +! nlon - no. of lons on subdomain (buffer points on ends) +! nlat - no. of lats on subdomain (buffer points on ends) +! numref - number of observation +! +! output argument list: +! Nmsclvl - vertical level of radar observation ref_mosaic31 +! ref_mosaic31- radar reflectivity horizontally in analysis grid and +! vertically in mosaic grid (height) +! +! USAGE: +! INPUT FILES: +! +! OUTPUT FILES: +! +! REMARKS: +! +! ATTRIBUTES: +! LANGUAGE: FORTRAN 90 +! MACHINE: Linux cluster (WJET) +! +!$$$ +! +!_____________________________________________________________________ +! + use kinds, only: r_kind,i_kind + implicit none + + INTEGER(i_kind),intent(in) :: mype + INTEGER(i_kind),intent(in) :: nlon,nlat + integer(i_kind),intent(in) :: lunin + integer(i_kind),intent(in) :: regional_time(6) + integer(i_kind),intent(in) :: istart + integer(i_kind),intent(in) :: jstart + INTEGER(i_kind),intent(in) :: numref + + INTEGER(i_kind),intent(out):: Nmsclvl + real(r_kind), intent(out):: ref_mosaic31(nlon,nlat,31) +! +! local +! + real(r_kind),allocatable :: ref_in(:,:) + + character(10) :: obstype + integer(i_kind):: nreal,nchanl,ilat1s,ilon1s + character(20) :: isis + + INTEGER(i_kind) :: i,j, ii,jj,k2, k + INTEGER(i_kind) :: ib,jb + +! + ib=jstart ! begin i point of this domain + jb=istart ! begin j point of this domain + + read(lunin) obstype,isis,nreal,nchanl + + ilon1s=1 + ilat1s=2 + Nmsclvl = nreal - 2 + IF( Nmsclvl .ne. 21 .and. Nmsclvl .ne.31) then + write(6,*) ' read_radar_ref: ', & + 'vertical dimesion inconsistent when read in reflectivty mosaic' + write(6,*) 'read in:',Nmsclvl + write(6,*) 'need:', 21, 'or', 31 + call stop2(114) + ENDIF + allocate( ref_in(nreal,numref) ) + ref_mosaic31=-9999.0_r_kind + + read(lunin) ref_in + DO i=1,numref + ii=int(ref_in(ilon1s,i)+0.001_r_kind) - ib + 2 + jj=int(ref_in(ilat1s,i)+0.001_r_kind) - jb + 2 + if( ii < 1 .or. ii > nlon ) write(6,*) 'read_radar_ref: ', & + 'Error in read in ref ii:',mype,ii,jj,i,ib,jb + if( jj < 1 .or. jj > nlat ) write(6,*) 'read_radar_ref: ', & + 'Error in read in ref jj:',mype,ii,jj,i,ib,jb + DO k=1,Nmsclvl + ref_mosaic31(ii,jj,k)=ref_in(2+k,i) + ENDDO + ENDDO + deallocate(ref_in) + +END SUBROUTINE read_radar_ref diff --git a/src/GSD/gsdcloud4nmmb/smooth.f90 b/src/GSD/gsdcloud4nmmb/smooth.f90 new file mode 100755 index 0000000000..73f6208091 --- /dev/null +++ b/src/GSD/gsdcloud4nmmb/smooth.f90 @@ -0,0 +1,98 @@ + SUBROUTINE SMOOTH (FIELD,HOLD,IX,IY,SMTH) +!C$$$ SUBPROGRAM DOCUMENTATION BLOCK +!C . . . . +!C SUBPROGRAM: SMOOTH SMOOTH A METEOROLOGICAL FIELD +!C PRGMMR: STAN BENJAMIN ORG: FSL/PROFS DATE: 90-06-15 +!C +!C ABSTRACT: SHAPIRO SMOOTHER. +!C +!C PROGRAM HISTORY LOG: +!C 85-12-09 S. BENJAMIN ORIGINAL VERSION +!C +!C USAGE: CALL SMOOTH (FIELD,HOLD,IX,IY,SMTH) +!C INPUT ARGUMENT LIST: +!C FIELD - REAL ARRAY FIELD(IX,IY) +!C METEOROLOGICAL FIELD +!C HOLD - REAL ARRAY HOLD(IX,2) +!C HOLDING THE VALUE FOR FIELD +!C IX - INTEGER X COORDINATES OF FIELD +!C IY - INTEGER Y COORDINATES OF FIELD +!C SMTH - REAL +!C +!C OUTPUT ARGUMENT LIST: +!C FIELD - REAL ARRAY FIELD(IX,IY) +!C SMOOTHED METEOROLOGICAL FIELD +!C +!C REMARKS: REFERENCE: SHAPIRO, 1970: "SMOOTHING, FILTERING, AND +!C BOUNDARY EFFECTS", REV. GEOPHYS. SP. PHYS., 359-387. +!C THIS FILTER IS OF THE TYPE +!C Z(I) = (1-S)Z(I) + S(Z(I+1)+Z(I-1))/2 +!C FOR A FILTER WHICH IS SUPPOSED TO DAMP 2DX WAVES COMPLETELY +!C BUT LEAVE 4DX AND LONGER WITH LITTLE DAMPING, +!C IT SHOULD BE RUN WITH 2 PASSES USING SMTH (OR S) OF 0.5 +!C AND -0.5. +!C +!C ATTRIBUTES: +!C$$$ +!C********************************************************************** +!C********************************************************************** + + + use kinds, only: r_kind,i_kind,r_single + implicit none +!C********************************************************************** + INTEGER(i_kind),INTENT(IN) :: IX,IY + real(r_kind),intent(inout) :: FIELD(IX,IY) + real(r_kind),intent(inout) :: HOLD (IX,2) + real(r_kind),intent(in) :: SMTH +!C********************************************************************** + real(r_kind) :: SMTH1,SMTH2,SMTH3,SMTH4,SMTH5 + INTEGER(i_kind) :: I1,I2,I,J,IT + real(r_kind) :: SUM1,SUM2 + + SMTH1 = 0.25 * SMTH * SMTH + SMTH2 = 0.5 * SMTH * (1.-SMTH) + SMTH3 = (1.-SMTH) * (1.-SMTH) + SMTH4 = (1.-SMTH) + SMTH5 = 0.5 * SMTH + I1 = 2 + I2 = 1 + DO J=2,IY-1 + IT = I1 + I1 = I2 + I2 = IT + DO I = 2,IX-1 + SUM1 = FIELD (I-1,J+1) + FIELD (I-1,J-1) & + + FIELD (I+1,J+1) + FIELD (I+1,J-1) + SUM2 = FIELD (I ,J+1) + FIELD (I+1,J ) & + + FIELD (I ,J-1) + FIELD (I-1,J ) + HOLD(I,I1) = SMTH1*SUM1 + SMTH2*SUM2 + SMTH3*FIELD(I,J) + ENDDO + IF (J /= 2) THEN + DO I=2,IX-1 + FIELD(I,J-1) = HOLD(I,I2) + ENDDO + ENDIF + ENDDO + + + DO I = 2,IX-1 + FIELD (I,IY-1) = HOLD(I,I1) + ENDDO + + DO I = 2,IX-1 + FIELD(I,1) = SMTH4* FIELD(I,1) & + + SMTH5 * (FIELD(I-1,1) + FIELD(I+1,1)) + FIELD(I,IY) = SMTH4* FIELD(I,IY) & + + SMTH5 * (FIELD(I-1,IY) + FIELD(I+1,IY)) + ENDDO + + DO J = 2,IY-1 + FIELD(1,J) = SMTH4* FIELD(1,J) & + + SMTH5 * (FIELD(1,J-1) + FIELD(1,J+1)) + FIELD(IX,J) = SMTH4* FIELD(IX,J) & + + SMTH5 * (FIELD(IX,J-1) + FIELD(IX,J+1)) + ENDDO + + RETURN + END diff --git a/src/GSD/gsdcloud4nmmb/vinterp_radar_ref.f90 b/src/GSD/gsdcloud4nmmb/vinterp_radar_ref.f90 new file mode 100755 index 0000000000..cdbadf3873 --- /dev/null +++ b/src/GSD/gsdcloud4nmmb/vinterp_radar_ref.f90 @@ -0,0 +1,143 @@ +SUBROUTINE vinterp_radar_ref(mype,nlon,nlat,nsig,Nmsclvl,ref_mos_3d,ref_mosaic31,h_bk,zh) +! +! +!$$$ subprogram documentation block +! . . . . +! subprogram: interp_radar_ref radar observation vertical interpolation +! +! PRGMMR: Ming Hu ORG: GSD/AMB DATE: 2006-11-17 +! +! ABSTRACT: +! This subroutine interpolate radar reflectivity vertically +! +! PROGRAM HISTORY LOG: +! 2009-01-20 Hu Add NCO document block +! +! +! input argument list: +! mype - processor ID +! nlon - no. of lons on subdomain (buffer points on ends) +! nlat - no. of lats on subdomain (buffer points on ends) +! nsig - no. of levels +! Nmsclvl - vertical level of radar observation ref_mosaic31 +! ref_mosaic31- radar reflectivity horizontally in analysis grid and vertically +! in mosaic grid (height) +! h_bk - 3D background height +! zh - terrain +! +! output argument list: +! ref_mos_3d - 3D radar reflectivity in analysis grid +! +! USAGE: +! INPUT FILES: +! +! OUTPUT FILES: +! +! REMARKS: +! +! ATTRIBUTES: +! LANGUAGE: FORTRAN 90 +! MACHINE: Linux cluster (WJET) +! +!$$$ +! +!_____________________________________________________________________ +! + use kinds, only: r_kind,i_kind, r_single + implicit none + + INTEGER(i_kind), intent(in) :: mype + INTEGER(i_kind), intent(in) :: nlon + INTEGER(i_kind), intent(in) :: nlat + INTEGER(i_kind), intent(in) :: nsig + INTEGER(i_kind), intent(in) :: Nmsclvl + real(r_single), intent(in) :: h_bk(nlon,nlat,nsig) ! 3D height + real(r_single), intent(in) :: zh(nlon,nlat) ! terrain + real(r_kind), intent(in) :: ref_mosaic31(nlon,nlat,Nmsclvl) + real(r_kind), intent(out):: ref_mos_3d(nlon,nlat,nsig) ! reflectivity in grid +! +! local +! + real(r_kind) :: msclvl21(21),msclvlAll(31) + INTEGER(i_kind) :: mscX,mscY + DATA msclvl21/1, 1.5, 2, 2.5, 3, 3.5, 4, 4.5, 5, 6, 7, & + 8, 9, 10, 11, 12, 13, 14, 15, 16, 17/ + DATA msclvlAll/0.5, 0.75, 1, 1.25, 1.5, 1.75, 2, 2.25, 2.5, 2.75, & + 3, 3.5, 4, 4.5, 5, 5.5, 6, 6.5, 7, 7.5, 8, 8.5, & + 9, 10, 11, 12, 13, 14, 15, 16, 18/ +! + REAL(r_kind) :: heightGSI,upref,downref,wght + INTEGER(i_kind) :: ilvl,numref + + real(r_kind) :: ref_mosaic + INTEGER(i_kind) :: i,j, k2, k + +! + if(Nmsclvl < -888 ) then + write(6,*) 'interp_radar_ref: No radar reflectivity data in this subdomain !' + return + endif +! + ref_mos_3d=-99999.0_r_kind + numref=0 + if (Nmsclvl == 31 ) then + DO k=1,Nmsclvl + msclvlAll(k)=msclvlAll(k)*1000.0_r_kind + ENDDO + elseif( Nmsclvl == 21 ) then + msclvlAll=0 + DO k=1,Nmsclvl + msclvlAll(k)=msclvl21(k)*1000.0_r_kind + ENDDO + else + write(6,*) 'interp_radar_ref: Wrong vertical radar mosaic levels' + write(6,*) ' the level read in is:', msclvlAll + call stop2(114) + endif + + DO k2=1,nsig + DO j=2,nlat-1 + DO i=2,nlon-1 + heightGSI=h_bk(i,j,k2)+zh(i,j) + if(heightGSI >= msclvlAll(1) .and. heightGSI < msclvlAll(Nmsclvl) ) then + do k=1,Nmsclvl-1 + if( heightGSI >=msclvlAll(k) .and. heightGSI < msclvlAll(k+1) ) ilvl=k + enddo + upref=ref_mosaic31(i,j,ilvl+1) + downref=ref_mosaic31(i,j,ilvl) + if(abs(upref) <90.0_r_kind .and. abs(downref) <90.0_r_kind ) then + wght=(heightGSI-msclvlAll(ilvl))/(msclvlAll(ilvl+1)-msclvlAll(ilvl)) + ref_mosaic=(1-wght)*downref + wght*upref + numref=numref+1 + elseif( abs(upref+99.0_r_kind) < 0.1_r_kind .or. & + abs(downref+99.0_r_kind) <0.1_r_kind ) then + ref_mosaic=-99.0_r_kind + else + ref_mosaic=-99999.0_r_kind + endif + ref_mos_3d(i,j,k2)=max(ref_mos_3d(i,j,k2),ref_mosaic) + else + ref_mos_3d(i,j,k2)=-99999.0_r_kind + endif + ENDDO + ENDDO + ENDDO + +! + DO k2=1,nsig + DO i=2,nlon-1 + ref_mos_3d(i,1,k2)=ref_mos_3d(i,2,k2) + ref_mos_3d(i,nlat,k2)=ref_mos_3d(i,nlat-1,k2) + ENDDO + DO j=2,nlat-1 + ref_mos_3d(1,j,k2)=ref_mos_3d(2,j,k2) + ref_mos_3d(nlon,j,k2)=ref_mos_3d(nlon-1,j,k2) + ENDDO + ref_mos_3d(nlon,nlat,k2)=ref_mos_3d(nlon-1,nlat-1,k2) + ref_mos_3d(nlon,1,k2)=ref_mos_3d(nlon-1,2,k2) + ref_mos_3d(1,nlat,k2)=ref_mos_3d(2,nlat-1,k2) + ref_mos_3d(1,j,k2)=ref_mos_3d(2,2,k2) + ENDDO + + +END SUBROUTINE vinterp_radar_ref diff --git a/src/enkf/gridio_wrf.f90 b/src/enkf/gridio_wrf.f90 index 6eabcd256f..2717b1e0b6 100644 --- a/src/enkf/gridio_wrf.f90 +++ b/src/enkf/gridio_wrf.f90 @@ -45,8 +45,8 @@ module gridio !------------------------------------------------------------------------- ! Define all public subroutines within this module private - public :: readgriddata - public :: writegriddata + public :: readgriddata, readgriddata_pnc + public :: writegriddata, writegriddata_pnc, WRITEINCREMENT, WRITEINCREMENT_PNC !------------------------------------------------------------------------- @@ -1347,4 +1347,57 @@ subroutine readpressure_arw(filename, znu, znw, mu, mub, ptop) end subroutine readpressure_arw + subroutine writeincrement(nanal1,nanal2,vars3d,vars2d,n3d,n2d,levels,ndim,grdin,no_inflate_flag) + use constants, only: max_varname_length + use params, only: nbackgrounds + implicit none + integer, intent(in) :: nanal1,nanal2 + character(len=max_varname_length), dimension(n2d), intent(in) :: vars2d + character(len=max_varname_length), dimension(n3d), intent(in) :: vars3d + integer, intent(in) :: n2d,n3d,ndim + integer, dimension(0:n3d), intent(in) :: levels + real(r_single), dimension(npts,ndim,nbackgrounds,1), intent(inout) :: grdin + logical, intent(in) :: no_inflate_flag + end subroutine writeincrement + + subroutine writeincrement_pnc(vars3d,vars2d,n3d,n2d,levels,ndim,grdin,no_inflate_flag) + use constants, only: max_varname_length + use params, only: nbackgrounds + implicit none + character(len=max_varname_length), dimension(n2d), intent(in) :: vars2d + character(len=max_varname_length), dimension(n3d), intent(in) :: vars3d + integer, intent(in) :: n2d,n3d,ndim + integer, dimension(0:n3d), intent(in) :: levels + real(r_single), dimension(npts,ndim,nbackgrounds,1), intent(inout) :: grdin + logical, intent(in) :: no_inflate_flag + end subroutine writeincrement_pnc + + subroutine readgriddata_pnc(vars3d,vars2d,n3d,n2d,levels,ndim,ntimes, & + fileprefixes,filesfcprefixes,reducedgrid,grdin,qsat) + use constants, only: max_varname_length + implicit none + character(len=max_varname_length), dimension(n2d), intent(in) :: vars2d + character(len=max_varname_length), dimension(n3d), intent(in) :: vars3d + integer, intent(in) :: n2d, n3d + integer, dimension(0:n3d), intent(in) :: levels + integer, intent(in) :: ndim, ntimes + character(len=120), dimension(7), intent(in) :: fileprefixes + character(len=120), dimension(7), intent(in) :: filesfcprefixes + logical, intent(in) :: reducedgrid + real(r_single), dimension(npts,ndim,ntimes,1), intent(out) :: grdin + real(r_double), dimension(npts,nlevs,ntimes,1), intent(out) :: qsat + end subroutine readgriddata_pnc + + subroutine writegriddata_pnc(vars3d,vars2d,n3d,n2d,levels,ndim,grdin,no_inflate_flag) + use constants, only: max_varname_length + use params, only: nbackgrounds + implicit none + character(len=max_varname_length), dimension(n2d), intent(in) :: vars2d + character(len=max_varname_length), dimension(n3d), intent(in) :: vars3d + integer, intent(in) :: n2d,n3d,ndim + integer, dimension(0:n3d), intent(in) :: levels + real(r_single), dimension(npts,ndim,nbackgrounds,1), intent(inout) :: grdin + logical, intent(in) :: no_inflate_flag + end subroutine writegriddata_pnc + end module gridio diff --git a/src/gsi/gsdcloudanalysis.F90 b/src/gsi/gsdcloudanalysis.F90 index 381aa012b3..599208ed8c 100644 --- a/src/gsi/gsdcloudanalysis.F90 +++ b/src/gsi/gsdcloudanalysis.F90 @@ -1,4 +1,3 @@ -#ifdef RR_CLOUDANALYSIS subroutine gsdcloudanalysis(mype) ! !$$$ subprogram documentation block @@ -86,6 +85,7 @@ subroutine gsdcloudanalysis(mype) ! Declare passed variables integer(i_kind),intent(in):: mype +#ifdef RR_CLOUDANALYSIS ! ! background ! @@ -1192,52 +1192,10 @@ subroutine gsdcloudanalysis(mype) write(6,*) '========================================' endif -end subroutine gsdcloudanalysis #else /* Start no RR cloud analysis library block */ -subroutine gsdcloudanalysis(mype) -! -!$$$ subprogram documentation block -! . . . . -! subprogram: gsdcloudanalysis driver for generalized cloud/hydrometeor analysis -! -! PRGMMR: Ming Hu ORG: GSD/AMB DATE: 2006-10-27 -! -! ABSTRACT: -! This subroutine serves as a driver for generalized cloud/hydrometeor analysis -! -! PROGRAM HISTORY LOG: -! 2008-12-20 Hu Add NCO document block -! -! -! input argument list: -! mype - processor ID that does this IO -! -! output argument list: -! -! USAGE: -! INPUT FILES: -! mype - processor ID that does this IO -! -! OUTPUT FILES: -! -! REMARKS: -! -! ATTRIBUTES: -! LANGUAGE: FORTRAN 90 -! MACHINE: Linux cluster (WJET) at NOAA/ESRL - Boulder, CO -! -!$$$ -!_____________________________________________________________________ -! - - use kinds, only: i_kind - implicit none - -! Declare passed variables - integer(i_kind),intent(in):: mype -! if( mype == 0) write(6,*)'gsdcloudanalysis: dummy routine, does nothing!' -end subroutine gsdcloudanalysis #endif /* End no RR cloud analysis library block */ + +end subroutine gsdcloudanalysis diff --git a/src/gsi/gsdcloudanalysis4gfs.F90 b/src/gsi/gsdcloudanalysis4gfs.F90 index 74c38d6a2a..c778471120 100644 --- a/src/gsi/gsdcloudanalysis4gfs.F90 +++ b/src/gsi/gsdcloudanalysis4gfs.F90 @@ -1,4 +1,3 @@ -#ifdef RR_CLOUDANALYSIS subroutine gsdcloudanalysis4gfs(mype) ! !$$$ subprogram documentation block @@ -83,6 +82,7 @@ subroutine gsdcloudanalysis4gfs(mype) ! Declare passed variables integer(i_kind),intent(in):: mype +#ifdef RR_CLOUDANALYSIS ! ! background ! @@ -931,53 +931,10 @@ subroutine gsdcloudanalysis4gfs(mype) write(6,*) 'gsdcloudanalysis: generalized cloud analysis finished:',mype write(6,*) '========================================' endif - -end subroutine gsdcloudanalysis4gfs #else /* Start no RR cloud analysis library block */ -subroutine gsdcloudanalysis4gfs(mype) -! -!$$$ subprogram documentation block -! . . . . -! subprogram: gsdcloudanalysis driver for generalized cloud/hydrometeor analysis -! -! PRGMMR: Ming Hu ORG: GSD/AMB DATE: 2006-10-27 -! -! ABSTRACT: -! This subroutine serves as a driver for generalized cloud/hydrometeor analysis -! -! PROGRAM HISTORY LOG: -! 2008-12-20 Hu Add NCO document block -! -! -! input argument list: -! mype - processor ID that does this IO -! -! output argument list: -! -! USAGE: -! INPUT FILES: -! mype - processor ID that does this IO -! -! OUTPUT FILES: -! -! REMARKS: -! -! ATTRIBUTES: -! LANGUAGE: FORTRAN 90 -! MACHINE: Linux cluster (WJET) at NOAA/ESRL - Boulder, CO -! -!$$$ -!_____________________________________________________________________ -! - - use kinds, only: i_kind - implicit none - -! Declare passed variables - integer(i_kind),intent(in):: mype -! if( mype == 0) write(6,*)'gsdcloudanalysis: dummy routine, does nothing!' -end subroutine gsdcloudanalysis4gfs #endif /* End no RR cloud analysis library block */ + +end subroutine gsdcloudanalysis4gfs diff --git a/src/gsi/phil2.f90 b/src/gsi/phil2.f90 index 9dce41f215..e17c43f176 100644 --- a/src/gsi/phil2.f90 +++ b/src/gsi/phil2.f90 @@ -349,11 +349,11 @@ subroutine denest(nob,nrand,nor, &! [denest] xob(:,L)=(/clat*clon,clat*slon,slon/) rob(L)=(altob(L)-vmin)/uv-vrand! <- altitudes in hilbert vertical units enddo -if(nrand<1 .or. nrand>273)stop'nrand is invalid' +if(nrand<1 .or. nrand>273)stop 'nrand is invalid' if(nrand>5)then; call getqset7( qset7); if(nrand>7)call getqset13(qset13) else; call getqset5(nrand,qset5) endif -if(nrand>91) call getqset5(3,qset3) +if(nrand>91) call getqset5(3,qset3(:,:)) ! Project the data onto nrand differently-oriented Hilbert curves and sum @@ -407,7 +407,7 @@ subroutine denest(nob,nrand,nor, &! [denest] case(1) call bsmoo1(nob,span,sob,rank,wtob) case default - stop'In denest; this value of B-spline order, nor, is not supported' + stop 'In denest; this value of B-spline order, nor, is not supported' end select enddo! irand ! Convert the sum of Hilbert-parameter-relative densities to an average, @@ -499,7 +499,7 @@ subroutine denestx(nob,nrand,nor, &! [denest] xob(:,L)=(/clat*clon,clat*slon,slon/) rob(L)=(altob(L)-vmin)/uv-vrand! <- altitudes in hilbert vertical units enddo -if(nrand<1 .or. nrand>104)stop'nrand is invalid' +if(nrand<1 .or. nrand>104)stop 'nrand is invalid' if(nrand>5)then; call getqset8( qset8); if(nrand>8)call getqset13(qset13) else; call getqset5(nrand,qset5) endif @@ -549,7 +549,7 @@ subroutine denestx(nob,nrand,nor, &! [denest] case(1) call bsmoo1(nob,span,sob,rank,denob) case default - stop'In denest; this value of B-spline order, nor, is not supported' + stop 'In denest; this value of B-spline order, nor, is not supported' end select enddo! irand ! Convert the sum of Hilbert-parameter-relative densities to an average, @@ -650,7 +650,7 @@ subroutine denest2d(nob,nrand,nor,dentrip,scale,& ! [denest2d] case(1) call bsmoo1(nob,span,sob,rank,wtob) case default - stop'In denest; this value of B-spline order, nor, is not supported' + stop 'In denest; this value of B-spline order, nor, is not supported' end select ! Rotate the Hilbert tile by a pi/(2*nrand) about its axis at (1/3,1/3): if(Lnunit)& - stop'In writevqcascfile; No available unit number for writing' + stop 'In writevqcascfile; No available unit number for writing' open(unit=iunit,file=vqcascfile,access='sequential',form='formatted') write(iunit,600)npx,npa,npb,npk,nx,na write(iunit,601)sgt @@ -198,15 +198,15 @@ subroutine readvqcascfile(vqcascfile,&! [readvqcascfile] if(.not.op)exit enddo if(.not.ex .or. iunit>nunit)& - stop'In readvqcascfile; No available unit number for reading' + stop 'In readvqcascfile; No available unit number for reading' open(unit=iunit,file=vqcascfile,access='sequential',form='formatted') read(iunit,600)npx,npa,npb,npk,nx,na -if(npx_a/=npx)stop'In readvqcascfile; mismatched specified npx' -if(npa_a/=npa)stop'In readvqcascfile; mismatched specified npa' -if(npb_a/=npb)stop'In readvqcascfile; mismatched specified npb' -if(npk_a/=npk)stop'In readvqcascfile; mismatched specified npk' -if(nx_a /=nx )stop'In readvqcascfile; mismatched specified nx' -if(na_a /=na )stop'In readvqcascfile; mismatched specified na' +if(npx_a/=npx)stop 'In readvqcascfile; mismatched specified npx' +if(npa_a/=npa)stop 'In readvqcascfile; mismatched specified npa' +if(npb_a/=npb)stop 'In readvqcascfile; mismatched specified npb' +if(npk_a/=npk)stop 'In readvqcascfile; mismatched specified npk' +if(nx_a /=nx )stop 'In readvqcascfile; mismatched specified nx' +if(na_a /=na )stop 'In readvqcascfile; mismatched specified na' nkm=npk-1 npb2=npb*2 allocate(sgt(-nx:nx,0:na,-nkm:nkm),swt(-nx:nx,0:na,-nkm:nkm),& @@ -250,13 +250,13 @@ subroutine writevqcdatfile(vqcdatfile,&! [writevqcdatfile] logical :: ex,op !============================================================================== if(.not.linitvqc)& - stop'In writevqcdatfile; VQC parameters and tables are not yet initialized' -if(npx_a/=npx)stop'In writevqcdatfile; mismatched specified npx' -if(npa_a/=npa)stop'In writevqcdatfile; mismatched specified npa' -if(npb_a/=npb)stop'In writevqcdatfile; mismatched specified npb' -if(npk_a/=npk)stop'In writevqcdatfile; mismatched specified npk' -if(nx_a /=nx )stop'In writevqcdatfile; mismatched specified nx' -if(na_a /=na )stop'In writevqcdatfile; mismatched specified na' + stop 'In writevqcdatfile; VQC parameters and tables are not yet initialized' +if(npx_a/=npx)stop 'In writevqcdatfile; mismatched specified npx' +if(npa_a/=npa)stop 'In writevqcdatfile; mismatched specified npa' +if(npb_a/=npb)stop 'In writevqcdatfile; mismatched specified npb' +if(npk_a/=npk)stop 'In writevqcdatfile; mismatched specified npk' +if(nx_a /=nx )stop 'In writevqcdatfile; mismatched specified nx' +if(na_a /=na )stop 'In writevqcdatfile; mismatched specified na' do iunit=lunit,nunit inquire(unit=iunit, exist=ex, opened=op) @@ -264,7 +264,7 @@ subroutine writevqcdatfile(vqcdatfile,&! [writevqcdatfile] if(.not.op)exit enddo if(.not.ex .or. iunit>nunit)& - stop'In writevqcdatfile; No available unit number for writing' + stop 'In writevqcdatfile; No available unit number for writing' open(unit=iunit,file=vqcdatfile,access='sequential',form='unformatted') write(unit=iunit)npx,npa,npb,npk,nx,na write(iunit)sgt @@ -306,15 +306,15 @@ subroutine readvqcdatfile(vqcdatfile,&! [readvqcdatfile] if(.not.op)exit enddo if(.not.ex .or. iunit>nunit)& - stop'In readvqcdatfile; No available unit number for reading' + stop 'In readvqcdatfile; No available unit number for reading' open(unit=iunit,file=vqcdatfile,access='sequential',form='unformatted') read(iunit)npx,npa,npb,npk,nx,na -if(npx_a/=npx)stop'In readvqcdatfile; mismatched specified npx' -if(npa_a/=npa)stop'In readvqcdatfile; mismatched specified npa' -if(npb_a/=npb)stop'In readvqcdatfile; mismatched specified npb' -if(npk_a/=npk)stop'In readvqcdatfile; mismatched specified npk' -if(nx_a /=nx )stop'In readvqcdatfile; mismatched specified nx' -if(na_a /=na )stop'In readvqcdatfile; mismatched specified na' +if(npx_a/=npx)stop 'In readvqcdatfile; mismatched specified npx' +if(npa_a/=npa)stop 'In readvqcdatfile; mismatched specified npa' +if(npb_a/=npb)stop 'In readvqcdatfile; mismatched specified npb' +if(npk_a/=npk)stop 'In readvqcdatfile; mismatched specified npk' +if(nx_a /=nx )stop 'In readvqcdatfile; mismatched specified nx' +if(na_a /=na )stop 'In readvqcdatfile; mismatched specified na' nkm=npk-1 npb2=npb*2 allocate(sgt(-nx:nx,0:na,-nkm:nkm),swt(-nx:nx,0:na,-nkm:nkm),& @@ -358,13 +358,13 @@ subroutine vqch_iii(ia,ib,ik,x,g,w)! [vqch] x1,x2,xa,ya,xx integer(i_kind) :: ja !============================================================================== -if(.not.linitvqc)stop'In vqch; VQC tables are not initialized' +if(.not.linitvqc)stop 'In vqch; VQC tables are not initialized' if(ia<0)then; sx=-x; ja=-ia else; sx= x; ja= ia endif -if(ja>na )stop'In vqch; ia out of bounds' -if(ib<=0.or.ib>=npb2 )stop'In vqch; ib out of bounds' -if(ik<=-npk.or.ik>=npk)stop'In vqch; ik out of bounds' +if(ja>na )stop 'In vqch; ia out of bounds' +if(ib<=0.or.ib>=npb2 )stop 'In vqch; ib out of bounds' +if(ik<=-npk.or.ik>=npk)stop 'In vqch; ik out of bounds' x1=x1t(ja,ik) x2=x2t(ja,ik) xa=xat(ja,ik) @@ -428,8 +428,8 @@ subroutine vqch_r(beta,x,g,w)! [vqch] real(dp),parameter:: pio4=pi/4_dp real(dp) :: bc,p,q,qx,x1,x2,ya,xx !============================================================================== -if(.not.linitvqc)stop'In vqch; VQC tables are not initialized' -if(beta<=u0.or.beta>=u2)stop'In vqch; beta out of bounds' +if(.not.linitvqc)stop 'In vqch; VQC tables are not initialized' +if(beta<=u0.or.beta>=u2)stop 'In vqch; beta out of bounds' x1=x1t(0,0) x2=x2t(0,0) ya=yat(0,0) @@ -478,13 +478,13 @@ subroutine vqcs_iii(ia,ib,ik,x,g,w)! [vqcs] ww,dfa,fl,dfl,f1,f2,df1,df2,g1,g2 integer(i_kind) :: ix1,ix2,ja !============================================================================== -if(.not.linitvqc)stop'In vqcs; VQC tables are not initialized' +if(.not.linitvqc)stop 'In vqcs; VQC tables are not initialized' if(ia<0)then; sx=-x; ja=-ia else; sx= x; ja= ia endif -if(ja>na )stop'In vqcs; ia out of bounds' -if(ib<=0.or.ib>=npb2 )stop'In vqcs; ib out of bounds' -if(ik<=-npk.or.ik>=npk)stop'In vqcs; ik out of bounds' +if(ja>na )stop 'In vqcs; ia out of bounds' +if(ib<=0.or.ib>=npb2 )stop 'In vqcs; ib out of bounds' +if(ik<=-npk.or.ik>=npk)stop 'In vqcs; ik out of bounds' beta =ib*db kappa=ik*dk bc=tan(pio4*(u2-beta)) @@ -574,7 +574,7 @@ subroutine vqcs_r(beta,x,g,w)! [vqcs] ww,dfa,fl,dfl,f1,f2,df1,df2,g1,g2 integer(i_kind) :: ix1,ix2 !============================================================================== -if(.not.linitvqc)stop'In vqcs; VQC tables are not initialized' +if(.not.linitvqc)stop 'In vqcs; VQC tables are not initialized' bc=tan(pio4*(u2-beta)) p=bc**2 q=u1/bc diff --git a/src/gsi/pvqc_tables.f90 b/src/gsi/pvqc_tables.f90 index 25bf8ca9ed..6f8da834c9 100755 --- a/src/gsi/pvqc_tables.f90 +++ b/src/gsi/pvqc_tables.f90 @@ -27,7 +27,7 @@ module pvqc_tables ! na: size [0:na] of one-sided table in alpha ! linitvqc: logical flag, true only when tables are initialized !============================================================================= -use kinds, only: dp,i_kind +use kinds, only: r_kind,dp,i_kind implicit none public real(dp),allocatable,dimension(:,:,:):: sgt,swt diff --git a/ush/build.comgsi b/ush/build.comgsi index 3b014dc078..2188f015af 100755 --- a/ush/build.comgsi +++ b/ush/build.comgsi @@ -5,31 +5,55 @@ # Cheyenne: source /glade/p/ral/jntp/gge/modulefiles/modulefile.cheyenne.GSI_UPP_WRF # # build commands: -# cmake -DENKF_MODE=WRF -DBUILD_CORELIBS=ON -DBUILD_GSDCLOUD_ARW=ON path_to_ProdGSI -# cmake -DENKF_MODE=WRF -DBUILD_CORELIBS=ON -DBUILD_GSDCLOUD_ARW=ON -DBUILD_UTIL_COM=ON -DBUILD_ENKF_PREPROCESS_ARW=ON" +# cmake -DENKF_MODE=WRF -DBUILD_CORELIBS=ON -DBUILD_GSDCLOUD_ARW=ON path_to_GSI +# cmake -DENKF_MODE=WRF -DBUILD_CORELIBS=ON -DBUILD_GSDCLOUD_ARW=ON -DBUILD_UTIL_COM=ON -DBUILD_ENKF_PREPROCESS_ARW=ON path_to_GSI" +# (for global: cmake -D-DENKF_MODE=GFS -DBUILD_CORELIBS=ON path_to_GSI) # make -j8 # dir_root=$(pwd) -if [[ "`grep -i "theia" /etc/hosts | head -n1`" != "" ]] ; then ###theia - source /etc/profile.d/modules.sh - modulefile="/home/rtrr/PARM_EXEC/modulefiles/modulefile.theia.GSI_UPP_WRF" -elif [[ "`grep -i "hera" /etc/hosts | head -n1`" != "" ]] ; then ###hera +################# Hera #################### +if [[ "`grep -i "hera" /etc/hosts | head -n1`" != "" ]] ; then source /etc/profile.d/modules.sh modulefile="/home/rtrr/PARM_EXEC/modulefiles/modulefile.hera.GSI_UPP_WRF" -elif [[ -d /jetmon ]] ; then ### jet + NCEPLIBS="/scratch1/BMC/comgsi/precompiled/NCEPLIBS/b_intel18.0.5.274_impi2018.0.4/install" + GSILIBS="/scratch1/BMC/comgsi/precompiled/GSILIBS/b_intel18.0.5.274_impi2018.0.4" + +################# Jet #################### +elif [[ -d /jetmon ]] ; then source /etc/profile.d/modules.sh modulefile="/home/rtrr/PARM_EXEC/modulefiles/modulefile.jet.GSI_UPP_WRF" -elif [[ -d /glade ]] ; then ### cheyenne + NCEPLIBS="/lfs4/BMC/wrfruc/gge/precompiled/NCEPLIBS/b_intel18.0.5.274_impi2018.4.274/install" + GSILIBS="/lfs4/BMC/wrfruc/gge/precompiled/GSILIBS/b_intel18.0.5.274_impi2018.4.274" + +################# Cheyenne #################### +elif [[ -d /glade ]] ; then source /etc/profile.d/modules.sh modulefile="/glade/p/ral/jntp/gge/modulefiles/modulefile.cheyenne.GSI_UPP_WRF" + NCEPLIBS="/glade/p/ral/jntp/gge/precompiled/NCEPLIBS/b_intel18.0.5_impi2018.4.274/install" + GSILIBS="/glade/p/ral/jntp/gge/precompiled/GSILIBS/b_intel18.0.5_impi2018.4.274" + #modulefile="/glade/p/ral/jntp/gge/precompiled/NCEPLIBS/modulefile.cheyenne.GSI_UPP_WRF.gnu" + #NCEPLIBS="/glade/p/ral/jntp/gge/precompiled/NCEPLIBS/b_gnu8.3.0_openmpi3.1.4/install" + #GSILIBS="/glade/p/ral/jntp/gge/precompiled/GSILIBS/b_gnu8.3.0_openmpi3.1.4/" + +################# Orion #################### elif [[ -d /work/noaa ]] ; then ### orion - modulefile="/work/noaa/comgsi/modulefiles/modulefile.orion.GSI_UPP_WRF" - #modulefile="/work/noaa/comgsi/modulefiles/modulefile.intel20" + modulefile="/home/gge/modulefiles/modulefile.orion.GSI_UPP_WRF" + NCEPLIBS="/work/noaa/wrfruc/gge/precompiled/NCEPLIBS/b_intel2018.4_impi2018.4/install" + GSILIBS="/work/noaa/wrfruc/gge/precompiled/GSILIBS/b_intel2018.4_impi2018.4" + +################# Generic #################### else - echo "unknown machine" + echo -e "\nunknown machine" + echo "Please modify build.comgsi at this location" + echo "to load required modules and setup NCEPLIBS and GSILIBS" + ##follow the above examples and delete the following "exit 9" to go forward exit 9 + source /etc/profile.d/modules.sh + modulefile="/my/modulefile.me.GSI_UPP_WRF" + NCEPLIBS="/my/NCEPLIBS/b_intel18.0.5_impi2018.4.274/install" + GSILIBS="/my/GSILIBS/b_intel18.0.5_impi2018.4.274/" fi if [ ! -f $modulefile ]; then @@ -43,6 +67,29 @@ if [[ "$NETCDF4" == "1" ]] || [[ "$NETCDF4" == "0" ]]; then unset NETCDF4 fi +export BACIO_LIB4=${NCEPLIBS}/lib/libbacio_4.a +#export BUFR_LIBd=${NCEPLIBS}/lib/libbufr_d.a + export BUFR_LIBd=${GSILIBS}/lib/libbufr_v.a + export GSIWRF_LIB=${GSILIBS}/lib/libWRFLIB.a +export CRTM_LIB=${NCEPLIBS}/lib/libcrtm.a +export CRTM_INC=${NCEPLIBS}/include +export NEMSIO_LIB=${NCEPLIBS}/lib/libnemsio.a +export NEMSIO_INC=${NCEPLIBS}/include +export SFCIO_LIB4=${NCEPLIBS}/lib/libsfcio_4.a +export SFCIO_INC4=${NCEPLIBS}/include_4 +export SIGIO_LIB4=${NCEPLIBS}/lib/libsigio_4.a +export SIGIO_INC4=${NCEPLIBS}/include_4 +export SP_LIBd=${NCEPLIBS}/lib/libsp_d.a +export SP_LIB4=${NCEPLIBS}/lib/libsp_4.a +export W3EMC_LIBd=${NCEPLIBS}/lib/libw3emc_d.a +export W3EMC_LIB4=${NCEPLIBS}/lib/libw3emc_4.a +export W3EMC_INCd=${NCEPLIBS}/include_d +export W3EMC_INC4=${NCEPLIBS}/include_4 +export W3NCO_LIBd=${NCEPLIBS}/lib/libw3nco_d.a +export W3NCO_LIB4=${NCEPLIBS}/lib/libw3nco_4.a +export IP_LIBd=${NCEPLIBS}/lib/libip_d.a +export IP_LIB4=${NCEPLIBS}/lib/libip_4.a + set -x rm -rf $dir_root/build mkdir -p $dir_root/build @@ -60,17 +107,18 @@ git log -1 | head -n1 >> output.log echo -e "\ngit status:" >> output.log git status >> output.log echo -e "\nCompiling commands:" >> output.log -echo " cmake -DENKF_MODE=WRF -DBUILD_CORELIBS=ON -DBUILD_GSDCLOUD_ARW=ON -DBUILD_ENKF_PREPROCESS_ARW=ON -DBUILD_UTIL_COM=ON .." >> output.log +echo " cmake -DENKF_MODE=WRF -DBUILD_CORELIBS=ON -DBUILD_GSDCLOUD_ARW=ON -DBUILD_ENKF_PREPROCESS_ARW=ON -DBUILD_UTIL_COM=ON -Wno-dev .." >> output.log echo " make -j8" >> output.log cat output.log -cmake -DENKF_MODE=WRF -DBUILD_CORELIBS=ON -DBUILD_GSDCLOUD_ARW=ON -DBUILD_ENKF_PREPROCESS_ARW=ON -DBUILD_UTIL_COM=ON .. 2>&1 | tee output.cmake +cmake -DENKF_MODE=WRF -DBUILD_CORELIBS=ON -DBUILD_GSDCLOUD_ARW=ON -DBUILD_ENKF_PREPROCESS_ARW=ON -DBUILD_UTIL_COM=ON -Wno-dev .. 2>&1 | tee output.cmake make -j 8 2>&1 | tee output.compile ###aftermath commitID=`git log -1 | head -n1 |cut -c8-15` repoName=`git config --get remote.origin.url | cut -d: -f2` +repoName=${repoName//\//:} datestamp=`date +%Y%m%d` cd bin ln -sf gsi.x gsi.x_${repoName}_${datestamp}_${commitID} diff --git a/util/EnKF/arw/src/enspreproc_regional.fd/CMakeLists.txt b/util/EnKF/arw/src/enspreproc_regional.fd/CMakeLists.txt index 663f6323f5..a994eb945e 100644 --- a/util/EnKF/arw/src/enspreproc_regional.fd/CMakeLists.txt +++ b/util/EnKF/arw/src/enspreproc_regional.fd/CMakeLists.txt @@ -2,12 +2,12 @@ cmake_minimum_required(VERSION 2.6) set(GSI_Fortran_FLAGS_LOCAL "${GSI_Fortran_FLAGS} -DWRF") file(GLOB LOCAL_SRC ${CMAKE_CURRENT_SOURCE_DIR}/*.f90 ${CMAKE_CURRENT_SOURCE_DIR}/*.F90) set_source_files_properties( ${LOCAL_SRC} PROPERTIES COMPILE_FLAGS ${GSI_Fortran_FLAGS_LOCAL} ) - include_directories( ${PROJECT_BINARY_DIR}/include ${CORE_INCS} ${NETCDF_INCLUDES} ${MPI_Fortran_INCLUDE_PATH} ) + include_directories( ${PROJECT_BINARY_DIR}/include ${CORE_INCS} ${NETCDF_INCLUDES} ${MPI_Fortran_INCLUDE_PATH} ${FV3GFS_NCIO_INCS} ) add_executable(enspreproc.x ${LOCAL_SRC} ) set_target_properties( enspreproc.x PROPERTIES COMPILE_FLAGS ${GSI_Fortran_FLAGS_LOCAL} ) target_link_libraries(enspreproc.x ${GSISHAREDLIB} ${GSILIB} ${GSISHAREDLIB} ${WRF_LIBRARIES} ${NETCDF_LIBRARIES_F90} ${NETCDF_LIBRARIES} ${HDF5_Fortran_HL_LIBRARIES} ${MPI_Fortran_LIBRARIES} ${LAPACK_LIBRARIES} -L./ ${EXTRA_LINKER_FLAGS} ${HDF5_LIBRARIES} ${CURL_LIBRARIES} ${CORE_LIBRARIES} ${CORE_BUILT} - ${GSI_LDFLAGS} ${NCDIAG_LIBRARIES} ${ZLIB_LIBRARIES} ${wrflib} ) + ${GSI_LDFLAGS} ${NCDIAG_LIBRARIES} ${ZLIB_LIBRARIES} ${wrflib} ${FV3GFS_NCIO_LIBRARIES} ) add_dependencies(enspreproc.x ${GSILIB})