diff --git a/.circleci/config.yml b/.circleci/config.yml index 6de527ca6..03b767822 100644 --- a/.circleci/config.yml +++ b/.circleci/config.yml @@ -1,11 +1,11 @@ version: 2.1 # Anchors in case we need to override the defaults from the orb -#baselibs_version: &baselibs_version v7.27.0 -#bcs_version: &bcs_version v11.6.0 +#baselibs_version: &baselibs_version v8.14.0 +#bcs_version: &bcs_version v12.0.0 orbs: - ci: geos-esm/circleci-tools@4 + ci: geos-esm/circleci-tools@5 workflows: build-test: @@ -21,7 +21,10 @@ workflows: #baselibs_version: *baselibs_version repo: GEOSgcm checkout_fixture: true - mepodevelop: true + # V12 code uses a special branch for now. + fixture_branch: feature/sdrabenh/gcm_v12 + # We comment out this as it will "undo" the fixture_branch + #mepodevelop: true persist_workspace: true # Needs to be true to run fv3/gcm experiment, costs extra # Run AMIP GCM (1 hour, no ExtData) diff --git a/.github/workflows/spack-ci.yml b/.github/workflows/spack-ci.yml index 4268d3b91..59c5bdd62 100644 --- a/.github/workflows/spack-ci.yml +++ b/.github/workflows/spack-ci.yml @@ -28,6 +28,7 @@ jobs: fetch-depth: 1 filter: blob:none repository: GEOS-ESM/GEOSgcm + ref: feature/sdrabenh/gcm_v12 - name: Set all directories as git safe run: | @@ -107,7 +108,7 @@ jobs: run: | spack clean -m spack -e spack-env install --add --no-check-signature --use-buildcache only \ - esmf gftl gftl-shared fargparse pflogger pfunit yafyaml ecbuild udunits openblas + esmf gftl gftl-shared fargparse pflogger pfunit yafyaml ecbuild udunits openblas fms - name: Build with Cmake shell: spack-bash {0} diff --git a/.github/workflows/workflow.yml b/.github/workflows/workflow.yml index 90f865944..5a2287cbe 100644 --- a/.github/workflows/workflow.yml +++ b/.github/workflows/workflow.yml @@ -21,7 +21,7 @@ jobs: if: "!contains(github.event.pull_request.labels.*.name, '0 diff trivial')" runs-on: ubuntu-24.04 container: - image: gmao/ubuntu24-geos-env:v7.33.0-intelmpi_2021.13-ifort_2021.13 + image: gmao/ubuntu24-geos-env:v8.14.0-intelmpi_2021.13-ifort_2021.13 # Per https://github.com/actions/virtual-environments/issues/1445#issuecomment-713861495 # It seems like we might not need secrets on GitHub Actions which is good for forked # pull requests @@ -45,6 +45,7 @@ jobs: fetch-depth: 1 filter: blob:none repository: GEOS-ESM/GEOSgcm + ref: feature/sdrabenh/gcm_v12 - name: Set all directories as git safe run: | diff --git a/CMakeLists.txt b/CMakeLists.txt index bba3fcd40..6a3588eef 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -9,11 +9,12 @@ set (alldirs ) option(BUILD_WITH_GIGATRAJ "Build GEOSgcm with Gigatraj" OFF) - if (BUILD_WITH_GIGATRAJ) list(APPEND alldirs GEOSgigatraj_GridComp) endif() +option(BUILD_WITH_PYMLINC "Build pyMLINC interface" OFF) + if (EXISTS ${CMAKE_CURRENT_SOURCE_DIR}/GEOS_GcmGridComp.F90) ecbuild_declare_project() @@ -23,6 +24,7 @@ if (EXISTS ${CMAKE_CURRENT_SOURCE_DIR}/GEOS_GcmGridComp.F90) DEPENDENCIES MAPL ESMF::ESMF) target_compile_definitions (${this} PRIVATE $<$:HAS_GIGATRAJ>) + target_compile_definitions (${this} PRIVATE $<$:HAS_PYMLINC>) ecbuild_install_project( NAME GEOSgcm_GridComp) diff --git a/GEOS_GcmGridComp.F90 b/GEOS_GcmGridComp.F90 index 96d183e14..d7aa45d4d 100644 --- a/GEOS_GcmGridComp.F90 +++ b/GEOS_GcmGridComp.F90 @@ -204,8 +204,8 @@ subroutine SetServices ( GC, RC ) call ESMF_ConfigGetAttribute(CF, NUM_ICE_CATEGORIES, Label="CICE_N_ICE_CATEGORIES:" , _RC) if (DO_CICE_THERMO == 1) then call ESMF_ConfigGetAttribute(CF, NUM_ICE_LAYERS, Label="CICE_N_ICE_LAYERS:" , _RC) - endif - else + endif + else NUM_ICE_CATEGORIES = 1 NUM_ICE_LAYERS = 1 endif @@ -577,8 +577,15 @@ subroutine SetServices ( GC, RC ) VERIFY_(STATUS) endif - - if (DO_CICE_THERMO == 2) then + call MAPL_AddConnectivity ( GC, & + SHORT_NAME = (/'QLTOT', 'QITOT', 'QRTOT', & + 'QSTOT', 'QGTOT'/), & + DST_ID = AIAU, & + SRC_ID = AGCM, & + RC=STATUS ) + VERIFY_(STATUS) + + if (DO_CICE_THERMO == 2) then call MAPL_AddConnectivity ( GC, & SHORT_NAME = (/'SURFSTATE'/), & DST_ID = AGCM, & @@ -618,15 +625,15 @@ subroutine SetServices ( GC, RC ) _RC) endif - if (DO_CICE_THERMO <= 1) then + if (DO_CICE_THERMO <= 1) then call MAPL_TerminateImport ( GC, & SHORT_NAME = [character(len=5) :: & 'HI', 'FRESH', 'FSALT', 'FHOCN'], & CHILD = OGCM, & _RC) - endif + endif - if (DO_CICE_THERMO == 1) then + if (DO_CICE_THERMO == 1) then call MAPL_TerminateImport ( GC, & SHORT_NAME = (/ & 'FRACICE', 'VOLICE ', 'VOLSNO ', & @@ -640,7 +647,7 @@ subroutine SetServices ( GC, RC ) end if if (DO_WAVES /= 0) then - ! Terminate the imports of WGCM with the exception + ! Terminate the imports of WGCM with the exception ! of the few that have to be sent to ExtData call MAPL_TerminateImport(GC, & SHORT_NAME = (/ & @@ -843,6 +850,7 @@ subroutine Initialize ( GC, IMPORT, EXPORT, CLOCK, RC ) type(ESMF_Calendar) :: cal type(ESMF_Time) :: rep_StartTime + type(ESMF_Time) :: rep_EndTime type(ESMF_Time) :: rep_RefTime type(ESMF_Time) :: currTime type(ESMF_Time) :: ringTime @@ -866,6 +874,7 @@ subroutine Initialize ( GC, IMPORT, EXPORT, CLOCK, RC ) integer :: MKIAU_REFERENCE_TIME integer :: rplshut integer :: rep_startdate(2) + integer :: rep_enddate(2) integer :: rep_YY integer :: rep_MM integer :: rep_DD @@ -919,7 +928,7 @@ subroutine Initialize ( GC, IMPORT, EXPORT, CLOCK, RC ) if (DO_WAVES /= 0) then call MAPL_GridCreate(GCS(WGCM), rc=status) VERIFY_(STATUS) - end if + end if ! Create Ocean grid !------------------ @@ -995,8 +1004,6 @@ subroutine Initialize ( GC, IMPORT, EXPORT, CLOCK, RC ) i_MKIAU_FREQUENCY = gcm_internal_state%rplfreq MKIAU_REFERENCE_TIME = gcm_internal_state%rplreft - call MAPL_GetResource(MAPL, rplshut, Label="REPLAY_SHUTOFF:", default=-3600, rc=status) - VERIFY_(STATUS) call ESMF_ClockGet(clock, currTime=currTime, calendar=cal, rc=status) VERIFY_(STATUS) @@ -1005,9 +1012,6 @@ subroutine Initialize ( GC, IMPORT, EXPORT, CLOCK, RC ) call ESMF_TimeIntervalSet(MKIAU_FREQUENCY, S=i_MKIAU_FREQUENCY, rc=status) VERIFY_(STATUS) - call ESMF_TimeIntervalSet(Shutoff, S=abs(rplshut), rc=status) - VERIFY_(STATUS) - rep_StartTime = currTime ! UNPACK REPLAY_STARTTIME @@ -1028,7 +1032,9 @@ subroutine Initialize ( GC, IMPORT, EXPORT, CLOCK, RC ) ! Update REPLAY_STARTDATE with User-Supplied values from CONFIG ! ------------------------------------------------------------- call MAPL_GetResource( MAPL, rep_startdate(1), label='REPLAY_STARTDATE:', default=rep_startdate(1), rc=STATUS ) + VERIFY_(STATUS) call MAPL_GetResource( MAPL, rep_startdate(2), label='REPLAY_STARTTIME:', default=rep_startdate(2), rc=STATUS ) + VERIFY_(STATUS) ! REPACK REPLAY_STARTTIME ! ----------------------- @@ -1063,6 +1069,54 @@ subroutine Initialize ( GC, IMPORT, EXPORT, CLOCK, RC ) calendar=cal, rc = STATUS ) VERIFY_(STATUS) + ! Initialize REPLAY_ENDDATE in YYYYMMDD & HHMMSS format + ! ------------------------------------------------------- + rep_enddate(1) = -10000*rep_YY - 100*rep_MM - rep_DD + rep_enddate(2) = 10000*rep_H + 100*rep_M + rep_S + + ! Update REPLAY_ENDDATE with User-Supplied values from CONFIG + ! ------------------------------------------------------------- + call MAPL_GetResource( MAPL, rep_enddate(1), label='REPLAY_ENDDATE:', default=rep_enddate(1), rc=STATUS ) + VERIFY_(STATUS) + call MAPL_GetResource( MAPL, rep_enddate(2), label='REPLAY_ENDTIME:', default=rep_enddate(2), rc=STATUS ) + VERIFY_(STATUS) + + ! REPACK REPLAY_ENDTIME + ! ----------------------- + if (rep_enddate(1) > 0) then + rep_YY = rep_enddate(1)/10000 + rep_MM = mod(rep_enddate(1),10000)/100 + rep_DD = mod(rep_enddate(1),100) + rep_H = rep_enddate(2)/10000 + rep_M = mod(rep_enddate(2),10000)/100 + rep_S = mod(rep_enddate(2),100) + + call ESMF_TimeSet( rep_EndTime, YY = rep_YY, & + MM = rep_MM, & + DD = rep_DD, & + H = rep_H , & + M = rep_M , & + S = rep_S , & + calendar=cal, rc = STATUS ) + VERIFY_(STATUS) + + ! Determine REPLAY_INTERVAL + ! -------------------------- + Shutoff = rep_EndTime - currTime + call ESMF_TimeIntervalGet(Shutoff, S=rplshut, rc=STATUS) + VERIFY_(STATUS) + rplshut = MAX(0,rplshut) + else + rplshut = -3600 + endif + + ! Initialize REPLAY_SHUTOFF (if USER specified this overrides REPLAY_ENDDATE) + ! --------------------------------------------------------------------------- + call MAPL_GetResource(MAPL, rplshut, Label="REPLAY_SHUTOFF:", default=rplshut, rc=status) + VERIFY_(STATUS) + call ESMF_TimeIntervalSet(Shutoff, S=abs(rplshut), rc=status) + VERIFY_(STATUS) + ! Compute Time of First Call to MKIAU ! ----------------------------------- if (rep_RefTime < currTime ) then @@ -1224,7 +1278,7 @@ subroutine Initialize ( GC, IMPORT, EXPORT, CLOCK, RC ) VERIFY_(ESMF_FAILURE) endif - if (rplshut <= 0) then ! this is a "flag" to never use Shutoff alarm + if (rplshut < 0) then ! this is a "flag" to never use Shutoff alarm call ESMF_AlarmDisable(replayShutoffAlarm, RC=STATUS) VERIFY_(STATUS) end if @@ -1316,7 +1370,7 @@ subroutine Initialize ( GC, IMPORT, EXPORT, CLOCK, RC ) result=GCM_INTERNAL_STATE%SURF_EXP, rc=status) VERIFY_(STATUS) - !select SURFACE import + !select SURFACE import call MAPL_ImportStateGet(GC, import=import, name='SURFACE', & result=GCM_INTERNAL_STATE%SURF_IMP, rc=status) VERIFY_(STATUS) @@ -1327,7 +1381,7 @@ subroutine Initialize ( GC, IMPORT, EXPORT, CLOCK, RC ) result=GCM_INTERNAL_STATE%TURB_EXP, rc=status) VERIFY_(STATUS) - !select TURBULENCE import + !select TURBULENCE import call MAPL_ImportStateGet(GC, import=import, name='TURBULENCE', & result=GCM_INTERNAL_STATE%TURB_IMP, rc=status) VERIFY_(STATUS) @@ -1346,7 +1400,7 @@ subroutine Initialize ( GC, IMPORT, EXPORT, CLOCK, RC ) if (DO_WAVES /= 0) then !select WAVE import GCM_INTERNAL_STATE%WGCM_IMP = GIM(WGCM) - + !select WAVE export GCM_INTERNAL_STATE%WGCM_EXP = GEX(WGCM) end if @@ -1437,7 +1491,7 @@ subroutine Initialize ( GC, IMPORT, EXPORT, CLOCK, RC ) RC=STATUS) VERIFY_(STATUS) - if (DO_CICE_THERMO <= 1) then + if (DO_CICE_THERMO <= 1) then call AllocateExports(GCM_INTERNAL_STATE%expSKIN, & [ character(len=8) :: & 'FRESH', 'FSALT','FHOCN'], & @@ -1867,8 +1921,8 @@ subroutine Run ( GC, IMPORT, EXPORT, CLOCK, RC ) ! Run the WGCM Gridded Component ! ------------------------------ - ! ...not safe for WW3. It is also unneccessary, unless - ! there are two-way interactions between W and O/A, + ! ...not safe for WW3. It is also unneccessary, unless + ! there are two-way interactions between W and O/A, ! so for now we opt not to run a wave model if (DO_WAVES /= 0) then #if (0) @@ -2032,7 +2086,7 @@ subroutine Run ( GC, IMPORT, EXPORT, CLOCK, RC ) else call MAPL_TimerOn(MAPL,"AGCM" ) endif - + #ifdef HAS_GIGATRAJ ! use agcm export as gigatraj's import to get the initial state. ! it only runs at the begining of the first time step @@ -2133,11 +2187,11 @@ subroutine RUN_OCEAN(phase, rc) if (.not. seaIceT_extData) then call MAPL_CopyFriendliness(GIM(OGCM),'TI',expSKIN,'TSKINI' ,_RC) call MAPL_CopyFriendliness(GIM(OGCM),'SI',expSKIN,'SSKINI', _RC) - if (DO_CICE_THERMO <= 1) then + if (DO_CICE_THERMO <= 1) then call MAPL_CopyFriendliness(GIM(OGCM),'HI',expSKIN,'HSKINI', _RC) endif endif - if (DO_CICE_THERMO == 1) then + if (DO_CICE_THERMO == 1) then call MAPL_CopyFriendliness(GIM(OGCM),'FRACICE',expSKIN,'FR', _RC) call MAPL_CopyFriendliness(GIM(OGCM),'VOLICE',expSKIN,'VOLICE', _RC) call MAPL_CopyFriendliness(GIM(OGCM),'VOLSNO',expSKIN,'VOLSNO', _RC) @@ -2150,7 +2204,7 @@ subroutine RUN_OCEAN(phase, rc) ! Do the routing between the atm and ocean's decompositions of the exchage grid !------------------------------------------------------------------------------ if (.not. seaIceT_extData) then - if (DO_CICE_THERMO <= 1) then + if (DO_CICE_THERMO <= 1) then call DO_A2O(GIM(OGCM),'HI' ,expSKIN,'HSKINI' , _RC) endif call DO_A2O(GIM(OGCM),'SI' ,expSKIN,'SSKINI' , _RC) @@ -2223,7 +2277,7 @@ subroutine RUN_OCEAN(phase, rc) VERIFY_(STATUS) call DO_A2O(GIM(OGCM),'DFNIR',expSKIN,'AO_DFNIR', RC=STATUS) VERIFY_(STATUS) - if (DO_CICE_THERMO <= 1) then + if (DO_CICE_THERMO <= 1) then call DO_A2O(GIM(OGCM),'FRESH' ,expSKIN,'FRESH' , _RC) call DO_A2O(GIM(OGCM),'FSALT' ,expSKIN,'FSALT' , _RC) call DO_A2O(GIM(OGCM),'FHOCN' ,expSKIN,'FHOCN' , _RC) @@ -2265,7 +2319,7 @@ subroutine RUN_OCEAN(phase, rc) if (.not. seaIceT_extData) then if (DO_CICE_THERMO <= 1) then call DO_O2A(expSKIN, 'HSKINI' , GIM(OGCM), 'HI' , _RC) - endif + endif call DO_O2A(expSKIN, 'SSKINI' , GIM(OGCM), 'SI' , _RC) endif @@ -2809,18 +2863,18 @@ end subroutine DO_O2A_SUBTILES2D_R8R4 subroutine DO_A2W(SRC,DST,NAME,RC) implicit none - + type(ESMF_STATE), intent(INout) :: SRC type(ESMF_STATE), intent(inout) :: DST character(len=*), intent(in) :: NAME integer, optional,intent(out) :: RC - character(len=ESMF_MAXSTR), parameter :: Iam = 'A2W' + character(len=ESMF_MAXSTR), parameter :: Iam = 'A2W' integer :: status type(ESMF_RouteHandle), pointer :: rh type(ESMF_Field) :: srcField, dstField - + call ESMF_StateGet(SRC, name, srcField, rc=status) VERIFY_(STATUS) call ESMF_StateGet(DST, name, dstField, rc=status) @@ -2851,19 +2905,19 @@ subroutine DO_A2W(SRC,DST,NAME,RC) RETURN_(ESMF_SUCCESS) end subroutine DO_A2W - + subroutine DO_W2A(SRC,DST,NAME,RC) type(ESMF_STATE), intent(INout) :: SRC type(ESMF_STATE), intent(inout) :: DST character(len=*), intent(in) :: NAME integer, optional,intent(out) :: RC - character(len=ESMF_MAXSTR), parameter :: Iam = 'W2A' + character(len=ESMF_MAXSTR), parameter :: Iam = 'W2A' integer :: status type(ESMF_RouteHandle), pointer :: rh type(ESMF_Field) :: srcField, dstField - + call ESMF_StateGet(SRC, name, srcField, rc=status) VERIFY_(STATUS) call ESMF_StateGet(DST, name, dstField, rc=status) @@ -2894,19 +2948,19 @@ subroutine DO_W2A(SRC,DST,NAME,RC) RETURN_(ESMF_SUCCESS) end subroutine DO_W2A - + subroutine DO_O2W(SRC,DST,NAME,RC) type(ESMF_STATE), intent(INout) :: SRC type(ESMF_STATE), intent(inout) :: DST character(len=*), intent(in) :: NAME integer, optional,intent(out) :: RC - character(len=ESMF_MAXSTR), parameter :: Iam = 'O2W' + character(len=ESMF_MAXSTR), parameter :: Iam = 'O2W' integer :: status type(ESMF_RouteHandle), pointer :: rh type(ESMF_Field) :: srcField, dstField - + call ESMF_StateGet(SRC, name, srcField, rc=status) VERIFY_(STATUS) call ESMF_StateGet(DST, name, dstField, rc=status) @@ -2937,19 +2991,19 @@ subroutine DO_O2W(SRC,DST,NAME,RC) RETURN_(ESMF_SUCCESS) end subroutine DO_O2W - + subroutine DO_W2O(SRC,DST,NAME,RC) type(ESMF_STATE), intent(INout) :: SRC type(ESMF_STATE), intent(inout) :: DST character(len=*), intent(in) :: NAME integer, optional,intent(out) :: RC - character(len=ESMF_MAXSTR), parameter :: Iam = 'W2O' + character(len=ESMF_MAXSTR), parameter :: Iam = 'W2O' integer :: status type(ESMF_RouteHandle), pointer :: rh type(ESMF_Field) :: srcField, dstField - + call ESMF_StateGet(SRC, name, srcField, rc=status) VERIFY_(STATUS) call ESMF_StateGet(DST, name, dstField, rc=status) @@ -2970,7 +3024,7 @@ subroutine DO_W2O(SRC,DST,NAME,RC) ! we could specify a regridMethod as additional argument in call above. ! The default is ESMF_REGRID_METHOD_BILINEAR. ! For conservative regridding, in addition to specify - ! ESMF_REGRID_METHOD_CONSERVATIVE, we need the corners of both grids + ! ESMF_REGRID_METHOD_CONSERVATIVE, we need the corners of both grids ! Also, we could have specified srcMaskValues, and dstMaskValues, ! we might need to attach a mask to the grid @@ -2982,7 +3036,7 @@ subroutine DO_W2O(SRC,DST,NAME,RC) RETURN_(ESMF_SUCCESS) end subroutine DO_W2O - + end subroutine Run !ALT we could have a finalize method to release memory diff --git a/GEOSagcm_GridComp/GEOS_AgcmGridComp.F90 b/GEOSagcm_GridComp/GEOS_AgcmGridComp.F90 index 26d96fdc2..9f04aa99b 100644 --- a/GEOSagcm_GridComp/GEOS_AgcmGridComp.F90 +++ b/GEOSagcm_GridComp/GEOS_AgcmGridComp.F90 @@ -541,6 +541,30 @@ subroutine SetServices ( GC, RC ) VLOCATION = MAPL_VLocationNone, RC=STATUS ) VERIFY_(STATUS) + call MAPL_AddExportSpec ( gc, & + SHORT_NAME = 'QRFILL', & + LONG_NAME = 'vertically_integrated_qr_adjustment_from_filling', & + UNITS = 'kg m-2 s-1', & + DIMS = MAPL_DimsHorzOnly, & + VLOCATION = MAPL_VLocationNone, RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec ( gc, & + SHORT_NAME = 'QSFILL', & + LONG_NAME = 'vertically_integrated_qs_adjustment_from_filling', & + UNITS = 'kg m-2 s-1', & + DIMS = MAPL_DimsHorzOnly, & + VLOCATION = MAPL_VLocationNone, RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec ( gc, & + SHORT_NAME = 'QGFILL', & + LONG_NAME = 'vertically_integrated_qg_adjustment_from_filling', & + UNITS = 'kg m-2 s-1', & + DIMS = MAPL_DimsHorzOnly, & + VLOCATION = MAPL_VLocationNone, RC=STATUS ) + VERIFY_(STATUS) + call MAPL_AddExportSpec ( gc, & SHORT_NAME = 'OXFILL', & LONG_NAME = 'vertically_integrated_ox_adjustment_from_filling', & @@ -613,6 +637,30 @@ subroutine SetServices ( GC, RC ) VLOCATION = MAPL_VLocationNone, RC=STATUS ) VERIFY_(STATUS) + call MAPL_AddExportSpec ( gc, & + SHORT_NAME = 'TQR', & + LONG_NAME = 'total_suspended_rain', & + UNITS = 'kg m-2' , & + DIMS = MAPL_DimsHorzOnly, & + VLOCATION = MAPL_VLocationNone, RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec ( gc, & + SHORT_NAME = 'TQS', & + LONG_NAME = 'total_suspended_snow', & + UNITS = 'kg m-2' , & + DIMS = MAPL_DimsHorzOnly, & + VLOCATION = MAPL_VLocationNone, RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec ( gc, & + SHORT_NAME = 'TQG', & + LONG_NAME = 'total_suspended_graupel', & + UNITS = 'kg m-2' , & + DIMS = MAPL_DimsHorzOnly, & + VLOCATION = MAPL_VLocationNone, RC=STATUS ) + VERIFY_(STATUS) + call MAPL_AddExportSpec ( gc, & SHORT_NAME = 'TOX', & LONG_NAME = 'total_column_odd_oxygen', & @@ -669,6 +717,30 @@ subroutine SetServices ( GC, RC ) VLOCATION = MAPL_VLocationCenter, RC=STATUS ) VERIFY_(STATUS) + call MAPL_AddExportSpec ( GC, & + SHORT_NAME = 'QRTOT', & + LONG_NAME = 'mass_fraction_of_suspended_rain', & + UNITS = 'kg kg-1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec ( GC, & + SHORT_NAME = 'QSTOT', & + LONG_NAME = 'mass_fraction_of_suspended_snow', & + UNITS = 'kg kg-1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec ( GC, & + SHORT_NAME = 'QGTOT', & + LONG_NAME = 'mass_fraction_of_suspended_graupel', & + UNITS = 'kg kg-1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, RC=STATUS ) + VERIFY_(STATUS) + call MAPL_AddExportSpec ( GC, & SHORT_NAME = 'PHIS', & LONG_NAME = 'surface geopotential height', & @@ -1513,6 +1585,9 @@ subroutine Run ( GC, IMPORT, EXPORT, CLOCK, RC ) real, pointer, dimension(:,:,:) :: EPV => null() real, pointer, dimension(:,:,:) :: QLTOT => null() real, pointer, dimension(:,:,:) :: QITOT => null() + real, pointer, dimension(:,:,:) :: QRTOT => null() + real, pointer, dimension(:,:,:) :: QSTOT => null() + real, pointer, dimension(:,:,:) :: QGTOT => null() real, pointer, dimension(:,:,:) :: DPEDT => null() real, pointer, dimension(:,:,:) :: DTDT => null() real, pointer, dimension(:,:,:) :: TENDAN => null() @@ -1537,9 +1612,15 @@ subroutine Run ( GC, IMPORT, EXPORT, CLOCK, RC ) real, pointer, dimension(:,:) :: QVFILL => null() real, pointer, dimension(:,:) :: QIFILL => null() real, pointer, dimension(:,:) :: QLFILL => null() + real, pointer, dimension(:,:) :: QRFILL => null() + real, pointer, dimension(:,:) :: QSFILL => null() + real, pointer, dimension(:,:) :: QGFILL => null() real, pointer, dimension(:,:) :: TQV => null() real, pointer, dimension(:,:) :: TQI => null() real, pointer, dimension(:,:) :: TQL => null() + real, pointer, dimension(:,:) :: TQR => null() + real, pointer, dimension(:,:) :: TQS => null() + real, pointer, dimension(:,:) :: TQG => null() real, pointer, dimension(:,:) :: TOX => null() real, pointer, dimension(:,:) :: TROPP1 => null() real, pointer, dimension(:,:) :: TROPP2 => null() @@ -1561,6 +1642,9 @@ subroutine Run ( GC, IMPORT, EXPORT, CLOCK, RC ) real, pointer, dimension(:,:) :: DQVDTPHYINT => null() real, pointer, dimension(:,:) :: DQLDTPHYINT => null() real, pointer, dimension(:,:) :: DQIDTPHYINT => null() + real, pointer, dimension(:,:) :: DQRDTPHYINT => null() + real, pointer, dimension(:,:) :: DQSDTPHYINT => null() + real, pointer, dimension(:,:) :: DQGDTPHYINT => null() real, pointer, dimension(:,:) :: DOXDTPHYINT => null() real, pointer, dimension(:,:,:) :: DP @@ -1658,11 +1742,6 @@ subroutine Run ( GC, IMPORT, EXPORT, CLOCK, RC ) type (ESMF_Time), save :: REPLAY_TIME0 logical,save :: first=.true. -! For DYN:PHY ratio estimates - integer :: START_TIME, END_TIME, DYN_TIME, PHY_TIME - integer :: COUNT_MAX, COUNT_RATE - real(kind=8) :: CRI - !ALT: for memory leak testing logical :: isPresent real, allocatable, target :: zero(:,:,:) @@ -1975,6 +2054,12 @@ subroutine Run ( GC, IMPORT, EXPORT, CLOCK, RC ) VERIFY_(STATUS) call MAPL_GetPointer( GEX(PHYS), DQIDTPHYINT, 'DQIDTPHYINT', rc=STATUS ) VERIFY_(STATUS) + call MAPL_GetPointer( GEX(PHYS), DQRDTPHYINT, 'DQRDTPHYINT', rc=STATUS ) + VERIFY_(STATUS) + call MAPL_GetPointer( GEX(PHYS), DQSDTPHYINT, 'DQSDTPHYINT', rc=STATUS ) + VERIFY_(STATUS) + call MAPL_GetPointer( GEX(PHYS), DQGDTPHYINT, 'DQGDTPHYINT', rc=STATUS ) + VERIFY_(STATUS) call MAPL_GetPointer( GEX(PHYS), DOXDTPHYINT, 'DOXDTPHYINT', rc=STATUS ) VERIFY_(STATUS) @@ -2496,19 +2581,10 @@ subroutine Run ( GC, IMPORT, EXPORT, CLOCK, RC ) call Pack_Chem_Groups( GEX(PHYS) ) ! Prepare to transport chemical families -! ! Call system clock to estmiate Dyn:Phy ratio -! call SYSTEM_CLOCK(COUNT_MAX=COUNT_MAX) - -! call SYSTEM_CLOCK(START_TIME) call MAPL_TimerOn (STATE,"SUPERDYNAMICS" ) call ESMF_GridCompRun(GCS(SDYN), importState=GIM(SDYN), exportState=GEX(SDYN), clock=CLOCK, PHASE=1, userRC=STATUS) VERIFY_(STATUS) call MAPL_TimerOFF (STATE,"SUPERDYNAMICS" ) -! call SYSTEM_CLOCK(END_TIME) -! DYN_TIME = END_TIME-START_TIME -! if(DYN_TIME<0) then -! DYN_TIME = DYN_TIME + COUNT_MAX -! endif ! Compute Tracer Advection increments !------------------------------------- @@ -2516,19 +2592,10 @@ subroutine Run ( GC, IMPORT, EXPORT, CLOCK, RC ) call Unpack_Chem_Groups( GEX(PHYS), PLE, AREA ) ! Finish transporting chemical families -! call SYSTEM_CLOCK(START_TIME) call MAPL_TimerOn (STATE,"PHYSICS" ) call ESMF_GridCompRun(GCS(PHYS), importState=GIM(PHYS), exportState=GEX(PHYS), clock=CLOCK, PHASE=1, userRC=STATUS) VERIFY_(STATUS) call MAPL_TimerOff(STATE,"PHYSICS" ) -! call SYSTEM_CLOCK(END_TIME) -! PHY_TIME = END_TIME-START_TIME -! if(PHY_TIME<0) then -! PHY_TIME = PHY_TIME + COUNT_MAX -! endif - -! if( MAPL_am_I_root() ) write(6,1000) REAL(DYN_TIME,kind=8)/REAL(PHY_TIME,kind=8) -! 1000 format(1x,'DYN:PHY Ratio: ',f7.2) ! Load Physics Tendencies into Imports for RUN2 of Dynamics (ADD_INCS) !--------------------------------------------------------------------- @@ -2580,6 +2647,12 @@ subroutine Run ( GC, IMPORT, EXPORT, CLOCK, RC ) VERIFY_(STATUS) call MAPL_GetPointer ( EXPORT, QLFILL, 'QLFILL', rc=STATUS ) VERIFY_(STATUS) + call MAPL_GetPointer ( EXPORT, QRFILL, 'QRFILL', rc=STATUS ) + VERIFY_(STATUS) + call MAPL_GetPointer ( EXPORT, QSFILL, 'QSFILL', rc=STATUS ) + VERIFY_(STATUS) + call MAPL_GetPointer ( EXPORT, QGFILL, 'QGFILL', rc=STATUS ) + VERIFY_(STATUS) call MAPL_GetPointer ( EXPORT, OXFILL, 'OXFILL', rc=STATUS ) VERIFY_(STATUS) call MAPL_GetPointer ( EXPORT, TOX , 'TOX' , rc=STATUS ) @@ -2590,10 +2663,23 @@ subroutine Run ( GC, IMPORT, EXPORT, CLOCK, RC ) VERIFY_(STATUS) call MAPL_GetPointer ( EXPORT, TQL , 'TQL' , rc=STATUS ) VERIFY_(STATUS) + call MAPL_GetPointer ( EXPORT, TQR , 'TQR' , rc=STATUS ) + VERIFY_(STATUS) + call MAPL_GetPointer ( EXPORT, TQS , 'TQS' , rc=STATUS ) + VERIFY_(STATUS) + call MAPL_GetPointer ( EXPORT, TQG , 'TQG' , rc=STATUS ) + VERIFY_(STATUS) call MAPL_GetPointer ( EXPORT, QLTOT , 'QLTOT' , rc=STATUS ) VERIFY_(STATUS) call MAPL_GetPointer ( EXPORT, QITOT , 'QITOT' , rc=STATUS ) VERIFY_(STATUS) + call MAPL_GetPointer ( EXPORT, QRTOT , 'QRTOT' , rc=STATUS ) + VERIFY_(STATUS) + call MAPL_GetPointer ( EXPORT, QSTOT , 'QSTOT' , rc=STATUS ) + VERIFY_(STATUS) + call MAPL_GetPointer ( EXPORT, QGTOT , 'QGTOT' , rc=STATUS ) + VERIFY_(STATUS) + call MAPL_GetPointer ( EXPORT, PERES , 'PERES' , rc=STATUS ) VERIFY_(STATUS) call MAPL_GetPointer ( EXPORT, PEFILL , 'PEFILL' , rc=STATUS ) @@ -2604,10 +2690,19 @@ subroutine Run ( GC, IMPORT, EXPORT, CLOCK, RC ) if(associated(QTFILL)) QTFILL = 0.0 if(associated(QIFILL)) QIFILL = 0.0 if(associated(QLFILL)) QLFILL = 0.0 + if(associated(QRFILL)) QRFILL = 0.0 + if(associated(QSFILL)) QSFILL = 0.0 + if(associated(QGFILL)) QGFILL = 0.0 if(associated(TQI) ) TQI = 0.0 if(associated(TQL) ) TQL = 0.0 + if(associated(TQR) ) TQR = 0.0 + if(associated(TQS) ) TQS = 0.0 + if(associated(TQG) ) TQG = 0.0 if(associated(QLTOT) ) QLTOT = 0.0 if(associated(QITOT) ) QITOT = 0.0 + if(associated(QRTOT) ) QRTOT = 0.0 + if(associated(QSTOT) ) QSTOT = 0.0 + if(associated(QGTOT) ) QGTOT = 0.0 allocate(QFILL(IM,JM) ,STAT=STATUS ) VERIFY_(STATUS) @@ -2725,6 +2820,39 @@ subroutine Run ( GC, IMPORT, EXPORT, CLOCK, RC ) if(associated(QLTOT)) QLTOT = QLTOT + Q endif +! Rain +! ------------ + if(NAMES(K)=='QRAIN') then + call FILL_Friendly ( Q,DP,QFILL,QINT ) + if(associated(QRFILL)) QRFILL = QRFILL + QFILL + if(associated(QTFILL)) QTFILL = QTFILL + QFILL + if(associated(DQRDTPHYINT)) DQRDTPHYINT = DQRDTPHYINT + QFILL + if(associated(TQR)) TQR = TQR + QINT + if(associated(QRTOT)) QRTOT = QRTOT + Q + endif + +! Snow +! ------------ + if(NAMES(K)=='QSNOW') then + call FILL_Friendly ( Q,DP,QFILL,QINT ) + if(associated(QSFILL)) QSFILL = QSFILL + QFILL + if(associated(QTFILL)) QTFILL = QTFILL + QFILL + if(associated(DQSDTPHYINT)) DQSDTPHYINT = DQSDTPHYINT + QFILL + if(associated(TQS)) TQS = TQS + QINT + if(associated(QSTOT)) QSTOT = QSTOT + Q + endif + +! Graupel +! ------------ + if(NAMES(K)=='QGRAUPEL') then + call FILL_Friendly ( Q,DP,QFILL,QINT ) + if(associated(QGFILL)) QGFILL = QGFILL + QFILL + if(associated(QTFILL)) QTFILL = QTFILL + QFILL + if(associated(DQGDTPHYINT)) DQGDTPHYINT = DQGDTPHYINT + QFILL + if(associated(TQG)) TQG = TQG + QINT + if(associated(QGTOT)) QGTOT = QGTOT + Q + endif + ! Total Odd-Oxygen ! ---------------- if(TRIM(fieldName) == 'OX') then diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOS_PhysicsGridComp.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOS_PhysicsGridComp.F90 index dea0f1a5e..afd96432e 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOS_PhysicsGridComp.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOS_PhysicsGridComp.F90 @@ -114,7 +114,9 @@ subroutine SetServices ( GC, RC ) integer :: DO_OBIO, DO_CO2CNNEE, ATM_CO2, nCols, NQ integer :: DO_WAVES, DO_SEA_SPRAY + real :: SYNCUV real :: SYNCTQ + logical :: DEBUG_SYNCTQ character(len=ESMF_MAXSTR), allocatable :: NAMES(:) character(len=ESMF_MAXSTR) :: TendUnits character(len=ESMF_MAXSTR) :: SURFRC @@ -189,10 +191,15 @@ subroutine SetServices ( GC, RC ) call ESMF_ConfigGetAttribute (SCF, label='USE_CNNEE:', value=DO_CO2CNNEE, DEFAULT=0, __RC__ ) call ESMF_ConfigDestroy (SCF, __RC__) -! Get SYNCTQ flag from config to know whether to terminate some imports +! Get SYNCTQ & SYNCUV flag from config to know whether to terminate some imports ! --------------------------------------------------------------------------- + call MAPL_GetResource ( MAPL, SYNCUV, Label="SYNCUV:", DEFAULT= 1.0, RC=STATUS) + VERIFY_(STATUS) call MAPL_GetResource ( MAPL, SYNCTQ, Label="SYNCTQ:", DEFAULT= 1.0, RC=STATUS) VERIFY_(STATUS) + call MAPL_GetResource ( MAPL, DEBUG_SYNCTQ, Label="DEBUG_SYNCTQ:", DEFAULT= .false., RC=STATUS) + VERIFY_(STATUS) + !BOS ! !INTERNAL STATE @@ -542,6 +549,15 @@ subroutine SetServices ( GC, RC ) RC=STATUS ) VERIFY_(STATUS) + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'TKESHOCIT', & + LONG_NAME = 'tendency_of_TKE_due_to_turbulence_transport', & + UNITS = 'm2 s-3', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RC=STATUS ) + VERIFY_(STATUS) + call MAPL_AddExportSpec(GC, & SHORT_NAME = 'TIF', & LONG_NAME = 'tendency_of_air_temperature_due_to_friction', & @@ -727,6 +743,33 @@ subroutine SetServices ( GC, RC ) RC=STATUS ) VERIFY_(STATUS) + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'DQRDTMSTINT', & + LONG_NAME = 'vertically_integrated_rain_tendency_due_to_moist_processes', & + UNITS = 'kg m-2 s-1', & + DIMS = MAPL_DimsHorzOnly, & + VLOCATION = MAPL_VLocationNone, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'DQSDTMSTINT', & + LONG_NAME = 'vertically_integrated_snow_tendency_due_to_moist_processes', & + UNITS = 'kg m-2 s-1', & + DIMS = MAPL_DimsHorzOnly, & + VLOCATION = MAPL_VLocationNone, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'DQGDTMSTINT', & + LONG_NAME = 'vertically_integrated_graupel_tendency_due_to_moist_processes', & + UNITS = 'kg m-2 s-1', & + DIMS = MAPL_DimsHorzOnly, & + VLOCATION = MAPL_VLocationNone, & + RC=STATUS ) + VERIFY_(STATUS) + call MAPL_AddExportSpec(GC, & SHORT_NAME = 'DOXDTCHMINT', & LONG_NAME = 'vertically_integrated_odd_oxygen_tendency_due_to_chemistry', & @@ -763,18 +806,406 @@ subroutine SetServices ( GC, RC ) RC=STATUS ) VERIFY_(STATUS) - call MAPL_AddExportSpec(GC, & - SHORT_NAME = 'DOXDTPHYINT', & - LONG_NAME = 'vertically_integrated_odd_oxygen_tendency_due_to_physics', & - UNITS = 'kg m-2 s-1', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, & + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'DQRDTPHYINT', & + LONG_NAME = 'vertically_integrated_rain_tendency_due_to_physics', & + UNITS = 'kg m-2 s-1', & + DIMS = MAPL_DimsHorzOnly, & + VLOCATION = MAPL_VLocationNone, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'DQSDTPHYINT', & + LONG_NAME = 'vertically_integrated_snow_tendency_due_to_physics', & + UNITS = 'kg m-2 s-1', & + DIMS = MAPL_DimsHorzOnly, & + VLOCATION = MAPL_VLocationNone, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'DQGDTPHYINT', & + LONG_NAME = 'vertically_integrated_graupel_tendency_due_to_physics', & + UNITS = 'kg m-2 s-1', & + DIMS = MAPL_DimsHorzOnly, & + VLOCATION = MAPL_VLocationNone, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'DOXDTPHYINT', & + LONG_NAME = 'vertically_integrated_odd_oxygen_tendency_due_to_physics', & + UNITS = 'kg m-2 s-1', & + DIMS = MAPL_DimsHorzOnly, & + VLOCATION = MAPL_VLocationNone, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'DQVDTSCL', & + LONG_NAME = 'tendency_of_water_vapor_due_to_mass_scaling', & + UNITS = 'kg m-2 s-1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'DQLDTSCL', & + LONG_NAME = 'tendency_of_cloud_water_due_to_mass_scaling', & + UNITS = 'kg m-2 s-1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'DQIDTSCL', & + LONG_NAME = 'tendency_of_cloud_ice_due_to_mass_scaling', & + UNITS = 'kg m-2 s-1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'DQVDT_FILL_PHYS0', & + LONG_NAME = 'tendency_of_water_vapor_due_to_negative_fill_before_phys', & + UNITS = 'kg m-2 s-1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'DQLLSDT_FILL_PHYS0', & + LONG_NAME = 'tendency_of_liquid_ls_due_to_negative_fill_before_phys', & + UNITS = 'kg m-2 s-1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'DQLCNDT_FILL_PHYS0', & + LONG_NAME = 'tendency_of_liquid_cn_due_to_negative_fill_before_phys', & + UNITS = 'kg m-2 s-1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'DQILSDT_FILL_PHYS0', & + LONG_NAME = 'tendency_of_ice_ls_due_to_negative_fill_before_phys', & + UNITS = 'kg m-2 s-1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'DQICNDT_FILL_PHYS0', & + LONG_NAME = 'tendency_of_ice_cn_due_to_negative_fill_before_phys', & + UNITS = 'kg m-2 s-1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'DQRDT_FILL_PHYS0', & + LONG_NAME = 'tendency_of_rain_due_to_negative_fill_before_phys', & + UNITS = 'kg m-2 s-1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'DQSDT_FILL_PHYS0', & + LONG_NAME = 'tendency_of_snow_due_to_negative_fill_before_phys', & + UNITS = 'kg m-2 s-1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'DQGDT_FILL_PHYS0', & + LONG_NAME = 'tendency_of_graupel_due_to_negative_fill_before_phys', & + UNITS = 'kg m-2 s-1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RC=STATUS ) + VERIFY_(STATUS) + + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'DQVDT_FILL_AFMST', & + LONG_NAME = 'tendency_of_water_vapor_due_to_negative_fill_after_moist', & + UNITS = 'kg m-2 s-1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'DQLLSDT_FILL_AFMST', & + LONG_NAME = 'tendency_of_liquid_ls_due_to_negative_fill_after_moist', & + UNITS = 'kg m-2 s-1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'DQLCNDT_FILL_AFMST', & + LONG_NAME = 'tendency_of_liquid_cn_due_to_negative_fill_after_moist', & + UNITS = 'kg m-2 s-1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'DQILSDT_FILL_AFMST', & + LONG_NAME = 'tendency_of_ice_ls_due_to_negative_fill_after_moist', & + UNITS = 'kg m-2 s-1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'DQICNDT_FILL_AFMST', & + LONG_NAME = 'tendency_of_ice_cn_due_to_negative_fill_after_moist', & + UNITS = 'kg m-2 s-1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'DQRDT_FILL_AFMST', & + LONG_NAME = 'tendency_of_rain_due_to_negative_fill_after_moist', & + UNITS = 'kg m-2 s-1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'DQSDT_FILL_AFMST', & + LONG_NAME = 'tendency_of_snow_due_to_negative_fill_after_moist', & + UNITS = 'kg m-2 s-1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'DQGDT_FILL_AFMST', & + LONG_NAME = 'tendency_of_graupel_due_to_negative_fill_after_moist', & + UNITS = 'kg m-2 s-1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'DQVDT_FILL_AFSTG1', & + LONG_NAME = 'tendency_of_water_vapor_due_to_negative_fill_after_stage1', & + UNITS = 'kg m-2 s-1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'DQLLSDT_FILL_AFSTG1', & + LONG_NAME = 'tendency_of_liquid_ls_due_to_negative_fill_after_stage1', & + UNITS = 'kg m-2 s-1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'DQLCNDT_FILL_AFSTG1', & + LONG_NAME = 'tendency_of_liquid_cn_due_to_negative_fill_after_stage1', & + UNITS = 'kg m-2 s-1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'DQILSDT_FILL_AFSTG1', & + LONG_NAME = 'tendency_of_ice_ls_due_to_negative_fill_after_stage1', & + UNITS = 'kg m-2 s-1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'DQICNDT_FILL_AFSTG1', & + LONG_NAME = 'tendency_of_ice_cn_due_to_negative_fill_after_stage1', & + UNITS = 'kg m-2 s-1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'DQRDT_FILL_AFSTG1', & + LONG_NAME = 'tendency_of_rain_due_to_negative_fill_after_stage1', & + UNITS = 'kg m-2 s-1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'DQSDT_FILL_AFSTG1', & + LONG_NAME = 'tendency_of_snow_due_to_negative_fill_after_stage1', & + UNITS = 'kg m-2 s-1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'DQGDT_FILL_AFSTG1', & + LONG_NAME = 'tendency_of_graupel_due_to_negative_fill_after_stage1', & + UNITS = 'kg m-2 s-1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'DQVDT_FILL_AFSTG2', & + LONG_NAME = 'tendency_of_water_vapor_due_to_negative_fill_after_phys', & + UNITS = 'kg m-2 s-1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'DQLLSDT_FILL_AFSTG2', & + LONG_NAME = 'tendency_of_liquid_ls_due_to_negative_fill_after_phys', & + UNITS = 'kg m-2 s-1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'DQLCNDT_FILL_AFSTG2', & + LONG_NAME = 'tendency_of_liquid_cn_due_to_negative_fill_after_phys', & + UNITS = 'kg m-2 s-1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'DQILSDT_FILL_AFSTG2', & + LONG_NAME = 'tendency_of_ice_ls_due_to_negative_fill_after_phys', & + UNITS = 'kg m-2 s-1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'DQICNDT_FILL_AFSTG2', & + LONG_NAME = 'tendency_of_ice_cn_due_to_negative_fill_after_phys', & + UNITS = 'kg m-2 s-1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'DQRDT_FILL_AFSTG2', & + LONG_NAME = 'tendency_of_rain_due_to_negative_fill_after_phys', & + UNITS = 'kg m-2 s-1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'DQSDT_FILL_AFSTG2', & + LONG_NAME = 'tendency_of_snow_due_to_negative_fill_after_phys', & + UNITS = 'kg m-2 s-1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'DQGDT_FILL_AFSTG2', & + LONG_NAME = 'tendency_of_graupel_due_to_negative_fill_after_phys', & + UNITS = 'kg m-2 s-1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'DQVDT_FILL_PHYS1', & + LONG_NAME = 'tendency_of_water_vapor_due_to_negative_fill_after_phys', & + UNITS = 'kg m-2 s-1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'DQLLSDT_FILL_PHYS1', & + LONG_NAME = 'tendency_of_liquid_ls_due_to_negative_fill_after_phys', & + UNITS = 'kg m-2 s-1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'DQLCNDT_FILL_PHYS1', & + LONG_NAME = 'tendency_of_liquid_cn_due_to_negative_fill_after_phys', & + UNITS = 'kg m-2 s-1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'DQILSDT_FILL_PHYS1', & + LONG_NAME = 'tendency_of_ice_ls_due_to_negative_fill_after_phys', & + UNITS = 'kg m-2 s-1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'DQICNDT_FILL_PHYS1', & + LONG_NAME = 'tendency_of_ice_cn_due_to_negative_fill_after_phys', & + UNITS = 'kg m-2 s-1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & RC=STATUS ) VERIFY_(STATUS) call MAPL_AddExportSpec(GC, & - SHORT_NAME = 'DQVDTSCL', & - LONG_NAME = 'tendency_of_water_vapor_due_to_mass_scaling', & + SHORT_NAME = 'DQRDT_FILL_PHYS1', & + LONG_NAME = 'tendency_of_rain_due_to_negative_fill_after_phys', & UNITS = 'kg m-2 s-1', & DIMS = MAPL_DimsHorzVert, & VLOCATION = MAPL_VLocationCenter, & @@ -782,8 +1213,8 @@ subroutine SetServices ( GC, RC ) VERIFY_(STATUS) call MAPL_AddExportSpec(GC, & - SHORT_NAME = 'DQLDTSCL', & - LONG_NAME = 'tendency_of_cloud_water_due_to_mass_scaling', & + SHORT_NAME = 'DQSDT_FILL_PHYS1', & + LONG_NAME = 'tendency_of_snow_due_to_negative_fill_after_phys', & UNITS = 'kg m-2 s-1', & DIMS = MAPL_DimsHorzVert, & VLOCATION = MAPL_VLocationCenter, & @@ -791,8 +1222,8 @@ subroutine SetServices ( GC, RC ) VERIFY_(STATUS) call MAPL_AddExportSpec(GC, & - SHORT_NAME = 'DQIDTSCL', & - LONG_NAME = 'tendency_of_cloud_ice_due_to_mass_scaling', & + SHORT_NAME = 'DQGDT_FILL_PHYS1', & + LONG_NAME = 'tendency_of_graupel_due_to_negative_fill_after_phys', & UNITS = 'kg m-2 s-1', & DIMS = MAPL_DimsHorzVert, & VLOCATION = MAPL_VLocationCenter, & @@ -912,6 +1343,60 @@ subroutine SetServices ( GC, RC ) RC=STATUS ) VERIFY_(STATUS) + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'TIME_IN_GWD', & + LONG_NAME = 'time_spent_in_gwd_physics', & + UNITS = 's', & + DIMS = MAPL_DimsHorzOnly, & + VLOCATION = MAPL_VLocationNone, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'TIME_IN_MST', & + LONG_NAME = 'time_spent_in_moist_physics', & + UNITS = 's', & + DIMS = MAPL_DimsHorzOnly, & + VLOCATION = MAPL_VLocationNone, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'TIME_IN_TRB', & + LONG_NAME = 'time_spent_in_turbulence_physics', & + UNITS = 's', & + DIMS = MAPL_DimsHorzOnly, & + VLOCATION = MAPL_VLocationNone, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'TIME_IN_SFC', & + LONG_NAME = 'time_spent_in_surface_physics', & + UNITS = 's', & + DIMS = MAPL_DimsHorzOnly, & + VLOCATION = MAPL_VLocationNone, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'TIME_IN_CHM', & + LONG_NAME = 'time_spent_in_chemistry_physics', & + UNITS = 's', & + DIMS = MAPL_DimsHorzOnly, & + VLOCATION = MAPL_VLocationNone, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'TIME_IN_RAD', & + LONG_NAME = 'time_spent_in_radiation_physics', & + UNITS = 's', & + DIMS = MAPL_DimsHorzOnly, & + VLOCATION = MAPL_VLocationNone, & + RC=STATUS ) + VERIFY_(STATUS) + ! Ozone (ppmv) and Odd Oxygen (mol/mol) ! Note: GMI currently provides just O3 as Odd Oxygen ! ---------------------------------------------------------- @@ -1056,13 +1541,13 @@ subroutine SetServices ( GC, RC ) RC=STATUS ) VERIFY_(STATUS) - call MAPL_AddConnectivity ( GC, & - SHORT_NAME = [character(len=6) :: & - 'QV','QLTOT','QITOT','FCLD', & - 'WTHV2','WQT_DC'], & - DST_ID = TURBL, & - SRC_ID = MOIST, & - RC=STATUS ) + call MAPL_AddConnectivity ( GC, & + SHORT_NAME = [character(len=6) :: & + 'QV','QLTOT','QITOT','QRTOT','QSTOT','QGTOT','FCLD', & + 'WTHV2','WQT_DC'], & + DST_ID = TURBL, & + SRC_ID = MOIST, & + RC=STATUS ) VERIFY_(STATUS) call MAPL_AddConnectivity ( GC, & @@ -1195,13 +1680,13 @@ subroutine SetServices ( GC, RC ) VERIFY_(STATUS) ENDIF - IF (DO_OBIO /= 0) THEN - call MAPL_AddConnectivity ( GC, & + IF (DO_OBIO /= 0) THEN + call MAPL_AddConnectivity ( GC, & SHORT_NAME = (/'DROBIO', 'DFOBIO'/), & SRC_ID = RAD, & - DST_ID = SURF, & - RC=STATUS ) - VERIFY_(STATUS) + DST_ID = SURF, & + RC=STATUS ) + VERIFY_(STATUS) ENDIF call MAPL_AddConnectivity ( GC, & @@ -1213,11 +1698,11 @@ subroutine SetServices ( GC, RC ) ! Imports for GWD !---------------- - call MAPL_AddConnectivity ( GC, & + call MAPL_AddConnectivity ( GC, & SHORT_NAME = [character(len=7) :: 'Q', 'DTDT_DC', 'CNV_FRC' ], & - DST_ID = GWD, & - SRC_ID = MOIST, & - RC=STATUS ) + DST_ID = GWD, & + SRC_ID = MOIST, & + RC=STATUS ) VERIFY_(STATUS) call MAPL_AddConnectivity ( GC, & SRC_NAME = 'DQIDT_micro', & @@ -1246,7 +1731,7 @@ subroutine SetServices ( GC, RC ) 'REV_LS ', 'REV_AN ', 'REV_CN ', 'TPREC ', & 'Q ', 'DQDT ', 'DQRL ', 'DQRC ', & 'CNV_MFC ', 'CNV_MFD ', 'CNV_CVW ', 'CNV_FRC ', & - 'LFR_GCC ', 'RH2 ', 'CN_PRCP ', & + 'LFR_GCC ', 'RH2 ', & 'BYNCY ', 'CAPE ', 'INHB ' /), & DST_ID = CHEM, & SRC_ID = MOIST, & @@ -1373,13 +1858,6 @@ subroutine SetServices ( GC, RC ) !-------------- DONIF Additional Moist Imports - call MAPL_AddConnectivity ( GC, & - SHORT_NAME = (/'VSCSFC'/), & - DST_ID = MOIST, & - SRC_ID = TURBL, & - RC=STATUS ) - VERIFY_(STATUS) - !Aerosol call MAPL_AddConnectivity ( GC, & SHORT_NAME = (/'AERO'/), & @@ -1402,7 +1880,6 @@ subroutine SetServices ( GC, RC ) RC=STATUS ) VERIFY_(STATUS) - call MAPL_AddConnectivity ( GC, & SHORT_NAME = (/'RADLW'/), & DST_ID = MOIST, & @@ -1424,15 +1901,6 @@ subroutine SetServices ( GC, RC ) RC=STATUS ) VERIFY_(STATUS) - call MAPL_AddConnectivity ( GC, & - SHORT_NAME = (/'TAUX', 'TAUY'/), & - DST_ID = MOIST, & - SRC_ID = SURF, & - RC=STATUS ) - - VERIFY_(STATUS) - - !EOP ! Disable connectivities of Surface imports that are filled manually from @@ -1446,10 +1914,18 @@ subroutine SetServices ( GC, RC ) RC=STATUS ) VERIFY_(STATUS) +! terminate imports to SURF for SYNCUV + if ( SYNCUV.ge.1.) then + call MAPL_TerminateImport ( GC, & + SHORT_NAME = [character(len=5) :: 'UA','VA','SPEED' ], & + CHILD = SURF, & + RC=STATUS ) + VERIFY_(STATUS) + endif ! terminate imports to SURF for SYNCTQ if ( SYNCTQ.ge.1.) then call MAPL_TerminateImport ( GC, & - SHORT_NAME = [character(len=5) :: 'UA','VA','TA','QA','SPEED' ], & + SHORT_NAME = [character(len=5) :: 'TA','QA' ], & CHILD = SURF, & RC=STATUS ) VERIFY_(STATUS) @@ -1469,7 +1945,7 @@ subroutine SetServices ( GC, RC ) CHILD = TURBL, & RC=STATUS ) VERIFY_(STATUS) - endif + endif call MAPL_TerminateImport ( GC, & SHORT_NAME = (/'TR ','TRG','DTG' /), & @@ -1477,10 +1953,18 @@ subroutine SetServices ( GC, RC ) RC=STATUS ) VERIFY_(STATUS) +! terminate imports to turb for SYNCUV + if ( SYNCUV.ge.1.) then + call MAPL_TerminateImport ( GC, & + SHORT_NAME = (/'U ','V ' /), & + CHILD = TURBL, & + RC=STATUS ) + VERIFY_(STATUS) + endif ! terminate imports to turb for SYNCTQ if ( SYNCTQ.ge.1.) then call MAPL_TerminateImport ( GC, & - SHORT_NAME = (/'U ','V ','T ','TH' /), & + SHORT_NAME = (/'T ','TH' /), & CHILD = TURBL, & RC=STATUS ) VERIFY_(STATUS) @@ -1491,6 +1975,7 @@ subroutine SetServices ( GC, RC ) CHILD = MOIST, & RC=STATUS) VERIFY_(STATUS) + call MAPL_TerminateImport ( GC, & SHORT_NAME = (/'DQDT_BL','DTDT_BL'/), & CHILD = MOIST, & @@ -2018,10 +2503,10 @@ subroutine Initialize ( GC, IMPORT, EXPORT, CLOCK, RC ) ! The original 3D increments: call Initialize_IncBundle_init(GC, GIM(MOIST), EXPORT, MTRIinc, __RC__) - + #ifdef PRINT_STATES call ESMF_StateGet(EXPORT, 'MTRI', iBUNDLE, rc=STATUS) - VERIFY_(STATUS) + VERIFY_(STATUS) call WRITE_PARALLEL ( trim(Iam)//": MTRI - Convective Transport and Scavenging 3D Tendency Bundle" ) if ( MAPL_am_I_root() ) call ESMF_FieldBundlePrint ( iBUNDLE, rc=STATUS ) @@ -2033,7 +2518,7 @@ subroutine Initialize ( GC, IMPORT, EXPORT, CLOCK, RC ) #ifdef PRINT_STATES call ESMF_StateGet(EXPORT, 'MCHEMTRI', iBUNDLE, rc=STATUS) - VERIFY_(STATUS) + VERIFY_(STATUS) call WRITE_PARALLEL ( trim(Iam)//": MCHEMTRI - Convective Transport and Scavenging 2D Tendency Bundle" ) if ( MAPL_am_I_root() ) call ESMF_FieldBundlePrint ( iBUNDLE, rc=STATUS ) @@ -2103,7 +2588,8 @@ subroutine Run ( GC, IMPORT, EXPORT, CLOCK, RC ) logical :: NEED_STN logical :: DPEDT_PHYS real :: DT - real :: SYNCTQ, DOPHYSICS + logical :: DEBUG_SYNCTQ + real :: SYNCUV, SYNCTQ, DOPHYSICS real :: HGT_SURFACE real, pointer, dimension(:,:,:) :: S, T, ZLE, PLE, PK, U, V, W @@ -2124,11 +2610,21 @@ subroutine Run ( GC, IMPORT, EXPORT, CLOCK, RC ) real, pointer, dimension(:,:,:) :: DOXDTCHM real, pointer, dimension(:,:,:) :: DQVDTMST, DQVDTTRB, DQVDTCHM - real, pointer, dimension(:,:,:) :: DQLDTTRB, DQIDTTRB + real, pointer, dimension(:,:,:) :: DQLDTTRB, DQIDTTRB, TKEIT real, pointer, dimension(:,:,:) :: DQLDTSCL, DQIDTSCL, DQVDTSCL real, pointer, dimension(:,:,:) :: DQLDTMST, DQIDTMST + real, pointer, dimension(:,:,:) :: DQRDTMST, DQSDTMST, DQGDTMST real, pointer, dimension(:,:,:) :: DPDTMST, DPDTTRB + real, pointer, dimension(:,:,:) :: DQVDT_FILL + real, pointer, dimension(:,:,:) :: DQLLSDT_FILL + real, pointer, dimension(:,:,:) :: DQLCNDT_FILL + real, pointer, dimension(:,:,:) :: DQILSDT_FILL + real, pointer, dimension(:,:,:) :: DQICNDT_FILL + real, pointer, dimension(:,:,:) :: DQRDT_FILL + real, pointer, dimension(:,:,:) :: DQSDT_FILL + real, pointer, dimension(:,:,:) :: DQGDT_FILL + real, pointer, dimension(:,:,:) :: RNDPERT,RNDPTR real, pointer, dimension(:,:,:) :: SKEBU_WT,SKEBV_WT real, pointer, dimension(:,:,:) :: SKEBU,SKEBV @@ -2145,14 +2641,15 @@ subroutine Run ( GC, IMPORT, EXPORT, CLOCK, RC ) real, pointer, dimension(:,: ) :: SRFDIS real, pointer, dimension(:,: ) :: DQVDTPHYINT, DQLDTPHYINT, DQIDTPHYINT, DOXDTPHYINT + real, pointer, dimension(:,: ) :: DQRDTPHYINT, DQSDTPHYINT, DQGDTPHYINT real, pointer, dimension(:,: ) :: DQVDTTRBINT, DQVDTMSTINT, DQVDTCHMINT real, pointer, dimension(:,: ) :: DQLDTMSTINT, DQIDTMSTINT, DOXDTCHMINT + real, pointer, dimension(:,: ) :: DQRDTMSTINT, DQSDTMSTINT, DQGDTMSTINT real, pointer, dimension(:,: ) :: PERAD,PETRB,PEMST,PEFRI,PEGWD,PECUF real, pointer, dimension(:,: ) :: PEPHY real, pointer, dimension(:,: ) :: KEPHY real, pointer, dimension(:,: ) :: AREA - real*8, allocatable, dimension(:,:) :: sumq real*8, allocatable, dimension(:,:,:) :: ple_new character(len=ESMF_MAXSTR), allocatable :: NAMES(:) @@ -2165,8 +2662,9 @@ subroutine Run ( GC, IMPORT, EXPORT, CLOCK, RC ) real, pointer, dimension(:,:,:) :: UFORCHEM, VFORCHEM, TFORCHEM, THFORCHEM real, pointer, dimension(:,:,:) :: UFORTURB, VFORTURB, TFORTURB, THFORTURB, SFORTURB real, pointer, dimension(:,:,:) :: TFORRAD - real, pointer, dimension(:,:,:) :: UAFDIFFUSE, VAFDIFFUSE, QAFDIFFUSE, SAFDIFFUSE, SAFUPDATE + real, pointer, dimension(:,:,:) :: UAFDIFFUSE, VAFDIFFUSE, SAFDIFFUSE, SAFUPDATE + real, allocatable, dimension(:,:,:) :: TMP3D real, allocatable, dimension(:,:,:) :: HGT real, allocatable, dimension(:,:,:) :: TDPOLD, TDPNEW real, allocatable, dimension(:,:,:) :: TFORQS @@ -2180,6 +2678,9 @@ subroutine Run ( GC, IMPORT, EXPORT, CLOCK, RC ) real(kind=MAPL_R8), allocatable, dimension(:,:,:) :: dq real, pointer, dimension(:,:,:) :: DTDT_BL, DQDT_BL + real, pointer, dimension(:,:) :: LONS, LATS + real, pointer, dimension(:,:) :: PTR2D + real(kind=8) :: t1, t2 real*8, allocatable, dimension(:,:) :: sum_qdp_b4 real*8, allocatable, dimension(:,:) :: sum_qdp_af @@ -2221,10 +2722,8 @@ subroutine Run ( GC, IMPORT, EXPORT, CLOCK, RC ) call MAPL_GetResource(STATE, SCM_NO_RAD, Label="SCM_NO_RAD:", default=.FALSE., RC=STATUS) VERIFY_(STATUS) - call MAPL_GetResource(STATE, DUMMY, Label="DPEDT_PHYS:", default='YES', RC=STATUS) + call MAPL_GetResource(STATE, DPEDT_PHYS, Label="DPEDT_PHYS:", default=.TRUE., RC=STATUS) VERIFY_(STATUS) - DUMMY = ESMF_UtilStringUpperCase(DUMMY) - DPEDT_PHYS = TRIM(DUMMY).eq.'YES' ! Get the children`s states from the generic state !------------------------------------------------- @@ -2232,6 +2731,7 @@ subroutine Run ( GC, IMPORT, EXPORT, CLOCK, RC ) call MAPL_Get ( STATE, & GCS=GCS, GIM=GIM, GEX=GEX, & IM = IM, JM = JM, LM = LM, & + LONS=LONS, LATS=LATS, & GCNames = GCNames, & INTERNAL_ESMF_STATE = INTERNAL, & RC=STATUS ) @@ -2286,18 +2786,19 @@ subroutine Run ( GC, IMPORT, EXPORT, CLOCK, RC ) QGRAUPEL => zero end if -! Initialize Passive Tracer QW -! ---------------------------- - call MAPL_GetPointer(INTERNAL, QW, 'QW', RC=STATUS); VERIFY_(STATUS) - QW = QV+QLLS+QLCN+QILS+QICN+QRAIN+QSNOW+QGRAUPEL - ! Get Global PHYSICS Parameters ! ----------------------------- + call MAPL_GetResource(STATE, SYNCUV, 'SYNCUV:', DEFAULT= 1.0, RC=STATUS) + VERIFY_(STATUS) call MAPL_GetResource(STATE, SYNCTQ, 'SYNCTQ:', DEFAULT= 1.0, RC=STATUS) VERIFY_(STATUS) + call MAPL_GetResource(STATE, DEBUG_SYNCTQ, Label="DEBUG_SYNCTQ:", DEFAULT= .false., RC=STATUS) + VERIFY_(STATUS) call MAPL_GetResource(STATE, DOPHYSICS, 'DOPHYSICS:', DEFAULT= 1.0, RC=STATUS) VERIFY_(STATUS) - call MAPL_GetResource(STATE, HGT_SURFACE, Label="HGT_SURFACE:", DEFAULT= 50.0, RC=STATUS) + HGT_SURFACE = 50.0 + if (LM .eq. 72) HGT_SURFACE = 0.0 + call MAPL_GetResource(STATE, HGT_SURFACE, Label="HGT_SURFACE:", DEFAULT= HGT_SURFACE, RC=STATUS) VERIFY_(STATUS) @@ -2313,23 +2814,47 @@ subroutine Run ( GC, IMPORT, EXPORT, CLOCK, RC ) call MAPL_GetPointer(IMPORT, PLE, 'PLE' , RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(IMPORT, AREA, 'AREA' , RC=STATUS); VERIFY_(STATUS) - allocate( TDPOLD(IM,JM,LM),stat=STATUS ) - VERIFY_(STATUS) - - TDPOLD = T(:,:,1:LM) * (PLE(:,:,1:LM)-PLE(:,:,0:LM-1)) - allocate(DM(IM,JM,LM),stat=STATUS) VERIFY_(STATUS) - DM = (PLE(:,:,1:LM)-PLE(:,:,0:LM-1))*(1.0/MAPL_GRAV) + DM = (PLE(:,:,1:LM)-PLE(:,:,0:LM-1))/MAPL_GRAV allocate(DPI(IM,JM,LM),stat=STATUS) VERIFY_(STATUS) DPI = 1./(PLE(:,:,1:LM)-PLE(:,:,0:LM-1)) - ! Create Old Dry Mass Variables - ! ----------------------------- - allocate( sumq( IM,JM ), STAT=STATUS ) ; VERIFY_(STATUS) - allocate( ple_new(IM,JM,0:LM),STAT=STATUS ) ; VERIFY_(STATUS) + allocate( TDPOLD(IM,JM,LM),stat=STATUS ) + VERIFY_(STATUS) + TDPOLD = T(:,:,1:LM) / DPI + + allocate( TMP3D(IM,JM,LM),stat=STATUS ) + VERIFY_(STATUS) + +! Get fill negative export pointers if requested +! ---------------------------------------------- + call MAPL_GetPointer(EXPORT, DQVDT_FILL, 'DQVDT_FILL_PHYS0', RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, DQLLSDT_FILL, 'DQLLSDT_FILL_PHYS0', RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, DQLCNDT_FILL, 'DQLCNDT_FILL_PHYS0', RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, DQILSDT_FILL, 'DQILSDT_FILL_PHYS0', RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, DQICNDT_FILL, 'DQICNDT_FILL_PHYS0', RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, DQRDT_FILL, 'DQRDT_FILL_PHYS0', RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, DQSDT_FILL, 'DQSDT_FILL_PHYS0', RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, DQGDT_FILL, 'DQGDT_FILL_PHYS0', RC=STATUS); VERIFY_(STATUS) + +! Cleanup negative water species +! ------------------------------ + call FILLQ2ZERO( QV , DM, DT=DT, DQDT= DQVDT_FILL, WARNING_LABEL="QV Before Physics" , VM=VMG, RC=STATUS); VERIFY_(STATUS) + call FILLQ2ZERO( QLLS , DM, DT=DT, DQDT=DQLLSDT_FILL, WARNING_LABEL="QLLS Before Physics", VM=VMG, RC=STATUS); VERIFY_(STATUS) + call FILLQ2ZERO( QLCN , DM, DT=DT, DQDT=DQLCNDT_FILL, WARNING_LABEL="QLCN Before Physics", VM=VMG, RC=STATUS); VERIFY_(STATUS) + call FILLQ2ZERO( QILS , DM, DT=DT, DQDT=DQILSDT_FILL, WARNING_LABEL="QILS Before Physics", VM=VMG, RC=STATUS); VERIFY_(STATUS) + call FILLQ2ZERO( QICN , DM, DT=DT, DQDT=DQICNDT_FILL, WARNING_LABEL="QICN Before Physics", VM=VMG, RC=STATUS); VERIFY_(STATUS) + call FILLQ2ZERO( QRAIN , DM, DT=DT, DQDT= DQRDT_FILL, WARNING_LABEL="QR Before Physics" , VM=VMG, RC=STATUS); VERIFY_(STATUS) + call FILLQ2ZERO( QSNOW , DM, DT=DT, DQDT= DQSDT_FILL, WARNING_LABEL="QS Before Physics" , VM=VMG, RC=STATUS); VERIFY_(STATUS) + call FILLQ2ZERO( QGRAUPEL, DM, DT=DT, DQDT= DQGDT_FILL, WARNING_LABEL="QG Before Physics" , VM=VMG, RC=STATUS); VERIFY_(STATUS) + +! Initialize Passive Tracer QW +! ---------------------------- + call MAPL_GetPointer(INTERNAL, QW, 'QW', RC=STATUS); VERIFY_(STATUS) + QW = QV+QLLS+QLCN+QILS+QICN+QRAIN+QSNOW+QGRAUPEL ! Pointers to Exports !-------------------- @@ -2361,6 +2886,9 @@ subroutine Run ( GC, IMPORT, EXPORT, CLOCK, RC ) call MAPL_GetPointer(EXPORT, DQVDTMSTINT, 'DQVDTMSTINT', RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(EXPORT, DQLDTMSTINT, 'DQLDTMSTINT', RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(EXPORT, DQIDTMSTINT, 'DQIDTMSTINT', RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, DQRDTMSTINT, 'DQRDTMSTINT', RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, DQSDTMSTINT, 'DQSDTMSTINT', RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, DQGDTMSTINT, 'DQGDTMSTINT', RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(EXPORT, DQVDTTRBINT, 'DQVDTTRBINT', RC=STATUS); VERIFY_(STATUS) @@ -2370,6 +2898,9 @@ subroutine Run ( GC, IMPORT, EXPORT, CLOCK, RC ) call MAPL_GetPointer(EXPORT, DQVDTPHYINT, 'DQVDTPHYINT', RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(EXPORT, DQLDTPHYINT, 'DQLDTPHYINT', RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(EXPORT, DQIDTPHYINT, 'DQIDTPHYINT', RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, DQRDTPHYINT, 'DQRDTPHYINT', RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, DQSDTPHYINT, 'DQSDTPHYINT', RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, DQGDTPHYINT, 'DQGDTPHYINT', RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(EXPORT, DOXDTPHYINT, 'DOXDTPHYINT', RC=STATUS); VERIFY_(STATUS) ! Get and allocate pointers to Exports that have been put in turbulence @@ -2433,6 +2964,8 @@ subroutine Run ( GC, IMPORT, EXPORT, CLOCK, RC ) VERIFY_(STATUS) call MAPL_GetPointer ( EXPORT, DQIDTTRB, 'QILSIT', alloc=.true., RC=STATUS) VERIFY_(STATUS) + call MAPL_GetPointer ( EXPORT, TKEIT, 'TKESHOCIT', alloc=.true., RC=STATUS) + VERIFY_(STATUS) call MAPL_GetPointer ( GEX(TURBL), DPDTTRB , 'DPDTTRB', alloc=.true., RC=STATUS) VERIFY_(STATUS) call MAPL_GetPointer ( GEX(MOIST), DPDTMST , 'DPDTMST', alloc=.true., RC=STATUS) @@ -2445,6 +2978,12 @@ subroutine Run ( GC, IMPORT, EXPORT, CLOCK, RC ) VERIFY_(STATUS) call MAPL_GetPointer ( GEX(MOIST), DQIDTMST, 'DQIDT', alloc=.true., RC=STATUS) VERIFY_(STATUS) + call MAPL_GetPointer ( GEX(MOIST), DQRDTMST, 'DQRDT', alloc=.true., RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer ( GEX(MOIST), DQSDTMST, 'DQSDT', alloc=.true., RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer ( GEX(MOIST), DQGDTMST, 'DQGDT', alloc=.true., RC=STATUS) + VERIFY_(STATUS) call MAPL_GetPointer (EXPORT, DQVDTSCL, 'DQVDTSCL', RC=STATUS) VERIFY_(STATUS) @@ -2494,11 +3033,11 @@ subroutine Run ( GC, IMPORT, EXPORT, CLOCK, RC ) if ( DOPHYSICS.eq.1. ) then - if ( SYNCTQ.ge.1. ) then + if ( (SYNCTQ.ge.1.) .OR. (SYNCUV.ge.1.) ) then ! Will need PK to get from T to TH and back allocate(PK(IM,JM,LM),stat=STATUS);VERIFY_(STATUS) PK = ((0.5*(PLE(:,:,0:LM-1)+PLE(:,:,1:LM))) / MAPL_P00)**MAPL_KAPPA - if ( (LM .ne. 72) .and. (HGT_SURFACE .gt. 0.0) ) then + if ( HGT_SURFACE .gt. 0.0 ) then allocate(HGT(IM,JM,LM+1),stat=STATUS);VERIFY_(STATUS) do k = 1,LM+1 HGT(:,:,k) = (ZLE(:,:,k-1) - ZLE(:,:,LM)) @@ -2512,9 +3051,12 @@ subroutine Run ( GC, IMPORT, EXPORT, CLOCK, RC ) !---------------------------------------- I=GWD - call MAPL_TimerOn (STATE,GCNames(I)) + t1 = MPI_Wtime(status); VERIFY_(STATUS) call ESMF_GridCompRun (GCS(I), importState=GIM(I), exportState=GEX(I), clock=CLOCK, userRC=STATUS ); VERIFY_(STATUS) + t2 = MPI_Wtime(status); VERIFY_(STATUS) + call MAPL_GetPointer (EXPORT, PTR2D, 'TIME_IN_GWD', RC=STATUS); VERIFY_(STATUS) + if (associated(PTR2D)) PTR2D = t2-t1 call MAPL_GenericRunCouplers (STATE, I, CLOCK, RC=STATUS ); VERIFY_(STATUS) call MAPL_TimerOff(STATE,GCNames(I)) @@ -2527,24 +3069,72 @@ subroutine Run ( GC, IMPORT, EXPORT, CLOCK, RC ) I=MOIST call MAPL_TimerOn (STATE,GCNames(I)) + t1 = MPI_Wtime(status); VERIFY_(STATUS) call ESMF_GridCompRun (GCS(I), importState=GIM(I), exportState=GEX(I), clock=CLOCK, userRC=STATUS ); VERIFY_(STATUS) + t2 = MPI_Wtime(status); VERIFY_(STATUS) + call MAPL_GetPointer (EXPORT, PTR2D, 'TIME_IN_MST', RC=STATUS); VERIFY_(STATUS) + if (associated(PTR2D)) PTR2D = t2-t1 call MAPL_GenericRunCouplers (STATE, I, CLOCK, RC=STATUS ); VERIFY_(STATUS) call MAPL_TimerOff(STATE,GCNames(I)) +! Get fill negative export pointers if requested +! ---------------------------------------------- + call MAPL_GetPointer(EXPORT, DQVDT_FILL, 'DQVDT_FILL_AFMST', RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, DQLLSDT_FILL, 'DQLLSDT_FILL_AFMST', RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, DQLCNDT_FILL, 'DQLCNDT_FILL_AFMST', RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, DQILSDT_FILL, 'DQILSDT_FILL_AFMST', RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, DQICNDT_FILL, 'DQICNDT_FILL_AFMST', RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, DQRDT_FILL, 'DQRDT_FILL_AFMST', RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, DQSDT_FILL, 'DQSDT_FILL_AFMST', RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, DQGDT_FILL, 'DQGDT_FILL_AFMST', RC=STATUS); VERIFY_(STATUS) + +! Cleanup negative water species +! ------------------------------ + call FILLQ2ZERO( QV , DM, DT=DT, DQDT= DQVDT_FILL, WARNING_LABEL="QV After Moist" , VM=VMG, RC=STATUS); VERIFY_(STATUS) + call FILLQ2ZERO( QLLS , DM, DT=DT, DQDT=DQLLSDT_FILL, WARNING_LABEL="QLLS After Moist", VM=VMG, RC=STATUS); VERIFY_(STATUS) + call FILLQ2ZERO( QLCN , DM, DT=DT, DQDT=DQLCNDT_FILL, WARNING_LABEL="QLCN After Moist", VM=VMG, RC=STATUS); VERIFY_(STATUS) + call FILLQ2ZERO( QILS , DM, DT=DT, DQDT=DQILSDT_FILL, WARNING_LABEL="QILS After Moist", VM=VMG, RC=STATUS); VERIFY_(STATUS) + call FILLQ2ZERO( QICN , DM, DT=DT, DQDT=DQICNDT_FILL, WARNING_LABEL="QICN After Moist", VM=VMG, RC=STATUS); VERIFY_(STATUS) + call FILLQ2ZERO( QRAIN , DM, DT=DT, DQDT= DQRDT_FILL, WARNING_LABEL="QR After Moist" , VM=VMG, RC=STATUS); VERIFY_(STATUS) + call FILLQ2ZERO( QSNOW , DM, DT=DT, DQDT= DQSDT_FILL, WARNING_LABEL="QS After Moist" , VM=VMG, RC=STATUS); VERIFY_(STATUS) + call FILLQ2ZERO( QGRAUPEL, DM, DT=DT, DQDT= DQGDT_FILL, WARNING_LABEL="QG After Moist" , VM=VMG, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetObjectFromGC ( GCS(I), CMETA, _RC) call Compute_IncBundle( GIM(MOIST), EXPORT, MTRIinc, STATE, __RC__) ! 3D non-weighted call Compute_IncMBundle(GIM(MOIST), EXPORT, CMETA, DM=DM, __RC__) ! 2D mass-weighted - call MAPL_GetPointer(GIM(MOIST), DTDT_BL, 'DTDT_BL', alloc = .true. ,RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(GIM(MOIST), DQDT_BL, 'DQDT_BL', alloc = .true. ,RC=STATUS); VERIFY_(STATUS) +! SYNCUV - Stage 1 SYNC of U/V +!-------------------------------------- + if ( SYNCUV.ge.1. ) then + ! From Moist + call MAPL_GetPointer ( GEX(MOIST), UAFMOIST, 'UAFMOIST', RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer ( GEX(MOIST), VAFMOIST, 'VAFMOIST', RC=STATUS); VERIFY_(STATUS) + ! For SURF + call MAPL_GetPointer ( GIM(SURF), UFORSURF, 'UA', RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer ( GIM(SURF), VFORSURF, 'VA', RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer ( GIM(SURF), SPD4SURF, 'SPEED', RC=STATUS); VERIFY_(STATUS) + if ( HGT_SURFACE .gt. 0.0 ) then + call VertInterp(UFORSURF,UAFMOIST,-HGT,-HGT_SURFACE, rc=status); VERIFY_(STATUS) + call VertInterp(VFORSURF,VAFMOIST,-HGT,-HGT_SURFACE, rc=status); VERIFY_(STATUS) + else + UFORSURF = UAFMOIST(:,:,LM) + VFORSURF = VAFMOIST(:,:,LM) + endif + SPD4SURF = SQRT( UFORSURF*UFORSURF + VFORSURF*VFORSURF ) + ! For TURBL + call MAPL_GetPointer ( GIM(TURBL), UFORTURB, 'U', RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer ( GIM(TURBL), VFORTURB, 'V', RC=STATUS); VERIFY_(STATUS) + UFORTURB = UAFMOIST + VFORTURB = VAFMOIST + endif ! SYNCTQ - Stage 1 SYNC of T/Q and U/V !-------------------------------------- if ( SYNCTQ.ge.1. ) then + call MAPL_GetPointer(GIM(MOIST), DTDT_BL, 'DTDT_BL', alloc = .true. ,RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(GIM(MOIST), DQDT_BL, 'DQDT_BL', alloc = .true. ,RC=STATUS); VERIFY_(STATUS) ! From Moist - call MAPL_GetPointer ( GEX(MOIST), UAFMOIST, 'UAFMOIST', RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer ( GEX(MOIST), VAFMOIST, 'VAFMOIST', RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer ( GEX(MOIST), TAFMOIST, 'TAFMOIST', RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer ( GEX(MOIST), THAFMOIST, 'THAFMOIST', RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer ( GEX(MOIST), SAFMOIST, 'SAFMOIST', RC=STATUS); VERIFY_(STATUS) @@ -2553,23 +3143,16 @@ subroutine Run ( GC, IMPORT, EXPORT, CLOCK, RC ) DTDT_BL=TAFMOIST DQDT_BL=QV ! For SURF - call MAPL_GetPointer ( GIM(SURF), UFORSURF, 'UA', RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer ( GIM(SURF), VFORSURF, 'VA', RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer ( GIM(SURF), TFORSURF, 'TA', RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer ( GIM(SURF), QFORSURF, 'QA', RC=STATUS); VERIFY_(STATUS) - if ( (LM .ne. 72) .and. (HGT_SURFACE .gt. 0.0) ) then - call VertInterp(UFORSURF,UAFMOIST,-HGT,-HGT_SURFACE, status); VERIFY_(STATUS) - call VertInterp(VFORSURF,VAFMOIST,-HGT,-HGT_SURFACE, status); VERIFY_(STATUS) - call VertInterp(TFORSURF,TAFMOIST,-HGT,-HGT_SURFACE, status); VERIFY_(STATUS) - call VertInterp(QFORSURF,QAFMOIST,-HGT,-HGT_SURFACE, status); VERIFY_(STATUS) + call MAPL_GetPointer ( GIM(SURF), SPD4SURF, 'SPEED', RC=STATUS); VERIFY_(STATUS) + if ( HGT_SURFACE .gt. 0.0 ) then + call VertInterp(TFORSURF,TAFMOIST,-HGT,-HGT_SURFACE, rc=status); VERIFY_(STATUS) + call VertInterp(QFORSURF,QAFMOIST,-HGT,-HGT_SURFACE, positive_definite=.true., rc=status); VERIFY_(STATUS) else - UFORSURF = UAFMOIST(:,:,LM) - VFORSURF = VAFMOIST(:,:,LM) TFORSURF = TAFMOIST(:,:,LM) QFORSURF = QAFMOIST(:,:,LM) endif - call MAPL_GetPointer ( GIM(SURF), SPD4SURF, 'SPEED', RC=STATUS); VERIFY_(STATUS) - SPD4SURF = SQRT( UFORSURF*UFORSURF + VFORSURF*VFORSURF ) ! For CHEM if ( SYNCTQ.eq.1. ) then call MAPL_GetPointer ( GIM(CHEM), TFORCHEM, 'T', RC=STATUS); VERIFY_(STATUS) @@ -2580,24 +3163,51 @@ subroutine Run ( GC, IMPORT, EXPORT, CLOCK, RC ) ! For TURBL call ESMF_StateGet(GIM(TURBL), 'TR', BUNDLE, RC=STATUS ); VERIFY_(STATUS) call ESMFL_BundleGetPointerToData(BUNDLE,'S',SFORTURB, RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer ( GIM(TURBL), UFORTURB, 'U', RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer ( GIM(TURBL), VFORTURB, 'V', RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer ( GIM(TURBL), TFORTURB, 'T', RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer ( GIM(TURBL), THFORTURB, 'TH', RC=STATUS); VERIFY_(STATUS) - UFORTURB = UAFMOIST - VFORTURB = VAFMOIST TFORTURB = TAFMOIST THFORTURB = THAFMOIST SFORTURB = SAFMOIST endif + if (DEBUG_SYNCTQ) then + if ( SYNCTQ.ge.1. ) then + call MAPL_MaxMin('SYNCTQ: TAFMOIST', TAFMOIST) + call MAPL_MaxMin('SYNCTQ: QAFMOIST', QAFMOIST) + call MAPL_MaxMin('SYNCTQ: TFORSURF', TFORSURF) + call MAPL_MaxMin('SYNCTQ: QFORSURF', QFORSURF) + endif + if ( SYNCUV.ge.1. ) then + call MAPL_MaxMin('SYNCTQ: UFORSURF', UFORSURF) + call MAPL_MaxMin('SYNCTQ: VFORSURF', VFORSURF) + endif + call MAPL_GetPointer ( GIM(SURF), PTR2D, 'TPREC', RC=STATUS); VERIFY_(STATUS) + call MAPL_MaxMin('SYNCTQ: TPREC ', PTR2D) + call MAPL_GetPointer ( GIM(SURF), PTR2D, 'CN_PRCP', RC=STATUS); VERIFY_(STATUS) + call MAPL_MaxMin('SYNCTQ: CN_PRCP ', PTR2D) + call MAPL_GetPointer ( GIM(SURF), PTR2D, 'PCU', RC=STATUS); VERIFY_(STATUS) + call MAPL_MaxMin('SYNCTQ: PCU ', PTR2D) + call MAPL_GetPointer ( GIM(SURF), PTR2D, 'PLS', RC=STATUS); VERIFY_(STATUS) + call MAPL_MaxMin('SYNCTQ: PLS ', PTR2D) + call MAPL_GetPointer ( GIM(SURF), PTR2D, 'SNO', RC=STATUS); VERIFY_(STATUS) + call MAPL_MaxMin('SYNCTQ: SNO ', PTR2D) + call MAPL_GetPointer ( GIM(SURF), PTR2D, 'ICE', RC=STATUS); VERIFY_(STATUS) + call MAPL_MaxMin('SYNCTQ: ICE ', PTR2D) + call MAPL_GetPointer ( GIM(SURF), PTR2D, 'FRZR', RC=STATUS); VERIFY_(STATUS) + call MAPL_MaxMin('SYNCTQ: FRZR ', PTR2D) + endif + ! Surface Stage 1 !---------------- I=SURF call MAPL_TimerOn(STATE,GCNames(I)) + t1 = MPI_Wtime(status); VERIFY_(STATUS) call ESMF_GridCompRun (GCS(I), importState=GIM(I), exportState=GEX(I), clock=CLOCK, PHASE=1, userRC=STATUS ); VERIFY_(STATUS) + t2 = MPI_Wtime(status); VERIFY_(STATUS) + call MAPL_GetPointer (EXPORT, PTR2D, 'TIME_IN_SFC', RC=STATUS); VERIFY_(STATUS) + if (associated(PTR2D)) PTR2D = t2-t1 call MAPL_TimerOff(STATE,GCNames(I)) ! Aerosol/Chemistry Stage 1 @@ -2606,7 +3216,11 @@ subroutine Run ( GC, IMPORT, EXPORT, CLOCK, RC ) I=CHEM call MAPL_TimerOn(STATE,GCNames(I)) + t1 = MPI_Wtime(status); VERIFY_(STATUS) call ESMF_GridCompRun (GCS(I), importState=GIM(I), exportState=GEX(I), clock=CLOCK, phase=1, userRC=STATUS ); VERIFY_(STATUS) + t2 = MPI_Wtime(status); VERIFY_(STATUS) + call MAPL_GetPointer (EXPORT, PTR2D, 'TIME_IN_CHM', RC=STATUS); VERIFY_(STATUS) + if (associated(PTR2D)) PTR2D = t2-t1 call MAPL_GenericRunCouplers (STATE, I, CLOCK, RC=STATUS ); VERIFY_(STATUS) call MAPL_TimerOff(STATE,GCNames(I)) @@ -2616,48 +3230,110 @@ subroutine Run ( GC, IMPORT, EXPORT, CLOCK, RC ) I=TURBL call MAPL_TimerOn(STATE,GCNames(I)) + t1 = MPI_Wtime(status); VERIFY_(STATUS) call ESMF_GridCompRun (GCS(I), importState=GIM(I), exportState=GEX(I), clock=CLOCK, PHASE=1, userRC=STATUS ); VERIFY_(STATUS) + t2 = MPI_Wtime(status); VERIFY_(STATUS) + call MAPL_GetPointer (EXPORT, PTR2D, 'TIME_IN_TRB', RC=STATUS); VERIFY_(STATUS) + if (associated(PTR2D)) PTR2D = t2-t1 call MAPL_TimerOff(STATE,GCNames(I)) -! SYNCTQ - Stage 2 SYNC of T/Q and U/V +! Get fill negative export pointers if requested +! ---------------------------------------------- + call MAPL_GetPointer(EXPORT, DQVDT_FILL, 'DQVDT_FILL_AFSTG1', RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, DQLLSDT_FILL, 'DQLLSDT_FILL_AFSTG1', RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, DQLCNDT_FILL, 'DQLCNDT_FILL_AFSTG1', RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, DQILSDT_FILL, 'DQILSDT_FILL_AFSTG1', RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, DQICNDT_FILL, 'DQICNDT_FILL_AFSTG1', RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, DQRDT_FILL, 'DQRDT_FILL_AFSTG1', RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, DQSDT_FILL, 'DQSDT_FILL_AFSTG1', RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, DQGDT_FILL, 'DQGDT_FILL_AFSTG1', RC=STATUS); VERIFY_(STATUS) + +! Cleanup negative water species +! ------------------------------ + call FILLQ2ZERO( QV , DM, DT=DT, DQDT= DQVDT_FILL, WARNING_LABEL="QV After Stage1" , VM=VMG, RC=STATUS); VERIFY_(STATUS) + call FILLQ2ZERO( QLLS , DM, DT=DT, DQDT=DQLLSDT_FILL, WARNING_LABEL="QLLS After Stage1", VM=VMG, RC=STATUS); VERIFY_(STATUS) + call FILLQ2ZERO( QLCN , DM, DT=DT, DQDT=DQLCNDT_FILL, WARNING_LABEL="QLCN After Stage1", VM=VMG, RC=STATUS); VERIFY_(STATUS) + call FILLQ2ZERO( QILS , DM, DT=DT, DQDT=DQILSDT_FILL, WARNING_LABEL="QILS After Stage1", VM=VMG, RC=STATUS); VERIFY_(STATUS) + call FILLQ2ZERO( QICN , DM, DT=DT, DQDT=DQICNDT_FILL, WARNING_LABEL="QICN After Stage1", VM=VMG, RC=STATUS); VERIFY_(STATUS) + call FILLQ2ZERO( QRAIN , DM, DT=DT, DQDT= DQRDT_FILL, WARNING_LABEL="QR After Stage1" , VM=VMG, RC=STATUS); VERIFY_(STATUS) + call FILLQ2ZERO( QSNOW , DM, DT=DT, DQDT= DQSDT_FILL, WARNING_LABEL="QS After Stage1" , VM=VMG, RC=STATUS); VERIFY_(STATUS) + call FILLQ2ZERO( QGRAUPEL, DM, DT=DT, DQDT= DQGDT_FILL, WARNING_LABEL="QG After Stage1" , VM=VMG, RC=STATUS); VERIFY_(STATUS) + +! SYNCUV - Stage 2 SYNC of U/V !-------------------------------------- - if ( SYNCTQ.ge.1. ) then + if ( SYNCUV.ge.1. ) then ! From TURBL Run 1 call MAPL_GetPointer ( GEX(TURBL), UAFDIFFUSE, 'UAFDIFFUSE', RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer ( GEX(TURBL), VAFDIFFUSE, 'VAFDIFFUSE', RC=STATUS); VERIFY_(STATUS) + ! For TURBL + call MAPL_GetPointer ( GIM(TURBL), UFORTURB, 'U', RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer ( GIM(TURBL), VFORTURB, 'V', RC=STATUS); VERIFY_(STATUS) + UFORTURB = UAFDIFFUSE + VFORTURB = VAFDIFFUSE + ! For SURF + call MAPL_GetPointer ( GIM(SURF), UFORSURF, 'UA', RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer ( GIM(SURF), VFORSURF, 'VA', RC=STATUS); VERIFY_(STATUS) + if ( HGT_SURFACE .gt. 0.0 ) then + call VertInterp(UFORSURF,UAFDIFFUSE,-HGT,-HGT_SURFACE, rc=status); VERIFY_(STATUS) + call VertInterp(VFORSURF,VAFDIFFUSE,-HGT,-HGT_SURFACE, rc=status); VERIFY_(STATUS) + else + UFORSURF = UAFDIFFUSE(:,:,LM) + VFORSURF = VAFDIFFUSE(:,:,LM) + endif + call MAPL_GetPointer ( GIM(SURF), SPD4SURF, 'SPEED', RC=STATUS); VERIFY_(STATUS) + SPD4SURF = SQRT( UFORSURF*UFORSURF + VFORSURF*VFORSURF ) + endif + +! SYNCTQ - Stage 2 SYNC of T/Q +!-------------------------------------- + if ( SYNCTQ.ge.1. ) then + ! From TURBL Run 1 call MAPL_GetPointer ( GEX(TURBL), SAFDIFFUSE, 'SAFDIFFUSE', RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer ( GEX(TURBL), QAFDIFFUSE, 'QAFDIFFUSE', RC=STATUS); VERIFY_(STATUS) ! For TURBL call ESMF_StateGet(GIM(TURBL), 'TR', BUNDLE, RC=STATUS ); VERIFY_(STATUS) call ESMFL_BundleGetPointerToData(BUNDLE,'S',SFORTURB, RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer ( GIM(TURBL), UFORTURB, 'U', RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer ( GIM(TURBL), VFORTURB, 'V', RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer ( GIM(TURBL), TFORTURB, 'T', RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer ( GIM(TURBL), THFORTURB, 'TH', RC=STATUS); VERIFY_(STATUS) - UFORTURB = UAFDIFFUSE - VFORTURB = VAFDIFFUSE ! For Stage 2 - Changes in S from TURBL assumed to be all in T TFORTURB = TFORTURB + (SAFDIFFUSE-SFORTURB)/MAPL_CP THFORTURB = TFORTURB/PK SFORTURB = SAFDIFFUSE ! For SURF - call MAPL_GetPointer ( GIM(SURF), UFORSURF, 'UA', RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer ( GIM(SURF), VFORSURF, 'VA', RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer ( GIM(SURF), TFORSURF, 'TA', RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer ( GIM(SURF), QFORSURF, 'QA', RC=STATUS); VERIFY_(STATUS) - if ( (LM .ne. 72) .and. (HGT_SURFACE .gt. 0.0) ) then - call VertInterp(TFORSURF,TFORTURB,-HGT,-HGT_SURFACE, status); VERIFY_(STATUS) - call VertInterp(UFORSURF,UAFDIFFUSE,-HGT,-HGT_SURFACE, status); VERIFY_(STATUS) - call VertInterp(VFORSURF,VAFDIFFUSE,-HGT,-HGT_SURFACE, status); VERIFY_(STATUS) - call VertInterp(QFORSURF,QAFDIFFUSE,-HGT,-HGT_SURFACE, status); VERIFY_(STATUS) + if ( HGT_SURFACE .gt. 0.0 ) then + call VertInterp(TFORSURF,TFORTURB,-HGT,-HGT_SURFACE, rc=status); VERIFY_(STATUS) + call VertInterp(QFORSURF,QV ,-HGT,-HGT_SURFACE, positive_definite=.true., rc=status); VERIFY_(STATUS) else TFORSURF = TFORTURB(:,:,LM) - UFORSURF = UAFDIFFUSE(:,:,LM) - VFORSURF = VAFDIFFUSE(:,:,LM) - QFORSURF = QAFDIFFUSE(:,:,LM) + QFORSURF = QV(:,:,LM) endif - call MAPL_GetPointer ( GIM(SURF), SPD4SURF, 'SPEED', RC=STATUS); VERIFY_(STATUS) - SPD4SURF = SQRT( UFORSURF*UFORSURF + VFORSURF*VFORSURF ) + endif + + if (DEBUG_SYNCTQ) then + if ( SYNCTQ.ge.1. ) then + call MAPL_MaxMin('SYNCTQ: TFORSURF', TFORSURF) + call MAPL_MaxMin('SYNCTQ: QFORSURF', QFORSURF) + call MAPL_MaxMin('SYNCTQ: TFORTURB', TFORTURB) + endif + if ( SYNCUV.ge.1. ) then + call MAPL_MaxMin('SYNCTQ: UFORSURF', UFORSURF) + call MAPL_MaxMin('SYNCTQ: VFORSURF', VFORSURF) + endif + call MAPL_GetPointer ( GIM(SURF), PTR2D, 'TPREC', RC=STATUS); VERIFY_(STATUS) + call MAPL_MaxMin('SYNCTQ: TPREC ', PTR2D) + call MAPL_GetPointer ( GIM(SURF), PTR2D, 'CN_PRCP', RC=STATUS); VERIFY_(STATUS) + call MAPL_MaxMin('SYNCTQ: CN_PRCP ', PTR2D) + call MAPL_GetPointer ( GIM(SURF), PTR2D, 'PCU', RC=STATUS); VERIFY_(STATUS) + call MAPL_MaxMin('SYNCTQ: PCU ', PTR2D) + call MAPL_GetPointer ( GIM(SURF), PTR2D, 'PLS', RC=STATUS); VERIFY_(STATUS) + call MAPL_MaxMin('SYNCTQ: PLS ', PTR2D) + call MAPL_GetPointer ( GIM(SURF), PTR2D, 'SNO', RC=STATUS); VERIFY_(STATUS) + call MAPL_MaxMin('SYNCTQ: SNO ', PTR2D) + call MAPL_GetPointer ( GIM(SURF), PTR2D, 'ICE', RC=STATUS); VERIFY_(STATUS) + call MAPL_MaxMin('SYNCTQ: ICE ', PTR2D) + call MAPL_GetPointer ( GIM(SURF), PTR2D, 'FRZR', RC=STATUS); VERIFY_(STATUS) + call MAPL_MaxMin('SYNCTQ: FRZR ', PTR2D) endif ! Surface Stage 2 @@ -2666,7 +3342,11 @@ subroutine Run ( GC, IMPORT, EXPORT, CLOCK, RC ) I=SURF call MAPL_TimerOn(STATE,GCNames(I)) + t1 = MPI_Wtime(status); VERIFY_(STATUS) call ESMF_GridCompRun (GCS(I), importState=GIM(I), exportState=GEX(I), clock=CLOCK, PHASE=2, userRC=STATUS ); VERIFY_(STATUS) + t2 = MPI_Wtime(status); VERIFY_(STATUS) + call MAPL_GetPointer (EXPORT, PTR2D, 'TIME_IN_SFC', RC=STATUS); VERIFY_(STATUS) + if (associated(PTR2D)) PTR2D = PTR2D + t2-t1 call MAPL_GenericRunCouplers (STATE, I, CLOCK, RC=STATUS ); VERIFY_(STATUS) call MAPL_TimerOff(STATE,GCNames(I)) @@ -2676,24 +3356,69 @@ subroutine Run ( GC, IMPORT, EXPORT, CLOCK, RC ) I=TURBL call MAPL_TimerOn(STATE,GCNames(I)) + t1 = MPI_Wtime(status); VERIFY_(STATUS) call ESMF_GridCompRun (GCS(I), importState=GIM(I), exportState=GEX(I), clock=CLOCK, PHASE=2, userRC=STATUS ); VERIFY_(STATUS) + t2 = MPI_Wtime(status); VERIFY_(STATUS) + call MAPL_GetPointer (EXPORT, PTR2D, 'TIME_IN_TRB', RC=STATUS); VERIFY_(STATUS) + if (associated(PTR2D)) PTR2D = PTR2D + t2-t1 call MAPL_GenericRunCouplers (STATE, I, CLOCK, RC=STATUS ); VERIFY_(STATUS) call MAPL_TimerOff(STATE,GCNames(I)) +! Get fill negative export pointers if requested +! ---------------------------------------------- + call MAPL_GetPointer(EXPORT, DQVDT_FILL, 'DQVDT_FILL_AFSTG2', RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, DQLLSDT_FILL, 'DQLLSDT_FILL_AFSTG2', RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, DQLCNDT_FILL, 'DQLCNDT_FILL_AFSTG2', RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, DQILSDT_FILL, 'DQILSDT_FILL_AFSTG2', RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, DQICNDT_FILL, 'DQICNDT_FILL_AFSTG2', RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, DQRDT_FILL, 'DQRDT_FILL_AFSTG2', RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, DQSDT_FILL, 'DQSDT_FILL_AFSTG2', RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, DQGDT_FILL, 'DQGDT_FILL_AFSTG2', RC=STATUS); VERIFY_(STATUS) + +! Cleanup negative water species +! ------------------------------ + call FILLQ2ZERO( QV , DM, DT=DT, DQDT= DQVDT_FILL, WARNING_LABEL="QV After Stage2" , VM=VMG, RC=STATUS); VERIFY_(STATUS) + call FILLQ2ZERO( QLLS , DM, DT=DT, DQDT=DQLLSDT_FILL, WARNING_LABEL="QLLS After Stage2", VM=VMG, RC=STATUS); VERIFY_(STATUS) + call FILLQ2ZERO( QLCN , DM, DT=DT, DQDT=DQLCNDT_FILL, WARNING_LABEL="QLCN After Stage2", VM=VMG, RC=STATUS); VERIFY_(STATUS) + call FILLQ2ZERO( QILS , DM, DT=DT, DQDT=DQILSDT_FILL, WARNING_LABEL="QILS After Stage2", VM=VMG, RC=STATUS); VERIFY_(STATUS) + call FILLQ2ZERO( QICN , DM, DT=DT, DQDT=DQICNDT_FILL, WARNING_LABEL="QICN After Stage2", VM=VMG, RC=STATUS); VERIFY_(STATUS) + call FILLQ2ZERO( QRAIN , DM, DT=DT, DQDT= DQRDT_FILL, WARNING_LABEL="QR After Stage2" , VM=VMG, RC=STATUS); VERIFY_(STATUS) + call FILLQ2ZERO( QSNOW , DM, DT=DT, DQDT= DQSDT_FILL, WARNING_LABEL="QS After Stage2" , VM=VMG, RC=STATUS); VERIFY_(STATUS) + call FILLQ2ZERO( QGRAUPEL, DM, DT=DT, DQDT= DQGDT_FILL, WARNING_LABEL="QG After Stage2" , VM=VMG, RC=STATUS); VERIFY_(STATUS) + if ( SYNCTQ.ge.1. ) then + call MAPL_GetPointer ( GIM(RAD), TFORRAD, 'T', RC=STATUS); VERIFY_(STATUS) ! From TURBL Stage 2 call MAPL_GetPointer ( GEX(TURBL), SAFUPDATE, 'SAFUPDATE', RC=STATUS); VERIFY_(STATUS) ! For RAD - call MAPL_GetPointer ( GIM(RAD), TFORRAD, 'T', RC=STATUS); VERIFY_(STATUS) - ! For Stage 2 - Changes in S from TURBL assumed to be all in T + ! For Stage 2 - Changes in S from TURBL assumed to be all in T TFORRAD = TFORTURB + (SAFUPDATE-SAFDIFFUSE)/MAPL_CP - ! For CHEM use the same T as CHEM + ! For CHEM use the same T as RAD if ( SYNCTQ.eq.1. ) then call MAPL_GetPointer ( GIM(CHEM), TFORCHEM, 'T', RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer ( GIM(CHEM), THFORCHEM, 'TH', RC=STATUS); VERIFY_(STATUS) TFORCHEM = TFORRAD THFORCHEM = TFORRAD/PK endif + + if (DEBUG_SYNCTQ) then + call MAPL_MaxMin('SYNCTQ: QFORRAD ', QV) + call MAPL_MaxMin('SYNCTQ: TFORRAD ', TFORRAD) + endif + do L=1,LM + do J=1,JM + do I=1,IM + if ( (TFORRAD(I,J,L) > 333.0) .OR. (QV(I,J,L) < 0.0) .OR. (QV(I,J,L) > 1.0) ) then + print *, "SYNTQ for Radiation error T= : ", TFORRAD(I,J,L) + print *, " Q= : ", QV(I,J,L) + print *, " Latitude =", LATS(I,J)*180.0/MAPL_PI + print *, " Longitude =", LONS(I,J)*180.0/MAPL_PI + print *, " Pressure (mb) =", 0.5*(PLE(I,J,L)+PLE(I,J,L-1))/100.0 + endif + end do ! IM loop + end do ! JM loop + end do ! LM loop + endif ! Boundary Layer Tendencies for GF @@ -2709,7 +3434,11 @@ subroutine Run ( GC, IMPORT, EXPORT, CLOCK, RC ) I=CHEM call MAPL_TimerOn(STATE,GCNames(I)) + t1 = MPI_Wtime(status); VERIFY_(STATUS) call ESMF_GridCompRun (GCS(I), importState=GIM(I), exportState=GEX(I), clock=CLOCK, PHASE=2, userRC=STATUS ); VERIFY_(STATUS) + t2 = MPI_Wtime(status); VERIFY_(STATUS) + call MAPL_GetPointer (EXPORT, PTR2D, 'TIME_IN_CHM', RC=STATUS); VERIFY_(STATUS) + if (associated(PTR2D)) PTR2D = PTR2D + t2-t1 call MAPL_GenericRunCouplers (STATE, I, CLOCK, RC=STATUS ); VERIFY_(STATUS) call MAPL_TimerOff(STATE,GCNames(I)) @@ -2719,14 +3448,24 @@ subroutine Run ( GC, IMPORT, EXPORT, CLOCK, RC ) I=RAD call MAPL_TimerOn (STATE,GCNames(I)) + t1 = MPI_Wtime(status); VERIFY_(STATUS) call ESMF_GridCompRun (GCS(I), importState=GIM(I), exportState=GEX(I), clock=CLOCK, userRC=STATUS ); VERIFY_(STATUS) + t2 = MPI_Wtime(status); VERIFY_(STATUS) + call MAPL_GetPointer (EXPORT, PTR2D, 'TIME_IN_RAD', RC=STATUS); VERIFY_(STATUS) + if (associated(PTR2D)) PTR2D = t2-t1 call MAPL_GenericRunCouplers (STATE, I, CLOCK, RC=STATUS ); VERIFY_(STATUS) call MAPL_TimerOff(STATE,GCNames(I)) + if (DEBUG_SYNCTQ) then + call MAPL_MaxMin('SYNCTQ: TAFRAD ', TFORRAD + DT*TIR*DPI) + endif + ! Clean up SYNTQ things if ( SYNCTQ.ge.1. ) then deallocate(PK) - if ( (LM .ne. 72) .and. (HGT_SURFACE .gt. 0.0) ) deallocate(HGT) + if ( HGT_SURFACE .gt. 0.0 ) then + deallocate(HGT) + endif endif endif ! end of if do physics condition @@ -2776,7 +3515,7 @@ subroutine Run ( GC, IMPORT, EXPORT, CLOCK, RC ) if(NEED_FRI) then allocate(FRI(IM,JM,LM),stat=STATUS) VERIFY_(STATUS) - FRI = INTDIS + TOPDIS + FRI = INTDIS + TOPDIS end if if(NEED_STN) then @@ -2863,6 +3602,33 @@ subroutine Run ( GC, IMPORT, EXPORT, CLOCK, RC ) + TICU ! Mass-Weighted Temperature Tendency due to Cumulus Friction end if + if (DEBUG_SYNCTQ) then + call MAPL_GetPointer ( GEX(RAD), PTR3D, 'RADLW', RC=STATUS); VERIFY_(STATUS) + if (associated(PTR3D)) call MAPL_MaxMin('RAD: LW ', TDPOLD*DPI + DT*PTR3D) + call MAPL_GetPointer ( GEX(RAD), PTR3D, 'RADLWC', RC=STATUS); VERIFY_(STATUS) + if (associated(PTR3D)) call MAPL_MaxMin('RAD: LWC ', TDPOLD*DPI + DT*PTR3D) + call MAPL_GetPointer ( GEX(RAD), PTR3D, 'RADLWNA', RC=STATUS); VERIFY_(STATUS) + if (associated(PTR3D)) call MAPL_MaxMin('RAD: LWNA', TDPOLD*DPI + DT*PTR3D) + + call MAPL_GetPointer ( GEX(RAD), PTR3D, 'RADSW', RC=STATUS); VERIFY_(STATUS) + if (associated(PTR3D)) call MAPL_MaxMin('RAD: SW ', TDPOLD*DPI + DT*PTR3D) + call MAPL_GetPointer ( GEX(RAD), PTR3D, 'RADSWC', RC=STATUS); VERIFY_(STATUS) + if (associated(PTR3D)) call MAPL_MaxMin('RAD: SWC ', TDPOLD*DPI + DT*PTR3D) + call MAPL_GetPointer ( GEX(RAD), PTR3D, 'RADSWNA', RC=STATUS); VERIFY_(STATUS) + if (associated(PTR3D)) call MAPL_MaxMin('RAD: SWNA', TDPOLD*DPI + DT*PTR3D) + + call MAPL_MaxMin('FRI: INT ', (TDPOLD + DT*INTDIS)*DPI) + call MAPL_MaxMin('FRI: TOP ', (TDPOLD + DT*TOPDIS)*DPI) + + call MAPL_MaxMin('PHYINC: OLD ', (TDPOLD )*DPI) + call MAPL_MaxMin('PHYINC: TIR ', (TDPOLD + DT*TIR )*DPI) + call MAPL_MaxMin('PHYINC: STN ', (TDPOLD + DT*STN )*DPI) + call MAPL_MaxMin('PHYINC: TTN ', (TDPOLD + DT*TTN )*DPI) + call MAPL_MaxMin('PHYINC: FRI ', (TDPOLD + DT*FRI )*DPI) + call MAPL_MaxMin('PHYINC: TIG ', (TDPOLD + DT*TIG )*DPI) + call MAPL_MaxMin('PHYINC: TICU', (TDPOLD + DT*TICU)*DPI) + endif + IF(DO_SPPT) THEN allocate(TFORQS(IM,JM,LM)) TFORQS = T + DT*TOT*DPI @@ -2933,14 +3699,37 @@ subroutine Run ( GC, IMPORT, EXPORT, CLOCK, RC ) if(associated(TIT )) TIT = STN * DPI if(associated(TIF )) TIF = FRI * DPI - ! Compute Total Water Mass Change due to Physics Sources and Sinks - ! ---------------------------------------------------------------- +! Get fill negative export pointers if requested +! ---------------------------------------------- + call MAPL_GetPointer(EXPORT, DQVDT_FILL, 'DQVDT_FILL_PHYS1', RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, DQLLSDT_FILL, 'DQLLSDT_FILL_PHYS1', RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, DQLCNDT_FILL, 'DQLCNDT_FILL_PHYS1', RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, DQILSDT_FILL, 'DQILSDT_FILL_PHYS1', RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, DQICNDT_FILL, 'DQICNDT_FILL_PHYS1', RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, DQRDT_FILL, 'DQRDT_FILL_PHYS1', RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, DQSDT_FILL, 'DQSDT_FILL_PHYS1', RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, DQGDT_FILL, 'DQGDT_FILL_PHYS1', RC=STATUS); VERIFY_(STATUS) + +! Cleanup negative water species +! ------------------------------ + call FILLQ2ZERO( QV , DM, DT=DT, DQDT= DQVDT_FILL, WARNING_LABEL="QV After Physics" , VM=VMG, RC=STATUS); VERIFY_(STATUS) + call FILLQ2ZERO( QLLS , DM, DT=DT, DQDT=DQLLSDT_FILL, WARNING_LABEL="QLLS After Physics", VM=VMG, RC=STATUS); VERIFY_(STATUS) + call FILLQ2ZERO( QLCN , DM, DT=DT, DQDT=DQLCNDT_FILL, WARNING_LABEL="QLCN After Physics", VM=VMG, RC=STATUS); VERIFY_(STATUS) + call FILLQ2ZERO( QILS , DM, DT=DT, DQDT=DQILSDT_FILL, WARNING_LABEL="QILS After Physics", VM=VMG, RC=STATUS); VERIFY_(STATUS) + call FILLQ2ZERO( QICN , DM, DT=DT, DQDT=DQICNDT_FILL, WARNING_LABEL="QICN After Physics", VM=VMG, RC=STATUS); VERIFY_(STATUS) + call FILLQ2ZERO( QRAIN , DM, DT=DT, DQDT= DQRDT_FILL, WARNING_LABEL="QR After Physics" , VM=VMG, RC=STATUS); VERIFY_(STATUS) + call FILLQ2ZERO( QSNOW , DM, DT=DT, DQDT= DQSDT_FILL, WARNING_LABEL="QS After Physics" , VM=VMG, RC=STATUS); VERIFY_(STATUS) + call FILLQ2ZERO( QGRAUPEL, DM, DT=DT, DQDT= DQGDT_FILL, WARNING_LABEL="QG After Physics" , VM=VMG, RC=STATUS); VERIFY_(STATUS) + +! Compute Total Water Mass Change due to Physics Sources and Sinks +! ---------------------------------------------------------------- allocate( DQ(IM,JM,LM) ) DQ = QV+QLLS+QLCN+QILS+QICN+QRAIN+QSNOW+QGRAUPEL - QW if( DPEDT_PHYS ) then - allocate(sumdq(IM,JM)) - allocate( dpe(IM,JM)) + allocate( ple_new(IM,JM,0:LM),STAT=STATUS ) ; VERIFY_(STATUS) + allocate( sumdq(IM,JM) ,STAT=STATUS ) ; VERIFY_(STATUS) + allocate( dpe(IM,JM) ,STAT=STATUS ) ; VERIFY_(STATUS) call ESMF_StateGet (EXPORT, 'TRADV', BUNDLE, RC=STATUS ) VERIFY_(STATUS) @@ -2995,7 +3784,6 @@ subroutine Run ( GC, IMPORT, EXPORT, CLOCK, RC ) deallocate( sumdq ) deallocate( dpe ) deallocate( names ) - deallocate( sumq ) deallocate( ple_new ) else @@ -3015,14 +3803,16 @@ subroutine Run ( GC, IMPORT, EXPORT, CLOCK, RC ) enddo endif - allocate( TDPNEW(IM,JM,LM),stat=STATUS ) - VERIFY_(STATUS) - do L=1,LM - TDPNEW(:,:,L) = ( T(:,:,L) + DT*DTDT(:,:,L)*DPI(:,:,L) ) * ( PLE(:,:,L)-PLE(:,:,L-1) + DT*(DPDT(:,:,L)-DPDT(:,:,L-1)) ) - enddo - DTDT = ( TDPNEW - TDPOLD )/DT - deallocate( TDPNEW ) - deallocate( TDPOLD ) + if( DPEDT_PHYS ) then + allocate( TDPNEW(IM,JM,LM),stat=STATUS ) + VERIFY_(STATUS) + do L=1,LM + TDPNEW(:,:,L) = ( T(:,:,L) + DT*DTDT(:,:,L)*DPI(:,:,L) ) * ( PLE(:,:,L)-PLE(:,:,L-1) + DT*(DPDT(:,:,L)-DPDT(:,:,L-1)) ) + enddo + DTDT = ( TDPNEW - TDPOLD )/DT + deallocate( TDPNEW ) + deallocate( TDPOLD ) + endif if(associated(FTU)) then FTU(:,:,0) = 0.0 @@ -3233,6 +4023,54 @@ subroutine Run ( GC, IMPORT, EXPORT, CLOCK, RC ) end do end if +! QRAIN Tendencies +! ------------- + if(associated(DQRDTPHYINT)) then + DQRDTPHYINT = 0.0 + do L=1,LM + DQRDTPHYINT = DQRDTPHYINT + DQRDTMST(:,:,L)*DM(:,:,L) + end do + end if + + if(associated(DQRDTMSTINT)) then + DQRDTMSTINT = 0.0 + do L=1,LM + DQRDTMSTINT = DQRDTMSTINT + DQRDTMST(:,:,L)*DM(:,:,L) + end do + end if + +! QSNOW Tendencies +! ------------- + if(associated(DQSDTPHYINT)) then + DQSDTPHYINT = 0.0 + do L=1,LM + DQSDTPHYINT = DQSDTPHYINT + DQSDTMST(:,:,L)*DM(:,:,L) + end do + end if + + if(associated(DQSDTMSTINT)) then + DQSDTMSTINT = 0.0 + do L=1,LM + DQSDTMSTINT = DQSDTMSTINT + DQSDTMST(:,:,L)*DM(:,:,L) + end do + end if + +! QGRAUPEL Tendencies +! ------------- + if(associated(DQGDTPHYINT)) then + DQGDTPHYINT = 0.0 + do L=1,LM + DQGDTPHYINT = DQGDTPHYINT + DQGDTMST(:,:,L)*DM(:,:,L) + end do + end if + + if(associated(DQGDTMSTINT)) then + DQGDTMSTINT = 0.0 + do L=1,LM + DQGDTMSTINT = DQGDTMSTINT + DQGDTMST(:,:,L)*DM(:,:,L) + end do + end if + ! OX Tendencies ! ------------- if(associated(DOXDTPHYINT)) then @@ -3252,12 +4090,14 @@ subroutine Run ( GC, IMPORT, EXPORT, CLOCK, RC ) end if if(SYNCTQ.eq.0.) then + call MAPL_GetPointer(GIM(MOIST), DTDT_BL, 'DTDT_BL', alloc = .true. ,RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(GIM(MOIST), DQDT_BL, 'DQDT_BL', alloc = .true. ,RC=STATUS); VERIFY_(STATUS) !- save 'boundary layer' tendencies of Q and T for the convection scheme DQDT_BL = DQVDTTRB DTDT_BL = 0. !- for SCM setup, TIT/TIF are not associated - if( associated(TIF)) DTDT_BL = DTDT_BL + TIF - if( associated(TIT)) DTDT_BL = DTDT_BL + TIT + if( associated(TIF)) DTDT_BL = DTDT_BL + TIF/DPI + if( associated(TIT)) DTDT_BL = DTDT_BL + TIT/DPI endif if(associated(DM )) deallocate(DM ) @@ -3283,12 +4123,13 @@ end subroutine Run !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - subroutine VertInterp(v2,v3,ple,pp,rc) + subroutine VertInterp(v2,v3,ple,pp,positive_definite,rc) real , intent(OUT) :: v2(:,:) real , intent(IN ) :: v3(:,:,:) real , intent(IN ) :: ple(:,:,:) real , intent(IN ) :: pp + logical, optional, intent(IN ) :: positive_definite integer, optional, intent(OUT) :: rc real, dimension(size(v2,1),size(v2,2)) :: al,PT,PB @@ -3333,7 +4174,98 @@ subroutine VertInterp(v2,v3,ple,pp,rc) end where end if + if (present(positive_definite)) then + if (positive_definite) then + where (v2 < tiny(0.0)) + v2 = 0.0 + endwhere + endif + endif + RETURN_(ESMF_SUCCESS) end subroutine VertInterp + subroutine FILLQ2ZERO( Q, MASS, DT, DQDT, WARNING_LABEL, VM, RC ) + + ! New algorithm to fill the negative q values in a mass conserving way. + ! Conservation of TPW was checked. Donifan Barahona + ! Updated from FILLQ2ZERO, avoids the usage of scalars + + real, dimension(:,:,:), intent(inout) :: Q + real, dimension(:,:,:), intent(in) :: MASS + real, optional, intent(in) :: DT + real, optional, pointer, intent(out) :: DQDT(:,:,:) + character(*), optional, intent(in) :: WARNING_LABEL + type( ESMF_VM ), optional,intent(in) :: VM + integer, intent(out) :: RC + ! Locals + real, dimension(:,:), allocatable :: TPW1, TPW2, TPWC + integer :: IM,JM,LM, l + integer :: RANK + integer :: neg_count, total_count, I1D(2) + character(len=ESMF_MAXSTR) :: IAm="FILLQ2ZERO" + integer :: STATUS + + if (PRESENT(WARNING_LABEL) .AND. PRESENT(VM)) then + ! Calculate local statistics + if (any(Q < 0.0)) then + neg_count = count(Q < 0.0) + else + neg_count = 0 + endif + total_count = size(Q) + if (PRESENT(VM)) then + call ESMF_VmGet(VM, localPet=RANK, rc=STATUS) + VERIFY_(STATUS) + call ESMF_VMAllReduce(VM, sendData=[neg_count,total_count], & + recvData=I1D, count=2, & + reduceflag=ESMF_REDUCE_SUM, rc=STATUS) + VERIFY_(STATUS) + if ((RANK==0) .AND. (I1D(1)>0) .AND. (I1D(2)>0)) & + write(*,'(A,A,A,/,2X,A,I0,A,I0,A,F5.1,A)') & + 'WARNING: Negative values filled in ', trim(WARNING_LABEL), ':', & + 'Count: ', I1D(1), '/', I1D(2), ' (', & + (real(I1D(1))/real(I1D(2)))*100.0, '%)' + endif + endif + + IM = SIZE( Q, 1 ) + JM = SIZE( Q, 2 ) + LM = SIZE( Q, 3 ) + + ALLOCATE(TPW1(IM, JM)) + ALLOCATE(TPW2(IM, JM)) + ALLOCATE(TPWC(IM, JM)) + + TPW2 =0.0 + TPWC= 0.0 + TPW1 = SUM( Q*MASS, 3 ) + + if (PRESENT(DQDT) .AND. PRESENT(DT)) then + if (ASSOCIATED(DQDT)) DQDT = Q + endif + + WHERE (Q < 1.e-15) + Q=1.e-15 + END WHERE + + TPW2 = SUM( Q*MASS, 3 ) + + WHERE (TPW2 > 1.e-15) + TPWC=(TPW2-TPW1)/TPW2 + END WHERE + + do l=1,LM + Q(:, :, l)= Q(:, :, l)*(1.0-TPWC) !reduce Q proportionally to the increase in TPW + end do + + if (PRESENT(DQDT) .AND. PRESENT(DT)) then + if (ASSOCIATED(DQDT)) DQDT = (Q - DQDT)/DT + endif + + DEALLOCATE(TPW1) + DEALLOCATE(TPW2) + DEALLOCATE(TPWC) + end subroutine FILLQ2ZERO + end module GEOS_PhysicsGridCompMod diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSgwd_GridComp/GEOS_GwdGridComp.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSgwd_GridComp/GEOS_GwdGridComp.F90 index 60d0f8f41..547dbae94 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSgwd_GridComp/GEOS_GwdGridComp.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSgwd_GridComp/GEOS_GwdGridComp.F90 @@ -68,7 +68,7 @@ module GEOS_GwdGridCompMod real :: TAU1 real :: H0 real :: HH - real, allocatable :: alpha(:) + real, allocatable :: alpha(:) type(ThreadWorkspace), allocatable :: workspaces(:) end type GEOS_GwdGridComp @@ -76,7 +76,7 @@ module GEOS_GwdGridCompMod type (GEOS_GwdGridComp), pointer :: PTR end type wrap_ - !logical, save :: FIRST_RUN = .true. + logical :: DEBUG_GWD contains @@ -113,7 +113,7 @@ subroutine SetServices ( GC, RC ) type (ESMF_Config) :: myCF type (wrap_) :: wrap - type (GEOS_GwdGridComp), pointer :: self + type (GEOS_GwdGridComp), pointer :: self integer :: num_threads ! Begin... @@ -148,6 +148,10 @@ subroutine SetServices ( GC, RC ) call MAPL%set_use_threads(use_threads) call ESMF_ConfigDestroy(myCF, _RC) + ! We need to get NCAR_NRDG because this is used in the GWD_Internal___.h auto-generated + ! code via the MAPL ACG + call MAPL_GetResource( MAPL, self%NCAR_NRDG, Label="NCAR_NRDG:", default=0, _RC) + ! Set the state variable specs. ! ----------------------------- #include "GWD_Import___.h" @@ -234,24 +238,26 @@ subroutine Initialize ( GC, IMPORT, EXPORT, CLOCK, RC ) character(len=ESMF_MAXPATHLEN) :: BERES_FILE_NAME character(len=ESMF_MAXSTR) :: ERRstring - logical :: JASON_BKG, JASON_ORO - logical :: NCAR_TAU_TOP_ZERO - real :: NCAR_PRNDL - real :: NCAR_QBO_HDEPTH_SCALING - integer :: NCAR_ORO_PGWV, NCAR_BKG_PGWV - real :: NCAR_ORO_GW_DC, NCAR_BKG_GW_DC - real :: NCAR_ORO_FCRIT2, NCAR_BKG_FCRIT2 - real :: NCAR_ORO_WAVELENGTH, NCAR_BKG_WAVELENGTH - real :: NCAR_ORO_SOUTH_FAC - real :: NCAR_ORO_TNDMAX - real :: NCAR_BKG_TNDMAX - real :: NCAR_HR_CF ! Grid cell convective conversion factor - real :: NCAR_ET_TAUBGND ! Extratropical background frontal forcing - logical :: NCAR_ET_USELATS - logical :: NCAR_DC_BERES - integer :: GEOS_PGWV - real :: NCAR_EFFGWBKG - real :: NCAR_DC_BERES_SRC_LEVEL + logical :: JASON_BKG, JASON_ORO + real :: NCAR_TAU_TOP_ZERO + real :: NCAR_PRNDL + real :: NCAR_QBO_HDEPTH_SCALING + integer :: NCAR_ORO_PGWV, NCAR_BKG_PGWV + real :: NCAR_ORO_GW_DC, NCAR_BKG_GW_DC + real :: NCAR_ORO_FCRIT2, NCAR_BKG_FCRIT2 + real :: NCAR_ORO_WAVELENGTH, NCAR_BKG_WAVELENGTH + real :: NCAR_ORO_SOUTH_FAC + real :: NCAR_ORO_TNDMAX + real :: NCAR_BKG_TNDMAX + real :: NCAR_HR_CF ! Grid cell convective conversion factor + real :: NCAR_TR_EFF ! Convective region efficiency factor + real :: NCAR_ET_EFF ! Frontal region efficiency factor + real :: NCAR_ET_TAUBGND ! Extratropical background frontal forcing + logical :: NCAR_ET_USE_DQCDT + logical :: NCAR_DC_BERES + integer :: GEOS_PGWV + real :: NCAR_EFFGWBKG + real :: NCAR_DC_BERES_SRC_LEVEL type (wrap_) :: wrap type (GEOS_GwdGridComp), pointer :: self @@ -304,20 +310,20 @@ subroutine Initialize ( GC, IMPORT, EXPORT, CLOCK, RC ) ! ---------------------------- call MAPL_GetResource(MAPL,JASON_BKG,'JASON_BKG:', default=(LM==72), _RC) if (JASON_BKG) then - GEOS_PGWV = 4 - call MAPL_GetResource( MAPL, self%GEOS_PGWV, Label="GEOS_PGWV:", default=GEOS_PGWV, _RC) - call MAPL_GetResource( MAPL, self%GEOS_BGSTRESS, Label="GEOS_BGSTRESS:", default=0.900, _RC) - call MAPL_GetResource( MAPL, self%GEOS_EFFGWBKG, Label="GEOS_EFFGWBKG:", default=0.125, _RC) - call MAPL_GetResource( MAPL, self%NCAR_EFFGWBKG, Label="NCAR_EFFGWBKG:", default=0.000, _RC) - call MAPL_GetResource( MAPL, self%TAU1, Label="RAYLEIGH_TAU1:", default=172800., _RC) + GEOS_PGWV = 4 + call MAPL_GetResource( MAPL, self%GEOS_PGWV, Label="GEOS_PGWV:", default=GEOS_PGWV, _RC) + call MAPL_GetResource( MAPL, self%GEOS_BGSTRESS, Label="GEOS_BGSTRESS:", default=0.900, _RC) + call MAPL_GetResource( MAPL, self%GEOS_EFFGWBKG, Label="GEOS_EFFGWBKG:", default=0.125, _RC) + call MAPL_GetResource( MAPL, self%NCAR_EFFGWBKG, Label="NCAR_EFFGWBKG:", default=0.000, _RC) + !! call MAPL_GetResource( MAPL, self%TAU1, Label="RAYLEIGH_TAU1:", default=172800., _RC) + call MAPL_GetResource( MAPL, self%TAU1, Label="RAYLEIGH_TAU1:", default=0.000, _RC) else - GEOS_PGWV = NINT(32*LM/181.0) - call MAPL_GetResource( MAPL, self%GEOS_PGWV, Label="GEOS_PGWV:", default=GEOS_PGWV, _RC) - call MAPL_GetResource( MAPL, self%GEOS_BGSTRESS, Label="GEOS_BGSTRESS:", default=0.000, _RC) - call MAPL_GetResource( MAPL, self%GEOS_EFFGWBKG, Label="GEOS_EFFGWBKG:", default=0.000, _RC) - self%NCAR_EFFGWBKG = 1.0 !(1.0 - 0.5*sigma) - call MAPL_GetResource( MAPL, self%NCAR_EFFGWBKG, Label="NCAR_EFFGWBKG:", default=self%NCAR_EFFGWBKG, _RC) - call MAPL_GetResource( MAPL, self%TAU1, Label="RAYLEIGH_TAU1:", default=0.00, _RC) + GEOS_PGWV = NINT(32*LM/181.0) + call MAPL_GetResource( MAPL, self%GEOS_PGWV, Label="GEOS_PGWV:", default=GEOS_PGWV, _RC) + call MAPL_GetResource( MAPL, self%GEOS_BGSTRESS, Label="GEOS_BGSTRESS:", default=0.000 , _RC) + call MAPL_GetResource( MAPL, self%GEOS_EFFGWBKG, Label="GEOS_EFFGWBKG:", default=0.000 , _RC) + call MAPL_GetResource( MAPL, self%NCAR_EFFGWBKG, Label="NCAR_EFFGWBKG:", default=0.400 , _RC) + call MAPL_GetResource( MAPL, self%TAU1, Label="RAYLEIGH_TAU1:", default=0.000 , _RC) endif ! Orographic Gravity wave drag @@ -327,10 +333,14 @@ subroutine Initialize ( GC, IMPORT, EXPORT, CLOCK, RC ) call MAPL_GetResource( MAPL, self%GEOS_EFFGWORO, Label="GEOS_EFFGWORO:", default=0.250, _RC) call MAPL_GetResource( MAPL, self%NCAR_EFFGWORO, Label="NCAR_EFFGWORO:", default=0.000, _RC) call MAPL_GetResource( MAPL, self%NCAR_NRDG, Label="NCAR_NRDG:", default=0, _RC) - else - call MAPL_GetResource( MAPL, self%GEOS_EFFGWORO, Label="GEOS_EFFGWORO:", default=0.000, _RC) - call MAPL_GetResource( MAPL, self%NCAR_EFFGWORO, Label="NCAR_EFFGWORO:", default=1.000, _RC) - call MAPL_GetResource( MAPL, self%NCAR_NRDG, Label="NCAR_NRDG:", default=16, _RC) + else + call MAPL_GetResource( MAPL, self%GEOS_EFFGWORO, Label="GEOS_EFFGWORO:", default=0.000, _RC) + call MAPL_GetResource( MAPL, self%NCAR_NRDG, Label="NCAR_NRDG:", default=0, _RC) ! use 0 [1:16] to disable [enable] ridge scheme + if (self%NCAR_NRDG == 16) then + call MAPL_GetResource( MAPL, self%NCAR_EFFGWORO, Label="NCAR_EFFGWORO:", default=1.000, _RC) + else + call MAPL_GetResource( MAPL, self%NCAR_EFFGWORO, Label="NCAR_EFFGWORO:", default=0.250, _RC) + endif endif ! Rayleigh friction @@ -341,13 +351,13 @@ subroutine Initialize ( GC, IMPORT, EXPORT, CLOCK, RC ) call MAPL_GetResource( MAPL, self%HH, Label="RAYLEIGH_HH:", default=7500., _RC) endif - ! NCAR GWD settings - ! ----------------- - call MAPL_GetResource( MAPL, NCAR_TAU_TOP_ZERO, Label="NCAR_TAU_TOP_ZERO:", default=.true., _RC) +! NCAR GWD settings +! ----------------- + call MAPL_GetResource( MAPL, NCAR_TAU_TOP_ZERO, Label="NCAR_TAU_TOP_ZERO:", default=35.0, _RC) ! 0.35 hPa call MAPL_GetResource( MAPL, NCAR_PRNDL, Label="NCAR_PRNDL:", default=0.50, _RC) - NCAR_QBO_HDEPTH_SCALING = 1.0 - 0.25*sigma + NCAR_QBO_HDEPTH_SCALING = 1.0 - 0.75*sigma call MAPL_GetResource( MAPL, NCAR_QBO_HDEPTH_SCALING, Label="NCAR_QBO_HDEPTH_SCALING:", default=NCAR_QBO_HDEPTH_SCALING, _RC) - NCAR_HR_CF = CEILING(30.0*sigma) + NCAR_HR_CF = CEILING(20.0*sigma) call MAPL_GetResource( MAPL, NCAR_HR_CF, Label="NCAR_HR_CF:", default=NCAR_HR_CF, _RC) call gw_common_init( NCAR_TAU_TOP_ZERO , 1 , & @@ -363,9 +373,11 @@ subroutine Initialize ( GC, IMPORT, EXPORT, CLOCK, RC ) call MAPL_GetResource( MAPL, NCAR_BKG_GW_DC, Label="NCAR_BKG_GW_DC:", default=2.5, _RC) call MAPL_GetResource( MAPL, NCAR_BKG_FCRIT2, Label="NCAR_BKG_FCRIT2:", default=1.0, _RC) call MAPL_GetResource( MAPL, NCAR_BKG_WAVELENGTH, Label="NCAR_BKG_WAVELENGTH:", default=1.e5, _RC) - call MAPL_GetResource( MAPL, NCAR_ET_TAUBGND, Label="NCAR_ET_TAUBGND:", default=3.2, _RC) - call MAPL_GetResource( MAPL, NCAR_ET_USELATS, Label="NCAR_ET_USELATS:", default=.TRUE., _RC) - call MAPL_GetResource( MAPL, NCAR_BKG_TNDMAX, Label="NCAR_BKG_TNDMAX:", default=800.0, _RC) + call MAPL_GetResource( MAPL, NCAR_TR_EFF, Label="NCAR_TR_EFF:", default=1.0, _RC) + call MAPL_GetResource( MAPL, NCAR_ET_EFF, Label="NCAR_ET_EFF:", default=1.0, _RC) + call MAPL_GetResource( MAPL, NCAR_ET_TAUBGND, Label="NCAR_ET_TAUBGND:", default=6.4, _RC) + call MAPL_GetResource( MAPL, NCAR_ET_USE_DQCDT, Label="NCAR_ET_USE_DQCDT:", default=.FALSE., _RC) + call MAPL_GetResource( MAPL, NCAR_BKG_TNDMAX, Label="NCAR_BKG_TNDMAX:", default=250.0, _RC) NCAR_BKG_TNDMAX = NCAR_BKG_TNDMAX/86400.0 ! Beres DeepCu call MAPL_GetResource( MAPL, NCAR_DC_BERES_SRC_LEVEL, "NCAR_DC_BERES_SRC_LEVEL:", DEFAULT=70000.0, _RC) @@ -373,38 +385,44 @@ subroutine Initialize ( GC, IMPORT, EXPORT, CLOCK, RC ) num_threads = MAPL_get_num_threads() bounds = MAPL_find_bounds(JM, num_threads) do thread = 0, num_threads-1 - JM_thread = bounds(thread+1)%max - bounds(thread+1)%min + 1 - call gw_beres_init( BERES_FILE_NAME , & - self%workspaces(thread)%beres_band, & - self%workspaces(thread)%beres_dc_desc, & - NCAR_BKG_PGWV, NCAR_BKG_GW_DC, NCAR_BKG_FCRIT2, & - NCAR_BKG_WAVELENGTH, NCAR_DC_BERES_SRC_LEVEL, & - 1000.0, .TRUE., NCAR_ET_TAUBGND, NCAR_ET_USELATS, NCAR_BKG_TNDMAX, NCAR_DC_BERES, & - IM*JM_thread, LATS(:,bounds(thread+1)%min:bounds(thread+1)%max)) + JM_thread = bounds(thread+1)%max - bounds(thread+1)%min + 1 + call gw_beres_init( BERES_FILE_NAME , & + self%workspaces(thread)%beres_band, & + self%workspaces(thread)%beres_dc_desc, & + NCAR_BKG_PGWV, NCAR_BKG_GW_DC, NCAR_BKG_FCRIT2, & + NCAR_BKG_WAVELENGTH, NCAR_DC_BERES_SRC_LEVEL, & + 1000.0, .TRUE., NCAR_TR_EFF, NCAR_ET_EFF, NCAR_ET_TAUBGND, NCAR_ET_USE_DQCDT, & + NCAR_BKG_TNDMAX, NCAR_DC_BERES, & + IM*JM_thread, LATS(:,bounds(thread+1)%min:bounds(thread+1)%max)) end do ! Orographic Scheme call MAPL_GetResource( MAPL, NCAR_ORO_PGWV, Label="NCAR_ORO_PGWV:", default=0, _RC) call MAPL_GetResource( MAPL, NCAR_ORO_GW_DC, Label="NCAR_ORO_GW_DC:", default=2.5, _RC) - call MAPL_GetResource( MAPL, NCAR_ORO_FCRIT2, Label="NCAR_ORO_FCRIT2:", default=1.0, _RC) call MAPL_GetResource( MAPL, NCAR_ORO_WAVELENGTH, Label="NCAR_ORO_WAVELENGTH:", default=1.e5, _RC) if (self%NCAR_NRDG > 0) then - ! Ridge Scheme - call MAPL_GetResource( MAPL, NCAR_ORO_TNDMAX, Label="NCAR_ORO_TNDMAX:", default=400.0, _RC) - NCAR_ORO_TNDMAX = NCAR_ORO_TNDMAX/86400.0 - do thread = 0, num_threads-1 - call gw_rdg_init ( self%workspaces(thread)%rdg_band, NCAR_ORO_GW_DC, NCAR_ORO_FCRIT2, NCAR_ORO_WAVELENGTH, NCAR_ORO_TNDMAX, NCAR_ORO_PGWV ) - end do + call MAPL_GetResource( MAPL, NCAR_ORO_FCRIT2, Label="NCAR_ORO_FCRIT2:", default=1.0, _RC) + call MAPL_GetResource( MAPL, NCAR_ORO_TNDMAX, Label="NCAR_ORO_TNDMAX:", default=400.0,_RC) + NCAR_ORO_TNDMAX = NCAR_ORO_TNDMAX/86400.0 + ! Ridge Scheme + do thread = 0, num_threads-1 + call gw_rdg_init ( self%workspaces(thread)%rdg_band, NCAR_ORO_GW_DC, NCAR_ORO_FCRIT2, NCAR_ORO_WAVELENGTH, NCAR_ORO_TNDMAX, NCAR_ORO_PGWV ) + end do else - ! Old Scheme - call MAPL_GetResource( MAPL, NCAR_ORO_SOUTH_FAC, Label="NCAR_ORO_SOUTH_FAC:", default=2.0, _RC) - do thread = 0, num_threads-1 - call gw_oro_init ( self%workspaces(thread)%oro_band, NCAR_ORO_GW_DC, & - NCAR_ORO_FCRIT2, NCAR_ORO_WAVELENGTH, NCAR_ORO_PGWV, & - NCAR_ORO_SOUTH_FAC ) - end do + ! Old Scheme + call MAPL_GetResource( MAPL, NCAR_ORO_FCRIT2, Label="NCAR_ORO_FCRIT2:", default=0.5, _RC) + call MAPL_GetResource( MAPL, NCAR_ORO_SOUTH_FAC, Label="NCAR_ORO_SOUTH_FAC:", default=1.0, _RC) + call MAPL_GetResource( MAPL, NCAR_ORO_TNDMAX, Label="NCAR_ORO_TNDMAX:", default=400.0, _RC) + NCAR_ORO_TNDMAX = NCAR_ORO_TNDMAX/86400.0 + do thread = 0, num_threads-1 + call gw_oro_init ( self%workspaces(thread)%oro_band, NCAR_ORO_GW_DC, & + NCAR_ORO_FCRIT2, NCAR_ORO_WAVELENGTH, NCAR_ORO_PGWV, & + NCAR_ORO_SOUTH_FAC, NCAR_ORO_TNDMAX ) + end do endif + call MAPL_GetResource( MAPL, DEBUG_GWD, Label="DEBUG_GWD:", default=.FALSE., _RC) + allocate(self%alpha(LM+1), _STAT) call MAPL_GetPointer( IMPORT, PREF, 'PREF', _RC ) call gw_newtonian_set(LM, PREF, self%alpha) @@ -448,13 +466,14 @@ subroutine RUN ( GC, IMPORT, EXPORT, CLOCK, RC ) type (ESMF_Alarm ) :: ALARM type (ESMF_Grid ) :: ESMFGRID + integer :: I, J, L integer :: IM, JM, LM !integer :: pgwv real :: tcrib !real :: effgworo, effgwbkg !real :: CDMBGWD1, CDMBGWD2 !real :: bgstressmax - real, pointer, dimension(:,:) :: LATS + real, pointer, dimension(:,:) :: LONS, LATS ! Rayleigh friction parameters @@ -502,7 +521,7 @@ subroutine RUN ( GC, IMPORT, EXPORT, CLOCK, RC ) call MAPL_Get(MAPL, & IM=IM, JM=JM, LM=LM, & - RUNALARM=ALARM, LATS=LATS, & + RUNALARM=ALARM, LONS=LONS, LATS=LATS, & _RC ) ! If its time, recalculate the GWD tendency @@ -534,126 +553,106 @@ subroutine Gwd_Driver(RC) type (ESMF_TimeInterval) :: TINT #include "GWD_DeclarePointer___.h" - - real, pointer, dimension(:,:,:) :: TMP3D - real, pointer, dimension(:,:) :: TMP2D - - ! local variables - - real, dimension(IM,JM,LM ) :: DQCDT_LS - real, dimension(IM,JM,LM ) :: ZM, PMID, PDEL, RPDEL, PMLN - real, dimension(IM,JM ) :: a2, Hefold - real, dimension(IM,JM,LM ) :: DUDT_ORG, DVDT_ORG, DTDT_ORG - real, dimension(IM,JM,LM ) :: DUDT_GWD, DVDT_GWD, DTDT_GWD - real, dimension(IM,JM,LM ) :: DUDT_RAH, DVDT_RAH, DTDT_RAH - real, dimension(IM,JM,LM ) :: DUDT_TOT, DVDT_TOT, DTDT_TOT - real, dimension(IM,JM,LM+1) :: PILN, ZI - real, dimension( LM ) :: ZREF, KRAY - real, dimension(IM,JM ) :: GBXAR_TMP - real, dimension(IM,JM ) :: TAUXO_TMP, TAUYO_TMP - real, dimension(IM,JM ) :: TAUXB_TMP, TAUYB_TMP - real, dimension(IM,JM,LM+1) :: TAUXO_3D , TAUYO_3D , FEO_3D, FEPO_3D - real, dimension(IM,JM,LM+1) :: TAUXB_3D , TAUYB_3D , FEB_3D, FEPB_3D - real, dimension(IM,JM,LM ) :: DUBKGSRC , DVBKGSRC , DTBKGSRC - real, dimension(IM,JM) :: KEGWD_X, KEORO_X, KERAY_X, KEBKG_X, KERES_X - real, dimension(IM,JM) :: PEGWD_X, PEORO_X, PERAY_X, PEBKG_X, BKGERR_X - - real, dimension(IM,JM,LM ) :: DUDT_GWD_GEOS , DVDT_GWD_GEOS , DTDT_GWD_GEOS - real, dimension(IM,JM,LM ) :: DUDT_ORG_GEOS , DVDT_ORG_GEOS , DTDT_ORG_GEOS - real, dimension(IM,JM ) :: TAUXB_TMP_GEOS, TAUYB_TMP_GEOS - real, dimension(IM,JM ) :: TAUXO_TMP_GEOS, TAUYO_TMP_GEOS - - real, dimension(IM,JM,LM ) :: DUDT_GWD_NCAR , DVDT_GWD_NCAR , DTDT_GWD_NCAR - real, dimension(IM,JM,LM ) :: DUDT_ORG_NCAR , DVDT_ORG_NCAR , DTDT_ORG_NCAR - real, dimension(IM,JM ) :: TAUXB_TMP_NCAR, TAUYB_TMP_NCAR - real, dimension(IM,JM ) :: TAUXO_TMP_NCAR, TAUYO_TMP_NCAR - - integer :: J, K, L, nrdg, ikpbl - real(ESMF_KIND_R8) :: DT_R8 - real :: DT ! time interval in sec - real :: a1, wsp, var_temp - !real, allocatable :: THV(:,:,:) - real :: THV(IM,JM,LM) - - integer :: I,IRUN - type (ESMF_State) :: INTERNAL - - ! Begin... - !---------- - - IAm = "Gwd_Driver" - - ! Get time step - !------------------------------------------------- - - call ESMF_AlarmGet( ALARM, ringInterval=TINT, _RC) - call ESMF_TimeIntervalGet(TINT, S_R8=DT_R8, _RC) - - DT = DT_R8 - - ! Pointers to import, export and internal variables - call MAPL_Get(MAPL, INTERNAL_ESMF_STATE=INTERNAL, _RC) + + real, pointer, dimension(:,:,:) :: PTR3D + real, pointer, dimension(:,:) :: PTR2D + +! local variables + + real, dimension(IM,JM,LM ) :: TMP3D + real, dimension(IM,JM,LM ) :: ZM, PMID, PDEL, RPDEL, PMLN + real, dimension(IM,JM ) :: a2, Hefold + real, dimension(IM,JM,LM ) :: DUDT_ORG, DVDT_ORG, DTDT_ORG + real, dimension(IM,JM,LM ) :: DUDT_GWD, DVDT_GWD, DTDT_GWD + real, dimension(IM,JM,LM ) :: DUDT_RAH, DVDT_RAH, DTDT_RAH + real, dimension(IM,JM,LM ) :: DUDT_TOT, DVDT_TOT, DTDT_TOT + real, dimension(IM,JM,LM+1) :: PILN, ZI + real, dimension( LM ) :: ZREF, KRAY + real, dimension(IM,JM ) :: GBXAR_TMP + real, dimension(IM,JM ) :: TAUXO_TMP, TAUYO_TMP + real, dimension(IM,JM ) :: TAUXB_TMP, TAUYB_TMP + real, dimension(IM,JM,LM+1) :: TAUXO_3D , TAUYO_3D , FEO_3D, FEPO_3D + real, dimension(IM,JM,LM+1) :: TAUXB_3D , TAUYB_3D , FEB_3D, FEPB_3D + real, dimension(IM,JM,LM ) :: DUBKGSRC , DVBKGSRC , DTBKGSRC + real, dimension(IM,JM) :: KEGWD_X, KEORO_X, KERAY_X, KEBKG_X, KERES_X + real, dimension(IM,JM) :: PEGWD_X, PEORO_X, PERAY_X, PEBKG_X, BKGERR_X + + real, dimension(IM,JM,LM ) :: DUDT_GWD_GEOS , DVDT_GWD_GEOS , DTDT_GWD_GEOS + real, dimension(IM,JM,LM ) :: DUDT_ORG_GEOS , DVDT_ORG_GEOS , DTDT_ORG_GEOS + real, dimension(IM,JM ) :: TAUXB_TMP_GEOS, TAUYB_TMP_GEOS + real, dimension(IM,JM ) :: TAUXO_TMP_GEOS, TAUYO_TMP_GEOS + + real, dimension(IM,JM,LM ) :: DUDT_GWD_NCAR , DVDT_GWD_NCAR , DTDT_GWD_NCAR + real, dimension(IM,JM,LM ) :: DUDT_ORG_NCAR , DVDT_ORG_NCAR , DTDT_ORG_NCAR + real, dimension(IM,JM ) :: TAUXB_TMP_NCAR, TAUYB_TMP_NCAR + real, dimension(IM,JM ) :: TAUXO_TMP_NCAR, TAUYO_TMP_NCAR + + REAL, ALLOCATABLE, TARGET, DIMENSION(:,:,:) :: scratch_ridge + + integer :: J, K, L, nrdg, ikpbl + real(ESMF_KIND_R8) :: DT_R8 + real :: DT ! time interval in sec + real :: a1, wsp, var_temp + + integer :: I,IRUN + type (ESMF_State) :: INTERNAL + +! Begin... +!---------- + + IAm = "Gwd_Driver" + +! Get time step +!------------------------------------------------- + + call ESMF_AlarmGet( ALARM, ringInterval=TINT, _RC) + call ESMF_TimeIntervalGet(TINT, S_R8=DT_R8, _RC) + + DT = DT_R8 + + ! Pointers to import, export and internal variables + call MAPL_Get(MAPL, INTERNAL_ESMF_STATE=INTERNAL, _RC) #include "GWD_GetPointer___.h" - CALL PREGEO(IM*JM, LM, & - PLE, LATS, PMID, PDEL, RPDEL, PILN, PMLN) - - ! Compute ZM - !------------- - - call GEOPOTENTIAL( IM*JM, LM, & - PILN, PMLN, PLE, PMID, PDEL, RPDEL, & - T, Q, ZI, ZM ) - - ! Do gravity wave drag calculations on a list of soundings - !--------------------------------------------------------- - - !call MAPL_TimerOn(MAPL,"-INTR") - - GBXAR_TMP = GBXAR * (MAPL_RADIUS/1000.)**2 ! transform to km^2 - WHERE (ANGLL < -180) - ANGLL = 0.0 - END WHERE - - do nrdg = 1, self%NCAR_NRDG - KWVRDG(:,:,nrdg) = 0.001/(HWDTH(:,:,nrdg)+0.001) - EFFRDG(:,:,nrdg) = self%NCAR_EFFGWORO*(HWDTH(:,:,nrdg)*CLNGT(:,:,nrdg))/GBXAR_TMP - enddo - - ! if (FIRST_RUN) then - ! FIRST_RUN = .false. - ! call gw_newtonian_set(LM, PREF) - !!#ifdef DEBUG_GWD - ! if (self%NCAR_NRDG > 0) then - ! IF (MAPL_AM_I_ROOT()) write(*,*) 'GWD internal state: ' - ! call Write_Profile(GBXAR_TMP, AREA, ESMFGRID, 'GBXAR') - ! do nrdg = 1, self%NCAR_NRDG - ! IF (MAPL_AM_I_ROOT()) write(*,*) 'NRDG: ', nrdg - ! call Write_Profile(MXDIS(:,:,nrdg), AREA, ESMFGRID, 'MXDIS') - ! call Write_Profile(ANGLL(:,:,nrdg), AREA, ESMFGRID, 'ANGLL') - ! call Write_Profile(ANIXY(:,:,nrdg), AREA, ESMFGRID, 'ANIXY') - ! call Write_Profile(CLNGT(:,:,nrdg), AREA, ESMFGRID, 'CLNGT') - ! call Write_Profile(HWDTH(:,:,nrdg), AREA, ESMFGRID, 'HWDTH') - ! call Write_Profile(KWVRDG(:,:,nrdg), AREA, ESMFGRID, 'KWVRDG') - ! call Write_Profile(EFFRDG(:,:,nrdg), AREA, ESMFGRID, 'EFFRDG') - ! enddo - ! endif - !!#endif - ! endif - - ! pchakrab: Redundant code? Commenting out. - ! call MAPL_GetPointer(EXPORT, TMP2D, 'RDG1_MXDIS', _RC) - ! if(associated(TMP2D)) TMP2D = MXDIS(:,:,1) - ! call MAPL_GetPointer(EXPORT, TMP2D, 'RDG1_HWDTH', _RC) - ! if(associated(TMP2D)) TMP2D = HWDTH(:,:,1) - ! call MAPL_GetPointer(EXPORT, TMP2D, 'RDG1_CLNGT', _RC) - ! if(associated(TMP2D)) TMP2D = CLNGT(:,:,1) - ! call MAPL_GetPointer(EXPORT, TMP2D, 'RDG1_ANGLL', _RC) - ! if(associated(TMP2D)) TMP2D = ANGLL(:,:,1) - ! call MAPL_GetPointer(EXPORT, TMP2D, 'RDG1_ANIXY', _RC) - ! if(associated(TMP2D)) TMP2D = ANIXY(:,:,1) - ! call MAPL_GetPointer(EXPORT, TMP2D, 'RDG1_GBXAR', _RC) - ! if(associated(TMP2D)) TMP2D = GBXAR_TMP + CALL PREGEO(IM*JM, LM, & + PLE, LATS, PMID, PDEL, RPDEL, PILN, PMLN) + +! Compute ZM +!------------- + + call GEOPOTENTIAL( IM*JM, LM, & + PILN, PMLN, PLE, PMID, PDEL, RPDEL, & + T, Q, ZI, ZM ) + +! Do gravity wave drag calculations on a list of soundings +!--------------------------------------------------------- + + if (self%NCAR_NRDG /= 0.0) then + + GBXAR_TMP = GBXAR * (MAPL_RADIUS/1000.)**2 ! transform to km^2 + WHERE (ANGLL < -180) + ANGLL = 0.0 + END WHERE + + do nrdg = 1, self%NCAR_NRDG + KWVRDG(:,:,nrdg) = 0.001/(HWDTH(:,:,nrdg)+0.001) + EFFRDG(:,:,nrdg) = self%NCAR_EFFGWORO*(HWDTH(:,:,nrdg)*CLNGT(:,:,nrdg))/GBXAR_TMP + enddo + + else + + allocate ( scratch_ridge(IM,JM,16) ) + scratch_ridge = 0.0 + MXDIS => scratch_ridge + HWDTH => scratch_ridge + CLNGT => scratch_ridge + ANGLL => scratch_ridge + ANIXY => scratch_ridge + KWVRDG => scratch_ridge + EFFRDG => scratch_ridge + GBXAR_TMP = 0.0 + + endif ! Use new NCAR code convective+oro (excludes extratropical bkg sources) DUDT_GWD_NCAR = 0.0 @@ -669,15 +668,16 @@ subroutine Gwd_Driver(RC) !call MAPL_TimerOn(MAPL,"-INTR_NCAR") if ( (self%NCAR_EFFGWORO /= 0.0) .OR. (self%NCAR_EFFGWBKG /= 0.0) ) then DO L=1, LM - DQCDT_LS(:,:,L) = (1.0-CNV_FRC)*(DQLDT(:,:,L)+DQIDT(:,:,L)) + TMP3D(:,:,L) = (1.0-CNV_FRC)*(DQLDT(:,:,L)+DQIDT(:,:,L)) END DO + if(associated(DQCDT_LS)) DQCDT_LS = TMP3D thread = MAPL_get_current_thread() workspace => self%workspaces(thread) call gw_intr_ncar(IM*JM, LM, DT, self%NCAR_NRDG, & workspace%beres_dc_desc, & workspace%beres_band, workspace%oro_band, workspace%rdg_band, & PLE, T, U, V, & - HT_dc, DQCDT_LS, & + HT_dc, TMP3D, & SGH, MXDIS, HWDTH, CLNGT, ANGLL, & ANIXY, GBXAR_TMP, KWVRDG, EFFRDG, PREF, & PMID, PDEL, RPDEL, PILN, ZM, LATS, & @@ -747,7 +747,7 @@ subroutine Gwd_Driver(RC) DUDT_ORG, & DVDT_ORG, & DTDT_ORG, & - + DUDT_TOT, & DVDT_TOT, & DTDT_TOT, & @@ -815,22 +815,53 @@ subroutine Gwd_Driver(RC) !----------------------------- if(associated(TTMGW )) TTMGW = DTDT_TOT - ! Fille additional exports - !------------------------- - if(associated( Q_EXP )) Q_EXP = Q - if(associated( U_EXP )) U_EXP = U + DUDT_TOT*DT - if(associated( V_EXP )) V_EXP = V + DVDT_TOT*DT - if(associated( T_EXP )) T_EXP = T + DTDT_TOT*DT - if(associated( PREF_EXP )) PREF_EXP = PREF - if(associated( SGH_EXP )) SGH_EXP = SGH - if(associated( PLE_EXP )) PLE_EXP = PLE - - ! All done - !----------- - RETURN_(ESMF_SUCCESS) - end subroutine GWD_DRIVER - - end subroutine RUN +! Fill additional exports +!------------------------- + if(associated( Q_EXP )) Q_EXP = Q + if(associated( U_EXP )) U_EXP = U + DUDT_TOT*DT + if(associated( V_EXP )) V_EXP = V + DVDT_TOT*DT + if(associated( T_EXP )) T_EXP = T + DTDT_TOT*DT + if(associated( PREF_EXP )) PREF_EXP = PREF + if(associated( SGH_EXP )) SGH_EXP = SGH + if(associated( PLE_EXP )) PLE_EXP = PLE + + if (DEBUG_GWD) then + if(associated( T_EXP )) call MAPL_MaxMin('GWD: T_AF_GWD ', T_EXP) + if(associated( U_EXP )) call MAPL_MaxMin('GWD: U_AF_GWD ', U_EXP) + if(associated( V_EXP )) call MAPL_MaxMin('GWD: V_AF_GWD ', V_EXP) + endif + + if (allocated(scratch_ridge)) deallocate(scratch_ridge) + + if(associated( T_EXP )) then + do L=1,LM + do J=1,JM + do I=1,IM + if (T_EXP(I,J,L) > 333.0) then + print *, "Temperature spike detected : ", T_EXP(I,J,L) + print *, " GWD TOT Temp Increment : ", DTDT_GWD(I,J,L)*DT + print *, " GWD ORO Temp Increment : ", DTDT_ORG(I,J,L)*DT + print *, " GWD BKG Temp Increment : ", (DTDT_GWD(I,J,L)-DTDT_ORG(I,J,L))*DT + print *, " AFTER GWD Parameterization" + print *, " Latitude =", LATS(I,J)*180.0/MAPL_PI + print *, " Longitude =", LONS(I,J)*180.0/MAPL_PI + print *, " Pressure (mb) =", PMID(I,J,L)/100.0 + if (associated(U_EXP) .AND. associated(V_EXP)) then + print *, " UWND =", U_EXP(I,J,L) + print *, " VWND =", V_EXP(I,J,L) + endif + endif + end do ! IM loop + end do ! JM loop + end do ! LM loop + endif + +! All done +!----------- + RETURN_(ESMF_SUCCESS) + end subroutine GWD_DRIVER + + end subroutine RUN !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -990,7 +1021,7 @@ subroutine postintr(pcols,pver,dt, h0, hh, z1, tau1, & dudt_org, & dvdt_org, & dtdt_org, & - + ! Outputs dudt_tot, & dvdt_tot, & diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSgwd_GridComp/GWD_StateSpecs.rc b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSgwd_GridComp/GWD_StateSpecs.rc index e69a235a8..fb80c1dcd 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSgwd_GridComp/GWD_StateSpecs.rc +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSgwd_GridComp/GWD_StateSpecs.rc @@ -5,17 +5,16 @@ category: INTERNAL #-------------------------------------------------------------------------------------------------------------------- # VARIABLE | DIMENSION | Additional Metadata #-------------------------------------------------------------------------------------------------------------------- - NAME | UNITS | DIMS | VLOC | UNGRIDDED | LONG NAME + NAME | UNITS | DIMS | VLOC | UNGRIDDED | COND | LONG NAME #-------------------------------------------------------------------------------------------------------------------- - SGH30 | m | xy | N | | standard deviation of 30s elevation from 3km cube - KWVRDG | km | xy | N | (/16/) | horizonal wwavenumber of mountain ridges - EFFRDG | km | xy | N | (/16/) | efficiency of mountain ridge scheme - GBXAR | NA | xy | N | | grid box area - HWDTH | km | xy | N | (/16/) | width of mountain ridges - CLNGT | km | xy | N | (/16/) | width of mountain ridges - MXDIS | NA | xy | N | (/16/) | NA - ANGLL | NA | xy | N | (/16/) | NA - ANIXY | NA | xy | N | (/16/) | NA + KWVRDG | km | xy | N | (/16/) | self%NCAR_NRDG /= 0.0 | horizonal wavenumber of mountain ridges + EFFRDG | km | xy | N | (/16/) | self%NCAR_NRDG /= 0.0 | efficiency of mountain ridge scheme + GBXAR | NA | xy | N | | self%NCAR_NRDG /= 0.0 | grid box area + HWDTH | km | xy | N | (/16/) | self%NCAR_NRDG /= 0.0 | width of mountain ridges + CLNGT | km | xy | N | (/16/) | self%NCAR_NRDG /= 0.0 | width of mountain ridges + MXDIS | NA | xy | N | (/16/) | self%NCAR_NRDG /= 0.0 | NA + ANGLL | NA | xy | N | (/16/) | self%NCAR_NRDG /= 0.0 | NA + ANIXY | NA | xy | N | (/16/) | self%NCAR_NRDG /= 0.0 | NA category: IMPORT #------------------------------------------------------------------------------------------------------- @@ -58,6 +57,7 @@ category: EXPORT RDG1_GBXAR | | km^2 | xy | N | ridge1_gridbox_area SGH | SGH_EXP | m | xy | N | standard_deviation_of_topography PREF | PREF_EXP | Pa | z | E | reference_air_pressure + DQCDT_LS | | kg kg-1 s-1 | xyz | C | total_condensate_tendency_for_frontal_GWD_forcing DTDT | | Pa K s-1 | xyz | C | mass_weighted_air_temperature_tendency_due_to_GWD TTMGW | | K s-1 | xyz | C | air_temperature_tendency_due_to_GWD DUDT | | m s-2 | xyz | C | tendency_of_eastward_wind_due_to_GWD diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSgwd_GridComp/ncar_gwd/gw_common.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSgwd_GridComp/ncar_gwd/gw_common.F90 index 6a25286f1..4e09157b4 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSgwd_GridComp/ncar_gwd/gw_common.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSgwd_GridComp/ncar_gwd/gw_common.F90 @@ -4,7 +4,7 @@ module gw_common ! ! This module contains code common to different gravity wave ! parameterizations. -! + ! implicit none private @@ -50,8 +50,9 @@ module gw_common ! Scaling factor for generating QBO real(GW_PRC), protected :: qbo_hdepth_scaling -! Whether or not to enforce an upper boundary condition of tau = 0. -logical :: tau_0_ubc = .false. +! Pressure (Pa) to begin transition to an upper boundary condition of tau = 0. +! default(0.0) is not active +real :: tau_0_ubc = 0.0 ! Inverse Prandtl number. real(GW_PRC) :: prndl ! Heating rate conversion factor @@ -68,10 +69,6 @@ module gw_common ! Background diffusivity. real(GW_PRC), parameter :: dback = 0.05_GW_PRC - -! Newtonian cooling coefficients. -!real, allocatable :: alpha(:) ! AOO global save/alloctable variable not thread-safe - ! ! Limits to keep values reasonable. ! @@ -146,7 +143,7 @@ subroutine gw_common_init( & tau_0_ubc_in, ktop_in, gravit_in, rair_in, cpair_in, & prndl_in, qbo_hdepth_scaling_in, hr_cf_in, errstring) - logical, intent(in) :: tau_0_ubc_in + real, intent(in) :: tau_0_ubc_in integer, intent(in) :: ktop_in real, intent(in) :: gravit_in real, intent(in) :: rair_in ! Gas constant for dry air (J kg-1 K-1) @@ -263,8 +260,7 @@ subroutine gw_drag_prof(ncol, pver, band, pint, delp, rdelp, & src_level, tend_level, dt, t, & piln, rhoi, nm, ni, ubm, ubi, xv, yv, & c, kvtt, tau, utgw, vtgw, & - ttgw, gwut, alpha, ro_adjust, tau_adjust, & - kwvrdg, satfac_in, tndmax_in ) + ttgw, gwut, alpha, ro_adjust, kwvrdg) !----------------------------------------------------------------------- ! Solve for the drag profile from the multiple gravity wave drag @@ -341,28 +337,16 @@ subroutine gw_drag_prof(ncol, pver, band, pint, delp, rdelp, & ! Gravity wave wind tendency for each wave. real(GW_PRC), intent(out) :: gwut(ncol,pver,-band%ngwv:band%ngwv) - real, intent(in) :: alpha(:) + real, intent(in) :: alpha(pver+1) ! Adjustment parameter for IGWs. real, intent(in), optional :: & ro_adjust(ncol,-band%ngwv:band%ngwv,pver+1) - ! Adjustment parameter for TAU. - real, intent(in), optional :: & - tau_adjust(ncol,pver+1) - ! Diagnosed horizontal wavenumber for ridges. real, intent(in), optional :: & kwvrdg(ncol) - ! Factor for saturation calculation. Here backwards - ! compatibility. I believe it should be 1.0 (jtb). - ! Looks like it has been 2.0 for a while in CAM. - real, intent(in), optional :: & - satfac_in - - real, intent(in), optional :: tndmax_in - !---------------------------Local storage------------------------------- ! Level, wavenumber, constituent and column loop indices. @@ -387,29 +371,12 @@ subroutine gw_drag_prof(ncol, pver, band, pint, delp, rdelp, & ! Temporary effkwv real(GW_PRC) :: effkwv(ncol) - ! saturation factor. Defaults to 2.0 - ! unless overidden by satfac_in - real(GW_PRC) :: satfac - - real(GW_PRC) :: tndmax - real(GW_PRC) :: near_zero = tiny(1.0_GW_PRC) ! LU decomposition. type(TriDiagDecomp) :: decomp - if (present(satfac_in)) then - satfac = satfac_in - else - satfac = 2.0 - endif - -! Maximum wind tendency from stress divergence (before efficiency applied). - if (present(tndmax_in)) then - tndmax = tndmax_in - else - tndmax = 400._GW_PRC / 86400._GW_PRC - endif + real(GW_PRC) :: tau_0_scaling ! Lowest levels that loops need to iterate over. kbot_tend = maxval(tend_level) @@ -442,10 +409,11 @@ subroutine gw_drag_prof(ncol, pver, band, pint, delp, rdelp, & !------------------------------------------------------------------------ ! Loop from bottom to top to get stress profiles. -! !$OMP parallel do default(none) shared(kbot_src,ktop,kvtt,band,ubi,c,effkwv,rhoi,ni,satfac, & -! !$OMP ro_adjust,ncol,alpha,piln,t,rog,src_level,tau_adjust,tau) & -! !$OMP private(k,d,l,i,tausat,taudmp,ubmc,ubmc2,wrk,mi) - do k = kbot_src, ktop, -1 !++ but this is in model now +!$OMP parallel do default(none) & +!$OMP shared(kbot_src,ktop,kvtt,band,ubi,c,effkwv,rhoi,ni, & +!$OMP near_zero,ro_adjust,ncol,alpha,piln,t,rog,src_level,tau) & +!$OMP private(k,d,l,i,tausat,taudmp,ubmc,ubmc2,wrk,mi) + do k = kbot_src, ktop, -1 ! Determine the diffusivity for each column. @@ -460,88 +428,91 @@ subroutine gw_drag_prof(ncol, pver, band, pint, delp, rdelp, & if (src_level(i) >= k) then - ! Determine the absolute value of the saturation stress. - ! Define critical levels where the sign of (u-c) changes between - ! interfaces. + ! Determine the absolute value of the saturation stress. + ! Define critical levels where the sign of (u-c) changes between + ! interfaces. ubmc(i) = ubi(i,k) - c(i,l) - ! Test to see if u-c has the same sign here as the level below. - if (ubmc(i) > 0.0 .eqv. ubi(i,k+1) > c(i,l)) then - if (ni(i,k) /= 0.0) & - tausat(i) = abs( effkwv(i) * rhoi(i,k) * ubmc(i)**3 / & - (satfac*ni(i,k)) ) + ! Test to see if u-c has the same sign here as the level below. + if (ubmc(i) > near_zero .eqv. ubi(i,k+1) > c(i,l)) then + if ( (abs(effkwv(i)) > near_zero) .AND. (abs(ni(i,k)) > near_zero) ) & + tausat(i) = abs( effkwv(i) * rhoi(i,k) * ubmc(i)**3 / ni(i,k) ) if (present(ro_adjust)) & tausat(i) = tausat(i) * sqrt(ro_adjust(i,l,k)) - if (present(tau_adjust)) & - tausat(i) = tausat(i) * tau_adjust(i,k) endif - ! Compute stress for each wave. The stress at this level is the - ! min of the saturation stress and the stress at the level below - ! reduced by damping. The sign of the stress must be the same as - ! at the level below. + ! Compute stress for each wave. The stress at this level is the + ! min of the saturation stress and the stress at the level below + ! reduced by damping. The sign of the stress must be the same as + ! at the level below. ubmc2(i) = max(ubmc(i)**2, ubmc2mn) - mi(i) = ni(i,k) / (2.0 * effkwv(i) * ubmc2(i)) * & ! Is this 2.0 related to satfac? - (alpha(k) + ni(i,k)**2/ubmc2(i) * d(i)) - wrk(i) = -2.0*mi(i)*rog*t(i,k)*(piln(i,k+1) - piln(i,k)) - wrk(i) = max( wrk(i), -200.0 ) * exp(wrk(i)) + if (abs(effkwv(i)) > near_zero) & + mi(i) = ni(i,k) / (effkwv(i) * ubmc2(i)) * & + (alpha(k) + ni(i,k)**2/ubmc2(i) * d(i)) + wrk(i) = -mi(i)*rog*t(i,k)*(piln(i,k+1) - piln(i,k)) + wrk(i) = max( wrk(i), -75.0 ) ! Protect against underflow in exp(wrk(i)) taudmp(i) = tau(i,l,k+1) * exp(wrk(i)) - ! For some reason, PGI 14.1 loses bit-for-bit reproducibility if - ! we limit tau, so instead limit the arrays used to set it. + + ! For some reason, PGI 14.1 loses bit-for-bit reproducibility if + ! we limit tau, so instead limit the arrays used to set it. if (tausat(i) <= taumin) tausat(i) = 0.0 if (taudmp(i) <= taumin) taudmp(i) = 0.0 + tau(i,l,k) = min(taudmp(i), tausat(i)) endif end do end do + end do - + ! Force tau at the top of the model to zero, if requested. - if (tau_0_ubc) tau(:,:,ktop) = 0.0 + if (tau_0_ubc > 0.0) then + do k=1,pver+1 + do i=1,ncol + tau_0_scaling = TANH((pint(i,k)-pint(i,ktop))/tau_0_ubc) + tau(i,:,k) = tau(i,:,k)*tau_0_scaling + enddo + enddo + endif !------------------------------------------------------------------------ ! Compute the tendencies from the stress divergence. !------------------------------------------------------------------------ - ! Loop over levels from top to bottom -! !$OMP parallel do default(none) shared(kbot_tend,ktop,band,ncol,tau,delp,rdelp,c,ubm,dt,gravit,utgw,vtgw, & -! !$OMP gwut,ubt,xv,yv,tend_level,near_zero) & -! !$OMP private(k,l,i,ubtl) +!$OMP parallel do default(none) & +!$OMP shared(kbot_tend,ktop,band,ncol,tau,delp,rdelp,c,ubm,dt,gravit,utgw,vtgw, & +!$OMP gwut,ubt,xv,yv,tend_level,near_zero) & +!$OMP private(k,l,i,ubtl) do k = ktop, kbot_tend ! Accumulate the mean wind tendency over wavenumber. ubt(:,k) = 0.0 - do l = -band%ngwv, band%ngwv ! loop over wave - do i=1,ncol - - ! Determine the wind tendency, including excess stress carried down - ! from above. - ubtl(i) = gravit * (tau(i,l,k+1)-tau(i,l,k)) * rdelp(i,k) ! p%rdel(i,k) !/1/D_pint - - - ! Apply first tendency limit to maintain numerical stability. - ! Enforce du/dt < |c-u|/dt so u-c cannot change sign - ! (u^n+1 = u^n + du/dt * dt) - ! The limiter is somewhat stricter, so that we don't come anywhere - ! near reversing c-u. - ubtl(i) = min(ubtl(i), umcfac * abs(c(i,l)-ubm(i,k)) / dt) - if (k <= tend_level(i)) then + ! Determine the wind tendency, including excess stress carried down + ! from above. + ubtl(i) = gravit * (tau(i,l,k+1)-tau(i,l,k)) * rdelp(i,k) + + ! Apply first tendency limit to maintain numerical stability. + ! Enforce du/dt < |c-u|/dt so u-c cannot change sign + ! (u^n+1 = u^n + du/dt * dt) + ! The limiter is somewhat stricter, so that we don't come anywhere + ! near reversing c-u. + ubtl(i) = min(ubtl(i), umcfac * abs(c(i,l)-ubm(i,k)) / dt) ! Save tendency for each wave (for later computation of kzz). ! sign function returns magnitude of ubtl with sign of c-ubm ! Renders ubt/ubm check for mountain waves unecessary gwut(i,k,l) = sign(ubtl(i), c(i,l)-ubm(i,k)) + if ( abs(gwut(i,k,l)) < near_zero ) then + gwut(i,k,l) = 0.0 ! protection against underflow + end if ubt(i,k) = ubt(i,k) + gwut(i,k,l) - end if - end do - end do do l = -band%ngwv, band%ngwv @@ -554,13 +525,9 @@ subroutine gw_drag_prof(ncol, pver, band, pint, delp, rdelp, & ! issues. !-------------------------------------------------- do i=1,ncol - if ( abs(gwut(i,k,l)) < near_zero ) then - gwut(i,k,l) = 0.0 - end if if (k <= tend_level(i)) then tau(i,l,k+1) = tau(i,l,k) + & abs(gwut(i,k,l)) * delp(i,k) / gravit - !!! abs(gwut(i,k,l)) * p%del(i,k) / gravit end if end do end do @@ -578,8 +545,9 @@ subroutine gw_drag_prof(ncol, pver, band, pint, delp, rdelp, & ! Evaluate second temperature tendency term: Conversion of kinetic ! energy into thermal. -! !$OMP parallel do default(none) shared(kbot_tend,ktop,band,ttgw,ubm,c,gwut) & -! !$OMP private(k,l) +!$OMP parallel do default(none) & +!$OMP shared(kbot_tend,ktop,band,ttgw,ubm,c,gwut) & +!$OMP private(k,l) do k = ktop, kbot_tend do l = -band%ngwv, band%ngwv ttgw(:,k) = ttgw(:,k) - (ubm(:,k) - c(:,l)) * gwut(:,k,l) @@ -600,8 +568,8 @@ subroutine gw_newtonian_set( pver, pref, alpha ) integer, intent(in) :: pver real, intent(in) :: pref( pver+1 ) ! Newtonian cooling coefficients. - real, intent(inout) :: alpha(:) ! Make alpha argument instead of global for correct behavior under threading - + real, intent(inout) :: alpha( pver+1 ) ! Make alpha argument instead of global for correct behavior under threading + ! Levels of pre-calculated Newtonian cooling (1/day). ! The following profile is digitized from: ! Wehrbein and Leovy (JAS, 39, 1532-1544, 1982) figure 5 @@ -662,8 +630,6 @@ subroutine gw_newtonian_set( pver, pref, alpha ) palph(k) = palph(k)*1.e2 end do - !allocate (alpha(pver+1)) ! Make alpha local instead of global for correct behavior under threading - ! interpolate to current vertical grid and obtain alpha call lininterp (alpha0, palph, nalph , alpha, pref, pver+1) @@ -796,7 +762,7 @@ subroutine momentum_fixer(ncol, pver, tend_level, p, um_flux, vm_flux, utgw, vtg integer :: i, k ! Reciprocal of total mass. real :: rdm(ncol) - + ! Total mass from ground to source level: rho*dz = dp/gravit do i = 1, ncol rdm(i) = gravit/(p(i,pver+1)-p(i,tend_level(i)+1)) @@ -881,7 +847,7 @@ end subroutine energy_fixer subroutine energy_momentum_adjust(ncol, pver, band, pint, delp, u, v, dt, c, tau, & effgw, t, ubm, ubi, xv, yv, utgw, vtgw, ttgw, & - tend_level, tndmax_in, pint_adj) + tend_level, tndmax_in) integer, intent(in) :: ncol, pver ! Wavelengths. @@ -907,14 +873,14 @@ subroutine energy_momentum_adjust(ncol, pver, band, pint, delp, u, v, dt, c, tau real, intent(in) :: xv(ncol), yv(ncol) ! tendency level index index integer, intent(in) :: tend_level(ncol) +! Optional ! Tendency limiter real, intent(in), optional :: tndmax_in +! Output ! Tendencies. real, intent(inout) :: utgw(ncol,pver) real, intent(inout) :: vtgw(ncol,pver) real, intent(inout) :: ttgw(ncol,pver) - ! Pressure level efficiency adjustment - real, intent(in), optional :: pint_adj(ncol,pver+1) real :: taucd(ncol,pver+1,4) real :: um_flux(ncol), vm_flux(ncol) @@ -940,13 +906,11 @@ subroutine energy_momentum_adjust(ncol, pver, band, pint, delp, u, v, dt, c, tau !--------------------------------------------------------------------------------------- ! Apply efficiency factor and tendency limiter to prevent unrealistically strong forcing !--------------------------------------------------------------------------------------- - ! efficiency factor and optional pressure adjustment + ! efficiency factor and optional pressure adjustment do k = ktop, pver - utfac = 1.0 - if (present(pint_adj)) utfac = pint_adj(i,k) - utgw(i,k) = utgw(i,k)*effgw(i)*utfac - vtgw(i,k) = vtgw(i,k)*effgw(i)*utfac - ttgw(i,k) = ttgw(i,k)*effgw(i)*utfac + utgw(i,k) = utgw(i,k)*effgw(i) + vtgw(i,k) = vtgw(i,k)*effgw(i) + ttgw(i,k) = ttgw(i,k)*effgw(i) end do ! tendency limiter uhtmax = 0.0 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSgwd_GridComp/ncar_gwd/gw_convect.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSgwd_GridComp/ncar_gwd/gw_convect.F90 index e88dddbe9..86dfb58e3 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSgwd_GridComp/ncar_gwd/gw_convect.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSgwd_GridComp/ncar_gwd/gw_convect.F90 @@ -44,7 +44,9 @@ module gw_convect real, allocatable :: mfcc(:,:,:) ! Forced background for extratropics real, allocatable :: taubck(:,:) - logical :: et_bkg_lat_forcing + ! Efficiency TR:ET function + real, allocatable :: effbck(:) + logical :: et_bkg_dqcdt_forcing end type BeresSourceDesc @@ -54,7 +56,8 @@ module gw_convect !------------------------------------ subroutine gw_beres_init (file_name, band, desc, pgwv, gw_dc, fcrit2, wavelength, & - spectrum_source, min_hdepth, storm_shift, tau_et, et_uselats, tndmax, & + spectrum_source, min_hdepth, storm_shift, eff_tr, eff_et, & + tau_et, et_use_dqcdt, tndmax, & active, ncol, lats) #include @@ -65,8 +68,8 @@ subroutine gw_beres_init (file_name, band, desc, pgwv, gw_dc, fcrit2, wavelength integer, intent(in) :: pgwv, ncol real, intent(in) :: gw_dc, fcrit2, wavelength - real, intent(in) :: spectrum_source, min_hdepth, tau_et, tndmax - logical, intent(in) :: storm_shift, active, et_uselats + real, intent(in) :: spectrum_source, min_hdepth, eff_tr, eff_et, tau_et, tndmax + logical, intent(in) :: storm_shift, active, et_use_dqcdt real, intent(in) :: lats(ncol) ! Stuff for Beres convective gravity wave source. @@ -75,7 +78,7 @@ subroutine gw_beres_init (file_name, band, desc, pgwv, gw_dc, fcrit2, wavelength ! For forced background extratropical wave speed real :: c4, latdeg, flat_gw - real, allocatable :: c0(:), cw4(:) + real, allocatable :: cw(:), cw4(:) integer :: i, kc ! Vars needed by NetCDF operators @@ -125,11 +128,12 @@ subroutine gw_beres_init (file_name, band, desc, pgwv, gw_dc, fcrit2, wavelength ! Number in each direction is half of total (and minus phase speed of 0). desc%maxuh = (desc%maxuh-1)/2 - ! midpoint of spectrum in netcdf file is ps_mfcc (odd number) -1 divided by 2, plus 1 - ! E.g., ps_mfcc = 5. So, ps_mfcc_mid = 3 - ! 1 2 3 4 5 - ! -2 -1 0 +1 +2 - ps_mfcc_mid= (ngwv_file-1)/2 + + ! midpoint of spectrum in netcdf file is ps_mfcc (odd number) divided by 2, plus 1 + ! E.g., ps_mfcc = 81. So, ps_mfcc_mid = 41 + ! 1 11 21 31 32 33 34 35 36 37 38 39 40 41 42 43 ... + ! -40 -30 -20 -10 -9 -8 -7 -6 -5 -4 -3 -2 -1 0 +1 +2 ... + ps_mfcc_mid= INT(ngwv_file/2) + 1 desc%active = active if (active) then @@ -156,51 +160,44 @@ subroutine gw_beres_init (file_name, band, desc, pgwv, gw_dc, fcrit2, wavelength desc%tndmax = tndmax ! Intialize forced background wave speeds + allocate(desc%effbck(ncol)) allocate(desc%taubck(ncol,-band%ngwv:band%ngwv)) - allocate(c0(-band%ngwv:band%ngwv)) + allocate(cw(-band%ngwv:band%ngwv)) allocate(cw4(-band%ngwv:band%ngwv)) + desc%effbck = 1.0 desc%taubck = 0.0 - c0 = 0.0 + cw = 0.0 cw4 = 0.0 do kc = -4,4 c4 = 10.0*kc cw4(kc) = exp(-(c4/30.)**2) enddo do kc = -band%ngwv,band%ngwv - c0(kc) = 10.0*(4.0/real(band%ngwv))*kc - desc%taubck(:,kc) = exp(-(c0(kc)/30.)**2) + cw(kc) = 10.0*(4.0/real(band%ngwv))*kc + cw(kc) = exp(-(cw(kc)/30.)**2) enddo - desc%et_bkg_lat_forcing = et_uselats - if (et_uselats) then - do i=1,ncol - ! include forced background stress in extra tropics - ! Determine the background stress at c=0 - ! Include dependence on latitude: + cw = cw*(sum(cw4)/sum(cw)) + desc%et_bkg_dqcdt_forcing = et_use_dqcdt + do i=1,ncol + ! include forced background stress in extra tropics + ! Determine the background stress at c=0 + ! Include dependence on latitude: latdeg = lats(i)*rad2deg - if (-15.3 < latdeg .and. latdeg < 15.3) then - flat_gw = 0.10 - else if (latdeg > -31. .and. latdeg <= -15.3) then - flat_gw = 0.10 - else if (latdeg < 31. .and. latdeg >= 15.3) then - flat_gw = 0.10 - else if (latdeg > -60. .and. latdeg <= -31.) then - flat_gw = 0.50*exp(-((abs(latdeg)-60.)/23.)**2) - else if (latdeg < 60. .and. latdeg >= 31.) then - flat_gw = 0.50*exp(-((abs(latdeg)-60.)/23.)**2) - else if (latdeg <= -60.) then - flat_gw = 0.50*exp(-((abs(latdeg)-60.)/70.)**2) - else if (latdeg >= 60.) then - flat_gw = 0.50*exp(-((abs(latdeg)-60.)/70.)**2) - end if - desc%taubck(i,:) = tau_et*0.001*flat_gw*desc%taubck(i,:)*(sum(cw4)/sum(desc%taubck(i,:))) - enddo - else - flat_gw = 0.5 ! constant scaling since DQCDT will be used for frontal detection - do i=1,ncol - desc%taubck(i,:) = tau_et*0.001*flat_gw*desc%taubck(i,:)*(sum(cw4)/sum(desc%taubck(i,:))) - enddo - end if - deallocate( c0, cw4 ) + if (desc%et_bkg_dqcdt_forcing) then + flat_gw = 0.15 + else + if (ABS(latdeg) < 60.) then + flat_gw = max(0.15,0.50*exp(-((abs(latdeg)-60.)/23.)**2)) + elseif (ABS(latdeg) >= 60.) then + flat_gw = 0.50*exp(-((abs(latdeg)-60.)/70.)**2) + endif + endif + desc%taubck(i,:) = tau_et*0.001*flat_gw*cw + ! efficiency function + desc%effbck(i) = eff_tr*cos(lats(i))**2 + & + eff_et*sin(lats(i))**2 + enddo + deallocate( cw, cw4 ) end if end subroutine gw_beres_init @@ -368,17 +365,9 @@ subroutine gw_beres_src(ncol, pver, band, desc, pint, u, v, & ! Compute source k-index do i=1,ncol - if (hd_idx(i) > 0) then - do k = 0, pver-2 - ! spectrum source index for DeepCu scheme - if (pint(i,k+1) < desc%spectrum_source) desc%k(i) = k+1 - end do - else - do k = 0, pver-2 - ! spectrum source index for frontal scheme - if (pint(i,k+1) < 90000.0) desc%k(i) = k+1 - end do - endif + do k = 0, pver-2 + if (pint(i,k+1) < desc%spectrum_source) desc%k(i) = k+1 + end do enddo !------------------------------------------------------------------------ @@ -409,16 +398,14 @@ subroutine gw_beres_src(ncol, pver, band, desc, pint, u, v, & ubi(:,1) = ubm(:,1) ubi(:,2:pver) = midpoint_interp(ubm) - ! Average wind in heating region, relative to storm cells. uh = 0.0 - do k = minval(topi), maxval(boti) - where (k >= topi .and. k <= boti) - uh = uh + ubm(:,k)/(boti-topi+1) - end where - end do - do i=1,ncol if (desc%storm_shift .and. (hd_idx(i) > 0)) then + ! Average wind in heating region, relative to storm cells. + do k = topi(i), boti(i) + uh(i) = uh(i) + ubm(i,k) + end do + uh(i) = uh(i)/(boti(i)-topi(i)+1) ! Find the cell speed where the storm speed is > 10 m/s. ! Storm speed is taken to be the source wind speed. CS(i) = sign(max(abs(ubm(i,desc%k(i)))-10.0, 0.0), ubm(i,desc%k(i))) @@ -475,7 +462,7 @@ subroutine gw_beres_src(ncol, pver, band, desc, pint, u, v, & end if ! Adjust magnitude. - tau0 = tau0*(q0(i)**2)/AL + tau0 = tau0*q0(i)*q0(i)/AL ! Adjust for critical level filtering. tau0(Umini(i):Umaxi(i)) = 0.0 @@ -484,7 +471,8 @@ subroutine gw_beres_src(ncol, pver, band, desc, pint, u, v, & else - if (desc%et_bkg_lat_forcing) then + tau(i,:,:) = 0.0 + if (.not. desc%et_bkg_dqcdt_forcing) then ! use latitudinal dependence ! include forced background stress in extra tropical large-scale systems ! Set the phase speeds and wave numbers in the direction of the source wind. @@ -493,22 +481,20 @@ subroutine gw_beres_src(ncol, pver, band, desc, pint, u, v, & tau(i,:,desc%k(i)+1) = desc%taubck(i,:) topi(i) = desc%k(i) else - ! Maximum condensate change, for frontal detection - q0(i) = 0.0 - do k = pver, 1, -1 ! Surface to top of atmosphere - if (dqcdt(i,k) < q0(i)) then ! Find max DQCDT level + ! Find largest condensate change level, for frontal detection + ! condensate tendencies from microphysics will be negative + q0(i) = 0.0 + do k = desc%k(i), 1, -1 ! tend-level to the surface [avoid convective overlap] + if (dqcdt(i,k) > q0(i)) then ! Find largest positive DQCDT tendency q0(i) = dqcdt(i,k) - desc%k(i) = k endif - end do - if (q0(i) < -1.e-8) then ! frontal region (large-scale forcing) + end do ! include forced background stress in extra tropical large-scale systems ! Set the phase speeds and wave numbers in the direction of the source wind. ! Set the source stress magnitude (positive only, note that the sign of the ! stress is the same as (c-u). - tau(i,:,desc%k(i)+1) = desc%taubck(i,:) + tau(i,:,desc%k(i)+1) = desc%taubck(i,:) * MIN(10.0,MAX(1.0,abs(q0(i)/1.e-9))) topi(i) = desc%k(i) - endif endif endif @@ -610,9 +596,6 @@ subroutine gw_beres_ifc( band, & ! Heating depth [m] and maximum heating in each column. real :: hdepth(ncol), maxq0(ncol) - real :: pint_adj(ncol,pver+1) - real :: zfac_layer - character(len=1) :: cn character(len=9) :: fname(4) @@ -627,38 +610,24 @@ subroutine gw_beres_ifc( band, & allocate(c(ncol,-band%ngwv:band%ngwv)) ! Efficiency of gravity wave momentum transfer. - ! This is really only to remove the pole points. - where (pi/2.0 - abs(lats(:ncol)) >= 1.e-4 ) !-4*epsilon(1.0)) - effgw = effgw_dp - elsewhere - effgw = 0.0 - end where - -!GEOS pressure scaling near model top - zfac_layer = 0.35e2 ! 0.35mb - do k=1,pver+1 - do i=1,ncol - pint_adj(i,k) = MIN(1.0,MAX(0.0,(pint(i,k)/zfac_layer)**3)) - enddo - enddo + effgw = effgw_dp*desc%effbck ! Determine wave sources for Beres deep scheme call gw_beres_src(ncol, pver, band, desc, pint, & u, v, netdt, zm, src_level, tend_level, tau, & ubm, ubi, xv, yv, c, hdepth, maxq0, lats, dqcdt=dqcdt) - ! Solve for the drag profile with orographic sources. + ! Solve for the drag profile with convective sources. call gw_drag_prof(ncol, pver, band, pint, delp, rdelp, & src_level, tend_level, dt, t, & piln, rhoi, nm, ni, ubm, ubi, xv, yv, & - c, kvtt, tau, utgw, vtgw, & - ttgw, gwut, alpha) !, tau_adjust=pint_adj) + c, kvtt, tau, utgw, vtgw, ttgw, gwut, alpha) ! Apply efficiency and limiters call energy_momentum_adjust(ncol, pver, band, pint, delp, u, v, dt, c, tau, & effgw, t, ubm, ubi, xv, yv, utgw, vtgw, ttgw, & - tend_level, tndmax_in=desc%tndmax) !, pint_adj=pint_adj) - + tend_level, tndmax_in=desc%tndmax) + deallocate(tau, gwut, c) end subroutine gw_beres_ifc diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSgwd_GridComp/ncar_gwd/gw_oro.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSgwd_GridComp/ncar_gwd/gw_oro.F90 index d123d231a..ac390b6ab 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSgwd_GridComp/ncar_gwd/gw_oro.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSgwd_GridComp/ncar_gwd/gw_oro.F90 @@ -17,28 +17,28 @@ module gw_oro real,parameter :: PI = 3.14159265358979323846 ! pi -real :: gw_oro_south_fac +real, protected :: gw_oro_south_fac +real, protected :: gw_oro_tndmax contains !========================================================================== !------------------------------------ -subroutine gw_oro_init (band, gw_dc, fcrit2, wavelength, pgwv, oro_south_fac) +subroutine gw_oro_init (band, gw_dc, fcrit2, wavelength, pgwv, oro_south_fac, oro_tndmax) #include type(GWBand), intent(inout) :: band - real, intent(in) :: gw_dc,fcrit2,wavelength,oro_south_fac + real, intent(in) :: gw_dc,fcrit2,wavelength,oro_south_fac,oro_tndmax integer, intent(in) :: pgwv - - ! Need to call GWBand for oro waves band = GWBand(pgwv, gw_dc, fcrit2, wavelength ) gw_oro_south_fac = oro_south_fac - + gw_oro_tndmax = oro_tndmax + end subroutine gw_oro_init !------------------------------------ @@ -246,7 +246,7 @@ subroutine gw_oro_ifc( band, & real, intent(in) :: sgh(ncol) ! subgrid orographic std dev (m) real, intent(in) :: lats(ncol) ! latitudes - real, intent(in) :: alpha(:) + real, intent(in) :: alpha(pver+1) real, intent(out) :: utgw(ncol,pver) ! zonal wind tendency @@ -279,9 +279,6 @@ subroutine gw_oro_ifc( band, & real :: xv(ncol) real :: yv(ncol) - real :: pint_adj(ncol,pver+1) - real :: zfac_layer - character(len=1) :: cn character(len=9) :: fname(4) @@ -311,23 +308,17 @@ subroutine gw_oro_ifc( band, & end if end do -!GEOS pressure scaling near model top - zfac_layer = 1000.0 ! 10mb - do k=1,pver+1 - do i=1,ncol - pint_adj(i,k) = MIN(1.0,MAX(0.0,(pint(i,k)/zfac_layer)**3)) - enddo - enddo - ! Solve for the drag profile with orographic sources. call gw_drag_prof(ncol, pver, band, pint, delp, rdelp, & src_level, tend_level, dt, t, & piln, rhoi, nm, ni, ubm, ubi, xv, yv, & c, kvtt, tau, utgw, vtgw, & - ttgw, gwut, alpha, tau_adjust=pint_adj) + ttgw, gwut, alpha) + ! Apply efficiency and limiters call energy_momentum_adjust(ncol, pver, band, pint, delp, u, v, dt, c, tau, & - effgw, t, ubm, ubi, xv, yv, utgw, vtgw, ttgw, tend_level) + effgw, t, ubm, ubi, xv, yv, utgw, vtgw, ttgw, tend_level, & + tndmax_in=gw_oro_tndmax) end subroutine gw_oro_ifc diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSgwd_GridComp/ncar_gwd/gw_rdg.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSgwd_GridComp/ncar_gwd/gw_rdg.F90 index fab1e67c9..54ecfc389 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSgwd_GridComp/ncar_gwd/gw_rdg.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSgwd_GridComp/ncar_gwd/gw_rdg.F90 @@ -181,7 +181,7 @@ subroutine gw_rdg_ifc( band, & real, intent(in) :: rdg_cd_llb ! Drag coefficient for low-level flow logical, intent(in) :: trpd_leewv - real, intent(in) :: alpha(:) + real, intent(in) :: alpha(pver+1) ! OUTPUTS @@ -269,11 +269,8 @@ subroutine gw_rdg_ifc( band, & real :: qtgw(ncol,pver,pcnst) ! constituents tendencies #endif - real :: pint_adj(ncol,pver+1) - real :: zfac_layer real :: utfac,uhtmax - character(len=4) :: type ! BETA or GAMMA (just BETA for now) character(len=1) :: cn character(len=9) :: fname(4) !---------------------------------------------------------------------------- @@ -283,21 +280,10 @@ subroutine gw_rdg_ifc( band, & allocate(gwut(ncol,pver,-band%ngwv:band%ngwv )) allocate(c(ncol,-band%ngwv:band%ngwv)) - type='BETA' - ! initialize accumulated momentum fluxes and tendencies utrdg = 0. vtrdg = 0. ttrdg = 0. - -!GEOS pressure scaling near model top - zfac_layer = 1000.0 ! 10mb - do k=1,pver+1 - do i=1,ncol - pint_adj(i,k) = MIN(1.0,MAX(0.0,(pint(i,k)/zfac_layer)**3)) - enddo - enddo - isoflag = 0 do nn = 1, n_rdg @@ -323,18 +309,18 @@ subroutine gw_rdg_ifc( band, & call gw_drag_prof(ncol, pver, band, pint, delp, rdelp, & src_level, tend_level,dt, t, & piln, rhoi, nm, ni, ubm, ubi, xv, yv, & - c, kvtt, tau, utgw, vtgw, & - ttgw, gwut, alpha, & - kwvrdg=kwvrdg(:,nn), satfac_in=1.0, tau_adjust=pint_adj) + c, kvtt, tau, utgw, vtgw, ttgw, gwut, alpha, & + kwvrdg=kwvrdg(:,nn)) ! Apply efficiency and limiters to the totals call energy_momentum_adjust(ncol, pver, band, pint, delp, u, v, dt, c, tau, & effrdg(:,nn), t, ubm, ubi, xv, yv, utgw, vtgw, ttgw, & tend_level, tndmax_in=orotndmax) - do i=1,ncol + do i=1,ncol !------------------------------------------------------------------- ! Apply tendency limiter to prevent unrealistically strong forcing + ! Accumulate ridge totals !------------------------------------------------------------------- uhtmax = 0.0 utfac = 1.0 @@ -350,38 +336,11 @@ subroutine gw_rdg_ifc( band, & utrdg(i,k) = utrdg(i,k)*utfac vtrdg(i,k) = vtrdg(i,k)*utfac ttrdg(i,k) = ttrdg(i,k)*utfac - end do - end do ! i=1,ncol - -#ifdef CAM -! disable tracer mixing in GW for now. - do icnst = 1, pcnst - do k = 1, pver - qtrdg(:,k,icnst) = qtrdg(:,k,icnst) + qtgw(:,k,icnst) - end do - end do - if (nn <= 6) then - write(cn, '(i1)') nn - end if -#endif + end do + end do ! i=1,ncol end do ! end of loop over multiple ridges - if (trim(type) == 'BETA') then - fname(1) = 'TAUGWX' - fname(2) = 'TAUGWY' - fname(3) = 'UTGWORO' - fname(4) = 'VTGWORO' - else if (trim(type) == 'GAMMA') then - fname(1) = 'TAURDGGMX' - fname(2) = 'TAURDGGMY' - fname(3) = 'UTRDGGM' - fname(4) = 'VTRDGGM' - else - call endrun('gw_rdg_calc: FATAL: type must be either BETA or GAMMA'& - //' type= '//type) - end if - deallocate(tau, gwut, c) end subroutine gw_rdg_ifc diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/CMakeLists.txt b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/CMakeLists.txt index 4374e909b..aa17c7f53 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/CMakeLists.txt +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/CMakeLists.txt @@ -7,8 +7,9 @@ set (srcs GEOS_MGB2_2M_InterfaceMod.F90 micro_mg3_0.F90 micro_mg_utils.F90 cldwat2m_micro.F90 wv_saturation.F90 aer_cloud.F90 wv_sat_methods.F90 - GEOS_GFDL_1M_InterfaceMod.F90 gfdl_cloud_microphys.F90 + GEOS_GFDL_1M_InterfaceMod.F90 gfdl_cloud_microphys.F90 gfdl_mp.F90 GEOS_THOM_1M_InterfaceMod.F90 module_mp_thompson.F90 module_mp_radar.F90 machine.F + GEOS_NSSL_2M_InterfaceMod.F90 module_mp_nssl_2mom.F90 GEOS_GF_InterfaceMod.F90 ConvPar_GF_GEOS5.F90 ConvPar_GF2020.F90 ConvPar_GF_Shared.F90 module_gate.F90 GEOS_UW_InterfaceMod.F90 uwshcu.F90 aer_actv_single_moment.F90 @@ -21,37 +22,51 @@ if (CMAKE_Fortran_COMPILER_ID MATCHES Intel AND CMAKE_BUILD_TYPE MATCHES Aggress set (CMAKE_Fortran_FLAGS_AGGRESSIVE "${GEOS_Fortran_FLAGS_VECT}") endif () -if (CMAKE_Fortran_COMPILER_ID MATCHES GNU AND CMAKE_BUILD_TYPE MATCHES Release) - string (REPLACE "${FOPT3}" "${FOPT2}" CMAKE_Fortran_FLAGS_RELEASE ${CMAKE_Fortran_FLAGS_RELEASE}) +# Apply only for GNU in Release or Aggressive builds +if (CMAKE_Fortran_COMPILER_ID STREQUAL "GNU" + AND CMAKE_BUILD_TYPE MATCHES "^(Release|Aggressive)$") + + # If Aggressive, start from your release flags. If you use the 'default' + # aggressive flags, the model is quickly unstable. + if (CMAKE_BUILD_TYPE STREQUAL "Aggressive") + set(CMAKE_Fortran_FLAGS_AGGRESSIVE "${GEOS_Fortran_FLAGS_RELEASE}") + # drop -O3 -> -O2 + string(REPLACE "${FOPT3}" "${FOPT2}" + CMAKE_Fortran_FLAGS_AGGRESSIVE "${CMAKE_Fortran_FLAGS_AGGRESSIVE}") + else() + # drop -O3 -> -O2 + string(REPLACE "${FOPT3}" "${FOPT2}" + CMAKE_Fortran_FLAGS_RELEASE "${CMAKE_Fortran_FLAGS_RELEASE}") + endif() + + # GCC 15+ workaround for GF sources # There is some odd interaction between GCC 15 and the GF code. FPEs # that do not occur with GCC 14 or earlier. For now, we compile GF # codes with -O1 which seems to avoid the bad instruction. Tests show # not much of a speed difference with GCC 14 - if (${CMAKE_Fortran_COMPILER_VERSION} VERSION_GREATER_EQUAL 15) - message (STATUS "[GCC15+] Setting GF Code to use -O1 for GCC 15") - set_source_files_properties(ConvPar_GF2020.F90 PROPERTIES COMPILE_OPTIONS ${FOPT1}) - set_source_files_properties(ConvPar_GF_GEOS5.F90 PROPERTIES COMPILE_OPTIONS ${FOPT1}) + if (CMAKE_Fortran_COMPILER_VERSION VERSION_GREATER_EQUAL 15) + message(STATUS "[GCC15+] Setting GF Code to use -O1 for GCC 15") + set(gf_sources + ConvPar_GF2020.F90 + ConvPar_GF_GEOS5.F90 + ) + set_source_files_properties(${gf_sources} + PROPERTIES COMPILE_OPTIONS "${FOPT1}") endif() -endif () +endif() # Note For unknown reasons, BACM_1M_Interface takes 20 minutes to compile at O3 # and 10 minutes at O2. But only 7 seconds with O1. So we compile at O1 if (CMAKE_Fortran_COMPILER_ID MATCHES Intel AND CMAKE_BUILD_TYPE MATCHES Release) set_source_files_properties(GEOS_BACM_1M_InterfaceMod.F90 PROPERTIES COMPILE_OPTIONS ${FOPT1}) - # set_source_files_properties(GEOS_MGB2_2M_InterfaceMod.F90 PROPERTIES COMPILE_OPTIONS ${FOPT1}) +# set_source_files_properties(GEOS_MGB2_2M_InterfaceMod.F90 PROPERTIES COMPILE_OPTIONS ${FOPT1}) endif () esma_add_library (${this} SRCS ${srcs} DEPENDENCIES GEOS_Shared GMAO_mpeu MAPL Chem_Shared Chem_Base ESMF::ESMF) -# We need to add_dependencies for fms_r4 because CMake doesn't know we -# need it for include purposes. In R4R8, we only ever link against -# fms_r8, so it doesn't know to build the target fms_r4 -# NOTE NOTE NOTE: This should *not* be included in GEOSgcm v12 -# because FMS is pre-built library in that case. -add_dependencies (${this} fms_r4) -get_target_property (extra_incs fms_r4 INCLUDE_DIRECTORIES) +get_target_property (extra_incs FMS::fms_r4 INTERFACE_INCLUDE_DIRECTORIES) target_include_directories(${this} PRIVATE $ ) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/ConvPar_GF2020.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/ConvPar_GF2020.F90 index e80231802..69c5a8085 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/ConvPar_GF2020.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/ConvPar_GF2020.F90 @@ -41,7 +41,9 @@ MODULE ConvPar_GF2020 REAL :: int_time = 0. !- !- number of microphysics schemes in the host model - INTEGER ,PARAMETER :: nmp = 2, lsmp = 1, cnmp = 2 + INTEGER ,PARAMETER :: nmp = 1, lsmp = 1, cnmp = 2 + + LOGICAL :: FIX_NEGATIVES = .true. INTEGER :: USE_MEMORY =-1 != -1/0/1/2 .../10 !- @@ -176,14 +178,14 @@ MODULE ConvPar_GF2020 CONTAINS !--------------------------------------------------------------------------------------------------- SUBROUTINE GF2020_INTERFACE( mxp,myp,mzp,LONS,LATS,DT_MOIST & - ,PLE, PLO, ZLE, ZLO, PK, MASS, KH & - ,T1, TH1, Q1, U1,V1,W1,BYNCY,QLCN,QICN,QLLS,QILS & + ,PLE, PLO, ZLE, ZLO, PK, MASS, KH & + ,T1, TH1, Q1, U1,V1,W1,BYNCY,QLIQ,QICE & ,CNPCPRATE & ,CNV_MF0, CNV_PRC3, CNV_MFD, CNV_DQCDT ,ENTLAM & - ,CNV_MFC, CNV_UPDF, CNV_CVW, CNV_QC, CLCN,CLLS & + ,CNV_MFC, CNV_UPDF, CNV_CVW, CNV_QC, QCLD & ,QV_DYN_IN,PLE_DYN_IN,U_DYN_IN,V_DYN_IN,T_DYN_IN & ,RADSW ,RADLW ,DQDT_BL ,DTDT_BL & - ,FRLAND ,AREA ,T2M ,Q2M & + ,FRLAND ,AREA ,T2M ,Q2M & ,TA ,QA ,SH ,EVAP ,PHIS & ,KPBLIN ,CNVFRC,SRFTYPE & ,STOCHASTIC_SIG, SIGMA_DEEP, SIGMA_MID & @@ -194,6 +196,7 @@ SUBROUTINE GF2020_INTERFACE( mxp,myp,mzp,LONS,LATS,DT_MOIST ,AA0,AA1,AA2,AA3,AA1_BL,AA1_CIN,TAU_BL,TAU_EC & ,DTDTDYN,DQVDTDYN & ,REVSU, entr3d, entr_dp, entr_md, entr_sh, PRFIL & + ,SGS_VVEL_DP, SGS_VVEL_MD, SGS_VVEL_SH & ,TPWI,TPWI_star,LIGHTN_DENS & ,CNV_TR) @@ -206,8 +209,8 @@ SUBROUTINE GF2020_INTERFACE( mxp,myp,mzp,LONS,LATS,DT_MOIST REAL ,DIMENSION(mxp,myp,0:mzp) ,INTENT(IN) :: PLE,ZLE REAL ,DIMENSION(mxp,myp,mzp) ,INTENT(IN) :: ZLO, PLO, PK, MASS, KH, & - T1,TH1,Q1,U1,V1,W1,BYNCY,QLCN,QICN,QLLS,QILS, & - CLLS,CLCN + T1,TH1,Q1,U1,V1,W1,BYNCY,QLIQ,QICE, & + QCLD REAL ,DIMENSION(mxp,myp,0:mzp) ,INTENT(IN) :: PLE_DYN_IN @@ -238,6 +241,8 @@ SUBROUTINE GF2020_INTERFACE( mxp,myp,mzp,LONS,LATS,DT_MOIST REAL ,DIMENSION(mxp,myp,mzp) ,INTENT(OUT) :: REVSU, entr3d, entr_dp, entr_md, entr_sh + REAL ,DIMENSION(mxp,myp,mzp) ,INTENT(OUT) :: SGS_VVEL_DP, SGS_VVEL_MD, SGS_VVEL_SH + REAL ,DIMENSION(mxp,myp,0:mzp) ,INTENT(OUT) :: PRFIL !- Tendencies @@ -342,7 +347,8 @@ SUBROUTINE GF2020_INTERFACE( mxp,myp,mzp,LONS,LATS,DT_MOIST ,prdn5d & ,clwup5d & ,tup5d & - ,conv_cld_fr5d + ,conv_cld_fr5d & + ,sgs_vvel_5d !-----------local var in GEOS-5 data structure REAL, DIMENSION(mxp, myp, mzp) :: DZ, AIR_DEN @@ -365,7 +371,6 @@ SUBROUTINE GF2020_INTERFACE( mxp,myp,mzp,LONS,LATS,DT_MOIST CNV_CVW = 0.0 CNV_QC = 0.0 ENTLAM = 0.0 - CNPCPRATE = 0.0 LIGHTN_DENS = 0.0 REVSU = 0.0 PRFIL = 0.0 @@ -533,12 +538,9 @@ SUBROUTINE GF2020_INTERFACE( mxp,myp,mzp,LONS,LATS,DT_MOIST endif entr3d(i,j,flip(k)) = ec3d(k,i,j) - mp_ice(lsmp,k,i,j) = QILS (i,j,flip(k)) - mp_liq(lsmp,k,i,j) = QLLS (i,j,flip(k)) - mp_cf (lsmp,k,i,j) = CLLS (i,j,flip(k)) - mp_ice(cnmp,k,i,j) = QICN (i,j,flip(k)) - mp_liq(cnmp,k,i,j) = QLCN (i,j,flip(k)) - mp_cf (cnmp,k,i,j) = CLCN (i,j,flip(k)) + mp_ice(lsmp,k,i,j) = QICE (i,j,flip(k)) + mp_liq(lsmp,k,i,j) = QLIQ (i,j,flip(k)) + mp_cf (lsmp,k,i,j) = QCLD (i,j,flip(k)) ENDDO ENDDO @@ -594,12 +596,9 @@ SUBROUTINE GF2020_INTERFACE( mxp,myp,mzp,LONS,LATS,DT_MOIST endif entr3d(i,j,flip(k)) = ec3d(k,i,j) - mp_ice(lsmp,k,i,j) = QILS (i,j,flip(k)) - mp_liq(lsmp,k,i,j) = QLLS (i,j,flip(k)) - mp_cf (lsmp,k,i,j) = CLLS (i,j,flip(k)) - mp_ice(cnmp,k,i,j) = QICN (i,j,flip(k)) - mp_liq(cnmp,k,i,j) = QLCN (i,j,flip(k)) - mp_cf (cnmp,k,i,j) = CLCN (i,j,flip(k)) + mp_ice(lsmp,k,i,j) = QICE (i,j,flip(k)) + mp_liq(lsmp,k,i,j) = QLIQ (i,j,flip(k)) + mp_cf (lsmp,k,i,j) = QCLD (i,j,flip(k)) ENDDO ENDDO ENDDO @@ -731,6 +730,7 @@ SUBROUTINE GF2020_INTERFACE( mxp,myp,mzp,LONS,LATS,DT_MOIST ,tup5d & ,conv_cld_fr5d& !-- for debug/diagnostic + ,sgs_vvel_5d & ,AA0,AA1,AA2,AA3,AA1_BL,AA1_CIN,TAU_BL,TAU_EC) @@ -792,6 +792,10 @@ SUBROUTINE GF2020_INTERFACE( mxp,myp,mzp,LONS,LATS,DT_MOIST ENDIF + sgs_vvel_dp = MAPL_UNDEF + sgs_vvel_md = MAPL_UNDEF + sgs_vvel_sh = MAPL_UNDEF + entr_dp = MAPL_UNDEF entr_md = MAPL_UNDEF entr_sh = MAPL_UNDEF @@ -802,6 +806,11 @@ SUBROUTINE GF2020_INTERFACE( mxp,myp,mzp,LONS,LATS,DT_MOIST DO i=1,mxp if(ierr4d(i,j,IENS) .ne. 0) cycle DO k=mzp,flip(ktop4d(i,j,IENS))-1,-1 + + !- Export sug-grid scale vertical velocities used by GF + if (IENS==DEEP) sgs_vvel_dp(i,j,k) = sgs_vvel_5d(i,flip(k),j,IENS) + if (IENS==MID ) sgs_vvel_md(i,j,k) = sgs_vvel_5d(i,flip(k),j,IENS) + if (IENS==SHAL) sgs_vvel_sh(i,j,k) = sgs_vvel_5d(i,flip(k),j,IENS) !- Export entrainment rates used by GF if (IENS==DEEP) entr_dp(i,j,k) = entr5d(i,flip(k),j,IENS) @@ -997,7 +1006,7 @@ SUBROUTINE GF2020_DRV(mxp,myp,mzp,mtp,nmp & ,temp & ,press & ,rvap & - ,mp_ice & + ,mp_ice & ,mp_liq & ,mp_cf & ,curr_rvap & @@ -1053,6 +1062,7 @@ SUBROUTINE GF2020_DRV(mxp,myp,mzp,mtp,nmp & ,tup5d & ,conv_cld_fr5d & !-- for debug/diagnostic + ,sgs_vvel_5d & ,AA0,AA1,AA2,AA3,AA1_BL,AA1_CIN,TAU_BL,TAU_EC) IMPLICIT NONE @@ -1155,7 +1165,8 @@ SUBROUTINE GF2020_DRV(mxp,myp,mzp,mtp,nmp & ,clwup5d & ,tup5d & ,conv_cld_fr5d -!--for debug +!--for diagnostics + REAL ,DIMENSION(mxp,mzp,myp,maxiens), INTENT(INOUT) :: sgs_vvel_5d REAL ,DIMENSION(mxp,myp) ,INTENT(INOUT) :: AA0,AA1,AA2,AA3,AA1_BL,AA1_CIN,TAU_BL,TAU_EC !---------------------------------------------------------------------- @@ -1168,8 +1179,6 @@ SUBROUTINE GF2020_DRV(mxp,myp,mzp,mtp,nmp & REAL, DIMENSION (kts:kte,its:ite,jts:jte) :: Tpert_h,Tpert_v - REAL, DIMENSION (its:ite,jts:jte) :: rtgt - REAL, DIMENSION (its:ite,kts:kte) :: & zo,temp_old,qv_old,PO,US,VS,WS,rhoi,phil & ,temp_new_dp,qv_new_dp,temp_new_sh,qv_new_sh,z2d & @@ -1233,9 +1242,6 @@ SUBROUTINE GF2020_DRV(mxp,myp,mzp,mtp,nmp & JCOL = J !-- initialization - DO I= its,itf - rtgt(i,j)=1.0 - ENDDO DO i= its,itf ztexec (i) = 0.0 zqexec (i) = 0.0 @@ -1311,7 +1317,7 @@ SUBROUTINE GF2020_DRV(mxp,myp,mzp,mtp,nmp & kr=k !+1 !<<<< only kr=k ! !- heigths, current pressure, temp and water vapor mix ratio - zo (i,k) = zt(kr,i,j)*rtgt(i,j)+topt(i,j) + zo (i,k) = zt(kr,i,j)+topt(i,j) po (i,k) = press(kr,i,j)*1.e-2 !mbar temp_old(i,k) = temp(kr,i,j) @@ -1573,6 +1579,7 @@ SUBROUTINE GF2020_DRV(mxp,myp,mzp,mtp,nmp & ,tup5d (:,:,j,plume) & ,conv_cld_fr5d (:,:,j,plume) & !-- for debug/diag + ,sgs_vvel_5d (:,:,j,plume) & ,AA0(:,j),AA1(:,j),AA2(:,j),AA3(:,j),AA1_BL(:,j),AA1_CIN(:,j),TAU_BL(:,j),TAU_EC(:,j) & !-- for diag ,lightn_dens (:,j) & @@ -1580,6 +1587,10 @@ SUBROUTINE GF2020_DRV(mxp,myp,mzp,mtp,nmp & ,prfil_gf_2d & ,Tpert_2d & ) + !--- accumulate precip for each plume + DO i=its,itf + CONPRR(i,j)= CONPRR(i,j)+cprr4d(i,j,plume) + ENDDO ! Save ierr from this plume ! if (plume /= SHAL) then ! DO i=its,itf @@ -1603,54 +1614,47 @@ SUBROUTINE GF2020_DRV(mxp,myp,mzp,mtp,nmp & endif enddo loop1 ENDDO + !----------- check for negative water vapor mix ratio - DO i=its,itf + if (FIX_NEGATIVES) then + DO i=its,itf if(do_this_column(i,j) == 0) CYCLE do k = kts,ktf temp_tendqv(i,k)= outq (i,k,shal) + outq (i,k,deep) + outq (i,k,mid ) enddo - do k = kts,ktf distance(k)= qv_curr(i,k) + temp_tendqv(i,k) * dt enddo - if(minval(distance(kts:ktf)) < 0.) then zmax = MINLOC(distance(kts:ktf),1) - if( abs(temp_tendqv(i,zmax) * dt) < mintracer) then fixout_qv(i)= 0.999999 - !fixout_qv(i)= 0. else fixout_qv(i)= ( (smallerQV - qv_curr(i,zmax))) / (temp_tendqv(i,zmax) *dt) endif fixout_qv(i)=max(0.,min(fixout_qv(i),1.)) endif - ENDDO - !------------ feedback - !-- deep convection - DO i=its,itf - if(do_this_column(i,j) == 0) CYCLE - CONPRR(i,j)= (cprr4d(i,j,deep) + cprr4d(i,j,mid) + cprr4d(i,j,shal)) * fixout_qv(i) - ENDDO + ENDDO + endif + !------------ feedback !-- deep + shallow + mid convection DO i = its,itf if(do_this_column(i,j) == 0) CYCLE + !--- apply to convective precip + CONPRR(i,j)= CONPRR(i,j) * fixout_qv(i) DO k = kts,kte kr=k!+1 !- feedback the tendencies from convection RTHCUTEN (kr,i,j)= (outt (i,k,shal) + outt (i,k,deep) + outt (i,k,mid )) *fixout_qv(i) - RQVCUTEN (kr,i,j)= (outq (i,k,shal) + outq (i,k,deep) + outq (i,k,mid )) *fixout_qv(i) - RQCCUTEN (kr,i,j)= (outqc(i,k,shal) + outqc(i,k,deep) + outqc(i,k,mid )) *fixout_qv(i) - REVSU_GF (kr,i,j)= revsu_gf_2d(i,k)*fixout_qv(i) !-- already contains deep and mid amounts. - !---these arrays are only for the deep plume mode PRFIL_GF (kr,i,j)= prfil_gf_2d (i,k)*fixout_qv(i) !-- ice/liq prec flux of the deep plume ENDDO ENDDO + IF(USE_MOMENTUM_TRANSP > 0) THEN DO i = its,itf if(do_this_column(i,j) == 0) CYCLE @@ -1662,7 +1666,6 @@ SUBROUTINE GF2020_DRV(mxp,myp,mzp,mtp,nmp & ENDDO ENDIF - IF(APPLY_SUB_MP == 1) THEN DO i = its,itf if(do_this_column(i,j) == 0) CYCLE @@ -1683,34 +1686,29 @@ SUBROUTINE GF2020_DRV(mxp,myp,mzp,mtp,nmp & RCHEMCUTEN (:,kr,i,j)= (out_CHEM(:,i,k,deep) +out_CHEM(:,i,k,mid)+out_CHEM(:,i,k,shal)) *fixout_qv(i) ENDDO ENDDO - !- constrain positivity for tracers + if (FIX_NEGATIVES) then DO i = its,itf if(do_this_column(i,j) == 0) CYCLE - do ispc=1,mtp - do k=kts,ktf distance(k)= se_chem(ispc,i,k) + RCHEMCUTEN(ispc,k,i,j)* dt enddo - !-- fixer for mass of tracer IF(minval(distance(kts:ktf)) < 0.) THEN zmax = MINLOC(distance(kts:ktf),1) - if( abs(RCHEMCUTEN(ispc,zmax,i,j)*dt) < mintracer) then fixouts= 0.999999 - !fixouts= 0. else fixouts= ( (mintracer - se_chem(ispc,i,zmax))) / (RCHEMCUTEN(ispc,zmax,i,j)*dt) endif if(fixouts > 1. .or. fixouts <0.)fixouts=0. - RCHEMCUTEN(ispc,kts:ktf,i,j)=fixouts*RCHEMCUTEN(ispc,kts:ktf,i,j) ENDIF enddo ENDDO ENDIF + endif IF(CONVECTION_TRACER==1) THEN DO i = its,itf @@ -1835,9 +1833,10 @@ SUBROUTINE CUP_gf(its,ite,kts,kte ,itf,ktf, mtp, nmp & ,clfrac & !- for convective transport-end !- for debug/diag + ,SGS_VVEL_ & ,AA0_,AA1_,AA2_,AA3_,AA1_BL_,AA1_CIN_,TAU_BL_,TAU_EC_ & - ,lightn_dens & - ,revsu_gf & + ,lightn_dens & + ,revsu_gf & ,prfil_gf & ,Tpert & ) @@ -2107,10 +2106,12 @@ SUBROUTINE CUP_gf(its,ite,kts,kte ,itf,ktf, mtp, nmp & ,clfrac !---------------------------------------------------------------------- !-- debug/diag + real, dimension (its:ite,kts:kte),intent (inout) :: SGS_VVEL_ real, dimension (its:ite) ,intent (inout) :: & aa0_,aa1_,aa2_,aa3_,aa1_bl_,aa1_cin_,tau_bl_,tau_ec_ real, dimension (its:ite,kts:kte) :: dtdt,dqdt real :: s1,s2,q1,q2,rzenv,factor,CWV,entr_threshold,resten_H,resten_Q,resten_T + real :: tau_0, tau_1 integer :: status real :: alp0,beta1,beta2,dp_p,dp_m,delt1,delt2,delt_Tvv,wkf,ckf,wkflcl,rcount real, dimension (kts:kte,8) :: tend2d @@ -2201,11 +2202,11 @@ SUBROUTINE CUP_gf(its,ite,kts,kte ,itf,ktf, mtp, nmp & if (stochastic_sig(i) /= 1.0) then sig(i) = sig(i)**(stochastic_sig(i)*MAX(1.0,sig(i))) endif - sig(i)= max(0.1,min(sig(i),1.)) - if(sig(i).le.0.1)then - ierr(i)=1 - ierrc(i)='scale_dep renders convection insignificant' - endif + sig(i)= max(0.001,min(sig(i),1.)) + !if(sig(i).le.0.1)then + ! ierr(i)=1 + ! ierrc(i)='scale_dep renders convection insignificant' + !endif if(ierr(i) /= 0) cycle enddo endif @@ -2305,7 +2306,13 @@ SUBROUTINE CUP_gf(its,ite,kts,kte ,itf,ktf, mtp, nmp & rho_hydr(i,:) = 0.0 if(ierr(i) /= 0)cycle do k=kts,ktf - rho_hydr(i,k)=100.*(po_cup(i,k)-po_cup(i,k+1))/(zo_cup(i,k+1)-zo_cup(i,k))/g + dz = zo_cup(i,k+1)-zo_cup(i,k) + if (dz == 0.0) then + print *,'WARNING: Better fix needed for rho_hydr' + rho_hydr(i,k) = rho(i,k) + else + rho_hydr(i,k)=100.*(po_cup(i,k)-po_cup(i,k+1))/dz/g + end if !print*,"rhohidr=",k,rho_hydr(i,k),po_cup(i,k+1),zo_cup(i,k+1) enddo enddo @@ -2773,7 +2780,7 @@ SUBROUTINE CUP_gf(its,ite,kts,kte ,itf,ktf, mtp, nmp & call cup_up_vvel(vvel2d,vvel1d,zws,entr_rate,cd,zo,zo_cup,zuo,dbyo,GAMMAo_CUP,tn_cup & ,tempco,qco,qrco,qo,klcl,kbcon,ktop,ierr,itf,ktf,its,ite, kts,kte ) - + SGS_VVEL_ = vvel2d endif ! @@ -2890,6 +2897,7 @@ SUBROUTINE CUP_gf(its,ite,kts,kte ,itf,ktf, mtp, nmp & ! call cup_up_vvel(vvel2d,vvel1d,zws,entr_rate,cd,zo,zo_cup,zuo,dbyo,GAMMAo_CUP,tn_cup & ,tempco,qco,qrco,qo,klcl,kbcon,ktop,ierr,itf,ktf,its,ite, kts,kte) + SGS_VVEL_ = vvel2d endif !---- new rain @@ -3082,20 +3090,23 @@ SUBROUTINE CUP_gf(its,ite,kts,kte ,itf,ktf, mtp, nmp & IF(SGS_W_TIMESCALE == 0) THEN DO i=its,itf if(ierr(i) /= 0) cycle - !- time-scale cape removal from Bechtold et al. 2008 - dz = zo_cup(i,ktop(i))- zo_cup(i,kbcon(i)) + !- time-scale cape removal if(trim(cumulus)=='deep') tau_ecmwf(i)=tau_deep if(trim(cumulus)=='mid' ) tau_ecmwf(i)=tau_mid ENDDO ELSE DO i=its,itf if(ierr(i) /= 0) cycle - !- time-scale cape removal from Bechtold et al. 2008 - dz = zo_cup(i,ktop(i))- zo_cup(i,kbcon(i)) - tau_ecmwf(i)= 3600.0*( sigma(dx(i))) + & - 10800.0*(1.0-sigma(dx(i))) + & - (dz / vvel1d(i)) - tau_ecmwf(i)= max(dtime,tau_ecmwf(i)) + ! cloud depth (H) + dz = max(z_cup(i,ktop(i))-z_cup(i,kbcon(i)),1.e-16) + ! time-scale cape removal from Bechtold et al. 2008 + tau_0 = (dz/vvel1d(i))*(1.0+sig(i))*real(SGS_W_TIMESCALE) + ! prefered time-scale for increasing resolution + tau_1 = tau_deep*(1.0-sig(i)) + ! Combine + tau_ecmwf(i)= tau_0 + tau_1*(1.0-cnvfrc(i)) + ! Limit + tau_ecmwf(i)= max(dtime,min(tau_ecmwf(i),tau_deep)) ENDDO ENDIF DO i=its,itf @@ -3514,8 +3525,10 @@ SUBROUTINE CUP_gf(its,ite,kts,kte ,itf,ktf, mtp, nmp & zdo(i,k )*(hcdo(i,k )-heo_cup(i,k ) ) )*g/dp*edto(i) !---meltglac------------------------------------------------- - dellah(i,k) = dellah(i,k) + xlf*((1.-p_liq_ice(i,k))*0.5*(qrco(i,k+1)+qrco(i,k)) & - - melting(i,k))*g/dp + dellah(i,k) = dellah(i,k) - xlf*melting(i,k)*g/dp +! BUG2025 dellah(i,k) = dellah(i,k) + xlf*((1.-p_liq_ice(i,k))*0.5*(qrco(i,k+1)+qrco(i,k)) & +! BUG2025 - melting(i,k))*g/dp +! BUG2025 latent heat of freezing for qrco included in hco already !-- for output only subten_H(i,k) = -(zuo(i,k+1)*(-heo_cup(i,k+1)) - zuo(i,k)*(-heo_cup(i,k)))*g/dp & @@ -3678,8 +3691,10 @@ SUBROUTINE CUP_gf(its,ite,kts,kte ,itf,ktf, mtp, nmp & +(zdo(i,k+1)*(hcdo(i,k+1)-heo_cup(i,k+1) ) - & zdo(i,k )*(hcdo(i,k )-heo_cup(i,k ) ) )*g/dp*edto(i) - dellah(i,k) = dellah(i,k) + xlf*((1.-p_liq_ice(i,k))* & - 0.5*(qrco(i,k+1)+qrco(i,k)) - melting(i,k))*g/dp + dellah(i,k) = dellah(i,k) - xlf*melting(i,k)*g/dp +! BUG2025 dellah(i,k) = dellah(i,k) + xlf*((1.-p_liq_ice(i,k))* & +! BUG2025 0.5*(qrco(i,k+1)+qrco(i,k)) - melting(i,k))*g/dp +! BUG2025 latent heat of freezing for qrco included in hco already !--- for output only subten_H(i,k) = -(zuo(i,k+1)*(-heo_cup(i,k+1)) - zuo(i,k)*(-heo_cup(i,k)))*g/dp & @@ -3707,8 +3722,10 @@ SUBROUTINE CUP_gf(its,ite,kts,kte ,itf,ktf, mtp, nmp & dellah(i,k) =-( zuo(i,k+1)*hco (i,k+1) - zuo(i,k)*hco (i,k) )*g/dp & +( zdo(i,k+1)*hcdo(i,k+1) - zdo(i,k)*hcdo(i,k) )*g/dp*edto(i) - dellah(i,k) = dellah(i,k) + xlf*((1.-p_liq_ice(i,k))* & - 0.5*(qrco(i,k+1)+qrco(i,k)) - melting(i,k))*g/dp + dellah(i,k) = dellah(i,k) - xlf*melting(i,k)*g/dp +! BUG2025 dellah(i,k) = dellah(i,k) + xlf*((1.-p_liq_ice(i,k))* & +! BUG2025 0.5*(qrco(i,k+1)+qrco(i,k)) - melting(i,k))*g/dp +! BUG2025 latent heat of freezing for qrco included in hco already !- update with subsidence term from the FCT scheme dellah(i,k) = dellah(i,k) + sub_tend(1,k) !--- for output only @@ -8399,7 +8416,6 @@ subroutine cup_up_vvel(vvel2d,vvel1d,zws,entr_rate,cd ,z,z_cup,zu,dby,GAMMA_CUP, dz1m = dz1m + dz enddo vvel2d(i,k) = vs/(1.e-16+dz1m) - !if(k>ktop(i)-3)print*,"v2=",k,ktop(i),sqrt(vvel2d(i,k)),sqrt(vvel2d(i,ktop(i))) enddo enddo endif @@ -8410,12 +8426,6 @@ subroutine cup_up_vvel(vvel2d,vvel1d,zws,entr_rate,cd ,z,z_cup,zu,dby,GAMMA_CUP, if(ierr(i) /= 0)cycle vvel2d(i,:)= sqrt(max(0.1,vvel2d(i,:))) - if(maxval(vvel2d(i,:)) < 1.0) then - ierr(i)=54 - ! print*,"ierr=54",maxval(vvel2d(i,:)) - endif - - !-- sanity check where(vvel2d(i,:) < 1. ) vvel2d(i,:) = 1. where(vvel2d(i,:) > 20.) vvel2d(i,:) = 20. @@ -8425,7 +8435,6 @@ subroutine cup_up_vvel(vvel2d,vvel1d,zws,entr_rate,cd ,z,z_cup,zu,dby,GAMMA_CUP, do k= kbcon(i),ktop(i) dz=z_cup(i,k+1)-z_cup(i,k) vvel1d(i)=vvel1d(i)+vvel2d(i,k)*dz - !print*,"w=",k,z_cup(i,k),vvel2d(i,k) enddo vvel1d(i)=vvel1d(i)/(z_cup(i,ktop(i)+1)-z_cup(i,kbcon(i))+1.e-16) vvel1d(i)=max(1.,vvel1d(i)) @@ -8784,8 +8793,8 @@ SUBROUTINE cup_output_ens_3d(name,xff_shal,xff_mid,xf_ens,ierr,dellat,dellaq,del outtem (i,k) = outtem (i,k) * check_cons_F(i,1) outq (i,k) = outq (i,k) * check_cons_F(i,2) outqc (i,k) = outqc (i,k) * check_cons_F(i,3) - outu (i,k) = outu (i,k) * check_cons_F(i,4) - outv (i,k) = outv (i,k) * check_cons_F(i,5) + outu (i,k) = outu (i,k) * check_cons_F(i,4) + outv (i,k) = outv (i,k) * check_cons_F(i,5) ENDDO ! print*,"check=",real( (check_cons_F(i,3)+check_cons_F(i,2))/(check_cons_I(i,3)+check_cons_I(i,2)),4)!& @@ -11149,7 +11158,7 @@ function gammaBrams(a) result(g) ! find a "reasonable" infinity... ! we compute this integral indeed ! \int_0^M dt t^{x-1} e^{-t} - ! where M is such that M^{x-1} e^{-M} ≤ \epsilon + ! where M is such that M^{x-1} e^{-M} ? \epsilon infty = 1.0e4 do while ( intfuncgamma(infty, x) > small ) infty = infty * 10.0 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_BACM_1M_InterfaceMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_BACM_1M_InterfaceMod.F90 index f36ac241f..8a4bfa2b9 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_BACM_1M_InterfaceMod.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_BACM_1M_InterfaceMod.F90 @@ -1,7 +1,6 @@ ! $Id$ #include "MAPL_Generic.h" -!#define PDFDIAG 1 !============================================================================= !BOP @@ -247,6 +246,8 @@ subroutine BACM_1M_Initialize (MAPL, RC) call MAPL_GetResource( MAPL, CLDPARAMS%FR_AN_ICE, 'FR_AN_ICE:', DEFAULT= 0.0 ) call MAPL_GetResource( MAPL, CFPBL_EXP, 'CFPBL_EXP:', DEFAULT= 1 ) + call MAPL_GetResource( MAPL, DBZ_LIQUID_SKIN , 'DBZ_LIQUID_SKIN:' , DEFAULT= 0 , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource(MAPL, GRIDNAME, 'AGCM.GRIDNAME:', RC=STATUS) VERIFY_(STATUS) GRIDNAME = AdjustL(GRIDNAME) @@ -267,7 +268,6 @@ subroutine BACM_1M_Initialize (MAPL, RC) call MAPL_GetResource( MAPL, CNV_FRACTION_MIN, 'CNV_FRACTION_MIN:', DEFAULT= 500.0, RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource( MAPL, CNV_FRACTION_MAX, 'CNV_FRACTION_MAX:', DEFAULT= 1500.0, RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource( MAPL, CNV_FRACTION_EXP, 'CNV_FRACTION_EXP:', DEFAULT= 1.0, RC=STATUS); VERIFY_(STATUS) end subroutine BACM_1M_Initialize @@ -350,12 +350,6 @@ subroutine BACM_1M_Run (GC, IMPORT, EXPORT, CLOCK, RC) real, pointer, dimension(:,: ) :: LS_SNR, CN_SNR, AN_SNR, SC_SNR real, pointer, dimension(:,:,:) :: PTR3D real, pointer, dimension(:,: ) :: PTR2D -#ifdef PDFDIAG - real, pointer, dimension(:,:,:) :: PDF_W1, PDF_W2, PDF_SIGW1, PDF_SIGW2, & - PDF_QT1, PDF_QT2, PDF_SIGQT1, PDF_SIGQT2, & - PDF_TH1, PDF_TH2, PDF_SIGTH1, PDF_SIGTH2, & - PDF_RQTTH, PDF_RWTH, PDF_RWQT -#endif call ESMF_GridCompGet( GC, CONFIG=CF, RC=STATUS ) VERIFY_(STATUS) @@ -481,16 +475,6 @@ subroutine BACM_1M_Run (GC, IMPORT, EXPORT, CLOCK, RC) end do end do - call MAPL_GetPointer(EXPORT, PTR2D, 'ZLCL', RC=STATUS); VERIFY_(STATUS) - if (associated(PTR2D)) then - tmp2d = FIND_KLCL( T, Q, PLmb, IM, JM, LM ) - do J=1,JM - do I=1,IM - PTR2D(I,J) = ZL0(I,J,tmp2d(I,J)) - end do - end do - endif - ! Export Tendencies call MAPL_GetPointer(EXPORT, DQVDT_macro, 'DQVDT_macro' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(EXPORT, DQIDT_macro, 'DQIDT_macro' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) @@ -609,24 +593,6 @@ subroutine BACM_1M_Run (GC, IMPORT, EXPORT, CLOCK, RC) call MAPL_GetPointer(EXPORT, WTHV2, 'WTHV2' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(EXPORT, WQL, 'WQL' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) -#ifdef PDFDIAG - call MAPL_GetPointer(EXPORT, PDF_W1, 'PDF_W1' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, PDF_W2, 'PDF_W2' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, PDF_SIGW1, 'PDF_SIGW1' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, PDF_SIGW2, 'PDF_SIGW2' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, PDF_QT1, 'PDF_QT1' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, PDF_QT2, 'PDF_QT2' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, PDF_SIGQT1, 'PDF_SIGQT1' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, PDF_SIGQT2, 'PDF_SIGQT2' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, PDF_TH1, 'PDF_TH1' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, PDF_TH2, 'PDF_TH2' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, PDF_SIGTH1, 'PDF_SIGTH1' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, PDF_SIGTH2, 'PDF_SIGTH2' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, PDF_RQTTH, 'PDF_RQTTH' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, PDF_RWTH, 'PDF_RWTH' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, PDF_RWQT, 'PDF_RWQT' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) -#endif - call PROGNO_CLOUD ( & IM*JM, LM , & DT_MOIST , & @@ -725,12 +691,6 @@ subroutine BACM_1M_Run (GC, IMPORT, EXPORT, CLOCK, RC) VFALLRN_AN , VFALLRN_LS ,VFALLRN_CN ,VFALLRN_SC , & PDF_A, PDFITERS, & DQVDT_macro, DQLDT_macro, DQIDT_macro, DQADT_macro, & -#ifdef PDFDIAG - PDF_SIGW1, PDF_SIGW2, PDF_W1, PDF_W2, & - PDF_SIGTH1, PDF_SIGTH2, PDF_TH1, PDF_TH2, & - PDF_SIGQT1, PDF_SIGQT2, PDF_QT1, PDF_QT2, & - PDF_RQTTH, PDF_RWTH, PDF_RWQT, & -#endif WTHV2, WQL, & NACTL, & NACTI, & @@ -756,13 +716,13 @@ subroutine BACM_1M_Run (GC, IMPORT, EXPORT, CLOCK, RC) endwhere RAD_CF = TMP3D endif - call FILLQ2ZERO(RAD_QV, MASS, TMP2D) - call FILLQ2ZERO(RAD_QL, MASS, TMP2D) - call FILLQ2ZERO(RAD_QI, MASS, TMP2D) - call FILLQ2ZERO(RAD_QR, MASS, TMP2D) - call FILLQ2ZERO(RAD_QS, MASS, TMP2D) - call FILLQ2ZERO(RAD_QG, MASS, TMP2D) - call FILLQ2ZERO(RAD_CF, MASS, TMP2D) + call FILLQ2ZERO(RAD_QV, MASS, RC=STATUS); VERIFY_(STATUS) + call FILLQ2ZERO(RAD_QL, MASS, RC=STATUS); VERIFY_(STATUS) + call FILLQ2ZERO(RAD_QI, MASS, RC=STATUS); VERIFY_(STATUS) + call FILLQ2ZERO(RAD_QR, MASS, RC=STATUS); VERIFY_(STATUS) + call FILLQ2ZERO(RAD_QS, MASS, RC=STATUS); VERIFY_(STATUS) + call FILLQ2ZERO(RAD_QG, MASS, RC=STATUS); VERIFY_(STATUS) + call FILLQ2ZERO(RAD_CF, MASS, RC=STATUS); VERIFY_(STATUS) RAD_QL = MIN( RAD_QL , 0.001 ) ! Still a ridiculously large RAD_QI = MIN( RAD_QI , 0.001 ) ! value. RAD_QR = MIN( RAD_QR , 0.01 ) ! value. @@ -821,7 +781,7 @@ subroutine BACM_1M_Run (GC, IMPORT, EXPORT, CLOCK, RC) call MAPL_GetPointer(EXPORT, PTR3D, 'DBZ' , RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(EXPORT, PTR2D, 'DBZ_MAX', RC=STATUS); VERIFY_(STATUS) if (associated(PTR3D) .OR. associated(PTR2D)) then - call CALCDBZ(TMP3D,100*PLmb,T,Q,RAD_QR*RAD_CF,RAD_QS*RAD_CF,RAD_QG*RAD_CF,IM,JM,LM,1,0,0) + call CALCDBZ(TMP3D,100*PLmb,T,Q,RAD_QR*RAD_CF,RAD_QS*RAD_CF,RAD_QG*RAD_CF,IM,JM,LM,1,0,DBZ_LIQUID_SKIN) if (associated(PTR3D)) PTR3D = TMP3D if (associated(PTR2D)) then PTR2D=-9999.0 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_GFDL_1M_InterfaceMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_GFDL_1M_InterfaceMod.F90 index 4e90dbdd1..0059469bd 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_GFDL_1M_InterfaceMod.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_GFDL_1M_InterfaceMod.F90 @@ -1,7 +1,6 @@ ! $Id$ #include "MAPL_Generic.h" -!#define PDFDIAG 1 !============================================================================= !BOP @@ -16,7 +15,8 @@ module GEOS_GFDL_1M_InterfaceMod use GEOS_UtilsMod use GEOSmoist_Process_Library use Aer_Actv_Single_Moment - use gfdl2_cloud_microphys_mod + use gfdl2_cloud_microphys_mod, only : gfdl_cloud_microphys_init, gfdl_cloud_microphys_driver, ICE_LSC_VFALL_PARAM, ICE_CNV_VFALL_PARAM + use gfdl_mp_mod, only : gfdl_mp_init, gfdl_mp_driver, do_hail, ifflag implicit none @@ -44,6 +44,7 @@ module GEOS_GFDL_1M_InterfaceMod ! Local resource variables real :: TURNRHCRIT_PARAM + real :: MIN_RH_UNSTABLE, MIN_RH_STABLE real :: TAU_EVAP, CCW_EVAP_EFF real :: TAU_SUBL, CCI_EVAP_EFF integer :: PDFSHAPE @@ -58,6 +59,9 @@ module GEOS_GFDL_1M_InterfaceMod logical :: LHYDROSTATIC logical :: LPHYS_HYDROSTATIC logical :: LMELTFRZ + real :: GFDL_MP_PLID + + logical :: GFDL_MP3 public :: GFDL_1M_Setup, GFDL_1M_Initialize, GFDL_1M_Run @@ -207,8 +211,9 @@ subroutine GFDL_1M_Setup (GC, CF, RC) end subroutine GFDL_1M_Setup -subroutine GFDL_1M_Initialize (MAPL, RC) +subroutine GFDL_1M_Initialize (MAPL, CLOCK, RC) type (MAPL_MetaComp), intent(inout) :: MAPL + type (ESMF_Clock), intent(inout) :: CLOCK ! The clock integer, optional :: RC ! return code type (ESMF_Grid ) :: GRID @@ -221,27 +226,36 @@ subroutine GFDL_1M_Initialize (MAPL, RC) real, pointer, dimension(:,:,:) :: Q, QLLS, QLCN, QILS, QICN, QRAIN, QSNOW, QGRAUPEL - type(ESMF_VM) :: VM - integer :: comm + CHARACTER(len=ESMF_MAXSTR) :: errmsg + + real :: cf_max + real :: DBZ_DT + type(ESMF_Calendar) :: calendar + type(ESMF_Alarm) :: DBZ_RunAlarm + type(ESMF_TimeInterval) :: ringInterval + integer :: year, month, day, hh, mm, ss + + call MAPL_Get(MAPL, RUNALARM=ALARM, RC=STATUS );VERIFY_(STATUS) + call ESMF_AlarmGet(ALARM, RingInterval=TINT, RC=STATUS); VERIFY_(STATUS) + call ESMF_TimeIntervalGet(TINT, S_R8=DT_R8,RC=STATUS); VERIFY_(STATUS) + DT_MOIST = DT_R8 + DBZ_DT = max(DT_MOIST,900.0) + call MAPL_GetResource(MAPL, DBZ_DT, 'DBZ_DT:', default=DBZ_DT, RC=STATUS); VERIFY_(STATUS) + call ESMF_ClockGet(CLOCK, calendar=calendar, RC=STATUS); VERIFY_(STATUS) + call ESMF_TimeIntervalSet(ringInterval, S=nint(DBZ_DT), calendar=calendar, RC=STATUS); VERIFY_(STATUS) + DBZ_RunAlarm = ESMF_AlarmCreate(Clock = CLOCK, & + Name = 'DBZ_RunAlarm',& + RingInterval = ringInterval, & + Sticky = .false. , RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource( MAPL, LHYDROSTATIC, Label="HYDROSTATIC:", default=.TRUE., RC=STATUS) - VERIFY_(STATUS) call MAPL_GetResource( MAPL, LPHYS_HYDROSTATIC, Label="PHYS_HYDROSTATIC:", default=.TRUE., RC=STATUS) VERIFY_(STATUS) + LHYDROSTATIC = LPHYS_HYDROSTATIC call MAPL_GetResource( MAPL, LMELTFRZ, Label="MELTFRZ:", default=.TRUE., RC=STATUS) VERIFY_(STATUS) call MAPL_Get ( MAPL, INTERNAL_ESMF_STATE=INTERNAL, RC=STATUS ) VERIFY_(STATUS) - call MAPL_Get( MAPL, & - RUNALARM = ALARM, & - INTERNAL_ESMF_STATE=INTERNAL, & - RC=STATUS ) - VERIFY_(STATUS) - - call ESMF_AlarmGet(ALARM, RingInterval=TINT, RC=STATUS); VERIFY_(STATUS) - call ESMF_TimeIntervalGet(TINT, S_R8=DT_R8,RC=STATUS); VERIFY_(STATUS) - DT_MOIST = DT_R8 call MAPL_GetPointer(INTERNAL, Q, 'Q' , RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(INTERNAL, QRAIN, 'QRAIN' , RC=STATUS); VERIFY_(STATUS) @@ -252,20 +266,43 @@ subroutine GFDL_1M_Initialize (MAPL, RC) call MAPL_GetPointer(INTERNAL, QILS, 'QILS' , RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(INTERNAL, QICN, 'QICN' , RC=STATUS); VERIFY_(STATUS) - call ESMF_VMGetCurrent(VM, _RC) - call ESMF_VMGet(VM, mpiCommunicator=comm, _RC) + call MAPL_GetResource( MAPL, GFDL_MP3, Label="GFDL_MP3:", default=.TRUE., RC=STATUS); VERIFY_(STATUS) + if (DT_R8 <= 150.0) then + do_hail = .true. + ifflag = 1 + endif - call gfdl_cloud_microphys_init(comm) - call WRITE_PARALLEL ("INITIALIZED GFDL_1M microphysics in non-generic GC INIT") + if (GFDL_MP3) then + call gfdl_mp_init(LHYDROSTATIC) + call WRITE_PARALLEL ("INITIALIZED GFDL_1M gfdl_mp v3 in non-generic GC INIT") + else + call gfdl_cloud_microphys_init() + call WRITE_PARALLEL ("INITIALIZED GFDL_1M gfdl_cloud_microphys in non-generic GC INIT") + endif call MAPL_GetResource( MAPL, SH_MD_DP , 'SH_MD_DP:' , DEFAULT= .TRUE., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource( MAPL, DBZ_LIQUID_SKIN , 'DBZ_LIQUID_SKIN:' , DEFAULT= DBZ_LIQUID_SKIN, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource( MAPL, DBZ_VAR_INTERCP , 'DBZ_VAR_INTERCP:' , DEFAULT= DBZ_VAR_INTERCP, RC=STATUS); VERIFY_(STATUS) + + + refl10cm_allow_wet_graupel = .false. + call MAPL_GetResource( MAPL, refl10cm_allow_wet_graupel , 'refl10cm_allow_wet_graupel:' , & + DEFAULT= refl10cm_allow_wet_graupel, RC=STATUS); VERIFY_(STATUS) + refl10cm_allow_wet_snow = .true. + call MAPL_GetResource( MAPL, refl10cm_allow_wet_snow , 'refl10cm_allow_wet_snow:' , & + DEFAULT= refl10cm_allow_wet_snow, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource( MAPL, TURNRHCRIT_PARAM, 'TURNRHCRIT:' , DEFAULT= -9999., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource( MAPL, MIN_RH_UNSTABLE , 'MIN_RH_UNSTABLE:' , DEFAULT= 0.9125, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource( MAPL, MIN_RH_STABLE , 'MIN_RH_STABLE:' , DEFAULT= 0.9125, RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource( MAPL, PDFSHAPE , 'PDFSHAPE:' , DEFAULT= 1 , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource( MAPL, ICE_LSC_VFALL_PARAM, 'ICE_LSC_VFALL_PARAM:',DEFAULT= 1, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource( MAPL, ICE_CNV_VFALL_PARAM, 'ICE_CNV_VFALL_PARAM:',DEFAULT= 2, RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource( MAPL, ANV_ICEFALL , 'ANV_ICEFALL:' , DEFAULT= 1.0 , RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource( MAPL, LS_ICEFALL , 'LS_ICEFALL:' , DEFAULT= 1.0 , RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource( MAPL, LIQ_RADII_PARAM , 'LIQ_RADII_PARAM:' , DEFAULT= 2 , RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource( MAPL, ICE_RADII_PARAM , 'ICE_RADII_PARAM:' , DEFAULT= 1 , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource( MAPL, LIQ_RADII_PARAM , 'LIQ_RADII_PARAM:' , DEFAULT= 1 , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource( MAPL, ICE_RADII_PARAM , 'ICE_RADII_PARAM:' , DEFAULT= 2 , RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource( MAPL, FAC_RI , 'FAC_RI:' , DEFAULT= 1.0 , RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource( MAPL, MIN_RI , 'MIN_RI:' , DEFAULT= 5.e-6, RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource( MAPL, MAX_RI , 'MAX_RI:' , DEFAULT=100.e-6, RC=STATUS); VERIFY_(STATUS) @@ -273,17 +310,22 @@ subroutine GFDL_1M_Initialize (MAPL, RC) call MAPL_GetResource( MAPL, MIN_RL , 'MIN_RL:' , DEFAULT= 2.5e-6, RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource( MAPL, MAX_RL , 'MAX_RL:' , DEFAULT=60.0e-6, RC=STATUS); VERIFY_(STATUS) - CCW_EVAP_EFF = 1.e-2 - if (do_evap) CCW_EVAP_EFF = 0.0 ! Evap done inside GFDL-MP + CCW_EVAP_EFF = 4.e-3 call MAPL_GetResource( MAPL, CCW_EVAP_EFF, 'CCW_EVAP_EFF:', DEFAULT= CCW_EVAP_EFF, RC=STATUS); VERIFY_(STATUS) - CCI_EVAP_EFF = 1.e-2 - if (do_subl) CCI_EVAP_EFF = 0.0 ! Subl done inside GFDL-MP + CCI_EVAP_EFF = 4.e-3 call MAPL_GetResource( MAPL, CCI_EVAP_EFF, 'CCI_EVAP_EFF:', DEFAULT= CCI_EVAP_EFF, RC=STATUS); VERIFY_(STATUS) + ! variations on max CAPE for convective fraction as timestep changes with resolution + cf_max = 100.0 * NINT( (1500.0+2500.0*(1-(DT_R8-30.0)/(900.0-30.0))**2) /100.0 ) + if (cf_max < 1500.0) cf_max = 1500.0 + if (cf_max > 4000.0) cf_max = 4000.0 call MAPL_GetResource( MAPL, CNV_FRACTION_MIN, 'CNV_FRACTION_MIN:', DEFAULT= 500.0, RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource( MAPL, CNV_FRACTION_MAX, 'CNV_FRACTION_MAX:', DEFAULT= 1500.0, RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource( MAPL, CNV_FRACTION_EXP, 'CNV_FRACTION_EXP:', DEFAULT= 1.0, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource( MAPL, CNV_FRACTION_MAX, 'CNV_FRACTION_MAX:', DEFAULT= cf_max, RC=STATUS); VERIFY_(STATUS) + + call MAPL_GetResource( MAPL, GFDL_MP_PLID , 'GFDL_MP_PLID:' , DEFAULT= -999.0, RC=STATUS); VERIFY_(STATUS) + + call init_refl10cm() end subroutine GFDL_1M_Initialize @@ -303,13 +345,14 @@ subroutine GFDL_1M_Run (GC, IMPORT, EXPORT, CLOCK, RC) type (ESMF_TimeInterval) :: TINT real(ESMF_KIND_R8) :: DT_R8 real :: DT_MOIST + logical :: alarm_is_ringing ! Internals real, pointer, dimension(:,:,:) :: Q, QLLS, QLCN, CLLS, CLCN, QILS, QICN, QRAIN, QSNOW, QGRAUPEL real, pointer, dimension(:,:,:) :: NACTL, NACTI ! Imports real, pointer, dimension(:,:,:) :: ZLE, PLE, T, U, V, W, KH - real, pointer, dimension(:,:) :: AREA, FRLAND, TS, DTSX, SH, EVAP, KPBLSC + real, pointer, dimension(:,:) :: AREA, PHIS, FRLAND, TS, DTSX, SH, EVAP, KPBLSC real, pointer, dimension(:,:,:) :: SL2, SL3, QT2, QT3, W2, W3, SLQT, WQT, WQL, WSL, PDF_A real, pointer, dimension(:,:,:) :: WTHV2 real, pointer, dimension(:,:,:) :: OMEGA @@ -321,12 +364,16 @@ subroutine GFDL_1M_Run (GC, IMPORT, EXPORT, CLOCK, RC) real, allocatable, dimension(:,:,:) :: DQST3, QST3 real, allocatable, dimension(:,:,:) :: DQVDTmic, DQLDTmic, DQRDTmic, DQIDTmic, & DQSDTmic, DQGDTmic, DQADTmic, & - DUDTmic, DVDTmic, DTDTmic + DUDTmic, DVDTmic, DTDTmic, DWDTmic + integer, allocatable, dimension(:,:):: KLCL + integer :: KLID real, allocatable, dimension(:,:,:) :: TMP3D real, allocatable, dimension(:,:) :: TMP2D - integer, allocatable, dimension(:,:) :: KLCL + real, allocatable, dimension(:) :: TMP1D ! Exports - real, pointer, dimension(:,: ) :: PRCP_RAIN, PRCP_SNOW, PRCP_ICE, PRCP_GRAUPEL + real, pointer, dimension(:,: ) :: LONS, LATS + real, pointer, dimension(:,:,:) :: NACTR + real, pointer, dimension(:,: ) :: PRCP_WATER, PRCP_RAIN, PRCP_SNOW, PRCP_ICE, PRCP_GRAUPEL real, pointer, dimension(:,: ) :: LS_PRCP, LS_SNR, ICE, FRZR, CNV_FRC, SRF_TYPE real, pointer, dimension(:,:,:) :: DQVDT_macro, DQIDT_macro, DQLDT_macro, DQADT_macro, DQRDT_macro, DQSDT_macro, DQGDT_macro real, pointer, dimension(:,:,:) :: DUDT_macro, DVDT_macro, DTDT_macro @@ -336,28 +383,35 @@ subroutine GFDL_1M_Run (GC, IMPORT, EXPORT, CLOCK, RC) real, pointer, dimension(:,:,:) :: CLDREFFL, CLDREFFI real, pointer, dimension(:,:,:) :: EVAPC, SUBLC real, pointer, dimension(:,:,:) :: RHX, REV_LS, RSU_LS + real, pointer, dimension(:,:,:) :: VFALL_ICE, VFALL_SNOW, VFALL_GRAUPEL, VFALL_RAIN real, pointer, dimension(:,:,:) :: PFL_LS, PFL_AN real, pointer, dimension(:,:,:) :: PFI_LS, PFI_AN + real, pointer, dimension(:,:,:) :: PFR_LS, PFS_LS, PFG_LS real, pointer, dimension(:,:,:) :: PDFITERS real, pointer, dimension(:,:,:) :: RHCRIT3D + real, pointer, dimension(:,:,:) :: CNV_PRC3 real, pointer, dimension(:,:) :: EIS, LTS real, pointer, dimension(:,:) :: DBZ_MAX, DBZ_1KM, DBZ_TOP, DBZ_M10C + real, pointer, dimension(:,:) :: DBZ_MAX_R, DBZ_MAX_S, DBZ_MAX_G + real, pointer, dimension(:,:,:) :: DQVDT_FILL + real, pointer, dimension(:,:,:) :: DQLLSDT_FILL + real, pointer, dimension(:,:,:) :: DQLCNDT_FILL + real, pointer, dimension(:,:,:) :: DQILSDT_FILL + real, pointer, dimension(:,:,:) :: DQICNDT_FILL + real, pointer, dimension(:,:,:) :: DQRDT_FILL + real, pointer, dimension(:,:,:) :: DQSDT_FILL + real, pointer, dimension(:,:,:) :: DQGDT_FILL real, pointer, dimension(:,:,:) :: PTR3D real, pointer, dimension(:,: ) :: PTR2D -#ifdef PDFDIAG - real, pointer, dimension(:,:,:) :: PDF_W1, PDF_W2, PDF_SIGW1, PDF_SIGW2, & - PDF_QT1, PDF_QT2, PDF_SIGQT1, PDF_SIGQT2, & - PDF_TH1, PDF_TH2, PDF_SIGTH1, PDF_SIGTH2, & - PDF_RQTTH, PDF_RWTH, PDF_RWQT -#endif ! Local variables - real :: facEIS + real :: facEIS, rand1 real :: minrhcrit, turnrhcrit, ALPHA, RHCRIT integer :: IM,JM,LM integer :: I, J, L + type( ESMF_VM ) :: VMG - call ESMF_GridCompGet( GC, CONFIG=CF, RC=STATUS ) + call ESMF_GridCompGet( GC, VM=VMG, CONFIG=CF, RC=STATUS ) VERIFY_(STATUS) ! Get my internal MAPL_Generic state @@ -372,6 +426,8 @@ subroutine GFDL_1M_Run (GC, IMPORT, EXPORT, CLOCK, RC) !----------------------------------- call MAPL_Get( MAPL, IM=IM, JM=JM, LM=LM, & + LATS = LATS, & ! These are in radians + LONS = LONS, & ! These are in radians RUNALARM = ALARM, & CF = CF, & INTERNAL_ESMF_STATE=INTERNAL, & @@ -420,6 +476,7 @@ subroutine GFDL_1M_Run (GC, IMPORT, EXPORT, CLOCK, RC) call MAPL_GetPointer(IMPORT, SH, 'SH' , RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(IMPORT, EVAP, 'EVAP' , RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(IMPORT, OMEGA, 'OMEGA' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(IMPORT, PHIS, 'PHIS' , RC=STATUS); VERIFY_(STATUS) ! Allocatables ! Edge variables @@ -449,9 +506,11 @@ subroutine GFDL_1M_Run (GC, IMPORT, EXPORT, CLOCK, RC) ALLOCATE ( DUDTmic(IM,JM,LM ) ) ALLOCATE ( DVDTmic(IM,JM,LM ) ) ALLOCATE ( DTDTmic(IM,JM,LM ) ) + ALLOCATE ( DWDTmic(IM,JM,LM ) ) ! 2D Variables - ALLOCATE ( KLCL (IM,JM) ) - ALLOCATE ( TMP2D (IM,JM) ) + ALLOCATE ( TMP2D (IM,JM ) ) + ! 1D Variables + ALLOCATE ( TMP1D ( LM ) ) ! Derived States PLEmb = PLE*.01 @@ -467,6 +526,12 @@ subroutine GFDL_1M_Run (GC, IMPORT, EXPORT, CLOCK, RC) iMASS = 1.0/MASS U0 = U V0 = V + KLCL = FIND_KLCL( T, Q, PLmb, IM, JM, LM ) + if (GFDL_MP_PLID > 0.0) then + KLID = FIND_KLID( GFDL_MP_PLID, PLE, RC=STATUS ); VERIFY_(STATUS) + else + KLID = 1 + endif ! Export and/or scratch Variable call MAPL_GetPointer(EXPORT, RAD_CF, 'FCLD', ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) @@ -484,6 +549,7 @@ subroutine GFDL_1M_Run (GC, IMPORT, EXPORT, CLOCK, RC) ! Exports required below call MAPL_GetPointer(EXPORT, EVAPC, 'EVAPC' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(EXPORT, SUBLC, 'SUBLC' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, PRCP_WATER, 'PRCP_WATER' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(EXPORT, PRCP_RAIN, 'PRCP_RAIN' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(EXPORT, PRCP_SNOW, 'PRCP_SNOW' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(EXPORT, PRCP_ICE, 'PRCP_ICE' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) @@ -500,9 +566,16 @@ subroutine GFDL_1M_Run (GC, IMPORT, EXPORT, CLOCK, RC) call MAPL_GetPointer(EXPORT, PFL_LS, 'PFL_LS' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(EXPORT, PFI_AN, 'PFI_AN' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(EXPORT, PFI_LS, 'PFI_LS' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, PFR_LS, 'PFR_LS' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, PFS_LS, 'PFS_LS' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, PFG_LS, 'PFG_LS' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(EXPORT, WTHV2, 'WTHV2' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(EXPORT, WQL, 'WQL' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(EXPORT, PDFITERS, 'PDFITERS', ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, VFALL_ICE, 'VFALL_ICE' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, VFALL_SNOW, 'VFALL_SNOW' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, VFALL_GRAUPEL, 'VFALL_GRAUPEL', ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, VFALL_RAIN, 'VFALL_RAIN' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) ! Unused Exports (forced to 0.0) call MAPL_GetPointer(EXPORT, PTR2D, 'CN_PRCP' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS); PTR2D=0.0 call MAPL_GetPointer(EXPORT, PTR2D, 'AN_PRCP' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS); PTR2D=0.0 @@ -510,20 +583,9 @@ subroutine GFDL_1M_Run (GC, IMPORT, EXPORT, CLOCK, RC) call MAPL_GetPointer(EXPORT, PTR2D, 'CN_SNR' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS); PTR2D=0.0 call MAPL_GetPointer(EXPORT, PTR2D, 'AN_SNR' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS); PTR2D=0.0 call MAPL_GetPointer(EXPORT, PTR2D, 'SC_SNR' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS); PTR2D=0.0 - ! Lowe tropospheric stability and estimated inversion strength + ! Lower tropospheric stability and estimated inversion strength from MoistGC call MAPL_GetPointer(EXPORT, LTS, 'LTS' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(EXPORT, EIS, 'EIS' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - KLCL = FIND_KLCL( T, Q, PLmb, IM, JM, LM ) - call MAPL_GetPointer(EXPORT, PTR2D, 'ZLCL', RC=STATUS); VERIFY_(STATUS) - if (associated(PTR2D)) then - do J=1,JM - do I=1,IM - PTR2D(I,J) = ZL0(I,J,KLCL(I,J)) - end do - end do - endif - TMP3D = (100.0*PLmb/MAPL_P00)**(MAPL_KAPPA) - call FIND_EIS(T/TMP3D, QST3, T, ZL0, PLEmb, KLCL, IM, JM, LM, LTS, EIS) call MAPL_TimerOn(MAPL,"---CLDMACRO") call MAPL_GetPointer(EXPORT, DQVDT_macro, 'DQVDT_macro' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) @@ -547,25 +609,11 @@ subroutine GFDL_1M_Run (GC, IMPORT, EXPORT, CLOCK, RC) DQSDT_macro=QSNOW DQGDT_macro=QGRAUPEL -#ifdef PDFDIAG - call MAPL_GetPointer(EXPORT, PDF_W1, 'PDF_W1' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, PDF_W2, 'PDF_W2' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, PDF_SIGW1, 'PDF_SIGW1' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, PDF_SIGW2, 'PDF_SIGW2' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, PDF_QT1, 'PDF_QT1' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, PDF_QT2, 'PDF_QT2' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, PDF_SIGQT1, 'PDF_SIGQT1' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, PDF_SIGQT2, 'PDF_SIGQT2' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, PDF_TH1, 'PDF_TH1' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, PDF_TH2, 'PDF_TH2' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, PDF_SIGTH1, 'PDF_SIGTH1' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, PDF_SIGTH2, 'PDF_SIGTH2' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, PDF_RQTTH, 'PDF_RQTTH' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, PDF_RWTH, 'PDF_RWTH' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, PDF_RWQT, 'PDF_RWQT' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) -#endif - - + ! Clear exports + EVAPC = 0.0 + SUBLC = 0.0 + PDFITERS = 0.0 + RHX = 0.0 ! Include shallow precip condensates if present call MAPL_GetPointer(EXPORT, PTR3D, 'SHLW_PRC3', ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) if (associated(PTR3D)) then @@ -580,10 +628,27 @@ subroutine GFDL_1M_Run (GC, IMPORT, EXPORT, CLOCK, RC) do L=1,LM do J=1,JM do I=1,IM - ! Send the condensates through the pdf after convection + ! cleanup clouds + call FIX_UP_CLOUDS( Q(I,J,L), T(I,J,L), QLLS(I,J,L), QILS(I,J,L), CLLS(I,J,L), & + QLCN(I,J,L), QICN(I,J,L), CLCN(I,J,L), & + REMOVE_CLOUDS=(L < KLID) ) + ! Debug large temperature values + if ( DEBUG_TQ_ERRORS .AND. (T(I,J,L) > 333.0) ) then + print *, "Temperature spike detected : ", T(I,J,L) + print *, " BEFORE any GFDL Procsess " + print *, " Latitude =", LATS(I,J)*180.0/MAPL_PI + print *, " Longitude =", LONS(I,J)*180.0/MAPL_PI + print *, " Pressure (mb) =", PLmb(I,J,L) + print *, " CLLS=", CLLS(I,J,L), "CLCN=", CLCN(I,J,L) + print *, " QV=", Q(I,J,L), " QL=", QLLS(I,J,L)+QLCN(I,J,L), " QI=", QILS(I,J,L)+QICN(I,J,L) + print *, " QR=", QRAIN(I,J,L), " QS=", QSNOW(I,J,L), " QG=", QGRAUPEL(I,J,L) + endif + ! Send the condensates through the pdf after convection [0:1 , unstable:stable] facEIS = MAX(0.0,MIN(1.0,EIS(I,J)/10.0))**2 - ! determine combined minrhcrit in stable/unstable regimes - minrhcrit = (1.0-dw_ocean)*(1.0-facEIS) + (1.0-dw_land)*facEIS + ! determine combined minrhcrit in unstable/stable regimes + minrhcrit = MIN_RH_UNSTABLE*(1.0-facEIS) + MIN_RH_STABLE*facEIS + ! include grid cell area scaling and limit RHcrit to > 70% + minrhcrit = 1.0 - min(0.3,(1.0-minrhcrit)*SQRT(SQRT(AREA(I,J)/1.e10))+0.01) if (TURNRHCRIT_PARAM <= 0.0) then ! determine the turn pressure using the LCL turnrhcrit = PLmb(I, J, KLCL(I,J)) - 250.0 ! 250mb above the LCL @@ -592,25 +657,25 @@ subroutine GFDL_1M_Run (GC, IMPORT, EXPORT, CLOCK, RC) endif ! Use Slingo-Ritter (1985) formulation for critical relative humidity RHCRIT = 1.0 - ! lower turn from maxrhcrit=1.0 if (PLmb(i,j,l) .le. turnrhcrit) then - RHCRIT = minrhcrit + RHCRIT = minrhcrit else - if (L.eq.LM) then - RHCRIT = 1.0 - else - RHCRIT = minrhcrit + (1.0-minrhcrit)/(19.) * & - ((atan( (2.*(PLmb(i,j,l)-turnrhcrit)/(PLEmb(i,j,LM)-turnrhcrit)-1.) * & - tan(20.*MAPL_PI/21.-0.5*MAPL_PI) ) + 0.5*MAPL_PI) * 21./MAPL_PI - 1.) - endif + if (L.eq.LM) then + RHCRIT = 1.0 + else + RHCRIT = minrhcrit + (1.0-minrhcrit)/(19.) * & + ((atan( (2.*(PLmb(i,j,l)-turnrhcrit)/(PLEmb(i,j,LM)-turnrhcrit)-1.) * & + tan(20.*MAPL_PI/21.-0.5*MAPL_PI) ) + 0.5*MAPL_PI) * 21./MAPL_PI - 1.) + endif endif - ! include grid cell area scaling and limit RHcrit to > 70% - ALPHA = max(0.0,min(0.30, (1.0-RHCRIT)*SQRT(SQRT(AREA(I,J)/1.e10)) ) ) + ! limit RHcrit to > 70% + ALPHA = max(0.0,min(0.30, (1.0-RHCRIT))) ! fill RHCRIT export if (associated(RHCRIT3D)) RHCRIT3D(I,J,L) = 1.0-ALPHA - ! Put condensates in touch with the PDF - if (.not. do_qa) then ! if not doing cloud pdf inside of GFDL-MP - call hystpdf( & + ! Do CLOUD MACRO below the pressure lid + if (L >= KLID) then + ! Put condensates in touch with the PDF + call hystpdf( & DT_MOIST , & ALPHA , & PDFSHAPE , & @@ -639,29 +704,11 @@ subroutine GFDL_1M_Run (GC, IMPORT, EXPORT, CLOCK, RC) SL3(I,J,L) , & PDF_A(I,J,L) , & PDFITERS(I,J,L), & -#ifdef PDFDIAG - PDF_SIGW1(I,J,L), & - PDF_SIGW2(I,J,L), & - PDF_W1(I,J,L), & - PDF_W2(I,J,L), & - PDF_SIGTH1(I,J,L), & - PDF_SIGTH2(I,J,L), & - PDF_TH1(I,J,L), & - PDF_TH2(I,J,L), & - PDF_SIGQT1(I,J,L), & - PDF_SIGQT2(I,J,L), & - PDF_QT1(I,J,L), & - PDF_QT2(I,J,L), & - PDF_RQTTH(I,J,L), & - PDF_RWTH(I,J,L), & - PDF_RWQT(I,J,L), & -#endif WTHV2(I,J,L) , & WQL(I,J,L) , & .false. , & USE_BERGERON) RHX(I,J,L) = Q(I,J,L)/GEOS_QSAT( T(I,J,L), PLmb(I,J,L) ) - endif if (LMELTFRZ) then ! meltfrz new condensates call MELTFRZ ( DT_MOIST , & @@ -670,12 +717,6 @@ subroutine GFDL_1M_Run (GC, IMPORT, EXPORT, CLOCK, RC) T(I,J,L) , & QLCN(I,J,L) , & QICN(I,J,L) ) - call MELTFRZ ( DT_MOIST , & - CNV_FRC(I,J) , & - SRF_TYPE(I,J), & - T(I,J,L) , & - QLLS(I,J,L) , & - QILS(I,J,L) ) endif ! evaporation for CN if (CCW_EVAP_EFF > 0.0) then ! else evap done inside GFDL @@ -715,12 +756,47 @@ subroutine GFDL_1M_Run (GC, IMPORT, EXPORT, CLOCK, RC) QST3(I,J,L) ) SUBLC(I,J,L) = ( Q(I,J,L) - SUBLC(I,J,L) ) / DT_MOIST endif + endif ! cleanup clouds - call FIX_UP_CLOUDS( Q(I,J,L), T(I,J,L), QLLS(I,J,L), QILS(I,J,L), CLLS(I,J,L), QLCN(I,J,L), QICN(I,J,L), CLCN(I,J,L) ) + call FIX_UP_CLOUDS( Q(I,J,L), T(I,J,L), QLLS(I,J,L), QILS(I,J,L), CLLS(I,J,L), & + QLCN(I,J,L), QICN(I,J,L), CLCN(I,J,L), & + REMOVE_CLOUDS=(L < KLID) ) + if ( DEBUG_TQ_ERRORS .AND. (T(I,J,L) > 333.0) ) then + print *, "Temperature spike detected : ", T(I,J,L) + print *, " AFTER cldmacro in GFDL-MP " + print *, " Latitude =", LATS(I,J)*180.0/MAPL_PI + print *, " Longitude =", LONS(I,J)*180.0/MAPL_PI + print *, " Pressure (mb) =", PLmb(I,J,L) + print *, " CLLS=", CLLS(I,J,L), "CLCN=", CLCN(I,J,L) + print *, " QV=", Q(I,J,L), " QL=", QLLS(I,J,L)+QLCN(I,J,L), " QI=", QLLS(I,J,L)+QLCN(I,J,L) + print *, " QR=", QRAIN(I,J,L), " QS=", QSNOW(I,J,L), " QG=", QGRAUPEL(I,J,L) + endif end do ! IM loop end do ! JM loop end do ! LM loop + +! Get fill negative export pointers if requested +! ---------------------------------------------- + call MAPL_GetPointer(EXPORT, DQVDT_FILL, 'DQVDT_FILL_CLDMACRO', RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, DQLLSDT_FILL, 'DQLLSDT_FILL_CLDMACRO', RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, DQLCNDT_FILL, 'DQLCNDT_FILL_CLDMACRO', RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, DQILSDT_FILL, 'DQILSDT_FILL_CLDMACRO', RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, DQICNDT_FILL, 'DQICNDT_FILL_CLDMACRO', RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, DQRDT_FILL, 'DQRDT_FILL_CLDMACRO', RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, DQSDT_FILL, 'DQSDT_FILL_CLDMACRO', RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, DQGDT_FILL, 'DQGDT_FILL_CLDMACRO', RC=STATUS); VERIFY_(STATUS) +! Cleanup negative water species +! ------------------------------ + call FILLQ2ZERO( Q , MASS, DT=DT_MOIST, DQDT= DQVDT_FILL, WARNING_LABEL="QV After GFDL Cloud Macrophysics", VM=VMG, RC=STATUS); VERIFY_(STATUS) + call FILLQ2ZERO( QLLS , MASS, DT=DT_MOIST, DQDT=DQLLSDT_FILL, WARNING_LABEL="QLLS After GFDL Cloud Macrophysics", VM=VMG, RC=STATUS); VERIFY_(STATUS) + call FILLQ2ZERO( QLCN , MASS, DT=DT_MOIST, DQDT=DQLCNDT_FILL, WARNING_LABEL="QLCN After GFDL Cloud Macrophysics", VM=VMG, RC=STATUS); VERIFY_(STATUS) + call FILLQ2ZERO( QILS , MASS, DT=DT_MOIST, DQDT=DQILSDT_FILL, WARNING_LABEL="QILS After GFDL Cloud Macrophysics", VM=VMG, RC=STATUS); VERIFY_(STATUS) + call FILLQ2ZERO( QICN , MASS, DT=DT_MOIST, DQDT=DQICNDT_FILL, WARNING_LABEL="QICN After GFDL Cloud Macrophysics", VM=VMG, RC=STATUS); VERIFY_(STATUS) + call FILLQ2ZERO( QRAIN , MASS, DT=DT_MOIST, DQDT= DQRDT_FILL, WARNING_LABEL="QR After GFDL Cloud Macrophysics", VM=VMG, RC=STATUS); VERIFY_(STATUS) + call FILLQ2ZERO( QSNOW , MASS, DT=DT_MOIST, DQDT= DQSDT_FILL, WARNING_LABEL="QS After GFDL Cloud Macrophysics", VM=VMG, RC=STATUS); VERIFY_(STATUS) + call FILLQ2ZERO( QGRAUPEL, MASS, DT=DT_MOIST, DQDT= DQGDT_FILL, WARNING_LABEL="QG After GFDL Cloud Macrophysics", VM=VMG, RC=STATUS); VERIFY_(STATUS) + ! Update macrophysics tendencies DUDT_macro=( U - DUDT_macro)/DT_MOIST DVDT_macro=( V - DVDT_macro)/DT_MOIST @@ -790,9 +866,33 @@ subroutine GFDL_1M_Run (GC, IMPORT, EXPORT, CLOCK, RC) ! GRAUPEL RAD_QG = QGRAUPEL ! Run the driver + if (GFDL_MP3) then + call gfdl_mp_driver( & + ! Input water/cloud species and liquid+ice CCN NACTL & NACTI (#/m^3) + RAD_QV, RAD_QL, RAD_QR, RAD_QI, RAD_QS, RAD_QG, RAD_CF, NACTL, NACTI, & + ! Input fields + T, W, U, V, DZ, DP, & + ! Other inputs + DT_MOIST, RHCRIT3D, PHIS, CNV_FRC, EIS, AREA, SRF_TYPE, & + ! Output precipitates + PRCP_WATER, PRCP_RAIN, PRCP_ICE, PRCP_SNOW, PRCP_GRAUPEL, & + ! constant grid/time information + LHYDROSTATIC, 1, IM*JM, 1,LM, KLID, & + ! Output tendencies + DQVDTmic, DQLDTmic, DQRDTmic, DQIDTmic, & + DQSDTmic, DQGDTmic, DQADTmic, DTDTmic, DUDTmic, DVDTmic, DWDTmic, & + ! Output mass flux during sedimentation (Pa kg/kg) + PFL_LS(:,:,1:LM), PFR_LS(:,:,1:LM), PFI_LS(:,:,1:LM), PFS_LS(:,:,1:LM), PFG_LS(:,:,1:LM) ) + ! Convert cloud/precipitation flux exports from (mm/day) to (kg m-2 s-1) + PFL_LS = PFL_LS/(86400.0) + PFI_LS = PFI_LS/(86400.0) + PFR_LS = PFR_LS/(86400.0) + PFS_LS = PFS_LS/(86400.0) + PFG_LS = PFG_LS/(86400.0) + else call gfdl_cloud_microphys_driver( & - ! Input water/cloud species and liquid+ice CCN [NACTL+NACTI (#/m^3)] - RAD_QV, RAD_QL, RAD_QR, RAD_QI, RAD_QS, RAD_QG, RAD_CF, (NACTL+NACTI), & + ! Input water/cloud species and liquid+ice CCN NACTL & NACTI (#/m^3) + RAD_QV, RAD_QL, RAD_QR, RAD_QI, RAD_QS, RAD_QG, RAD_CF, NACTL, NACTI, & ! Output tendencies DQVDTmic, DQLDTmic, DQRDTmic, DQIDTmic, & DQSDTmic, DQGDTmic, DQADTmic, DTDTmic, & @@ -803,28 +903,71 @@ subroutine GFDL_1M_Run (GC, IMPORT, EXPORT, CLOCK, RC) RHCRIT3D, ANV_ICEFALL, LS_ICEFALL, & ! Output rain re-evaporation and sublimation REV_LS, RSU_LS, & + ! Output fall speeds + VFALL_ICE, VFALL_SNOW, VFALL_GRAUPEL, VFALL_RAIN, & ! Output precipitates PRCP_RAIN, PRCP_SNOW, PRCP_ICE, PRCP_GRAUPEL, & ! Output mass flux during sedimentation (Pa kg/kg) PFL_LS(:,:,1:LM), PFI_LS(:,:,1:LM), & ! constant grid/time information LHYDROSTATIC, LPHYS_HYDROSTATIC, & - 1,IM, 1,JM, 1,LM, 1, LM) + 1,IM, 1,JM, 1,LM, KLID, LM) + ! Convert precipitation fluxes from (Pa kg/kg) to (kg m-2 s-1) + PFL_LS = PFL_LS/(MAPL_GRAV*DT_MOIST) + PFI_LS = PFI_LS/(MAPL_GRAV*DT_MOIST) + PFR_LS = 0.0 + PFS_LS = 0.0 + PFG_LS = 0.0 + endif ! Apply tendencies T = T + DTDTmic * DT_MOIST U = U + DUDTmic * DT_MOIST V = V + DVDTmic * DT_MOIST ! Apply moist/cloud species tendencies - RAD_QV = RAD_QV + DQVDTmic * DT_MOIST - RAD_QL = RAD_QL + DQLDTmic * DT_MOIST - RAD_QR = RAD_QR + DQRDTmic * DT_MOIST - RAD_QI = RAD_QI + DQIDTmic * DT_MOIST - RAD_QS = RAD_QS + DQSDTmic * DT_MOIST - RAD_QG = RAD_QG + DQGDTmic * DT_MOIST + RAD_QV = MAX(RAD_QV + DQVDTmic * DT_MOIST, 1.e-12) + RAD_QL = MAX(RAD_QL + DQLDTmic * DT_MOIST, 0.0) + RAD_QR = MAX(RAD_QR + DQRDTmic * DT_MOIST, 0.0) + RAD_QI = MAX(RAD_QI + DQIDTmic * DT_MOIST, 0.0) + RAD_QS = MAX(RAD_QS + DQSDTmic * DT_MOIST, 0.0) + RAD_QG = MAX(RAD_QG + DQGDTmic * DT_MOIST, 0.0) RAD_CF = MIN(1.0,MAX(0.0,RAD_CF + DQADTmic * DT_MOIST)) + ! CleanUp Negative Water Vapor, cloud liquid/ice, and condensates + call FILLQ2ZERO(RAD_QV, MASS, WARNING_LABEL="QV After GFDL Driver", VM=VMG, RC=STATUS); VERIFY_(STATUS) + call FILLQ2ZERO(RAD_QL, MASS, WARNING_LABEL="QL After GFDL Driver", VM=VMG, RC=STATUS); VERIFY_(STATUS) + call FILLQ2ZERO(RAD_QI, MASS, WARNING_LABEL="QI After GFDL Driver", VM=VMG, RC=STATUS); VERIFY_(STATUS) + call FILLQ2ZERO(RAD_QR, MASS, WARNING_LABEL="QR After GFDL Driver", VM=VMG, RC=STATUS); VERIFY_(STATUS) + call FILLQ2ZERO(RAD_QS, MASS, WARNING_LABEL="QS After GFDL Driver", VM=VMG, RC=STATUS); VERIFY_(STATUS) + call FILLQ2ZERO(RAD_QG, MASS, WARNING_LABEL="QG After GFDL Driver", VM=VMG, RC=STATUS); VERIFY_(STATUS) + call FILLQ2ZERO(RAD_CF, MASS, WARNING_LABEL="QA After GFDL Driver", VM=VMG, RC=STATUS); VERIFY_(STATUS) ! Redistribute CN/LS CF/QL/QI call REDISTRIBUTE_CLOUDS(RAD_CF, RAD_QL, RAD_QI, CLCN, CLLS, QLCN, QLLS, QICN, QILS, RAD_QV, T) + ! Fill vapor/rain/snow/graupel state + Q = RAD_QV + QRAIN = RAD_QR + QSNOW = RAD_QS + QGRAUPEL = RAD_QG + ! Get fill negative export pointers if requested + ! ---------------------------------------------- + call MAPL_GetPointer(EXPORT, DQVDT_FILL, 'DQVDT_FILL_CLDMICRO', RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, DQLLSDT_FILL, 'DQLLSDT_FILL_CLDMICRO', RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, DQLCNDT_FILL, 'DQLCNDT_FILL_CLDMICRO', RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, DQILSDT_FILL, 'DQILSDT_FILL_CLDMICRO', RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, DQICNDT_FILL, 'DQICNDT_FILL_CLDMICRO', RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, DQRDT_FILL, 'DQRDT_FILL_CLDMICRO', RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, DQSDT_FILL, 'DQSDT_FILL_CLDMICRO', RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, DQGDT_FILL, 'DQGDT_FILL_CLDMICRO', RC=STATUS); VERIFY_(STATUS) + ! Cleanup negative water species + ! ------------------------------ + call FILLQ2ZERO( Q , MASS, DT=DT_MOIST, DQDT= DQVDT_FILL, WARNING_LABEL="QV After GFDL Cloud Microphysics", VM=VMG, RC=STATUS); VERIFY_(STATUS) + call FILLQ2ZERO( QLLS , MASS, DT=DT_MOIST, DQDT=DQLLSDT_FILL, WARNING_LABEL="QLLS After GFDL Cloud Microphysics", VM=VMG, RC=STATUS); VERIFY_(STATUS) + call FILLQ2ZERO( QLCN , MASS, DT=DT_MOIST, DQDT=DQLCNDT_FILL, WARNING_LABEL="QLCN After GFDL Cloud Microphysics", VM=VMG, RC=STATUS); VERIFY_(STATUS) + call FILLQ2ZERO( QILS , MASS, DT=DT_MOIST, DQDT=DQILSDT_FILL, WARNING_LABEL="QILS After GFDL Cloud Microphysics", VM=VMG, RC=STATUS); VERIFY_(STATUS) + call FILLQ2ZERO( QICN , MASS, DT=DT_MOIST, DQDT=DQICNDT_FILL, WARNING_LABEL="QICN After GFDL Cloud Microphysics", VM=VMG, RC=STATUS); VERIFY_(STATUS) + call FILLQ2ZERO( QRAIN , MASS, DT=DT_MOIST, DQDT= DQRDT_FILL, WARNING_LABEL="QR After GFDL Cloud Microphysics", VM=VMG, RC=STATUS); VERIFY_(STATUS) + call FILLQ2ZERO( QSNOW , MASS, DT=DT_MOIST, DQDT= DQSDT_FILL, WARNING_LABEL="QS After GFDL Cloud Microphysics", VM=VMG, RC=STATUS); VERIFY_(STATUS) + call FILLQ2ZERO( QGRAUPEL, MASS, DT=DT_MOIST, DQDT= DQGDT_FILL, WARNING_LABEL="QG After GFDL Cloud Microphysics", VM=VMG, RC=STATUS); VERIFY_(STATUS) ! Convert precip diagnostics from mm/day to kg m-2 s-1 + PRCP_WATER = MAX(PRCP_WATER / 86400.0, 0.0) PRCP_RAIN = MAX(PRCP_RAIN / 86400.0, 0.0) PRCP_SNOW = MAX(PRCP_SNOW / 86400.0, 0.0) PRCP_ICE = MAX(PRCP_ICE / 86400.0, 0.0) @@ -834,57 +977,69 @@ subroutine GFDL_1M_Run (GC, IMPORT, EXPORT, CLOCK, RC) LS_SNR = PRCP_SNOW ICE = PRCP_ICE + PRCP_GRAUPEL FRZR = 0.0 - ! Convert precipitation fluxes from (Pa kg/kg) to (kg m-2 s-1) - PFL_LS = PFL_LS/(MAPL_GRAV*DT_MOIST) - PFI_LS = PFI_LS/(MAPL_GRAV*DT_MOIST) ! Redistribute precipitation fluxes for chemistry TMP3D = MIN(1.0,MAX(QLCN/MAX(RAD_QL,1.E-8),0.0)) - PFL_AN(:,:,1:LM) = PFL_LS(:,:,1:LM) * TMP3D - PFL_LS(:,:,1:LM) = PFL_LS(:,:,1:LM) - PFL_AN(:,:,1:LM) + PFL_AN(:,:,1:LM) = (PFL_LS(:,:,1:LM)+PFR_LS(:,:,1:LM)) * TMP3D + PFL_LS(:,:,1:LM) = (PFL_LS(:,:,1:LM)+PFR_LS(:,:,1:LM)) - PFL_AN(:,:,1:LM) TMP3D = MIN(1.0,MAX(QICN/MAX(RAD_QI,1.E-8),0.0)) - PFI_AN(:,:,1:LM) = PFI_LS(:,:,1:LM) * TMP3D - PFI_LS(:,:,1:LM) = PFI_LS(:,:,1:LM) - PFI_AN(:,:,1:LM) - ! cleanup suspended precipitation condensates - call FIX_NEGATIVE_PRECIP(RAD_QR, RAD_QS, RAD_QG) - ! Fill vapor/rain/snow/graupel state - Q = RAD_QV - QRAIN = RAD_QR - QSNOW = RAD_QS - QGRAUPEL = RAD_QG - ! Radiation Coupling + PFI_AN(:,:,1:LM) = (PFI_LS(:,:,1:LM)+PFS_LS(:,:,1:LM)+PFG_LS(:,:,1:LM)) * TMP3D + PFI_LS(:,:,1:LM) = (PFI_LS(:,:,1:LM)+PFS_LS(:,:,1:LM)+PFG_LS(:,:,1:LM)) - PFI_AN(:,:,1:LM) + ! MeltFreeze and FixUp do L = 1, LM do J = 1, JM do I = 1, IM + if (LMELTFRZ) then + ! meltfrz new condensates + call MELTFRZ ( DT_MOIST , & + CNV_FRC(I,J) , & + SRF_TYPE(I,J), & + T(I,J,L) , & + QLCN(I,J,L) , & + QICN(I,J,L) ) + ! meltfrz new condensates + call MELTFRZ ( DT_MOIST , & + CNV_FRC(I,J) , & + SRF_TYPE(I,J), & + T(I,J,L) , & + QLLS(I,J,L) , & + QILS(I,J,L) ) + endif ! cleanup clouds - call FIX_UP_CLOUDS( Q(I,J,L), T(I,J,L), QLLS(I,J,L), QILS(I,J,L), CLLS(I,J,L), QLCN(I,J,L), QICN(I,J,L), CLCN(I,J,L) ) + call FIX_UP_CLOUDS( Q(I,J,L), T(I,J,L), QLLS(I,J,L), QILS(I,J,L), CLLS(I,J,L), & + QLCN(I,J,L), QICN(I,J,L), CLCN(I,J,L), & + REMOVE_CLOUDS=(L < KLID) ) ! get radiative properties call RADCOUPLE ( T(I,J,L), PLmb(I,J,L), CLLS(I,J,L), CLCN(I,J,L), & Q(I,J,L), QLLS(I,J,L), QILS(I,J,L), QLCN(I,J,L), QICN(I,J,L), QRAIN(I,J,L), QSNOW(I,J,L), QGRAUPEL(I,J,L), NACTL(I,J,L), NACTI(I,J,L), & RAD_QV(I,J,L), RAD_QL(I,J,L), RAD_QI(I,J,L), RAD_QR(I,J,L), RAD_QS(I,J,L), RAD_QG(I,J,L), RAD_CF(I,J,L), & CLDREFFL(I,J,L), CLDREFFI(I,J,L), & FAC_RL, MIN_RL, MAX_RL, FAC_RI, MIN_RI, MAX_RI) - if (do_qa) RHX(I,J,L) = Q(I,J,L)/GEOS_QSAT( T(I,J,L), PLmb(I,J,L) ) - enddo - enddo + ! Debug large temperature values + if ( DEBUG_TQ_ERRORS .AND. (T(I,J,L) > 333.0) ) then + print *, "Temperature spike detected : ", T(I,J,L) + print *, " GFDL-MP Temp Increment : ", DTDTmic(I,J,L) * DT_MOIST + print *, " Latitude =", LATS(I,J)*180.0/MAPL_PI + print *, " Longitude =", LONS(I,J)*180.0/MAPL_PI + print *, " Pressure (mb) =", PLmb(I,J,L) + print *, " CLLS=", CLLS(I,J,L), "CLCN=", CLCN(I,J,L) + print *, " QV=", Q(I,J,L), " QL=", QLLS(I,J,L)+QLCN(I,J,L), " QI=", QILS(I,J,L)+QICN(I,J,L) + print *, " QR=", QRAIN(I,J,L), " QS=", QSNOW(I,J,L), " QG=", QGRAUPEL(I,J,L) + endif + enddo + enddo enddo - call FILLQ2ZERO(RAD_QV, MASS, TMP2D) - call FILLQ2ZERO(RAD_QL, MASS, TMP2D) - call FILLQ2ZERO(RAD_QI, MASS, TMP2D) - call FILLQ2ZERO(RAD_QR, MASS, TMP2D) - call FILLQ2ZERO(RAD_QS, MASS, TMP2D) - call FILLQ2ZERO(RAD_QG, MASS, TMP2D) - call FILLQ2ZERO(RAD_CF, MASS, TMP2D) + call FILLQ2ZERO(RAD_QV, MASS, RC=STATUS); VERIFY_(STATUS) + call FILLQ2ZERO(RAD_QL, MASS, RC=STATUS); VERIFY_(STATUS) + call FILLQ2ZERO(RAD_QI, MASS, RC=STATUS); VERIFY_(STATUS) + call FILLQ2ZERO(RAD_QR, MASS, RC=STATUS); VERIFY_(STATUS) + call FILLQ2ZERO(RAD_QS, MASS, RC=STATUS); VERIFY_(STATUS) + call FILLQ2ZERO(RAD_QG, MASS, RC=STATUS); VERIFY_(STATUS) + call FILLQ2ZERO(RAD_CF, MASS, RC=STATUS); VERIFY_(STATUS) RAD_QL = MIN( RAD_QL , 0.001 ) ! Still a ridiculously large RAD_QI = MIN( RAD_QI , 0.001 ) ! value. RAD_QR = MIN( RAD_QR , 0.01 ) ! value. RAD_QS = MIN( RAD_QS , 0.01 ) ! value. RAD_QG = MIN( RAD_QG , 0.01 ) ! value. - where (QILS+QICN .le. 0.0) - CLDREFFI = 36.0e-6 - end where - where (QLLS+QLCN .le. 0.0) - CLDREFFL = 14.0e-6 - end where ! Update microphysics tendencies DQVDT_micro = ( Q - DQVDT_micro) / DT_MOIST @@ -899,6 +1054,9 @@ subroutine GFDL_1M_Run (GC, IMPORT, EXPORT, CLOCK, RC) DTDT_micro = ( T - DTDT_micro) / DT_MOIST call MAPL_TimerOff(MAPL,"---CLDMICRO") + + call MAPL_TimerOn(MAPL,"---CLDDIAGS") + call MAPL_GetPointer(EXPORT, PTR3D, 'DQRL', RC=STATUS); VERIFY_(STATUS) if(associated(PTR3D)) PTR3D = DQRDT_macro + DQRDT_micro @@ -911,55 +1069,117 @@ subroutine GFDL_1M_Run (GC, IMPORT, EXPORT, CLOCK, RC) endif ! Compute DBZ radar reflectivity + + ! diagnosed Marshall Palmer rain number concentration + call MAPL_GetPointer(EXPORT, NACTR, 'NACTR', ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) + NACTR = 1.e8*QRAIN**0.8 + + call ESMF_ClockGetAlarm(clock, 'DBZ_RunAlarm', alarm, RC=STATUS); VERIFY_(STATUS) + alarm_is_ringing = ESMF_AlarmIsRinging(alarm, RC=STATUS); VERIFY_(STATUS) + if (alarm_is_ringing) then + ! calc_refl10cm is expensive, do not call every time + call ESMF_AlarmRingerOff(alarm, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, PTR2D , 'REFL10CM_MAX' , RC=STATUS); VERIFY_(STATUS) + if (associated(PTR2D)) then + call MAPL_TimerOn(MAPL,"---CLD_REFL10CM") + rand1 = 0.0 + TMP3D = 0.0 + DO J=1,JM ; DO I=1,IM + !rand1= 1000000 * ( 100*T(I,J,LM) - INT( 100*T(I,J,LM) ) ) + !rand1= max( rand1/1000000., 1e-6 ) + call calc_refl10cm(Q(I,J,:), QRAIN(I,J,:), NACTR(I,J,:), QSNOW(I,J,:), QGRAUPEL(I,J,:), & + T(I,J,:), 100*PLmb(I,J,:), TMP3D(I,J,:), rand1, 1, LM, I, J) + END DO ; END DO + PTR2D=-9999.0 + DO L=1,LM ; DO J=1,JM ; DO I=1,IM + PTR2D(I,J) = MAX(PTR2D(I,J),TMP3D(I,J,L)) + END DO ; END DO ; END DO + call MAPL_TimerOff(MAPL,"---CLD_REFL10CM") + endif + endif + call MAPL_GetPointer(EXPORT, PTR3D , 'DBZ' , RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(EXPORT, DBZ_MAX , 'DBZ_MAX' , RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(EXPORT, DBZ_1KM , 'DBZ_1KM' , RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(EXPORT, DBZ_TOP , 'DBZ_TOP' , RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(EXPORT, DBZ_M10C, 'DBZ_M10C', RC=STATUS); VERIFY_(STATUS) - if (associated(PTR3D) .OR. & associated(DBZ_MAX) .OR. associated(DBZ_1KM) .OR. associated(DBZ_TOP) .OR. associated(DBZ_M10C)) then + call MAPL_TimerOn(MAPL,"---CLD_CALCDBZ") + ! CALCDBZ is 10x cheaper + TMP3D = 0.0 + call CALCDBZ(TMP3D,100*PLmb,T,Q,QRAIN,QSNOW,QGRAUPEL,IM,JM,LM,1,DBZ_VAR_INTERCP,DBZ_LIQUID_SKIN) + if (associated(PTR3D)) PTR3D = TMP3D + call MAPL_TimerOff(MAPL,"---CLD_CALCDBZ") + end if + + if (associated(DBZ_MAX)) then + DBZ_MAX=-9999.0 + DO L=1,LM ; DO J=1,JM ; DO I=1,IM + DBZ_MAX(I,J) = MAX(DBZ_MAX(I,J),TMP3D(I,J,L)) + END DO ; END DO ; END DO + endif + + if (associated(DBZ_1KM)) then + call cs_interpolator(1, IM, 1, JM, LM, TMP3D, 1000., ZLE0, DBZ_1KM, -20.) + endif - call CALCDBZ(TMP3D,100*PLmb,T,Q,QRAIN,QSNOW,QGRAUPEL,IM,JM,LM,1,0,1) - if (associated(PTR3D)) PTR3D = TMP3D + if (associated(DBZ_TOP)) then + DBZ_TOP=MAPL_UNDEF + DO J=1,JM ; DO I=1,IM + DO L=LM,1,-1 + if (ZLE0(i,j,l) >= 25000.) continue + if (TMP3D(i,j,l) >= 18.5 ) then + DBZ_TOP(I,J) = ZLE0(I,J,L) + exit + endif + END DO + END DO ; END DO + endif - if (associated(DBZ_MAX)) then - DBZ_MAX=-9999.0 + if (associated(DBZ_M10C)) then + DBZ_M10C=MAPL_UNDEF + DO J=1,JM ; DO I=1,IM + DO L=LM,1,-1 + if (ZLE0(i,j,l) >= 25000.) continue + if (T(i,j,l) <= MAPL_TICE-10.0) then + DBZ_M10C(I,J) = TMP3D(I,J,L) + exit + endif + END DO + END DO ; END DO + endif + + call MAPL_GetPointer(EXPORT, DBZ_MAX_R , 'DBZ_MAX_R' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, DBZ_MAX_S , 'DBZ_MAX_S' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, DBZ_MAX_G , 'DBZ_MAX_G' , RC=STATUS); VERIFY_(STATUS) + if (associated(DBZ_MAX_R) .OR. associated(DBZ_MAX_S) .OR. associated(DBZ_MAX_G)) then + call MAPL_TimerOn(MAPL,"---CLD_REFRSG") + if (associated(DBZ_MAX_R)) then + TMP3D = 0.0 + call CALCDBZ(TMP3D,100*PLmb,T,Q,QRAIN,0*QSNOW,0*QGRAUPEL,IM,JM,LM,1,DBZ_VAR_INTERCP,DBZ_LIQUID_SKIN) + DBZ_MAX_R=-9999.0 DO L=1,LM ; DO J=1,JM ; DO I=1,IM - DBZ_MAX(I,J) = MAX(DBZ_MAX(I,J),TMP3D(I,J,L)) + DBZ_MAX_R(I,J) = MAX(DBZ_MAX_R(I,J),TMP3D(I,J,L)) END DO ; END DO ; END DO endif - - if (associated(DBZ_1KM)) then - call cs_interpolator(1, IM, 1, JM, LM, TMP3D, 1000., ZLE0, DBZ_1KM, -20.) - endif - - if (associated(DBZ_TOP)) then - DBZ_TOP=MAPL_UNDEF - DO J=1,JM ; DO I=1,IM - DO L=LM,1,-1 - if (ZLE0(i,j,l) >= 25000.) continue - if (TMP3D(i,j,l) >= 18.5 ) then - DBZ_TOP(I,J) = ZLE0(I,J,L) - exit - endif - END DO - END DO ; END DO + if (associated(DBZ_MAX_S)) then + TMP3D = 0.0 + call CALCDBZ(TMP3D,100*PLmb,T,Q,0*QRAIN,QSNOW,0*QGRAUPEL,IM,JM,LM,1,DBZ_VAR_INTERCP,DBZ_LIQUID_SKIN) + DBZ_MAX_S=-9999.0 + DO L=1,LM ; DO J=1,JM ; DO I=1,IM + DBZ_MAX_S(I,J) = MAX(DBZ_MAX_S(I,J),TMP3D(I,J,L)) + END DO ; END DO ; END DO endif - - if (associated(DBZ_M10C)) then - DBZ_M10C=MAPL_UNDEF - DO J=1,JM ; DO I=1,IM - DO L=LM,1,-1 - if (ZLE0(i,j,l) >= 25000.) continue - if (T(i,j,l) <= MAPL_TICE-10.0) then - DBZ_M10C(I,J) = TMP3D(I,J,L) - exit - endif - END DO - END DO ; END DO + if (associated(DBZ_MAX_G)) then + TMP3D = 0.0 + call CALCDBZ(TMP3D,100*PLmb,T,Q,0*QRAIN,0*QSNOW,QGRAUPEL,IM,JM,LM,1,DBZ_VAR_INTERCP,DBZ_LIQUID_SKIN) + DBZ_MAX_G=-9999.0 + DO L=1,LM ; DO J=1,JM ; DO I=1,IM + DBZ_MAX_G(I,J) = MAX(DBZ_MAX_G(I,J),TMP3D(I,J,L)) + END DO ; END DO ; END DO endif - + call MAPL_TimerOff(MAPL,"---CLD_REFRSG") endif call MAPL_GetPointer(EXPORT, PTR3D, 'QRTOT', RC=STATUS); VERIFY_(STATUS) @@ -971,6 +1191,8 @@ subroutine GFDL_1M_Run (GC, IMPORT, EXPORT, CLOCK, RC) call MAPL_GetPointer(EXPORT, PTR3D, 'QGTOT', RC=STATUS); VERIFY_(STATUS) if (associated(PTR3D)) PTR3D = QGRAUPEL + call MAPL_TimerOff(MAPL,"---CLDDIAGS") + call MAPL_TimerOff(MAPL,"--GFDL_1M",RC=STATUS) end subroutine GFDL_1M_Run diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_GF_InterfaceMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_GF_InterfaceMod.F90 index 609d81d48..84f779cf3 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_GF_InterfaceMod.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_GF_InterfaceMod.F90 @@ -33,7 +33,6 @@ module GEOS_GF_InterfaceMod type (FRIENDLIES_TYPE) FRIENDLIES integer :: USE_GF2020 - logical :: LHYDROSTATIC logical :: STOCHASTIC_CNV real :: STOCH_TOP, STOCH_BOT real :: SCLM_DEEP @@ -119,7 +118,6 @@ subroutine GF_Initialize (MAPL, CLOCK, RC) call MAPL_GetResource(MAPL, USE_GF2020 , 'USE_GF2020:' ,default= 1, RC=STATUS );VERIFY_(STATUS) endif IF (USE_GF2020==1) THEN - call MAPL_GetResource(MAPL, LHYDROSTATIC , 'HYDROSTATIC:' ,default=.TRUE., RC=STATUS );VERIFY_(STATUS) call MAPL_GetResource(MAPL, ZERO_DIFF , 'ZERO_DIFF:' ,default= 0, RC=STATUS );VERIFY_(STATUS) call MAPL_GetResource(MAPL, ICUMULUS_GF(DEEP) , 'DEEP:' ,default= 1, RC=STATUS );VERIFY_(STATUS) call MAPL_GetResource(MAPL, ICUMULUS_GF(SHAL) , 'SHALLOW:' ,default= 0, RC=STATUS );VERIFY_(STATUS) @@ -128,22 +126,18 @@ subroutine GF_Initialize (MAPL, CLOCK, RC) call MAPL_GetResource(MAPL, CLOSURE_CHOICE(SHAL) , 'CLOSURE_SHALLOW:' ,default= 7, RC=STATUS );VERIFY_(STATUS) call MAPL_GetResource(MAPL, CLOSURE_CHOICE(MID) , 'CLOSURE_CONGESTUS:' ,default= 3, RC=STATUS );VERIFY_(STATUS) call MAPL_GetResource(MAPL, ENTRVERSION , 'ENTRVERSION:' ,default= 1, RC=STATUS );VERIFY_(STATUS) - if (ZERO_DIFF == 0) then + if (INT(ZERO_DIFF) == 0) then call MAPL_GetResource(MAPL, ENTRVERSION , 'ENTRVERSION:' ,default= 0, RC=STATUS );VERIFY_(STATUS) call MAPL_GetResource(MAPL, MIN_ENTR_RATE , 'MIN_ENTR_RATE:' ,default= 0.3e-4,RC=STATUS );VERIFY_(STATUS) - call MAPL_GetResource(MAPL, CUM_ENTR_RATE(DEEP) , 'ENTR_DP:' ,default= 1.0e-4,RC=STATUS );VERIFY_(STATUS) - call MAPL_GetResource(MAPL, CUM_ENTR_RATE(MID) , 'ENTR_MD:' ,default= 1.0e-4,RC=STATUS );VERIFY_(STATUS) - call MAPL_GetResource(MAPL, CUM_ENTR_RATE(SHAL) , 'ENTR_SH:' ,default= 1.0e-4,RC=STATUS );VERIFY_(STATUS) - SGS_W_TIMESCALE = 1 - if (LHYDROSTATIC) SGS_W_TIMESCALE = 0 - call MAPL_GetResource(MAPL, SGS_W_TIMESCALE , 'SGS_W_TIMESCALE:' ,default= SGS_W_TIMESCALE, RC=STATUS );VERIFY_(STATUS) + call MAPL_GetResource(MAPL, CUM_ENTR_RATE(DEEP) , 'ENTR_DP:' ,default= 2.0e-4,RC=STATUS );VERIFY_(STATUS) + call MAPL_GetResource(MAPL, CUM_ENTR_RATE(MID) , 'ENTR_MD:' ,default= 4.0e-4,RC=STATUS );VERIFY_(STATUS) + call MAPL_GetResource(MAPL, CUM_ENTR_RATE(SHAL) , 'ENTR_SH:' ,default= 6.0e-4,RC=STATUS );VERIFY_(STATUS) else call MAPL_GetResource(MAPL, ENTRVERSION , 'ENTRVERSION:' ,default= 1, RC=STATUS );VERIFY_(STATUS) call MAPL_GetResource(MAPL, MIN_ENTR_RATE , 'MIN_ENTR_RATE:' ,default= 0.1e-4,RC=STATUS );VERIFY_(STATUS) call MAPL_GetResource(MAPL, CUM_ENTR_RATE(DEEP) , 'ENTR_DP:' ,default= 1.0e-4,RC=STATUS );VERIFY_(STATUS) call MAPL_GetResource(MAPL, CUM_ENTR_RATE(MID) , 'ENTR_MD:' ,default= 9.0e-4,RC=STATUS );VERIFY_(STATUS) call MAPL_GetResource(MAPL, CUM_ENTR_RATE(SHAL) , 'ENTR_SH:' ,default= 1.0e-3,RC=STATUS );VERIFY_(STATUS) - call MAPL_GetResource(MAPL, SGS_W_TIMESCALE , 'SGS_W_TIMESCALE:' ,default= 0 ,RC=STATUS );VERIFY_(STATUS) endif call MAPL_GetResource(MAPL, CUM_FADJ_MASSFLX(DEEP) , 'FADJ_MASSFLX_DP:' ,default= 1.0, RC=STATUS );VERIFY_(STATUS) call MAPL_GetResource(MAPL, CUM_FADJ_MASSFLX(SHAL) , 'FADJ_MASSFLX_SH:' ,default= 1.0, RC=STATUS );VERIFY_(STATUS) @@ -172,18 +166,21 @@ subroutine GF_Initialize (MAPL, CLOCK, RC) call MAPL_GetResource(MAPL, BETA_SH , 'BETA_SH:' ,default= 2.2, RC=STATUS );VERIFY_(STATUS) call MAPL_GetResource(MAPL, USE_LINEAR_SUBCL_MF , 'USE_LINEAR_SUBCL_MF:' ,default= 0, RC=STATUS );VERIFY_(STATUS) call MAPL_GetResource(MAPL, CAP_MAXS , 'CAP_MAXS:' ,default= 50., RC=STATUS );VERIFY_(STATUS) - call MAPL_GetResource(MAPL, GF_ENV_SETTING , 'GF_ENV_SETTING:' ,default= 'DYNAMICS', RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource(MAPL, GF_ENV_SETTING , 'GF_ENV_SETTING:' ,default= 'CURRENT', RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource(MAPL, STOCH_TOP , 'STOCH_TOP:' ,default= 2.50, RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource(MAPL, STOCH_BOT , 'STOCH_BOT:' ,default= 0.75, RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource(MAPL, STOCHASTIC_CNV , 'STOCHASTIC_CNV:' ,default= .FALSE.,RC=STATUS); VERIFY_(STATUS) - if (ZERO_DIFF == 0) then + if (INT(ZERO_DIFF) == 0) then call MAPL_GetResource(MAPL, GF_MIN_AREA , 'GF_MIN_AREA:' ,default= 0.0, RC=STATUS );VERIFY_(STATUS) - call MAPL_GetResource(MAPL, TAU_MID , 'TAU_MID:' ,default= 5400., RC=STATUS );VERIFY_(STATUS) - call MAPL_GetResource(MAPL, TAU_DEEP , 'TAU_DEEP:' ,default= 10800.,RC=STATUS );VERIFY_(STATUS) + SGS_W_TIMESCALE = 3 ! Hours + call MAPL_GetResource(MAPL, SGS_W_TIMESCALE , 'SGS_W_TIMESCALE:' ,default= SGS_W_TIMESCALE, RC=STATUS );VERIFY_(STATUS) + call MAPL_GetResource(MAPL, TAU_MID , 'TAU_MID:' ,default= 3600., RC=STATUS );VERIFY_(STATUS) + call MAPL_GetResource(MAPL, TAU_DEEP , 'TAU_DEEP:' ,default= 10800., RC=STATUS );VERIFY_(STATUS) else call MAPL_GetResource(MAPL, GF_MIN_AREA , 'GF_MIN_AREA:' ,default= 1.e6, RC=STATUS );VERIFY_(STATUS) call MAPL_GetResource(MAPL, TAU_MID , 'TAU_MID:' ,default= 3600., RC=STATUS );VERIFY_(STATUS) call MAPL_GetResource(MAPL, TAU_DEEP , 'TAU_DEEP:' ,default= 5400., RC=STATUS );VERIFY_(STATUS) + call MAPL_GetResource(MAPL, SGS_W_TIMESCALE , 'SGS_W_TIMESCALE:' ,default= 0 ,RC=STATUS );VERIFY_(STATUS) endif call MAPL_GetResource(MAPL, CLEV_GRID , 'CLEV_GRID:' ,default= 1, RC=STATUS );VERIFY_(STATUS) call MAPL_GetResource(MAPL, VERT_DISCR , 'VERT_DISCR:' ,default= 1, RC=STATUS );VERIFY_(STATUS) @@ -209,7 +206,7 @@ subroutine GF_Initialize (MAPL, CLOCK, RC) call MAPL_GetResource(MAPL, QRC_CRIT_OCN , 'QRC_CRIT_OCN:' ,default= 2.0e-4,RC=STATUS );VERIFY_(STATUS) call MAPL_GetResource(MAPL, QRC_CRIT_LND , 'QRC_CRIT_LND:' ,default= 2.0e-4,RC=STATUS );VERIFY_(STATUS) call MAPL_GetResource(MAPL, C1 , 'C1:' ,default= 0.0, RC=STATUS );VERIFY_(STATUS) - if (ZERO_DIFF == 0) then + if (INT(ZERO_DIFF) == 0) then call MAPL_GetResource(MAPL, CUM_HEI_DOWN_LAND(DEEP) , 'HEI_DOWN_LAND_DP:' ,default= 0.3, RC=STATUS );VERIFY_(STATUS) call MAPL_GetResource(MAPL, CUM_HEI_DOWN_LAND(SHAL) , 'HEI_DOWN_LAND_SH:' ,default= 0.0, RC=STATUS );VERIFY_(STATUS) call MAPL_GetResource(MAPL, CUM_HEI_DOWN_LAND(MID) , 'HEI_DOWN_LAND_MD:' ,default= 0.3, RC=STATUS );VERIFY_(STATUS) @@ -313,7 +310,7 @@ subroutine GF_Run (GC, IMPORT, EXPORT, CLOCK, RC) type (ESMF_State ) :: INTERNAL type (ESMF_TimeInterval) :: TINT real(ESMF_KIND_R8) :: DT_R8 - real :: GF_DT + real :: GF_DT, MOIST_DT type(ESMF_Alarm) :: alarm logical :: alarm_is_ringing @@ -368,56 +365,71 @@ subroutine GF_Run (GC, IMPORT, EXPORT, CLOCK, RC) real, pointer, dimension(:,:,:) :: RSU_CN,REV_CN,PFL_CN,PFI_CN real, pointer, dimension(:,: ) :: SIGMA_DEEP, SIGMA_MID real, pointer, dimension(:,:,:) :: ENTR, ENTR_DP, ENTR_MD, ENTR_SH + real, pointer, dimension(:,:,:) :: SGS_VVEL_DP, SGS_VVEL_MD, SGS_VVEL_SH real, pointer, dimension(:,: ) :: CNV_TOPP_DP, CNV_TOPP_MD, CNV_TOPP_SH + real, pointer, dimension(:,:,:) :: DQVDT_FILL + real, pointer, dimension(:,:,:) :: DQLLSDT_FILL + real, pointer, dimension(:,:,:) :: DQLCNDT_FILL + real, pointer, dimension(:,:,:) :: DQILSDT_FILL + real, pointer, dimension(:,:,:) :: DQICNDT_FILL real, pointer, dimension(:,:,:) :: PTR3D real, pointer, dimension(:,: ) :: PTR2D - call ESMF_ClockGetAlarm(clock, 'GF_RunAlarm', alarm, RC=STATUS); VERIFY_(STATUS) - alarm_is_ringing = ESMF_AlarmIsRinging(alarm, RC=STATUS); VERIFY_(STATUS) - - if (alarm_is_ringing) then - -!!! call WRITE_PARALLEL('GF is Running') - call ESMF_AlarmRingerOff(alarm, RC=STATUS); VERIFY_(STATUS) - call ESMF_AlarmGet(alarm, RingInterval=TINT, RC=STATUS); VERIFY_(STATUS) - call ESMF_TimeIntervalGet(TINT, S_R8=DT_R8,RC=STATUS); VERIFY_(STATUS) - GF_DT = DT_R8 - - call ESMF_GridCompGet( GC, CONFIG=CF, RC=STATUS ); VERIFY_(STATUS) - - ! Get my internal MAPL_Generic state - !----------------------------------- + type( ESMF_VM ) :: VMG call MAPL_GetObjectFromGC ( GC, MAPL, RC=STATUS); VERIFY_(STATUS) - - call MAPL_TimerOn (MAPL,"--GF") - - ! Get parameters from generic state. - !----------------------------------- - call MAPL_Get( MAPL, IM=IM, JM=JM, LM=LM, & CF = CF, & LONS = LONS, & LATS = LATS, & INTERNAL_ESMF_STATE=INTERNAL, & + RUNALARM = ALARM, & RC=STATUS ) VERIFY_(STATUS) + call ESMF_AlarmGet(ALARM, RingInterval=TINT, RC=STATUS); VERIFY_(STATUS) + call ESMF_TimeIntervalGet(TINT, S_R8=DT_R8,RC=STATUS); VERIFY_(STATUS) + MOIST_DT = DT_R8 + + call ESMF_GridCompGet ( GC, VM=VMG, RC=STATUS ) + VERIFY_(STATUS) ! Internals call MAPL_GetPointer(INTERNAL, Q, 'Q' , RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(INTERNAL, QLLS, 'QLLS' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL, QLLS, 'QLLS' , RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(INTERNAL, QLCN, 'QLCN' , RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(INTERNAL, CLCN, 'CLCN' , RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(INTERNAL, CLLS, 'CLLS' , RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(INTERNAL, QILS, 'QILS' , RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(INTERNAL, QICN, 'QICN' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL, CLCN, 'CLCN' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL, CLLS, 'CLLS' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL, QILS, 'QILS' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL, QICN, 'QICN' , RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(INTERNAL, CNV_TR, 'CNV_TR' , RC=STATUS); VERIFY_(STATUS) + ! Imports + call MAPL_GetPointer(IMPORT, T ,'T' ,RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(IMPORT, U ,'U' ,RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(IMPORT, V ,'V' ,RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(IMPORT, PLE ,'PLE' ,RC=STATUS); VERIFY_(STATUS) + ! Initialize tendencies + call MAPL_GetPointer(EXPORT, DUDT_DC, 'DUDT_DC' , ALLOC = .TRUE., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, DVDT_DC, 'DVDT_DC' , ALLOC = .TRUE., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, DTDT_DC, 'DTDT_DC' , ALLOC = .TRUE., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, DQVDT_DC, 'DQVDT_DC' , ALLOC = .TRUE., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, DQLDT_DC, 'DQLDT_DC' , ALLOC = .TRUE., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, DQIDT_DC, 'DQIDT_DC' , ALLOC = .TRUE., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, DQADT_DC, 'DQADT_DC' , ALLOC = .TRUE., RC=STATUS); VERIFY_(STATUS) + + call ESMF_GridCompGet( GC, CONFIG=CF, RC=STATUS ); VERIFY_(STATUS) + + ! Get my internal MAPL_Generic state + !----------------------------------- + + call MAPL_TimerOn (MAPL,"--GF") + + ! Get parameters from generic state. + !----------------------------------- ! Imports call MAPL_GetPointer(IMPORT, FRLAND ,'FRLAND' ,RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(IMPORT, AREA ,'AREA' ,RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(IMPORT, ZLE ,'ZLE' ,RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(IMPORT, PLE ,'PLE' ,RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(IMPORT, T ,'T' ,RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(IMPORT, U ,'U' ,RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(IMPORT, V ,'V' ,RC=STATUS); VERIFY_(STATUS) @@ -474,6 +486,17 @@ subroutine GF_Run (GC, IMPORT, EXPORT, CLOCK, RC) TH = T/PK MASS = ( PLE(:,:,1:LM)-PLE(:,:,0:LM-1) )/MAPL_GRAV + call ESMF_ClockGetAlarm(clock, 'GF_RunAlarm', alarm, RC=STATUS); VERIFY_(STATUS) + alarm_is_ringing = ESMF_AlarmIsRinging(alarm, RC=STATUS); VERIFY_(STATUS) + + if (alarm_is_ringing) then + +!!! call WRITE_PARALLEL('GF is Running') + call ESMF_AlarmRingerOff(alarm, RC=STATUS); VERIFY_(STATUS) + call ESMF_AlarmGet(alarm, RingInterval=TINT, RC=STATUS); VERIFY_(STATUS) + call ESMF_TimeIntervalGet(TINT, S_R8=DT_R8,RC=STATUS); VERIFY_(STATUS) + GF_DT = DT_R8 + ! Required Exports (connectivities to moist siblings) call MAPL_GetPointer(EXPORT, MFD_DC, 'MFD_DC' , ALLOC = .TRUE., RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(EXPORT, UMF_DC, 'UMF_DC' , ALLOC = .TRUE., RC=STATUS); VERIFY_(STATUS) @@ -519,33 +542,19 @@ subroutine GF_Run (GC, IMPORT, EXPORT, CLOCK, RC) call MAPL_GetPointer(EXPORT, TAU_BL ,'TAU_BL' ,ALLOC = .TRUE. ,RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(EXPORT, TAU_EC ,'TAU_EC' ,ALLOC = .TRUE. ,RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(EXPORT, WQT_DC ,'WQT_DC' ,ALLOC = .TRUE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, ENTR, 'ENTR' ,ALLOC = .TRUE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, ENTR_DP, 'ENTR_DP' ,ALLOC = .TRUE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, ENTR_MD, 'ENTR_MD' ,ALLOC = .TRUE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, ENTR_SH, 'ENTR_SH' ,ALLOC = .TRUE., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, ENTR ,'ENTR' ,ALLOC = .TRUE., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, ENTR_DP ,'ENTR_DP' ,ALLOC = .TRUE., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, ENTR_MD ,'ENTR_MD' ,ALLOC = .TRUE., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, ENTR_SH ,'ENTR_SH' ,ALLOC = .TRUE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, CNV_TOPP_DP, 'CNV_TOPP_DP' ,ALLOC = .TRUE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, CNV_TOPP_MD, 'CNV_TOPP_MD' ,ALLOC = .TRUE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, CNV_TOPP_SH, 'CNV_TOPP_SH' ,ALLOC = .TRUE., RC=STATUS); VERIFY_(STATUS) - - call MAPL_GetPointer(EXPORT, ENTR, 'ENTR' ,ALLOC = .TRUE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, ENTR_DP, 'ENTR_DP' ,ALLOC = .TRUE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, ENTR_MD, 'ENTR_MD' ,ALLOC = .TRUE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, ENTR_SH, 'ENTR_SH' ,ALLOC = .TRUE., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, SGS_VVEL_DP, 'SGS_VVEL_DP' ,ALLOC = .TRUE., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, SGS_VVEL_MD, 'SGS_VVEL_MD' ,ALLOC = .TRUE., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, SGS_VVEL_SH, 'SGS_VVEL_SH' ,ALLOC = .TRUE., RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(EXPORT, CNV_TOPP_DP, 'CNV_TOPP_DP' ,ALLOC = .TRUE., RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(EXPORT, CNV_TOPP_MD, 'CNV_TOPP_MD' ,ALLOC = .TRUE., RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(EXPORT, CNV_TOPP_SH, 'CNV_TOPP_SH' ,ALLOC = .TRUE., RC=STATUS); VERIFY_(STATUS) - ! Initialize tendencies - call MAPL_GetPointer(EXPORT, DUDT_DC, 'DUDT_DC' , ALLOC = .TRUE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, DVDT_DC, 'DVDT_DC' , ALLOC = .TRUE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, DTDT_DC, 'DTDT_DC' , ALLOC = .TRUE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, DQVDT_DC, 'DQVDT_DC' , ALLOC = .TRUE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, DQLDT_DC, 'DQLDT_DC' , ALLOC = .TRUE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, DQIDT_DC, 'DQIDT_DC' , ALLOC = .TRUE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, DQADT_DC, 'DQADT_DC' , ALLOC = .TRUE., RC=STATUS); VERIFY_(STATUS) - if (STOCHASTIC_CNV) then ! Create bit-processor-reproducible random white noise for convection [0:1] SEEDINI = 1000000 * ( 100*T(:,:,LM) - INT( 100*T(:,:,LM) ) ) @@ -577,7 +586,7 @@ subroutine GF_Run (GC, IMPORT, EXPORT, CLOCK, RC) IF (USE_GF2020==1) THEN !- Determine which W is proper import - IF (LHYDROSTATIC) THEN + IF (all(W == 0.0)) THEN TMP3D = -1*OMEGA/(MAPL_GRAV*PL/(MAPL_RDRY*T*(1.0+MAPL_VIREPS*Q))) ELSE TMP3D = W @@ -586,9 +595,9 @@ subroutine GF_Run (GC, IMPORT, EXPORT, CLOCK, RC) ! PLE and PL are passed in Pa call GF2020_Interface( IM,JM,LM,LONS,LATS,GF_DT & ,PLE, PL, ZLE0, ZL0, PK, MASS, KH & - ,T, TH, Q, U, V, TMP3D, BYNCY, QLCN, QICN, QLLS, QILS, CNPCPRATE & + ,T, TH, Q, U, V, TMP3D, BYNCY, (QLCN+QLLS), (QICN+QILS), CNPCPRATE & ,CNV_MF0, CNV_PRC3, MFD_DC, CNV_DQCDT, ENTLAM & - ,UMF_DC, CNV_UPDF, CNV_CVW, CNV_QC, CLCN, CLLS & + ,UMF_DC, CNV_UPDF, CNV_CVW, CNV_QC, (CLCN+CLLS) & ,QV_DYN_IN,PLE_DYN_IN,U_DYN_IN,V_DYN_IN,T_DYN_IN & ,RADSW ,RADLW ,DQDT_BL ,DTDT_BL & ,FRLAND, TMP2D, T2M & @@ -602,6 +611,7 @@ subroutine GF_Run (GC, IMPORT, EXPORT, CLOCK, RC) ,AA0,AA1,AA2,AA3,AA1_BL,AA1_CIN,TAU_BL,TAU_EC & ,DTDTDYN,DQVDTDYN & ,REVSU, ENTR, ENTR_DP, ENTR_MD, ENTR_SH, PRFIL & + , SGS_VVEL_DP, SGS_VVEL_MD, SGS_VVEL_SH & ,TPWI, TPWI_star, LFR_GF, CNV_TR) ELSE !- call GF/GEOS5 interface routine @@ -625,14 +635,8 @@ subroutine GF_Run (GC, IMPORT, EXPORT, CLOCK, RC) ,REVSU, PRFIL) ENDIF - ! add tendencies to the moist import state - U = U + DUDT_DC*GF_DT - V = V + DVDT_DC*GF_DT - Q = Q + DQVDT_DC*GF_DT - T = T + DTDT_DC*GF_DT - TH = T/PK ! update DeepCu QL/QI/CF tendencies - fQi = ice_fraction( T, CNV_FRC, SRF_TYPE ) + fQi = ice_fraction( T+DTDT_DC*GF_DT, CNV_FRC, SRF_TYPE ) TMP3D = CNV_DQCDT/MASS DQLDT_DC = (1.0-fQi)*TMP3D DQIDT_DC = fQi *TMP3D @@ -646,56 +650,60 @@ subroutine GF_Run (GC, IMPORT, EXPORT, CLOCK, RC) PFI_CN (:,:,L) = PRFIL(:,:,L)* fQi(:,:,L) PFL_CN (:,:,L) = PRFIL(:,:,L)*(1.0-fQi(:,:,L)) enddo - ! add QI/QL/CL tendencies - QLCN = QLCN + DQLDT_DC*GF_DT - QICN = QICN + DQIDT_DC*GF_DT - CLCN = MAX(MIN(CLCN + DQADT_DC*GF_DT, 1.0), 0.0) ! Export call MAPL_GetPointer(EXPORT, PTR3D, 'CNV_FICE', RC=STATUS); VERIFY_(STATUS) if (associated(PTR3D)) PTR3D = fQi - ! fix 'convective' cloud fraction - if (FIX_CNV_CLOUD) then - ! fix convective cloud - TMP3D = GEOS_DQSAT(T, PL, PASCALS=.true., QSAT=QST3) - TMP3D = QST3 - WHERE (CLCN < 1.0) - TMP3D = ( Q - QST3 * CLCN )/(1.-CLCN) - END WHERE - minrhx = 0.001 - WHERE ( (( TMP3D - minrhx*QST3 ) < 0.0 ) .AND. (CLCN > 0.0) ) - CLCN = (Q - minrhx*QST3 )/( QST3*(1.0-minrhx) ) - END WHERE - ! If still cant make suitable env RH then destroy anvil - WHERE ( CLCN < 0.0 ) - CLCN = 0. - DQLDT_DC = DQLDT_DC - (QLCN )/GF_DT - DQIDT_DC = DQIDT_DC - ( QICN)/GF_DT - DQVDT_DC = DQVDT_DC + (QLCN + QICN)/GF_DT - Q = Q + (QLCN + QICN) - TMP3D = (MAPL_ALHL*QLCN + MAPL_ALHS*QICN)/MAPL_CP - DTDT_DC = DTDT_DC - TMP3D/GF_DT - T = T - TMP3D - TH = T/PK - QLCN = 0. - QICN = 0. - END WHERE - endif - - !-------------------------------------------------------------- - ! For Now add DeepCu contribution to total/detraining mass flux exports - !-------------------------------------------------------------- - call MAPL_GetPointer(EXPORT, PTR3D, 'CNV_MFC', ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - PTR3D = PTR3D + UMF_DC - call MAPL_GetPointer(EXPORT, PTR3D, 'CNV_MFD', ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - PTR3D = PTR3D + MFD_DC - call MAPL_GetPointer(EXPORT, PTR3D, 'DQRC', RC=STATUS); VERIFY_(STATUS) if(associated(PTR3D)) PTR3D = CNV_PRC3 / GF_DT + call MAPL_GetPointer(EXPORT, PTR2D, 'CCWP', RC=STATUS); VERIFY_(STATUS) + if (associated(PTR2D)) PTR2D = SUM( CNV_QC*MASS , 3 ) - call MAPL_TimerOff (MAPL,"--GF") + endif + ! add tendencies to the moist import state + U = U + DUDT_DC*MOIST_DT + V = V + DVDT_DC*MOIST_DT + Q = Q + DQVDT_DC*MOIST_DT + T = T + DTDT_DC*MOIST_DT + ! add QI/QL/CL tendencies + QLCN = QLCN + DQLDT_DC*MOIST_DT + QICN = QICN + DQIDT_DC*MOIST_DT + CLCN = MAX(MIN(CLCN + DQADT_DC*MOIST_DT, 1.0), 0.0) + +! Cleanup negative water species +! ------------------------------ + call MAPL_GetPointer(EXPORT, DQVDT_FILL, 'DQVDT_FILL_DC', RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, DQLLSDT_FILL, 'DQLLSDT_FILL_DC', RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, DQLCNDT_FILL, 'DQLCNDT_FILL_DC', RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, DQILSDT_FILL, 'DQILSDT_FILL_DC', RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, DQICNDT_FILL, 'DQICNDT_FILL_DC', RC=STATUS); VERIFY_(STATUS) + call FILLQ2ZERO( Q , MASS, DT=MOIST_DT, DQDT= DQVDT_FILL, WARNING_LABEL="QV After GF DeepCu", VM=VMG, RC=STATUS); VERIFY_(STATUS) + call FILLQ2ZERO( QLLS , MASS, DT=MOIST_DT, DQDT=DQLLSDT_FILL, WARNING_LABEL="QLLS After GF DeepCu", VM=VMG, RC=STATUS); VERIFY_(STATUS) + call FILLQ2ZERO( QLCN , MASS, DT=MOIST_DT, DQDT=DQLCNDT_FILL, WARNING_LABEL="QLCN After GF DeepCu", VM=VMG, RC=STATUS); VERIFY_(STATUS) + call FILLQ2ZERO( QILS , MASS, DT=MOIST_DT, DQDT=DQILSDT_FILL, WARNING_LABEL="QILS After GF DeepCu", VM=VMG, RC=STATUS); VERIFY_(STATUS) + call FILLQ2ZERO( QICN , MASS, DT=MOIST_DT, DQDT=DQICNDT_FILL, WARNING_LABEL="QICN After GF DeepCu", VM=VMG, RC=STATUS); VERIFY_(STATUS) + + if (DEBUG_TQ_ERRORS) then + do L=1,LM + do J=1,JM + do I=1,IM + if (T(I,J,L) > 333.0) then + print *, "Temperature spike detected : ", T(I,J,L) + print *, " GF Temp Increment : ", DTDT_DC(I,J,L)*MOIST_DT + print *, " AFTER Grell-Freitas DeepCu" + print *, " Latitude =", LATS(I,J)*180.0/MAPL_PI + print *, " Longitude =", LONS(I,J)*180.0/MAPL_PI + print *, " Pressure (mb) =", 0.5*(PLE(I,J,L-1) + PLE(I,J,L))/100.0 + print *, " CLLS=", CLLS(I,J,L), "CLCN=", CLCN(I,J,L) + print *, " QV=", Q(I,J,L), " QL=", QLLS(I,J,L)+QLCN(I,J,L), " QI=", QILS(I,J,L)+QICN(I,J,L) + endif + end do ! IM loop + end do ! JM loop + end do ! LM loop endif + call MAPL_TimerOff (MAPL,"--GF") + end subroutine GF_Run end module GEOS_GF_InterfaceMod diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_MGB2_2M_InterfaceMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_MGB2_2M_InterfaceMod.F90 index da0140a95..434b138a0 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_MGB2_2M_InterfaceMod.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_MGB2_2M_InterfaceMod.F90 @@ -51,7 +51,6 @@ module GEOS_MGB2_2M_InterfaceMod character(len=ESMF_MAXSTR) :: COMP_NAME ! Local resource variables - integer :: imsize real :: TURNRHCRIT, TURNRHCRIT_UP real :: MINRHCRIT real :: CCW_EVAP_EFF @@ -63,7 +62,6 @@ module GEOS_MGB2_2M_InterfaceMod real :: FAC_RL real :: MIN_RI real :: MAX_RI - logical :: LHYDROSTATIC logical :: USE_AV_V logical :: SECOND_HYSTPDF @@ -80,7 +78,6 @@ module GEOS_MGB2_2M_InterfaceMod public :: MGB2_2M_Setup, MGB2_2M_Initialize, MGB2_2M_Run public :: MGVERSION - character(LEN=ESMF_MAXSTR):: CONVPAR_OPTION contains @@ -97,8 +94,6 @@ subroutine MGB2_2M_Setup (GC, CF, RC) Iam = trim(COMP_NAME) // Iam call ESMF_ConfigGetAttribute( CF, MGVERSION, Label="MGVERSION:", default=3, __RC__) - call ESMF_ConfigGetAttribute( CF, CONVPAR_OPTION, Label='CONVPAR_OPTION:', __RC__) ! Note: Default set in GEOS_GcmGridComp.F90 - ! !INTERNAL STATE: @@ -143,8 +138,8 @@ subroutine MGB2_2M_Setup (GC, CF, RC) default = 1.0e-6, & RESTART = MAPL_RestartRequired, & DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, RC=STATUS ) - VERIFY_(STATUS) + VLOCATION = MAPL_VLocationCenter, RC=STATUS ) + VERIFY_(STATUS) call MAPL_AddInternalSpec(GC, & SHORT_NAME = 'QLLS', & @@ -152,8 +147,8 @@ subroutine MGB2_2M_Setup (GC, CF, RC) UNITS = 'kg kg-1', & FRIENDLYTO = trim(FRIENDLIES%QLLS), & DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, RC=STATUS ) - VERIFY_(STATUS) + VLOCATION = MAPL_VLocationCenter, RC=STATUS ) + VERIFY_(STATUS) call MAPL_AddInternalSpec(GC, & SHORT_NAME = 'QLCN', & @@ -161,8 +156,8 @@ subroutine MGB2_2M_Setup (GC, CF, RC) UNITS = 'kg kg-1', & FRIENDLYTO = trim(FRIENDLIES%QLCN), & DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, RC=STATUS ) - VERIFY_(STATUS) + VLOCATION = MAPL_VLocationCenter, RC=STATUS ) + VERIFY_(STATUS) call MAPL_AddInternalSpec(GC, & SHORT_NAME = 'CLLS', & @@ -170,8 +165,8 @@ subroutine MGB2_2M_Setup (GC, CF, RC) UNITS = '1', & FRIENDLYTO = trim(FRIENDLIES%CLLS), & DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, RC=STATUS ) - VERIFY_(STATUS) + VLOCATION = MAPL_VLocationCenter, RC=STATUS ) + VERIFY_(STATUS) call MAPL_AddInternalSpec(GC, & SHORT_NAME = 'CLCN', & @@ -179,8 +174,8 @@ subroutine MGB2_2M_Setup (GC, CF, RC) UNITS = '1', & FRIENDLYTO = trim(FRIENDLIES%CLCN), & DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, RC=STATUS ) - VERIFY_(STATUS) + VLOCATION = MAPL_VLocationCenter, RC=STATUS ) + VERIFY_(STATUS) call MAPL_AddInternalSpec(GC, & SHORT_NAME = 'QILS', & @@ -188,8 +183,8 @@ subroutine MGB2_2M_Setup (GC, CF, RC) UNITS = 'kg kg-1', & FRIENDLYTO = trim(FRIENDLIES%QILS), & DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, RC=STATUS ) - VERIFY_(STATUS) + VLOCATION = MAPL_VLocationCenter, RC=STATUS ) + VERIFY_(STATUS) call MAPL_AddInternalSpec(GC, & SHORT_NAME = 'QICN', & @@ -197,14 +192,15 @@ subroutine MGB2_2M_Setup (GC, CF, RC) UNITS = 'kg kg-1', & FRIENDLYTO = trim(FRIENDLIES%QICN), & DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, RC=STATUS ) - VERIFY_(STATUS) + VLOCATION = MAPL_VLocationCenter, RC=STATUS ) + VERIFY_(STATUS) call MAPL_AddInternalSpec(GC, & SHORT_NAME = 'QRAIN', & - LONG_NAME = 'mass_fraction_of_rain', & + LONG_NAME = 'mass_fraction_of_rain', & UNITS = 'kg kg-1', & FRIENDLYTO = trim(FRIENDLIES%QRAIN), & + default = 0.0, & DIMS = MAPL_DimsHorzVert, & VLOCATION = MAPL_VLocationCenter, RC=STATUS ) VERIFY_(STATUS) @@ -214,6 +210,7 @@ subroutine MGB2_2M_Setup (GC, CF, RC) LONG_NAME = 'mass_fraction_of_snow', & UNITS = 'kg kg-1', & FRIENDLYTO = trim(FRIENDLIES%QSNOW), & + default = 0.0, & DIMS = MAPL_DimsHorzVert, & VLOCATION = MAPL_VLocationCenter, RC=STATUS ) VERIFY_(STATUS) @@ -223,6 +220,7 @@ subroutine MGB2_2M_Setup (GC, CF, RC) LONG_NAME = 'mass_fraction_of_graupel', & UNITS = 'kg kg-1', & FRIENDLYTO = trim(FRIENDLIES%QGRAUPEL), & + default = 0.0, & DIMS = MAPL_DimsHorzVert, & VLOCATION = MAPL_VLocationCenter, RC=STATUS ) VERIFY_(STATUS) @@ -261,25 +259,26 @@ subroutine MGB2_2M_Setup (GC, CF, RC) LONG_NAME ='particle_number_for_snow', & UNITS ='kg-1', & FRIENDLYTO = trim(FRIENDLIES%NSNOW), & + DEFAULT = 0.0, & DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, RC=STATUS ) - - VERIFY_(STATUS) - + VLOCATION = MAPL_VLocationCenter, RC=STATUS ) + VERIFY_(STATUS) call MAPL_AddInternalSpec(GC, & SHORT_NAME ='NGRAUPEL', & LONG_NAME ='particle_number_for_graupel', & UNITS ='kg-1', & FRIENDLYTO = trim(FRIENDLIES%NGRAUPEL), & + DEFAULT = 0.0, & DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, RC=STATUS ) + VLOCATION = MAPL_VLocationCenter, RC=STATUS ) + VERIFY_(STATUS) call MAPL_AddInternalSpec(GC, & SHORT_NAME = 'NACTL', & - LONG_NAME = 'activ aero # conc liq phase for 1-mom', & + LONG_NAME = 'activ aero # conc liq phase for 1-mom', & UNITS = 'm-3', & - RESTART = MAPL_RestartSkip, & + RESTART = MAPL_RestartSkip, & DIMS = MAPL_DimsHorzVert, & VLOCATION = MAPL_VLocationCenter, RC=STATUS ) VERIFY_(STATUS) @@ -305,7 +304,6 @@ end subroutine MGB2_2M_Setup subroutine MGB2_2M_Initialize (MAPL, RC) type (MAPL_MetaComp), intent(inout) :: MAPL integer, optional :: RC ! return code - type (ESMF_State) :: INTERNAL @@ -359,7 +357,6 @@ subroutine MGB2_2M_Initialize (MAPL, RC) call MAPL_GetResource( MAPL, TURNRHCRIT_UP, 'TURNRHCRIT_UP:', DEFAULT = 300., RC=STATUS); VERIFY_(STATUS) !pressure to turn the profile back at upper trop -1 dsiables it call MAPL_GetResource( MAPL, CNV_FRACTION_MIN, 'CNV_FRACTION_MIN:', DEFAULT= 500.0, RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource( MAPL, CNV_FRACTION_MAX, 'CNV_FRACTION_MAX:', DEFAULT= 1500.0, RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource( MAPL, CNV_FRACTION_EXP, 'CNV_FRACTION_EXP:', DEFAULT= 1.0, RC=STATUS); VERIFY_(STATUS) @@ -416,7 +413,6 @@ subroutine MGB2_2M_Initialize (MAPL, RC) call MAPL_GetResource(MAPL, WSUB_OPTION, 'WSUB_OPTION:', DEFAULT= 1.0, __RC__) !0- param 1- Use Wsub climatology 2-Wnet call MAPL_GetResource(MAPL, SECOND_HYSTPDF, 'SECOND_HYSTPDF:', DEFAULT= .TRUE. ,RC=STATUS) !drop vol radius in cnv - mui_cnstr8 = MUI_CST ncnstr8 = NC_CST if (NC_CST .gt. 0.0) nccons =.true. @@ -424,7 +420,7 @@ subroutine MGB2_2M_Initialize (MAPL, RC) if (NI_CST .gt. 0.0) nicons =.true. ngnstr8 = NG_CST if (NG_CST .gt. 0.0) ngcons =.true. - + if (MGVERSION .gt. 1) then do_graupel = .false. if (MGVERSION .gt. 2) do_graupel = .true. @@ -435,11 +431,21 @@ subroutine MGB2_2M_Initialize (MAPL, RC) nccons, nicons, ncnstr8, ninstr8, 2.0) end if - call aer_cloud_init() + call aer_cloud_init() -end subroutine MGB2_2M_Initialize + call WRITE_PARALLEL ("INITIALIZED MGB2_2M microphysics in non-generic GC INIT") + CCW_EVAP_EFF = 4.e-3 + call MAPL_GetResource( MAPL, CCW_EVAP_EFF, 'CCW_EVAP_EFF:', DEFAULT= CCW_EVAP_EFF, RC=STATUS); VERIFY_(STATUS) + CCI_EVAP_EFF = 4.e-3 + call MAPL_GetResource( MAPL, CCI_EVAP_EFF, 'CCI_EVAP_EFF:', DEFAULT= CCI_EVAP_EFF, RC=STATUS); VERIFY_(STATUS) + + call MAPL_GetResource( MAPL, CNV_FRACTION_MIN, 'CNV_FRACTION_MIN:', DEFAULT= 500.0, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource( MAPL, CNV_FRACTION_MAX, 'CNV_FRACTION_MAX:', DEFAULT= 1500.0, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource( MAPL, DBZ_LIQUID_SKIN , 'DBZ_LIQUID_SKIN:' , DEFAULT= 0 , RC=STATUS); VERIFY_(STATUS) + +end subroutine MGB2_2M_Initialize subroutine MGB2_2M_Run (GC, IMPORT, EXPORT, CLOCK, RC) type(ESMF_GridComp), intent(inout) :: GC ! Gridded component @@ -472,6 +478,7 @@ subroutine MGB2_2M_Run (GC, IMPORT, EXPORT, CLOCK, RC) real, pointer, dimension(:,:,:) :: ALH, RADLW, RADSW, WSUB_CLIM ! Local + real, allocatable, dimension(:,:,:) :: U0, V0 real, allocatable, dimension(:,:,:) :: PLEmb, ZLE0 real, allocatable, dimension(:,:,:) :: PLmb, ZL0, GZLO real, allocatable, dimension(:,:,:) :: DZET, DP, MASS, iMASS @@ -496,6 +503,7 @@ subroutine MGB2_2M_Run (GC, IMPORT, EXPORT, CLOCK, RC) real, pointer, dimension(:,:,:) :: PFI_LS, PFI_AN real, pointer, dimension(:,:,:) :: PDF_A, PDFITERS real, pointer, dimension(:,:,:) :: RHCRIT + real, pointer, dimension(:,: ) :: DBZ_MAX, DBZ_1KM, DBZ_TOP, DBZ_M10C real, pointer, dimension(:,:,:) :: PTR3D real, pointer, dimension(:,: ) :: PTR2D #ifdef PDFDIAG @@ -624,7 +632,6 @@ subroutine MGB2_2M_Run (GC, IMPORT, EXPORT, CLOCK, RC) allocate(ficer8(1,LM), __STAT__) allocate(qilsr8(1,LM), __STAT__) allocate(uwind_gw(1,LM), __STAT__) - allocate(ter8(1,LM), __STAT__) allocate(qvr8(1,LM), __STAT__) allocate(qcr8(1,LM), __STAT__) @@ -818,7 +825,6 @@ subroutine MGB2_2M_Run (GC, IMPORT, EXPORT, CLOCK, RC) allocate(NCPL_CLDBASEX(IM,JM ), __STAT__) !allocate(TH(IM,JM,LM ), __STAT__) - call ESMF_AlarmGet(ALARM, RingInterval=TINT, RC=STATUS); VERIFY_(STATUS) call ESMF_TimeIntervalGet(TINT, S_R8=DT_R8,RC=STATUS); VERIFY_(STATUS) DT_MOIST = DT_R8 @@ -955,6 +961,8 @@ subroutine MGB2_2M_Run (GC, IMPORT, EXPORT, CLOCK, RC) ALLOCATE ( ZLE0 (IM,JM,0:LM) ) ALLOCATE ( PLEmb(IM,JM,0:LM) ) ! Layer variables + ALLOCATE ( U0 (IM,JM,LM ) ) + ALLOCATE ( V0 (IM,JM,LM ) ) ALLOCATE ( ZL0 (IM,JM,LM ) ) ALLOCATE ( PLmb (IM,JM,LM ) ) ALLOCATE ( DZET (IM,JM,LM ) ) @@ -984,6 +992,8 @@ subroutine MGB2_2M_Run (GC, IMPORT, EXPORT, CLOCK, RC) DP = ( PLE(:,:,1:LM)-PLE(:,:,0:LM-1) ) MASS = DP/MAPL_GRAV iMASS = 1.0/MASS + U0 = U + V0 = V PK = (100.0*PLmb/MAPL_P00)**(MAPL_KAPPA) TH1 = T/PK AIRDEN = 100.*PLmb/T/MAPL_RGAS @@ -1278,16 +1288,6 @@ subroutine MGB2_2M_Run (GC, IMPORT, EXPORT, CLOCK, RC) call MAPL_GetPointer(EXPORT, PTR2D, 'AN_SNR' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS); PTR2D=0.0 call MAPL_GetPointer(EXPORT, PTR2D, 'SC_SNR' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS); PTR2D=0.0 - call MAPL_GetPointer(EXPORT, PTR2D, 'ZLCL', RC=STATUS); VERIFY_(STATUS) - if (associated(PTR2D)) then - tmp2d = FIND_KLCL( T, Q, PLmb, IM, JM, LM ) - do J=1,JM - do I=1,IM - PTR2D(I,J) = ZL0(I,J,tmp2d(I,J)) - end do - end do - endif - call MAPL_TimerOn(MAPL,"---CLDMACRO") call MAPL_GetPointer(EXPORT, DQVDT_macro, 'DQVDT_macro' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(EXPORT, DQIDT_macro, 'DQIDT_macro' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) @@ -1587,7 +1587,7 @@ subroutine MGB2_2M_Run (GC, IMPORT, EXPORT, CLOCK, RC) ! Update TH TH1 = T/PK - + !initialize MG variables cldfr8 = 0.0_r8 prectr8 = 0.0_r8 @@ -1696,7 +1696,6 @@ subroutine MGB2_2M_Run (GC, IMPORT, EXPORT, CLOCK, RC) liqcldfr8 = cldfr8!*(qcr8/(qir8 + qcr8 + 1.e-12)) icecldfr8 = cldfr8! max(cldfr8- liqcldfr8, 0.) - ! Nucleation tendencies naair8(1,1:LM) = max(( INC_NUC(I, J, 1:LM)*cldfr8(1,1:LM) - nir8(1,1:LM))/DT_MOIST, 0.0) npccninr8(1,1:LM) = max((CDNC_NUC(I, J, 1:LM)*cldfr8(1,1:LM) - ncr8(1,1:LM))/DT_MOIST, 0.0) @@ -1874,7 +1873,6 @@ subroutine MGB2_2M_Run (GC, IMPORT, EXPORT, CLOCK, RC) end if - IF (MGVERSION > 1) then RAD_QR(I,J,1:LM) = max(RAD_QR(I,J,1:LM) + REAL(qrtendr8(1, 1:LM)*DT_R8), 0.0) ! grid average @@ -1964,14 +1962,12 @@ subroutine MGB2_2M_Run (GC, IMPORT, EXPORT, CLOCK, RC) DNCAUTICE (I,J,1:LM) = REAL(nprcior8(1,1:LM)) !ice number tendency from autoconversion DNCHMSPLIT(I,J,1:LM) = REAL(nsacwior8(1,1:LM)) !ice number tendency from H-M process - enddo !I enddo !J !============================================Finish 2-moment micro implementation=========================== !update water tracers - ! Redistribute CN/LS CF/QL/QI call REDISTRIBUTE_CLOUDS(RAD_CF, RAD_QL, RAD_QI, CLCN, CLLS, QLCN, QLLS, QICN, QILS, RAD_QV, T) !============ Put cloud fraction back in contact with the PDF and create new condensate if neccesary (Barahona et al., GMD, 2014)============ @@ -1989,13 +1985,13 @@ subroutine MGB2_2M_Run (GC, IMPORT, EXPORT, CLOCK, RC) PDFSHAPE , & CNV_FRC(I, J) , & SRF_TYPE(I, J) , & - PLmb(I, J, K) , & - Q (I, J, K) , & + PLmb(I, J, K) , & + Q (I, J, K) , & QLLS(I, J, K) , & QLCN(I, J, K) , & QILS(I, J, K) , & QICN(I, J, K) , & - T(I, J, K) , & + T(I, J, K) , & CLLS(I, J, K) , & CLCN(I, J, K) , & SC_ICE(I, J, K) , & @@ -2153,13 +2149,13 @@ subroutine MGB2_2M_Run (GC, IMPORT, EXPORT, CLOCK, RC) !Everything in-cloud for radiation============== - call FILLQ2ZERO(RAD_QV, MASS, TMP2D) - call FILLQ2ZERO(RAD_QL, MASS, TMP2D) - call FILLQ2ZERO(RAD_QI, MASS, TMP2D) - call FILLQ2ZERO(RAD_QR, MASS, TMP2D) - call FILLQ2ZERO(RAD_QS, MASS, TMP2D) - call FILLQ2ZERO(RAD_QG, MASS, TMP2D) - call FILLQ2ZERO(RAD_CF, MASS, TMP2D) + call FILLQ2ZERO(RAD_QV, MASS, RC=STATUS); VERIFY_(STATUS) + call FILLQ2ZERO(RAD_QL, MASS, RC=STATUS); VERIFY_(STATUS) + call FILLQ2ZERO(RAD_QI, MASS, RC=STATUS); VERIFY_(STATUS) + call FILLQ2ZERO(RAD_QR, MASS, RC=STATUS); VERIFY_(STATUS) + call FILLQ2ZERO(RAD_QS, MASS, RC=STATUS); VERIFY_(STATUS) + call FILLQ2ZERO(RAD_QG, MASS, RC=STATUS); VERIFY_(STATUS) + call FILLQ2ZERO(RAD_CF, MASS, RC=STATUS); VERIFY_(STATUS) RAD_QL = MIN( RAD_QL , 0.001 ) ! Still a ridiculously large RAD_QI = MIN( RAD_QI , 0.001 ) ! value. RAD_QR = MIN( RAD_QR , 0.01 ) ! value. @@ -2328,28 +2324,103 @@ subroutine MGB2_2M_Run (GC, IMPORT, EXPORT, CLOCK, RC) END WHERE endif - call MAPL_GetPointer(EXPORT, PTR3D, 'DQRL', RC=STATUS); VERIFY_(STATUS) if(associated(PTR3D)) PTR3D = DQRDT_macro + DQRDT_micro + ! dissipative heating tendency from KE across the macro/micro physics + call MAPL_GetPointer(EXPORT, PTR3D, 'DTDTFRIC', RC=STATUS); VERIFY_(STATUS) + if(associated(PTR3D)) then + call dissipative_ke_heating(IM,JM,LM, MASS,U0,V0, & + DUDT_macro+DUDT_micro,& + DVDT_macro+DVDT_micro,PTR3D) + endif + ! Compute DBZ radar reflectivity - call MAPL_GetPointer(EXPORT, PTR3D, 'DBZ' , RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, PTR2D, 'DBZ_MAX', RC=STATUS); VERIFY_(STATUS) - if (associated(PTR3D) .OR. associated(PTR2D)) then - call CALCDBZ(TMP3D,100*PLmb,T,Q,QRAIN,QSNOW,QGRAUPEL,IM,JM,LM,1,0,1) - if (associated(PTR3D)) PTR3D = TMP3D - if (associated(PTR2D)) then - PTR2D=-9999.0 - DO L=1,LM ; DO J=1,JM ; DO I=1,IM - PTR2D(I,J) = MAX(PTR2D(I,J),TMP3D(I,J,L)) - END DO ; END DO ; END DO - endif + call MAPL_GetPointer(EXPORT, PTR3D , 'DBZ' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, DBZ_MAX , 'DBZ_MAX' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, DBZ_1KM , 'DBZ_1KM' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, DBZ_TOP , 'DBZ_TOP' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, DBZ_M10C, 'DBZ_M10C', RC=STATUS); VERIFY_(STATUS) + + if (associated(PTR3D) .OR. & + associated(DBZ_MAX) .OR. associated(DBZ_1KM) .OR. associated(DBZ_TOP) .OR. associated(DBZ_M10C)) then + + call CALCDBZ(TMP3D,100*PLmb,T,Q,QRAIN,QSNOW,QGRAUPEL,IM,JM,LM,1,0,DBZ_LIQUID_SKIN) + if (associated(PTR3D)) PTR3D = TMP3D + + if (associated(DBZ_MAX)) then + DBZ_MAX=-9999.0 + DO L=1,LM ; DO J=1,JM ; DO I=1,IM + DBZ_MAX(I,J) = MAX(DBZ_MAX(I,J),TMP3D(I,J,L)) + END DO ; END DO ; END DO + endif + + if (associated(DBZ_1KM)) then + call cs_interpolator(1, IM, 1, JM, LM, TMP3D, 1000., ZLE0, DBZ_1KM, -20.) + endif + + if (associated(DBZ_TOP)) then + DBZ_TOP=MAPL_UNDEF + DO J=1,JM ; DO I=1,IM + DO L=LM,1,-1 + if (ZLE0(i,j,l) >= 25000.) continue + if (TMP3D(i,j,l) >= 18.5 ) then + DBZ_TOP(I,J) = ZLE0(I,J,L) + exit + endif + END DO + END DO ; END DO + endif + + if (associated(DBZ_M10C)) then + DBZ_M10C=MAPL_UNDEF + DO J=1,JM ; DO I=1,IM + DO L=LM,1,-1 + if (ZLE0(i,j,l) >= 25000.) continue + if (T(i,j,l) <= MAPL_TICE-10.0) then + DBZ_M10C(I,J) = TMP3D(I,J,L) + exit + endif + END DO + END DO ; END DO + endif + endif - call MAPL_TimerOff(MAPL,"--MGB2_2M",__RC__) + call MAPL_GetPointer(EXPORT, PTR2D , 'DBZ_MAX_R' , RC=STATUS); VERIFY_(STATUS) + if (associated(PTR2D)) then + call CALCDBZ(TMP3D,100*PLmb,T,Q,QRAIN,0.0*QSNOW,0.0*QGRAUPEL,IM,JM,LM,1,0,DBZ_LIQUID_SKIN) + PTR2D=-9999.0 + DO L=1,LM ; DO J=1,JM ; DO I=1,IM + PTR2D(I,J) = MAX(PTR2D(I,J),TMP3D(I,J,L)) + END DO ; END DO ; END DO + endif + call MAPL_GetPointer(EXPORT, PTR2D , 'DBZ_MAX_S' , RC=STATUS); VERIFY_(STATUS) + if (associated(PTR2D)) then + call CALCDBZ(TMP3D,100*PLmb,T,Q,0.0*QRAIN,QSNOW,0.0*QGRAUPEL,IM,JM,LM,1,0,DBZ_LIQUID_SKIN) + PTR2D=-9999.0 + DO L=1,LM ; DO J=1,JM ; DO I=1,IM + PTR2D(I,J) = MAX(PTR2D(I,J),TMP3D(I,J,L)) + END DO ; END DO ; END DO + endif + call MAPL_GetPointer(EXPORT, PTR2D , 'DBZ_MAX_G' , RC=STATUS); VERIFY_(STATUS) + if (associated(PTR2D)) then + call CALCDBZ(TMP3D,100*PLmb,T,Q,0.0*QRAIN,0.0*QSNOW,QGRAUPEL,IM,JM,LM,1,0,DBZ_LIQUID_SKIN) + PTR2D=-9999.0 + DO L=1,LM ; DO J=1,JM ; DO I=1,IM + PTR2D(I,J) = MAX(PTR2D(I,J),TMP3D(I,J,L)) + END DO ; END DO ; END DO + endif -end subroutine MGB2_2M_Run + call MAPL_GetPointer(EXPORT, PTR3D, 'QRTOT', RC=STATUS); VERIFY_(STATUS) + if (associated(PTR3D)) PTR3D = QRAIN + call MAPL_GetPointer(EXPORT, PTR3D, 'QSTOT', RC=STATUS); VERIFY_(STATUS) + if (associated(PTR3D)) PTR3D = QSNOW + call MAPL_GetPointer(EXPORT, PTR3D, 'QGTOT', RC=STATUS); VERIFY_(STATUS) + if (associated(PTR3D)) PTR3D = QGRAUPEL + call MAPL_TimerOff(MAPL,"--MGB2_2M",RC=STATUS) +end subroutine MGB2_2M_Run end module GEOS_MGB2_2M_InterfaceMod diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_MoistGridComp.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_MoistGridComp.F90 index 09171b586..e4d816146 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_MoistGridComp.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_MoistGridComp.F90 @@ -42,13 +42,12 @@ module GEOS_MoistGridCompMod private - logical :: DEBUG = .false. + logical :: DEBUG_MST logical :: LDIAGNOSE_PRECIP_TYPE logical :: LUPDATE_PRECIP_TYPE - logical :: LHYDROSTATIC - logical :: USE_AERO_BUFFER real :: CCN_OCN real :: CCN_LND + logical :: MOVE_CN_TO_LS ! !PUBLIC MEMBER FUNCTIONS: @@ -157,6 +156,9 @@ subroutine SetServices ( GC, RC ) adjustl(CONVPAR_OPTION)=="GF" .or. & adjustl(CONVPAR_OPTION)=="NONE" _ASSERT( LCONVPAR, 'Unsupported Deep Convection Option' ) + call MAPL_GetResource( CF, SIGMA_DX , Label='SIGMA_DX:' , default=SIGMA_DX , RC=STATUS) + call MAPL_GetResource( CF, SIGMA_EXP, Label='SIGMA_EXP:', default=SIGMA_EXP, RC=STATUS) + ! Inititialize shallow convective parameterizations (Options: UW or NONE) !---------------------------------------------------------------------- @@ -190,6 +192,10 @@ subroutine SetServices ( GC, RC ) gfEnvRestartSkip = MAPL_RestartSkip endif + call MAPL_GetResource( CF, DEBUG_MST, Label="DEBUG_MST:", default=.false., RC=STATUS) ; VERIFY_(STATUS) + + call MAPL_GetResource( CF, DEBUG_TQ_ERRORS, Label="DEBUG_TQ_ERRORS:", default=.false., RC=STATUS) ; VERIFY_(STATUS) + ! NOTE: Binary restarts expect Q to be the first field in the moist_internal_rst. Thus, ! the first MAPL_AddInternalSpec call must be from the microphysics @@ -914,7 +920,7 @@ subroutine SetServices ( GC, RC ) call MAPL_AddExportSpec(GC, & SHORT_NAME = 'QCTOT', & - LONG_NAME = 'mass_fraction_of_total_cloud_water', & + LONG_NAME = 'mass_fraction_of_total_condensate', & UNITS = 'kg kg-1', & DIMS = MAPL_DimsHorzVert, & VLOCATION = MAPL_VLocationCenter, RC=STATUS ) @@ -1258,6 +1264,36 @@ subroutine SetServices ( GC, RC ) VERIFY_(STATUS) + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'SGS_VVEL_DP', & + LONG_NAME = 'subgridscale_vert_vel_in_gf_deep_convection_updraft', & + UNITS = 'm s-1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RC=STATUS ) + + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'SGS_VVEL_MD', & + LONG_NAME = 'subgridscale_vert_vel_in_gf_mid_convection_updraft', & + UNITS = 'm s-1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RC=STATUS ) + + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'SGS_VVEL_SH', & + LONG_NAME = 'subgridscale_vert_vel_in_gf_shallow_convection_updraft', & + UNITS = 'm s-1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RC=STATUS ) + + VERIFY_(STATUS) + call MAPL_AddExportSpec(GC, & SHORT_NAME = 'CNV_UPDF', & LONG_NAME = 'updraft_areal_fraction', & @@ -1807,7 +1843,7 @@ subroutine SetServices ( GC, RC ) VLOCATION = MAPL_VLocationCenter, RC=STATUS ) VERIFY_(STATUS) - call MAPL_AddExportSpec(GC, & + call MAPL_AddExportSpec(GC, & SHORT_NAME = 'RG', & LONG_NAME = 'falling_graupel_particle_effective_radius', & UNITS = 'm', & @@ -1815,6 +1851,38 @@ subroutine SetServices ( GC, RC ) VLOCATION = MAPL_VLocationCenter, RC=STATUS ) VERIFY_(STATUS) + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'VFALL_ICE', & + LONG_NAME = 'terminal_velocity_of_falling_ice', & + UNITS = 'm s-1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'VFALL_SNOW', & + LONG_NAME = 'terminal_velocity_of_falling_snow', & + UNITS = 'm s-1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'VFALL_GRAUPEL', & + LONG_NAME = 'terminal_velocity_of_falling_graupel', & + UNITS = 'm s-1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'VFALL_RAIN', & + LONG_NAME = 'terminal_velocity_of_falling_rain', & + UNITS = 'm s-1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, RC=STATUS ) + VERIFY_(STATUS) + call MAPL_AddExportSpec(GC, & SHORT_NAME ='NCCN_LIQ', & LONG_NAME ='number_concentration_of_cloud_liquid_particles', & @@ -1959,6 +2027,14 @@ subroutine SetServices ( GC, RC ) VLOCATION = MAPL_VLocationCenter, RC=STATUS ) VERIFY_(STATUS) + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'NACTR', & + LONG_NAME = 'rain_number_concentration', & + UNITS = '# m-3', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, RC=STATUS ) + VERIFY_(STATUS) + call MAPL_AddExportSpec(GC, & SHORT_NAME = 'DBZ', & LONG_NAME = 'Simulated_radar_reflectivity', & @@ -1967,6 +2043,38 @@ subroutine SetServices ( GC, RC ) VLOCATION = MAPL_VLocationCenter, RC=STATUS ) VERIFY_(STATUS) + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'DBZ_MAX_S', & + LONG_NAME = 'Maximum_composite_radar_reflectivity_snow', & + UNITS = 'dBZ', & + DIMS = MAPL_DimsHorzOnly, & + VLOCATION = MAPL_VLocationNone, RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'DBZ_MAX_R', & + LONG_NAME = 'Maximum_composite_radar_reflectivity_rain', & + UNITS = 'dBZ', & + DIMS = MAPL_DimsHorzOnly, & + VLOCATION = MAPL_VLocationNone, RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'DBZ_MAX_G', & + LONG_NAME = 'Maximum_composite_radar_reflectivity_graupel', & + UNITS = 'dBZ', & + DIMS = MAPL_DimsHorzOnly, & + VLOCATION = MAPL_VLocationNone, RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'REFL10CM_MAX', & + LONG_NAME = 'Maximum_composite_10cm_radar_reflectivity', & + UNITS = 'dBZ', & + DIMS = MAPL_DimsHorzOnly, & + VLOCATION = MAPL_VLocationNone, RC=STATUS ) + VERIFY_(STATUS) + call MAPL_AddExportSpec(GC, & SHORT_NAME = 'DBZ_MAX', & LONG_NAME = 'Maximum_composite_radar_reflectivity', & @@ -1999,6 +2107,14 @@ subroutine SetServices ( GC, RC ) VLOCATION = MAPL_VLocationNone, RC=STATUS ) VERIFY_(STATUS) + call MAPL_AddExportSpec(GC, & + SHORT_NAME ='PRCP_WATER', & + LONG_NAME ='falling_water_at_surface', & + UNITS ='kg m-2 s-1', & + DIMS = MAPL_DimsHorzOnly, & + VLOCATION = MAPL_VLocationNone, RC=STATUS ) + VERIFY_(STATUS) + call MAPL_AddExportSpec(GC, & SHORT_NAME ='PRCP_RAIN', & LONG_NAME ='falling_rain_precipitation_at_surface', & @@ -2153,22 +2269,6 @@ subroutine SetServices ( GC, RC ) VLOCATION = MAPL_VLocationNone, RC=STATUS ) VERIFY_(STATUS) - call MAPL_AddExportSpec(GC, & - SHORT_NAME = 'FILLNQV_IN', & - LONG_NAME = 'filling_of_negative_Q_on_entry_to_moist', & - UNITS = 'kg m-2 s-1', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - SHORT_NAME = 'FILLNQV', & - LONG_NAME = 'filling_of_negative_Q', & - UNITS = 'kg m-2 s-1', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, RC=STATUS ) - VERIFY_(STATUS) - call MAPL_AddExportSpec(GC, & SHORT_NAME = 'PGENTOT', & LONG_NAME = 'Total_column_production_of_precipitation', & @@ -2571,14 +2671,6 @@ subroutine SetServices ( GC, RC ) VLOCATION = MAPL_VLocationNone, RC=STATUS ) VERIFY_(STATUS) - call MAPL_AddExportSpec(GC, & - SHORT_NAME='RKFRE', & - LONG_NAME ='fraction_of_tke_associated_with_vertical_velocity', & - UNITS ='' , & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, RC=STATUS ) - VERIFY_(STATUS) - call MAPL_AddExportSpec(GC, & SHORT_NAME='STOCH_CNV', & LONG_NAME ='stochastic_factor_for_convection', & @@ -2651,42 +2743,6 @@ subroutine SetServices ( GC, RC ) VLOCATION = MAPL_VLocationCenter, RC=STATUS ) VERIFY_(STATUS) -#if 0 - ! taken out since they are now friendly to dynamics - call MAPL_AddExportSpec(GC, & - SHORT_NAME ='QLCN', & - LONG_NAME ='mass_fraction_of_convective_cloud_liquid_water', & - UNITS ='1', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - SHORT_NAME ='QICN', & - LONG_NAME ='mass_fraction_of_convective_cloud_ice_water', & - UNITS ='1', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - SHORT_NAME ='CLLS', & - LONG_NAME ='large_scale_cloud_volume_fraction', & - UNITS ='1', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - SHORT_NAME ='CLCN', & - LONG_NAME ='convective_cloud_volume_fraction', & - UNITS ='1', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, RC=STATUS ) - VERIFY_(STATUS) -#endif - - call MAPL_AddExportSpec(GC, & SHORT_NAME='RH1', & LONG_NAME ='relative_humidity_before_moist', & @@ -3026,6 +3082,30 @@ subroutine SetServices ( GC, RC ) VLOCATION = MAPL_VLocationEdge, RC=STATUS ) VERIFY_(STATUS) + call MAPL_AddExportSpec(GC, & + SHORT_NAME='PFR_LS', & + LONG_NAME ='3D_flux_of_rain_nonanvil_large_scale_precipitation',& + UNITS ='kg m-2 s-1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationEdge, RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME='PFS_LS', & + LONG_NAME ='3D_flux_of_snow_nonanvil_large_scale_precipitation',& + UNITS ='kg m-2 s-1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationEdge, RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME='PFG_LS', & + LONG_NAME ='3D_flux_of_graupel_nonanvil_large_scale_precipitation',& + UNITS ='kg m-2 s-1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationEdge, RC=STATUS ) + VERIFY_(STATUS) + call MAPL_AddExportSpec(GC, & SHORT_NAME='DPDTMST', & LONG_NAME ='layer_pressure_thickness_tendency_from_moist', & @@ -3597,6 +3677,14 @@ subroutine SetServices ( GC, RC ) VLOCATION = MAPL_VLocationCenter, RC=STATUS ) VERIFY_(STATUS) + call MAPL_AddExportSpec(GC, & + SHORT_NAME ='CLLSX1', & + LONG_NAME ='final_large_scale_cloud_area_fraction', & + UNITS ='1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, RC=STATUS ) + VERIFY_(STATUS) + call MAPL_AddExportSpec(GC, & SHORT_NAME ='CLCNX0', & LONG_NAME ='convective_cloud_area_fraction', & @@ -3605,6 +3693,14 @@ subroutine SetServices ( GC, RC ) VLOCATION = MAPL_VLocationCenter, RC=STATUS ) VERIFY_(STATUS) + call MAPL_AddExportSpec(GC, & + SHORT_NAME ='CLCNX1', & + LONG_NAME ='final_convective_cloud_area_fraction', & + UNITS ='1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, RC=STATUS ) + VERIFY_(STATUS) + call MAPL_AddExportSpec(GC, & SHORT_NAME ='QILSX0', & LONG_NAME ='initial_mass_fraction_of_large_scale_cloud_ice_water', & @@ -4044,7 +4140,293 @@ subroutine SetServices ( GC, RC ) VLOCATION = MAPL_VLocationCenter, RC=STATUS ) VERIFY_(STATUS) + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'DQVDT_FILL_SC', & + LONG_NAME = 'tendency_of_water_vapor_due_to_negative_fill_after_shallow_cu', & + UNITS = 'kg m-2 s-1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'DQLLSDT_FILL_SC', & + LONG_NAME = 'tendency_of_liquid_ls_due_to_negative_fill_after_shallow_cu', & + UNITS = 'kg m-2 s-1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'DQLCNDT_FILL_SC', & + LONG_NAME = 'tendency_of_liquid_cn_due_to_negative_fill_after_shallow_cu', & + UNITS = 'kg m-2 s-1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RC=STATUS ) + VERIFY_(STATUS) + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'DQILSDT_FILL_SC', & + LONG_NAME = 'tendency_of_ice_ls_due_to_negative_fill_after_shallow_cu', & + UNITS = 'kg m-2 s-1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'DQICNDT_FILL_SC', & + LONG_NAME = 'tendency_of_ice_cn_due_to_negative_fill_after_shallow_cu', & + UNITS = 'kg m-2 s-1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'DQRDT_FILL_SC', & + LONG_NAME = 'tendency_of_rain_due_to_negative_fill_after_shallow_cu', & + UNITS = 'kg m-2 s-1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'DQSDT_FILL_SC', & + LONG_NAME = 'tendency_of_snow_due_to_negative_fill_after_shallow_cu', & + UNITS = 'kg m-2 s-1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'DQGDT_FILL_SC', & + LONG_NAME = 'tendency_of_graupel_due_to_negative_fill_after_shallow_cu', & + UNITS = 'kg m-2 s-1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'DQVDT_FILL_DC', & + LONG_NAME = 'tendency_of_water_vapor_due_to_negative_fill_after_deep_cu', & + UNITS = 'kg m-2 s-1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'DQLLSDT_FILL_DC', & + LONG_NAME = 'tendency_of_liquid_ls_due_to_negative_fill_after_deep_cu', & + UNITS = 'kg m-2 s-1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'DQLCNDT_FILL_DC', & + LONG_NAME = 'tendency_of_liquid_cn_due_to_negative_fill_after_deep_cu', & + UNITS = 'kg m-2 s-1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'DQILSDT_FILL_DC', & + LONG_NAME = 'tendency_of_ice_ls_due_to_negative_fill_after_deep_cu', & + UNITS = 'kg m-2 s-1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'DQICNDT_FILL_DC', & + LONG_NAME = 'tendency_of_ice_cn_due_to_negative_fill_after_deep_cu', & + UNITS = 'kg m-2 s-1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'DQRDT_FILL_DC', & + LONG_NAME = 'tendency_of_rain_due_to_negative_fill_after_deep_cu', & + UNITS = 'kg m-2 s-1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'DQSDT_FILL_DC', & + LONG_NAME = 'tendency_of_snow_due_to_negative_fill_after_deep_cu', & + UNITS = 'kg m-2 s-1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'DQGDT_FILL_DC', & + LONG_NAME = 'tendency_of_graupel_due_to_negative_fill_after_deep_cu', & + UNITS = 'kg m-2 s-1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'DQVDT_FILL_CLDMACRO', & + LONG_NAME = 'tendency_of_water_vapor_due_to_negative_fill_after_cldmacro', & + UNITS = 'kg m-2 s-1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'DQLLSDT_FILL_CLDMACRO', & + LONG_NAME = 'tendency_of_liquid_ls_due_to_negative_fill_after_cldmacro', & + UNITS = 'kg m-2 s-1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'DQLCNDT_FILL_CLDMACRO', & + LONG_NAME = 'tendency_of_liquid_cn_due_to_negative_fill_after_cldmacro', & + UNITS = 'kg m-2 s-1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'DQILSDT_FILL_CLDMACRO', & + LONG_NAME = 'tendency_of_ice_ls_due_to_negative_fill_after_cldmacro', & + UNITS = 'kg m-2 s-1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'DQICNDT_FILL_CLDMACRO', & + LONG_NAME = 'tendency_of_ice_cn_due_to_negative_fill_after_cldmacro', & + UNITS = 'kg m-2 s-1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'DQRDT_FILL_CLDMACRO', & + LONG_NAME = 'tendency_of_rain_due_to_negative_fill_after_cldmacro', & + UNITS = 'kg m-2 s-1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'DQSDT_FILL_CLDMACRO', & + LONG_NAME = 'tendency_of_snow_due_to_negative_fill_after_cldmacro', & + UNITS = 'kg m-2 s-1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'DQGDT_FILL_CLDMACRO', & + LONG_NAME = 'tendency_of_graupel_due_to_negative_fill_after_cldmacro', & + UNITS = 'kg m-2 s-1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'DQVDT_FILL_CLDMICRO', & + LONG_NAME = 'tendency_of_water_vapor_due_to_negative_fill_after_cldmicro', & + UNITS = 'kg m-2 s-1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'DQLLSDT_FILL_CLDMICRO', & + LONG_NAME = 'tendency_of_liquid_ls_due_to_negative_fill_after_cldmicro', & + UNITS = 'kg m-2 s-1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'DQLCNDT_FILL_CLDMICRO', & + LONG_NAME = 'tendency_of_liquid_cn_due_to_negative_fill_after_cldmicro', & + UNITS = 'kg m-2 s-1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'DQILSDT_FILL_CLDMICRO', & + LONG_NAME = 'tendency_of_ice_ls_due_to_negative_fill_after_cldmicro', & + UNITS = 'kg m-2 s-1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'DQICNDT_FILL_CLDMICRO', & + LONG_NAME = 'tendency_of_ice_cn_due_to_negative_fill_after_cldmicro', & + UNITS = 'kg m-2 s-1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'DQRDT_FILL_CLDMICRO', & + LONG_NAME = 'tendency_of_rain_due_to_negative_fill_after_cldmicro', & + UNITS = 'kg m-2 s-1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'DQSDT_FILL_CLDMICRO', & + LONG_NAME = 'tendency_of_snow_due_to_negative_fill_after_cldmicro', & + UNITS = 'kg m-2 s-1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'DQGDT_FILL_CLDMICRO', & + LONG_NAME = 'tendency_of_graupel_due_to_negative_fill_after_cldmicro', & + UNITS = 'kg m-2 s-1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RC=STATUS ) + VERIFY_(STATUS) call MAPL_AddExportSpec(GC, & SHORT_NAME='DQVDT_micro', & @@ -4785,7 +5167,6 @@ subroutine SetServices ( GC, RC ) VLOCATION = MAPL_VLocationNone, RC=STATUS ) VERIFY_(STATUS) - call MAPL_AddExportSpec(GC, & SHORT_NAME='LTS', & LONG_NAME ='Lower tropospheric stability', & @@ -4794,7 +5175,7 @@ subroutine SetServices ( GC, RC ) VLOCATION = MAPL_VLocationNone, RC=STATUS ) VERIFY_(STATUS) - call MAPL_AddExportSpec(GC, & + call MAPL_AddExportSpec(GC, & SHORT_NAME='EIS', & LONG_NAME ='Estimated Inversion Strength', & UNITS ='K', & @@ -5141,26 +5522,26 @@ subroutine Initialize ( GC, IMPORT, EXPORT, CLOCK, RC ) !----------------------------------- call MAPL_GetResource( MAPL, LDIAGNOSE_PRECIP_TYPE, Label="DIAGNOSE_PRECIP_TYPE:", default=.FALSE., RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource( MAPL, LUPDATE_PRECIP_TYPE, Label="UPDATE_PRECIP_TYPE:", default=.FALSE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource( MAPL, LHYDROSTATIC, Label="HYDROSTATIC:", default=.TRUE. , RC=STATUS) call MAPL_GetResource( MAPL, USE_AEROSOL_NN , 'USE_AEROSOL_NN:' , DEFAULT=.TRUE. , RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource( MAPL, USE_BERGERON , 'USE_BERGERON:' , DEFAULT=USE_AEROSOL_NN, RC=STATUS); VERIFY_(STATUS) if (USE_AEROSOL_NN) then - call MAPL_GetResource( MAPL, USE_AERO_BUFFER , 'USE_AERO_BUFFER:' , DEFAULT=.TRUE. , RC=STATUS); VERIFY_(STATUS) call aer_cloud_init() call WRITE_PARALLEL ("INITIALIZED aer_cloud_init") endif ! MAT These have to be defined as they are passed into Aer_Activate below and are intent(in) ! Note: It's possible these aren't *used* if USE_AEROSOL_NN=.TRUE. but they are still passed ! in so they have to be defined - call MAPL_GetResource( MAPL, CCN_OCN, 'NCCN_OCN:', DEFAULT= 100., RC=STATUS); VERIFY_(STATUS) ! #/cm^3 - call MAPL_GetResource( MAPL, CCN_LND, 'NCCN_LND:', DEFAULT= 300., RC=STATUS); VERIFY_(STATUS) ! #/cm^3 + call MAPL_GetResource( MAPL, CCN_OCN, 'NCCN_OCN:', DEFAULT= 100., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource( MAPL, CCN_LND, 'NCCN_LND:', DEFAULT= 300., RC=STATUS); VERIFY_(STATUS) + + call MAPL_GetResource( MAPL, MOVE_CN_TO_LS, Label="MOVE_CN_TO_LS:", default=.FALSE., RC=STATUS); VERIFY_(STATUS) if (adjustl(CONVPAR_OPTION)=="RAS" ) call RAS_Initialize(MAPL, RC=STATUS) ; VERIFY_(STATUS) if (adjustl(CONVPAR_OPTION)=="GF" ) call GF_Initialize(MAPL, CLOCK, RC=STATUS) ; VERIFY_(STATUS) if (adjustl(SHALLOW_OPTION)=="UW" ) call UW_Initialize(MAPL, CLOCK, RC=STATUS) ; VERIFY_(STATUS) if (adjustl(CLDMICR_OPTION)=="BACM_1M") call BACM_1M_Initialize(MAPL, RC=STATUS) ; VERIFY_(STATUS) - if (adjustl(CLDMICR_OPTION)=="GFDL_1M") call GFDL_1M_Initialize(MAPL, RC=STATUS) ; VERIFY_(STATUS) + if (adjustl(CLDMICR_OPTION)=="GFDL_1M") call GFDL_1M_Initialize(MAPL, CLOCK, RC=STATUS) ; VERIFY_(STATUS) if (adjustl(CLDMICR_OPTION)=="THOM_1M") call THOM_1M_Initialize(MAPL, RC=STATUS) ; VERIFY_(STATUS) if (adjustl(CLDMICR_OPTION)=="MGB2_2M") call MGB2_2M_Initialize(MAPL, RC=STATUS) ; VERIFY_(STATUS) @@ -5220,14 +5601,16 @@ subroutine RUN ( GC, IMPORT, EXPORT, CLOCK, RC ) real, allocatable, dimension(:,:,:) :: QST3, DQST3, MWFA real, allocatable, dimension(:,:,:) :: TMP3D real, allocatable, dimension(:,:) :: TMP2D + integer, allocatable,dimension(:,:) :: KLCL ! Internals - real, pointer, dimension(:,:,:) :: Q, QLLS, QLCN, CLLS, CLCN, QILS, QICN - real, pointer, dimension(:,:,:) :: NACTL, NACTI, NCPL, NCPI + real, pointer, dimension(:,:,:) :: Q, QLLS, QLCN, CLLS, CLCN, QILS, QICN, QRTOT, QSTOT, QGTOT + real, pointer, dimension(:,:,:) :: NACTL, NACTI ! Imports real, pointer, dimension(:,:,:) :: ZLE, PLE, T, U, V, W real, pointer, dimension(:,:) :: FRLAND, FRLANDICE, FRACI, SNOMAS real, pointer, dimension(:,:) :: SH, TS, EVAP, KPBL real, pointer, dimension(:,:,:) :: KH, TKE, OMEGA + integer :: n_modes type(ESMF_State) :: AERO type(ESMF_FieldBundle) :: TR ! Exports @@ -5241,13 +5624,15 @@ subroutine RUN ( GC, IMPORT, EXPORT, CLOCK, RC ) real, pointer, dimension(:,: ) :: CAPE, INHB, MLCAPE, SBCAPE, MLCIN, MUCAPE, MUCIN, SBCIN, LFC, LNB real, pointer, dimension(:,: ) :: CNV_FRC, SRF_TYPE real, pointer, dimension(:,:,:) :: CFICE, CFLIQ - real, pointer, dimension(:,:,: ) :: NWFA + real, pointer, dimension(:,:,:) :: NWFA + real, pointer, dimension(:,:) :: EIS, LTS + real, pointer, dimension(:,:,:) :: PTRDC, PTRSC real, pointer, dimension(:,:,:) :: PTR3D real, pointer, dimension(:,: ) :: PTR2D real, pointer, dimension(: ) :: PTR1D integer :: IM,JM,LM - integer :: I, J, L + integer :: I, J, L, n !============================================================================= @@ -5295,8 +5680,6 @@ subroutine RUN ( GC, IMPORT, EXPORT, CLOCK, RC ) call MAPL_GetPointer(INTERNAL, QICN, 'QICN' , RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(INTERNAL, NACTL, 'NACTL' , RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(INTERNAL, NACTI, 'NACTI' , RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(INTERNAL, NCPL, 'NACTL' , RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(INTERNAL, NCPI, 'NACTI' , RC=STATUS); VERIFY_(STATUS) ! Import State call MAPL_GetPointer(IMPORT, PLE, 'PLE' , RC=STATUS); VERIFY_(STATUS) @@ -5349,6 +5732,7 @@ subroutine RUN ( GC, IMPORT, EXPORT, CLOCK, RC ) ALLOCATE ( MASS (IM,JM,LM ) ) ALLOCATE ( TMP3D(IM,JM,LM ) ) ALLOCATE ( TMP2D(IM,JM ) ) + ALLOCATE ( KLCL(IM,JM ) ) ! Save input winds call MAPL_GetPointer(EXPORT, PTR3D, 'UMST0', ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) @@ -5356,11 +5740,20 @@ subroutine RUN ( GC, IMPORT, EXPORT, CLOCK, RC ) call MAPL_GetPointer(EXPORT, PTR3D, 'VMST0', ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) PTR3D = V + ! pre-fill default condensate radii + call MAPL_GetPointer(EXPORT, PTR3D, 'RL', RC=STATUS); VERIFY_(STATUS) + if(associated(PTR3D)) PTR3D = MAPL_UNDEF + call MAPL_GetPointer(EXPORT, PTR3D, 'RI', RC=STATUS); VERIFY_(STATUS) + if(associated(PTR3D)) PTR3D = MAPL_UNDEF + call MAPL_GetPointer(EXPORT, PTR3D, 'RR', RC=STATUS); VERIFY_(STATUS) + if(associated(PTR3D)) PTR3D = 50.e-6 + call MAPL_GetPointer(EXPORT, PTR3D, 'RS', RC=STATUS); VERIFY_(STATUS) + if(associated(PTR3D)) PTR3D = 50.e-6 + call MAPL_GetPointer(EXPORT, PTR3D, 'RG', RC=STATUS); VERIFY_(STATUS) + if(associated(PTR3D)) PTR3D = 50.e-6 + ! Derived States MASS = ( PLE(:,:,1:LM)-PLE(:,:,0:LM-1) )/MAPL_GRAV - call FILLQ2ZERO(Q, MASS, TMP2D) - call MAPL_GetPointer(EXPORT, PTR2D, 'FILLNQV_IN', RC=STATUS); VERIFY_(STATUS) - if (associated(PTR2D)) PTR2D = TMP2D PLEmb = PLE*.01 PKE = (PLE/MAPL_P00)**(MAPL_KAPPA) PLmb = 0.5*(PLEmb(:,:,0:LM-1) + PLEmb(:,:,1:LM)) @@ -5372,6 +5765,21 @@ subroutine RUN ( GC, IMPORT, EXPORT, CLOCK, RC ) DZET = (ZLE0(:,:,0:LM-1) - ZLE0(:,:,1:LM) ) ! Layer thickness (m) DQST3 = GEOS_DQSAT(T, PLmb, QSAT=QST3) + ! Lower tropospheric stability and estimated inversion strength + call MAPL_GetPointer(EXPORT, LTS, 'LTS' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, EIS, 'EIS' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) + KLCL = FIND_KLCL( T, Q, PLmb, IM, JM, LM ) + call MAPL_GetPointer(EXPORT, PTR2D, 'ZLCL', RC=STATUS); VERIFY_(STATUS) + if (associated(PTR2D)) then + do J=1,JM + do I=1,IM + PTR2D(I,J) = ZL0(I,J,KLCL(I,J)) + end do + end do + endif + TMP3D = (100.0*PLmb/MAPL_P00)**(MAPL_KAPPA) + call FIND_EIS(T/TMP3D, QST3, T, ZL0, PLEmb, KLCL, IM, JM, LM, LTS, EIS) + ! Recording of import/internal vars into export if desired !--------------------------------------------------------- call MAPL_GetPointer(EXPORT, PTR3D, 'QX0' , RC=STATUS); VERIFY_(STATUS) @@ -5454,21 +5862,18 @@ subroutine RUN ( GC, IMPORT, EXPORT, CLOCK, RC ) call BUOYANCY2( IM, JM, LM, T, Q, QST3, DQST3, DZET, ZL0, PLmb, PLEmb(:,:,LM), SBCAPE, MLCAPE, MUCAPE, SBCIN, MLCIN, MUCIN, BYNCY, LFC, LNB ) call BUOYANCY( T, Q, QST3, DQST3, DZET, ZL0, BYNCY, CAPE, INHB) - ! reset total mass fluxes to be accumuated over deep and shalow convection - call MAPL_GetPointer(EXPORT, PTR3D, 'CNV_MFC', ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - PTR3D = 0.0 - call MAPL_GetPointer(EXPORT, PTR3D, 'CNV_MFD', ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - PTR3D = 0.0 - ! initialize diagnosed convective fraction CNV_FRC = 0.0 if( CNV_FRACTION_MAX > CNV_FRACTION_MIN ) then - WHERE (CAPE .ne. MAPL_UNDEF) - CNV_FRC =(MAX(1.e-6,MIN(1.0,(CAPE-CNV_FRACTION_MIN)/(CNV_FRACTION_MAX-CNV_FRACTION_MIN)))) - END WHERE - endif - if (CNV_FRACTION_EXP /= 1.0) then - CNV_FRC = CNV_FRC**CNV_FRACTION_EXP + WHERE (CAPE .ne. MAPL_UNDEF) + CNV_FRC = (1.0-COS(MAPL_PI*(CAPE-CNV_FRACTION_MIN)/(CNV_FRACTION_MAX-CNV_FRACTION_MIN)))/2.0 + END WHERE + WHERE (CAPE .le. CNV_FRACTION_MIN) + CNV_FRC = 0.0 + END WHERE + WHERE (CAPE .ge. CNV_FRACTION_MAX) + CNV_FRC = 1.0 + END WHERE endif ! Extract convective tracers from the TR bundle @@ -5479,17 +5884,44 @@ subroutine RUN ( GC, IMPORT, EXPORT, CLOCK, RC ) ! Get aerosol activation properties call MAPL_TimerOn (MAPL,"---AERO_ACTIVATE") if (USE_AEROSOL_NN) then - allocate ( AeroProps(IM,JM,LM) ) ! get veritical velocity - if (LHYDROSTATIC) then + if (all(W == 0.0)) then TMP3D = -OMEGA/(MAPL_GRAV*PLmb*100.0/(MAPL_RGAS*T)) else TMP3D = W endif ! Pressures in Pa - call Aer_Activation(IM,JM,LM, Q, T, PLmb*100.0, PLE, ZL0, ZLE0, QLCN, QICN, QLLS, QILS, & - SH, EVAP, KPBL, TKE, TMP3D, FRLAND, USE_AERO_BUFFER, & - AeroProps, AERO, NACTL, NACTI, NWFA, CCN_LND*1.e6, CCN_OCN*1.e6) + call Aer_Activation(MAPL, IM,JM,LM, Q, T, PLmb*100.0, PLE, TKE, TMP3D, FRLAND, & + AeroPropsNew, AERO, NACTL, NACTI, NWFA, CCN_LND*1.e6, CCN_OCN*1.e6, & + (adjustl(CLDMICR_OPTION)=="MGB2_2M"), __RC__) +! Temporary +! call MAPL_MaxMin('MST: NWFA ', NWFA *1.e-6) +! call MAPL_MaxMin('MST: NACTL ', NACTL*1.e-6) +! call MAPL_MaxMin('MST: NACTI ', NACTI*1.e-6) +! Temporary + if (adjustl(CLDMICR_OPTION)=="MGB2_2M") then + call MAPL_TimerOn (MAPL,"----AERO_ACTIVATE_MGB2_2M") + call ESMF_AttributeGet(AERO, name='number_of_aerosol_modes', value=n_modes, RC=STATUS); VERIFY_(STATUS) + allocate ( AeroProps(IM,JM,LM) ) + do L=1,LM + do J=1,JM + do I=1,IM + AeroProps(I,J,L)%nmods = n_modes + do n=1,n_modes + AeroProps(I,J,L)%num(n) = AeroPropsNew(n)%num(I,J,L) + AeroProps(I,J,L)%dpg(n) = AeroPropsNew(n)%dpg(I,J,L) + AeroProps(I,J,L)%sig(n) = AeroPropsNew(n)%sig(I,J,L) + AeroProps(I,J,L)%den(n) = AeroPropsNew(n)%den(I,J,L) + AeroProps(I,J,L)%kap(n) = AeroPropsNew(n)%kap(I,J,L) + AeroProps(I,J,L)%fdust(n) = AeroPropsNew(n)%fdust(I,J,L) + AeroProps(I,J,L)%fsoot(n) = AeroPropsNew(n)%fsoot(I,J,L) + AeroProps(I,J,L)%forg(n) = AeroPropsNew(n)%forg(I,J,L) + enddo + enddo + enddo + enddo + call MAPL_TimerOff (MAPL,"----AERO_ACTIVATE_MGB2_2M") + endif else do L=1,LM NACTL(:,:,L) = (CCN_LND*FRLAND + CCN_OCN*(1.0-FRLAND))*1.e6 ! #/m^3 @@ -5505,18 +5937,94 @@ subroutine RUN ( GC, IMPORT, EXPORT, CLOCK, RC ) if (SH_MD_DP) then if (adjustl(SHALLOW_OPTION)=="UW" ) call UW_Run(GC, IMPORT, EXPORT, CLOCK, RC=STATUS) ; VERIFY_(STATUS) + if (adjustl(SHALLOW_OPTION)=="UW" ) then + if (DEBUG_MST) then + call MAPL_MaxMin('MST: Q_AF_UW ', Q) + call MAPL_MaxMin('MST: T_AF_UW ', T) + call MAPL_MaxMin('MST: U_AF_UW ', U) + call MAPL_MaxMin('MST: V_AF_UW ', V) + endif + endif if (adjustl(CONVPAR_OPTION)=="RAS" ) call RAS_Run(GC, IMPORT, EXPORT, CLOCK, RC=STATUS) ; VERIFY_(STATUS) if (adjustl(CONVPAR_OPTION)=="GF" ) call GF_Run(GC, IMPORT, EXPORT, CLOCK, RC=STATUS) ; VERIFY_(STATUS) + if (adjustl(CONVPAR_OPTION)=="GF" ) then + if (DEBUG_MST) then + call MAPL_MaxMin('MST: Q_AF_GF ', Q) + call MAPL_MaxMin('MST: T_AF_GF ', T) + call MAPL_MaxMin('MST: U_AF_GF ', U) + call MAPL_MaxMin('MST: V_AF_GF ', V) + endif + endif else if (adjustl(CONVPAR_OPTION)=="RAS" ) call RAS_Run(GC, IMPORT, EXPORT, CLOCK, RC=STATUS) ; VERIFY_(STATUS) if (adjustl(CONVPAR_OPTION)=="GF" ) call GF_Run(GC, IMPORT, EXPORT, CLOCK, RC=STATUS) ; VERIFY_(STATUS) + if (adjustl(CONVPAR_OPTION)=="GF" ) then + if (DEBUG_MST) then + call MAPL_MaxMin('MST: Q_AF_GF ', Q) + call MAPL_MaxMin('MST: T_AF_GF ', T) + call MAPL_MaxMin('MST: U_AF_GF ', U) + call MAPL_MaxMin('MST: V_AF_GF ', V) + endif + endif if (adjustl(SHALLOW_OPTION)=="UW" ) call UW_Run(GC, IMPORT, EXPORT, CLOCK, RC=STATUS) ; VERIFY_(STATUS) + if (adjustl(SHALLOW_OPTION)=="UW" ) then + if (DEBUG_MST) then + call MAPL_MaxMin('MST: Q_AF_UW ', Q) + call MAPL_MaxMin('MST: T_AF_UW ', T) + call MAPL_MaxMin('MST: U_AF_UW ', U) + call MAPL_MaxMin('MST: V_AF_UW ', V) + endif + endif + endif + + ! Mass fluxes + ! accumuated over deep and shalow convection + call MAPL_GetPointer(EXPORT, PTR3D, 'CNV_MFC', ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, PTRDC, 'UMF_DC' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, PTRSC, 'UMF_SC' , RC=STATUS); VERIFY_(STATUS) + PTR3D = 0.0 + if (associated(PTRDC)) PTR3D = PTR3D + PTRDC + if (associated(PTRSC)) PTR3D = PTR3D + PTRSC + + if (MOVE_CN_TO_LS) then + do L = 1, LM + do J = 1, JM + do I = 1, IM + if (0.5*(PTR3D(I,J,L)+PTR3D(I,J,L+1)) < 1.e-5) then + ! Move all QL,QI,CL to LS when cnv_mfc is 0.0 + QLLS(I,J,L) = QLLS(I,J,L)+QLCN(I,J,L) + QLCN(I,J,L) = 0.0 + QILS(I,J,L) = QILS(I,J,L)+QICN(I,J,L) + QICN(I,J,L) = 0.0 + CLLS(I,J,L) = CLLS(I,J,L)+CLCN(I,J,L) + CLCN(I,J,L) = 0.0 + endif + ! cleanup clouds + call FIX_UP_CLOUDS( Q(I,J,L), T(I,J,L), QLLS(I,J,L), QILS(I,J,L), CLLS(I,J,L), QLCN(I,J,L), QICN(I,J,L), CLCN(I,J,L) ) + enddo + enddo + enddo endif + + call MAPL_GetPointer(EXPORT, PTR3D, 'CNV_MFD', ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, PTRDC, 'MFD_DC' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, PTRSC, 'MFD_SC' , RC=STATUS); VERIFY_(STATUS) + PTR3D = 0.0 + if (associated(PTRDC)) PTR3D = PTR3D + PTRDC + if (associated(PTRSC)) PTR3D = PTR3D + PTRSC + if (adjustl(CLDMICR_OPTION)=="BACM_1M") call BACM_1M_Run(GC, IMPORT, EXPORT, CLOCK, RC=STATUS) ; VERIFY_(STATUS) if (adjustl(CLDMICR_OPTION)=="GFDL_1M") call GFDL_1M_Run(GC, IMPORT, EXPORT, CLOCK, RC=STATUS) ; VERIFY_(STATUS) if (adjustl(CLDMICR_OPTION)=="THOM_1M") call THOM_1M_Run(GC, IMPORT, EXPORT, CLOCK, RC=STATUS) ; VERIFY_(STATUS) if (adjustl(CLDMICR_OPTION)=="MGB2_2M") call MGB2_2M_Run(GC, IMPORT, EXPORT, CLOCK, RC=STATUS) ; VERIFY_(STATUS) + if (DEBUG_MST) then + call MAPL_MaxMin('MST: Q_AF_MP ', Q) + call MAPL_MaxMin('MST: T_AF_MP ', T) + call MAPL_MaxMin('MST: U_AF_MP ', U) + call MAPL_MaxMin('MST: V_AF_MP ', V) + endif + ! Exports ! Cloud fraction exports call MAPL_GetPointer(EXPORT, CFICE, 'CFICE', ALLOC=.true., RC=STATUS); VERIFY_(STATUS) @@ -5536,18 +6044,8 @@ subroutine RUN ( GC, IMPORT, EXPORT, CLOCK, RC ) CFLIQ=MAX(MIN(CFLIQ, 1.0), 0.0) endif - ! Rain-out and Relative Humidity where RH > 110% - call MAPL_GetPointer(EXPORT, DTDT_ER, 'DTDT_ER', ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, DQVDT_ER, 'DQVDT_ER', ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - DTDT_ER = T - DQVDT_ER = Q - ! some diagnostics to export - if (.FALSE.) then - QST3 = GEOS_QsatICE (T, PLmb*100.0, DQ=DQST3) - else - DQST3 = GEOS_DQSAT (T, PLmb, QSAT=QST3) ! this qsat function expects hPa... - end if + QST3 = GEOS_QsatICE (T, PLmb*100.0, DQ=DQST3) call MAPL_GetPointer(EXPORT, PTR3D, 'RHICE', RC=STATUS); VERIFY_(STATUS) if (associated(PTR3D)) then PTR3D = Q/QST3 @@ -5555,7 +6053,6 @@ subroutine RUN ( GC, IMPORT, EXPORT, CLOCK, RC ) PTR3D=0.0 end where endif - call MAPL_GetPointer(EXPORT, PTR3D, 'SAT_RAT', RC=STATUS); VERIFY_(STATUS) if (associated(PTR3D)) then where (CFICE .lt. 0.99 .and. QST3 .gt. 1.0e-20) @@ -5566,15 +6063,17 @@ subroutine RUN ( GC, IMPORT, EXPORT, CLOCK, RC ) end where endif - if (adjustl(CLDMICR_OPTION)=="MGB2_2M") then - QST3 = GEOS_QsatLQU (T, PLmb*100.0, DQ=DQST3) !clean up only with respect to liquid water - else - DQST3 = GEOS_DQSAT (T, PLmb, QSAT=QST3) ! this qsat function expects hPa... - end if + QST3 = GEOS_QsatLQU (T, PLmb*100.0, DQ=DQST3) call MAPL_GetPointer(EXPORT, PTR3D, 'RHLIQ', RC=STATUS); VERIFY_(STATUS) if (associated(PTR3D)) PTR3D = Q/QST3 - ! rainout excesive RH + ! Clean up supersaturation only with respect to liquid water + call MAPL_GetPointer(EXPORT, DTDT_ER, 'DTDT_ER', ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, DQVDT_ER, 'DQVDT_ER', ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) + DTDT_ER = T + DQVDT_ER = Q + + ! Rain-out of Relative Humidity where RH > 110% call MAPL_GetPointer(EXPORT, LS_PRCP, 'LS_PRCP' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(EXPORT, PTR2D, 'ER_PRCP' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) where ( Q > 1.1*QST3 ) @@ -5582,23 +6081,22 @@ subroutine RUN ( GC, IMPORT, EXPORT, CLOCK, RC ) elsewhere TMP3D = 0.0 endwhere + ! protect against producing negatice QV + where ( TMP3D > Q ) + TMP3D = Q + endwhere PTR2D = SUM(TMP3D*MASS,3)/DT_MOIST LS_PRCP = LS_PRCP + PTR2D Q = Q - TMP3D T = T + (MAPL_ALHL/MAPL_CP)*TMP3D - DTDT_ER = (T - DTDT_ER)/DT_MOIST + + DTDT_ER = (T - DTDT_ER)/DT_MOIST DQVDT_ER = (Q - DQVDT_ER)/DT_MOIST - ! cleanup any negative QV/QC/CF - call FILLQ2ZERO(Q, MASS, TMP2D) - call MAPL_GetPointer(EXPORT, PTR2D, 'FILLNQV', RC=STATUS); VERIFY_(STATUS) - if (associated(PTR2D)) PTR2D = TMP2D/DT_MOIST - - if (USE_AEROSOL_NN) then + if (USE_AEROSOL_NN .and. adjustl(CLDMICR_OPTION)=="MGB2_2M") then deallocate ( AeroProps ) endif - ! Export Total Moist Tendencies call MAPL_GetPointer(EXPORT, DUDT, 'DUDT', RC=STATUS); VERIFY_(STATUS) @@ -5833,6 +6331,7 @@ subroutine RUN ( GC, IMPORT, EXPORT, CLOCK, RC ) if (associated(PTR2D)) CN_PRCP = CN_PRCP + PTR2D call MAPL_GetPointer(EXPORT, PTR2D, 'CN_SNR' , RC=STATUS); VERIFY_(STATUS) if (associated(PTR2D)) CN_PRCP = CN_PRCP + PTR2D + CN_PRCP = MAX(CN_PRCP, 0.0) endif ! all large-scale precip (rain+snow) @@ -5844,6 +6343,7 @@ subroutine RUN ( GC, IMPORT, EXPORT, CLOCK, RC ) if (associated(PTR2D)) LS_PRCP = LS_PRCP + PTR2D call MAPL_GetPointer(EXPORT, PTR2D, 'FRZR' , RC=STATUS); VERIFY_(STATUS) if (associated(PTR2D)) LS_PRCP = LS_PRCP + PTR2D + LS_PRCP = MAX(LS_PRCP, 0.0) endif ! all anvil precip (rain+snow) @@ -5858,6 +6358,7 @@ subroutine RUN ( GC, IMPORT, EXPORT, CLOCK, RC ) if (associated(SC_PRCP)) then call MAPL_GetPointer(EXPORT, PTR2D, 'SC_SNR' , RC=STATUS); VERIFY_(STATUS) if (associated(PTR2D)) SC_PRCP = SC_PRCP + PTR2D + SC_PRCP = MAX(SC_PRCP, 0.0) endif ! Total - all precip (rain+snow) @@ -5886,8 +6387,8 @@ subroutine RUN ( GC, IMPORT, EXPORT, CLOCK, RC ) if (associated(PTR2D)) PREC_STRAT = PREC_STRAT + PTR2D call MAPL_GetPointer(EXPORT, PTR2D, 'AN_PRCP' , RC=STATUS); VERIFY_(STATUS) if (associated(PTR2D)) PREC_STRAT = PREC_STRAT + PTR2D - PREC_STRAT = MAX(PREC_STRAT, 0.0) endif + PREC_STRAT = MAX(PREC_STRAT, 0.0) endif ! diagnosed convective precip (rain+snow) @@ -5901,8 +6402,8 @@ subroutine RUN ( GC, IMPORT, EXPORT, CLOCK, RC ) if (associated(PTR2D)) PREC_CONV = PREC_CONV + PTR2D call MAPL_GetPointer(EXPORT, PTR2D, 'SC_PRCP' , RC=STATUS); VERIFY_(STATUS) if (associated(PTR2D)) PREC_CONV = PREC_CONV + PTR2D - PREC_CONV = MAX(PREC_CONV, 0.0) endif + PREC_CONV = MAX(PREC_CONV, 0.0) endif ! Diagnostic precip types: @@ -5913,6 +6414,8 @@ subroutine RUN ( GC, IMPORT, EXPORT, CLOCK, RC ) call DIAGNOSE_PRECIP_TYPE(IM, JM, LM, TPREC, PLS, PCU, RAIN, SNOW, ICE, FRZR, & PTYPE, PLE, T/PK, PK, PKE, ZL0, LUPDATE_PRECIP_TYPE) endif + ICE = MAX(ICE, 0.0) + FRZR = MAX(FRZR, 0.0) ! Get Kuchera snow:rain ratios do I = 1,IM do J = 1,JM @@ -5945,7 +6448,15 @@ subroutine RUN ( GC, IMPORT, EXPORT, CLOCK, RC ) if (associated(PTR3D)) PTR3D = QILS+QICN call MAPL_GetPointer(EXPORT, PTR3D, 'QCTOT', RC=STATUS); VERIFY_(STATUS) - if (associated(PTR3D)) PTR3D = QLLS+QLCN+QILS+QICN + if (associated(PTR3D)) then + PTR3D = QLLS+QLCN+QILS+QICN + call MAPL_GetPointer(EXPORT, QRTOT, 'QRTOT', RC=STATUS); VERIFY_(STATUS) + if (associated(QRTOT)) PTR3D=PTR3D+QRTOT + call MAPL_GetPointer(EXPORT, QSTOT, 'QSTOT', RC=STATUS); VERIFY_(STATUS) + if (associated(QSTOT)) PTR3D=PTR3D+QSTOT + call MAPL_GetPointer(EXPORT, QGTOT, 'QGTOT', RC=STATUS); VERIFY_(STATUS) + if (associated(QGTOT)) PTR3D=PTR3D+QGTOT + endif ! Cloud condensate exports call MAPL_GetPointer(EXPORT, PTR3D, 'QLLSX1', RC=STATUS); VERIFY_(STATUS) @@ -5960,6 +6471,12 @@ subroutine RUN ( GC, IMPORT, EXPORT, CLOCK, RC ) call MAPL_GetPointer(EXPORT, PTR3D, 'QICNX1', RC=STATUS); VERIFY_(STATUS) if (associated(PTR3D)) PTR3D = QICN + call MAPL_GetPointer(EXPORT, PTR3D, 'CLLSX1', RC=STATUS); VERIFY_(STATUS) + if (associated(PTR3D)) PTR3D = CLLS + + call MAPL_GetPointer(EXPORT, PTR3D, 'CLCNX1', RC=STATUS); VERIFY_(STATUS) + if (associated(PTR3D)) PTR3D = CLCN + ! Fill wind, temperature & RH exports needed for SYNCTQ call MAPL_GetPointer(EXPORT, PTR3D, 'UAFMOIST', ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) @@ -5991,7 +6508,7 @@ subroutine RUN ( GC, IMPORT, EXPORT, CLOCK, RC ) call MAPL_GetPointer(EXPORT, PTR2D, 'CLWP', RC=STATUS); VERIFY_(STATUS) if (associated(PTR2D)) PTR2D = SUM( ( QLCN+QLLS ) *MASS , 3 ) call MAPL_GetPointer(EXPORT, PTR2D, 'LWP', RC=STATUS); VERIFY_(STATUS) - if (associated(PTR2D)) PTR2D = SUM( ( QLCN+QLLS) *MASS , 3 ) + if (associated(PTR2D)) PTR2D = SUM( ( QLCN+QLLS ) *MASS , 3 ) call MAPL_GetPointer(EXPORT, PTR2D, 'IWP', RC=STATUS); VERIFY_(STATUS) if (associated(PTR2D)) PTR2D = SUM( ( QICN+QILS ) *MASS , 3 ) call MAPL_GetPointer(EXPORT, PTR2D, 'TPW', RC=STATUS); VERIFY_(STATUS) @@ -6023,9 +6540,6 @@ subroutine RUN ( GC, IMPORT, EXPORT, CLOCK, RC ) ALLOCATE ( TMP2D(IM,JM ) ) ! dervied states MASS = ( PLE(:,:,1:LM)-PLE(:,:,0:LM-1) )/MAPL_GRAV - call FILLQ2ZERO(Q, MASS, TMP2D) - call MAPL_GetPointer(EXPORT, PTR2D, 'FILLNQV_IN', RC=STATUS); VERIFY_(STATUS) - if (associated(PTR2D)) PTR2D = TMP2D PLEmb = PLE*.01 PLmb = 0.5*(PLEmb(:,:,0:LM-1) + PLEmb(:,:,1:LM)) PK = (100.0*PLmb/MAPL_P00)**(MAPL_KAPPA) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_NSSL_2M_InterfaceMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_NSSL_2M_InterfaceMod.F90 new file mode 100644 index 000000000..959050cbc --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_NSSL_2M_InterfaceMod.F90 @@ -0,0 +1,1128 @@ +! $Id$ + +#include "MAPL_Generic.h" + +!============================================================================= +!BOP + +! !MODULE: GEOS_NSSL_2M_InterfaceMod -- A Module to interface with the +! NSSL_2M cloud microphysics + +module GEOS_NSSL_2M_InterfaceMod + + use ESMF + use MAPL + use GEOS_UtilsMod + use GEOSmoist_Process_Library + use Aer_Actv_Single_Moment + use module_mp_nssl_2mom + + implicit none + + private + + character(len=ESMF_MAXSTR) :: IAm + integer :: STATUS + + ! specify how to handle friendlies with DYN:TRB:CHM:ANA + type FRIENDLIES_TYPE + character(len=ESMF_MAXSTR) :: QV + character(len=ESMF_MAXSTR) :: CLLS + character(len=ESMF_MAXSTR) :: CLCN + character(len=ESMF_MAXSTR) :: QLLS + character(len=ESMF_MAXSTR) :: QLCN + character(len=ESMF_MAXSTR) :: QILS + character(len=ESMF_MAXSTR) :: QICN + character(len=ESMF_MAXSTR) :: QRAIN + character(len=ESMF_MAXSTR) :: QSNOW + character(len=ESMF_MAXSTR) :: QGRAUPEL + character(len=ESMF_MAXSTR) :: NCPL + character(len=ESMF_MAXSTR) :: NCPI + character(len=ESMF_MAXSTR) :: NRAIN + end type FRIENDLIES_TYPE + type (FRIENDLIES_TYPE) FRIENDLIES + + character(len=ESMF_MAXSTR) :: COMP_NAME + + ! Local resource variables + real :: TURNRHCRIT_PARAM + real :: TAU_EVAP, CCW_EVAP_EFF + real :: TAU_SUBL, CCI_EVAP_EFF + integer :: PDFSHAPE + real :: ANV_ICEFALL + real :: LS_ICEFALL + real :: FAC_RL + real :: MIN_RL + real :: MAX_RL + real :: FAC_RI + real :: MIN_RI + real :: MAX_RI + logical :: LMELTFRZ + + public :: NSSL_2M_Setup, NSSL_2M_Initialize, NSSL_2M_Run + +contains + +subroutine NSSL_2M_Setup (GC, CF, RC) + type(ESMF_GridComp), intent(INOUT) :: GC ! gridded component + type(ESMF_Config), intent(inout) :: CF + integer, optional :: RC ! return code + character(len=ESMF_MAXSTR) :: COMP_NAME + + IAm = "GEOS_NSSL_2M_InterfaceMod" + call ESMF_GridCompGet( GC, NAME=COMP_NAME, RC=STATUS ) + VERIFY_(STATUS) + Iam = trim(COMP_NAME) // Iam + + ! !INTERNAL STATE: + + FRIENDLIES%QV = "DYNAMICS:TURBULENCE:CHEMISTRY:ANALYSIS" + FRIENDLIES%CLLS = "DYNAMICS" + FRIENDLIES%CLCN = "DYNAMICS" + FRIENDLIES%QLLS = "DYNAMICS:TURBULENCE" + FRIENDLIES%QLCN = "DYNAMICS:TURBULENCE" + FRIENDLIES%QILS = "DYNAMICS:TURBULENCE" + FRIENDLIES%QICN = "DYNAMICS:TURBULENCE" + FRIENDLIES%QRAIN = "DYNAMICS:TURBULENCE" + FRIENDLIES%QSNOW = "DYNAMICS:TURBULENCE" + FRIENDLIES%QGRAUPEL = "DYNAMICS:TURBULENCE" + FRIENDLIES%NCPL = "DYNAMICS:TURBULENCE" + FRIENDLIES%NCPI = "DYNAMICS:TURBULENCE" + FRIENDLIES%NRAIN = "DYNAMICS:TURBULENCE" + + !BOS + + call MAPL_AddInternalSpec(GC, & + SHORT_NAME = 'Q', & + LONG_NAME = 'specific_humidity', & + UNITS = 'kg kg-1', & + FRIENDLYTO = trim(FRIENDLIES%QV), & + default = 1.0e-6, & + RESTART = MAPL_RestartRequired, & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddInternalSpec(GC, & + SHORT_NAME = 'QLLS', & + LONG_NAME = 'mass_fraction_of_large_scale_cloud_liquid_water', & + UNITS = 'kg kg-1', & + FRIENDLYTO = trim(FRIENDLIES%QLLS), & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddInternalSpec(GC, & + SHORT_NAME = 'QLCN', & + LONG_NAME = 'mass_fraction_of_convective_cloud_liquid_water', & + UNITS = 'kg kg-1', & + FRIENDLYTO = trim(FRIENDLIES%QLCN), & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddInternalSpec(GC, & + SHORT_NAME = 'CLLS', & + LONG_NAME = 'large_scale_cloud_area_fraction', & + UNITS = '1', & + FRIENDLYTO = trim(FRIENDLIES%CLLS), & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddInternalSpec(GC, & + SHORT_NAME = 'CLCN', & + LONG_NAME = 'convective_cloud_area_fraction', & + UNITS = '1', & + FRIENDLYTO = trim(FRIENDLIES%CLCN), & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddInternalSpec(GC, & + SHORT_NAME = 'QILS', & + LONG_NAME = 'mass_fraction_of_large_scale_cloud_ice_water', & + UNITS = 'kg kg-1', & + FRIENDLYTO = trim(FRIENDLIES%QILS), & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddInternalSpec(GC, & + SHORT_NAME = 'QICN', & + LONG_NAME = 'mass_fraction_of_convective_cloud_ice_water', & + UNITS = 'kg kg-1', & + FRIENDLYTO = trim(FRIENDLIES%QICN), & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddInternalSpec(GC, & + SHORT_NAME = 'QRAIN', & + LONG_NAME = 'mass_fraction_of_rain', & + UNITS = 'kg kg-1', & + FRIENDLYTO = trim(FRIENDLIES%QRAIN), & + default = 0.0, & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddInternalSpec(GC, & + SHORT_NAME = 'QSNOW', & + LONG_NAME = 'mass_fraction_of_snow', & + UNITS = 'kg kg-1', & + FRIENDLYTO = trim(FRIENDLIES%QSNOW), & + default = 0.0, & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddInternalSpec(GC, & + SHORT_NAME = 'QGRAUPEL', & + LONG_NAME = 'mass_fraction_of_graupel', & + UNITS = 'kg kg-1', & + FRIENDLYTO = trim(FRIENDLIES%QGRAUPEL), & + default = 0.0, & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddInternalSpec(GC, & + SHORT_NAME ='NCPL', & + LONG_NAME ='particle_number_for_liquid_cloud', & + UNITS ='kg-1', & + FRIENDLYTO = trim(FRIENDLIES%NCPL), & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + DEFAULT = 50.0e6 , __RC__ ) + + call MAPL_AddInternalSpec(GC, & + SHORT_NAME ='NCPI', & + LONG_NAME ='particle_number_for_ice_cloud', & + UNITS ='kg-1', & + FRIENDLYTO = trim(FRIENDLIES%NCPI), & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + DEFAULT = 1.0e3, __RC__ ) + + call MAPL_AddInternalSpec(GC, & + SHORT_NAME ='NRAIN', & + LONG_NAME ='particle_number_for_rain', & + UNITS ='kg-1', & + FRIENDLYTO = trim(FRIENDLIES%NRAIN), & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + DEFAULT = 0.0 , __RC__ ) + + call MAPL_AddInternalSpec(GC, & + SHORT_NAME = 'NACTL', & + LONG_NAME = 'activ aero # conc liq phase for 1-mom', & + UNITS = 'm-3', & + RESTART = MAPL_RestartSkip, & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddInternalSpec(GC, & + SHORT_NAME = 'NACTI', & + LONG_NAME = 'activ aero # conc ice phase for 1-mom', & + UNITS = 'm-3', & + RESTART = MAPL_RestartSkip, & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_TimerAdd(GC, name="--NSSL_2M", RC=STATUS) + VERIFY_(STATUS) + +end subroutine NSSL_2M_Setup + +subroutine NSSL_2M_Initialize (MAPL, RC) + type (MAPL_MetaComp), intent(inout) :: MAPL + integer, optional :: RC ! return code + + type (ESMF_Grid ) :: GRID + type (ESMF_State) :: INTERNAL + + type (ESMF_Alarm ) :: ALARM + type (ESMF_TimeInterval) :: TINT + real(ESMF_KIND_R8) :: DT_R8 + real :: DT_MOIST + + real, pointer, dimension(:,:,:) :: Q, QLLS, QLCN, QILS, QICN, QRAIN, QSNOW, QGRAUPEL + + integer :: IM, JM, LM + + integer :: NSSL_CONFIG + + integer, parameter :: NSSL_1MOM = 1 + integer, parameter :: NSSL_2MOM = 2 + integer, parameter :: NSSL_2MOMG = 3 + + real, parameter :: con_g = MAPL_GRAV + real, parameter :: con_rd = MAPL_RGAS + real, parameter :: con_cp = MAPL_CP + real, parameter :: con_rv = MAPL_RVAP + real, parameter :: con_t0c = MAPL_TICE + real, parameter :: con_cliq = MAPL_CAPWTR + real, parameter :: con_csol = MAPL_CAPICE + real, parameter :: con_eps = MAPL_EPSILON + + REAL, DIMENSION(20) :: nssl_params + + character(len=ESMF_MAXSTR) :: errmsg + integer :: errflg + + type(ESMF_VM) :: VM + integer :: comm + + call MAPL_GetResource( MAPL, LMELTFRZ, Label="MELTFRZ:", default=.TRUE., RC=STATUS) + VERIFY_(STATUS) + + call MAPL_Get( MAPL, IM=IM, JM=JM, LM=LM, & + INTERNAL_ESMF_STATE=INTERNAL, & + RC=STATUS ) + VERIFY_(STATUS) + call MAPL_Get( MAPL, & + RUNALARM = ALARM, & + INTERNAL_ESMF_STATE=INTERNAL, & + RC=STATUS ) + VERIFY_(STATUS) + + call ESMF_AlarmGet(ALARM, RingInterval=TINT, RC=STATUS); VERIFY_(STATUS) + call ESMF_TimeIntervalGet(TINT, S_R8=DT_R8,RC=STATUS); VERIFY_(STATUS) + DT_MOIST = DT_R8 + + call MAPL_GetPointer(INTERNAL, Q, 'Q' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL, QRAIN, 'QRAIN' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL, QSNOW, 'QSNOW' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL, QGRAUPEL, 'QGRAUPEL', RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL, QLLS, 'QLLS' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL, QLCN, 'QLCN' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL, QILS, 'QILS' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL, QICN, 'QICN' , RC=STATUS); VERIFY_(STATUS) + + call ESMF_VMGetCurrent(VM, _RC) + call ESMF_VMGet(VM, mpiCommunicator=comm, _RC) + + call nssl_2mom_init_const( & + con_g, con_rd, con_cp, con_rv, con_t0c, con_cliq, con_csol, con_eps ) + + nssl_params(1) = 0.6e9 ! nssl_cccn CCN base value + nssl_params(2) = 0. ! nssl_alphah PSD shape parameter for graupel (2-moment) + nssl_params(3) = 1. ! nssl_alphahl PSD shape parameter for hail (2-moment) + nssl_params(4) = 4.e5 ! nssl_cnoh graupel intercept (1-moment only) + nssl_params(5) = 4.e4 ! nssl_cnohl hail intercept (1-moment only) + nssl_params(6) = 8.e5 ! nssl_cnor rain intercept (1-moment only) + nssl_params(7) = 3.e6 ! nssl_cnos snow intercept (1-moment only) + nssl_params(8) = 500. ! nssl_rho_qh graupel density + nssl_params(9) = 800. ! nssl_rho_qhl hail density + nssl_params(10) = 100. ! nssl_rho_qs snow density + nssl_params(11) = 0. ! nssl_ipelec_tmp + nssl_params(12) = 0. ! nssl_isaund + + call MAPL_GetResource( MAPL, NSSL_CONFIG, Label="NSSL_CONFIG:", default=1, RC=STATUS) + VERIFY_(STATUS) + mp_select: SELECT CASE(NSSL_CONFIG) + + CASE (NSSL_1MOM) + call nssl_2mom_init(1,IM, 1,JM, 1,LM, nssl_params,ipctmp=0,mixphase=0,ihvol=0, errmsg=errmsg, errflg=errflg) + CASE (NSSL_2MOM) + call nssl_2mom_init(1,IM, 1,JM, 1,LM, nssl_params,ipctmp=5,mixphase=0,ihvol=1, errmsg=errmsg, errflg=errflg) + CASE (NSSL_2MOMG) + call nssl_2mom_init(1,IM, 1,JM, 1,LM, nssl_params,ipctmp=5,mixphase=0,ihvol=-1, errmsg=errmsg, errflg=errflg) ! turn off hail + CASE DEFAULT + + END SELECT mp_select + + + call WRITE_PARALLEL ("INITIALIZED NSSL_2M microphysics in non-generic GC INIT") + + call MAPL_GetResource( MAPL, SH_MD_DP , 'SH_MD_DP:' , DEFAULT= .TRUE., RC=STATUS); VERIFY_(STATUS) + + call MAPL_GetResource( MAPL, DBZ_LIQUID_SKIN , 'DBZ_LIQUID_SKIN:' , DEFAULT= 0 , RC=STATUS); VERIFY_(STATUS) + + call MAPL_GetResource( MAPL, TURNRHCRIT_PARAM, 'TURNRHCRIT:' , DEFAULT= -9999., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource( MAPL, PDFSHAPE , 'PDFSHAPE:' , DEFAULT= 1 , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource( MAPL, ANV_ICEFALL , 'ANV_ICEFALL:' , DEFAULT= 1.0 , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource( MAPL, LS_ICEFALL , 'LS_ICEFALL:' , DEFAULT= 1.0 , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource( MAPL, LIQ_RADII_PARAM , 'LIQ_RADII_PARAM:' , DEFAULT= 1 , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource( MAPL, ICE_RADII_PARAM , 'ICE_RADII_PARAM:' , DEFAULT= 2 , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource( MAPL, FAC_RI , 'FAC_RI:' , DEFAULT= 1.0 , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource( MAPL, MIN_RI , 'MIN_RI:' , DEFAULT= 5.e-6, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource( MAPL, MAX_RI , 'MAX_RI:' , DEFAULT=100.e-6, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource( MAPL, FAC_RL , 'FAC_RL:' , DEFAULT= 1.0 , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource( MAPL, MIN_RL , 'MIN_RL:' , DEFAULT= 2.5e-6, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource( MAPL, MAX_RL , 'MAX_RL:' , DEFAULT=60.0e-6, RC=STATUS); VERIFY_(STATUS) + + CCW_EVAP_EFF = 2.e-3 + call MAPL_GetResource( MAPL, CCW_EVAP_EFF, 'CCW_EVAP_EFF:', DEFAULT= CCW_EVAP_EFF, RC=STATUS); VERIFY_(STATUS) + + CCI_EVAP_EFF = 2.e-3 + call MAPL_GetResource( MAPL, CCI_EVAP_EFF, 'CCI_EVAP_EFF:', DEFAULT= CCI_EVAP_EFF, RC=STATUS); VERIFY_(STATUS) + + call MAPL_GetResource( MAPL, CNV_FRACTION_MIN, 'CNV_FRACTION_MIN:', DEFAULT= 500.0, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource( MAPL, CNV_FRACTION_MAX, 'CNV_FRACTION_MAX:', DEFAULT= 1500.0, RC=STATUS); VERIFY_(STATUS) + +end subroutine NSSL_2M_Initialize + +subroutine NSSL_2M_Run (GC, IMPORT, EXPORT, CLOCK, RC) + type(ESMF_GridComp), intent(inout) :: GC ! Gridded component + type(ESMF_State), intent(inout) :: IMPORT ! Import state + type(ESMF_State), intent(inout) :: EXPORT ! Export state + type(ESMF_Clock), intent(inout) :: CLOCK ! The clock + integer, optional, intent( out) :: RC ! Error code: + + ! Local derived type aliases + + type (MAPL_MetaComp), pointer :: MAPL + type (ESMF_Config ) :: CF + type (ESMF_State ) :: INTERNAL + type (ESMF_Alarm ) :: ALARM + type (ESMF_TimeInterval) :: TINT + real(ESMF_KIND_R8) :: DT_R8 + real :: DT_MOIST + + ! Internals + real, pointer, dimension(:,:,:) :: Q, QLLS, QLCN, CLLS, CLCN, QILS, QICN, QRAIN, QSNOW, QGRAUPEL + real, pointer, dimension(:,:,:) :: NCPL, NCPI, NRAIN, NACTL, NACTI + ! Imports + real, pointer, dimension(:,:,:) :: ZLE, PLE, T, U, V, W, KH + real, pointer, dimension(:,:) :: AREA, FRLAND, TS, DTSX, SH, EVAP, KPBLSC + real, pointer, dimension(:,:,:) :: SL2, SL3, QT2, QT3, W2, W3, SLQT, WQT, WQL, WSL, PDF_A + real, pointer, dimension(:,:,:) :: WTHV2 + real, pointer, dimension(:,:,:) :: OMEGA + ! Local + real, allocatable, dimension(:,:,:) :: U0, V0 + real, allocatable, dimension(:,:,:) :: PLEmb, ZLE0 + real, allocatable, dimension(:,:,:) :: PLmb, ZL0 + real, allocatable, dimension(:,:,:) :: DZ, DZET, DP, MASS, iMASS + real, allocatable, dimension(:,:,:) :: DQST3, QST3 + real, allocatable, dimension(:,:,:) :: DQVDTmic, DQLDTmic, DQRDTmic, DQIDTmic, & + DQSDTmic, DQGDTmic, DQADTmic, & + DUDTmic, DVDTmic, DTDTmic + real, allocatable, dimension(:,:,:) :: TMP3D + real, allocatable, dimension(:,:) :: TMP2D + integer, allocatable, dimension(:,:) :: KLCL + ! Exports + real, pointer, dimension(:,: ) :: PRCP_RAIN, PRCP_SNOW, PRCP_ICE, PRCP_GRAUPEL + real, pointer, dimension(:,: ) :: LS_PRCP, LS_SNR, ICE, FRZR, CNV_FRC, SRF_TYPE + real, pointer, dimension(:,:,:) :: DQVDT_macro, DQIDT_macro, DQLDT_macro, DQADT_macro, DQRDT_macro, DQSDT_macro, DQGDT_macro + real, pointer, dimension(:,:,:) :: DUDT_macro, DVDT_macro, DTDT_macro + real, pointer, dimension(:,:,:) :: DQVDT_micro, DQIDT_micro, DQLDT_micro, DQADT_micro, DQRDT_micro, DQSDT_micro, DQGDT_micro + real, pointer, dimension(:,:,:) :: DUDT_micro, DVDT_micro, DTDT_micro + real, pointer, dimension(:,:,:) :: RAD_CF, RAD_QV, RAD_QL, RAD_QI, RAD_QR, RAD_QS, RAD_QG + real, pointer, dimension(:,:,:) :: CLDREFFL, CLDREFFI + real, pointer, dimension(:,:,:) :: EVAPC, SUBLC + real, pointer, dimension(:,:,:) :: RHX, REV_LS, RSU_LS + real, pointer, dimension(:,:,:) :: PFL_LS, PFL_AN + real, pointer, dimension(:,:,:) :: PFI_LS, PFI_AN + real, pointer, dimension(:,:,:) :: PDFITERS + real, pointer, dimension(:,:,:) :: RHCRIT3D + real, pointer, dimension(:,:) :: EIS, LTS + real, pointer, dimension(:,:) :: DBZ_MAX, DBZ_1KM, DBZ_TOP, DBZ_M10C + real, pointer, dimension(:,:,:) :: PTR3D + real, pointer, dimension(:,: ) :: PTR2D + + ! Local variables + real :: facEIS + real :: minrhcrit, turnrhcrit, ALPHA, RHCRIT + integer :: IM,JM,LM + integer :: I, J, L + + call ESMF_GridCompGet( GC, CONFIG=CF, RC=STATUS ) + VERIFY_(STATUS) + + ! Get my internal MAPL_Generic state + !----------------------------------- + + call MAPL_GetObjectFromGC ( GC, MAPL, RC=STATUS) + VERIFY_(STATUS) + + call MAPL_TimerOn (MAPL,"--NSSL_2M",RC=STATUS) + + ! Get parameters from generic state. + !----------------------------------- + + call MAPL_Get( MAPL, IM=IM, JM=JM, LM=LM, & + RUNALARM = ALARM, & + CF = CF, & + INTERNAL_ESMF_STATE=INTERNAL, & + RC=STATUS ) + VERIFY_(STATUS) + + call ESMF_AlarmGet(ALARM, RingInterval=TINT, RC=STATUS); VERIFY_(STATUS) + call ESMF_TimeIntervalGet(TINT, S_R8=DT_R8,RC=STATUS); VERIFY_(STATUS) + DT_MOIST = DT_R8 + + call MAPL_GetPointer(INTERNAL, Q, 'Q' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL, QRAIN, 'QRAIN' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL, QSNOW, 'QSNOW' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL, QGRAUPEL, 'QGRAUPEL', RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL, QLLS, 'QLLS' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL, QLCN, 'QLCN' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL, CLCN, 'CLCN' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL, CLLS, 'CLLS' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL, QILS, 'QILS' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL, QICN, 'QICN' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL, NCPL, 'NCPL' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL, NCPI, 'NCPI' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL, NRAIN, 'NRAIN' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL, NACTL, 'NACTL' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL, NACTI, 'NACTI' , RC=STATUS); VERIFY_(STATUS) + + ! Import State + call MAPL_GetPointer(IMPORT, AREA, 'AREA' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(IMPORT, ZLE, 'ZLE' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(IMPORT, PLE, 'PLE' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(IMPORT, T, 'T' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(IMPORT, U, 'U' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(IMPORT, V, 'V' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(IMPORT, W, 'W' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(IMPORT, FRLAND, 'FRLAND' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(IMPORT, KH, 'KH' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(IMPORT, PDF_A, 'PDF_A' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(IMPORT, W2, 'W2' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(IMPORT, W3, 'W3' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(IMPORT, WQT, 'WQT' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(IMPORT, WSL, 'WSL' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(IMPORT, SL2, 'SL2' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(IMPORT, SL3, 'SL3' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(IMPORT, QT2, 'QT2' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(IMPORT, QT3, 'QT3' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(IMPORT, SLQT, 'SLQT' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(IMPORT, TS, 'TS' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(IMPORT, KPBLSC, 'KPBL_SC' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(IMPORT, SH, 'SH' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(IMPORT, EVAP, 'EVAP' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(IMPORT, OMEGA, 'OMEGA' , RC=STATUS); VERIFY_(STATUS) + + ! Allocatables + ! Edge variables + ALLOCATE ( ZLE0 (IM,JM,0:LM) ) + ALLOCATE ( PLEmb(IM,JM,0:LM) ) + ! Layer variables + ALLOCATE ( U0 (IM,JM,LM ) ) + ALLOCATE ( V0 (IM,JM,LM ) ) + ALLOCATE ( ZL0 (IM,JM,LM ) ) + ALLOCATE ( PLmb (IM,JM,LM ) ) + ALLOCATE ( DZET (IM,JM,LM ) ) + ALLOCATE ( DZ (IM,JM,LM ) ) + ALLOCATE ( DP (IM,JM,LM ) ) + ALLOCATE ( MASS (IM,JM,LM ) ) + ALLOCATE ( iMASS(IM,JM,LM ) ) + ALLOCATE ( DQST3(IM,JM,LM ) ) + ALLOCATE ( QST3(IM,JM,LM ) ) + ALLOCATE ( TMP3D(IM,JM,LM ) ) + ! Local tendencies + ALLOCATE ( DQVDTmic(IM,JM,LM ) ) + ALLOCATE ( DQLDTmic(IM,JM,LM ) ) + ALLOCATE ( DQIDTmic(IM,JM,LM ) ) + ALLOCATE ( DQRDTmic(IM,JM,LM ) ) + ALLOCATE ( DQSDTmic(IM,JM,LM ) ) + ALLOCATE ( DQGDTmic(IM,JM,LM ) ) + ALLOCATE ( DQADTmic(IM,JM,LM ) ) + ALLOCATE ( DUDTmic(IM,JM,LM ) ) + ALLOCATE ( DVDTmic(IM,JM,LM ) ) + ALLOCATE ( DTDTmic(IM,JM,LM ) ) + ! 2D Variables + ALLOCATE ( KLCL (IM,JM) ) + ALLOCATE ( TMP2D (IM,JM) ) + + ! Derived States + PLEmb = PLE*.01 + PLmb = 0.5*(PLEmb(:,:,0:LM-1) + PLEmb(:,:,1:LM)) + DO L=0,LM + ZLE0(:,:,L)= ZLE(:,:,L) - ZLE(:,:,LM) ! Edge Height (m) above the surface + END DO + ZL0 = 0.5*(ZLE0(:,:,0:LM-1) + ZLE0(:,:,1:LM) ) ! Layer Height (m) above the surface + DZET = (ZLE0(:,:,0:LM-1) - ZLE0(:,:,1:LM) ) ! Layer thickness (m) + DQST3 = GEOS_DQSAT(T, PLmb, QSAT=QST3) + DP = ( PLE(:,:,1:LM)-PLE(:,:,0:LM-1) ) + MASS = DP/MAPL_GRAV + iMASS = 1.0/MASS + U0 = U + V0 = V + + ! Export and/or scratch Variable + call MAPL_GetPointer(EXPORT, RAD_CF, 'FCLD', ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, RAD_QV, 'QV' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, RAD_QL, 'QL' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, RAD_QI, 'QI' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, RAD_QR, 'QR' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, RAD_QS, 'QS' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, RAD_QG, 'QG' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, CLDREFFL, 'RL' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, CLDREFFI, 'RI' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) + ! This export MUST have been filled in the GridComp + call MAPL_GetPointer(EXPORT, CNV_FRC, 'CNV_FRC' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, SRF_TYPE, 'SRF_TYPE' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) + ! Exports required below + call MAPL_GetPointer(EXPORT, EVAPC, 'EVAPC' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, SUBLC, 'SUBLC' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, PRCP_RAIN, 'PRCP_RAIN' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, PRCP_SNOW, 'PRCP_SNOW' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, PRCP_ICE, 'PRCP_ICE' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, PRCP_GRAUPEL, 'PRCP_GRAUPEL' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) + ! Exports to be filled + call MAPL_GetPointer(EXPORT, LS_PRCP, 'LS_PRCP' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, LS_SNR, 'LS_SNR' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, ICE, 'ICE' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, FRZR, 'FRZR' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, RHX , 'RHX' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, REV_LS, 'REV_LS' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, RSU_LS, 'RSU_LS' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, PFL_AN, 'PFL_AN' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, PFL_LS, 'PFL_LS' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, PFI_AN, 'PFI_AN' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, PFI_LS, 'PFI_LS' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, WTHV2, 'WTHV2' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, WQL, 'WQL' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, PDFITERS, 'PDFITERS', ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) + ! Unused Exports (forced to 0.0) + call MAPL_GetPointer(EXPORT, PTR2D, 'CN_PRCP' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS); PTR2D=0.0 + call MAPL_GetPointer(EXPORT, PTR2D, 'AN_PRCP' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS); PTR2D=0.0 + call MAPL_GetPointer(EXPORT, PTR2D, 'SC_PRCP' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS); PTR2D=0.0 + call MAPL_GetPointer(EXPORT, PTR2D, 'CN_SNR' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS); PTR2D=0.0 + call MAPL_GetPointer(EXPORT, PTR2D, 'AN_SNR' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS); PTR2D=0.0 + call MAPL_GetPointer(EXPORT, PTR2D, 'SC_SNR' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS); PTR2D=0.0 + ! Lowe tropospheric stability and estimated inversion strength + call MAPL_GetPointer(EXPORT, LTS, 'LTS' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, EIS, 'EIS' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) + KLCL = FIND_KLCL( T, Q, PLmb, IM, JM, LM ) + call MAPL_GetPointer(EXPORT, PTR2D, 'ZLCL', RC=STATUS); VERIFY_(STATUS) + if (associated(PTR2D)) then + do J=1,JM + do I=1,IM + PTR2D(I,J) = ZL0(I,J,KLCL(I,J)) + end do + end do + endif + TMP3D = (100.0*PLmb/MAPL_P00)**(MAPL_KAPPA) + call FIND_EIS(T/TMP3D, QST3, T, ZL0, PLEmb, KLCL, IM, JM, LM, LTS, EIS) + + call MAPL_TimerOn(MAPL,"---CLDMACRO") + call MAPL_GetPointer(EXPORT, DQVDT_macro, 'DQVDT_macro' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, DQIDT_macro, 'DQIDT_macro' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, DQLDT_macro, 'DQLDT_macro' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, DQADT_macro, 'DQADT_macro' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, DQRDT_macro, 'DQRDT_macro' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, DQSDT_macro, 'DQSDT_macro' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, DQGDT_macro, 'DQGDT_macro' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, DUDT_macro, 'DUDT_macro' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, DVDT_macro, 'DVDT_macro' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, DTDT_macro, 'DTDT_macro' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) + DUDT_macro=U + DVDT_macro=V + DTDT_macro=T + DQVDT_macro=Q + DQLDT_macro=QLCN+QLLS + DQIDT_macro=QICN+QILS + DQADT_macro=CLCN+CLLS + DQRDT_macro=QRAIN + DQSDT_macro=QSNOW + DQGDT_macro=QGRAUPEL + + ! Include shallow precip condensates if present + call MAPL_GetPointer(EXPORT, PTR3D, 'SHLW_PRC3', ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) + if (associated(PTR3D)) then + QRAIN = QRAIN + PTR3D*DT_MOIST + endif + call MAPL_GetPointer(EXPORT, PTR3D, 'SHLW_SNO3', ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) + if (associated(PTR3D)) then + QSNOW = QSNOW + PTR3D*DT_MOIST + endif + ! evap/subl/pdf + call MAPL_GetPointer(EXPORT, RHCRIT3D, 'RHCRIT', ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) + do L=1,LM + do J=1,JM + do I=1,IM + ! Send the condensates through the pdf after convection + facEIS = MAX(0.0,MIN(1.0,EIS(I,J)/10.0))**2 + ! determine combined minrhcrit in stable/unstable regimes + minrhcrit = (0.9)*(1.0-facEIS) + (0.95)*facEIS + if (TURNRHCRIT_PARAM <= 0.0) then + ! determine the turn pressure using the LCL + turnrhcrit = PLmb(I, J, KLCL(I,J)) - 250.0 ! 250mb above the LCL + else + turnrhcrit = TURNRHCRIT_PARAM + endif + ! Use Slingo-Ritter (1985) formulation for critical relative humidity + RHCRIT = 1.0 + ! lower turn from maxrhcrit=1.0 + if (PLmb(i,j,l) .le. turnrhcrit) then + RHCRIT = minrhcrit + else + if (L.eq.LM) then + RHCRIT = 1.0 + else + RHCRIT = minrhcrit + (1.0-minrhcrit)/(19.) * & + ((atan( (2.*(PLmb(i,j,l)-turnrhcrit)/(PLEmb(i,j,LM)-turnrhcrit)-1.) * & + tan(20.*MAPL_PI/21.-0.5*MAPL_PI) ) + 0.5*MAPL_PI) * 21./MAPL_PI - 1.) + endif + endif + ! include grid cell area scaling and limit RHcrit to > 70% + ALPHA = max(0.0,min(0.30, (1.0-RHCRIT)*SQRT(SQRT(AREA(I,J)/1.e10)) ) ) + ! fill RHCRIT export + if (associated(RHCRIT3D)) RHCRIT3D(I,J,L) = 1.0-ALPHA + ! Put condensates in touch with the PDF + call hystpdf( & + DT_MOIST , & + ALPHA , & + PDFSHAPE , & + CNV_FRC(I,J) , & + SRF_TYPE(I,J) , & + PLmb(I,J,L) , & + ZL0(I,J,L) , & + Q(I,J,L) , & + QLLS(I,J,L) , & + QLCN(I,J,L) , & + QILS(I,J,L) , & + QICN(I,J,L) , & + T(I,J,L) , & + CLLS(I,J,L) , & + CLCN(I,J,L) , & + NACTL(I,J,L) , & + NACTI(I,J,L) , & + WSL(I,J,L) , & + WQT(I,J,L) , & + SL2(I,J,L) , & + QT2(I,J,L) , & + SLQT(I,J,L) , & + W3(I,J,L) , & + W2(I,J,L) , & + QT3(I,J,L) , & + SL3(I,J,L) , & + PDF_A(I,J,L) , & + PDFITERS(I,J,L), & + WTHV2(I,J,L) , & + WQL(I,J,L) , & + .false. , & + USE_BERGERON) + RHX(I,J,L) = Q(I,J,L)/GEOS_QSAT( T(I,J,L), PLmb(I,J,L) ) + if (LMELTFRZ) then + ! meltfrz new condensates + call MELTFRZ ( DT_MOIST , & + CNV_FRC(I,J) , & + SRF_TYPE(I,J), & + T(I,J,L) , & + QLCN(I,J,L) , & + QICN(I,J,L) ) + call MELTFRZ ( DT_MOIST , & + CNV_FRC(I,J) , & + SRF_TYPE(I,J), & + T(I,J,L) , & + QLLS(I,J,L) , & + QILS(I,J,L) ) + endif + ! evaporation for CN + if (CCW_EVAP_EFF > 0.0) then + RHCRIT = 1.0 + EVAPC(I,J,L) = Q(I,J,L) + call EVAP3 ( & + DT_MOIST , & + CCW_EVAP_EFF , & + RHCRIT , & + PLmb(I,J,L) , & + T(I,J,L) , & + Q(I,J,L) , & + QLCN(I,J,L) , & + QICN(I,J,L) , & + CLCN(I,J,L) , & + NACTL(I,J,L) , & + NACTI(I,J,L) , & + QST3(I,J,L) ) + EVAPC(I,J,L) = ( Q(I,J,L) - EVAPC(I,J,L) ) / DT_MOIST + endif + ! sublimation for CN + if (CCI_EVAP_EFF > 0.0) then + RHCRIT = 1.0 + SUBLC(I,J,L) = Q(I,J,L) + call SUBL3 ( & + DT_MOIST , & + CCI_EVAP_EFF , & + RHCRIT , & + PLmb(I,J,L) , & + T(I,J,L) , & + Q(I,J,L) , & + QLCN(I,J,L) , & + QICN(I,J,L) , & + CLCN(I,J,L) , & + NACTL(I,J,L) , & + NACTI(I,J,L) , & + QST3(I,J,L) ) + SUBLC(I,J,L) = ( Q(I,J,L) - SUBLC(I,J,L) ) / DT_MOIST + endif + ! cleanup clouds + call FIX_UP_CLOUDS( Q(I,J,L), T(I,J,L), QLLS(I,J,L), QILS(I,J,L), CLLS(I,J,L), QLCN(I,J,L), QICN(I,J,L), CLCN(I,J,L) ) + end do ! IM loop + end do ! JM loop + end do ! LM loop + + ! Update macrophysics tendencies + DUDT_macro=( U - DUDT_macro)/DT_MOIST + DVDT_macro=( V - DVDT_macro)/DT_MOIST + DTDT_macro=( T - DTDT_macro)/DT_MOIST + DQVDT_macro=( Q -DQVDT_macro)/DT_MOIST + DQLDT_macro=((QLCN+QLLS)-DQLDT_macro)/DT_MOIST + DQIDT_macro=((QICN+QILS)-DQIDT_macro)/DT_MOIST + DQADT_macro=((CLCN+CLLS)-DQADT_macro)/DT_MOIST + DQRDT_macro=( QRAIN -DQRDT_macro)/DT_MOIST + DQSDT_macro=( QSNOW -DQSDT_macro)/DT_MOIST + DQGDT_macro=( QGRAUPEL -DQGDT_macro)/DT_MOIST + call MAPL_TimerOff(MAPL,"---CLDMACRO") + + call MAPL_TimerOn(MAPL,"---CLDMICRO") + ! Zero-out microphysics tendencies + call MAPL_GetPointer(EXPORT, DQVDT_micro, 'DQVDT_micro' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, DQIDT_micro, 'DQIDT_micro' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, DQLDT_micro, 'DQLDT_micro' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, DQADT_micro, 'DQADT_micro' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, DQRDT_micro, 'DQRDT_micro' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, DQSDT_micro, 'DQSDT_micro' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, DQGDT_micro, 'DQGDT_micro' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, DUDT_micro, 'DUDT_micro' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, DVDT_micro, 'DVDT_micro' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, DTDT_micro, 'DTDT_micro' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) + DQVDT_micro = Q + DQLDT_micro = QLLS + QLCN + DQIDT_micro = QILS + QICN + DQRDT_micro = QRAIN + DQSDT_micro = QSNOW + DQGDT_micro = QGRAUPEL + DQADT_micro = CLLS + CLCN + DUDT_micro = U + DVDT_micro = V + DTDT_micro = T + + ! Delta-Z layer thickness (MP expects this to be negative) + DZ = -1.0*DZET + ! Zero-out local microphysics tendencies + DQVDTmic = 0. + DQLDTmic = 0. + DQRDTmic = 0. + DQIDTmic = 0. + DQSDTmic = 0. + DQGDTmic = 0. + DQADTmic = 0. + DUDTmic = 0. + DVDTmic = 0. + DTDTmic = 0. + ! Zero-out 3D Precipitation Fluxes + ! Ice + PFI_LS = 0. + ! Liquid + PFL_LS = 0. + ! Cloud + RAD_CF = MIN(CLCN+CLLS,1.0) + ! Liquid + RAD_QL = QLCN+QLLS + ! Ice + RAD_QI = QICN+QILS + ! VAPOR + RAD_QV = Q + ! RAIN + RAD_QR = QRAIN + ! SNOW + RAD_QS = QSNOW + ! GRAUPEL + RAD_QG = QGRAUPEL +#ifdef INTERFACE +SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw, chl, & + cn, vhw, vhl, cna, cni, f_cn, f_cna, f_cina, & + zrw, zhw, zhl, & + qsw, qhw, qhlw, & + tt, th, pii, p, w, dn, dz, dtp, itimestep, & + RAINNC,RAINNCV, & + dx, dy, & + axtra, & + SNOWNC, SNOWNCV, GRPLNC, GRPLNCV, & + SR,HAILNC, HAILNCV, & + tkediss, & + re_cloud, re_ice, re_snow, re_rain, & + has_reqc, has_reqi, has_reqs, has_reqr, & + rainncw2, rainnci2, & + dbz, vzf,compdbz, & + rscghis_2d,rscghis_2dp,rscghis_2dn, & + scr,scw,sci,scs,sch,schl,sctot, & + elec_physics, & + induc,elecz,scion,sciona, & + noninduc,noninducp,noninducn, & + pcc2, pre2, depsubr, & + mnucf2, melr2, ctr2, & + rim1_2, rim2_2,rim3_2, & + nctr2, nnuccd2, nnucf2, & + effc2,effr2,effi2, & + effs2, effg2, & + fc2, fr2,fi2,fs2,fg2, & + fnc2, fnr2,fni2,fns2,fng2, & +! qcond,qdep,qfrz,qrauto,qhcnvi,qhcollw,qscollw, & +! ncauto, niinit,nifrz, & +! re_liquid, re_graupel, re_hail, re_icesnow, & +! vtcloud, vtrain, vtsnow, vtgraupel, vthail, & + ipelectmp, & + diagflag,ke_diag, & + errmsg, errflg, & + nssl_progn, & ! wrf-chem +! 20130903 acd_mb_washout start + wetscav_on, rainprod, evapprod, & ! wrf-chem +! 20130903 acd_mb_washout end + cu_used, qrcuten, qscuten, qicuten, qccuten, & ! hm added + ids,ide, jds,jde, kds,kde, & ! domain dims + ims,ime, jms,jme, kms,kme, & ! memory dims + its,ite, jts,jte, kts,kte) ! tile dims +#endif +#ifdef RUN_MP + ! Run the driver + CALL nssl_2mom_driver( & + TT=t, & + QV=qv_curr, & + QC=qc_curr, & + QR=qr_curr, & + QI=qi_curr, & + QS=qs_curr, & + QH=qg_curr, & + QHL=qh_curr, & + CCW=qndrop_curr, & + CRW=qnr_curr, & + CCI=qni_curr, & + CSW=qns_curr, & + CHW=qng_curr, & + CHL=qnh_curr, & + VHW=qvolg_curr, f_vhw=F_QVOLG, & + VHL=qvolh_curr, f_vhl=F_QVOLH, & + ZRW=qzr_curr, f_zrw = f_qzr, & + ZHW=qzg_curr, f_zhw = f_qzg, & + ZHL=qzh_curr, f_zhl = f_qzh, & + cn=qnn_curr, f_cn=f_qnn, & + PII=pi_phy, & + P=p, & + W=w, & + DZ=dz8w, & + DTP=dt, & + DN=rho, & + RAINNC = RAINNC, & + RAINNCV = RAINNCV, & + SNOWNC = SNOWNC, & + SNOWNCV = SNOWNCV, & + HAILNC = HAILNC, & + HAILNCV = HAILNCV, & + GRPLNC = GRAUPELNC, & + GRPLNCV = GRAUPELNCV, & + SR=SR, & + dbz = refl_10cm, & +#if ( WRF_CHEM == 1 ) + WETSCAV_ON = config_flags%wetscav_onoff == 1, & + EVAPPROD=evapprod,RAINPROD=rainprod, & +#endif + nssl_progn=nssl_progn, & + diagflag = diagflag, & + ke_diag = ke_diag, & + cu_used=cu_used, & + qrcuten=qrcuten, & ! hm + qscuten=qscuten, & ! hm + qicuten=qicuten, & ! hm + qccuten=qccuten, & ! hm + re_cloud=re_cloud, & + re_ice=re_ice, & + re_snow=re_snow, & + has_reqc=has_reqc, & ! ala G. Thompson + has_reqi=has_reqi, & ! ala G. Thompson + has_reqs=has_reqs, & ! ala G. Thompson + hail_maxk1=hail_maxk1, & + hail_max2d=hail_max2d, & + nwp_diagnostics=config_flags%nwp_diagnostics, & + IDS=ids,IDE=ide, JDS=jds,JDE=jde, KDS=kds,KDE=kde, & + IMS=ims,IME=ime, JMS=jms,JME=jme, KMS=kms,KME=kme, & + ITS=its,ITE=ite, JTS=jts,JTE=jte, KTS=kts,KTE=kte & + ) + ! RESHAPE + RAD_QV = RESHAPE(qv/(1.0+qv),(/IM,JM,LM/)) + RAD_QL = RESHAPE(qc,(/IM,JM,LM/)) + RAD_QR = RESHAPE(qr,(/IM,JM,LM/)) + RAD_QI = RESHAPE(qi,(/IM,JM,LM/)) + RAD_QS = RESHAPE(qs,(/IM,JM,LM/)) + RAD_QG = RESHAPE(qg,(/IM,JM,LM/)) + T = RESHAPE(tt,(/IM,JM,LM/)) + NCPL = RESHAPE(nc,(/IM,JM,LM/))*AIRDEN + NCPI = RESHAPE(ni,(/IM,JM,LM/))*AIRDEN + NRAIN = RESHAPE(nr,(/IM,JM,LM/))*AIRDEN +#endif + ! Redistribute CN/LS CF/QL/QI + call REDISTRIBUTE_CLOUDS(RAD_CF, RAD_QL, RAD_QI, CLCN, CLLS, QLCN, QLLS, QICN, QILS, RAD_QV, T) + ! Convert precip diagnostics from mm/day to kg m-2 s-1 + PRCP_RAIN = MAX(PRCP_RAIN / 86400.0, 0.0) + PRCP_SNOW = MAX(PRCP_SNOW / 86400.0, 0.0) + PRCP_ICE = MAX(PRCP_ICE / 86400.0, 0.0) + PRCP_GRAUPEL = MAX(PRCP_GRAUPEL / 86400.0, 0.0) + ! Fill GEOS precip diagnostics + LS_PRCP = PRCP_RAIN + LS_SNR = PRCP_SNOW + ICE = PRCP_ICE + PRCP_GRAUPEL + FRZR = 0.0 + ! Convert precipitation fluxes from (Pa kg/kg) to (kg m-2 s-1) + PFL_LS = PFL_LS/(MAPL_GRAV*DT_MOIST) + PFI_LS = PFI_LS/(MAPL_GRAV*DT_MOIST) + ! Redistribute precipitation fluxes for chemistry + TMP3D = MIN(1.0,MAX(QLCN/MAX(RAD_QL,1.E-8),0.0)) + PFL_AN(:,:,1:LM) = PFL_LS(:,:,1:LM) * TMP3D + PFL_LS(:,:,1:LM) = PFL_LS(:,:,1:LM) - PFL_AN(:,:,1:LM) + TMP3D = MIN(1.0,MAX(QICN/MAX(RAD_QI,1.E-8),0.0)) + PFI_AN(:,:,1:LM) = PFI_LS(:,:,1:LM) * TMP3D + PFI_LS(:,:,1:LM) = PFI_LS(:,:,1:LM) - PFI_AN(:,:,1:LM) + ! cleanup suspended precipitation condensates + call FIX_NEGATIVE_PRECIP(RAD_QR, RAD_QS, RAD_QG) + ! Fill vapor/rain/snow/graupel state + Q = RAD_QV + QRAIN = RAD_QR + QSNOW = RAD_QS + QGRAUPEL = RAD_QG + ! Radiation Coupling + do L = 1, LM + do J = 1, JM + do I = 1, IM + ! cleanup clouds + call FIX_UP_CLOUDS( Q(I,J,L), T(I,J,L), QLLS(I,J,L), QILS(I,J,L), CLLS(I,J,L), QLCN(I,J,L), QICN(I,J,L), CLCN(I,J,L) ) + ! get radiative properties + call RADCOUPLE ( T(I,J,L), PLmb(I,J,L), CLLS(I,J,L), CLCN(I,J,L), & + Q(I,J,L), QLLS(I,J,L), QILS(I,J,L), QLCN(I,J,L), QICN(I,J,L), QRAIN(I,J,L), QSNOW(I,J,L), QGRAUPEL(I,J,L), NACTL(I,J,L), NACTI(I,J,L), & + RAD_QV(I,J,L), RAD_QL(I,J,L), RAD_QI(I,J,L), RAD_QR(I,J,L), RAD_QS(I,J,L), RAD_QG(I,J,L), RAD_CF(I,J,L), & + CLDREFFL(I,J,L), CLDREFFI(I,J,L), & + FAC_RL, MIN_RL, MAX_RL, FAC_RI, MIN_RI, MAX_RI) + enddo + enddo + enddo + call FILLQ2ZERO(RAD_QV, MASS, RC=STATUS); VERIFY_(STATUS) + call FILLQ2ZERO(RAD_QL, MASS, RC=STATUS); VERIFY_(STATUS) + call FILLQ2ZERO(RAD_QI, MASS, RC=STATUS); VERIFY_(STATUS) + call FILLQ2ZERO(RAD_QR, MASS, RC=STATUS); VERIFY_(STATUS) + call FILLQ2ZERO(RAD_QS, MASS, RC=STATUS); VERIFY_(STATUS) + call FILLQ2ZERO(RAD_QG, MASS, RC=STATUS); VERIFY_(STATUS) + call FILLQ2ZERO(RAD_CF, MASS, RC=STATUS); VERIFY_(STATUS) + RAD_QL = MIN( RAD_QL , 0.001 ) ! Still a ridiculously large + RAD_QI = MIN( RAD_QI , 0.001 ) ! value. + RAD_QR = MIN( RAD_QR , 0.01 ) ! value. + RAD_QS = MIN( RAD_QS , 0.01 ) ! value. + RAD_QG = MIN( RAD_QG , 0.01 ) ! value. + where (QILS+QICN .le. 0.0) + CLDREFFI = 36.0e-6 + end where + where (QLLS+QLCN .le. 0.0) + CLDREFFL = 14.0e-6 + end where + + ! Update microphysics tendencies + DQVDT_micro = ( Q - DQVDT_micro) / DT_MOIST + DQLDT_micro = ((QLLS+QLCN) - DQLDT_micro) / DT_MOIST + DQIDT_micro = ((QILS+QICN) - DQIDT_micro) / DT_MOIST + DQADT_micro = ((CLLS+CLCN) - DQADT_micro) / DT_MOIST + DQRDT_micro = ( QRAIN - DQRDT_micro) / DT_MOIST + DQSDT_micro = ( QSNOW - DQSDT_micro) / DT_MOIST + DQGDT_micro = ( QGRAUPEL - DQGDT_micro) / DT_MOIST + DUDT_micro = ( U - DUDT_micro) / DT_MOIST + DVDT_micro = ( V - DVDT_micro) / DT_MOIST + DTDT_micro = ( T - DTDT_micro) / DT_MOIST + call MAPL_TimerOff(MAPL,"---CLDMICRO") + + call MAPL_GetPointer(EXPORT, PTR3D, 'DQRL', RC=STATUS); VERIFY_(STATUS) + if(associated(PTR3D)) PTR3D = DQRDT_macro + DQRDT_micro + + ! dissipative heating tendency from KE across the macro/micro physics + call MAPL_GetPointer(EXPORT, PTR3D, 'DTDTFRIC', RC=STATUS); VERIFY_(STATUS) + if(associated(PTR3D)) then + call dissipative_ke_heating(IM,JM,LM, MASS,U0,V0, & + DUDT_macro+DUDT_micro,& + DVDT_macro+DVDT_micro,PTR3D) + endif + + ! Compute DBZ radar reflectivity + call MAPL_GetPointer(EXPORT, PTR3D , 'DBZ' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, DBZ_MAX , 'DBZ_MAX' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, DBZ_1KM , 'DBZ_1KM' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, DBZ_TOP , 'DBZ_TOP' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, DBZ_M10C, 'DBZ_M10C', RC=STATUS); VERIFY_(STATUS) + + if (associated(PTR3D) .OR. & + associated(DBZ_MAX) .OR. associated(DBZ_1KM) .OR. associated(DBZ_TOP) .OR. associated(DBZ_M10C)) then + + call CALCDBZ(TMP3D,100*PLmb,T,Q,QRAIN,QSNOW,QGRAUPEL,IM,JM,LM,1,0,DBZ_LIQUID_SKIN) + if (associated(PTR3D)) PTR3D = TMP3D + + if (associated(DBZ_MAX)) then + DBZ_MAX=-9999.0 + DO L=1,LM ; DO J=1,JM ; DO I=1,IM + DBZ_MAX(I,J) = MAX(DBZ_MAX(I,J),TMP3D(I,J,L)) + END DO ; END DO ; END DO + endif + + if (associated(DBZ_1KM)) then + call cs_interpolator(1, IM, 1, JM, LM, TMP3D, 1000., ZLE0, DBZ_1KM, -20.) + endif + + if (associated(DBZ_TOP)) then + DBZ_TOP=MAPL_UNDEF + DO J=1,JM ; DO I=1,IM + DO L=LM,1,-1 + if (ZLE0(i,j,l) >= 25000.) continue + if (TMP3D(i,j,l) >= 18.5 ) then + DBZ_TOP(I,J) = ZLE0(I,J,L) + exit + endif + END DO + END DO ; END DO + endif + + if (associated(DBZ_M10C)) then + DBZ_M10C=MAPL_UNDEF + DO J=1,JM ; DO I=1,IM + DO L=LM,1,-1 + if (ZLE0(i,j,l) >= 25000.) continue + if (T(i,j,l) <= MAPL_TICE-10.0) then + DBZ_M10C(I,J) = TMP3D(I,J,L) + exit + endif + END DO + END DO ; END DO + endif + + endif + + call MAPL_GetPointer(EXPORT, PTR2D , 'DBZ_MAX_R' , RC=STATUS); VERIFY_(STATUS) + if (associated(PTR2D)) then + call CALCDBZ(TMP3D,100*PLmb,T,Q,QRAIN,0.0*QSNOW,0.0*QGRAUPEL,IM,JM,LM,1,0,DBZ_LIQUID_SKIN) + PTR2D=-9999.0 + DO L=1,LM ; DO J=1,JM ; DO I=1,IM + PTR2D(I,J) = MAX(PTR2D(I,J),TMP3D(I,J,L)) + END DO ; END DO ; END DO + endif + call MAPL_GetPointer(EXPORT, PTR2D , 'DBZ_MAX_S' , RC=STATUS); VERIFY_(STATUS) + if (associated(PTR2D)) then + call CALCDBZ(TMP3D,100*PLmb,T,Q,0.0*QRAIN,QSNOW,0.0*QGRAUPEL,IM,JM,LM,1,0,DBZ_LIQUID_SKIN) + PTR2D=-9999.0 + DO L=1,LM ; DO J=1,JM ; DO I=1,IM + PTR2D(I,J) = MAX(PTR2D(I,J),TMP3D(I,J,L)) + END DO ; END DO ; END DO + endif + call MAPL_GetPointer(EXPORT, PTR2D , 'DBZ_MAX_G' , RC=STATUS); VERIFY_(STATUS) + if (associated(PTR2D)) then + call CALCDBZ(TMP3D,100*PLmb,T,Q,0.0*QRAIN,0.0*QSNOW,QGRAUPEL,IM,JM,LM,1,0,DBZ_LIQUID_SKIN) + PTR2D=-9999.0 + DO L=1,LM ; DO J=1,JM ; DO I=1,IM + PTR2D(I,J) = MAX(PTR2D(I,J),TMP3D(I,J,L)) + END DO ; END DO ; END DO + endif + + call MAPL_GetPointer(EXPORT, PTR3D, 'QRTOT', RC=STATUS); VERIFY_(STATUS) + if (associated(PTR3D)) PTR3D = QRAIN + + call MAPL_GetPointer(EXPORT, PTR3D, 'QSTOT', RC=STATUS); VERIFY_(STATUS) + if (associated(PTR3D)) PTR3D = QSNOW + + call MAPL_GetPointer(EXPORT, PTR3D, 'QGTOT', RC=STATUS); VERIFY_(STATUS) + if (associated(PTR3D)) PTR3D = QGRAUPEL + + call MAPL_TimerOff(MAPL,"--NSSL_2M",RC=STATUS) + +end subroutine NSSL_2M_Run + +end module GEOS_NSSL_2M_InterfaceMod diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_THOM_1M_InterfaceMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_THOM_1M_InterfaceMod.F90 index 4a84fcbe1..71a72acb0 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_THOM_1M_InterfaceMod.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_THOM_1M_InterfaceMod.F90 @@ -1,7 +1,6 @@ ! $Id$ #include "MAPL_Generic.h" -!#define PDFDIAG 1 !============================================================================= !BOP @@ -59,8 +58,6 @@ module GEOS_THOM_1M_InterfaceMod real :: FAC_RI real :: MIN_RI real :: MAX_RI - logical :: LHYDROSTATIC - logical :: LPHYS_HYDROSTATIC public :: THOM_1M_Setup, THOM_1M_Initialize, THOM_1M_Run @@ -251,10 +248,6 @@ subroutine THOM_1M_Initialize (MAPL, RC) real, pointer, dimension(:,:,:) :: Q, QLLS, QLCN, QILS, QICN, QRAIN, QSNOW, QGRAUPEL - call MAPL_GetResource( MAPL, LHYDROSTATIC, Label="HYDROSTATIC:", default=.TRUE., RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetResource( MAPL, LPHYS_HYDROSTATIC, Label="PHYS_HYDROSTATIC:", default=.TRUE., RC=STATUS) - VERIFY_(STATUS) call MAPL_GetResource( MAPL, DT_THOM, Label="DT_THOM:", default=300.0, RC=STATUS) VERIFY_(STATUS) @@ -274,6 +267,8 @@ subroutine THOM_1M_Initialize (MAPL, RC) _ASSERT( STATUS==0, errmsg ) call WRITE_PARALLEL ("INITIALIZED THOM_1M microphysics in non-generic GC INIT") + call MAPL_GetResource( MAPL, DBZ_LIQUID_SKIN , 'DBZ_LIQUID_SKIN:' , DEFAULT= 0 , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource( MAPL, TURNRHCRIT_PARAM, 'TURNRHCRIT:' , DEFAULT= -9999., RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource( MAPL, PDFSHAPE , 'PDFSHAPE:' , DEFAULT= 1 , RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource( MAPL, ANV_ICEFALL , 'ANV_ICEFALL:' , DEFAULT= 0.8 , RC=STATUS); VERIFY_(STATUS) @@ -293,7 +288,6 @@ subroutine THOM_1M_Initialize (MAPL, RC) call MAPL_GetResource( MAPL, CNV_FRACTION_MIN, 'CNV_FRACTION_MIN:', DEFAULT= 0.0, RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource( MAPL, CNV_FRACTION_MAX, 'CNV_FRACTION_MAX:', DEFAULT= 1500.0, RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource( MAPL, CNV_FRACTION_EXP, 'CNV_FRACTION_EXP:', DEFAULT= 0.5, RC=STATUS); VERIFY_(STATUS) end subroutine THOM_1M_Initialize @@ -354,13 +348,6 @@ subroutine THOM_1M_Run (GC, IMPORT, EXPORT, CLOCK, RC) real, pointer, dimension(:,:,:) :: DBZ3D real, pointer, dimension(:,:,:) :: PTR3D real, pointer, dimension(:,: ) :: PTR2D -#ifdef PDFDIAG - real, pointer, dimension(:,:,:) :: PDF_W1, PDF_W2, PDF_SIGW1, PDF_SIGW2, & - PDF_QT1, PDF_QT2, PDF_SIGQT1, PDF_SIGQT2, & - PDF_TH1, PDF_TH2, PDF_SIGTH1, PDF_SIGTH2, & - PDF_RQTTH, PDF_RWTH, PDF_RWQT -#endif - ! Thompson Pointers for inputs real, dimension(:,:,:), allocatable, target :: inputs real, dimension(:,:,:), pointer :: qv => null() @@ -687,24 +674,6 @@ subroutine THOM_1M_Run (GC, IMPORT, EXPORT, CLOCK, RC) DQSDT_macro=QSNOW DQGDT_macro=QGRAUPEL -#ifdef PDFDIAG - call MAPL_GetPointer(EXPORT, PDF_W1, 'PDF_W1' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, PDF_W2, 'PDF_W2' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, PDF_SIGW1, 'PDF_SIGW1' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, PDF_SIGW2, 'PDF_SIGW2' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, PDF_QT1, 'PDF_QT1' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, PDF_QT2, 'PDF_QT2' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, PDF_SIGQT1, 'PDF_SIGQT1' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, PDF_SIGQT2, 'PDF_SIGQT2' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, PDF_TH1, 'PDF_TH1' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, PDF_TH2, 'PDF_TH2' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, PDF_SIGTH1, 'PDF_SIGTH1' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, PDF_SIGTH2, 'PDF_SIGTH2' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, PDF_RQTTH, 'PDF_RQTTH' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, PDF_RWTH, 'PDF_RWTH' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, PDF_RWQT, 'PDF_RWQT' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) -#endif - ! Include shallow precip condensates if present call MAPL_GetPointer(EXPORT, PTR3D, 'SHLW_PRC3', ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) if (associated(PTR3D)) then @@ -777,23 +746,6 @@ subroutine THOM_1M_Run (GC, IMPORT, EXPORT, CLOCK, RC) SL3(I,J,L) , & PDF_A(I,J,L) , & PDFITERS(I,J,L), & -#ifdef PDFDIAG - PDF_SIGW1(I,J,L), & - PDF_SIGW2(I,J,L), & - PDF_W1(I,J,L), & - PDF_W2(I,J,L), & - PDF_SIGTH1(I,J,L), & - PDF_SIGTH2(I,J,L), & - PDF_TH1(I,J,L), & - PDF_TH2(I,J,L), & - PDF_SIGQT1(I,J,L), & - PDF_SIGQT2(I,J,L), & - PDF_QT1(I,J,L), & - PDF_QT2(I,J,L), & - PDF_RQTTH(I,J,L), & - PDF_RWTH(I,J,L), & - PDF_RWQT(I,J,L), & -#endif WTHV2(I,J,L) , & WQL(I,J,L) , & .false. , & @@ -914,11 +866,11 @@ subroutine THOM_1M_Run (GC, IMPORT, EXPORT, CLOCK, RC) ! Air Density AIRDEN = MAPL_EPSILON*100.*PLmb/(T*MAPL_RGAS*(Q+MAPL_EPSILON)) ! Vertical velocity - if (LHYDROSTATIC) then - VVEL = -OMEGA/(MAPL_GRAV*AIRDEN) - else - VVEL = W - endif + IF (all(W == 0.0)) THEN + VVEL = -OMEGA/(MAPL_GRAV*AIRDEN) + ELSE + VVEL = W + ENDIF ! RESHAPE qv = RESHAPE(RAD_QV,(/IM*JM,LM,1/)) qc = RESHAPE(RAD_QL,(/IM*JM,LM,1/)) @@ -1043,13 +995,13 @@ subroutine THOM_1M_Run (GC, IMPORT, EXPORT, CLOCK, RC) enddo enddo enddo - call FILLQ2ZERO(RAD_QV, MASS, TMP2D) - call FILLQ2ZERO(RAD_QL, MASS, TMP2D) - call FILLQ2ZERO(RAD_QI, MASS, TMP2D) - call FILLQ2ZERO(RAD_QR, MASS, TMP2D) - call FILLQ2ZERO(RAD_QS, MASS, TMP2D) - call FILLQ2ZERO(RAD_QG, MASS, TMP2D) - call FILLQ2ZERO(RAD_CF, MASS, TMP2D) + call FILLQ2ZERO(RAD_QV, MASS, RC=STATUS); VERIFY_(STATUS) + call FILLQ2ZERO(RAD_QL, MASS, RC=STATUS); VERIFY_(STATUS) + call FILLQ2ZERO(RAD_QI, MASS, RC=STATUS); VERIFY_(STATUS) + call FILLQ2ZERO(RAD_QR, MASS, RC=STATUS); VERIFY_(STATUS) + call FILLQ2ZERO(RAD_QS, MASS, RC=STATUS); VERIFY_(STATUS) + call FILLQ2ZERO(RAD_QG, MASS, RC=STATUS); VERIFY_(STATUS) + call FILLQ2ZERO(RAD_CF, MASS, RC=STATUS); VERIFY_(STATUS) where (RAD_QI .le. 0.0) CLDREFFI = MAPL_UNDEF end where @@ -1090,7 +1042,7 @@ subroutine THOM_1M_Run (GC, IMPORT, EXPORT, CLOCK, RC) if (associated(DBZ3D) .OR. & associated(DBZ_MAX) .OR. associated(DBZ_1KM) .OR. associated(DBZ_TOP) .OR. associated(DBZ_M10C)) then - call CALCDBZ(TMP3D,100*PLmb,T,Q,QRAIN,QSNOW,QGRAUPEL,IM,JM,LM,1,0,1) + call CALCDBZ(TMP3D,100*PLmb,T,Q,QRAIN,QSNOW,QGRAUPEL,IM,JM,LM,1,0,DBZ_LIQUID_SKIN) if (associated(DBZ3D)) DBZ3D = TMP3D if (associated(DBZ_MAX)) then @@ -1137,7 +1089,7 @@ subroutine THOM_1M_Run (GC, IMPORT, EXPORT, CLOCK, RC) call MAPL_GetPointer(EXPORT, PTR3D, 'QSTOT', RC=STATUS); VERIFY_(STATUS) if (associated(PTR3D)) PTR3D = QSNOW - + call MAPL_GetPointer(EXPORT, PTR3D, 'QGTOT', RC=STATUS); VERIFY_(STATUS) if (associated(PTR3D)) PTR3D = QGRAUPEL diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_UW_InterfaceMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_UW_InterfaceMod.F90 index f60a1ddbc..815947d01 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_UW_InterfaceMod.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_UW_InterfaceMod.F90 @@ -107,20 +107,19 @@ subroutine UW_Initialize (MAPL, CLOCK, RC) call MAPL_GetResource(MAPL, SHLWPARAMS%MIXSCALE, 'MIXSCALE:' ,DEFAULT=0.0, RC=STATUS) ; VERIFY_(STATUS) call MAPL_GetResource(MAPL, SHLWPARAMS%CRIQC, 'CRIQC:' ,DEFAULT=1.0e-3, RC=STATUS) ; VERIFY_(STATUS) call MAPL_GetResource(MAPL, SHLWPARAMS%THLSRC_FAC, 'THLSRC_FAC:' ,DEFAULT= 0.0, RC=STATUS) ; VERIFY_(STATUS) + call MAPL_GetResource(MAPL, SHLWPARAMS%RKFRE, 'RKFRE:' ,DEFAULT= 1.0, RC=STATUS) ; VERIFY_(STATUS) + call MAPL_GetResource(MAPL, SHLWPARAMS%RKM, 'RKM:' ,DEFAULT= 12.0, RC=STATUS) ; VERIFY_(STATUS) + call MAPL_GetResource(MAPL, SHLWPARAMS%FRC_RASN, 'FRC_RASN:' ,DEFAULT= 0.0, RC=STATUS) ; VERIFY_(STATUS) + call MAPL_GetResource(MAPL, SHLWPARAMS%RPEN, 'RPEN:' ,DEFAULT= 3.0, RC=STATUS) ; VERIFY_(STATUS) + call MAPL_GetResource(MAPL, SCLM_SHALLOW, 'SCLM_SHALLOW:' ,DEFAULT= 1.0, RC=STATUS) ; VERIFY_(STATUS) else call MAPL_GetResource(MAPL, SHLWPARAMS%WINDSRCAVG, 'WINDSRCAVG:' ,DEFAULT=1, RC=STATUS) ; VERIFY_(STATUS) call MAPL_GetResource(MAPL, SHLWPARAMS%MIXSCALE, 'MIXSCALE:' ,DEFAULT=3000.0, RC=STATUS) ; VERIFY_(STATUS) call MAPL_GetResource(MAPL, SHLWPARAMS%CRIQC, 'CRIQC:' ,DEFAULT=0.9e-3, RC=STATUS) ; VERIFY_(STATUS) call MAPL_GetResource(MAPL, SHLWPARAMS%THLSRC_FAC, 'THLSRC_FAC:' ,DEFAULT= 1.0, RC=STATUS) ; VERIFY_(STATUS) - endif - if (JASON_UW) then + call MAPL_GetResource(MAPL, SHLWPARAMS%RKFRE, 'RKFRE:' ,DEFAULT= 1.0, RC=STATUS) ; VERIFY_(STATUS) + call MAPL_GetResource(MAPL, SHLWPARAMS%RKM, 'RKM:' ,DEFAULT= 11.0, RC=STATUS) ; VERIFY_(STATUS) call MAPL_GetResource(MAPL, SHLWPARAMS%FRC_RASN, 'FRC_RASN:' ,DEFAULT= 0.0, RC=STATUS) ; VERIFY_(STATUS) - call MAPL_GetResource(MAPL, SHLWPARAMS%RKM, 'RKM:' ,DEFAULT= 12.0, RC=STATUS) ; VERIFY_(STATUS) - call MAPL_GetResource(MAPL, SHLWPARAMS%RPEN, 'RPEN:' ,DEFAULT= 3.0, RC=STATUS) ; VERIFY_(STATUS) - call MAPL_GetResource(MAPL, SCLM_SHALLOW, 'SCLM_SHALLOW:' ,DEFAULT= 1.0, RC=STATUS) ; VERIFY_(STATUS) - else - call MAPL_GetResource(MAPL, SHLWPARAMS%FRC_RASN, 'FRC_RASN:' ,DEFAULT= 1.0, RC=STATUS) ; VERIFY_(STATUS) - call MAPL_GetResource(MAPL, SHLWPARAMS%RKM, 'RKM:' ,DEFAULT= 8.0, RC=STATUS) ; VERIFY_(STATUS) call MAPL_GetResource(MAPL, SHLWPARAMS%RPEN, 'RPEN:' ,DEFAULT= 3.0, RC=STATUS) ; VERIFY_(STATUS) call MAPL_GetResource(MAPL, SCLM_SHALLOW, 'SCLM_SHALLOW:' ,DEFAULT= 1.0, RC=STATUS) ; VERIFY_(STATUS) endif @@ -166,14 +165,13 @@ subroutine UW_Run (GC, IMPORT, EXPORT, CLOCK, RC) real, allocatable, dimension(:,:,:) :: ZLE0, ZL0 real, allocatable, dimension(:,:,:) :: PL, PK, PKE, DP real, allocatable, dimension(:,:,:) :: MASS + real, allocatable, dimension(:,:) :: RKM2D, RKFRE, MIX2D real, allocatable, dimension(:,:,:) :: TMP3D - real, allocatable, dimension(:,:) :: TMP2D ! Required Exports (connectivities to moist siblings) real, pointer, dimension(:,:) :: CNPCPRATE real, pointer, dimension(:,:) :: CNV_FRC, SRF_TYPE ! Exports - real, pointer, dimension(:,:) :: RKFRE real, pointer, dimension(:,:,:) :: CUFRC_SC real, pointer, dimension(:,:,:) :: UMF_SC, MFD_SC, DCM_SC real, pointer, dimension(:,:,:) :: QTFLX_SC, SLFLX_SC, UFLX_SC, VFLX_SC @@ -184,32 +182,67 @@ subroutine UW_Run (GC, IMPORT, EXPORT, CLOCK, RC) QLSUB_SC, QISUB_SC, SC_NDROP, SC_NICE real, pointer, dimension(:,:) :: TPERT_SC, QPERT_SC real, pointer, dimension(:,:,:) :: QLTOT, QITOT + real, pointer, dimension(:,:,:) :: DQVDT_FILL + real, pointer, dimension(:,:,:) :: DQLLSDT_FILL + real, pointer, dimension(:,:,:) :: DQLCNDT_FILL + real, pointer, dimension(:,:,:) :: DQILSDT_FILL + real, pointer, dimension(:,:,:) :: DQICNDT_FILL real, pointer, dimension(:,:,:) :: PTR3D real, pointer, dimension(:,:) :: PTR2D + real, pointer, dimension(:,:) :: LONS, LATS + type (MAPL_MetaComp), pointer :: MAPL type (ESMF_State ) :: INTERNAL type (ESMF_TimeInterval) :: TINT real(ESMF_KIND_R8) :: DT_R8 - real :: UW_DT + real :: UW_DT, MOIST_DT + real :: SIG type(ESMF_Alarm) :: alarm logical :: alarm_is_ringing + type( ESMF_VM ) :: VMG ! Local variables integer :: I, J, L integer :: IM,JM,LM - call ESMF_ClockGetAlarm(clock, 'UW_RunAlarm', alarm, RC=STATUS); VERIFY_(STATUS) - alarm_is_ringing = ESMF_AlarmIsRinging(alarm, RC=STATUS); VERIFY_(STATUS) - - if (alarm_is_ringing) then - -!!! call WRITE_PARALLEL('UW is Running') - call ESMF_AlarmRingerOff(alarm, RC=STATUS); VERIFY_(STATUS) - call ESMF_AlarmGet(alarm, RingInterval=TINT, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetObjectFromGC ( GC, MAPL, RC=STATUS); VERIFY_(STATUS) + call MAPL_Get( MAPL, RUNALARM=ALARM, & + INTERNAL_ESMF_STATE=INTERNAL, IM=IM, JM=JM, LM=LM, & + LONS = LONS, & + LATS = LATS, & + RC=STATUS ) + VERIFY_(STATUS) + call ESMF_AlarmGet(ALARM, RingInterval=TINT, RC=STATUS); VERIFY_(STATUS) call ESMF_TimeIntervalGet(TINT, S_R8=DT_R8,RC=STATUS); VERIFY_(STATUS) - UW_DT = DT_R8 + MOIST_DT = DT_R8 + + call ESMF_GridCompGet ( GC, VM=VMG, RC=STATUS ) + VERIFY_(STATUS) + + ! Internals + call MAPL_GetPointer(INTERNAL, Q, 'Q' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL, QLLS, 'QLLS' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL, QLCN, 'QLCN' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL, CLCN, 'CLCN' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL, CLLS, 'CLLS' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL, QILS, 'QILS' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL, QICN, 'QICN' , RC=STATUS); VERIFY_(STATUS) + ! Imports + call MAPL_GetPointer(IMPORT, T ,'T' ,RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(IMPORT, U ,'U' ,RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(IMPORT, V ,'V' ,RC=STATUS); VERIFY_(STATUS) + ! Tendency Export + call MAPL_GetPointer(EXPORT, DUDT_SC, 'DUDT_SC' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, DVDT_SC, 'DVDT_SC' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, DTDT_SC, 'DTDT_SC' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, DQVDT_SC, 'DQVDT_SC' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, DQIDT_SC, 'DQIDT_SC' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, DQLDT_SC, 'DQLDT_SC' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, DQRDT_SC, 'DQRDT_SC' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, DQSDT_SC, 'DQSDT_SC' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, DQADT_SC, 'DQADT_SC' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) ! Get my internal MAPL_Generic state !----------------------------------- @@ -222,28 +255,13 @@ subroutine UW_Run (GC, IMPORT, EXPORT, CLOCK, RC) ! Get parameters from generic state. !----------------------------------- - call MAPL_Get( MAPL, IM=IM, JM=JM, LM=LM, & - INTERNAL_ESMF_STATE=INTERNAL, & - RC=STATUS ) - VERIFY_(STATUS) - ! Internals - call MAPL_GetPointer(INTERNAL, Q, 'Q' , RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(INTERNAL, QLLS, 'QLLS' , RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(INTERNAL, QLCN, 'QLCN' , RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(INTERNAL, CLCN, 'CLCN' , RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(INTERNAL, CLLS, 'CLLS' , RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(INTERNAL, QILS, 'QILS' , RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(INTERNAL, QICN, 'QICN' , RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(INTERNAL, CUSH, 'CUSH' , RC=STATUS); VERIFY_(STATUS) ! Imports call MAPL_GetPointer(IMPORT, FRLAND ,'FRLAND' ,RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(IMPORT, ZLE ,'ZLE' ,RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(IMPORT, PLE ,'PLE' ,RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(IMPORT, T ,'T' ,RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(IMPORT, U ,'U' ,RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(IMPORT, V ,'V' ,RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(IMPORT, SH ,'SH' ,RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(IMPORT, EVAP ,'EVAP' ,RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(IMPORT, KPBL_SC ,'KPBL_SC' ,RC=STATUS); VERIFY_(STATUS) @@ -259,9 +277,10 @@ subroutine UW_Run (GC, IMPORT, EXPORT, CLOCK, RC) ALLOCATE ( PK (IM,JM,LM ) ) ALLOCATE ( DP (IM,JM,LM ) ) ALLOCATE ( MASS (IM,JM,LM ) ) - ALLOCATE ( TMP3D(IM,JM,LM ) ) ! 2D Variables - ALLOCATE ( TMP2D (IM,JM) ) + ALLOCATE ( RKFRE (IM,JM) ) + ALLOCATE ( RKM2D (IM,JM) ) + ALLOCATE ( MIX2D (IM,JM) ) ! Derived States PKE = (PLE/MAPL_P00)**(MAPL_KAPPA) @@ -274,6 +293,17 @@ subroutine UW_Run (GC, IMPORT, EXPORT, CLOCK, RC) DP = ( PLE(:,:,1:LM)-PLE(:,:,0:LM-1) ) MASS = DP/MAPL_GRAV + call ESMF_ClockGetAlarm(clock, 'UW_RunAlarm', alarm, RC=STATUS); VERIFY_(STATUS) + alarm_is_ringing = ESMF_AlarmIsRinging(alarm, RC=STATUS); VERIFY_(STATUS) + + if (alarm_is_ringing) then + +!!! call WRITE_PARALLEL('UW is Running') + call ESMF_AlarmRingerOff(alarm, RC=STATUS); VERIFY_(STATUS) + call ESMF_AlarmGet(alarm, RingInterval=TINT, RC=STATUS); VERIFY_(STATUS) + call ESMF_TimeIntervalGet(TINT, S_R8=DT_R8,RC=STATUS); VERIFY_(STATUS) + UW_DT = DT_R8 + ! Required Exports (connectivities to moist siblings) call MAPL_GetPointer(EXPORT, MFD_SC, 'MFD_SC' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(EXPORT, QLDET_SC, 'QLDET_SC' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) @@ -282,16 +312,6 @@ subroutine UW_Run (GC, IMPORT, EXPORT, CLOCK, RC) call MAPL_GetPointer(EXPORT, CNPCPRATE, 'CNPCPRATE' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(EXPORT, CNV_FRC , 'CNV_FRC' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(EXPORT, SRF_TYPE, 'SRF_TYPE' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - ! Tendency Export - call MAPL_GetPointer(EXPORT, DUDT_SC, 'DUDT_SC' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, DVDT_SC, 'DVDT_SC' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, DTDT_SC, 'DTDT_SC' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, DQVDT_SC, 'DQVDT_SC' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, DQIDT_SC, 'DQIDT_SC' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, DQLDT_SC, 'DQLDT_SC' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, DQRDT_SC, 'DQRDT_SC' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, DQSDT_SC, 'DQSDT_SC' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, DQADT_SC, 'DQADT_SC' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) ! Exports call MAPL_GetPointer(EXPORT, UMF_SC, 'UMF_SC' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(EXPORT, DCM_SC, 'DCM_SC' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) @@ -307,15 +327,22 @@ subroutine UW_Run (GC, IMPORT, EXPORT, CLOCK, RC) call MAPL_GetPointer(EXPORT, SLFLX_SC, 'SLFLX_SC' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(EXPORT, UFLX_SC, 'UFLX_SC' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(EXPORT, VFLX_SC, 'VFLX_SC' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, RKFRE, 'RKFRE' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) + if (JASON_UW) then - RKFRE = 1.0 + RKFRE = SHLWPARAMS%RKFRE + RKM2D = SHLWPARAMS%RKM + MIX2D = SHLWPARAMS%MIXSCALE else ! resolution dependent throttle on UW via TKE and scaling of cloud-base mass flux call MAPL_GetPointer(IMPORT, PTR2D, 'AREA', RC=STATUS); VERIFY_(STATUS) do J=1,JM do I=1,IM - RKFRE(i,j) = sigma(SQRT(PTR2D(i,j))) + !! option to vary RKFRE by resolution + SIG = sigma(SQRT(PTR2D(i,j))) ! Param -> Resolved + RKFRE(i,j) = SHLWPARAMS%RKFRE + ! support for varying rkm/mix if needed ! Param -> Resolved + RKM2D(i,j) = SHLWPARAMS%RKM*SIG + 8.0*(1.0-SIG) ! RKM -> 8.0 + MIX2D(i,j) = SHLWPARAMS%MIXSCALE enddo enddo endif @@ -331,7 +358,7 @@ subroutine UW_Run (GC, IMPORT, EXPORT, CLOCK, RC) call compute_uwshcu_inv(IM*JM, LM, UW_DT, & ! IN PL, ZL0, PK, PLE, ZLE0, PKE, DP, & U, V, Q, QLTOT, QITOT, T, TKE, RKFRE, KPBL_SC,& - SH, EVAP, CNPCPRATE, FRLAND, & + SH, EVAP, CNPCPRATE, FRLAND, RKM2D, MIX2D, & CUSH, & ! INOUT UMF_SC, DCM_SC, DQVDT_SC, DQLDT_SC, DQIDT_SC, & ! OUT DTDT_SC, DUDT_SC, DVDT_SC, DQRDT_SC, & @@ -350,12 +377,6 @@ subroutine UW_Run (GC, IMPORT, EXPORT, CLOCK, RC) #endif USE_TRACER_TRANSP_UW) - ! Apply tendencies - !-------------------------------------------------------------- - Q = Q + DQVDT_SC * UW_DT ! note this adds to the convective - T = T + DTDT_SC * UW_DT ! tendencies calculated below - U = U + DUDT_SC * UW_DT - V = V + DVDT_SC * UW_DT ! Calculate detrained mass flux !-------------------------------------------------------------- if (JASON_UW) then @@ -367,10 +388,7 @@ subroutine UW_Run (GC, IMPORT, EXPORT, CLOCK, RC) else MFD_SC = DCM_SC endif - ! Tiedtke-style cloud fraction !! - DQADT_SC= MFD_SC*SCLM_SHALLOW/MASS - CLCN = CLCN + DQADT_SC*UW_DT - CLCN = MIN( CLCN , 1.0 ) + DQADT_SC= MFD_SC*SCLM_SHALLOW/MASS ! Convert detrained water units before passing to cloud !--------------------------------------------------------------- call MAPL_GetPointer(EXPORT, QLENT_SC, 'QLENT_SC', ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) @@ -385,35 +403,29 @@ subroutine UW_Run (GC, IMPORT, EXPORT, CLOCK, RC) QIENT_SC = QIDET_SC QIDET_SC = 0. END WHERE - ! add detrained shallow convective ice/liquid source - QLCN = QLCN + QLDET_SC*UW_DT - QICN = QICN + QIDET_SC*UW_DT ! scale the detrained fluxes before exporting QLDET_SC = QLDET_SC*MASS QIDET_SC = QIDET_SC*MASS - ! Apply condensate tendency from subsidence, and sink from - ! condensate entrained into shallow updraft. - !------------------------------------------------------------- - QLLS = QLLS + (QLSUB_SC+QLENT_SC)*UW_DT - QILS = QILS + (QISUB_SC+QIENT_SC)*UW_DT ! Precipitation !-------------------------------------------------------------- call MAPL_GetPointer(EXPORT, PTR3D, 'SHLW_PRC3', ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) if (associated(PTR3D)) PTR3D = DQRDT_SC ! [kg/kg/s] call MAPL_GetPointer(EXPORT, PTR3D, 'SHLW_SNO3', ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) if (associated(PTR3D)) PTR3D = DQSDT_SC ! [kg/kg/s] - ! Other exports + + ! Additional exports call MAPL_GetPointer(EXPORT, PTR2D, 'SC_QT', RC=STATUS); VERIFY_(STATUS) if (associated(PTR2D)) then ! column integral of UW total water tendency, for checking conservation - PTR2D = 0. - DO L = 1,LM + PTR2D = 0. + DO L = 1,LM PTR2D = PTR2D + ( DQSDT_SC(:,:,L)+DQRDT_SC(:,:,L)+DQVDT_SC(:,:,L) & + QLENT_SC(:,:,L)+QLSUB_SC(:,:,L)+QIENT_SC(:,:,L) & + QISUB_SC(:,:,L) )*MASS(:,:,L) & + QLDET_SC(:,:,L)+QIDET_SC(:,:,L) END DO - end if + end if + call MAPL_GetPointer(EXPORT, PTR2D, 'SC_MSE', RC=STATUS); VERIFY_(STATUS) if (associated(PTR2D)) then ! column integral of UW moist static energy tendency @@ -423,23 +435,69 @@ subroutine UW_Run (GC, IMPORT, EXPORT, CLOCK, RC) + MAPL_ALHL*DQVDT_SC(:,:,L) & - MAPL_ALHF*DQIDT_SC(:,:,L))*MASS(:,:,L) END DO - end if - - !-------------------------------------------------------------- - ! For Now add ShallowCu contribution to total/detraining mass flux exports - !-------------------------------------------------------------- - call MAPL_GetPointer(EXPORT, PTR3D, 'CNV_MFC', ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - PTR3D = PTR3D + UMF_SC - call MAPL_GetPointer(EXPORT, PTR3D, 'CNV_MFD', ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - PTR3D = PTR3D + MFD_SC + end if call MAPL_GetPointer(EXPORT, PTR2D, 'CUSH_SC', RC=STATUS); VERIFY_(STATUS) if (associated(PTR2D)) PTR2D = CUSH - call MAPL_TimerOff (MAPL,"--UW") + endif + ! Apply tendencies + !-------------------------------------------------------------- + Q = Q + DQVDT_SC * MOIST_DT + T = T + DTDT_SC * MOIST_DT + U = U + DUDT_SC * MOIST_DT + V = V + DVDT_SC * MOIST_DT + ! Tiedtke-style cloud fraction !! + CLCN = MAX(0.0, MIN(CLCN + DQADT_SC*MOIST_DT, 1.0)) + ! add detrained shallow convective ice/liquid source + call MAPL_GetPointer(EXPORT, QLDET_SC, 'QLDET_SC', ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) + QLCN = MAX(0.0, QLCN + QLDET_SC*MOIST_DT/MASS) + call MAPL_GetPointer(EXPORT, QIDET_SC, 'QIDET_SC', ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) + QICN = MAX(0.0, QICN + QIDET_SC*MOIST_DT/MASS) + ! Apply condensate tendency from subsidence, and sink from + ! condensate entrained into shallow updraft. + call MAPL_GetPointer(EXPORT, QLSUB_SC, 'QLSUB_SC', ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, QLENT_SC, 'QLENT_SC', ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) + QLLS = MAX(0.0, QLLS + (QLSUB_SC+QLENT_SC)*MOIST_DT) + call MAPL_GetPointer(EXPORT, QISUB_SC, 'QISUB_SC', ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, QIENT_SC, 'QIENT_SC', ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) + QILS = MAX(0.0, QILS + (QISUB_SC+QIENT_SC)*MOIST_DT) + +! Cleanup negative water species +! ------------------------------ + call MAPL_GetPointer(EXPORT, DQVDT_FILL, 'DQVDT_FILL_SC', RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, DQLLSDT_FILL, 'DQLLSDT_FILL_SC', RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, DQLCNDT_FILL, 'DQLCNDT_FILL_SC', RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, DQILSDT_FILL, 'DQILSDT_FILL_SC', RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, DQICNDT_FILL, 'DQICNDT_FILL_SC', RC=STATUS); VERIFY_(STATUS) + call FILLQ2ZERO( Q , MASS, DT=MOIST_DT, DQDT= DQVDT_FILL, WARNING_LABEL="QV After UW ShallowCu", VM=VMG, RC=STATUS); VERIFY_(STATUS) + call FILLQ2ZERO( QLLS , MASS, DT=MOIST_DT, DQDT=DQLLSDT_FILL, WARNING_LABEL="QLLS After UW ShallowCu", VM=VMG, RC=STATUS); VERIFY_(STATUS) + call FILLQ2ZERO( QLCN , MASS, DT=MOIST_DT, DQDT=DQLCNDT_FILL, WARNING_LABEL="QLCN After UW ShallowCu", VM=VMG, RC=STATUS); VERIFY_(STATUS) + call FILLQ2ZERO( QILS , MASS, DT=MOIST_DT, DQDT=DQILSDT_FILL, WARNING_LABEL="QILS After UW ShallowCu", VM=VMG, RC=STATUS); VERIFY_(STATUS) + call FILLQ2ZERO( QICN , MASS, DT=MOIST_DT, DQDT=DQICNDT_FILL, WARNING_LABEL="QICN After UW ShallowCu", VM=VMG, RC=STATUS); VERIFY_(STATUS) + + if (DEBUG_TQ_ERRORS) then + do L=1,LM + do J=1,JM + do I=1,IM + if (T(I,J,L) > 333.0) then + print *, "Temperature spike detected : ", T(I,J,L) + print *, " UW Temp Increment : ", DTDT_SC(I,J,L)*MOIST_DT + print *, " AFTER UW ShallowCu" + print *, " Latitude =", LATS(I,J)*180.0/MAPL_PI + print *, " Longitude =", LONS(I,J)*180.0/MAPL_PI + print *, " Pressure (mb) =", 0.5*(PLE(I,J,L)+PLE(I,J,L-1))/100.0 + print *, " CLLS=", CLLS(I,J,L), "CLCN=", CLCN(I,J,L) + print *, " QV=", Q(I,J,L), " QL=", QLLS(I,J,L)+QLCN(I,J,L), " QI=", QILS(I,J,L)+QICN(I,J,L) + endif + end do ! IM loop + end do ! JM loop + end do ! LM loop endif + call MAPL_TimerOff (MAPL,"--UW") + end subroutine UW_Run end module GEOS_UW_InterfaceMod diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/Process_Library.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/Process_Library.F90 index 9ec85d331..3da74a1ca 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/Process_Library.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/Process_Library.F90 @@ -1,7 +1,6 @@ ! $Id$ #include "MAPL_Generic.h" -!#define PDFDIAG 1 !============================================================================= !BOP @@ -20,6 +19,8 @@ module GEOSmoist_Process_Library character(len=ESMF_MAXSTR) :: IAm="GEOSmoist_Process_Library" integer :: STATUS + logical :: DEBUG_TQ_ERRORS + interface MELTFRZ module procedure MELTFRZ_3D module procedure MELTFRZ_2D @@ -32,6 +33,13 @@ module GEOSmoist_Process_Library module procedure ICE_FRACTION_1D module procedure ICE_FRACTION_SC end interface ICE_FRACTION + + ! SRF_TYPE constants + integer, parameter :: SRF_TYPE_LAND = 1 + integer, parameter :: SRF_TYPE_SNOW = 2 + integer, parameter :: SRF_TYPE_ICE = 3 + integer, parameter :: SRF_TYPE_OCEAN = 0 + ! ICE_FRACTION constants ! In anvil/convective clouds real, parameter :: aT_ICE_ALL = 252.16 @@ -40,7 +48,7 @@ module GEOSmoist_Process_Library ! Over snow SRF_TYPE = 2 and over ice SRF_TYPE = 3 real, parameter :: iT_ICE_ALL = 236.16 real, parameter :: iT_ICE_MAX = 261.16 - real, parameter :: iICEFRPWR = 6.0 + real, parameter :: iICEFRPWR = 5.0 ! Over Land SRF_TYPE = 1 real, parameter :: lT_ICE_ALL = 239.16 real, parameter :: lT_ICE_MAX = 261.16 @@ -63,8 +71,9 @@ module GEOSmoist_Process_Library real, parameter :: EPSILON = MAPL_H2OMW/MAPL_AIRMW real, parameter :: K_COND = 2.4e-2 ! J m**-1 s**-1 K**-1 real, parameter :: DIFFU = 2.2e-5 ! m**2 s**-1 - real, parameter :: taufrz = 450.0 - real, parameter :: dQCmax = 1.e-4 + real, parameter :: taufrz = 600.0 ! timescale for freezing + real, parameter :: taumlt = 300.0 ! timescale for melting + real, parameter :: QCMIN = 1.e-8 ! minimum condensate values ! LDRADIUS4 ! Jason real, parameter :: abeta = 0.07 @@ -72,24 +81,129 @@ module GEOSmoist_Process_Library real, parameter :: bx = 100.* (3./(4.*MAPL_PI))**(1./3.) ! Liquid based on DOI 10.1088/1748-9326/3/4/045021 real, parameter :: RHO_W = 1000.0 ! Density of liquid water in kg/m^3 + real, parameter :: rho_s = 100.0 + real, parameter :: rho_g = 500.0 + real, parameter :: rho_i = 890.0 real, parameter :: Ldiss = 0.07 ! tunable dispersion effect real, parameter :: Lk = 0.75 ! tunable shape effect (0.5:1) real, parameter :: Lbe = 1./3. - 0.14 real, parameter :: Lbx = Ldiss*1.e3*(3./(4.*MAPL_PI*Lk*RHO_W*1.e-3))**(1./3.) ! LDRADIUS eqs are in cgs units - ! Ice - real, parameter :: RHO_I = 916.8 ! Density of ice crystal in kg/m^3 - ! combined constantc + ! combined constants real, parameter :: cpbgrav = MAPL_CP/MAPL_GRAV real, parameter :: gravbcp = MAPL_GRAV/MAPL_CP real, parameter :: alhlbcp = MAPL_ALHL/MAPL_CP real, parameter :: alhfbcp = MAPL_ALHF/MAPL_CP real, parameter :: alhsbcp = MAPL_ALHS/MAPL_CP + ! base grid length for sigma calculation + real :: SIGMA_DX = 750.0 + real :: SIGMA_EXP = 2.0 + ! control for order of plumes logical :: SH_MD_DP = .FALSE. + ! Radar parameter + integer :: DBZ_VAR_INTERCP=1 ! use variable intercept parameters + integer :: DBZ_LIQUID_SKIN=1 ! use liquid skin on snow(1) and graupel(2) in warm environments + LOGICAL :: refl10cm_allow_wet_graupel = .false. + LOGICAL :: refl10cm_allow_wet_snow = .true. + + ! Thompson radar constants + LOGICAL, PARAMETER:: iiwarm = .false. +!..Rho_not used in fallspeed relations (rho_not/rho)**.5 adjustment. + REAL, PARAMETER:: rho_not = 101325.0/(287.05*298.0) +!..Mass power law relations: mass = am*D**bm +!.. Snow from Field et al. (2005), others assume spherical form. + REAL, PARAMETER:: am_r = MAPL_PI*RHO_W/6.0 + REAL, PARAMETER:: bm_r = 3.0 + REAL, PARAMETER:: am_s = 0.069 + REAL, PARAMETER:: bm_s = 2.0 + REAL, PARAMETER:: bm_s_2 = 2.0**2 + REAL, PARAMETER:: bm_s_3 = 2.0**3 + REAL, PARAMETER:: am_g = MAPL_PI*rho_g/6.0 + REAL, PARAMETER:: bm_g = 3.0 + REAL, PARAMETER:: am_i = MAPL_PI*rho_i/6.0 + REAL, PARAMETER:: bm_i = 3.0 + REAL, PARAMETER:: am_s_r001 = (0.176/0.93) * (6.0/MAPL_PI) * (6.0/MAPL_PI) * (am_s/900.0)**2 + REAL, PARAMETER:: am_g_r001 = (0.176/0.93) * (6.0/MAPL_PI) * (6.0/MAPL_PI) * (am_g/900.0)**2 +!..Fallspeed power laws relations: v = (av*D**bv)*exp(-fv*D) +!.. Rain from Ferrier (1994), ice, snow, and graupel from +!.. Thompson et al (2008). Coefficient fv is zero for graupel/ice. + REAL, PARAMETER:: av_r = 4854.0 + REAL, PARAMETER:: bv_r = 1.0 + REAL, PARAMETER:: fv_r = 195.0 + REAL, PARAMETER:: av_s = 40.0 + REAL, PARAMETER:: bv_s = 0.55 + REAL, PARAMETER:: fv_s = 100.0 + REAL, PARAMETER:: av_g = 442.0 + REAL, PARAMETER:: bv_g = 0.89 + REAL, PARAMETER:: bv_i = 1.0 + REAL, PARAMETER:: av_c = 0.316946E8 + REAL, PARAMETER:: bv_c = 2.0 +!..Variables holding a bunch of exponents and gamma values (cloud water, +!.. cloud ice, rain, snow, then graupel). + REAL, DIMENSION(5,15), PRIVATE:: cce, ccg + REAL, DIMENSION(15), PRIVATE:: ocg1, ocg2 + REAL, DIMENSION(7), PRIVATE:: cie, cig + REAL, PRIVATE:: oig1, oig2, obmi + REAL, DIMENSION(13), PRIVATE:: cre, crg + REAL, PRIVATE:: ore1, org1, org2, org3, obmr + REAL, DIMENSION(18), PRIVATE:: cse, csg + REAL, PRIVATE:: oams, obms, ocms + REAL, DIMENSION(12), PRIVATE:: cge, cgg + REAL, PRIVATE:: oge1, ogg1, ogg2, ogg3, oamg, obmg, ocmg +!..Generalized gamma distributions for rain, graupel and cloud ice. +!.. N(D) = N_0 * D**mu * exp(-lamda*D); mu=0 is exponential. + REAL, PARAMETER:: mu_r = 0.0 + REAL, PARAMETER:: mu_g = 0.0 + REAL, PARAMETER:: mu_i = 0.0 +!..Sum of two gamma distrib for snow (Field et al. 2005). +!.. N(D) = M2**4/M3**3 * [Kap0*exp(-M2*Lam0*D/M3) +!.. + Kap1*(M2/M3)**mu_s * D**mu_s * exp(-M2*Lam1*D/M3)] +!.. M2 and M3 are the (bm_s)th and (bm_s+1)th moments respectively +!.. calculated as function of ice water content and temperature. + REAL, PARAMETER:: mu_s = 0.6357 + REAL, PARAMETER:: Kap0 = 490.6 + REAL, PARAMETER:: Kap1 = 17.46 + REAL, PARAMETER:: Lam0 = 20.78 + REAL, PARAMETER:: Lam1 = 3.29 +!..Y-intercept parameter for graupel is not constant and depends on +!.. mixing ratio. Also, when mu_g is non-zero, these become equiv +!.. y-intercept for an exponential distrib and proper values are +!.. computed based on same mixing ratio and total number concentration. + REAL, PARAMETER:: gonv_min = 1.E2 + REAL, PARAMETER:: gonv_max = 1.E6 +!> For snow moments conversions (from Field et al. 2005) + REAL, DIMENSION(10), PARAMETER, PRIVATE:: & + sa = (/ 5.065339, -0.062659, -3.032362, 0.029469, -0.000285, & + 0.31255, 0.000204, 0.003199, 0.0, -0.015952/) + REAL, DIMENSION(10), PARAMETER, PRIVATE:: & + sb = (/ 0.476221, -0.015896, 0.165977, 0.007468, -0.000141, & + 0.060366, 0.000079, 0.000594, 0.0, -0.003577/) + + REAL, PARAMETER:: sa3_bm_s = sa(3)*bm_s + REAL, PARAMETER:: sa4_bm_s = sa(4)*bm_s + REAL, PARAMETER:: sa6_bm_s = sa(6)*bm_s*bm_s + REAL, PARAMETER:: sa7_bm_s = sa(7)*bm_s + REAL, PARAMETER:: sa8_bm_s = sa(8)*bm_s*bm_s + REAL, PARAMETER:: sa10_bm_s = sa(10)*bm_s*bm_s*bm_s + + REAL, PARAMETER:: sb3_bm_s = sb(3)*bm_s + REAL, PARAMETER:: sb4_bm_s = sb(4)*bm_s + REAL, PARAMETER:: sb6_bm_s = sb(6)*bm_s*bm_s + REAL, PARAMETER:: sb7_bm_s = sb(7)*bm_s + REAL, PARAMETER:: sb8_bm_s = sb(8)*bm_s*bm_s + REAL, PARAMETER:: sb10_bm_s = sb(10)*bm_s*bm_s*bm_s + + REAL :: sa3_cse1, sa4_cse1, sa6_cse1, sa7_cse1, sa8_cse1, sa10_cse1 + REAL :: sb3_cse1, sb4_cse1, sb6_cse1, sb7_cse1, sb8_cse1, sb10_cse1 + REAL :: sa3_cse3, sa4_cse3, sa6_cse3, sa7_cse3, sa8_cse3, sa10_cse3 + REAL :: sb3_cse3, sb4_cse3, sb6_cse3, sb7_cse3, sb8_cse3, sb10_cse3 + + REAL :: r2o7, lam_r000, lam_r001 + ! option for cloud liq/ice radii integer :: LIQ_RADII_PARAM = 1 integer :: ICE_RADII_PARAM = 1 @@ -97,9 +211,9 @@ module GEOSmoist_Process_Library ! defined to determine CNV_FRACTION real :: CNV_FRACTION_MIN real :: CNV_FRACTION_MAX - real :: CNV_FRACTION_EXP ! Storage of aerosol properties for activation + type(AerPropsNew) :: AeroPropsNew(nsmx_par) type(AerProps), allocatable, dimension (:,:,:) :: AeroProps ! Tracer Bundle things for convection @@ -122,12 +236,14 @@ module GEOSmoist_Process_Library end type CNV_Tracer_Type type(CNV_Tracer_Type), allocatable :: CNV_Tracers(:) + public :: DEBUG_TQ_ERRORS public :: AeroProps + public :: AeroPropsNew public :: CNV_Tracer_Type, CNV_Tracers, CNV_Tracers_Init public :: ICE_FRACTION, EVAP3, SUBL3, LDRADIUS4, BUOYANCY, BUOYANCY2 public :: REDISTRIBUTE_CLOUDS, RADCOUPLE, FIX_UP_CLOUDS public :: hystpdf, fix_up_clouds_2M - public :: FILLQ2ZERO, FILLQ2ZERO1 + public :: FILLQ2ZERO public :: MELTFRZ public :: DIAGNOSE_PRECIP_TYPE public :: VertInterp, cs_interpolator @@ -136,13 +252,16 @@ module GEOSmoist_Process_Library public :: make_IceNumber, make_DropletNumber, make_RainNumber public :: dissipative_ke_heating public :: pdffrac, pdfcondensate, partition_dblgss - public :: CNV_FRACTION_MIN, CNV_FRACTION_MAX, CNV_FRACTION_EXP - public :: SH_MD_DP, LIQ_RADII_PARAM, ICE_RADII_PARAM + public :: SIGMA_DX, SIGMA_EXP + public :: CNV_FRACTION_MIN, CNV_FRACTION_MAX + public :: SH_MD_DP, DBZ_VAR_INTERCP, DBZ_LIQUID_SKIN, LIQ_RADII_PARAM, ICE_RADII_PARAM + public :: refl10cm_allow_wet_graupel, refl10cm_allow_wet_snow public :: update_cld, meltfrz_inst2M public :: FIX_NEGATIVE_PRECIP - public :: pdf_alpha - + public :: FIND_KLID public :: sigma + public :: pdf_alpha + public :: init_refl10cm, calc_refl10cm contains @@ -330,9 +449,18 @@ subroutine CNV_Tracers_Init(TR, RC) end subroutine CNV_Tracers_Init - real function sigma (dx) + real function sigma (dx, BASE_DX, BASE_EXP) real, intent(in) :: dx - sigma = 1.0-0.9839*exp(-0.09835*(dx/1000.)) ! Arakawa 2011 sigma + real, optional , intent(in) :: BASE_DX, BASE_EXP + real :: tmp_exp + tmp_exp = SIGMA_EXP + if (present(BASE_EXP)) tmp_exp = BASE_EXP + ! Arakawa 2011 based sigma function + if (present(BASE_DX)) then + sigma = (1.0-0.9839*exp(-0.09835*(dx/ BASE_DX)))**tmp_exp + else + sigma = (1.0-0.9839*exp(-0.09835*(dx/SIGMA_DX)))**tmp_exp + endif end function sigma function ICE_FRACTION_3D (TEMP,CNV_FRACTION,SRF_TYPE) RESULT(ICEFRCT) @@ -374,12 +502,13 @@ function ICE_FRACTION_SC (TEMP,CNV_FRACTION,SRF_TYPE) RESULT(ICEFRCT) real :: tc, ptc real :: ICEFRCT_C, ICEFRCT_M -#ifdef MODIS_ICE_POLY +#ifdef USE_MODIS_ICE_POLY ! Use MODIS polynomial from Hu et al, DOI: (10.1029/2009JD012384) tc = MAX(-46.0,MIN(TEMP-MAPL_TICE,46.0)) ! convert to celcius and limit range from -46:46 C ptc = 7.6725 + 1.0118*tc + 0.1422*tc**2 + 0.0106*tc**3 + 0.000339*tc**4 + 0.00000395*tc**5 ICEFRCT = 1.0 - (1.0/(1.0 + exp(-1*ptc))) #else + ! Use sigmoidal functions based on surface type from Hu et al, DOI: (10.1029/2009JD012384) ! Anvil clouds ! Anvil-Convective sigmoidal function like figure 6(right) ! Sigmoidal functions Hu et al 2010, doi:10.1029/2009JD012384 @@ -403,29 +532,20 @@ function ICE_FRACTION_SC (TEMP,CNV_FRACTION,SRF_TYPE) RESULT(ICEFRCT) ICEFRCT_C = MAX(ICEFRCT_C,0.00) ICEFRCT_C = ICEFRCT_C**aICEFRPWR ! Sigmoidal functions like figure 6b/6c of Hu et al 2010, doi:10.1029/2009JD012384 - if (SRF_TYPE >= 2.0) then + select case (nint(SRF_TYPE)) + case (SRF_TYPE_SNOW, SRF_TYPE_ICE) ! Over snow (SRF_TYPE == 2.0) and ice (SRF_TYPE == 3.0) - if (ICE_RADII_PARAM == 1) then - ! Jason formula - ICEFRCT_M = 0.00 - if ( TEMP <= JiT_ICE_ALL ) then - ICEFRCT_M = 1.000 - else if ( (TEMP > JiT_ICE_ALL) .AND. (TEMP <= JiT_ICE_MAX) ) then - ICEFRCT_M = 1.00 - ( TEMP - JiT_ICE_ALL ) / ( JiT_ICE_MAX - JiT_ICE_ALL ) - end if - else - ICEFRCT_M = 0.00 - if ( TEMP <= iT_ICE_ALL ) then - ICEFRCT_M = 1.000 - else if ( (TEMP > iT_ICE_ALL) .AND. (TEMP <= iT_ICE_MAX) ) then - ICEFRCT_M = SIN( 0.5*MAPL_PI*( 1.00 - ( TEMP - iT_ICE_ALL ) / ( iT_ICE_MAX - iT_ICE_ALL ) ) ) - end if + ICEFRCT_M = 0.00 + if ( TEMP <= iT_ICE_ALL ) then + ICEFRCT_M = 1.000 + else if ( (TEMP > iT_ICE_ALL) .AND. (TEMP <= iT_ICE_MAX) ) then + ICEFRCT_M = SIN( 0.5*MAPL_PI*( 1.00 - ( TEMP - iT_ICE_ALL ) / ( iT_ICE_MAX - iT_ICE_ALL ) ) ) end if ICEFRCT_M = MIN(ICEFRCT_M,1.00) ICEFRCT_M = MAX(ICEFRCT_M,0.00) ICEFRCT_M = ICEFRCT_M**iICEFRPWR - else if (SRF_TYPE > 1.0) then - ! Over Land + case (SRF_TYPE_LAND) + ! Over Land (SRF_TYPE == 1) ICEFRCT_M = 0.00 if ( TEMP <= lT_ICE_ALL ) then ICEFRCT_M = 1.000 @@ -435,8 +555,8 @@ function ICE_FRACTION_SC (TEMP,CNV_FRACTION,SRF_TYPE) RESULT(ICEFRCT) ICEFRCT_M = MIN(ICEFRCT_M,1.00) ICEFRCT_M = MAX(ICEFRCT_M,0.00) ICEFRCT_M = ICEFRCT_M**lICEFRPWR - else - ! Over Oceans + case (SRF_TYPE_OCEAN) + ! Over Oceans (SRF_TYPE == 0) ICEFRCT_M = 0.00 if ( TEMP <= oT_ICE_ALL ) then ICEFRCT_M = 1.000 @@ -446,7 +566,11 @@ function ICE_FRACTION_SC (TEMP,CNV_FRACTION,SRF_TYPE) RESULT(ICEFRCT) ICEFRCT_M = MIN(ICEFRCT_M,1.00) ICEFRCT_M = MAX(ICEFRCT_M,0.00) ICEFRCT_M = ICEFRCT_M**oICEFRPWR - endif + case default + ! You should not be here + print *, 'ICE_FRACTION_SC: Unknown SRF_TYPE = ',SRF_TYPE + error stop + end select ! Combine the Convective and MODIS functions ICEFRCT = ICEFRCT_M*(1.0-CNV_FRACTION) + ICEFRCT_C*(CNV_FRACTION) #endif @@ -516,7 +640,7 @@ subroutine EVAP3(& if ( (RHx < RHCR ) .and. (RADIUS > 0.0) ) then EVAP = A_EFF*QL*DT*(RHCR - RHx) / ((K1+K2)*RADIUS**2) - EVAP = MIN( EVAP , QL ) + EVAP = MAX(0.0, MIN( EVAP , QL )) else EVAP = 0.0 end if @@ -595,7 +719,7 @@ subroutine SUBL3( & if ( (RHx < RHCR) .and.(RADIUS > 0.0) ) then SUBL = A_EFF*QI*DT*(RHCR - RHx) / ((K1+K2)*RADIUS**2) - SUBL = MIN( SUBL , QI ) + SUBL = MAX(0.0, MIN( SUBL , QI )) else SUBL = 0.0 end if @@ -619,7 +743,7 @@ function LDRADIUS4(PL,TE,QC,NNL,NNI,ITYPE) RESULT(RADIUS) REAL :: RADIUS INTEGER, PARAMETER :: LIQUID=1, ICE=2 REAL :: NNX,RHO,BB,WC - REAL :: TC,ZFSR,AA + REAL :: TC,AA !- air density (kg/m^3) RHO = (100.*PL) / (MAPL_RGAS*TE ) @@ -648,7 +772,7 @@ function LDRADIUS4(PL,TE,QC,NNL,NNI,ITYPE) RESULT(RADIUS) !- radius in meters if (ICE_RADII_PARAM == 1) then !------ice cloud effective radius ----- [klaus wyser, 1998] - if(TE>MAPL_TICE .or. QC <=0.) then + if(TE>MAPL_TICE .or. QC < 1.e-9) then BB = -2. else BB = -2. + log10(WC/50.)*(1.e-3*(MAPL_TICE-TE)**1.5) @@ -658,12 +782,12 @@ function LDRADIUS4(PL,TE,QC,NNL,NNI,ITYPE) RESULT(RADIUS) RADIUS = MIN(150.e-6,MAX(5.e-6, 1.e-6*RADIUS)) else !------ice cloud effective radius ----- [Sun, 2001] + ! https://agupubs.onlinelibrary.wiley.com/doi/full/10.1029/2022GL102521 TC = TE - MAPL_TICE - ZFSR = 1.2351 + 0.0105 * TC AA = 45.8966 * (WC**0.2214) - BB = 0.79570 * (WC**0.2535) - RADIUS = ZFSR * (AA + BB * (TE - 83.15)) - RADIUS = MIN(150.e-6,MAX(5.e-6, 1.e-6*RADIUS*0.64952)) + BB = 0.79570 * (WC**0.2535) * (TE - 83.15) + RADIUS = MIN(155.0 ,MAX(30.0 , (1.2351 + 0.0105*TC) * (AA + BB))) + RADIUS = MIN(150.e-6,MAX( 5.e-6, 1.e-6*0.64952*RADIUS)) endif ELSE @@ -965,29 +1089,29 @@ subroutine RADCOUPLE( & RAD_CF = MAX(MIN(CF+AF,1.0),0.0) if ( RAD_CF >= 1.e-5 ) then ! Total In-cloud liquid - if ( (QClLS + QClAN) >= 1.e-8 ) then + if ( (QClLS + QClAN) >= QCMIN ) then RAD_QL = ( QClLS + QClAN ) / RAD_CF else RAD_QL = 0.0 end if ! Total In-cloud ice - if ( (QCiLS + QCiAN) >= 1.e-8 ) then + if ( (QCiLS + QCiAN) >= QCMIN ) then RAD_QI = ( QCiLS + QCiAN ) / RAD_CF else RAD_QI = 0.0 end if ! Total In-cloud precipitation - if (QRN_ALL >= 1.e-8 ) then + if (QRN_ALL >= QCMIN ) then RAD_QR = ( QRN_ALL ) / RAD_CF else RAD_QR = 0.0 end if - if (QSN_ALL >= 1.e-8 ) then + if (QSN_ALL >= QCMIN ) then RAD_QS = ( QSN_ALL ) / RAD_CF else RAD_QS = 0.0 end if - if (QGR_ALL >= 1.e-8 ) then + if (QGR_ALL >= QCMIN ) then RAD_QG = ( QGR_ALL ) / RAD_CF else RAD_QG = 0.0 @@ -1008,16 +1132,24 @@ subroutine RADCOUPLE( & RAD_QG = MIN( RAD_QG, 0.01 ) ! LIQUID RADII - !-BRAMS formulation - RAD_RL = LDRADIUS4(PL,TE,RAD_QL,NL,NI,1) - ! apply limits - RAD_RL = MAX( MIN_RL, MIN(RAD_RL*FAC_RL, MAX_RL) ) + if (RAD_QL > QCMIN) then + !-BRAMS formulation + RAD_RL = LDRADIUS4(PL,TE,RAD_QL,NL,NI,1) + ! apply limits + RAD_RL = MAX( MIN_RL, MIN(RAD_RL*FAC_RL, MAX_RL) ) + else + RAD_RL = MAPL_UNDEF + end if ! ICE RADII - !-BRAMS formulation - RAD_RI = LDRADIUS4(PL,TE,RAD_QI,NL,NI,2) - ! apply limits - RAD_RI = MAX( MIN_RI, MIN(RAD_RI*FAC_RI, MAX_RI) ) + if (RAD_QI > QCMIN) then + !-BRAMS formulation + RAD_RI = LDRADIUS4(PL,TE,RAD_QI,NL,NI,2) + ! apply limits + RAD_RI = MAX( MIN_RI, MIN(RAD_RI*FAC_RI, MAX_RI) ) + else + RAD_RI = MAPL_UNDEF + end if end subroutine RADCOUPLE @@ -1029,64 +1161,49 @@ subroutine FIX_UP_CLOUDS( & CF, & QLA,& QIA,& - AF ) + AF ,& + REMOVE_CLOUDS ) real, intent(inout) :: TE,QV,QLC,CF,QLA,AF,QIC,QIA + logical, optional, intent(IN) :: REMOVE_CLOUDS + real :: FCLD + logical :: RM_CLDS - ! Fix if Anvil cloud fraction too small - if (AF < 1.E-5) then - QV = QV + QLA + QIA - TE = TE - (alhlbcp)*QLA - (alhsbcp)*QIA + RM_CLDS = .false. + if (present(REMOVE_CLOUDS)) RM_CLDS = REMOVE_CLOUDS + + if (RM_CLDS .AND. (QLA+QIA+QLC+QIC > QCMIN)) then + + ! Remove ALL cloud quants above the klid + QV = QV + QLA + QIA + QLC + QIC + TE = TE - (alhlbcp)*(QLA+QLC) - (alhsbcp)*(QIA+QIC) AF = 0. QLA = 0. QIA = 0. - end if - - ! Fix if LS cloud fraction too small - if ( CF < 1.E-5 ) then - QV = QV + QLC + QIC - TE = TE - (alhlbcp)*QLC - (alhsbcp)*QIC CF = 0. QLC = 0. QIC = 0. - end if - ! LS LIQUID too small - if ( QLC < 1.E-8 ) then - QV = QV + QLC - TE = TE - (alhlbcp)*QLC - QLC = 0. - end if - ! LS ICE too small - if ( QIC < 1.E-8 ) then - QV = QV + QIC - TE = TE - (alhsbcp)*QIC - QIC = 0. - end if + else - ! Anvil LIQUID too small - if ( QLA < 1.E-8 ) then - QV = QV + QLA - TE = TE - (alhlbcp)*QLA - QLA = 0. - end if - ! Anvil ICE too small - if ( QIA < 1.E-8 ) then - QV = QV + QIA - TE = TE - (alhsbcp)*QIA - QIA = 0. + ! Ensure total cloud fraction <= 1.0 + FCLD = CF + AF + if (FCLD > 1.0) then + CF = CF*(1.0/FCLD) + AF = AF*(1.0/FCLD) end if - ! Fix ALL cloud quants if Anvil cloud LIQUID+ICE too small - if ( ( QLA + QIA ) < 1.E-8 ) then - QV = QV + QLA + QIA - TE = TE - (alhlbcp)*QLA - (alhsbcp)*QIA + ! Fix if Anvil cloud fraction too small + if ( (AF == 0.0) .AND. (QLA+QIA > QCMIN) ) then + QV = QV + QLA + QIA + TE = TE - (alhlbcp)*QLA - (alhsbcp)*QIA AF = 0. QLA = 0. QIA = 0. end if - ! Ditto if LS cloud LIQUID+ICE too small - if ( ( QLC + QIC ) < 1.E-8 ) then + + ! Fix if LS cloud fraction too small + if ( (CF == 0.0) .AND. (QLC+QIC > QCMIN) ) then QV = QV + QLC + QIC TE = TE - (alhlbcp)*QLC - (alhsbcp)*QIC CF = 0. @@ -1094,6 +1211,8 @@ subroutine FIX_UP_CLOUDS( & QIC = 0. end if + end if + end subroutine FIX_UP_CLOUDS subroutine fix_up_clouds_2M( & @@ -1121,12 +1240,15 @@ subroutine fix_up_clouds_2M( & real, dimension(:,:,:), intent(in) :: MASS real, dimension(:,:), intent( out) :: TMP2D integer :: IM, JM, LM + integer :: STATUS real, parameter :: qmin = 1.0e-12 real, parameter :: cfmin = 1.0e-4 real, parameter :: nmin = 100.0 + + ! Fix if Anvil cloud fraction too small where (AF < cfmin) QV = QV + QLA + QIA @@ -1187,7 +1309,7 @@ subroutine fix_up_clouds_2M( & QLC = 0. QIC = 0. end where - + IM = SIZE( QV, 1 ) JM = SIZE( QV, 2 ) LM = SIZE( QV, 3 ) @@ -1221,18 +1343,18 @@ subroutine fix_up_clouds_2M( & where (QS .le. qmin) NS = 0. where (QG .le. qmin) NG = 0. - + ! need to clean up small negative values. MG does can't handle them - call FILLQ2ZERO( QV, MASS, TMP2D) - call FILLQ2ZERO( QG, MASS, TMP2D) - call FILLQ2ZERO( QR, MASS, TMP2D) - call FILLQ2ZERO( QS, MASS, TMP2D) - call FILLQ2ZERO( QLC, MASS, TMP2D) - call FILLQ2ZERO( QLA, MASS, TMP2D) - call FILLQ2ZERO( QIC, MASS, TMP2D) - call FILLQ2ZERO( QIA, MASS, TMP2D) - call FILLQ2ZERO( CF, MASS, TMP2D) - call FILLQ2ZERO( AF, MASS, TMP2D) + call FILLQ2ZERO( QV, MASS, RC=STATUS) + call FILLQ2ZERO( QG, MASS, RC=STATUS) + call FILLQ2ZERO( QR, MASS, RC=STATUS) + call FILLQ2ZERO( QS, MASS, RC=STATUS) + call FILLQ2ZERO( QLC, MASS, RC=STATUS) + call FILLQ2ZERO( QLA, MASS, RC=STATUS) + call FILLQ2ZERO( QIC, MASS, RC=STATUS) + call FILLQ2ZERO( QIA, MASS, RC=STATUS) + call FILLQ2ZERO( CF, MASS, RC=STATUS) + call FILLQ2ZERO( AF, MASS, RC=STATUS) end subroutine fix_up_clouds_2M @@ -1517,21 +1639,21 @@ subroutine partition_dblgss( fQi, & ! IN ! Compute square roots of some variables so we don't have to do it again - if (w_sec > 0.0) then + if (w_sec > w_thresh*w_thresh) then sqrtw2 = sqrt(w_sec) Skew_w = w3var / (sqrtw2*sqrtw2*sqrtw2) else sqrtw2 = w_thresh Skew_w = 0. endif - if (thlsec > 0.0) then + if (thlsec > 1e-6) then sqrtthl = sqrt(thlsec) skew_thl = hl3 / sqrtthl**3 else sqrtthl = 1e-3 skew_thl = 0. endif - if (qwsec > 0.0) then + if (qwsec > 1e-8*total_water*total_water) then sqrtqt = sqrt(qwsec) skew_qw = qt3/sqrtqt**3 else @@ -1680,7 +1802,7 @@ subroutine partition_dblgss( fQi, & ! IN IF (qwsec <= rt_tol*rt_tol .or. abs(w1_2-w1_1) <= w_thresh) THEN ! if no active updrafts - if (aterm .lt. 1e-3 .or. aterm.gt.0.499 .or. Skew_qw.lt.1e-8) then ! if no residual skewness + if (aterm .lt. 1e-3 .or. aterm.gt.0.499 .or. abs(Skew_qw).lt.1e-8) then ! if no residual skewness qw1_1 = total_water qw1_2 = total_water qw2_1 = qwsec @@ -1831,7 +1953,6 @@ subroutine partition_dblgss( fQi, & ! IN ! this is qs evaluated at Tl qs1 = om1 * (0.622*esval1_1/max(esval1_1,pval-0.378*esval1_1)) & + (1.-om1) * (0.622*esval2_1/max(esval2_1,pval-0.378*esval2_1)) -! qs1 = GEOS_QSAT( Tl1_1, pval*0.01 ) beta1 = (lstarn1*lstarn1*onebrvcp) / (Tl1_1*Tl1_1) @@ -1842,18 +1963,10 @@ subroutine partition_dblgss( fQi, & ! IN beta2 = beta1 ELSE -! IF (Tl1_2 < tbgmin) THEN -! esval1_2 = MAPL_EQsat(Tl1_2,OverIce=.TRUE.) -! lstarn2 = lsub -! ELSE IF (Tl1_2 >= tbgmax) THEN -! esval1_2 = MAPL_EQsat(Tl1_2) -! lstarn2 = lcond -! ELSE esval1_2 = MAPL_EQsat(Tl1_2) esval2_2 = MAPL_EQsat(Tl1_2,OverIce=.TRUE.) om2 = max(0.,min(1.,1.-fQi)) !max(0.,min(1.,a_bg*(Tl1_2-tbgmin))) lstarn2 = lcond + (1.-om2)*lfus -! ENDIF qs2 = om2 * (0.622*esval1_2/max(esval1_2,pval-0.378*esval1_2)) & + (1.-om2) * (0.622*esval2_2/max(esval2_2,pval-0.378*esval2_2)) @@ -1925,7 +2038,7 @@ subroutine partition_dblgss( fQi, & ! IN ! finally, compute the SGS cloud fraction - diag_frac = aterm*C1 + onema*C2 + cld_sgs = aterm*C1 + onema*C2 ! om1 = max(0.,min(1.,(Tl1_1-tbgmin)*a_bg)) ! om2 = max(0.,min(1.,(Tl1_2-tbgmin)*a_bg)) @@ -1950,21 +2063,13 @@ subroutine partition_dblgss( fQi, & ! IN ! + tkesbdiss(i,j,k) * (dtn/cp) ! tke dissipative heating ! Update moisture fields - - -! qc = diag_ql + diag_qi -! qi = diag_qi -! qwv = total_water - diag_qn - cld_sgs = diag_frac - - if (sqrtqt>0.0 .AND. sqrtw2>0.0) then - rwqt = (1.-0.5)*wqwsec/(sqrtqt*sqrtw2) -! rwqt = (wqwsec)/(sqrtqt*sqrtw2) + if (sqrtqt>1e-4*total_water .AND. sqrtw2>w_thresh) then + rwqt = 0.5*wqwsec/(sqrtqt*sqrtw2) ! rwqt = max(-1.,min(1.,pdf_rwqt)) else rwqt = 0.0 end if - if (sqrtthl>0.0 .AND. sqrtw2>0.0) then + if (sqrtthl>1e-3 .AND. sqrtw2>w_thresh) then rwthl = wthlsec/(sqrtthl*sqrtw2) ! rwthl = max(-1.,min(1.,pdf_rwth)) else @@ -1987,8 +2092,7 @@ subroutine partition_dblgss( fQi, & ! IN wthv_sec = wthlsec + wrk*wqwsec & + (fac_cond-bastoeps)*wqls & + (fac_sub-bastoeps) *wqis - -! + ((lstarn1/cp)-thv(i,j,k))*0.5*(wqp_sec(i,j,kd)+wqp_sec(i,j,ku)) +! + ((lstarn1/cp)-thv(i,j,k))*0.5*(wqp_sec(i,j,kd)+wqp_sec(i,j,ku)) end subroutine partition_dblgss @@ -2069,7 +2173,7 @@ subroutine hystpdf( & real :: TEp, QSp, CFp, QVp, QCp real :: TEn, QSn, CFn, QVn, QCn - real :: QAo, QAx, QCx, QC, fQi, QCi, qsnx + real :: QCx, QC, fQi, QCi, qsnx real :: dQICN, dQLCN, dQILS, dQLLS, Nfac, NLv, NIv real :: tmpARR @@ -2081,13 +2185,9 @@ subroutine hystpdf( & scice = 1.0 - tmpARR = 0.0 if (CLCN < 1.0) tmpARR = 1.0/(1.0-CLCN) - QAx = 0.0 - if (CLCN > tiny(0.0)) QAx = (QLCN+QICN)/CLCN - CFn = (CLLS )*tmpARR QCn = (QLLS + QILS)*tmpARR QCi = (QILS)*tmpARR @@ -2108,7 +2208,7 @@ subroutine hystpdf( & DQS = GEOS_DQSAT( TEn, PL, QSAT=QSn ) if(present(SC_ICE)) then - scice = min(max(SC_ICE, 1.0), 1.7) + scice = min(max(SC_ICE, 1.0), 1.7) qsnx= Qsn*scice ! if ((QCi .ge. 0.0) .and. (Qsn .gt. Qt)) QSn=Qsnx !this way we do not evaporate preexisting ice but maintain supersat end if @@ -2180,6 +2280,7 @@ subroutine hystpdf( & IF(USE_BERGERON) THEN DQCALL = QCn - QCp + CLLS = CFn * (1.-CLCN) Nfac = 100.*PL*R_AIR/TEn !density times conversion factor NLv = NL/Nfac NIv = NI/Nfac @@ -2215,41 +2316,21 @@ subroutine hystpdf( & QCn = QCp + 0.5*(QCn-QCp) endif - if ( CLCN > 0. ) then - QAo = QAx - else - QAo = 0. - end if - QVn = QVp - (QCn - QCp) - TEn = TEp + (1.0-fQi)*(alhlbcp)*( (QCn - QCp)*(1.-CLCN) + (QAo-QAx)*CLCN ) & - + fQi *(alhsbcp)*( (QCn - QCp)*(1.-CLCN) + (QAo-QAx)*CLCN ) + TEn = TEp + (1.0-fQi)*(alhlbcp)*(QCn - QCp)*(1.-CLCN) & + + fQi *(alhsbcp)*(QCn - QCp)*(1.-CLCN) PDFITERS = n if (abs(TEn - TEp) .lt. 0.00001) exit enddo ! qsat iteration - if ( CLCN < 1.0 ) then - CLLS = CFn * (1.-CLCN) - QCn = QCn * (1.-CLCN) - QAo = QAo * CLCN - else - ! Special case CLCN=1, i.e., box filled with anvil. - ! - Note: no guarantee QV_box > QS_box - CLLS = 0. ! Remove any LS cloud - QAo = QLCN+QICN+QLLS+QILS ! Add all LS condensate to anvil type - QCn = 0. ! Remove same from new LS - QT = QAo + QV ! Update total water - ! Now set anvil condensate to any excess of total water - ! over QSx (saturation value at top) - QAo = MAX( QT - QSx, 0. ) - end if - ! Now take {\em New} condensate and partition into ice and liquid ! large-scale - QCx = QCn - (QLLS+QILS) + CLLS = CFn * (1.-CLCN) + QCn = QCn * (1.-CLCN) + QCx = QCn - (QLLS+QILS) if (QCx .lt. 0.0) then !net evaporation dQLLS = max(QCx , -QLLS) ! Water evaporates first dQILS = max(QCx - dQLLS, -QILS) ! Then sublimation @@ -2258,47 +2339,16 @@ subroutine hystpdf( & dQILS = fQi *QCx end if - ! convective - QAx = QAo - (QLCN+QICN) - if (QAx .lt. 0.0) then !net evaporation - dQLCN = max(QAx , -QLCN) ! Water evaporates first - dQICN = max(QAx - dQLCN, -QICN) ! Then sublimation - else - dQLCN = (1.0-fQi)*QAx - dQICN = fQi *QAx - end if - ! Clean-up cloud if fractions are too small - if ( CLCN < 1.e-5 ) then - dQICN = -QICN - dQLCN = -QLCN - end if if ( CLLS < 1.e-5 ) then dQILS = -QILS dQLLS = -QLLS end if - QICN = QICN + dQICN - QLCN = QLCN + dQLCN QILS = QILS + dQILS QLLS = QLLS + dQLLS - QV = QV - (dQICN+dQILS+dQLCN+dQLLS) - TE = TE + alhlbcp*(dQICN+dQILS+dQLCN+dQLLS) + alhfbcp*(dQICN+dQILS) - - ! We need to take care of situations where QS moves past QA - ! during QSAT iteration. This should be only when QA/AF is small - ! to begin with. Effect is to make QAo negative. So, we - ! "evaporate" offending QA's - ! - ! We get rid of anvil fraction also, although strictly - ! speaking, PDF-wise, we should not do this. - if ( QAo <= 0. ) then - QV = QV + QICN + QLCN - TE = TE - alhsbcp*QICN - alhlbcp*QLCN - QICN = 0. - QLCN = 0. - CLCN = 0. - end if + QV = QV - (dQILS+dQLLS) + TE = TE + alhlbcp*(dQILS+dQLLS) + alhfbcp*(dQILS) end subroutine hystpdf @@ -2335,7 +2385,7 @@ subroutine pdf_alpha(PP,P_LM, ALPHA, FRLAND, MINRHCRIT, TURNRHCRIT, TURNRHCRIT_U if (TURNRHCRIT_UPPER .gt. 0.0) then aux2= 1.0/(1.0+exp(aux2)) !this function reverses the profile P< TURNRHCRIT_UPPER else - aux2=1.0 + aux2=1.0 end if ALPHA = min(maxalpha*aux1*aux2, 0.4) @@ -2401,7 +2451,7 @@ subroutine Bergeron_Partition ( & TC = TE-MAPL_TICE fQI_0 = fQI - !Completelely glaciated cloud: + !Completely glaciated cloud: if (TE .ge. iT_ICE_MAX) then !liquid cloud FQI = 0.0 elseif(TE .le. iT_ICE_ALL) then !ice cloud @@ -2509,15 +2559,15 @@ subroutine MELTFRZ_SC( DT, CNVFRC, SRFTYPE, TE, QL, QI ) ! freeze liquid first if ( TE <= MAPL_TICE ) then fQi = ice_fraction( TE, CNVFRC, SRFTYPE ) - dQil = Ql *(1.0 - EXP( -Dt * fQi / taufrz ) ) + dQil = Ql *(1.0 - EXP( -DT * fQi / max(DT,taufrz) ) ) dQil = max( 0., dQil ) Qi = Qi + dQil Ql = Ql - dQil TE = TE + (MAPL_ALHS-MAPL_ALHL)*dQil/MAPL_CP end if - ! melt ice instantly above 0^C + ! melt ice above 0^C if ( TE > MAPL_TICE ) then - dQil = -Qi + dQil = -Qi *(1.0 - EXP( -DT / max(DT,taumlt) ) ) dQil = min( 0., dQil ) Qi = Qi + dQil Ql = Ql - dQil @@ -2525,7 +2575,7 @@ subroutine MELTFRZ_SC( DT, CNVFRC, SRFTYPE, TE, QL, QI ) end if end subroutine MELTFRZ_SC - subroutine FILLQ2ZERO( Q, MASS, FILLQ ) + subroutine FILLQ2ZERO( Q, MASS, DT, DQDT, WARNING_LABEL, VM, RC ) ! New algorithm to fill the negative q values in a mass conserving way. ! Conservation of TPW was checked. Donifan Barahona @@ -2533,77 +2583,81 @@ subroutine FILLQ2ZERO( Q, MASS, FILLQ ) real, dimension(:,:,:), intent(inout) :: Q real, dimension(:,:,:), intent(in) :: MASS - real, dimension(:,:), intent( out) :: FILLQ + real, optional, intent(in) :: DT + real, optional, pointer, intent(out) :: DQDT(:,:,:) + character(*), optional, intent(in) :: WARNING_LABEL + type( ESMF_VM ), optional,intent(in) :: VM + integer, intent(out) :: RC + ! Locals real, dimension(:,:), allocatable :: TPW1, TPW2, TPWC integer :: IM,JM,LM, l + integer :: RANK + integer :: neg_count, total_count, I1D(2) + character(len=ESMF_MAXSTR) :: IAm="FILLQ2ZERO" + integer :: STATUS + + if (PRESENT(WARNING_LABEL) .AND. PRESENT(VM)) then + ! Calculate local statistics + if (any(Q < 0.0)) then + neg_count = count(Q < 0.0) + else + neg_count = 0 + endif + total_count = size(Q) + if (PRESENT(VM)) then + call ESMF_VmGet(VM, localPet=RANK, rc=STATUS) + VERIFY_(STATUS) + call ESMF_VMAllReduce(VM, sendData=[neg_count,total_count], & + recvData=I1D, count=2, & + reduceflag=ESMF_REDUCE_SUM, rc=STATUS) + VERIFY_(STATUS) + if ((RANK==0) .AND. (I1D(1)>0) .AND. (I1D(2)>0)) & + write(*,'(A,A,A,/,2X,A,I0,A,I0,A,F5.1,A)') & + 'WARNING: Negative values filled in ', trim(WARNING_LABEL), ':', & + 'Count: ', I1D(1), '/', I1D(2), ' (', & + (real(I1D(1))/real(I1D(2)))*100.0, '%)' + endif + endif IM = SIZE( Q, 1 ) JM = SIZE( Q, 2 ) LM = SIZE( Q, 3 ) - + ALLOCATE(TPW1(IM, JM)) ALLOCATE(TPW2(IM, JM)) ALLOCATE(TPWC(IM, JM)) + + TPW2 =0.0 + TPWC= 0.0 + TPW1 = SUM( Q*MASS, 3 ) - TPW2 =0.0 - TPWC= 0.0 - TPW1 = SUM( Q*MASS, 3 ) - - WHERE (Q < 0.0) - Q=0.0 + if (PRESENT(DQDT) .AND. PRESENT(DT)) then + if (ASSOCIATED(DQDT)) DQDT = Q + endif + + WHERE (Q < 1.e-15) + Q=1.e-15 END WHERE TPW2 = SUM( Q*MASS, 3 ) - - WHERE (TPW2 > 0.0) + + WHERE (TPW2 > 1.e-15) TPWC=(TPW2-TPW1)/TPW2 END WHERE - + do l=1,LM Q(:, :, l)= Q(:, :, l)*(1.0-TPWC) !reduce Q proportionally to the increase in TPW end do - - FILLQ = TPW2-TPW1 + + if (PRESENT(DQDT) .AND. PRESENT(DT)) then + if (ASSOCIATED(DQDT)) DQDT = (Q - DQDT)/DT + endif DEALLOCATE(TPW1) DEALLOCATE(TPW2) DEALLOCATE(TPWC) end subroutine FILLQ2ZERO - subroutine FILLQ2ZERO1( Q, MASS, FILLQ ) - real, dimension(:,:,:), intent(inout) :: Q - real, dimension(:,:,:), intent(in) :: MASS - real, dimension(:,:), intent( out) :: FILLQ - integer :: IM,JM,LM - integer :: I,J,K,L - real :: TPW, NEGTPW -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - ! Fills in negative q values in a mass conserving way. - ! Conservation of TPW was checked. -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - IM = SIZE( Q, 1 ) - JM = SIZE( Q, 2 ) - LM = SIZE( Q, 3 ) - do j=1,JM - do i=1,IM - TPW = SUM( Q(i,j,:)*MASS(i,j,:) ) - NEGTPW = 0. - do l=1,LM - if ( Q(i,j,l) < 0.0 ) then - NEGTPW = NEGTPW + ( Q(i,j,l)*MASS( i,j,l ) ) - Q(i,j,l) = 0.0 - endif - enddo - do l=1,LM - if ( Q(i,j,l) >= 0.0 ) then - Q(i,j,l) = Q(i,j,l)*( 1.0+NEGTPW/(TPW-NEGTPW) ) - endif - enddo - FILLQ(i,j) = -NEGTPW - end do - end do - end subroutine FILLQ2ZERO1 - subroutine DIAGNOSE_PRECIP_TYPE(IM, JM, LM, TPREC, RAIN_LS, RAIN_CU, RAIN, SNOW, ICE, FRZR, PTYPE, PLE, TH, PK, PKE, ZL0, LUPDATE_PRECIP_TYPE) integer, intent(in ) :: IM, JM, LM real, dimension(IM,JM), intent(inout) :: TPREC, RAIN_LS, RAIN_CU, RAIN, SNOW, ICE, FRZR @@ -3313,7 +3367,7 @@ subroutine update_cld( & real, intent(in) :: DT,ALPHA,PL,CNVFRC,SRFTYPE integer, intent(in) :: pdfflag - real, intent(inout) :: TE,QV,QCl,QCi,CF,QAl,QAi,AF, NI, RHCmicro, NL, SCICE + real, intent(inout) :: TE,QV,QCl,QCi,CF,QAl,QAi,AF,SCICE,NI,NL,RHCmicro ! internal arrays real :: CFO @@ -3389,7 +3443,7 @@ subroutine update_cld( & else RHCmicro = 1.0-ALPHA end if - + RHCmicro = max(min(RHCmicro, 0.99), 0.6) CFALL = max(CFo, 0.0) @@ -3488,15 +3542,15 @@ end subroutine meltfrz_inst2M subroutine FIX_NEGATIVE_PRECIP(QRAIN, QSNOW, QGRAUPEL) real, dimension(:,:,:), intent(inout) :: QRAIN, QSNOW, QGRAUPEL - WHERE (QRAIN < 1.e-8) + WHERE (QRAIN < QCMIN) QRAIN = 0.0 END WHERE - WHERE (QSNOW < 1.e-8) + WHERE (QSNOW < QCMIN) QSNOW = 0.0 END WHERE - WHERE (QGRAUPEL < 1.e-8) + WHERE (QGRAUPEL < QCMIN) QGRAUPEL = 0.0 END WHERE @@ -3504,73 +3558,43 @@ end subroutine FIX_NEGATIVE_PRECIP subroutine REDISTRIBUTE_CLOUDS(CF, QL, QI, CLCN, CLLS, QLCN, QLLS, QICN, QILS, QV, TE) real, dimension(:,:,:), intent(inout) :: CF, QL, QI, CLCN, CLLS, QLCN, QLLS, QICN, QILS, QV, TE - ! local storage for cnv fraction of condensate/cloud - real :: FCN(size(CF,1),size(CF,2),size(CF,3)) - real :: DQC(size(CF,1),size(CF,2),size(CF,3)) - - ! Fix cloud quants if too small - WHERE (QL+QI < 1.E-8) - QV = QV + QL + QI - TE = TE - alhlbcp*QL - alhsbcp*QI - CF = 0. - QL = 0. - QI = 0. - END WHERE - WHERE (CF < 1.E-5) - QV = QV + QL + QI - TE = TE - alhlbcp*QL - alhsbcp*QI - CF = 0. - QL = 0. - QI = 0. - END WHERE - ! Redistribute liquid CN/LS portions based on prior fractions - ! FCN Needs to be calculated first - FCN = 0.0 - WHERE (QLCN+QLLS > 0.0) - FCN = min(max(QLCN/(QLCN+QLLS), 0.0), 1.0) + ! Liquid + QLLS = QLLS + (QL - (QLCN+QLLS)) + WHERE (QLLS < 0.0) + QLCN = max(0.0,QLCN + QLLS) + QLLS = 0.0 + END WHERE + + ! Ice + QILS = QILS + (QI - (QICN+QILS)) + WHERE (QILS < 0.0) + QICN = max(0.0,QICN + QILS) + QILS = 0.0 END WHERE - ! put all new condensate into LS - DQC = QL - (QLCN+QLLS) - WHERE (DQC > 0.0) - QLLS = QLLS+DQC - DQC = 0.0 - END WHERE - ! any loss of condensate uses the FCN ratio - QLCN = QLCN + DQC*( FCN) - QLLS = QLLS + DQC*(1.0-FCN) - - ! Redistribute ice CN/LS portions based on prior fractions - ! FCN Needs to be calculated first - FCN = 0.0 - WHERE (QICN+QILS > 0.0) - FCN = min(max(QICN/(QICN+QILS), 0.0), 1.0) - END WHERE - ! put all new condensate into LS - DQC = QI - (QICN+QILS) - WHERE (DQC > 0.0) - QILS = QILS+DQC - DQC = 0.0 + + ! Cloud + CLLS = min(1.0,CLLS + (CF - (CLCN+CLLS))) + WHERE (CLLS < 0.0) + CLCN = max(0.0,min(1.0,CLCN + CLLS)) + CLLS = 0.0 END WHERE - ! any loss of condensate uses the FCN ratio - QICN = QICN + DQC*( FCN) - QILS = QILS + DQC*(1.0-FCN) - - ! Redistribute cloud-fraction CN/LS portions based on prior fractions - ! FCN Needs to be calculated first - FCN = 0.0 - WHERE (CLCN+CLLS > 0.0) - FCN = min(max(CLCN/(CLCN+CLLS), 0.0), 1.0) + + ! Evaporate/Sublimate liquid/ice where clouds are gone + WHERE ( (CLLS == 0.0) .AND. (QLLS+QILS > 0.0) ) + QV = QV + QLLS + QILS + TE = TE - (alhlbcp)*QLLS - (alhsbcp)*QILS + CLLS = 0. + QLLS = 0. + QILS = 0. END WHERE - ! put all new condensate into LS - DQC = CF - (CLCN+CLLS) - WHERE (DQC > 0.0) - CLLS = CLLS+DQC - DQC = 0.0 + WHERE ( (CLCN == 0.0) .AND. (QLCN+QICN > 0.0) ) + QV = QV + QLCN + QICN + TE = TE - (alhlbcp)*QLCN - (alhsbcp)*QICN + CLCN = 0. + QLCN = 0. + QICN = 0. END WHERE - ! any loss of condensate uses the FCN ratio - CLCN = CLCN + DQC*( FCN) - CLLS = CLLS + DQC*(1.0-FCN) end subroutine REDISTRIBUTE_CLOUDS @@ -3586,8 +3610,6 @@ subroutine cs_interpolator(is, ie, js, je, km, qin, zout, wz, qout, qmin) real:: s0, a6 integer:: i,j,k -!$OMP parallel do default(none) shared(qmin,is,ie,js,je,km,zout,qin,qout,wz) & -!$OMP private(s0,a6,q2,dz,qe) do j=js,je do i=is,ie @@ -3705,6 +3727,587 @@ subroutine cs_prof(q2, delp, q, km, i1, i2, iv) end subroutine cs_prof + integer function FIND_KLID (plid, ple, rc) RESULT(klid) + +! !USES: + implicit NONE + +! !INPUT PARAMETERS: + real, intent(in) :: plid ! pressure lid [hPa] + real, dimension(:,:,:), intent(in) :: ple ! air pressure [Pa] + +! !OUTPUT PARAMETERS: + integer, intent(out) :: rc ! return code; 0 - all is good +! 1 - bad + +! !DESCRIPTION: Finds corresponding vertical index for defined pressure lid +! +! !REVISION HISTORY: +! +! 25Aug2020 E.Sherman - Written +! +! !Local Variables + integer :: k, j, i + real :: plid_, diff, refDiff + real, allocatable, dimension(:) :: pres ! pressure at each model level [Pa] + +!EOP +!---------------------------------------------------------------------------------- +! Begin... + klid = 1 + rc = 0 + +! convert from hPa to Pa + plid_ = plid*100.0 + + allocate(pres(ubound(ple,3))) + +! find pressure at each model level + do k = 1, ubound(ple,3) + pres(k) = ple(1,1,k) + end do + +! find smallest absolute difference between plid and average pressure at each model level + refDiff = 150000.0 + do k = 1, ubound(ple,3) + diff = abs(pres(k) - plid_) + if (diff < refDiff) then + klid = k + refDiff = diff + end if + end do + +! Check to make sure that all pressures at (i,j) were the same + do j = 1, ubound(ple,2) + do i = 1, ubound(ple,1) + if (pres(klid) /= ple(i,j,klid)) then + rc = 1 + return + end if + end do + end do + + end function FIND_KLID + +! (C) Copr. 1986-92 Numerical Recipes Software 2.02 +!+---+-----------------------------------------------------------------+ + REAL FUNCTION WGAMMA(y) + IMPLICIT NONE + REAL, INTENT(IN):: y + WGAMMA = EXP(GAMMLN(y)) + END FUNCTION WGAMMA + +!! Returns the value ln(gamma(xx)) for xx > 0. + REAL FUNCTION GAMMLN(XX) +! --- RETURNS THE VALUE LN(GAMMA(XX)) FOR XX > 0. + IMPLICIT NONE + REAL, INTENT(IN):: XX + DOUBLE PRECISION, PARAMETER:: STP = 2.5066282746310005D0 + DOUBLE PRECISION, DIMENSION(6), PARAMETER:: & + COF = (/76.18009172947146D0, -86.50532032941677D0, & + 24.01409824083091D0, -1.231739572450155D0, & + .1208650973866179D-2, -.5395239384953D-5/) + DOUBLE PRECISION:: SER,TMP,X,Y + INTEGER:: J + X=XX + Y=X + TMP=X+5.5D0 + TMP=(X+0.5D0)*LOG(TMP)-TMP + SER=1.000000000190015D0 + DO 11 J=1,6 + Y=Y+1.D0 + SER=SER+COF(J)/Y +11 CONTINUE + GAMMLN=TMP+LOG(STP*SER/X) + END FUNCTION GAMMLN +! (C) Copr. 1986-92 Numerical Recipes Software 2.02 + + subroutine init_refl10cm () + + USE module_mp_radar + + IMPLICIT NONE + + integer :: n + + cre(1) = bm_r + 1. + cre(2) = mu_r + 1. + cre(3) = bm_r + mu_r + 1. + cre(4) = bm_r*2. + mu_r + 1. + cre(5) = mu_r + bv_r + 1. + cre(6) = bm_r + mu_r + bv_r + 1. + cre(7) = bm_r*0.5 + mu_r + bv_r + 1. + cre(8) = bm_r + mu_r + bv_r + 3. + cre(9) = mu_r + bv_r + 3. + cre(10) = mu_r + 2. + cre(11) = 0.5*(bv_r + 5. + 2.*mu_r) + cre(12) = bm_r*0.5 + mu_r + 1. + cre(13) = bm_r*2. + mu_r + bv_r + 1. + do n = 1, 13 + crg(n) = WGAMMA(cre(n)) + enddo + obmr = 1./bm_r + ore1 = 1./cre(1) + org1 = 1./crg(1) + org2 = 1./crg(2) + org3 = 1./crg(3) + + cse(1) = bm_s + 1. + cse(2) = bm_s + 2. + cse(3) = bm_s*2. + cse(4) = bm_s + bv_s + 1. + cse(5) = bm_s*2. + bv_s + 1. + cse(6) = bm_s*2. + 1. + cse(7) = bm_s + mu_s + 1. + cse(8) = bm_s + mu_s + 2. + cse(9) = bm_s + mu_s + 3. + cse(10) = bm_s + mu_s + bv_s + 1. + cse(11) = bm_s*2. + mu_s + bv_s + 1. + cse(12) = bm_s*2. + mu_s + 1. + cse(13) = bv_s + 2. + cse(14) = bm_s + bv_s + cse(15) = mu_s + 1. + cse(16) = 1.0 + (1.0 + bv_s)/2. + cse(17) = cse(16) + mu_s + 1. + cse(18) = bv_s + mu_s + 3. + do n = 1, 18 + csg(n) = WGAMMA(cse(n)) + enddo + oams = 1./am_s + obms = 1./bm_s + ocms = oams**obms + + cge(1) = bm_g + 1. + cge(2) = mu_g + 1. + cge(3) = bm_g + mu_g + 1. + cge(4) = bm_g*2. + mu_g + 1. + cge(5) = bm_g*2. + mu_g + bv_g + 1. + cge(6) = bm_g + mu_g + bv_g + 1. + cge(7) = bm_g + mu_g + bv_g + 2. + cge(8) = bm_g + mu_g + bv_g + 3. + cge(9) = mu_g + bv_g + 3. + cge(10) = mu_g + 2. + cge(11) = 0.5*(bv_g + 5. + 2.*mu_g) + cge(12) = 0.5*(bv_g + 5.) + mu_g + do n = 1, 12 + cgg(n) = WGAMMA(cge(n)) + enddo + oamg = 1./am_g + obmg = 1./bm_g + ocmg = oamg**obmg + oge1 = 1./cge(1) + ogg1 = 1./cgg(1) + ogg2 = 1./cgg(2) + ogg3 = 1./cgg(3) + + r2o7 = 2./7. + lam_r000 = am_g*cgg(1) + lam_r001 = (cgg(3)*ogg2*ogg1)**obmg + +!> - Call radar_init() to initialize various constants for computing radar reflectivity + xam_r = am_r + xbm_r = bm_r + xmu_r = mu_r + xam_s = am_s + xbm_s = bm_s + xmu_s = mu_s + xam_g = am_g + xbm_g = bm_g + xmu_g = mu_g + call radar_init + + sa3_cse1 = sa(3)*cse(1) + sa4_cse1 = sa(4)*cse(1) + sa6_cse1 = sa(6)*cse(1)*cse(1) + sa7_cse1 = sa(7)*cse(1) + sa8_cse1 = sa(8)*cse(1)*cse(1) + sa10_cse1 = sa(10)*cse(1)*cse(1)*cse(1) + + sb3_cse1 = sb(3)*cse(1) + sb4_cse1 = sb(4)*cse(1) + sb6_cse1 = sb(6)*cse(1)*cse(1) + sb7_cse1 = sb(7)*cse(1) + sb8_cse1 = sb(8)*cse(1)*cse(1) + sb10_cse1 = sb(10)*cse(1)*cse(1)*cse(1) + + sa3_cse3 = sa(3)*cse(3) + sa4_cse3 = sa(4)*cse(3) + sa6_cse3 = sa(6)*cse(3)*cse(3) + sa7_cse3 = sa(7)*cse(3) + sa8_cse3 = sa(8)*cse(3)*cse(3) + sa10_cse3 = sa(10)*cse(3)*cse(3)*cse(3) + + sb3_cse3 = sb(3)*cse(3) + sb4_cse3 = sb(4)*cse(3) + sb6_cse3 = sb(6)*cse(3)*cse(3) + sb7_cse3 = sb(7)*cse(3) + sb8_cse3 = sb(8)*cse(3)*cse(3) + sb10_cse3 = sb(10)*cse(3)*cse(3)*cse(3) + + end subroutine init_refl10cm + +!+---+-----------------------------------------------------------------+ +!>\ingroup aathompson +!! Compute radar reflectivity assuming 10 cm wavelength radar and using +!! Rayleigh approximation. Only complication is melted snow/graupel +!! which we treat as water-coated ice spheres and use Uli Blahak's +!! library of routines. The meltwater fraction is simply the amount +!! of frozen species remaining from what initially existed at the +!! melting level interface. + + subroutine calc_refl10cm (qv1d, qr1d, nr1d, qs1d, qg1d, & + t1d, p1d, dBZ, rand1, kts, kte, ii, jj, & + vt_dBZ, first_time_step, ktopin, kbotin) + + USE module_mp_radar + + IMPLICIT NONE + +!..Sub arguments + INTEGER, INTENT(IN):: kts, kte, ii, jj + REAL, INTENT(IN):: rand1 + REAL, DIMENSION(kts:kte), INTENT(IN):: & + qv1d, qr1d, nr1d, qs1d, qg1d, t1d, p1d + REAL, DIMENSION(kts:kte), INTENT(INOUT):: dBZ + REAL, DIMENSION(kts:kte), OPTIONAL, INTENT(INOUT):: vt_dBZ + LOGICAL, OPTIONAL, INTENT(IN) :: first_time_step + INTEGER, OPTIONAL, INTENT(IN) :: ktopin, kbotin + +!..Local variables + LOGICAL :: do_vt_dBZ + REAL, DIMENSION(kts:kte):: temp, pres, qv, rho, rhof + REAL, DIMENSION(kts:kte):: rr, nr, rs, rg + + DOUBLE PRECISION, DIMENSION(kts:kte):: ilamr, ilamg, N0_r, N0_g + REAL, DIMENSION(kts:kte):: mvd_r + REAL, DIMENSION(kts:kte):: smob, smo2, smoc, smoz + REAL:: oM3, M0, Mrat, slam1, slam2, xDs + REAL:: ils1, ils2, t1_vts, t2_vts, t3_vts, t4_vts + REAL:: vtr_dbz_wt, vts_dbz_wt, vtg_dbz_wt + + REAL, DIMENSION(kts:kte):: ze_rain, ze_snow, ze_graupel + + DOUBLE PRECISION:: N0_exp, N0_min, lam_exp, lamr, lamg + REAL:: a_, b_, loga_, tc0, tc0_2, tc0_3, sa1259, sb1259, SR + DOUBLE PRECISION:: fmelt_s, fmelt_g + + INTEGER:: i, k, k_0, ktop, kbot, kdwn, n + LOGICAL:: melti + REAL:: frland + LOGICAL, DIMENSION(kts:kte):: L_qr, L_qs, L_qg + + DOUBLE PRECISION:: cback, x, eta, f_d + REAL:: xslw1, ygra1, zans1 + + REAL, PARAMETER:: R = MAPL_RGAS + REAL, PARAMETER:: PI = MAPL_PI + REAL, PARAMETER:: R1 = 1.E-12 + REAL, PARAMETER:: R2 = 1.E-6 + + LOGICAL:: allow_wet_snow + LOGICAL:: allow_wet_graupel + +!+---+ + if (present(ktopin) .and. present(kbotin)) then + ktop=ktopin + kbot=kbotin + if (ktop < kbot) then + kdwn= 1 + else + kdwn=-1 + endif + else + ktop=kte + kbot=kts + kdwn=-1 + endif + + if (present(vt_dBZ) .and. present(first_time_step)) then + do_vt_dBZ = .true. + if (first_time_step) then +! no bright banding, to be consistent with hydrometeor retrieval in GSI + allow_wet_snow = .false. + else + allow_wet_snow = refl10cm_allow_wet_snow + endif + allow_wet_graupel = refl10cm_allow_wet_graupel + else + do_vt_dBZ = .false. + allow_wet_snow = refl10cm_allow_wet_snow + allow_wet_graupel = refl10cm_allow_wet_graupel + endif + melti = (allow_wet_snow .or. allow_wet_graupel) + + do k = kts, kte + dBZ(k) = -35.0 + enddo + +!+---+-----------------------------------------------------------------+ +!..Put column of data into local arrays. +!+---+-----------------------------------------------------------------+ + do k = kts, kte + temp(k) = t1d(k) + qv(k) = MAX(1.E-10, qv1d(k)) + pres(k) = p1d(k) + rho(k) = 0.622*pres(k)/(R*temp(k)*(qv(k)+0.622)) + rhof(k) = SQRT(RHO_NOT/rho(k)) + if (qr1d(k) .gt. R2) then + rr(k) = qr1d(k)*rho(k) + nr(k) = MAX(R2, nr1d(k)*rho(k)) + lamr = (am_r*crg(3)*org2*nr(k)/rr(k))**obmr + ilamr(k) = 1./lamr + N0_r(k) = nr(k)*org2*lamr**cre(2) + mvd_r(k) = (3.0 + mu_r + 0.672) * ilamr(k) + L_qr(k) = .true. + else + rr(k) = R1 + nr(k) = R1 + mvd_r(k) = 50.E-6 + L_qr(k) = .false. + endif + if (qs1d(k) .gt. R2) then + rs(k) = qs1d(k)*rho(k) + L_qs(k) = .true. + else + rs(k) = R1 + L_qs(k) = .false. + endif + if (qg1d(k) .gt. R2) then + rg(k) = qg1d(k)*rho(k) + L_qg(k) = .true. + else + rg(k) = R1 + L_qg(k) = .false. + endif + enddo + +!+---+-----------------------------------------------------------------+ +!..Calculate y-intercept, slope, and useful moments for snow. +!+---+-----------------------------------------------------------------+ + do k = kts, kte + smo2(k) = 0. + smob(k) = 0. + smoc(k) = 0. + smoz(k) = 0. + enddo + if (ANY(L_qs .eqv. .true.)) then + do k = kts, kte + if (.not. L_qs(k)) CYCLE + tc0 = MIN(-0.1, temp(k)-273.15) + tc0_2 = tc0*tc0 + tc0_3 = tc0*tc0_2 + smob(k) = rs(k)*oams + + sa1259 = sa(1) + sa(2)*tc0 + sa(5)*tc0_2 + sa(9)*tc0_3 + sb1259 = sb(1) + sb(2)*tc0 + sb(5)*tc0_2 + sb(9)*tc0_3 + +!..All other moments based on reference, 2nd moment. If bm_s.ne.2, +!.. then we must compute actual 2nd moment and use as reference. + if (bm_s.gt.(2.0-1.e-3) .and. bm_s.lt.(2.0+1.e-3)) then + smo2(k) = smob(k) + else + loga_ = sa1259 + sa3_bm_s & + & + sa4_bm_s*tc0 & + & + sa6_bm_s + sa7_bm_s*tc0_2 & + & + sa8_bm_s*tc0 & + & + sa10_bm_s + a_ = 10.0**loga_ + b_ = sb1259 + sb3_bm_s & + & + sb4_bm_s*tc0 & + & + sb6_bm_s + sb7_bm_s*tc0_2 & + & + sb8_bm_s*tc0 & + & + sb10_bm_s + smo2(k) = (smob(k)/a_)**(1./b_) + endif + +!..Calculate bm_s+1 (th) moment. Useful for diameter calcs. + loga_ = sa1259 + sa3_cse1 & + & + sa4_cse1*tc0 & + & + sa6_cse1 + sa7_cse1*tc0_2 & + & + sa8_cse1*tc0 & + & + sa10_cse1 + a_ = 10.0**loga_ + b_ = sb1259 + sb3_cse1 & + & + sb4_cse1*tc0 & + & + sb6_cse1 + sb7_cse1*tc0_2 & + & + sb8_cse1*tc0 & + & + sb10_cse1 + smoc(k) = a_ * smo2(k)**b_ + +!..Calculate bm_s*2 (th) moment. Useful for reflectivity. + loga_ = sa1259 + sa3_cse3 & + & + sa4_cse3*tc0 & + & + sa6_cse3 + sa7_cse3*tc0_2 & + & + sa8_cse3*tc0 & + & + sa10_cse3 + a_ = 10.0**loga_ + b_ = sb1259 + sb3_cse3 & + & + sb4_cse3*tc0 & + & + sb6_cse3 + sb7_cse3*tc0_2 & + & + sb8_cse3*tc0 & + & + sb10_cse3 + smoz(k) = a_ * smo2(k)**b_ + + enddo + endif + +!+---+-----------------------------------------------------------------+ +!..Calculate y-intercept, slope values for graupel. +!+---+-----------------------------------------------------------------+ + + if (ANY(L_qg .eqv. .true.)) then + do k = ktop, kbot, kdwn + ygra1 = alog10(max(1.E-9, rg(k))) + zans1 = 3.4 + r2o7*(ygra1+8.) + rand1 + N0_exp = 10.**(zans1) + N0_exp = MAX(DBLE(gonv_min), MIN(N0_exp, DBLE(gonv_max))) + lam_exp = (N0_exp*lam_r000/rg(k))**oge1 + lamg = lam_exp * lam_r001 + ilamg(k) = 1./lamg + N0_g(k) = N0_exp/(cgg(2)*lam_exp) * lamg**cge(2) + enddo + endif + +!+---+-----------------------------------------------------------------+ +!..Locate K-level of start of melting (k_0 is level above). +!+---+-----------------------------------------------------------------+ + k_0 = kbot + if ( melti ) then + K_LOOP:do k = ktop+kdwn, kbot, kdwn + if ((temp(k).gt.273.15) .and. L_qr(k) & + & .and. (L_qs(k-kdwn).or.L_qg(k-kdwn)) ) then + if (kdwn < 0) then + k_0 = MAX(k-kdwn, k_0) + else + k_0 = MIN(k-kdwn, k_0) + endif + EXIT K_LOOP + endif + enddo K_LOOP + endif +!+---+-----------------------------------------------------------------+ +!..Assume Rayleigh approximation at 10 cm wavelength. Rain (all temps) +!.. and non-water-coated snow and graupel when below freezing are +!.. simple. Integrations of m(D)*m(D)*N(D)*dD. +!+---+-----------------------------------------------------------------+ + + do k = kts, kte + ze_rain(k) = 1.e-22 + ze_snow(k) = 1.e-22 + ze_graupel(k) = 1.e-22 + if (L_qr(k)) ze_rain(k) = N0_r(k)*crg(4)*ilamr(k)**cre(4) + if (L_qs(k)) ze_snow(k) = am_s_r001*smoz(k) + if (L_qg(k)) ze_graupel(k) = am_g_r001 * & + & N0_g(k)*cgg(4)*ilamg(k)**cge(4) + enddo + +!+---+-----------------------------------------------------------------+ +!..Special case of melting ice (snow/graupel) particles. Assume the +!.. ice is surrounded by the liquid water. Fraction of meltwater is +!.. extremely simple based on amount found above the melting level. +!.. Uses code from Uli Blahak (rayleigh_soak_wetgraupel and supporting +!.. routines). +!+---+-----------------------------------------------------------------+ + + if (.not. iiwarm .and. melti .and. k_0.ge.2) then + do k = k_0+kdwn, kbot, kdwn + +!..Reflectivity contributed by melting snow + if (allow_wet_snow .and. L_qs(k) .and. L_qs(k_0) ) then + SR = MAX(0.01, MIN(1.0 - rs(k)/(rs(k) + rr(k)), 0.99)) + fmelt_s = DBLE(SR*SR) + eta = 0.d0 + oM3 = 1./smoc(k) + M0 = (smob(k)*oM3) + Mrat = smob(k)*M0*M0*M0 + slam1 = M0 * Lam0 + slam2 = M0 * Lam1 + do n = 1, nrbins + x = am_s * xxDs(n)**bm_s + call rayleigh_soak_wetgraupel (x, DBLE(ocms), DBLE(obms), & + & fmelt_s, melt_outside_s, m_w_0, m_i_0, lamda_radar, & + & CBACK, mixingrulestring_s, matrixstring_s, & + & inclusionstring_s, hoststring_s, & + & hostmatrixstring_s, hostinclusionstring_s) + f_d = Mrat*(Kap0*DEXP(-slam1*xxDs(n)) & + & + Kap1*(M0*xxDs(n))**mu_s * DEXP(-slam2*xxDs(n))) + eta = eta + f_d * CBACK * simpson(n) * xdts(n) + enddo + ze_snow(k) = SNGL(lamda4 / (pi5 * K_w) * eta) + endif + +!..Reflectivity contributed by melting graupel + if (allow_wet_graupel .and. L_qg(k) .and. L_qg(k_0) ) then + SR = MAX(0.01, MIN(1.0 - rg(k)/(rg(k) + rr(k)), 0.99)) + fmelt_g = DBLE(SR*SR) + eta = 0.d0 + lamg = 1./ilamg(k) + do n = 1, nrbins + x = am_g * xxDg(n)**bm_g + call rayleigh_soak_wetgraupel (x, DBLE(ocmg), DBLE(obmg), & + & fmelt_g, melt_outside_g, m_w_0, m_i_0, lamda_radar, & + & CBACK, mixingrulestring_g, matrixstring_g, & + & inclusionstring_g, hoststring_g, & + & hostmatrixstring_g, hostinclusionstring_g) + f_d = N0_g(k)*xxDg(n)**mu_g * DEXP(-lamg*xxDg(n)) + eta = eta + f_d * CBACK * simpson(n) * xdtg(n) + enddo + ze_graupel(k) = SNGL(lamda4 / (pi5 * K_w) * eta) + endif + + enddo + endif + + do k = ktop, kbot, kdwn + dBZ(k) = 10.*log10((ze_rain(k)+ze_snow(k)+ze_graupel(k))*1.d18) + enddo + +!..Reflectivity-weighted terminal velocity (snow, rain, graupel, mix). + if (do_vt_dBZ) then + do k = ktop, kbot, kdwn + vt_dBZ(k) = 1.E-3 + if (rs(k).gt.R2) then + Mrat = smob(k) / smoc(k) + ils1 = 1./(Mrat*Lam0 + fv_s) + ils2 = 1./(Mrat*Lam1 + fv_s) + t1_vts = Kap0*csg(5)*ils1**cse(5) + t2_vts = Kap1*Mrat**mu_s*csg(11)*ils2**cse(11) + ils1 = 1./(Mrat*Lam0) + ils2 = 1./(Mrat*Lam1) + t3_vts = Kap0*csg(6)*ils1**cse(6) + t4_vts = Kap1*Mrat**mu_s*csg(12)*ils2**cse(12) + vts_dbz_wt = rhof(k)*av_s * (t1_vts+t2_vts)/(t3_vts+t4_vts) + if (temp(k).ge.273.15 .and. temp(k).lt.275.15) then + vts_dbz_wt = vts_dbz_wt*1.5 + elseif (temp(k).ge.275.15) then + vts_dbz_wt = vts_dbz_wt*2.0 + endif + else + vts_dbz_wt = 1.E-3 + endif + + if (rr(k).gt.R1) then + lamr = 1./ilamr(k) + vtr_dbz_wt = rhof(k)*av_r*crg(13)*(lamr+fv_r)**(-cre(13)) & + / (crg(4)*lamr**(-cre(4))) + else + vtr_dbz_wt = 1.E-3 + endif + + if (rg(k).gt.R2) then + lamg = 1./ilamg(k) + vtg_dbz_wt = rhof(k)*av_g*cgg(5)*lamg**(-cge(5)) & + / (cgg(4)*lamg**(-cge(4))) + else + vtg_dbz_wt = 1.E-3 + endif + + vt_dBZ(k) = (vts_dbz_wt*ze_snow(k) + vtr_dbz_wt*ze_rain(k) & + + vtg_dbz_wt*ze_graupel(k)) & + / (ze_rain(k)+ze_snow(k)+ze_graupel(k)) + enddo + endif + end subroutine calc_refl10cm end module GEOSmoist_Process_Library diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/WSUB_ExtData.yaml b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/WSUB_ExtData.yaml index f7a53106c..90112086f 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/WSUB_ExtData.yaml +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/WSUB_ExtData.yaml @@ -1,7 +1,7 @@ Collections: WSUB_SWclim_2005%m2.nc4: template: /discover/nobackup/dbarahon/DEV/SWclim/L72/SWclim_2005%m2.nc4 - valid_range: "2005-01-01/2005-12-01" + valid_range: "2005-01-01/2005-12-31" Samplings: WSUB_sample_0: diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/aer_actv_single_moment.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/aer_actv_single_moment.F90 index 2fbe3b778..0d14192f7 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/aer_actv_single_moment.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/aer_actv_single_moment.F90 @@ -1,693 +1,585 @@ MODULE Aer_Actv_Single_Moment -! + ! #include "MAPL_Generic.h" - USE ESMF - USE MAPL - USE aer_cloud, only: AerProps -!------------------------------------------------------------------------------------------------------------------------- - IMPLICIT NONE - PUBLIC :: Aer_Activation, USE_BERGERON, USE_AEROSOL_NN, R_AIR - PRIVATE - - ! Real kind for activation. - integer,public,parameter :: AER_R4 = SELECTED_REAL_KIND(6,37) - integer,public,parameter :: AER_R8 = SELECTED_REAL_KIND(15,307) - integer,public,parameter :: AER_PR = AER_R8 - - real , parameter :: R_AIR = 3.47e-3 !m3 Pa kg-1K-1 - real(AER_PR), parameter :: zero_par = 1.e-6 ! small non-zero value - real(AER_PR), parameter :: ai = 0.0000594 - real(AER_PR), parameter :: bi = 3.33 - real(AER_PR), parameter :: ci = 0.0264 - real(AER_PR), parameter :: di = 0.0033 - - real(AER_PR), parameter :: betai = -2.262e+3 - real(AER_PR), parameter :: gamai = 5.113e+6 - real(AER_PR), parameter :: deltai = 2.809e+3 - real(AER_PR), parameter :: densic = 917.0 !Ice crystal density in kgm-3 - - real, parameter :: NN_MIN = 100.0e6 - real, parameter :: NN_MAX = 1000.0e6 - - LOGICAL :: USE_BERGERON, USE_AEROSOL_NN - CONTAINS - -!>---------------------------------------------------------------------------------------------------------------------- -!>---------------------------------------------------------------------------------------------------------------------- - - SUBROUTINE Aer_Activation(IM,JM,LM, q, t, plo, ple, zlo, zle, qlcn, qicn, qlls, qils, & - sh, evap, kpbl, tke, vvel, FRLAND, USE_AERO_BUFFER, & - AeroProps, aero_aci, NACTL, NACTI, NWFA, NN_LAND, NN_OCEAN) + USE ESMF + USE MAPL + USE aer_cloud, only: AerPropsNew + !------------------------------------------------------------------------------------------------------------------------- + IMPLICIT NONE + PUBLIC :: Aer_Activation, USE_BERGERON, USE_AEROSOL_NN, R_AIR + PRIVATE + + ! Real kind for activation. + integer,public,parameter :: AER_PR = MAPL_R4 + + real , parameter :: R_AIR = 3.47e-3 !m3 Pa kg-1K-1 + real(AER_PR), parameter :: ai = 0.0000594 + real(AER_PR), parameter :: bi = 3.33 + real(AER_PR), parameter :: ci = 0.0264 + real(AER_PR), parameter :: di = 0.0033 + + real(AER_PR), parameter :: betai = -2.262e+3 + real(AER_PR), parameter :: gamai = 5.113e+6 + real(AER_PR), parameter :: deltai = 2.809e+3 + real(AER_PR), parameter :: densic = 917.0 !Ice crystal density in kgm-3 + + real, parameter :: NN_MIN = 100.0e6 + real, parameter :: NN_MAX = 500.0e6 + + LOGICAL :: USE_BERGERON = .TRUE. + LOGICAL :: USE_AEROSOL_NN = .TRUE. +CONTAINS + + !>---------------------------------------------------------------------------------------------------------------------- + !>---------------------------------------------------------------------------------------------------------------------- + + SUBROUTINE Aer_Activation(MAPL, IM,JM,LM, q, t, plo, ple, tke, vvel, FRLAND, & + AeroPropsNew, aero_aci, NACTL, NACTI, NWFA, & + NN_LAND, NN_OCEAN, need_extra_fields, rc) IMPLICIT NONE + type (MAPL_MetaComp), pointer :: MAPL integer, intent(in)::IM,JM,LM - TYPE(AerProps), dimension (IM,JM,LM),intent(inout) :: AeroProps + TYPE(AerPropsNew), dimension (:), intent(inout) :: AeroPropsNew type(ESMF_State) ,intent(inout) :: aero_aci real, dimension (IM,JM,LM) ,intent(in ) :: plo ! Pa real, dimension (IM,JM,0:LM),intent(in ) :: ple ! Pa - real, dimension (IM,JM,LM) ,intent(in ) :: q,t,tke,vvel,zlo, qlcn, qicn, qlls, qils - real, dimension (IM,JM,0:LM),intent(in ) :: zle + real, dimension (IM,JM,LM) ,intent(in ) :: q,t,tke,vvel real, dimension (IM,JM) ,intent(in ) :: FRLAND - real, dimension (IM,JM) ,intent(in ) :: sh, evap, kpbl - real ,intent(in ) :: NN_LAND, NN_OCEAN - logical ,intent(in ) :: USE_AERO_BUFFER - - - real, dimension (IM,JM,LM),intent(OUT) :: NACTL,NACTI, NWFA - - real(AER_PR), allocatable, dimension (:) :: sig0,rg,ni,bibar,nact - real(AER_PR), dimension (IM,JM,LM) :: zws - real(AER_PR) :: wupdraft,tk,press,air_den,QI,QL,WC,BB,RAUX - - integer, dimension (IM,JM) :: kpbli - - real, dimension(:,:,:,:,:), allocatable :: buffer - - character(len=ESMF_MAXSTR) :: aci_field_name + real ,intent(in ) :: NN_LAND, NN_OCEAN + logical ,intent(in ) :: need_extra_fields + integer, optional ,intent(out) :: rc + + real, dimension (IM,JM,LM),intent(OUT) :: NACTL, NACTI, NWFA + + real(AER_PR), allocatable, dimension (:,:,:) :: sig0,rg,ni,bibar,nact + real(AER_PR), dimension(IM,JM) :: wupdraft,tk,press,air_den + + integer, parameter :: ALT_MAXSTR=64 + character(len=ALT_MAXSTR) :: aci_field_name real, pointer, dimension(:,:) :: aci_ptr_2d real, pointer, dimension(:,:,:) :: aci_ptr_3d - real, pointer, dimension(:,:,:) :: aci_num - real, pointer, dimension(:,:,:) :: aci_dgn - real, pointer, dimension(:,:,:) :: aci_sigma - real, pointer, dimension(:,:,:) :: aci_density - real, pointer, dimension(:,:,:) :: aci_hygroscopicity - real, pointer, dimension(:,:,:) :: aci_f_dust - real, pointer, dimension(:,:,:) :: aci_f_soot - real, pointer, dimension(:,:,:) :: aci_f_organic - character(len=ESMF_MAXSTR), allocatable, dimension(:) :: aero_aci_modes + character(len=ALT_MAXSTR), allocatable, dimension(:) :: aero_aci_modes integer :: ACI_STATUS - REAL :: aux1,aux2,aux3,hfs,hfl, nfaux integer :: n_modes - REAL :: numbinit - integer :: i,j,k,n,rc + REAL :: numbinit(IM,JM) + integer :: i,j,k,n + integer :: nn character(len=ESMF_MAXSTR) :: IAm="Aer_Activation" integer :: STATUS - do k = 1, LM - do j = 1, JM - do i = 1, IM - AeroProps(i,j,k)%num = 0.0 - end do - end do - end do + NWFA = 0.0 - kpbli = MAX(MIN(NINT(kpbl),LM-1),1) - - if (USE_AEROSOL_NN) then - - call ESMF_AttributeGet(aero_aci, name='number_of_aerosol_modes', value=n_modes, __RC__) - - if (n_modes > 0) then - - allocate( sig0(n_modes), __STAT__) - allocate( rg(n_modes), __STAT__) - allocate( ni(n_modes), __STAT__) - allocate(bibar(n_modes), __STAT__) - allocate( nact(n_modes), __STAT__) - - allocate(aero_aci_modes(n_modes), __STAT__) - call ESMF_AttributeGet(aero_aci, name='aerosol_modes', itemcount=n_modes, valuelist=aero_aci_modes, __RC__) - - call ESMF_AttributeGet(aero_aci, name='air_pressure_for_aerosol_optics', value=aci_field_name, __RC__) - if (aci_field_name /= '') then - call MAPL_GetPointer(aero_aci, aci_ptr_3d, trim(aci_field_name), __RC__) - aci_ptr_3d = PLE - end if - - call ESMF_AttributeGet(aero_aci, name='air_temperature', value=aci_field_name, __RC__) - if (aci_field_name /= '') then - call MAPL_GetPointer(aero_aci, aci_ptr_3d, trim(aci_field_name), __RC__) - aci_ptr_3d = T - end if - - call ESMF_AttributeGet(aero_aci, name='fraction_of_land_type', value=aci_field_name, __RC__) - if (aci_field_name /= '') then - call MAPL_GetPointer(aero_aci, aci_ptr_2d, trim(aci_field_name), __RC__) - aci_ptr_2d = FRLAND - end if - - if (USE_AERO_BUFFER) then - allocate(buffer(im,jm,lm,n_modes,8), __STAT__) - end if - - ACTIVATION_PROPERTIES: do n = 1, n_modes - call ESMF_AttributeSet(aero_aci, name='aerosol_mode', value=trim(aero_aci_modes(n)), __RC__) - - ! execute the aerosol activation properties method - call ESMF_MethodExecute(aero_aci, label='aerosol_activation_properties', userRC=ACI_STATUS, RC=STATUS) - VERIFY_(ACI_STATUS) - VERIFY_(STATUS) - - ! copy out aerosol activation properties - call ESMF_AttributeGet(aero_aci, name='aerosol_number_concentration', value=aci_field_name, __RC__) - call MAPL_GetPointer(aero_aci, aci_num, trim(aci_field_name), __RC__) - - call ESMF_AttributeGet(aero_aci, name='aerosol_dry_size', value=aci_field_name, __RC__) - call MAPL_GetPointer(aero_aci, aci_dgn, trim(aci_field_name), __RC__) - - call ESMF_AttributeGet(aero_aci, name='width_of_aerosol_mode', value=aci_field_name, __RC__) - call MAPL_GetPointer(aero_aci, aci_sigma, trim(aci_field_name), __RC__) - - call ESMF_AttributeGet(aero_aci, name='aerosol_density', value=aci_field_name, __RC__) - call MAPL_GetPointer(aero_aci, aci_density, trim(aci_field_name), __RC__) - - call ESMF_AttributeGet(aero_aci, name='aerosol_hygroscopicity', value=aci_field_name, __RC__) - call MAPL_GetPointer(aero_aci, aci_hygroscopicity, trim(aci_field_name), __RC__) - - call ESMF_AttributeGet(aero_aci, name='fraction_of_dust_aerosol', value=aci_field_name, __RC__) - call MAPL_GetPointer(aero_aci, aci_f_dust, trim(aci_field_name), __RC__) - - call ESMF_AttributeGet(aero_aci, name='fraction_of_soot_aerosol', value=aci_field_name, __RC__) - call MAPL_GetPointer(aero_aci, aci_f_soot, trim(aci_field_name), __RC__) - - call ESMF_AttributeGet(aero_aci, name='fraction_of_organic_aerosol', value=aci_field_name, __RC__) - call MAPL_GetPointer(aero_aci, aci_f_organic, trim(aci_field_name), __RC__) - - if (USE_AERO_BUFFER) then - buffer(:,:,:,n,1) = aci_num - buffer(:,:,:,n,2) = aci_dgn - buffer(:,:,:,n,3) = aci_sigma - buffer(:,:,:,n,4) = aci_hygroscopicity - buffer(:,:,:,n,5) = aci_density - buffer(:,:,:,n,6) = aci_f_dust - buffer(:,:,:,n,7) = aci_f_soot - buffer(:,:,:,n,8) = aci_f_organic - else - AeroProps(:,:,:)%num(n) = aci_num - AeroProps(:,:,:)%dpg(n) = aci_dgn - AeroProps(:,:,:)%sig(n) = aci_sigma - AeroProps(:,:,:)%kap(n) = aci_hygroscopicity - AeroProps(:,:,:)%den(n) = aci_density - AeroProps(:,:,:)%fdust(n) = aci_f_dust - AeroProps(:,:,:)%fsoot(n) = aci_f_soot - AeroProps(:,:,:)%forg(n) = aci_f_organic - AeroProps(:,:,:)%nmods = n_modes ! no need of a 3D field: aero provider specific - end if - - end do ACTIVATION_PROPERTIES - - if (USE_AERO_BUFFER) then - do k = 1, LM - do j = 1, JM - do i = 1, IM - do n = 1, n_modes - AeroProps(i,j,k)%num(n) = buffer(i,j,k,n,1) - AeroProps(i,j,k)%dpg(n) = buffer(i,j,k,n,2) - AeroProps(i,j,k)%sig(n) = buffer(i,j,k,n,3) - AeroProps(i,j,k)%kap(n) = buffer(i,j,k,n,4) - AeroProps(i,j,k)%den(n) = buffer(i,j,k,n,5) - AeroProps(i,j,k)%fdust(n) = buffer(i,j,k,n,6) - AeroProps(i,j,k)%fsoot(n) = buffer(i,j,k,n,7) - AeroProps(i,j,k)%forg(n) = buffer(i,j,k,n,8) - end do - AeroProps(i,j,k)%nmods = n_modes ! no need of a 3D field: aero provider specific - end do - end do - end do - - deallocate(buffer, __STAT__) - end if - - - do k = 1, LM - do j = 1, JM - do i = 1, IM - nfaux = 0.0 - do n = 1, n_modes - if (AeroProps(i,j,k)%kap(n) .gt. 0.4) then - nfaux = nfaux + AeroProps(i,j,k)%num(n) - end if - end do !modes - NWFA(I, J, K) = nfaux - end do - end do - end do - - - deallocate(aero_aci_modes, __STAT__) + if (.not. USE_AEROSOL_NN) then - !--- activated aerosol # concentration for liq/ice phases (units: m^-3) - numbinit = 0. - WC = 0. - BB = 0. - RAUX = 0. - - !--- determing aerosol number concentration at cloud base - DO j=1,JM - Do i=1,IM - k = kpbli(i,j) - tk = T(i,j,k) ! K - press = plo(i,j,k) ! Pa - air_den = press*28.8e-3/8.31/tk ! kg/m3 - ENDDO;ENDDO - - DO k=LM,1,-1 - NACTL(:,:,k) = NN_LAND*FRLAND + NN_OCEAN*(1.0-FRLAND) - NACTI(:,:,k) = NN_LAND*FRLAND + NN_OCEAN*(1.0-FRLAND) - DO j=1,JM - DO i=1,IM - - tk = T(i,j,k) ! K - press = plo(i,j,k) ! Pa - air_den = press*28.8e-3/8.31/tk ! kg/m3 - qi = (qicn(i,j,k)+qils(i,j,k))*1.e+3 ! g/kg - ql = (qlcn(i,j,k)+qlls(i,j,k))*1.e+3 ! g/kg - wupdraft = vvel(i,j,k) + SQRT(tke(i,j,k)) - - ! Liquid Clouds - IF( (tk >= MAPL_TICE-40.0) .and. (plo(i,j,k) > 10000.0) .and. & - (wupdraft > 0.1 .and. wupdraft < 100.) ) then - - ni (1:n_modes) = max(AeroProps(i,j,k)%num(1:n_modes)*air_den, zero_par) ! unit: [m-3] - rg (1:n_modes) = max(AeroProps(i,j,k)%dpg(1:n_modes)*0.5*1.e6, zero_par) ! unit: [um] - sig0 (1:n_modes) = AeroProps(i,j,k)%sig(1:n_modes) ! unit: [um] - bibar(1:n_modes) = max(AeroProps(i,j,k)%kap(1:n_modes), zero_par) - - call GetActFrac( n_modes & - , ni(1:n_modes) & - , rg(1:n_modes) & - , sig0(1:n_modes) & - , tk & - , press & - ,wupdraft & - , nact(1:n_modes) & - , bibar(1:n_modes) & - ) - - numbinit = 0. - NACTL(i,j,k) = 0. - DO n=1,n_modes - numbinit = numbinit + AeroProps(i,j,k)%num(n)*air_den - NACTL(i,j,k)= NACTL(i,j,k) + nact(n) !#/m3 - ENDDO - NACTL(i,j,k) = MIN(NACTL(i,j,k),0.99*numbinit) - - ENDIF ! Liquid Clouds - - ! Ice Clouds - IF( (tk <= MAPL_TICE) .and. ((QI > tiny(1.)) .or. (QL > tiny(1.))) ) then - numbinit = 0. - DO n=1,n_modes - if (AeroProps(i,j,k)%dpg(n) .ge. 0.5e-6) & ! diameters > 0.5 microns - numbinit = numbinit + AeroProps(i,j,k)%num(n) - ENDDO - numbinit = numbinit * air_den ! #/m3 - ! Number of activated IN following deMott (2010) [#/m3] - NACTI(i,j,k) = ai*((MAPL_TICE-tk)**bi) * numbinit**(ci*(MAPL_TICE-tk)+di) !#/m3 - ENDIF - - !-- apply limits for NACTL/NACTI - IF(NACTL(i,j,k) < NN_MIN) NACTL(i,j,k) = NN_MIN - IF(NACTL(i,j,k) > NN_MAX) NACTL(i,j,k) = NN_MAX - IF(NACTI(i,j,k) < NN_MIN) NACTI(i,j,k) = NN_MIN - IF(NACTI(i,j,k) > NN_MAX) NACTI(i,j,k) = NN_MAX - - ENDDO;ENDDO;ENDDO - - deallocate( rg, __STAT__) - deallocate( ni, __STAT__) - deallocate(bibar, __STAT__) - deallocate( nact, __STAT__) - - end if ! n_modes > 0 - - else ! USE_AEROSOL_NN - - do k = 1, LM - NACTL(:,:,k) = NN_LAND*FRLAND + NN_OCEAN*(1.0-FRLAND) - NACTI(:,:,k) = NN_LAND*FRLAND + NN_OCEAN*(1.0-FRLAND) - end do + do k = 1, LM + NACTL(:,:,k) = NN_LAND*FRLAND + NN_OCEAN*(1.0-FRLAND) + NACTI(:,:,k) = NN_LAND*FRLAND + NN_OCEAN*(1.0-FRLAND) + end do + RETURN_(ESMF_SUCCESS) end if - END SUBROUTINE Aer_Activation - -!>---------------------------------------------------------------------------------------------------------------------- -!! 12-12-06, DLW: Routine to set up the call to subr. ACTFRAC_MAT to calculate the -!! activated fraction of the number and mass concentrations, -!! as well as the number and mass concentrations activated -!! for each of nmodes modes. The minimum dry radius for activation -!! for each mode is also returned. -!! -!! Each mode is assumed to potentially contains 5 chemical species: -!! (1) sulfate -!! (2) BC -!! (3) OC -!! (4) mineral dust -!! (5) sea salt -!! -!! The aerosol activation parameterizations are described in -!! -!! 1. Abdul-Razzak et al. 1998, JGR, vol.103, p.6123-6131. -!! 2. Abdul-Razzak and Ghan 2000, JGR, vol.105, p.6837-6844. -!! -!! and values for many of the required parameters were taken from -!! -!! 3. Ghan et al. 2001, JGR vol 106, p.5295-5316. -!! -!! With the density of sea salt set to the value used in ref. 3 (1900 kg/m^3), this routine -!! yields values for the hygroscopicity parameters Bi in agreement with ref. 3. -!!---------------------------------------------------------------------------------------------------------------------- - subroutine GetActFrac(nmodes & !nmodes & - ,xnap & !ni (1:nmodes) & - ,rg & !0.5d+00*dgn_dry (1:nmodes) & - ,sigmag & !sig0 (1:nmodes) & - ,tkelvin & !tk (i,j,k) & - ,ptot & !pres (i,j,k) & - ,wupdraft & !wupdraft (i,j,k) & - ,nact & !nact (i,j,k,1:nmodes) & - ,bibar) - - IMPLICIT NONE + call ESMF_AttributeGet(aero_aci, name='number_of_aerosol_modes', value=n_modes, __RC__) + + if (n_modes == 0) then + RETURN_(ESMF_SUCCESS) + end if + + call MAPL_TimerOn (MAPL,"----AERO_ACTIVATE_1",__RC__) + + allocate(aero_aci_modes(n_modes), __STAT__) + call ESMF_AttributeGet(aero_aci, name='aerosol_modes', itemcount=n_modes, valuelist=aero_aci_modes, __RC__) + + call ESMF_AttributeGet(aero_aci, name='air_pressure_for_aerosol_optics', value=aci_field_name, __RC__) + if (aci_field_name /= '') then + call MAPL_GetPointer(aero_aci, aci_ptr_3d, trim(aci_field_name), __RC__) + aci_ptr_3d = PLE + end if + + call ESMF_AttributeGet(aero_aci, name='air_temperature', value=aci_field_name, __RC__) + if (aci_field_name /= '') then + call MAPL_GetPointer(aero_aci, aci_ptr_3d, trim(aci_field_name), __RC__) + aci_ptr_3d = T + end if + + call ESMF_AttributeGet(aero_aci, name='fraction_of_land_type', value=aci_field_name, __RC__) + if (aci_field_name /= '') then + call MAPL_GetPointer(aero_aci, aci_ptr_2d, trim(aci_field_name), __RC__) + aci_ptr_2d = FRLAND + end if + + ACTIVATION_PROPERTIES: do n = 1, n_modes + call ESMF_AttributeSet(aero_aci, name='aerosol_mode', value=trim(aero_aci_modes(n)), __RC__) + ! call WRITE_PARALLEL (trim(aero_aci_modes(n))) + + ! execute the aerosol activation properties method + call ESMF_MethodExecute(aero_aci, label='aerosol_activation_properties', userRC=ACI_STATUS, RC=STATUS) + VERIFY_(ACI_STATUS) + VERIFY_(STATUS) + + ! copy out aerosol activation properties + call ESMF_AttributeGet(aero_aci, name='aerosol_number_concentration', value=aci_field_name, __RC__) + call MAPL_GetPointer(aero_aci, aci_ptr_3d, trim(aci_field_name), __RC__) + AeroPropsNew(n)%num = aci_ptr_3d + + call ESMF_AttributeGet(aero_aci, name='aerosol_dry_size', value=aci_field_name, __RC__) + call MAPL_GetPointer(aero_aci, aci_ptr_3d, trim(aci_field_name), __RC__) + AeroPropsNew(n)%dpg = aci_ptr_3d + ! if (MAPL_am_I_root()) print *, AeroPropsNew(n)%dpg(1,1,1) - ! arguments. - - integer :: nmodes !< number of modes [1] - real(AER_PR) :: xnap(nmodes) !< number concentration for each mode [#/m^3] - real(AER_PR) :: rg(nmodes) !< geometric mean dry radius for each mode [um] - real(AER_PR) :: sigmag(nmodes) !< geometric standard deviation for each mode [um] - real(AER_PR) :: tkelvin !< absolute temperature [k] - real(AER_PR) :: ptot !< ambient pressure [pa] - real(AER_PR) :: wupdraft !< updraft velocity [m/s] -! real(AER_PR) :: ac(nmodes) !< minimum dry radius for activation for each mode [um] -! real(AER_PR) :: fracactn(nmodes) !< activating fraction of number conc. for each mode [1] - real(AER_PR) :: nact(nmodes) !< activating number concentration for each mode [#/m^3] - real(AER_PR) :: bibar(nmodes) ! hygroscopicity parameter for each mode [1] - - ! local variables. - - integer :: i, j ! loop counters - - !-------------------------------------------------------------------------------------------------------------- - ! calculate the droplet activation parameters for each mode. - !-------------------------------------------------------------------------------------------------------------- - call ActFrac_Mat(nmodes,xnap,rg,sigmag,bibar,tkelvin,ptot,wupdraft,nact) - - end subroutine GetActFrac - - -!>---------------------------------------------------------------------------------------------------------------------- -!! 12-12-06, DLW: Routine to calculate the activated fraction of the number -!! and mass concentrations, as well as the number and mass -!! concentrations activated for each of nmodes modes. The -!! minimum dry radius for activation for each mode is also returned. -!! -!! The aerosol activation parameterizations are described in -!! -!! 1. Abdul-Razzak et al. 1998, JGR, vol.103, p.6123-6131. -!! 2. Abdul-Razzak and Ghan 2000, JGR, vol.105, p.6837-6844. -!! -!! This routine is for the multiple-aerosol type parameterization. -!!---------------------------------------------------------------------------------------------------------------------- - subroutine ActFrac_Mat(nmodes,xnap,rg,sigmag,bibar,tkelvin,ptot,wupdraft,nact) + call ESMF_AttributeGet(aero_aci, name='width_of_aerosol_mode', value=aci_field_name, __RC__) + call MAPL_GetPointer(aero_aci, aci_ptr_3d, trim(aci_field_name), __RC__) + AeroPropsNew(n)%sig = aci_ptr_3d + + call ESMF_AttributeGet(aero_aci, name='aerosol_hygroscopicity', value=aci_field_name, __RC__) + call MAPL_GetPointer(aero_aci, aci_ptr_3d, trim(aci_field_name), __RC__) + AeroPropsNew(n)%kap = aci_ptr_3d + ! if (MAPL_am_I_root()) print *, AeroPropsNew(n)%kap(1,1,1) + + if (need_extra_fields) then + + call ESMF_AttributeGet(aero_aci, name='aerosol_density', value=aci_field_name, __RC__) + call MAPL_GetPointer(aero_aci, aci_ptr_3d, trim(aci_field_name), __RC__) + AeroPropsNew(n)%den = aci_ptr_3d + + call ESMF_AttributeGet(aero_aci, name='fraction_of_dust_aerosol', value=aci_field_name, __RC__) + call MAPL_GetPointer(aero_aci, aci_ptr_3d, trim(aci_field_name), __RC__) + AeroPropsNew(n)%fdust = aci_ptr_3d + + call ESMF_AttributeGet(aero_aci, name='fraction_of_soot_aerosol', value=aci_field_name, __RC__) + call MAPL_GetPointer(aero_aci, aci_ptr_3d, trim(aci_field_name), __RC__) + AeroPropsNew(n)%fsoot = aci_ptr_3d + + call ESMF_AttributeGet(aero_aci, name='fraction_of_organic_aerosol', value=aci_field_name, __RC__) + call MAPL_GetPointer(aero_aci, aci_ptr_3d, trim(aci_field_name), __RC__) + AeroPropsNew(n)%forg = aci_ptr_3d + + endif + + AeroPropsNew(n)%nmods = n_modes + + where (AeroPropsNew(n)%kap > 0.4) + NWFA = NWFA + AeroPropsNew(n)%num + end where + + end do ACTIVATION_PROPERTIES + + deallocate(aero_aci_modes, __STAT__) + + call MAPL_Timeroff(MAPL,"----AERO_ACTIVATE_1",__RC__) + + call MAPL_TimerOn (MAPL,"----AERO_ACTIVATE_2",__RC__) + !--- activated aerosol # concentration for liq/ice phases (units: m^-3) + + allocate( sig0(IM,JM,n_modes), source=0.0, __STAT__) + allocate( rg(IM,JM,n_modes), source=0.0, __STAT__) + allocate( ni(IM,JM,n_modes), source=0.0, __STAT__) + allocate(bibar(IM,JM,n_modes), source=0.0, __STAT__) + allocate( nact(IM,JM,n_modes), source=0.0, __STAT__) + + !$OMP parallel do default(none) shared(IM,JM,LM,n_modes,T,plo,vvel,tke,MAPL_RGAS, & + !$OMP AeroPropsNew,NACTL,NACTI,NN_MIN,NN_MAX,ai,bi,ci,di) & + !$OMP private(k,n,tk,press,air_den,wupdraft,ni,rg,bibar,sig0,nact) + DO k=1,LM + + tk = T(:,:,k) ! K + press = plo(:,:,k) ! Pa + air_den = press/(MAPL_RGAS*tk) ! kg/m3 + wupdraft = vvel(:,:,k)+SQRT(tke(:,:,k)) ! m/s + + ! Liquid Clouds + DO n=1,n_modes + ni (:,:,n) = AeroPropsNew(n)%num(:,:,k)*air_den ! unit: [m-3] + rg (:,:,n) = AeroPropsNew(n)%dpg(:,:,k)*0.5e6 ! unit: [um] + bibar(:,:,n) = AeroPropsNew(n)%kap(:,:,k) + sig0 (:,:,n) = AeroPropsNew(n)%sig(:,:,k) + ENDDO + call GetActFrac(IM*JM, n_modes & + , ni(1,1,1) & + , rg(1,1,1) & + , sig0(1,1,1) & + , bibar(1,1,1) & + , tk(1,1) & + , press(1,1) & + ,wupdraft(1,1) & + , nact(1,1,1) & + ) + numbinit(:,:) = 0. + NACTL(:,:,k) = 0. + DO n=1,n_modes + DO j = 1, JM + DO i = 1, IM + if (AeroPropsNew(n)%kap(i,j,k) > 0.4) then + numbinit(i,j) = numbinit(i,j) + AeroPropsNew(n)%num(i,j,k) + NACTL(i,j,k)= NACTL(i,j,k) + nact(i,j,n) !#/m3 + endif + ENDDO + ENDDO + ENDDO + numbinit = numbinit * air_den ! #/m3 + DO j = 1, JM + DO i = 1, IM + numbinit(i,j) = max(numbinit(i,j),0.0) + NACTL(i,j,k) = MIN(NACTL(i,j,k),0.99*numbinit(i,j)) + NACTL(i,j,k) = MAX(MIN(NACTL(i,j,k),NN_MAX),NN_MIN) + ENDDO + ENDDO + + ! Ice Clouds + numbinit(:,:) = 0. + DO n=1,n_modes + DO j = 1, JM + DO i = 1, IM + if ( (AeroPropsNew(n)%kap(i,j,k) > 0.4) .and. & + (AeroPropsNew(n)%dpg(i,j,k) .ge. 0.5e-6) ) then + numbinit(i,j) = numbinit(i,j) + AeroPropsNew(n)%num(i,j,k) + endif + ENDDO + ENDDO + ENDDO + numbinit = numbinit * air_den ! #/m3 + DO j = 1, JM + DO i = 1, IM + numbinit(i,j) = max(numbinit(i,j),0.0) + ! Number of activated IN following deMott (2010) [#/m3] + NACTI(i,j,k) = (ai*(max(0.0,(MAPL_TICE-tk(i,j)))**bi)) * (numbinit(i,j)**(ci*max((MAPL_TICE-tk(i,j)),0.0)+di)) !#/m3 + NACTI(i,j,k) = MAX(MIN(NACTI(i,j,k),NN_MAX),NN_MIN) + ENDDO + ENDDO + + ENDDO + + deallocate( sig0, __STAT__) + deallocate( rg, __STAT__) + deallocate( ni, __STAT__) + deallocate(bibar, __STAT__) + deallocate( nact, __STAT__) + + call MAPL_TimerOff(MAPL,"----AERO_ACTIVATE_2",__RC__) + + RETURN_(ESMF_SUCCESS) + END SUBROUTINE Aer_Activation + + !>---------------------------------------------------------------------------------------------------------------------- + !! 12-12-06, DLW: Routine to calculate the activated fraction of the number + !! and mass concentrations, as well as the number and mass + !! concentrations activated for each of nmodes modes. The + !! minimum dry radius for activation for each mode is also returned. + !! for each mode is also returned. + !! + !! Each mode is assumed to potentially contains 5 chemical species: + !! (1) sulfate + !! (2) BC + !! (3) OC + !! (4) mineral dust + !! (5) sea salt + !! + !! The aerosol activation parameterizations are described in + !! + !! 1. Abdul-Razzak et al. 1998, JGR, vol.103, p.6123-6131. + !! 2. Abdul-Razzak and Ghan 2000, JGR, vol.105, p.6837-6844. + !! + !! and values for many of the required parameters were taken from + !! + !! 3. Ghan et al. 2001, JGR vol 106, p.5295-5316. + !! + !! With the density of sea salt set to the value used in ref. 3 (1900 kg/m^3), this routine + !! yields values for the hygroscopicity parameters Bi in agreement with ref. 3. + !! + !! The aerosol activation parameterizations are described in + !! + !! 1. Abdul-Razzak et al. 1998, JGR, vol.103, p.6123-6131. + !! 2. Abdul-Razzak and Ghan 2000, JGR, vol.105, p.6837-6844. + !! + !! This routine is for the multiple-aerosol type parameterization. + !!---------------------------------------------------------------------------------------------------------------------- + subroutine GetActFrac(im, nmodes,xnap,rg,sigmag,bibar,tkelvin,ptot,wupdraft,nact) IMPLICIT NONE ! Arguments. - - integer :: nmodes !< number of modes [1] - real(AER_PR) :: xnap(nmodes) !< number concentration for each mode [#/m^3] -! real(AER_PR) :: xmap(nmodes) !< mass concentration for each mode [ug/m^3] - real(AER_PR) :: rg(nmodes) !< geometric mean radius for each mode [um] - real(AER_PR) :: sigmag(nmodes) !< geometric standard deviation for each mode [um] - real(AER_PR) :: bibar(nmodes) !< hygroscopicity parameter for each mode [1] - real(AER_PR) :: tkelvin !< absolute temperature [k] - real(AER_PR) :: ptot !< ambient pressure [pa] - real(AER_PR) :: wupdraft !< updraft velocity [m/s] - real(AER_PR) :: ac(nmodes) !< minimum dry radius for activation for each mode [um] - real(AER_PR) :: fracactn(nmodes) !< activating fraction of number conc. for each mode [1] - real(AER_PR) :: nact(nmodes) !< activating number concentration for each mode [#/m^3] + + integer :: im + integer :: nmodes !< number of modes [1] + real(AER_PR) :: xnap(im,nmodes) !< number concentration for each mode [#/m^3] + ! real(AER_PR) :: xmap(im,nmodes) !< mass concentration for each mode [ug/m^3] + real(AER_PR) :: rg(im,nmodes) !< geometric mean radius for each mode [um] + real(AER_PR) :: sigmag(im,nmodes) !< geometric standard deviation for each mode [um] + real(AER_PR) :: bibar(im,nmodes) !< hygroscopicity parameter for each mode [1] + real(AER_PR) :: tkelvin(im) !< absolute temperature [k] + real(AER_PR) :: ptot(im) !< ambient pressure [pa] + real(AER_PR) :: wupdraft(im) !< updraft velocity [m/s] + real(AER_PR) :: fracactn(im,nmodes) !< activating fraction of number conc. for each mode [1] + real(AER_PR) :: nact(im,nmodes) !< activating number concentration for each mode [#/m^3] ! parameters. - - real(AER_PR), parameter :: pi = 3.141592653589793d+00 - real(AER_PR), parameter :: twopi = 2.0d+00 * pi - real(AER_PR), parameter :: sqrt2 = 1.414213562d+00 - real(AER_PR), parameter :: threesqrt2by2 = 1.5d+00 * sqrt2 + + real(AER_PR), parameter :: pi = 3.141592653589793 + real(AER_PR), parameter :: twopi = 2.0 * pi + real(AER_PR), parameter :: sqrt2 = 1.414213562 + real(AER_PR), parameter :: threesqrt2by2 = 1.5 * sqrt2 real(AER_PR), parameter :: avgnum = 6.0221367d+23 ! [1/mol] - real(AER_PR), parameter :: rgasjmol = 8.31451d+00 ! [j/mol/k] - real(AER_PR), parameter :: wmolmass = 18.01528d-03 ! molar mass of h2o [kg/mol] - real(AER_PR), parameter :: amolmass = 28.966d-03 ! molar mass of air [kg/mol] - real(AER_PR), parameter :: asmolmss = 132.1406d-03 ! molar mass of nh42so4 [kg/mol] + real(AER_PR), parameter :: rgasjmol = 8.31451 ! [j/mol/k] + real(AER_PR), parameter :: wmolmass = 18.01528e-03 ! molar mass of h2o [kg/mol] + real(AER_PR), parameter :: amolmass = 28.966e-03 ! molar mass of air [kg/mol] + real(AER_PR), parameter :: asmolmss = 132.1406e-03 ! molar mass of nh42so4 [kg/mol] real(AER_PR), parameter :: denh2o = 1.00d+03 ! density of water [kg/m^3] real(AER_PR), parameter :: denamsul = 1.77d+03 ! density of pure ammonium sulfate [kg/m^3] - real(AER_PR), parameter :: xnuamsul = 3.00d+00 ! # of ions formed when the salt is dissolved in water [1] - real(AER_PR), parameter :: phiamsul = 1.000d+00 ! osmotic coefficient value in a-r 1998. [1] - real(AER_PR), parameter :: gravity = 9.81d+00 ! grav. accel. at the earth's surface [m/s/s] - real(AER_PR), parameter :: heatvap = 40.66d+03/wmolmass ! latent heat of vap. for water and tnbp [j/kg] - real(AER_PR), parameter :: cpair = 1006.0d+00 ! heat capacity of air [j/kg/k] - real(AER_PR), parameter :: t0dij = 273.15d+00 ! reference temp. for dv [k] - real(AER_PR), parameter :: p0dij = 101325.0d+00 ! reference pressure for dv [pa] - real(AER_PR), parameter :: dijh2o0 = 0.211d-04 ! reference value of dv [m^2/s] (p&k,2nd ed., p.503) - !---------------------------------------------------------------------------------------------------------------- - ! real(AER_PR), parameter :: t0dij = 283.15d+00 ! reference temp. for dv [k] - ! real(AER_PR), parameter :: p0dij = 80000.0d+00 ! reference pressure for dv [pa] - ! real(AER_PR), parameter :: dijh2o0 = 0.300d-04 ! reference value of dv [m^2/s] (p&k,2nd ed., p.503) + real(AER_PR), parameter :: xnuamsul = 3.00 ! # of ions formed when the salt is dissolved in water [1] + real(AER_PR), parameter :: phiamsul = 1.000 ! osmotic coefficient value in a-r 1998. [1] + real(AER_PR), parameter :: gravity = 9.81 ! grav. accel. at the earth's surface [m/s/s] + real(AER_PR), parameter :: heatvap = 40.66d+03/wmolmass ! latent heat of vap. for water and tnbp [j/kg] + real(AER_PR), parameter :: cpair = 1006.0 ! heat capacity of air [j/kg/k] + real(AER_PR), parameter :: t0dij = 273.15 ! reference temp. for dv [k] + real(AER_PR), parameter :: p0dij = 101325.0 ! reference pressure for dv [pa] + real(AER_PR), parameter :: dijh2o0 = 0.211e-04 ! reference value of dv [m^2/s] (p&k,2nd ed., p.503) !---------------------------------------------------------------------------------------------------------------- - real(AER_PR), parameter :: deltav = 1.096d-07 ! vapor jump length [m] - real(AER_PR), parameter :: deltat = 2.160d-07 ! thermal jump length [m] - real(AER_PR), parameter :: alphac = 1.000d+00 ! condensation mass accommodation coefficient [1] - real(AER_PR), parameter :: alphat = 0.960d+00 ! thermal accommodation coefficient [1] - - ! local variables. - - integer :: i ! loop counter - real(AER_PR) :: dv ! diffusion coefficient for water [m^2/s] - real(AER_PR) :: dvprime ! modified diffusion coefficient for water [m^2/s] - real(AER_PR) :: dumw, duma ! scratch variables [s/m] - real(AER_PR) :: wpe ! saturation vapor pressure of water [pa] - real(AER_PR) :: surten ! surface tension of air-water interface [j/m^2] - real(AER_PR) :: xka ! thermal conductivity of air [j/m/s/k] - real(AER_PR) :: xkaprime ! modified thermal conductivity of air [j/m/s/k] - real(AER_PR) :: eta(nmodes) ! model parameter [1] - real(AER_PR) :: zeta ! model parameter [1] - real(AER_PR) :: xlogsigm(nmodes) ! ln(sigmag) [1] - real(AER_PR) :: a ! [m] - real(AER_PR) :: g ! [m^2/s] - real(AER_PR) :: rdrp ! [m] - real(AER_PR) :: f1 ! [1] - real(AER_PR) :: f2 ! [1] - real(AER_PR) :: alpha ! [1/m] - real(AER_PR) :: gamma ! [m^3/kg] - real(AER_PR) :: sm(nmodes) ! [1] - real(AER_PR) :: dum ! [1/m] - real(AER_PR) :: u ! argument to error function [1] - real(AER_PR) :: erf ! error function [1], but not declared in an f90 module - real(AER_PR) :: smax ! maximum supersaturation [1] - - real(AER_PR) :: aux1,aux2 ! aux -!---------------------------------------------------------------------------------------------------------------------- -! rdrp is the radius value used in eqs.(17) & (18) and was adjusted to yield eta and zeta -! values close to those given in a-z et al. 1998 figure 5. -!---------------------------------------------------------------------------------------------------------------------- - rdrp = 0.105d-06 ! [m] tuned to approximate the results in figures 1-5 in a-z et al. 1998. -!---------------------------------------------------------------------------------------------------------------------- -! these variables are common to all modes and need only be computed once. -!---------------------------------------------------------------------------------------------------------------------- - dv = dijh2o0*(p0dij/ptot)*(tkelvin/t0dij)**1.94d+00 ! [m^2/s] (p&k,2nd ed., p.503) - surten = 76.10d-03 - 0.155d-03 * (tkelvin-273.15d+00) ! [j/m^2] - wpe = exp( 77.34491296d+00 - 7235.424651d+00/tkelvin - 8.2d+00*log(tkelvin) + tkelvin*5.7113d-03 ) ! [pa] - dumw = sqrt(twopi*wmolmass/rgasjmol/tkelvin) ! [s/m] - dvprime = dv / ( (rdrp/(rdrp+deltav)) + (dv*dumw/(rdrp*alphac)) ) ! [m^2/s] - eq. (17) - xka = (5.69d+00+0.017d+00*(tkelvin-273.15d+00))*418.4d-05 ! [j/m/s/k] (0.0238 j/m/s/k at 273.15 k) + ! real(AER_PR), parameter :: t0dij = 283.15 ! reference temp. for dv [k] + ! real(AER_PR), parameter :: p0dij = 80000.0 ! reference pressure for dv [pa] + ! real(AER_PR), parameter :: dijh2o0 = 0.300e-04 ! reference value of dv [m^2/s] (p&k,2nd ed., p.503) + !---------------------------------------------------------------------------------------------------------------- + real(AER_PR), parameter :: deltav = 1.096e-07 ! vapor jump length [m] + real(AER_PR), parameter :: deltat = 2.160e-07 ! thermal jump length [m] + real(AER_PR), parameter :: alphac = 1.000 ! condensation mass accommodation coefficient [1] + real(AER_PR), parameter :: alphat = 0.960 ! thermal accommodation coefficient [1] + + ! local variables. + + integer :: i, n ! loop counter + real(AER_PR) :: ac !< minimum dry radius for activation for each mode [um] + real(AER_PR) :: dv(im) ! diffusion coefficient for water [m^2/s] + real(AER_PR) :: dvprime(im) ! modified diffusion coefficient for water [m^2/s] + real(AER_PR) :: dumw(im), duma(im) ! scratch variables [s/m] + real(AER_PR) :: wpe(im) ! saturation vapor pressure of water [pa] + real(AER_PR) :: surten(im) ! surface tension of air-water interface [j/m^2] + real(AER_PR) :: xka(im) ! thermal conductivity of air [j/m/s/k] + real(AER_PR) :: xkaprime(im) ! modified thermal conductivity of air [j/m/s/k] + real(AER_PR) :: eta ! model parameter [1] + real(AER_PR) :: zeta(im) ! model parameter [1] + real(AER_PR) :: xlogsigm(im,nmodes) ! ln(sigmag) [1] + real(AER_PR) :: a(im) ! [m] + real(AER_PR) :: g(im) ! [m^2/s] + real(AER_PR) :: rdrp(im) ! [m] + real(AER_PR) :: f1 ! [1] + real(AER_PR) :: f2 ! [1] + real(AER_PR) :: alpha(im) ! [1/m] + real(AER_PR) :: gamma(im) ! [m^3/kg] + real(AER_PR) :: sm(im,nmodes) ! [1] + real(AER_PR) :: dum(im) ! [1/m] + real(AER_PR) :: u ! argument to error function [1] + real(AER_PR) :: erf ! error function [1], but not declared in an f90 module + real(AER_PR) :: smax(im) ! maximum supersaturation [1] + real(AER_PR) :: r23 = 2.0/3.0 + + sm = 0.0 + + !---------------------------------------------------------------------------------------------------------------------- + ! rdrp is the radius value used in eqs.(17) & (18) and was adjusted to yield eta and zeta + ! values close to those given in a-z et al. 1998 figure 5. + !---------------------------------------------------------------------------------------------------------------------- + rdrp = 0.105e-06 ! [m] tuned to approximate the results in figures 1-5 in a-z et al. 1998. + !---------------------------------------------------------------------------------------------------------------------- + ! these variables are common to all modes and need only be computed once. + !---------------------------------------------------------------------------------------------------------------------- + dv = dijh2o0*(p0dij/ptot)*(tkelvin/t0dij)**1.94 ! [m^2/s] (p&k,2nd ed., p.503) + surten = 76.10e-03 - 0.155e-03 * (tkelvin-273.15) ! [j/m^2] + wpe = exp( 77.34491296 - 7235.424651/tkelvin - 8.2*log(tkelvin) + tkelvin*5.7113e-03 ) ! [pa] + dumw = sqrt(twopi*wmolmass/rgasjmol/tkelvin) ! [s/m] + dvprime = dv / ( (rdrp/(rdrp+deltav)) + (dv*dumw/(rdrp*alphac)) ) ! [m^2/s] - eq. (17) + xka = (5.69+0.017*(tkelvin-273.15))*418.4e-05 ! [j/m/s/k] (0.0238 j/m/s/k at 273.15 k) duma = sqrt(twopi*amolmass/rgasjmol/tkelvin) ! [s/m] xkaprime = xka / ( ( rdrp/(rdrp+deltat) ) + ( xka*duma/(rdrp*alphat*denh2o*cpair) ) ) ! [j/m/s/k] - g = 1.0d+00 / ( (denh2o*rgasjmol*tkelvin) / (wpe*dvprime*wmolmass) & - + ( (heatvap*denh2o) / (xkaprime*tkelvin) ) & - * ( (heatvap*wmolmass) / (rgasjmol*tkelvin) - 1.0d+00 ) ) ! [m^2/s] - a = (2.0d+00*surten*wmolmass)/(denh2o*rgasjmol*tkelvin) ! [m] - alpha = (gravity/(rgasjmol*tkelvin))*((wmolmass*heatvap)/(cpair*tkelvin) - amolmass) ! [1/m] + g = 1.0 / ( (denh2o*rgasjmol*tkelvin) / (wpe*dvprime*wmolmass) & + + ( (heatvap*denh2o) / (xkaprime*tkelvin) ) & + * ( (heatvap*wmolmass) / (rgasjmol*tkelvin) - 1.0 ) ) ! [m^2/s] + a = (2.0*surten*wmolmass)/(denh2o*rgasjmol*tkelvin) ! [m] + alpha = (gravity/(rgasjmol*tkelvin))*((wmolmass*heatvap)/(cpair*tkelvin) - amolmass) ! [1/m] gamma = (rgasjmol*tkelvin)/(wpe*wmolmass) & - + (wmolmass*heatvap*heatvap)/(cpair*ptot*amolmass*tkelvin) ! [m^3/kg] - dum = sqrt(alpha*wupdraft/g) ! [1/m] - zeta = 2.d+00*a*dum/3.d+00 ! [1] -!---------------------------------------------------------------------------------------------------------------- - ! write(1,'(a27,4d15.5)')'surten,wpe,a =',surten,wpe,a - ! write(1,'(a27,4d15.5)')'xka,xkaprime,dv,dvprime =',xka,xkaprime,dv,dvprime - ! write(1,'(a27,4d15.5)')'alpha,gamma,g, zeta =',alpha,gamma,g,zeta -!---------------------------------------------------------------------------------------------------------------------- -! these variables must be computed for each mode. -!---------------------------------------------------------------------------------------------------------------------- - xlogsigm(:) = log(sigmag(:)) ! [1] - smax = 0.0d+00 ! [1] - - do i=1, nmodes - - sm(i) = ( 2.0d+00/sqrt(bibar(i)) ) * ( a/(3.0*rg(i)) )**1.5d+00 ! [1] - eta(i) = dum**3 / (twopi*denh2o*gamma*xnap(i)) ! [1] - - !-------------------------------------------------------------------------------------------------------------- - ! write(1,'(a27,i4,4d15.5)')'i,eta(i),sm(i) =',i,eta(i),sm(i) - !-------------------------------------------------------------------------------------------------------------- - f1 = 0.5d+00 * exp(2.50d+00 * xlogsigm(i)**2) ! [1] - f2 = 1.0d+00 + 0.25d+00 * xlogsigm(i) ! [1] - smax = smax + ( f1*( zeta / eta(i) )**1.50d+00 & - + f2*(sm(i)**2/(eta(i)+3.0d+00*zeta))**0.75d+00 ) / sm(i)**2 ! [1] - eq. (6) - enddo - smax = 1.0d+00 / sqrt(smax) ! [1] - - - !aux1=0.0D0; aux2=0.0D0 - do i=1, nmodes - - ac(i) = rg(i) * ( sm(i) / smax )**0.66666666666666667d+00 ! [um] - - u = log(ac(i)/rg(i)) / ( sqrt2 * xlogsigm(i) ) ! [1] - fracactn(i) = 0.5d+00 * (1.0d+00 - erf(u)) ! [1] - nact(i) = fracactn(i) * xnap(i) ! [#/m^3] - !-------------------------------------------------------------------------------------------------------------- - !aux1=aux1+ xnap(i); aux2=aux2+ nact(i) - - !if(fracactn(i) .gt. 0.9999999d+00 ) then - ! write(*,*)i,ac(i),u,fracactn(i),xnap(i) - ! print*,' xxx',i,ac(i),u,fracactn(i),xnap(i) - ! stop - ! endif - !-------------------------------------------------------------------------------------------------------------- - enddo + + (wmolmass*heatvap*heatvap)/(cpair*ptot*amolmass*tkelvin) ! [m^3/kg] + where (wupdraft > 0.0) + dum = sqrt(alpha*wupdraft/g) ! [1/m] + zeta = 2.*a*dum/3. ! [1] + else where + dum = 0.0 + zeta = 0.0 + end where + !---------------------------------------------------------------------------------------------------------------------- + ! these variables must be computed for each mode. + !---------------------------------------------------------------------------------------------------------------------- + xlogsigm(:,:) = log(sigmag(:,:)) + + smax(:) = 0.0 + do n=1, nmodes + do i = 1, im + if ((bibar(i,n) > 0.4) .and. (rg(i,n) > 0.0) .and. (wupdraft(i) > 0.0) .and. (xnap(i,n) > 0.0)) then + sm(i,n) = (2.0/sqrt(bibar(i,n))) * (a(i)/(3.0* rg(i,n)))**1.5 + eta = dum(i)**3 / (twopi * denh2o * gamma(i) * xnap(i,n)) + f1 = 0.5 * exp(2.50* xlogsigm(i,n)**2) + f2 = 1.0 + 0.25* xlogsigm(i,n) + smax(i) = smax(i) + (f1 * (zeta(i) / eta)**1.5 + & + f2 * (sm(i,n)**2 / (eta + 3.0*zeta(i)))**0.75) / sm(i,n)**2 + end if + end do + end do + ! Finalize smax + do i = 1, im + if (smax(i) > 0.0) then + smax(i) = 1.0/sqrt(smax(i)) + end if + end do + ! compute nact + fracactn(:,:) = 0.0 + nact(:,:) = 0.0 + do n=1, nmodes + do i = 1, im + if (smax(i) > 0.0 .and. sm(i,n) > 0.0) then + ac = rg(i,n) * ( sm(i,n)/smax(i) )**r23 ! [um] + u = log(ac/rg(i,n)) / ( sqrt2 * xlogsigm(i,n) ) ! [1] + fracactn(i,n) = 0.5 * (1.0 - erf(u)) ! [1] + nact(i,n) = min(fracactn(i,n),0.99) * xnap(i,n) ! [#/m^3] + end if + end do + end do return - end subroutine ActFrac_Mat + end subroutine GetActFrac -!>----------------------------------------------------------------------------------------------------------------------- -!! see numerical recipes, w. press et al., 2nd edition. -!!----------------------------------------------------------------------------------------------------------------------- - subroutine GcfMatrix(gammcf,a,x,gln) + !>----------------------------------------------------------------------------------------------------------------------- + !! see numerical recipes, w. press et al., 2nd edition. + !!----------------------------------------------------------------------------------------------------------------------- + subroutine GcfMatrix(gammcf,a,x,gln) implicit none integer, parameter :: itmax=10000 - real(AER_PR), parameter :: eps=3.0d-07 - real(AER_PR), parameter :: fpmin=1.0d-30 + real(AER_PR), parameter :: eps=3.0e-07 + real(AER_PR), parameter :: fpmin=tiny(1.0) real(AER_PR) :: a,gammcf,gln,x integer :: i real(AER_PR) :: an,b,c,d,del,h - !real(AER_PR) :: gammln ! function names not declared in an f90 module gln=gammln(a) - b=x+1.0d+00-a - c=1.0d+00/fpmin - d=1.0d+00/b + b=x+1.0-a + c=1.0/fpmin + d=1.0/b h=d do i=1,itmax - an=-i*(i-a) - b=b+2.0d+00 - d=an*d+b - if(abs(d).lt.fpmin)d=fpmin - c=b+an/c - if(abs(c).lt.fpmin)c=fpmin - d=1.0d+00/d - del=d*c - h=h*del - if(abs(del-1.0d+00).lt.eps)goto 1 + an=-i*(i-a) + b=b+2.0 + d=an*d+b + if(abs(d).lt.fpmin)d=fpmin + c=b+an/c + if(abs(c).lt.fpmin)c=fpmin + d=1.0/d + del=d*c + h=h*del + if(abs(del-1.0).lt.eps)goto 1 enddo write(*,*)'AERO_ACTV: SUBROUTINE GCF: A TOO LARGE, ITMAX TOO SMALL', gammcf,a,x,gln 1 gammcf=exp(-x+a*log(x)-gln)*h return - end subroutine GcfMatrix + end subroutine GcfMatrix -!>----------------------------------------------------------------------------------------------------------------------- -!! see numerical recipes, w. press et al., 2nd edition. -!!----------------------------------------------------------------------------------------------------------------------- - subroutine Gser(gamser,a,x,gln) + !>----------------------------------------------------------------------------------------------------------------------- + !! see numerical recipes, w. press et al., 2nd edition. + !!----------------------------------------------------------------------------------------------------------------------- + subroutine Gser(gamser,a,x,gln) implicit none - integer, parameter :: itmax=10000 ! was itmax=100 in press et al. - real(AER_PR), parameter :: eps=3.0d-09 ! was eps=3.0d-07 in press et al. + integer, parameter :: itmax=10000 ! was itmax=100 in press et al. + real(AER_PR), parameter :: eps=3.0e-09 ! was eps=3.0e-07 in press et al. real(AER_PR) :: a,gamser,gln,x integer :: n real(AER_PR) :: ap,del,sum - !real(AER_PR) :: gammln ! function names not declared in an f90 module gln=gammln(a) - if(x.le.0.d+00)then - if(x.lt.0.)stop 'aero_actv: subroutine gser: x < 0 in gser' - gamser=0.d+00 - return + if(x.le.0.)then + if(x.lt.0.)stop 'aero_actv: subroutine gser: x < 0 in gser' + gamser=0. + return endif ap=a - sum=1.d+00/a + sum=1./a del=sum do n=1,itmax - ap=ap+1.d+00 - del=del*x/ap - sum=sum+del - if(abs(del).lt.abs(sum)*eps)goto 1 + ap=ap+1. + del=del*x/ap + sum=sum+del + if(abs(del).lt.abs(sum)*eps)goto 1 enddo write(*,*)'aero_actv: subroutine gser: a too large, itmax too small' 1 gamser=sum*exp(-x+a*log(x)-gln) return - end subroutine Gser + end subroutine Gser -!>----------------------------------------------------------------------------------------------------------------------- -!! see numerical recipes, w. press et al., 2nd edition. -!!----------------------------------------------------------------------------------------------------------------------- - double precision function GammLn(xx) + !>----------------------------------------------------------------------------------------------------------------------- + !! see numerical recipes, w. press et al., 2nd edition. + !!----------------------------------------------------------------------------------------------------------------------- + real(AER_PR) function GammLn(xx) implicit none real(AER_PR) :: xx integer j - double precision ser,stp,tmp,x,y,cof(6) + real(AER_PR) ser,stp,tmp,x,y,cof(6) save cof,stp - data cof,stp/76.18009172947146d0,-86.50532032941677d0, & - 24.01409824083091d0,-1.231739572450155d0,.1208650973866179d-2, & - -.5395239384953d-5,2.5066282746310005d0/ + data cof,stp/76.18009172947146,-86.50532032941677, & + 24.01409824083091,-1.231739572450155,.1208650973866179e-2, & + -.5395239384953e-5,2.5066282746310005/ x=xx y=x - tmp=x+5.5d0 - tmp=(x+0.5d0)*log(tmp)-tmp - ser=1.000000000190015d0 + tmp=x+5.5 + tmp=(x+0.5)*log(tmp)-tmp + ser=1.000000000190015 do j=1,6 - y=y+1.d0 - ser=ser+cof(j)/y + y=y+1. + ser=ser+cof(j)/y enddo gammln=tmp+log(stp*ser/x) return - end function GammLn + end function GammLn -!>----------------------------------------------------------------------------------------------------------------------- -!! see numerical recipes, w. press et al., 2nd edition. -!!----------------------------------------------------------------------------------------------------------------------- - double precision function Erf(x) + !>----------------------------------------------------------------------------------------------------------------------- + !! see numerical recipes, w. press et al., 2nd edition. + !!----------------------------------------------------------------------------------------------------------------------- + real(AER_PR) function Erf(x) implicit none real(AER_PR) :: x -!u uses gammp - !LFR real(AER_PR) :: gammp ! function names not declared in an f90 module - erf = 0.d0 - if(x.lt.0.0d+00)then - erf=-gammp(0.5d0,x**2) + erf = 0. + if(x.lt.0.0)then + erf=-gammp(0.5,x**2) else - erf= gammp(0.5d0,x**2) + erf= gammp(0.5,x**2) endif return - end function Erf + end function Erf -!>----------------------------------------------------------------------------------------------------------------------- -!! see numerical recipes, w. press et al., 2nd edition. -!!----------------------------------------------------------------------------------------------------------------------- - double precision function GammP(a,x) + !>----------------------------------------------------------------------------------------------------------------------- + !! see numerical recipes, w. press et al., 2nd edition. + !!----------------------------------------------------------------------------------------------------------------------- + real(AER_PR) function GammP(a,x) implicit none real(AER_PR) :: a,x real(AER_PR) :: gammcf,gamser,gln - if(x.lt.0.0d+00.or.a.le.0.0d+00)then - write(*,*)'aero_actv: function gammp: bad arguments' + if(x.lt.0.0.or.a.le.0.0)then + write(*,*)'aero_actv: function gammp: bad arguments' endif - if(x.lt.a+1.0d+00)then - call Gser(gamser,a,x,gln) - gammp=gamser + if(x.lt.a+1.0)then + call Gser(gamser,a,x,gln) + gammp=gamser else - call GcfMatrix(gammcf,a,x,gln) - gammp=1.0d+00-gammcf + call GcfMatrix(gammcf,a,x,gln) + gammp=1.0-gammcf endif return - end function GammP -!>----------------------------------------------------------------------------------------------------------------------- + end function GammP + !>----------------------------------------------------------------------------------------------------------------------- END MODULE Aer_Actv_Single_Moment diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/aer_cloud.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/aer_cloud.F90 index c2e80ce69..b542f5b44 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/aer_cloud.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/aer_cloud.F90 @@ -16,7 +16,7 @@ MODULE aer_cloud public :: aerosol_activate public :: AerConversion public :: AerProps - !public :: AerPropsNew + public :: AerPropsNew public :: getINsubset public :: init_Aer public :: aer_cloud_init @@ -29,18 +29,18 @@ MODULE aer_cloud integer, parameter :: nsmx_par = 20 !maximum number of modes allowed integer, parameter :: npgauss = 10 - !type :: AerPropsNew - !sequence - !real, dimension(:,:,:), pointer :: num !Num conc m-3 - !real, dimension(:,:,:), pointer :: dpg !dry Geometric size, m - !real, dimension(:,:,:), pointer :: sig !logarithm (base e) of the dry geometric disp - !real, dimension(:,:,:), pointer :: den !dry density , Kg m-3 - !real, dimension(:,:,:), pointer :: kap !Hygroscopicity parameter - !real, dimension(:,:,:), pointer :: fdust! mass fraction of dust - !real, dimension(:,:,:), pointer :: fsoot ! mass fraction of soot - !real, dimension(:,:,:), pointer :: forg ! mass fraction of organics - !integer :: nmods ! total number of modes (nmods pi_8 - ! use fms_mod, only: write_version_number, open_namelist_file, & - ! check_nml_error, file_exist, close_file - - use fms_mod, only: write_version_number, open_namelist_file, & - check_nml_error, close_file, file_exist, & - fms_init - use GEOSmoist_Process_Library, only: sigma, ice_fraction + ! use mpp_mod, only: mpp_pe, mpp_root_pe + + ! use fms_mod, only: write_version_number, open_namelist_file, & + ! check_nml_error, close_file, file_exist, & + ! fms_init + use GEOSmoist_Process_Library, only: sigma, ice_fraction, LDRADIUS4 + use MAPL, only: MAPL_AM_I_ROOT implicit none private public gfdl_cloud_microphys_driver, gfdl_cloud_microphys_init, gfdl_cloud_microphys_end - public wqs1, wqs2, qs_blend, wqsat_moist, wqsat2_moist - public qsmith_init, qsmith, es2_table1d, es3_table1d, esw_table1d - public setup_con, wet_bulb public cloud_diagnosis + public ICE_LSC_VFALL_PARAM, ICE_CNV_VFALL_PARAM + + integer :: ICE_LSC_VFALL_PARAM = 1 + integer :: ICE_CNV_VFALL_PARAM = 1 real :: missing_value = - 1.e10 @@ -75,17 +69,13 @@ module gfdl2_cloud_microphys_mod real, parameter :: hlv = 2.5e6 !< gfs: latent heat of evaporation real, parameter :: hlf = 3.3358e5 !< gfs: latent heat of fusion real, parameter :: pi = 3.1415926535897931 !< gfs: ratio of circle circumference to diameter - ! real, parameter :: cp_air = rdgas * 7. / 2. ! 1004.675, heat capacity of dry air at constant pressure real, parameter :: cp_vap = 4.0 * rvgas !< 1846.0, heat capacity of water vapore at constnat pressure - ! real, parameter :: cv_air = 717.56 ! satoh value real, parameter :: cv_air = cp_air - rdgas !< 717.55, heat capacity of dry air at constant volume - ! real, parameter :: cv_vap = 1410.0 ! emanuel value real, parameter :: cv_vap = 3.0 * rvgas !< 1384.5, heat capacity of water vapor at constant volume ! the following two are from emanuel's book "atmospheric convection" ! real, parameter :: c_ice = 2106.0 ! heat capacity of ice at 0 deg c: c = c_ice + 7.3 * (t - tice) ! real, parameter :: c_liq = 4190.0 ! heat capacity of water at 0 deg c - real, parameter :: c_ice = 1972.0 !< gfdl: heat capacity of ice at - 15 deg c real, parameter :: c_liq = 4185.5 !< gfdl: heat capacity of water at 15 deg c ! real, parameter :: c_liq = 4218.0 ! ifs: heat capacity of liquid at 0 deg c @@ -96,6 +86,11 @@ module gfdl2_cloud_microphys_mod real, parameter :: t_ice = 273.16 !< freezing temperature real, parameter :: table_ice = 273.16 !< freezing point for qs table + integer, parameter :: es_table_length = 2621 + real , parameter :: es_table_tmin = table_ice - 160. + real , parameter :: delt = 0.1 + real , parameter :: rdelt = 1.0/delt + ! real, parameter :: e00 = 610.71 ! gfdl: saturation vapor pressure at 0 deg c real, parameter :: e00 = 611.21 !< ifs: saturation vapor pressure at 0 deg c @@ -117,9 +112,6 @@ module gfdl2_cloud_microphys_mod real, parameter :: qvmin = 1.e-20 !< min value for water vapor (treated as zero) real, parameter :: qcmin = 1.e-12 !< min value for cloud condensates - real, parameter :: vr_min = 1.e-3 !< min fall speed for rain - real, parameter :: vf_min = 1.e-5 !< min fall speed for cloud ice, snow, graupel - real, parameter :: dz_min = 1.e-2 ! use for correcting flipped height real, parameter :: sfcrho = 1.2 !< surface air density @@ -142,20 +134,21 @@ module gfdl2_cloud_microphys_mod ! cloud microphysics switchers - integer :: icloud_f = 0 !< cloud scheme + integer :: icloud_f = 3 !< cloud scheme integer :: irain_f = 0 !< cloud water to rain auto conversion scheme logical :: de_ice = .false. !< to prevent excessive build - up of cloud ice from external sources - logical :: sedi_transport = .false. !< transport of momentum in sedimentation + logical :: sedi_transport = .true. !< transport of momentum in sedimentation logical :: do_sedi_w = .false. !< transport of vertical motion in sedimentation logical :: do_sedi_heat = .false. !< transport of heat in sedimentation - logical :: prog_ccn = .false. !< do prognostic ccn (yi ming's method) logical :: do_bigg = .false. !< do bigg mechanism freezing of supercooled liquid on aerosol nuclei - logical :: do_evap = .false. !< do evaporation - logical :: do_subl = .false. !< do sublimation + logical :: do_evap = .true. !< do evaporation + logical :: do_subl = .true. !< do sublimation + logical :: in_cloud = .true. !< use in-cloud autoconversion logical :: do_qa = .false. !< do inline cloud fraction (WMP: in FV3 dynamics) + logical :: do_icepsettle = .true. ! include ice pressure settling function logical :: preciprad = .true. !< consider precipitates in cloud fraciton calculation - logical :: fix_negative = .false. !< fix negative water species + logical :: fix_negative = .true. !< fix negative water species logical :: do_setup = .true. !< setup constants and parameters logical :: p_nonhydro = .false. !< perform hydrosatic adjustment on air density @@ -164,25 +157,12 @@ module gfdl2_cloud_microphys_mod logical :: tables_are_initialized = .false. - ! logical :: root_proc - ! integer :: id_rh, id_vtr, id_vts, id_vtg, id_vti, id_rain, id_snow, id_graupel, & - ! id_ice, id_prec, id_cond, id_var, id_droplets - ! integer :: gfdl_mp_clock ! clock for timing of driver routine - real, parameter :: dt_fr = 8. !< epsilon on homogeneous freezing of cloud water at t_wfr + dt_fr ! minimum temperature water can exist (moore & molinero nov. 2011, nature) ! dt_fr can be considered as the error bar real :: p_min = 100. !< minimum pressure (pascal) for mp to operate - ! slj, the following parameters are for cloud - resolving resolution: 1 - 5 km - - ! qi0_crt = 0.8e-4 - ! qs0_crt = 0.6e-3 - ! c_psaci = 0.1 - ! c_pgacs = 0.1 - ! c_pgaci = 0.05 - ! ----------------------------------------------------------------------- !> namelist parameters ! ----------------------------------------------------------------------- @@ -194,80 +174,72 @@ module gfdl2_cloud_microphys_mod real :: tice0 = 273.16 - 0.01 real :: t_wfr = 273.16 - 40.0 ! supercooled water can exist down to - 40 c, which is the "absolute" - real :: t_min = 178. !< min temp to freeze - dry all water vapor - real :: t_sub = 184. !< min temp for sublimation of cloud ice + real :: t_min = 273.16 - 95.16 !< min temp to freeze all water vapor + real :: t_sub = 273.16 - 89.16 !< min temp for sublimation of cloud ice real :: mp_time = 150. !< maximum micro - physics time step (sec) ! relative humidity increment - real :: rh_inc = 0.25 !< rh increment for complete evaporation of cloud water and cloud ice - real :: rh_inr = 0.25 !< rh increment for minimum evaporation of rain - real :: rh_ins = 0.25 !< rh increment for sublimation of snow + real :: rh_inc = 0.30 !< rh increment for complete evaporation of cloud water and cloud ice + real :: rh_inr = 0.30 !< rh increment for minimum evaporation of rain + real :: rh_ins = -99. !< rh increment for sublimation of snow [wmp: not used] ! conversion time scale - real :: tau_r2g = 900. !< rain freezing during fast_sat - real :: tau_smlt = 900. !< snow melting - real :: tau_g2r = 600. !< graupel melting to rain - real :: tau_imlt = 600. !< cloud ice melting - real :: tau_i2s = 1000. !< cloud ice to snow auto - conversion - real :: tau_l2r = 900. !< cloud water to rain auto - conversion - real :: tau_v2l = 150. !< water vapor to cloud water (condensation) - real :: tau_l2v = 300. !< cloud water to water vapor (evaporation) - real :: tau_i2v = 300. !< cloud ice to water vapor (sublimation) - real :: tau_s2v = 600. !< snow sublimation - real :: tau_v2s = 21600. !< snow deposition -- make it a slow process - real :: tau_g2v = 900. !< graupel sublimation - real :: tau_v2g = 21600. !< graupel deposition -- make it a slow process - real :: tau_revp = 600. !< rain re-evaporation - real :: tau_frz = 450. !, timescale for liquid-ice freezing - ! horizontal subgrid variability - - real :: dw_land = 0.20 !< base value for subgrid deviation / variability over land - real :: dw_ocean = 0.10 !< base value for ocean - - ! prescribed ccn - - real :: ccn_o = 90. !< ccn over ocean (cm^ - 3) - real :: ccn_l = 270. !< ccn over land (cm^ - 3) - - real :: rthreshu = 7.0e-6 !< critical cloud drop radius (micro m) - real :: rthreshs = 10.0e-6 !< critical cloud drop radius (micro m) + real :: tau_r2g = -9999. !< rain freezing during fast_sat [wmp: not used] + real :: tau_l2r = -9999. !< cloud water to rain auto - conversion [wmp: not used] + real :: tau_v2l = -9999. !< water vapor to cloud water (condensation) [wmp: not used] + real :: tau_l2v = 300. !< cloud water to water vapor (evaporation) + real :: tau_i2v = 300. !< cloud ice to water vapor (sublimation) + real :: tau_s2v = 600. !< snow sublimation + real :: tau_g2v = 900. !< graupel sublimation + real :: tau_v2s = 21600. !< snow deposition -- make it a slow process + real :: tau_v2g = 21600. !< graupel deposition -- make it a slow process + real :: tau_i2s = 1000. !< cloud ice to snow auto - conversion + real :: tau_revp = 600. !< rain re-evaporation + real :: tau_frz = 600. !< timescale for liquid-ice freezing + real :: tau_imlt = 600. !< cloud ice melting + real :: tau_smlt = 900. !< snow melting + real :: tau_gmlt = 1200. !< graupel melting to rain + + real :: rthreshu = 7.0e-6 !< unstable critical cloud drop radius (micro m) + real :: rthreshs = 10.0e-6 !< stable critical cloud drop radius (micro m) real :: sat_adj0 = 0.90 !< adjustment factor (0: no, 1: full) during fast_sat_adj real :: qc_crt = 5.0e-8 !< mini condensate mixing ratio to allow partial cloudiness - real :: qi_lim = 1. !< cloud ice limiter to prevent large ice build up + real :: qi_lim = 1. !< cloud ice limiter to prevent large ice build up by deposition real :: ql_mlt = 2.0e-3 !< max value of cloud water allowed from melted cloud ice real :: qs_mlt = 1.0e-6 !< max cloud water due to snow melt - real :: ql_gen = 1.0e-3 !< max cloud water generation real :: qi_gen = 9.82679e-5 !< max cloud ice generation at -40 C ! cloud condensate upper bounds: "safety valves" for ql & qi - real :: ql0_max = 2.0e-3 !< max cloud water value (auto converted to rain) - real :: qi0_max = 1.0e-4 !< max cloud ice value (by other sources) - real :: qi0_crt = 1.0e-4 !< cloud ice to snow autoconversion threshold (was 1.e-4) - !! qi0_crt is highly dependent on horizontal resolution - real :: qr0_crt = 1.0e-4 !< rain to snow or graupel / hail threshold - !! lfo used * mixing ratio * = 1.e-4 (hail in lfo) - real :: qs0_crt = 1.0e-3 !< snow to graupel density threshold (0.6e-3 in purdue lin scheme) + ! critical autoconverion parameters + real :: qi0_crt = 1.0e-4 !< cloud ice to snow autoconversion threshold + !! qi0_crt can be dependent on horizontal resolution + !! this sensitivity could be handled with onemsig later in the code + real :: qs0_crt = 0.6e-3 !< snow to graupel density threshold (0.6e-3 in purdue lin scheme) - real :: c_paut = 0.55 !< autoconversion cloud water to rain (use 0.5 to reduce autoconversion) - real :: c_psaci = 0.02 !< accretion: cloud ice to snow (was 0.1 in zetac) - real :: c_piacr = 5.0 !< accretion: rain to ice: - real :: c_cracw = 0.9 !< rain accretion efficiency - real :: c_pgacs = 2.0e-3 !< snow to graupel "accretion" eff. (was 0.1 in zetac) - real :: c_pgaci = 0.05 !< ice to graupel "accretion" eff. + real :: c_paut = 1.00 !< autoconversion cloud water to rain (use 0.5 to reduce autoconversion) - ! decreasing clin to reduce csacw (so as to reduce cloud water --- > snow) + ! collection efficiencies for accretion + ! Dry processes (frozen to/from frozen) + real :: c_psaci = 0.05 !< accretion: cloud ice to snow + real :: c_pgacs = 0.01 !< accretion: snow to graupel + real :: c_pgaci = 0.01 !< accretion: cloud ice to graupel + real :: c_pgacw = 0.01 !< accretion: cloud water to graupel + ! Wet processes (liquid to/from frozen) + real :: c_cracw = 1.00 !< accretion: cloud water to rain - real :: alin = 842.0 !< "a" in lin1983 - real :: clin = 4.8 !< "c" in lin 1983, 4.8 -- > 6. (to ehance ql -- > qs) + ! accretion efficiencies + real :: alin = 842.0 !< "a" in lin 1983, [Rain] (increase to ehance ql/qi -- > qr) + real :: clin = 4.8 !< "c" in lin 1983, [Snow] (increase to ehance ql/qi -- > qs) + real :: gcon = 40.74 * sqrt (sfcrho) ! [Graupel] (increase to ehance ql/qi -- > qg) ! fall velocity tuning constants: @@ -276,29 +248,36 @@ module gfdl2_cloud_microphys_mod logical :: const_vg = .false. !< if .t. the constants are specified by v * _fac logical :: const_vr = .false. !< if .t. the constants are specified by v * _fac - ! good values: - - real :: vi_fac = 1. !< if const_vi: 1 / 3 - real :: vs_fac = 1. !< if const_vs: 1. - real :: vg_fac = 1. !< if const_vg: 2. - real :: vr_fac = 1. !< if const_vr: 4. - - ! upper bounds of fall speed (with variable speed option) + ! ice fall speed ranges based on https://doi.org/10.1002/2013JD020602 fig. 9 + ! bounds of fall speed (with variable speed option) for precip base on + ! https://www.atmos.albany.edu/facstaff/rfovell/ATM562/lin-etal-1983.pdf fig. 2 + + real :: vi_fac = 1. + real :: vs_fac = 1. + real :: vg_fac = 1. + real :: vr_fac = 1. + real :: vh_fac = 1. + + real :: vi_min = 0.01 !< minimum fall speed or constant fall speed + real :: vs_min = 1. !< minimum fall speed or constant fall speed + real :: vg_min = 3. !< minimum fall speed or constant fall speed + real :: vr_min = 4. !< minimum fall speed or constant fall speed + real :: vh_min = 9. !< minimum fall speed or constant fall speed real :: vi_max = 1.0 !< max fall speed for ice - real :: vs_max = 2.0 !< max fall speed for snow - real :: vg_max = 12. !< max fall speed for graupel - real :: vr_max = 12. !< max fall speed for rain + real :: vs_max = 3.0 !< max fall speed for snow + real :: vg_max = 12.0 !< max fall speed for graupel + real :: vr_max = 12.0 !< max fall speed for rain + real :: vh_max = 19.0 !< max fall speed for hail ! cloud microphysics switchers logical :: fast_sat_adj = .false. !< has fast saturation adjustments - logical :: z_slope_liq = .true. !< use linear mono slope for autocconversions - logical :: z_slope_ice = .false. !< use linear mono slope for autocconversions - logical :: use_ccn = .false. !< use input ccn when .T. else use ccn_o/ccn_l - logical :: use_ppm = .false. !< use ppm fall scheme - logical :: mono_prof = .true. !< perform terminal fall with mono ppm scheme - logical :: mp_print = .false. !< cloud microphysics debugging printout + logical :: z_slope_liq = .true. !< use linear mono slope for autocconversions + logical :: z_slope_ice = .true. !< use linear mono slope for autocconversions + logical :: use_ppm = .false. !< use ppm fall scheme + logical :: mono_prof = .true. !< perform terminal fall with mono ppm scheme + logical :: mp_print = .false. !< cloud microphysics debugging printout ! real :: global_area = - 1. @@ -307,31 +286,34 @@ module gfdl2_cloud_microphys_mod ! ----------------------------------------------------------------------- namelist / gfdl_cloud_microphysics_nml / & - mp_time, t_min, t_sub, tau_r2g, tau_smlt, tau_g2r, dw_land, dw_ocean, & - vi_fac, vr_fac, vs_fac, vg_fac, ql_mlt, do_qa, fix_negative, vi_max, & - vs_max, vg_max, vr_max, qs_mlt, qs0_crt, qi_gen, ql0_max, qi0_max, & - qi0_crt, qr0_crt, fast_sat_adj, rh_inc, rh_ins, rh_inr, const_vi, & - const_vs, const_vg, const_vr, use_ccn, rthreshu, rthreshs, ccn_l, ccn_o, qc_crt, & + mp_time, t_min, t_sub, tau_r2g, tau_smlt, tau_gmlt, & + vi_fac, vr_fac, vs_fac, vg_fac, & + vi_min, vr_min, vs_min, vg_min, ql_mlt, do_qa, fix_negative, vi_max, & + vs_max, vg_max, vr_max, qs_mlt, qs0_crt, qi_gen, ql0_max, & + qi0_crt, fast_sat_adj, rh_inc, rh_ins, rh_inr, const_vi, & + const_vs, const_vg, const_vr, rthreshu, rthreshs, qc_crt, & tau_g2v, tau_v2g, tau_s2v, tau_v2s, & tau_revp, tau_frz, do_bigg, do_evap, do_subl, & - sat_adj0, c_piacr, tau_imlt, tau_v2l, tau_l2v, tau_i2v, & - tau_i2s, tau_l2r, qi_lim, ql_gen, c_paut, c_psaci, c_pgacs, c_pgaci, & - z_slope_liq, z_slope_ice, prog_ccn, c_cracw, alin, clin, & - preciprad, cld_min, use_ppm, mono_prof, & + sat_adj0, tau_imlt, tau_v2l, tau_l2v, tau_i2v, & + tau_i2s, tau_l2r, qi_lim, c_paut, c_psaci, c_pgacs, c_pgaci, c_pgacw, & + z_slope_liq, z_slope_ice, c_cracw, alin, clin, & + preciprad, cld_min, use_ppm, mono_prof, in_cloud, & + do_icepsettle, & do_sedi_heat, sedi_transport, do_sedi_w, de_ice, icloud_f, irain_f, mp_print public & - mp_time, t_min, t_sub, tau_r2g, tau_smlt, tau_g2r, dw_land, dw_ocean, & - vi_fac, vr_fac, vs_fac, vg_fac, ql_mlt, do_qa, fix_negative, vi_max, & - vs_max, vg_max, vr_max, qs_mlt, qs0_crt, qi_gen, ql0_max, qi0_max, & - qi0_crt, qr0_crt, fast_sat_adj, rh_inc, rh_ins, rh_inr, const_vi, & - const_vs, const_vg, const_vr, use_ccn, rthreshu, rthreshs, ccn_l, ccn_o, qc_crt, & + mp_time, t_min, t_sub, tau_r2g, tau_smlt, tau_gmlt, & + vi_min, vr_min, vs_min, vg_min, ql_mlt, do_qa, fix_negative, vi_max, & + vs_max, vg_max, vr_max, qs_mlt, qs0_crt, qi_gen, ql0_max, & + qi0_crt, fast_sat_adj, rh_inc, rh_ins, rh_inr, const_vi, & + const_vs, const_vg, const_vr, rthreshu, rthreshs, qc_crt, & tau_g2v, tau_v2g, tau_s2v, tau_v2s, & tau_revp, tau_frz, do_bigg, do_evap, do_subl, & - sat_adj0, c_piacr, tau_imlt, tau_v2l, tau_l2v, tau_i2v, & - tau_i2s, tau_l2r, qi_lim, ql_gen, c_paut, c_psaci, c_pgacs, c_pgaci, & - z_slope_liq, z_slope_ice, prog_ccn, c_cracw, alin, clin, & - preciprad, cld_min, use_ppm, mono_prof, & + sat_adj0, tau_imlt, tau_v2l, tau_l2v, tau_i2v, & + tau_i2s, tau_l2r, qi_lim, c_paut, c_psaci, c_pgacs, c_pgaci, c_pgacw, & + z_slope_liq, z_slope_ice, c_cracw, alin, clin, & + preciprad, cld_min, use_ppm, mono_prof, in_cloud, & + do_icepsettle, & do_sedi_heat, sedi_transport, do_sedi_w, de_ice, icloud_f, irain_f, mp_print contains @@ -342,12 +324,12 @@ module gfdl2_cloud_microphys_mod !>@brief The subroutine 'gfdl_cloud_microphys_driver' executes the full GFDL !! cloud microphysics. -subroutine gfdl_cloud_microphys_driver (qv, ql, qr, qi, qs, qg, qa, qn, & +subroutine gfdl_cloud_microphys_driver (qv, ql, qr, qi, qs, qg, qa, qnl, qni, & qv_dt, ql_dt, qr_dt, qi_dt, qs_dt, qg_dt, qa_dt, pt_dt, pt, w, & uin, vin, udt, vdt, dz, delp, area, dt_in, & land, cnv_fraction, srf_type, eis, & rhcrit, anv_icefall, lsc_icefall, & - revap, isubl, & + revap, isubl, vti, vts, vtg, vtr, & rain, snow, ice, & graupel, m2_rain, m2_sol, hydrostatic, phys_hydrostatic, & iis, iie, jjs, jje, kks, kke, ktop, kbot) @@ -371,7 +353,7 @@ subroutine gfdl_cloud_microphys_driver (qv, ql, qr, qi, qs, qg, qa, qn, & real, intent (in) :: anv_icefall, lsc_icefall real, intent (in), dimension (:, :, :) :: delp, dz, uin, vin - real, intent (in), dimension (:, :, :) :: pt, qv, ql, qr, qg, qa, qn + real, intent (in), dimension (:, :, :) :: pt, qv, ql, qr, qg, qa, qnl, qni real, intent (inout), dimension (:, :, :) :: qi, qs real, intent (inout), dimension (:, :, :) :: pt_dt, qa_dt, udt, vdt, w @@ -382,6 +364,7 @@ subroutine gfdl_cloud_microphys_driver (qv, ql, qr, qi, qs, qg, qa, qn, & real, intent (out), dimension (:, :, :) :: m2_rain, m2_sol ! Rain and Ice fluxes (Pa kg/kg) real, intent (out), dimension (:, :, :) :: revap ! Rain evaporation real, intent (out), dimension (:, :, :) :: isubl ! Ice sublimation + real, intent (out), dimension (:, :, :) :: vti, vts, vtg, vtr ! Fall speed exports ! logical :: used @@ -394,7 +377,7 @@ subroutine gfdl_cloud_microphys_driver (qv, ql, qr, qi, qs, qg, qa, qn, & real, dimension (iie - iis + 1, jje - jjs + 1) :: prec_mp, prec1, cond, w_var, rh0 - real, dimension (iie - iis + 1, jje - jjs + 1, kke - kks + 1) :: vt_r, vt_s, vt_g, vt_i, qn2 + real, dimension (iie - iis + 1, jje - jjs + 1, kke - kks + 1) :: qn2 real :: allmax @@ -405,8 +388,6 @@ subroutine gfdl_cloud_microphys_driver (qv, ql, qr, qi, qs, qg, qa, qn, & je = jje - jjs + 1 ke = kke - kks + 1 - ! call mpp_clock_begin (gfdl_mp_clock) - ! ----------------------------------------------------------------------- ! define heat capacity of dry air and water vapor based on hydrostatical property ! ----------------------------------------------------------------------- @@ -473,15 +454,15 @@ subroutine gfdl_cloud_microphys_driver (qv, ql, qr, qi, qs, qg, qa, qn, & do j = js, je call mpdrv (hydrostatic, uin, vin, w, delp, pt, qv, ql, qr, qi, qs, qg,& - qa, qn, dz, is, ie, js, je, ks, ke, ktop, kbot, j, dt_in, ntimes, & + qa, qnl, qni, dz, is, ie, js, je, ks, ke, ktop, kbot, j, dt_in, ntimes, & rain (:, j), snow (:, j), graupel (:, j), ice (:, j), m2_rain, & m2_sol, cond (:, j), area (:, j), & land (:, j), cnv_fraction(:, j), srf_type(:, j), eis(:,j), & rhcrit, anv_icefall, lsc_icefall, & revap, isubl, & udt, vdt, pt_dt, & - qv_dt, ql_dt, qr_dt, qi_dt, qs_dt, qg_dt, qa_dt, w_var, vt_r, & - vt_s, vt_g, vt_i, qn2) + qv_dt, ql_dt, qr_dt, qi_dt, qs_dt, qg_dt, qa_dt, w_var, & + vtr, vts, vtg, vti, qn2) enddo ! ----------------------------------------------------------------------- @@ -498,34 +479,6 @@ subroutine gfdl_cloud_microphys_driver (qv, ql, qr, qi, qs, qg, qa, qn, & enddo endif - ! ----------------------------------------------------------------------- - ! diagnostic output - ! ----------------------------------------------------------------------- - - ! if (id_vtr > 0) then - ! used = send_data (id_vtr, vt_r, time, is_in = iis, js_in = jjs) - ! endif - - ! if (id_vts > 0) then - ! used = send_data (id_vts, vt_s, time, is_in = iis, js_in = jjs) - ! endif - - ! if (id_vtg > 0) then - ! used = send_data (id_vtg, vt_g, time, is_in = iis, js_in = jjs) - ! endif - - ! if (id_vti > 0) then - ! used = send_data (id_vti, vt_i, time, is_in = iis, js_in = jjs) - ! endif - - ! if (id_droplets > 0) then - ! used = send_data (id_droplets, qn2, time, is_in = iis, js_in = jjs) - ! endif - - ! if (id_var > 0) then - ! used = send_data (id_var, w_var, time, is_in = iis, js_in = jjs) - ! endif - ! convert to mm / day convt = 86400. * rdt * rgrav @@ -539,74 +492,6 @@ subroutine gfdl_cloud_microphys_driver (qv, ql, qr, qi, qs, qg, qa, qn, & enddo enddo - ! if (id_cond > 0) then - ! do j = js, je - ! do i = is, ie - ! cond (i, j) = cond (i, j) * rgrav - ! enddo - ! enddo - ! used = send_data (id_cond, cond, time, is_in = iis, js_in = jjs) - ! endif - - ! if (id_snow > 0) then - ! used = send_data (id_snow, snow, time, iis, jjs) - ! used = send_data (id_snow, snow, time, is_in = iis, js_in = jjs) - ! if (mp_print .and. seconds == 0) then - ! tot_prec = g_sum (snow, is, ie, js, je, area, 1) - ! if (root_proc) write (*, *) 'mean snow = ', tot_prec - ! endif - ! endif - ! - ! if (id_graupel > 0) then - ! used = send_data (id_graupel, graupel, time, iis, jjs) - ! used = send_data (id_graupel, graupel, time, is_in = iis, js_in = jjs) - ! if (mp_print .and. seconds == 0) then - ! tot_prec = g_sum (graupel, is, ie, js, je, area, 1) - ! if (root_proc) write (*, *) 'mean graupel = ', tot_prec - ! endif - ! endif - ! - ! if (id_ice > 0) then - ! used = send_data (id_ice, ice, time, iis, jjs) - ! used = send_data (id_ice, ice, time, is_in = iis, js_in = jjs) - ! if (mp_print .and. seconds == 0) then - ! tot_prec = g_sum (ice, is, ie, js, je, area, 1) - ! if (root_proc) write (*, *) 'mean ice_mp = ', tot_prec - ! endif - ! endif - ! - ! if (id_rain > 0) then - ! used = send_data (id_rain, rain, time, iis, jjs) - ! used = send_data (id_rain, rain, time, is_in = iis, js_in = jjs) - ! if (mp_print .and. seconds == 0) then - ! tot_prec = g_sum (rain, is, ie, js, je, area, 1) - ! if (root_proc) write (*, *) 'mean rain = ', tot_prec - ! endif - ! endif - ! - ! if (id_rh > 0) then !not used? - ! used = send_data (id_rh, rh0, time, iis, jjs) - ! used = send_data (id_rh, rh0, time, is_in = iis, js_in = jjs) - ! endif - ! - ! - ! if (id_prec > 0) then - ! used = send_data (id_prec, prec_mp, time, iis, jjs) - ! used = send_data (id_prec, prec_mp, time, is_in = iis, js_in = jjs) - ! endif - - ! if (mp_print) then - ! prec1 (:, :) = prec1 (:, :) + prec_mp (:, :) - ! if (seconds == 0) then - ! prec1 (:, :) = prec1 (:, :) * dt_in / 86400. - ! tot_prec = g_sum (prec1, is, ie, js, je, area, 1) - ! if (root_proc) write (*, *) 'daily prec_mp = ', tot_prec - ! prec1 (:, :) = 0. - ! endif - ! endif - - ! call mpp_clock_end (gfdl_mp_clock) - end subroutine gfdl_cloud_microphys_driver ! ----------------------------------------------------------------------- @@ -624,7 +509,7 @@ end subroutine gfdl_cloud_microphys_driver !>@param 6) qg: graupel (kg / kg) ! ----------------------------------------------------------------------- subroutine mpdrv (hydrostatic, uin, vin, w, delp, pt, qv, ql, qr, qi, qs, & - qg, qa, qn, dz, is, ie, js, je, ks, ke, ktop, kbot, j, dt_in, ntimes, & + qg, qa, qnl, qni, dz, is, ie, js, je, ks, ke, ktop, kbot, j, dt_in, ntimes, & rain, snow, graupel, ice, m2_rain, m2_sol, cond, area1, land, & cnv_fraction, srf_type, eis, rhcrit, anv_icefall, lsc_icefall, revap, isubl, & u_dt, v_dt, pt_dt, qv_dt, ql_dt, qr_dt, qi_dt, qs_dt, qg_dt, qa_dt, & @@ -649,7 +534,7 @@ subroutine mpdrv (hydrostatic, uin, vin, w, delp, pt, qv, ql, qr, qi, qs, & real, intent (in) :: anv_icefall, lsc_icefall real, intent (in), dimension (is:, js:, ks:) :: uin, vin, delp, pt, dz - real, intent (in), dimension (is:, js:, ks:) :: qv, qi, ql, qr, qs, qg, qa, qn + real, intent (in), dimension (is:, js:, ks:) :: qv, qi, ql, qr, qs, qg, qa, qnl, qni real, intent (inout), dimension (is:, js:, ks:) :: u_dt, v_dt, w, pt_dt, qa_dt real, intent (inout), dimension (is:, js:, ks:) :: qv_dt, ql_dt, qr_dt, qi_dt, qs_dt, qg_dt @@ -669,12 +554,12 @@ subroutine mpdrv (hydrostatic, uin, vin, w, delp, pt, qv, ql, qr, qi, qs, & real, dimension (ktop:kbot) :: dp0, dp1, dz0, dz1 real, dimension (ktop:kbot) :: qv0, ql0, qr0, qi0, qs0, qg0, qa0 real, dimension (ktop:kbot) :: t0, den, den0, tz, p1, denfac - real, dimension (ktop:kbot) :: ccn, c_praut, m1_rain, m1_sol, m1, evap1, subl1 + real, dimension (ktop:kbot) :: ccn_l, ccn_i, c_praut, m1_rain, m1_sol, m1, evap1, subl1 real, dimension (ktop:kbot) :: u0, v0, u1, v1, w1 - real :: onemsig + real :: onemsig, fac_eis real :: cpaut, rh_adj, rh_rain - real :: r1, s1, i1, g1, rdt, ccn0 + real :: r1, s1, i1, g1, rdt real :: dts real :: s_leng, t_land, t_ocean, h_var real :: cvm, tmp, omq @@ -764,31 +649,28 @@ subroutine mpdrv (hydrostatic, uin, vin, w, delp, pt, qv, ql, qr, qi, qs, & enddo endif + ! 1 minus sigma used to control resolution sensitive parameters + onemsig = 1.0 - sigma(sqrt(area1(i))) + ! ----------------------------------------------------------------------- ! calculate cloud condensation nuclei (ccn) ! the following is based on klein eq. 15 ! ----------------------------------------------------------------------- - - cpaut = c_paut * 0.104 * grav / 1.717e-5 - - ! 1 minus sigma used to control minimum cloud fraction needed to autoconvert ql->qr - onemsig = 1.0 - sigma(sqrt(area1(i))) + if (srf_type(i) < 2.0) then ! exclude snow/ice covered regions + fac_eis = min(1.0,eis(i)/10.0)**2 ! Estimated inversion strength determine stable regime + cpaut = c_paut * (0.75*fac_eis + (1.0-fac_eis)) ! scaling autoconversion for stable->unstable + else + fac_eis = 0.0 + cpaut = c_paut + endif ! ccn needs units #/m^3 - if (prog_ccn) then - do k = ktop, kbot - ! qn has units # / m^3 - ccn (k) = qn (i, j, k) - c_praut (k) = cpaut * (ccn (k) * rhor) ** (- 1. / 3.) - enddo - else do k = ktop, kbot - ! qn has units # / m^3 - ccn (k) = qn (i, j, k) -!!! use GEOS ccn: ccn (k) = (ccn_l * land (i) + ccn_o * (1. - land (i))) * 1.e6 - c_praut (k) = cpaut * (ccn (k) * rhor) ** (- 1. / 3.) + ! qnl has units # / m^3 + ccn_i (k) = qni (i, j, k) + ccn_l (k) = qnl (i, j, k) + c_praut (k) = cpaut * (ccn_l (k) * rhor) ** (- 1. / 3.) enddo - endif ! ----------------------------------------------------------------------- ! fix all negative water species @@ -827,7 +709,7 @@ subroutine mpdrv (hydrostatic, uin, vin, w, delp, pt, qv, ql, qr, qi, qs, & ! ----------------------------------------------------------------------- call fall_speed (ktop, kbot, p1, cnv_fraction(i), anv_icefall, lsc_icefall, & - den, qsz, qiz, qgz, qlz, tz, vtsz, vtiz, vtgz) + onemsig, den, qsz, qiz, qgz, qlz, tz, vtsz, vtiz, vtgz) call terminal_fall (dts, ktop, kbot, tz, qvz, qlz, qrz, qgz, qsz, qiz, & dz1, dp1, den, vtgz, vtsz, vtiz, r1, g1, s1, i1, m1_sol, w1) @@ -850,7 +732,7 @@ subroutine mpdrv (hydrostatic, uin, vin, w, delp, pt, qv, ql, qr, qi, qs, & ! ----------------------------------------------------------------------- call warm_rain (dts, ktop, kbot, dp1, dz1, tz, qvz, qlz, qrz, qiz, qsz, & - qgz, qaz, eis(i), onemsig, den, denfac, ccn, c_praut, vtrz, & + qgz, qaz, fac_eis, onemsig, den, denfac, ccn_l, c_praut, vtrz, & r1, evap1, m1_rain, w1, h_var1d) rain (i) = rain (i) + r1 @@ -868,7 +750,7 @@ subroutine mpdrv (hydrostatic, uin, vin, w, delp, pt, qv, ql, qr, qi, qs, & call icloud (ktop, kbot, tz, p1, qvz, qlz, qrz, qiz, qsz, qgz, dp1, den, & denfac, vtsz, vtgz, vtrz, qaz, dts, subl1, h_var1d, & - ccn, cnv_fraction(i), srf_type(i)) + ccn_i, cnv_fraction(i), srf_type(i), onemsig) do k = ktop, kbot isubl (i,j,k) = isubl (i,j,k) + subl1(k) @@ -897,6 +779,13 @@ subroutine mpdrv (hydrostatic, uin, vin, w, delp, pt, qv, ql, qr, qi, qs, & enddo endif + ! ----------------------------------------------------------------------- + ! fix all negative water species + ! ----------------------------------------------------------------------- + + if (fix_negative) & + call neg_adj (ktop, kbot, tz, dp1, qvz, qlz, qrz, qiz, qsz, qgz) + ! ----------------------------------------------------------------------- ! update moist air mass (actually hydrostatic pressure) ! convert to dry mixing ratios @@ -936,32 +825,32 @@ subroutine mpdrv (hydrostatic, uin, vin, w, delp, pt, qv, ql, qr, qi, qs, & ! endif ! ! if (id_vtr > 0) then - ! do k = ktop, kbot - ! vt_r (i, j, k) = vtrz (k) - ! enddo + do k = ktop, kbot + vt_r (i, j, k) = vtrz (k) + enddo ! endif ! ! if (id_vts > 0) then - ! do k = ktop, kbot - ! vt_s (i, j, k) = vtsz (k) - ! enddo + do k = ktop, kbot + vt_s (i, j, k) = vtsz (k) + enddo ! endif ! ! if (id_vtg > 0) then - ! do k = ktop, kbot - ! vt_g (i, j, k) = vtgz (k) - ! enddo + do k = ktop, kbot + vt_g (i, j, k) = vtgz (k) + enddo ! endif ! ! if (id_vts > 0) then - ! do k = ktop, kbot - ! vt_i (i, j, k) = vtiz (k) - ! enddo + do k = ktop, kbot + vt_i (i, j, k) = vtiz (k) + enddo ! endif ! ! if (id_droplets > 0) then ! do k = ktop, kbot - ! qn2 (i, j, k) = ccn (k) + ! qn2 (i, j, k) = ccn_l (k) ! enddo ! endif @@ -1029,7 +918,7 @@ end subroutine sedi_heat ! ----------------------------------------------------------------------- subroutine warm_rain (dt, ktop, kbot, dp, dz, tz, qv, ql, qr, qi, qs, qg, qa, & - eis, onemsig, & + fac_eis, onemsig, & den, denfac, ccn, c_praut, vtr, r1, evap1, m1_rain, w1, h_var) implicit none @@ -1044,7 +933,7 @@ subroutine warm_rain (dt, ktop, kbot, dp, dz, tz, qv, ql, qr, qi, qs, qg, qa, & real, intent (in), dimension (ktop:kbot) :: denfac, ccn, c_praut real, intent (in) :: onemsig - real, intent (in) :: eis !< estimated inversion strength + real, intent (in) :: fac_eis !< estimated inversion strength real, intent (inout), dimension (ktop:kbot) :: tz, vtr real, intent (inout), dimension (ktop:kbot) :: qv, ql, qr, qi, qs, qg, qa @@ -1083,6 +972,7 @@ subroutine warm_rain (dt, ktop, kbot, dp, dz, tz, qv, ql, qr, qi, qs, qg, qa, & call check_column (ktop, kbot, qr, no_fall) + ! ----------------------------------------------------------------------- ! auto - conversion ! assuming linear subgrid vertical distribution of cloud water @@ -1090,7 +980,7 @@ subroutine warm_rain (dt, ktop, kbot, dp, dz, tz, qv, ql, qr, qi, qs, qg, qa, & ! ----------------------------------------------------------------------- ! Use In-Cloud condensates - if (.not. do_qa) then + if (in_cloud) then qadum = max(qa,qcmin) else qadum = 1.0 @@ -1098,8 +988,7 @@ subroutine warm_rain (dt, ktop, kbot, dp, dz, tz, qv, ql, qr, qi, qs, qg, qa, & ql = ql/qadum qi = qi/qadum - fac_rc = min(1.0,eis/15.0)**2 ! Estimated inversion strength determine stable regime - fac_rc = rc * (rthreshs*fac_rc + rthreshu*(1.0-fac_rc)) ** 3 + fac_rc = rc * (rthreshs*fac_eis + rthreshu*(1.0-fac_eis)) ** 3 if (irain_f /= 0) then @@ -1108,29 +997,30 @@ subroutine warm_rain (dt, ktop, kbot, dp, dz, tz, qv, ql, qr, qi, qs, qg, qa, & ! ----------------------------------------------------------------------- do k = ktop, kbot - if (qadum(k) > onemsig) then if (tz (k) > t_wfr) then qc = fac_rc * ccn (k) / den (k) dq = ql (k) - qc if (dq > 0.) then sink = min (dq, dt * c_praut (k) * den (k) * exp (so3 * log (ql (k)))) - sink = min(ql0_max, ql(k), max(0.,sink)) + sink = min(ql0_max/qadum(k), ql(k), max(0.,sink)) ql (k) = ql (k) - sink qr (k) = qr (k) + sink*qadum(k) + ! new total condensate / old condensate + qa (k) = max(0.0,min(1.,qa (k) * max(qadum(k)*(qi (k)+ql (k)-sink),0.0 ) / & + max(qadum(k)*(qi (k)+ql (k) ),qcmin) ) ) endif endif - endif enddo else + ! ----------------------------------------------------------------------- ! with subgrid variability ! ----------------------------------------------------------------------- call linear_prof (kbot - ktop + 1, ql (ktop), dl (ktop), z_slope_liq, h_var) do k = ktop, kbot - if (qadum(k) > onemsig) then if (tz (k) > t_wfr + dt_fr) then dl (k) = min (max (qcmin, dl (k)), 0.5 * ql (k)) ! -------------------------------------------------------------------- @@ -1147,27 +1037,30 @@ subroutine warm_rain (dt, ktop, kbot, dp, dz, tz, qv, ql, qr, qi, qs, qg, qa, & ! revised continuous form: linearly decays (with subgrid dl) to zero at qc == ql + dl ! -------------------------------------------------------------------- sink = min (1., dq / dl (k)) * dt * c_praut (k) * den (k) * exp (so3 * log (ql (k))) - sink = min(ql0_max, ql(k), max(0.,sink)) + sink = min(ql0_max/qadum(k), ql(k), max(0.,sink)) ql (k) = ql (k) - sink qr (k) = qr (k) + sink*qadum(k) + ! new total condensate / old condensate + qa (k) = max(0.0,min(1.,qa (k) * max(qadum(k)*(qi (k)+ql (k) ),0.0 ) / & + max(qadum(k)*(qi (k)+ql (k)+sink),qcmin) ) ) endif endif - endif enddo + endif ! Revert In-Cloud condensate ql = ql*qadum qi = qi*qadum - + ! ----------------------------------------------------------------------- ! fall speed of rain ! ----------------------------------------------------------------------- if (no_fall) then - vtr (:) = vf_min + vtr (:) = vr_min elseif (const_vr) then - vtr (:) = vr_fac ! ifs_2016: 4.0 + vtr (:) = 0.5*(vr_min+vr_max) else do k = ktop, kbot qden = qr (k) * den (k) @@ -1272,25 +1165,16 @@ subroutine revap_racc (ktop, kbot, dt, tz, qv, ql, qr, qi, qs, qg, qa, revap, de real :: dqv, qsat, dqsdt, evap, t2, qden, q_plus, q_minus, sink real :: qpz, dq, dqh, tin real :: fac_revp - real :: TOT_PREC_LS, AREA_LS_PRC, AREA_LS_PRC_K integer :: k revap(:) = 0. - TOT_PREC_LS = 0. - AREA_LS_PRC = 0. do k = ktop, kbot - TOT_PREC_LS = TOT_PREC_LS + ( ( qr (k) + qs (k) + qg (k) ) * den (k) ) - AREA_LS_PRC = AREA_LS_PRC + ( qa (k) * ( qr (k) + qs (k) + qg (k) ) * den (k) ) - if (tz (k) > t_wfr .and. qr (k) > qpmin) then - !! area and timescale efficiency on revap - ! AREA_LS_PRC_K = 0.0 - !if (TOT_PREC_LS > 0.0) AREA_LS_PRC_K = MAX( AREA_LS_PRC/TOT_PREC_LS, 1.E-6 ) - !fac_revp = 1. - exp (- AREA_LS_PRC_K * dt / tau_revp) - fac_revp = 1. - exp (- dt / tau_revp) + ! timescale efficiency on revap + fac_revp = 1. - exp (- dt / tau_revp) * qa (k) ! Increase revp when no clouds present (WMP) ! ----------------------------------------------------------------------- ! define heat capacity and latent heat coefficient @@ -1307,7 +1191,7 @@ subroutine revap_racc (ktop, kbot, dt, tz, qv, ql, qr, qi, qs, qg, qa, revap, de qsat = wqs2 (tin, den (k), dqsdt) dqh = max (ql (k), h_var(k) * max (qpz, qcmin)) dqh = min (dqh, 0.2 * qpz) ! new limiter - dqv = qsat - qv (k) ! use this to prevent super - sat the gird box + dqv = qsat - qv (k) ! use this to prevent super - sat the grid box q_minus = qpz - dqh q_plus = qpz + dqh @@ -1349,7 +1233,12 @@ subroutine revap_racc (ktop, kbot, dt, tz, qv, ql, qr, qi, qs, qg, qa, revap, de if (qr (k) > qpmin .and. ql (k) > qcmin .and. qsat < q_minus) then sink = dt * denfac (k) * cracw * exp (0.95 * log (qr (k) * den (k))) - sink = sink / (1. + sink) * ql (k) + sink = ql (k) * sink / (1. + sink) + + ! new total condensate / old condensate + qa (k) = max(0.0,min(1.,qa (k) * max(qi (k)+ql (k)-sink,0.0 ) / & + max(qi (k)+ql (k) ,qcmin) ) ) + ql (k) = ql (k) - sink qr (k) = qr (k) + sink endif @@ -1428,7 +1317,7 @@ end subroutine linear_prof ! ======================================================================= subroutine icloud (ktop, kbot, tzk, p1, qvk, qlk, qrk, qik, qsk, qgk, dp1, & - den, denfac, vts, vtg, vtr, qak, dts, subl1, h_var, ccn, cnv_fraction, srf_type) + den, denfac, vts, vtg, vtr, qak, dts, subl1, h_var, ccn, cnv_fraction, srf_type, onemsig) implicit none @@ -1440,14 +1329,14 @@ subroutine icloud (ktop, kbot, tzk, p1, qvk, qlk, qrk, qik, qsk, qgk, dp1, & real, intent (out), dimension (ktop:kbot) :: subl1 - real, intent (in) :: dts, cnv_fraction, srf_type + real, intent (in) :: dts, cnv_fraction, srf_type, onemsig real, intent (in), dimension (ktop:kbot) :: h_var, ccn real, dimension (ktop:kbot) :: lcpk, icpk, tcpk, di, lhl, lhi real, dimension (ktop:kbot) :: cvm, q_liq, q_sol - real :: rdts, fac_g2v, fac_i2s, fac_imlt, fac_frz, newice, newliq + real :: rdts, fac_i2s, fac_imlt, fac_frz, newice, newliq real :: tz, qv, ql, qr, qi, qs, qg, melt, frez, ifrac, newqi, newql real :: pracs, psacw, pgacw, psacr, pgacr, pgaci, praci, psaci real :: pgmlt, psmlt, pgfr, pgaut, psaut, pgsub @@ -1455,6 +1344,8 @@ subroutine icloud (ktop, kbot, tzk, p1, qvk, qlk, qrk, qik, qsk, qgk, dp1, & real :: factor, sink, qi_crt real :: tmp, qsw, qsi, dqsdt, dq real :: dtmp, qc, q_plus, q_minus + real :: qadum + real :: critical_qi_factor integer :: k, it @@ -1464,9 +1355,7 @@ subroutine icloud (ktop, kbot, tzk, p1, qvk, qlk, qrk, qik, qsk, qgk, dp1, & ! define conversion scalar / factor ! ----------------------------------------------------------------------- - fac_i2s = 1. - exp (- dts / tau_i2s) - fac_g2v = 1. - exp (- dts / tau_g2v) - + fac_i2s = 1. - exp (- dts / tau_i2s) fac_imlt = 1. - exp (- dts / tau_imlt) fac_frz = 1. - exp (- dts / tau_frz) @@ -1489,53 +1378,64 @@ subroutine icloud (ktop, kbot, tzk, p1, qvk, qlk, qrk, qik, qsk, qgk, dp1, & ! sat_adj (deposition; requires pre - existing snow) ; initial snow comes from auto conversion ! ----------------------------------------------------------------------- - do k = ktop, kbot - newice = max(0.0,qik (k) + new_ice_condensate(tzk (k), qlk (k), qik (k), cnv_fraction, srf_type)) - newliq = max(0.0,qlk (k) + qik (k) - newice) + ! Use In-Cloud condensates + if (in_cloud) then + qadum = max(qak(k),qcmin) + else + qadum = 1.0 + endif - melt = fac_imlt * max(0.0,newliq - qlk (k)) - frez = fac_frz * max(0.0,newice - qik (k)) + ql = qlk (k)/qadum + qi = qik (k)/qadum - if (melt > 0.0 .and. tzk (k) > tice .and. qik (k) > qcmin) then + if (tzk (k) > tice .and. qi > qcmin) then ! ----------------------------------------------------------------------- ! pimlt: melting of cloud ice ! ----------------------------------------------------------------------- - tmp = min (melt, dim (ql_mlt, qlk (k))) ! max ql amount + newliq = new_liq_condensate(tzk (k), ql, qi, cnv_fraction, srf_type) + melt = fac_imlt * min (qi, newliq, (tzk (k) - tice) / icpk (k)) + tmp = min (melt, dim (ql_mlt/qadum, ql)) ! new total condensate / old condensate - qak(k) = max(0.0,min(1.,qak(k) * max(qik(k)+qlk(k)-melt+tmp,0.0 ) / & - max(qik(k)+qlk(k) ,qcmin) ) ) - - qlk (k) = qlk (k) + tmp - qrk (k) = qrk (k) + melt - tmp - qik (k) = qik (k) - melt - q_liq (k) = q_liq (k) + melt - q_sol (k) = q_sol (k) - melt + qak(k) = max(0.0,min(1.,qak(k) * max(qi+ql-melt+tmp,0.0 ) / & + max(qi+ql ,qcmin) ) ) + + ql = ql + tmp + qrk (k) = qrk (k) + (melt - tmp)*qadum + qi = qi - melt + q_liq (k) = q_liq (k) + melt*qadum + q_sol (k) = q_sol (k) - melt*qadum cvm (k) = c_air + qvk (k) * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice - tzk (k) = tzk (k) - melt * lhi (k) / cvm (k) - elseif (frez > 0.0 .and. tzk (k) <= tice .and. qlk (k) > qcmin) then + tzk (k) = tzk (k) - melt*qadum * lhi (k) / cvm (k) + elseif (tzk (k) <= tice .and. ql > qcmin) then ! ----------------------------------------------------------------------- ! pihom: homogeneous freezing of cloud water into cloud ice ! this is the 1st occurance of liquid water freezing in the split mp process ! ----------------------------------------------------------------------- - qi_crt = ice_fraction(tzk(k),cnv_fraction,srf_type) * qi0_crt / den (k) - tmp = min (frez, dim (qi_crt, qik (k))) + newice = new_ice_condensate(tzk (k), ql, qi, cnv_fraction, srf_type) + frez = fac_frz * min(ql, newice, ql * (tice - tzk (k)) / icpk (k)) + qi_crt = qi_gen / den (k) + tmp = min (frez, dim (qi_crt/qadum, qi)) ! new total condensate / old condensate - qak(k) = max(0.0,min(1.,qak(k) * max(qik(k)+qlk(k)-frez+tmp,0.0 ) / & - max(qik(k)+qlk(k) ,qcmin) ) ) - - qlk (k) = qlk (k) - frez - qsk (k) = qsk (k) + frez - tmp - qik (k) = qik (k) + tmp - q_liq (k) = q_liq (k) - frez - q_sol (k) = q_sol (k) + frez + qak(k) = max(0.0,min(1.,qak(k) * max(qi+ql-frez+tmp,0.0 ) / & + max(qi+ql ,qcmin) ) ) + + ql = ql - frez + qsk (k) = qsk (k) + (frez - tmp)*qadum + qi = qi + tmp + q_liq (k) = q_liq (k) - frez*qadum + q_sol (k) = q_sol (k) + frez*qadum cvm (k) = c_air + qvk (k) * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice - tzk (k) = tzk (k) + frez * lhi (k) / cvm (k) + tzk (k) = tzk (k) + frez*qadum * lhi (k) / cvm (k) endif + ! Revert In-Cloud condensate + qlk (k) = ql*qadum + qik (k) = qi*qadum + enddo ! ----------------------------------------------------------------------- @@ -1574,9 +1474,8 @@ subroutine icloud (ktop, kbot, tzk, p1, qvk, qlk, qrk, qik, qsk, qgk, dp1, & pgacr = 0. pgacw = 0. - tc = tz - tice - if (tc .ge. 0.) then + if (tz > tice) then ! ----------------------------------------------------------------------- ! melting of snow @@ -1588,7 +1487,7 @@ subroutine icloud (ktop, kbot, tzk, p1, qvk, qlk, qrk, qik, qsk, qgk, dp1, & ! ----------------------------------------------------------------------- ! psacw: accretion of cloud water by snow - ! only rate is used (for snow melt) since tc > 0. + ! only rate is used (for snow melt) since tz > tice ! ----------------------------------------------------------------------- if (ql > qcmin) then @@ -1617,26 +1516,23 @@ subroutine icloud (ktop, kbot, tzk, p1, qvk, qlk, qrk, qik, qsk, qgk, dp1, & ! psmlt: snow melt (due to rain accretion) ! ----------------------------------------------------------------------- + tc = tz - tice psmlt = max (0., smlt (tc, dqs0, qs * den (k), psacw, psacr, csmlt, & den (k), denfac (k))) sink = min (qs, dts * (psmlt + pracs), tc / icpk (k)) qs = qs - sink - ! sjl, 20170321: tmp = min (sink, dim (qs_mlt, ql)) ! max ql due to snow melt - ! new total condensate / old condensate - qak(k) = max(0.0,min(1.,qak(k) * max(qi+ql+tmp,0.0 ) / & - max(qi+ql ,qcmin) ) ) + ! new total condensate / old condensate + qak(k) = max(0.0,min(1.,qak(k) * max(qi+ql+tmp,0.0 ) / & + max(qi+ql ,qcmin) ) ) ql = ql + tmp qr = qr + sink - tmp - ! qr = qr + sink - ! sjl, 20170321: q_liq (k) = q_liq (k) + sink q_sol (k) = q_sol (k) - sink cvm (k) = c_air + qv * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice tz = tz - sink * lhi (k) / cvm (k) - tc = tz - tice endif @@ -1651,7 +1547,7 @@ subroutine icloud (ktop, kbot, tzk, p1, qvk, qlk, qrk, qik, qsk, qgk, dp1, & ! melting of graupel ! ----------------------------------------------------------------------- - if (qg > qpmin .and. tc > 0.) then + if (qg > qpmin .and. tz > tice) then ! ----------------------------------------------------------------------- ! pgacr: accretion of rain by graupel @@ -1675,7 +1571,8 @@ subroutine icloud (ktop, kbot, tzk, p1, qvk, qlk, qrk, qik, qsk, qgk, dp1, & ! pgmlt: graupel melt ! ----------------------------------------------------------------------- - pgmlt = dts * gmlt (tc, dqs0, qden, pgacw, pgacr, cgmlt, den (k)) + tc = tz - tice + pgmlt = dts * gmlt (tc, dqs0, qg * den (k), pgacw, pgacr, cgmlt, den (k)) pgmlt = min (max (0., pgmlt), qg, tc / icpk (k)) qg = qg - pgmlt qr = qr + pgmlt @@ -1696,7 +1593,9 @@ subroutine icloud (ktop, kbot, tzk, p1, qvk, qlk, qrk, qik, qsk, qgk, dp1, & ! psaci: accretion of cloud ice by snow ! ----------------------------------------------------------------------- - if (qi > 3.e-7) then ! cloud ice sink terms + if (qi > 3.e-7 .and. tz < tice) then ! cloud ice sink terms + + tc = tz - tice if (qs > qpmin) then ! ----------------------------------------------------------------------- @@ -1704,7 +1603,7 @@ subroutine icloud (ktop, kbot, tzk, p1, qvk, qlk, qrk, qik, qsk, qgk, dp1, & ! to reduce accretion, use esi = exp (0.05 * tc) as in hong et al 2004 ! ----------------------------------------------------------------------- factor = dts * denfac (k) * csaci * exp (0.05 * tc + 0.8125 * log (qs * den (k))) - psaci = factor / (1. + factor) * qi + psaci = qi * factor / (1. + factor) else psaci = 0. endif @@ -1715,22 +1614,22 @@ subroutine icloud (ktop, kbot, tzk, p1, qvk, qlk, qrk, qik, qsk, qgk, dp1, & ! ----------------------------------------------------------------------- ! similar to lfo 1983: eq. 21 solved implicitly - ! threshold from wsm6 scheme, hong et al 2004, eq (13) : qi0_crt ~0.8e-4 + ! threshold from wsm6 scheme, hong et al 2004, eq (13) + ! slight decrease in critical_qi_factor at warmer temps ! ----------------------------------------------------------------------- - - qim = ice_fraction(tz,cnv_fraction,srf_type) * qi0_crt / den (k) + ! qi0_crt (ice to snow conversion) has strong resolution dependence + ! account for this using onemsig to convert more ice to snow at coarser resolutions + critical_qi_factor = qi0_crt*(onemsig + 1.e-1*(1.0-onemsig)) + + ! use ice_fraction to convert more ice to snow closer to 0-cel + qim = ice_fraction(tz, cnv_fraction, srf_type) * critical_qi_factor / den (k) + ! ----------------------------------------------------------------------- ! assuming linear subgrid vertical distribution of cloud ice ! the mismatch computation following lin et al. 1994, mwr ! ----------------------------------------------------------------------- - if (const_vi) then - tmp = fac_i2s - else - tmp = fac_i2s * exp (0.025 * tc) - endif - di (k) = max (di (k), qcmin) q_plus = qi + di (k) if (q_plus > (qim + qcmin)) then @@ -1739,15 +1638,15 @@ subroutine icloud (ktop, kbot, tzk, p1, qvk, qlk, qrk, qik, qsk, qgk, dp1, & else dq = qi - qim endif - psaut = tmp * dq + psaut = fac_i2s * exp (0.025 * tc) * dq else psaut = 0. endif sink = min (qi, psaci + psaut) ! new total condensate / old condensate - qak(k) = max(0.0,min(1.,qak(k) * max(qi+ql-sink+tmp,0.0 ) / & - max(qi+ql ,qcmin) ) ) + qak(k) = max(0.0,min(1.,qak(k) * max(qi+ql-sink,0.0 ) / & + max(qi+ql ,qcmin) ) ) qi = qi - sink qs = qs + sink @@ -1763,6 +1662,11 @@ subroutine icloud (ktop, kbot, tzk, p1, qvk, qlk, qrk, qik, qsk, qgk, dp1, & ! ----------------------------------------------------------------------- factor = dts * cgaci * sqrt (den (k)) * qg pgaci = factor / (1. + factor) * qi + + ! new total condensate / old condensate + qak(k) = max(0.0,min(1.,qak(k) * max(qi+ql-pgaci,0.0 ) / & + max(qi+ql ,qcmin) ) ) + qi = qi - pgaci qg = qg + pgaci endif @@ -1777,9 +1681,9 @@ subroutine icloud (ktop, kbot, tzk, p1, qvk, qlk, qrk, qik, qsk, qgk, dp1, & ! rain to ice, snow, graupel processes: ! ----------------------------------------------------------------------- - tc = tz - tice + if (qr > qpmin .and. tz < tice) then - if (qr > qpmin .and. tc < 0.) then + tc = tz - tice ! ----------------------------------------------------------------------- ! * sink * terms to qr: psacr + pgfr @@ -1836,7 +1740,7 @@ subroutine icloud (ktop, kbot, tzk, p1, qvk, qlk, qrk, qik, qsk, qgk, dp1, & ! graupel production terms: ! ----------------------------------------------------------------------- - if (qs > qpmin) then + if (qs > qpmin .and. tz < tice0) then ! ----------------------------------------------------------------------- ! accretion: snow -- > graupel @@ -1855,7 +1759,7 @@ subroutine icloud (ktop, kbot, tzk, p1, qvk, qlk, qrk, qik, qsk, qgk, dp1, & qsm = qs0_crt / den (k) if (qs > qsm) then factor = dts * 1.e-3 * exp (0.09 * (tz - tice)) - sink = sink + factor / (1. + factor) * (qs - qsm) + sink = sink + (qs - qsm) * factor / (1. + factor) endif sink = min (qs, sink) qs = qs - sink @@ -1921,7 +1825,7 @@ subroutine icloud (ktop, kbot, tzk, p1, qvk, qlk, qrk, qik, qsk, qgk, dp1, & ! ----------------------------------------------------------------------- call subgrid_z_proc (ktop, kbot, p1, den, denfac, dts, tzk, qvk, & - qlk, qrk, qik, qsk, qgk, qak, subl1, h_var, ccn, cnv_fraction, srf_type) + qlk, qrk, qik, qsk, qgk, qak, subl1, h_var, ccn, cnv_fraction, srf_type, onemsig) end subroutine icloud @@ -1930,7 +1834,7 @@ end subroutine icloud ! ======================================================================= subroutine subgrid_z_proc (ktop, kbot, p1, den, denfac, dts, tz, qv, & - ql, qr, qi, qs, qg, qa, subl1, h_var, ccn, cnv_fraction, srf_type) + ql, qr, qi, qs, qg, qa, subl1, h_var, ccn, cnv_fraction, srf_type, onemsig) implicit none @@ -1938,7 +1842,7 @@ subroutine subgrid_z_proc (ktop, kbot, p1, den, denfac, dts, tz, qv, & real, intent (in), dimension (ktop:kbot) :: p1, den, denfac - real, intent (in) :: dts, cnv_fraction, srf_type + real, intent (in) :: dts, cnv_fraction, srf_type, onemsig real, intent (in), dimension (ktop:kbot) :: h_var, ccn @@ -1949,7 +1853,7 @@ subroutine subgrid_z_proc (ktop, kbot, p1, den, denfac, dts, tz, qv, & real, dimension (ktop:kbot) :: lcpk, icpk, tcpk, tcp3, lhl, lhi real, dimension (ktop:kbot) :: cvm, q_liq, q_sol, q_cond - real :: fac_v2l, fac_l2v, fac_i2v + real :: fac_l2v, fac_i2v real :: pidep, qi_crt @@ -1972,7 +1876,6 @@ subroutine subgrid_z_proc (ktop, kbot, p1, den, denfac, dts, tz, qv, & ! define conversion scalar / factor ! ----------------------------------------------------------------------- - fac_v2l = 1. - exp (- dts / tau_v2l) fac_l2v = 1. - exp (- dts / tau_l2v) fac_i2v = 1. - exp (- dts / tau_i2v) fac_s2v = 1. - exp (- dts / tau_s2v) @@ -1999,8 +1902,8 @@ subroutine subgrid_z_proc (ktop, kbot, p1, den, denfac, dts, tz, qv, & do k = ktop, kbot - rh_adj = 1. - h_var(k) - rh_inc - rh_rain = max (0.35, rh_adj - rh_inr) + rh_adj = 1. - h_var(k) - rh_inc + rh_rain = max (0.35, 1. - h_var(k) - rh_inr) subl1(k) = 0.0 @@ -2017,7 +1920,7 @@ subroutine subgrid_z_proc (ktop, kbot, p1, den, denfac, dts, tz, qv, & q_sol (k) = q_sol (k) + sink cvm (k) = c_air + qv (k) * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice tz (k) = tz (k) + sink * (lhl (k) + lhi (k)) / cvm (k) - if (do_qa) qa (k) = 1. ! air fully saturated; 100 % cloud cover + qa (k) = 1. ! air fully saturated; 100 % cloud cover cycle endif @@ -2032,41 +1935,46 @@ subroutine subgrid_z_proc (ktop, kbot, p1, den, denfac, dts, tz, qv, & tcpk (k) = lcpk (k) + icpk (k) tcp3 (k) = lcpk (k) + icpk (k) * min (1., dim (tice, tz (k)) / (tice - t_wfr)) - ! ----------------------------------------------------------------------- - ! instant evaporation / sublimation of all clouds if rh < rh_adj -- > cloud free - ! ----------------------------------------------------------------------- - qpz = qv (k) + ql (k) + qi (k) - tin = tz (k) - (lhl (k) * (ql (k) + qi (k)) + lhi (k) * qi (k)) / (c_air + & - qpz * c_vap + qr (k) * c_liq + (qs (k) + qg (k)) * c_ice) - if (tin > t_sub + 6.) then - rh = qpz / iqs1 (tin, den (k)) - if (rh < rh_adj) then ! qpz / rh_adj < qs - tz (k) = tin - qv (k) = qpz - ql (k) = 0. - qi (k) = 0. - if (do_qa) qa (k) = 0. - cycle ! cloud free - endif - endif - ! ----------------------------------------------------------------------- ! cloud water < -- > vapor adjustment: LS evaporation ! ----------------------------------------------------------------------- if (do_evap) then - qsw = wqs2 (tz (k), den (k), dwsdt) - dq0 = qsw - qv (k) - if (dq0 > qvmin) then - factor = min (1., fac_l2v * (10. * dq0 / qsw)) - evap = min (ql (k), factor * ql(k) / (1. + tcp3 (k) * dwsdt)) - else - evap = 0.0 - endif - qv (k) = qv (k) + evap - ql (k) = ql (k) - evap - q_liq (k) = q_liq (k) - evap - cvm (k) = c_air + qv (k) * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice - tz (k) = tz (k) - evap * lhl (k) / cvm (k) + evap = 0.0 + subl = 0.0 + qpz = qv (k) + ql (k) + qi (k) + tin = tz (k) - (lhl (k) * (ql (k) + qi (k)) + lhi (k) * qi (k)) / (c_air + & + qpz * c_vap + qr (k) * c_liq + (qs (k) + qg (k)) * c_ice) + if (tin > t_sub + 6.) then + rh = qpz / iqs1 (tin, den (k)) + if (rh < rh_adj) then + ! instant evap of all liquid + evap = ql(k) + ! instant subl of all ice + subl = ql(k) + else + ! partial evap of liquid + qsw = wqs2 (tz (k), den (k), dwsdt) + dq0 = qsw - qv (k) + if (dq0 > qvmin) then + factor = min (1., fac_l2v * (10. * dq0 / qsw)) + evap = min (ql (k), factor * ql(k) / (1. + tcp3 (k) * dwsdt)) + endif + endif + endif + + evap = evap*onemsig ! resolution dependent evap 0:1 coarse:fine + subl = subl*onemsig ! resolution dependent subl 0:1 coarse:fine + + ! new total condensate / old condensate + qa(k) = max(0.0,min(1.,qa(k) * max(qi(k)+ql(k)-evap-subl,0.0 ) / & + max(qi(k)+ql(k) ,qcmin) ) ) + qv (k) = qv (k) + evap + subl + ql (k) = ql (k) - evap + qi (k) = qi (k) - subl + q_liq (k) = q_liq (k) - evap + q_sol (k) = q_sol (k) - subl + cvm (k) = c_air + qv (k) * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice + tz (k) = tz (k) - evap * lhl (k) / cvm (k) - subl * lhi (k) / cvm (k) endif ! ----------------------------------------------------------------------- @@ -2141,21 +2049,24 @@ subroutine subgrid_z_proc (ktop, kbot, p1, den, denfac, dts, tz, qv, & endif if (dq > 0.) then ! vapor - > ice ! deposition - ifrac = ice_fraction(tz (k),cnv_fraction,srf_type) tmp = tice - tz (k) qi_crt = 4.92e-11 * exp (1.33 * log (1.e3 * exp (0.1 * tmp))) - qi_crt = max (qi_crt, 1.82e-6) * qi_lim * ifrac / den (k) + qi_crt = max (qi_crt, 1.82e-6) * min (qi_lim, 0.1 * tmp) / den (k) sink = min (sink, max (qi_crt - qi (k), pidep), tmp / tcpk (k)) else ! ice -- > vapor ! sublimation if (do_subl) then pidep = pidep * min (1., dim (tz (k), t_sub) * 0.2) sink = fac_i2v * max (pidep, sink, - qi (k)) - subl1(k) = subl1(k) + pssub / dts + subl1(k) = subl1(k) - sink / dts else sink = 0. endif + sink = sink*onemsig ! resolution dependent subl 0:1 coarse:fine endif + ! new total condensate / old condensate + qa(k) = max(0.0,min(1.,qa(k) * max(qi(k)+ql(k)+sink,0.0 ) / & + max(qi(k)+ql(k) ,qcmin) ) ) qv (k) = qv (k) - sink qi (k) = qi (k) + sink q_sol (k) = q_sol (k) + sink @@ -2240,7 +2151,6 @@ subroutine subgrid_z_proc (ktop, kbot, p1, den, denfac, dts, tz, qv, & tz (k) = tz (k) + pgsub * (lhl (k) + lhi (k)) / cvm (k) endif -#ifdef USE_MIN_EVAP ! ----------------------------------------------------------------------- ! update capacity heat and latend heat coefficient ! ----------------------------------------------------------------------- @@ -2261,7 +2171,6 @@ subroutine subgrid_z_proc (ktop, kbot, p1, den, denfac, dts, tz, qv, & cvm (k) = c_air + qv (k) * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice tz (k) = tz (k) - sink * lhl (k) / cvm (k) endif -#endif ! ----------------------------------------------------------------------- ! update capacity heat and latend heat coefficient @@ -2470,7 +2379,7 @@ subroutine terminal_fall (dtm, ktop, kbot, tz, qv, ql, qr, qg, qs, qi, dz, dp, & call check_column (ktop, kbot, qi, no_fall) - if (vi_fac < 1.e-5 .or. no_fall) then + if (vi_min < 1.e-5 .or. no_fall) then i1 = 0. else @@ -2489,7 +2398,8 @@ subroutine terminal_fall (dtm, ktop, kbot, tz, qv, ql, qr, qg, qs, qi, dz, dp, & do m = k + 1, kbot if (zt (k + 1) >= ze (m)) exit if (zt (k) < ze (m + 1) .and. tz (m) > tice) then - dtime = min (1.0, (ze (m) - ze (m + 1)) / (max (vr_min, vti (k)) * tau_imlt)) + dtime = min (dtm, (ze (m) - ze (m + 1)) / vti (k)) + dtime = min (1.0, dtime / tau_imlt) sink = min (qi (k) * dp (k) / dp (m), dtime * (tz (m) - tice) / icpk (m)) tmp = min (sink, dim (ql_mlt, ql (m))) ql (m) = ql (m) + tmp @@ -2550,8 +2460,8 @@ subroutine terminal_fall (dtm, ktop, kbot, tz, qv, ql, qr, qg, qs, qi, dz, dp, & if (qs (k) > qpmin) then do m = k + 1, kbot if (zt (k + 1) >= ze (m)) exit - dtime = min (dtm, (ze (m) - ze (m + 1)) / (vr_min + vts (k))) if (zt (k) < ze (m + 1) .and. tz (m) > tice) then + dtime = min (dtm, (ze (m) - ze (m + 1)) / vts (k)) dtime = min (1.0, dtime / tau_smlt) sink = min (qs (k) * dp (k) / dp (m), dtime * (tz (m) - tice) / icpk (m)) tz (m) = tz (m) - sink * icpk (m) @@ -2619,9 +2529,9 @@ subroutine terminal_fall (dtm, ktop, kbot, tz, qv, ql, qr, qg, qs, qi, dz, dp, & if (qg (k) > qpmin) then do m = k + 1, kbot if (zt (k + 1) >= ze (m)) exit - dtime = min (dtm, (ze (m) - ze (m + 1)) / vtg (k)) if (zt (k) < ze (m + 1) .and. tz (m) > tice) then - dtime = min (1., dtime / tau_g2r) + dtime = min (dtm, (ze (m) - ze (m + 1)) / vtg (k)) + dtime = min (1.0, dtime / tau_gmlt) sink = min (qg (k) * dp (k) / dp (m), dtime * (tz (m) - tice) / icpk (m)) tz (m) = tz (m) - sink * icpk (m) qg (k) = qg (k) - sink * dp (m) / dp (k) @@ -3086,13 +2996,13 @@ end subroutine cs_limiters ! ======================================================================= subroutine fall_speed (ktop, kbot, pl, cnv_fraction, anv_icefall, lsc_icefall, & - den, qs, qi, qg, ql, tk, vts, vti, vtg) + onemsig, den, qs, qi, qg, ql, tk, vts, vti, vtg) implicit none integer, intent (in) :: ktop, kbot - real, intent (in) :: cnv_fraction, anv_icefall, lsc_icefall + real, intent (in) :: cnv_fraction, anv_icefall, lsc_icefall, onemsig real, intent (in), dimension (ktop:kbot) :: pl, den, qs, qi, qg, ql, tk real, intent (out), dimension (ktop:kbot) :: vts, vti, vtg @@ -3121,9 +3031,11 @@ subroutine fall_speed (ktop, kbot, pl, cnv_fraction, anv_icefall, lsc_icefall, & real, parameter :: norms = 942477796.076938 real, parameter :: normg = 5026548245.74367 - real, dimension (ktop:kbot) :: qden, tc, rhof + real, dimension (ktop:kbot) :: rhof - real :: vi1, viCNV, viLSC, IWC + real :: tc + real :: zero=0.0 + real :: viCNV, viLSC, IWC real :: rBB, C0, C1, DIAM, lnP integer :: k @@ -3145,47 +3057,61 @@ subroutine fall_speed (ktop, kbot, pl, cnv_fraction, anv_icefall, lsc_icefall, & ! ----------------------------------------------------------------------- if (const_vi) then - vti (:) = vi_fac + vti (:) = 0.5*(vi_min+vi_max) else - vi1 = 0.01 * vi_fac do k = ktop, kbot - if (qi (k) < thi) then ! this is needed as the fall - speed maybe problematic for small qi - vti (k) = vf_min + if (qi (k) < thi) then + vti (k) = vi_min else - tc (k) = tk (k) - tice ! deg C + tc = tk (k) - tice ! deg C IWC = qi (k) * den (k) * 1.e3 ! Units are g/m3 + + if (ICE_LSC_VFALL_PARAM == 1) then ! ----------------------------------------------------------------------- ! use deng and mace (2008, grl) ! https://doi.org/10.1029/2008GL035054 ! ----------------------------------------------------------------------- - viLSC = lsc_icefall*10.0**(log10(IWC) * (tc (k) * (aaL * tc (k) + bbL) + ccL) + ddL * tc (k) + eeL) - viCNV = anv_icefall*10.0**(log10(IWC) * (tc (k) * (aaC * tc (k) + bbC) + ccC) + ddC * tc (k) + eeC) + viLSC = lsc_icefall*10.0**(log10(IWC) * (tc * (aaL * tc + bbL) + ccL) + ddL * tc + eeL) + else ! ----------------------------------------------------------------------- ! use Mishra et al (2014, JGR) 'Parameterization of ice fall speeds in ! ice clouds: Results from SPartICus' ! ----------------------------------------------------------------------- - !viLSC = MAX(10.0,lsc_icefall*(1.411*tc(k) + 11.71*log10(IWC*1.e3) + 82.35)) - !viCNV = MAX(10.0,anv_icefall*(1.119*tc(k) + 14.21*log10(IWC*1.e3) + 68.85)) + viLSC = MAX(10.0,lsc_icefall*(1.411*tc + 11.71*log10(IWC*1.e3) + 82.35)) + endif + + if (ICE_CNV_VFALL_PARAM == 1) then + ! ----------------------------------------------------------------------- + ! use deng and mace (2008, grl) + ! https://doi.org/10.1029/2008GL035054 + ! ----------------------------------------------------------------------- + viCNV = anv_icefall*10.0**(log10(IWC) * (tc * (aaC * tc + bbC) + ccC) + ddC * tc + eeC) + else + ! ----------------------------------------------------------------------- + ! use Mishra et al (2014, JGR) 'Parameterization of ice fall speeds in + ! ice clouds: Results from SPartICus' + ! ----------------------------------------------------------------------- + viCNV = MAX(10.0,anv_icefall*(1.119*tc + 14.21*log10(IWC*1.e3) + 68.85)) + endif + ! Combine vti (k) = viLSC*(1.0-cnv_fraction) + viCNV*(cnv_fraction) + + if (do_icepsettle) then + ! Include pressure sensitivity (eq 14 in https://doi.org/10.1175/JAS-D-12-0124.1) + DIAM = 2.0*LDRADIUS4(pl(k)/100.0,tk(k),qi(k),zero,zero,2)*1.e6 ! microns + lnP = log(pl(k)/100.0) + C0 = -1.04 + 0.298*lnP + C1 = 0.67 - 0.097*lnP + ! apply pressure scaling + vti (k) = vti (k) * (C0 + C1*log(DIAM)) + endif + ! Update units from cm/s to m/s - vti (k) = vi1 * vti (k) - ! Include pressure sensitivity (eq 14 in https://doi.org/10.1175/JAS-D-12-0124.1) - !------ice cloud effective radius ----- [klaus wyser, 1998] - !if(tk(k)>t_ice) then - ! rBB = -2. - !else - ! rBB = -2. + log10(IWC/50.)*(1.e-3*(t_ice-tk(k))**1.5) - !endif - !rBB = MIN((MAX(rBB,-6.)),-2.) - !DIAM = 2.0*(377.4 + 203.3 * rBB+ 37.91 * rBB **2 + 2.3696 * rBB **3) - !lnP = log(pl(k)/100.0) - !C0 = -1.04 + 0.298*lnP - !C1 = 0.67 - 0.097*lnP - ! apply pressure scaling - !vti (k) = vti (k) * (C0 + C1*log(DIAM)) + vti (k) = 0.01 * vi_fac * vti (k) + ! Limits - vti (k) = min (vi_max, max (vf_min, vti (k))) + vti (k) = min (vi_max, max (vi_min, vti (k))) endif enddo endif @@ -3195,14 +3121,14 @@ subroutine fall_speed (ktop, kbot, pl, cnv_fraction, anv_icefall, lsc_icefall, & ! ----------------------------------------------------------------------- if (const_vs) then - vts (:) = vs_fac ! 1. ifs_2016 + vts (:) = 0.5*(vs_min+vs_max) else do k = ktop, kbot if (qs (k) < ths) then - vts (k) = vf_min + vts (k) = vs_min else vts (k) = vs_fac * vcons * rhof (k) * exp (0.0625 * log (qs (k) * den (k) / norms)) - vts (k) = min (vs_max, max (vf_min, vts (k))) + vts (k) = min (vs_max, max (vs_min, vts (k))) endif enddo endif @@ -3212,14 +3138,14 @@ subroutine fall_speed (ktop, kbot, pl, cnv_fraction, anv_icefall, lsc_icefall, & ! ----------------------------------------------------------------------- if (const_vg) then - vtg (:) = vg_fac ! 2. + vtg (:) = 0.5*(vg_min+vg_max) else do k = ktop, kbot if (qg (k) < thg) then - vtg (k) = vf_min + vtg (k) = vg_min else vtg (k) = vg_fac * vcong * rhof (k) * sqrt (sqrt (sqrt (qg (k) * den (k) / normg))) - vtg (k) = min (vg_max, max (vf_min, vtg (k))) + vtg (k) = min (vg_max, max (vg_min, vtg (k))) endif enddo endif @@ -3235,7 +3161,7 @@ subroutine setupm implicit none - real :: gcon, cd, scm3, pisq, act (8) + real :: cd, scm3, pisq, act (8) real :: vdifu, tcond real :: visk real :: ch2o, hltf @@ -3276,21 +3202,25 @@ subroutine setupm pisq = pie * pie scm3 = (visk / vdifu) ** (1. / 3.) + c_paut = c_paut * 0.104 * grav / 1.717e-5 + cracs = pisq * rnzr * rnzs * rhos csacr = pisq * rnzr * rnzs * rhor cgacr = pisq * rnzr * rnzg * rhor cgacs = pisq * rnzg * rnzs * rhos cgacs = cgacs * c_pgacs - ! act: 1 - 2:racs (s - r) ; 3 - 4:sacr (r - s) ; - ! 5 - 6:gacr (r - g) ; 7 - 8:gacs (s - g) + ! act: 1 - 2:racs (s - r) + ! 3 - 4:sacr (r - s) + ! 5 - 6:gacr (r - g) + ! 7 - 8:gacs (s - g) act (1) = pie * rnzs * rhos act (2) = pie * rnzr * rhor - act (6) = pie * rnzg * rhog act (3) = act (2) act (4) = act (1) act (5) = act (2) + act (6) = pie * rnzg * rhog act (7) = act (1) act (8) = act (6) @@ -3300,20 +3230,18 @@ subroutine setupm enddo enddo - gcon = 40.74 * sqrt (sfcrho) ! 44.628 - - csacw = pie * rnzs * clin * gam325 / (4. * act (1) ** 0.8125) - ! decreasing csacw to reduce cloud water --- > snow - + ! decreasing alin will reduce accretion of rain from cloud ice/water craci = pie * rnzr * alin * gam380 / (4. * act (2) ** 0.95) - csaci = csacw * c_psaci - - cgacw = pie * rnzg * gam350 * gcon / (4. * act (6) ** 0.875) + cracw = c_cracw * craci - cgaci = cgacw * c_pgaci + ! decreasing clin will reduce accretion of snow from cloud water/ice + csacw = pie * rnzs * clin * gam325 / (4. * act (1) ** 0.8125) + csaci = c_psaci * csacw - cracw = craci ! cracw = 3.27206196043822 - cracw = c_cracw * cracw + ! decreasing gcon will reduce accretion of graupel from cloud ice/water + cgacw = pie * rnzg * gcon * gam350 / (4. * act (6) ** 0.875) + cgaci = c_pgaci * cgacw + cgacw = c_pgacw * cgacw ! subl and revp: five constants for three separate processes @@ -3327,9 +3255,9 @@ subroutine setupm cgsub (3) = 0.31 * scm3 * gam275 * sqrt (gcon / visk) / act (6) ** 0.6875 crevp (3) = 0.31 * scm3 * gam290 * sqrt (alin / visk) / act (2) ** 0.725 cssub (4) = tcond * rvgas - cssub (5) = hlts ** 2 * vdifu cgsub (4) = cssub (4) crevp (4) = cssub (4) + cssub (5) = hlts ** 2 * vdifu cgsub (5) = cssub (5) crevp (5) = hltc ** 2 * vdifu @@ -3363,27 +3291,14 @@ end subroutine setupm !! cloud microphysics. ! ======================================================================= -subroutine gfdl_cloud_microphys_init (comm) +subroutine gfdl_cloud_microphys_init () implicit none - integer, intent(in) :: comm integer :: nlunit character (len = 64) :: fn_nml = 'input.nml' integer :: ios, ierr logical :: exists - ! integer, intent (in) :: id, jd, kd - ! integer, intent (in) :: axes (4) - ! type (time_type), intent (in) :: time - - ! integer :: unit, io, ierr, k, logunit - ! logical :: flag - ! real :: tmp, q1, q2 - - call fms_init(comm) - - ! root_proc = (mpp_pe () .eq.mpp_root_pe ()) - #ifdef INTERNAL_FILE_NML read (input_nml_file, nml = gfdl_cloud_microphysics_nml) #else @@ -3392,88 +3307,35 @@ subroutine gfdl_cloud_microphys_init (comm) write (6, *) 'gfdl - mp :: namelist file: ', trim (fn_nml), ' does not exist' stop else - nlunit=open_namelist_file() - rewind (nlunit) + !nlunit=open_namelist_file() + !rewind (nlunit) + open(NEWUNIT=nlunit,file=trim(fn_nml), form='formatted',access='sequential',iostat=ios) + if(ios /= 0) stop 'open namelist file gfdl_cloud_microphys_init failed, bailing out...' + rewind (nlunit, iostat=ios) + if(ios /= 0) stop 'rewind namelist file gfdl_cloud_microphys_init failed, bailing out...' ! Read Main namelist read (nlunit,gfdl_cloud_microphysics_nml,iostat=ios) - ierr = check_nml_error(ios,'gfdl_cloud_microphysics_nml') - call close_file(nlunit) + if(ios /= 0) stop 'read namelist gfdl_cloud_microphys_init failed, bailing out...' + !ierr = check_nml_error(ios,'gfdl_cloud_microphysics_nml') + !call close_file(nlunit) + close(nlunit, iostat=ios) + if(ios /= 0) stop 'close namelist file gfdl_cloud_microphys_init failed, bailing out...' endif #endif - if (mpp_pe() .EQ. mpp_root_pe()) then + if (MAPL_AM_I_ROOT()) then write (*, *) " ================================================================== " write (*, *) "gfdl_cloud_microphys_mod" write (*, nml = gfdl_cloud_microphysics_nml) write (*, *) " ================================================================== " endif - ! write version number and namelist to log file - !if (me == root_proc) then - ! write (logunit, *) " ================================================================== " - ! write (logunit, *) "gfdl_cloud_microphys_mod" - ! write (logunit, nml = gfdl_cloud_microphysics_nml) - !endif - if (do_setup) then call setup_con call setupm do_setup = .false. endif - ! if (root_proc) write (logunit, nml = gfdl_cloud_microphys_nml) - ! - ! id_vtr = register_diag_field (mod_name, 'vt_r', axes (1:3), time, & - ! 'rain fall speed', 'm / s', missing_value = missing_value) - ! id_vts = register_diag_field (mod_name, 'vt_s', axes (1:3), time, & - ! 'snow fall speed', 'm / s', missing_value = missing_value) - ! id_vtg = register_diag_field (mod_name, 'vt_g', axes (1:3), time, & - ! 'graupel fall speed', 'm / s', missing_value = missing_value) - ! id_vti = register_diag_field (mod_name, 'vt_i', axes (1:3), time, & - ! 'ice fall speed', 'm / s', missing_value = missing_value) - - ! id_droplets = register_diag_field (mod_name, 'droplets', axes (1:3), time, & - ! 'droplet number concentration', '# / m3', missing_value = missing_value) - ! id_rh = register_diag_field (mod_name, 'rh_lin', axes (1:2), time, & - ! 'relative humidity', 'n / a', missing_value = missing_value) - - ! id_rain = register_diag_field (mod_name, 'rain_lin', axes (1:2), time, & - ! 'rain_lin', 'mm / day', missing_value = missing_value) - ! id_snow = register_diag_field (mod_name, 'snow_lin', axes (1:2), time, & - ! 'snow_lin', 'mm / day', missing_value = missing_value) - ! id_graupel = register_diag_field (mod_name, 'graupel_lin', axes (1:2), time, & - ! 'graupel_lin', 'mm / day', missing_value = missing_value) - ! id_ice = register_diag_field (mod_name, 'ice_lin', axes (1:2), time, & - ! 'ice_lin', 'mm / day', missing_value = missing_value) - ! id_prec = register_diag_field (mod_name, 'prec_lin', axes (1:2), time, & - ! 'prec_lin', 'mm / day', missing_value = missing_value) - - ! if (root_proc) write (*, *) 'prec_lin diagnostics initialized.', id_prec - - ! id_cond = register_diag_field (mod_name, 'cond_lin', axes (1:2), time, & - ! 'total condensate', 'kg / m ** 2', missing_value = missing_value) - ! id_var = register_diag_field (mod_name, 'var_lin', axes (1:2), time, & - ! 'subgrid variance', 'n / a', missing_value = missing_value) - - ! call qsmith_init - - ! testing the water vapor tables - - ! if (mp_debug .and. root_proc) then - ! write (*, *) 'testing water vapor tables in gfdl_cloud_microphys' - ! tmp = tice - 90. - ! do k = 1, 25 - ! q1 = wqsat_moist (tmp, 0., 1.e5) - ! q2 = qs1d_m (tmp, 0., 1.e5) - ! write (*, *) nint (tmp - tice), q1, q2, 'dq = ', q1 - q2 - ! tmp = tmp + 5. - ! enddo - ! endif - - ! if (root_proc) write (*, *) 'gfdl_cloud_micrphys diagnostics initialized.' - - ! gfdl_mp_clock = mpp_clock_id ('gfdl_cloud_microphys', grain = clock_routine) - module_is_initialized = .true. end subroutine gfdl_cloud_microphys_init @@ -3510,8 +3372,6 @@ subroutine setup_con implicit none - ! root_proc = (mpp_pe () .eq.mpp_root_pe ()) - rgrav = 1. / grav if (.not. qsmith_tables_initialized) call qsmith_init @@ -3599,47 +3459,36 @@ subroutine qsmith_init implicit none - integer, parameter :: length = 2621 - integer :: i if (.not. tables_are_initialized) then - ! root_proc = (mpp_pe () .eq. mpp_root_pe ()) - ! if (root_proc) print *, ' gfdl mp: initializing qs tables' - - ! debug code - ! print *, mpp_pe (), allocated (table), allocated (table2), & - ! allocated (table3), allocated (tablew), allocated (des), & - ! allocated (des2), allocated (des3), allocated (desw) - ! end debug code - ! generate es table (dt = 0.1 deg. c) - allocate (table (length)) - allocate (table2 (length)) - allocate (table3 (length)) - allocate (tablew (length)) - allocate (des (length)) - allocate (des2 (length)) - allocate (des3 (length)) - allocate (desw (length)) - - call qs_table (length) - call qs_table2 (length) - call qs_table3 (length) - call qs_tablew (length) - - do i = 1, length - 1 + allocate (table (es_table_length)) + allocate (table2 (es_table_length)) + allocate (table3 (es_table_length)) + allocate (tablew (es_table_length)) + allocate (des (es_table_length)) + allocate (des2 (es_table_length)) + allocate (des3 (es_table_length)) + allocate (desw (es_table_length)) + + call qs_table (es_table_length) + call qs_table2 (es_table_length) + call qs_table3 (es_table_length) + call qs_tablew (es_table_length) + + do i = 1, es_table_length - 1 des (i) = max (0., table (i + 1) - table (i)) des2 (i) = max (0., table2 (i + 1) - table2 (i)) des3 (i) = max (0., table3 (i + 1) - table3 (i)) desw (i) = max (0., tablew (i + 1) - tablew (i)) enddo - des (length) = des (length - 1) - des2 (length) = des2 (length - 1) - des3 (length) = des3 (length - 1) - desw (length) = desw (length - 1) + des (es_table_length) = des (es_table_length - 1) + des2 (es_table_length) = des2 (es_table_length - 1) + des3 (es_table_length) = des3 (es_table_length - 1) + desw (es_table_length) = desw (es_table_length - 1) tables_are_initialized = .true. @@ -3662,13 +3511,12 @@ real function wqs1 (ta, den) real, intent (in) :: ta, den - real :: es, ap1, tmin + real :: es - integer :: it + integer :: it, ap1 - tmin = table_ice - 160. - ap1 = 10. * dim (ta, tmin) + 1. - ap1 = min(2621., ap1) + ap1 = rdelt * max(0.0,dim (ta, es_table_tmin)) + 1. + ap1 = min(es_table_length, ap1) it = ap1 es = tablew (it) + (ap1 - it) * desw (it) wqs1 = es / (rvgas * ta * den) @@ -3693,53 +3541,24 @@ real function wqs2 (ta, den, dqdt) real, intent (out) :: dqdt - real :: es, ap1, tmin + real :: es - integer :: it + integer :: it, ap1 - tmin = table_ice - 160. if (.not. tables_are_initialized) call qsmith_init - ap1 = 10. * dim (ta, tmin) + 1. - ap1 = min (2621., ap1) + ap1 = rdelt * max(0.0,dim (ta, es_table_tmin)) + 1. + ap1 = min (es_table_length, ap1) it = ap1 es = tablew (it) + (ap1 - it) * desw (it) wqs2 = es / (rvgas * ta * den) it = ap1 - 0.5 ! finite diff, del_t = 0.1: - dqdt = 10. * (desw (it) + (ap1 - it) * (desw (it + 1) - desw (it))) / (rvgas * ta * den) + dqdt = rdelt * (desw (it) + (ap1 - it) * (desw (it + 1) - desw (it))) / (rvgas * ta * den) end function wqs2 -! ======================================================================= -! compute wet buld temperature -!>@brief The function 'wet_bulb' uses 'wqs2' to compute the wet-bulb temperature -!! from the mixing ratio and the temperature. -! ======================================================================= - -real function wet_bulb (q, t, den) - - implicit none - - real, intent (in) :: t, q, den - - real :: qs, tp, dqdt - - wet_bulb = t - qs = wqs2 (wet_bulb, den, dqdt) - tp = 0.5 * (qs - q) / (1. + lcp * dqdt) * lcp - wet_bulb = wet_bulb - tp - - ! tp is negative if super - saturated - if (tp > 0.01) then - qs = wqs2 (wet_bulb, den, dqdt) - tp = (qs - q) / (1. + lcp * dqdt) * lcp - wet_bulb = wet_bulb - tp - endif - -end function wet_bulb - ! ======================================================================= !>@brief The function 'iqs1' computes the saturated specific humidity !! for table iii @@ -3754,13 +3573,12 @@ real function iqs1 (ta, den) real, intent (in) :: ta, den - real :: es, ap1, tmin + real :: es - integer :: it + integer :: it, ap1 - tmin = table_ice - 160. - ap1 = 10. * dim (ta, tmin) + 1. - ap1 = min (2621., ap1) + ap1 = rdelt * max(0.0,dim (ta, es_table_tmin))+ 1. + ap1 = min (es_table_length, ap1) it = ap1 es = table2 (it) + (ap1 - it) * des2 (it) iqs1 = es / (rvgas * ta * den) @@ -3783,290 +3601,20 @@ real function iqs2 (ta, den, dqdt) real, intent (out) :: dqdt - real :: es, ap1, tmin + real :: es - integer :: it + integer :: it, ap1 - tmin = table_ice - 160. - ap1 = 10. * dim (ta, tmin) + 1. - ap1 = min(2621., ap1) + ap1 = rdelt * max(0.0,dim (ta, es_table_tmin)) + 1. + ap1 = min(es_table_length, ap1) it = ap1 es = table2 (it) + (ap1 - it) * des2 (it) iqs2 = es / (rvgas * ta * den) it = ap1 - 0.5 - dqdt = 10. * (des2 (it) + (ap1 - it) * (des2 (it + 1) - des2 (it))) / (rvgas * ta * den) + dqdt = rdelt * (des2 (it) + (ap1 - it) * (des2 (it + 1) - des2 (it))) / (rvgas * ta * den) end function iqs2 -! ======================================================================= -!>@brief The function 'qs1d_moist' computes the gradient of saturated -!! specific humidity for table iii. -! ======================================================================= - -real function qs1d_moist (ta, qv, pa, dqdt) - - implicit none - - real, intent (in) :: ta, pa, qv - - real, intent (out) :: dqdt - - real :: es, ap1, tmin, eps10 - - integer :: it - - tmin = table_ice - 160. - eps10 = 10. * eps - ap1 = 10. * dim (ta, tmin) + 1. - ap1 = min (2621., ap1) - it = ap1 - es = table2 (it) + (ap1 - it) * des2 (it) - qs1d_moist = eps * es * (1. + zvir * qv) / pa - it = ap1 - 0.5 - dqdt = eps10 * (des2 (it) + (ap1 - it) * (des2 (it + 1) - des2 (it))) * (1. + zvir * qv) / pa - -end function qs1d_moist - -! ======================================================================= -! compute the gradient of saturated specific humidity for table ii -!>@brief The function 'wqsat2_moist' computes the saturated specific humidity -!! for pure liquid water , as well as des/dT. -! ======================================================================= - -real function wqsat2_moist (ta, qv, pa, dqdt) - - implicit none - - real, intent (in) :: ta, pa, qv - - real, intent (out) :: dqdt - - real :: es, ap1, tmin, eps10 - - integer :: it - - tmin = table_ice - 160. - eps10 = 10. * eps - ap1 = 10. * dim (ta, tmin) + 1. - ap1 = min (2621., ap1) - it = ap1 - es = tablew (it) + (ap1 - it) * desw (it) - wqsat2_moist = eps * es * (1. + zvir * qv) / pa - it = ap1 - 0.5 - dqdt = eps10 * (desw (it) + (ap1 - it) * (desw (it + 1) - desw (it))) * (1. + zvir * qv) / pa - -end function wqsat2_moist - -! ======================================================================= -! compute the saturated specific humidity for table ii -!>@brief The function 'wqsat_moist' computes the saturated specific humidity -!! for pure liquid water. -! ======================================================================= - -real function wqsat_moist (ta, qv, pa) - - implicit none - - real, intent (in) :: ta, pa, qv - - real :: es, ap1, tmin - - integer :: it - - tmin = table_ice - 160. - ap1 = 10. * dim (ta, tmin) + 1. - ap1 = min(2621., ap1) - it = ap1 - es = tablew (it) + (ap1 - it) * desw (it) - wqsat_moist = eps * es * (1. + zvir * qv) / pa - -end function wqsat_moist - -! ======================================================================= -!>@brief The function 'qs1d_m' computes the saturated specific humidity -!! for table iii -! ======================================================================= - -real function qs1d_m (ta, qv, pa) - - implicit none - - real, intent (in) :: ta, pa, qv - - real :: es, ap1, tmin - - integer :: it - - tmin = table_ice - 160. - ap1 = 10. * dim (ta, tmin) + 1. - ap1 = min (2621., ap1) - it = ap1 - es = table2 (it) + (ap1 - it) * des2 (it) - qs1d_m = eps * es * (1. + zvir * qv) / pa - -end function qs1d_m - -! ======================================================================= -!>@brief The function 'd_sat' computes the difference in saturation -!! vapor * density * between water and ice -! ======================================================================= - -real function d_sat (ta, den) - - implicit none - - real, intent (in) :: ta, den - - real :: es_w, es_i, ap1, tmin - - integer :: it - - tmin = table_ice - 160. - ap1 = 10. * dim (ta, tmin) + 1. - ap1 = min (2621., ap1) - it = ap1 - es_w = tablew (it) + (ap1 - it) * desw (it) - es_i = table2 (it) + (ap1 - it) * des2 (it) - d_sat = dim (es_w, es_i) / (rvgas * ta * den) ! take positive difference - -end function d_sat - -! ======================================================================= -!>@brief The function 'esw_table' computes the saturated water vapor -!! pressure for table ii -! ======================================================================= - -real function esw_table (ta) - - implicit none - - real, intent (in) :: ta - - real :: ap1, tmin - - integer :: it - - tmin = table_ice - 160. - ap1 = 10. * dim (ta, tmin) + 1. - ap1 = min (2621., ap1) - it = ap1 - esw_table = tablew (it) + (ap1 - it) * desw (it) - -end function esw_table - -! ======================================================================= -!>@brief The function 'es2_table' computes the saturated water -!! vapor pressure for table iii -! ======================================================================= - -real function es2_table (ta) - - implicit none - - real, intent (in) :: ta - - real :: ap1, tmin - - integer :: it - - tmin = table_ice - 160. - ap1 = 10. * dim (ta, tmin) + 1. - ap1 = min (2621., ap1) - it = ap1 - es2_table = table2 (it) + (ap1 - it) * des2 (it) - -end function es2_table - -! ======================================================================= -!>@brief The subroutine 'esw_table1d' computes the saturated water vapor -!! pressure for table ii. -! ======================================================================= - -subroutine esw_table1d (ta, es, n) - - implicit none - - integer, intent (in) :: n - - real, intent (in) :: ta (n) - - real, intent (out) :: es (n) - - real :: ap1, tmin - - integer :: i, it - - tmin = table_ice - 160. - - do i = 1, n - ap1 = 10. * dim (ta (i), tmin) + 1. - ap1 = min (2621., ap1) - it = ap1 - es (i) = tablew (it) + (ap1 - it) * desw (it) - enddo - -end subroutine esw_table1d - -! ======================================================================= -!>@brief The subroutine 'es3_table1d' computes the saturated water vapor -!! pressure for table iii. -! ======================================================================= - -subroutine es2_table1d (ta, es, n) - - implicit none - - integer, intent (in) :: n - - real, intent (in) :: ta (n) - - real, intent (out) :: es (n) - - real :: ap1, tmin - - integer :: i, it - - tmin = table_ice - 160. - - do i = 1, n - ap1 = 10. * dim (ta (i), tmin) + 1. - ap1 = min (2621., ap1) - it = ap1 - es (i) = table2 (it) + (ap1 - it) * des2 (it) - enddo - -end subroutine es2_table1d - -! ======================================================================= -!>@brief The subroutine 'es3_table1d' computes the saturated water vapor -!! pressure for table iv. -! ======================================================================= - -subroutine es3_table1d (ta, es, n) - - implicit none - - integer, intent (in) :: n - - real, intent (in) :: ta (n) - - real, intent (out) :: es (n) - - real :: ap1, tmin - - integer :: i, it - - tmin = table_ice - 160. - - do i = 1, n - ap1 = 10. * dim (ta (i), tmin) + 1. - ap1 = min (2621., ap1) - it = ap1 - es (i) = table3 (it) + (ap1 - it) * des3 (it) - enddo - -end subroutine es3_table1d - ! ======================================================================= !>@brief saturation water vapor pressure table ii ! 1 - phase table @@ -4078,19 +3626,16 @@ subroutine qs_tablew (n) integer, intent (in) :: n - real :: delt = 0.1 - real :: tmin, tem, fac0, fac1, fac2 + real :: tem, fac0, fac1, fac2 integer :: i - tmin = table_ice - 160. - ! ----------------------------------------------------------------------- ! compute es over water ! ----------------------------------------------------------------------- do i = 1, n - tem = tmin + delt * real (i - 1) + tem = es_table_tmin + delt * real (i - 1) fac0 = (tem - t_ice) / (tem * t_ice) fac1 = fac0 * lv0 fac2 = (dc_vap * log (tem / t_ice) + fac1) / rvgas @@ -4110,15 +3655,12 @@ subroutine qs_table2 (n) integer, intent (in) :: n - real :: delt = 0.1 - real :: tmin, tem0, tem1, fac0, fac1, fac2 + real :: tem0, tem1, fac0, fac1, fac2 integer :: i, i0, i1 - tmin = table_ice - 160. - do i = 1, n - tem0 = tmin + delt * real (i - 1) + tem0 = es_table_tmin + delt * real (i - 1) fac0 = (tem0 - t_ice) / (tem0 * t_ice) if (i <= 1600) then ! ----------------------------------------------------------------------- @@ -4160,8 +3702,7 @@ subroutine qs_table3 (n) integer, intent (in) :: n - real :: delt = 0.1 - real :: esbasw, tbasw, esbasi, tmin, tem, aa, b, c, d, e + real :: esbasw, tbasw, esbasi, tem, aa, b, c, d, e real :: tem0, tem1 integer :: i, i0, i1 @@ -4169,10 +3710,9 @@ subroutine qs_table3 (n) esbasw = 1013246.0 tbasw = table_ice + 100. esbasi = 6107.1 - tmin = table_ice - 160. do i = 1, n - tem = tmin + delt * real (i - 1) + tem = es_table_tmin + delt * real (i - 1) ! if (i <= 1600) then if (i <= 1580) then ! change to - 2 c ! ----------------------------------------------------------------------- @@ -4224,13 +3764,12 @@ real function qs_blend (t, p, q) real, intent (in) :: t, p, q - real :: es, ap1, tmin + real :: es - integer :: it + integer :: it, ap1 - tmin = table_ice - 160. - ap1 = 10. * dim (t, tmin) + 1. - ap1 = min (2621., ap1) + ap1 = rdelt * max(0.0,dim (t, es_table_tmin)) + 1. + ap1 = min (es_table_length, ap1) it = ap1 es = table (it) + (ap1 - it) * des (it) qs_blend = eps * es * (1. + zvir * q) / p @@ -4248,22 +3787,19 @@ subroutine qs_table (n) integer, intent (in) :: n - real :: delt = 0.1 - real :: tmin, tem, esh40 + real :: tem, esh40 real :: wice, wh2o, fac0, fac1, fac2 real :: esupc (400) integer :: i real :: tc - tmin = table_ice - 160. - ! ----------------------------------------------------------------------- ! compute es over ice between - 160 deg c and 0 deg c. ! ----------------------------------------------------------------------- do i = 1, 1600 - tem = tmin + delt * real (i - 1) + tem = es_table_tmin + delt * real (i - 1) fac0 = (tem - t_ice) / (tem * t_ice) fac1 = fac0 * li2 fac2 = (d2ice * log (tem / t_ice) + fac1) / rvgas @@ -4274,7 +3810,7 @@ subroutine qs_table (n) ! compute es over water between - 40 deg c and 102 deg c. ! ----------------------------------------------------------------------- - do i = 1, 1421 + do i = 1, es_table_length-1200 tem = 233.16 + delt * real (i - 1) fac0 = (tem - t_ice) / (tem * t_ice) fac1 = fac0 * lv0 @@ -4293,8 +3829,6 @@ subroutine qs_table (n) do i = 1, 400 tem = 233.16 + delt * real (i - 1) - ! wice = 0.05 * (table_ice - tem) - ! wh2o = 0.05 * (tem - 253.16) ! GEOS ! WMP impose CALIPSO ice polynomial from 0 C to -40 C wice = ice_fraction(tem,0.0,0.0) wh2o = 1.0 - wice @@ -4323,13 +3857,12 @@ subroutine qsmith (im, km, ks, t, p, q, qs, dqdt) real, intent (out), dimension (im, km), optional :: dqdt - real :: eps10, ap1, tmin + real :: eps10 real, dimension (im, km) :: es - integer :: i, k, it + integer :: i, k, it, ap1 - tmin = table_ice - 160. eps10 = 10. * eps if (.not. tables_are_initialized) then @@ -4338,8 +3871,8 @@ subroutine qsmith (im, km, ks, t, p, q, qs, dqdt) do k = ks, km do i = 1, im - ap1 = 10. * dim (t (i, k), tmin) + 1. - ap1 = min (2621., ap1) + ap1 = rdelt * max(0.0,dim (t (i, k), es_table_tmin)) + 1. + ap1 = min (es_table_length, ap1) it = ap1 es (i, k) = table (it) + (ap1 - it) * des (it) qs (i, k) = eps * es (i, k) * (1. + zvir * q (i, k)) / p (i, k) @@ -4349,8 +3882,8 @@ subroutine qsmith (im, km, ks, t, p, q, qs, dqdt) if (present (dqdt)) then do k = ks, km do i = 1, im - ap1 = 10. * dim (t (i, k), tmin) + 1. - ap1 = min (2621., ap1) - 0.5 + ap1 = rdelt * max(0.0,dim (t (i, k), es_table_tmin)) + 1. + ap1 = min (es_table_length, ap1) - 0.5 it = ap1 dqdt (i, k) = eps10 * (des (it) + (ap1 - it) * (des (it + 1) - des (it))) * (1. + zvir * q (i, k)) / p (i, k) enddo @@ -4454,52 +3987,6 @@ subroutine neg_adj (ktop, kbot, pt, dp, qv, ql, qr, qi, qs, qg) end subroutine neg_adj -! ======================================================================= -! compute global sum -!>@brief quick local sum algorithm -! ======================================================================= - -!real function g_sum (p, ifirst, ilast, jfirst, jlast, area, mode) -! -! use mpp_mod, only: mpp_sum -! -! implicit none -! -! integer, intent (in) :: ifirst, ilast, jfirst, jlast -! integer, intent (in) :: mode ! if == 1 divided by area -! -! real, intent (in), dimension (ifirst:ilast, jfirst:jlast) :: p, area -! -! integer :: i, j -! -! real :: gsum -! -! if (global_area < 0.) then -! global_area = 0. -! do j = jfirst, jlast -! do i = ifirst, ilast -! global_area = global_area + area (i, j) -! enddo -! enddo -! call mpp_sum (global_area) -! endif -! -! gsum = 0. -! do j = jfirst, jlast -! do i = ifirst, ilast -! gsum = gsum + p (i, j) * area (i, j) -! enddo -! enddo -! call mpp_sum (gsum) -! -! if (mode == 1) then -! g_sum = gsum / global_area -! else -! g_sum = gsum -! endif -! -!end function g_sum - ! ========================================================================== !>@brief The subroutine 'interpolate_z' interpolates to a prescribed height. ! ========================================================================== @@ -4522,8 +4009,6 @@ subroutine interpolate_z (is, ie, js, je, km, zl, hgt, a3, a2) integer :: i, j, k - !$omp parallel do default (none) shared (is, ie, js, je, km, hgt, zl, a2, a3) private (zm) - do j = js, je do i = is, ie do k = 1, km @@ -4669,6 +4154,16 @@ subroutine cloud_diagnosis (is, ie, js, je, den, qw, qi, qr, qs, qg, t, & end subroutine cloud_diagnosis +real function new_liq_condensate(tk, qlk, qik, cnv_fraction, srf_type) + + real, intent(in) :: tk, qlk, qik, cnv_fraction, srf_type + real :: ptc, ifrac + + ifrac = ice_fraction(tk,cnv_fraction, srf_type) + new_liq_condensate = min(max(0.0,(1.0-ifrac)*(qlk+qik) - qlk),qik) + +end function new_liq_condensate + real function new_ice_condensate(tk, qlk, qik, cnv_fraction, srf_type) real, intent(in) :: tk, qlk, qik, cnv_fraction, srf_type diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_mp.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_mp.F90 new file mode 100644 index 000000000..bb1d28e07 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_mp.F90 @@ -0,0 +1,8123 @@ +!*********************************************************************** +!* GNU Lesser General Public License +!* +!* This file is part of the FV3 dynamical core. +!* +!* The FV3 dynamical core is free software: you can redistribute it +!* and/or modify it under the terms of the +!* GNU Lesser General Public License as published by the +!* Free Software Foundation, either version 3 of the License, or +!* (at your option) any later version. +!* +!* The FV3 dynamical core is distributed in the hope that it will be +!* useful, but WITHOUT ANY WARRANTY; without even the implied warranty +!* of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. +!* See the GNU General Public License for more details. +!* +!* You should have received a copy of the GNU Lesser General Public +!* License along with the FV3 dynamical core. +!* If not, see . +!*********************************************************************** + +! ======================================================================= +! GFDL Cloud Microphysics Package (GFDL MP) Version 3 +! The algorithms are originally derived from Lin et al. (1983). +! Most of the key elements have been simplified / improved. +! This code at this stage bears little to no similarity to the original Lin MP in ZETAC. +! Developers: Linjiong Zhou and the GFDL FV3 Team +! References: +! Version 0: Chen and Lin (2011 doi: 10.1029/2011GL047629, 2013 doi: 10.1175/JCLI-D-12-00061.1) +! Version 1: Zhou et al. (2019 doi: 10.1175/BAMS-D-17-0246.1) +! Version 2: Harris et al. (2020 doi: 10.1029/2020MS002223), Zhou et al. (2022 doi: 10.25923/pz3c-8b96) +! Version 3: Zhou et al. (2022 doi: 10.1029/2021MS002971) +! NASA integration: Putman April 2025 +! ======================================================================= + +module gfdl_mp_mod + + use GEOSmoist_Process_Library, only: sigma, ice_fraction, LDRADIUS4 + use MAPL, only: MAPL_AM_I_ROOT + + implicit none + + private + + ! ----------------------------------------------------------------------- + ! interface functions + ! ----------------------------------------------------------------------- + + interface wqs + procedure wes_t + procedure wqs_trho + procedure wqs_ptqv + end interface wqs + + interface mqs + procedure mes_t + procedure mqs_trho + procedure mqs_ptqv + end interface mqs + + interface iqs + procedure ies_t + procedure iqs_trho + procedure iqs_ptqv + end interface iqs + + interface mhc + procedure mhc3 + procedure mhc4 + procedure mhc6 + end interface mhc + + interface wet_bulb + procedure wet_bulb_dry + procedure wet_bulb_moist + end interface wet_bulb + + ! ----------------------------------------------------------------------- + ! public subroutines, functions, and variables + ! ----------------------------------------------------------------------- + + public :: gfdl_mp_init + public :: gfdl_mp_driver + public :: gfdl_mp_end +!! public :: fast_sat_adj + public :: cld_eff_rad, rad_ref + public :: qs_init, wqs, iqs, mqs, mqs3d + public :: c_liq, c_ice, rhow, wet_bulb + public :: cv_air, cv_vap, mtetw, mte + public :: hlv, hlf, tice + public :: do_hail, ifflag + + ! ----------------------------------------------------------------------- + ! precision definition + ! ----------------------------------------------------------------------- + + integer, parameter :: r8 = 8 ! double precision + + ! ----------------------------------------------------------------------- + ! initialization conditions + ! ----------------------------------------------------------------------- + + logical :: tables_are_initialized = .false. ! initialize satuation tables + + ! ----------------------------------------------------------------------- + ! physics constants + ! ----------------------------------------------------------------------- + + real, parameter :: grav = 9.80665 ! acceleration due to gravity (m/s^2), ref: IFS + + real, parameter :: rgrav = 1.0 / grav ! inversion of gravity acceleration (s^2/m) + + real, parameter :: pi = 4.0 * atan (1.0) ! ratio of circle circumference to diameter + + real, parameter :: boltzmann = 1.38064852e-23 ! boltzmann constant (J/K) + real, parameter :: avogadro = 6.02214076e23 ! avogadro number (1/mol) + real, parameter :: runiver = avogadro * boltzmann ! 8.314459727525675, universal gas constant (J/K/mol) + real, parameter :: mmd = 2.89644e-2 ! dry air molar mass (kg/mol), ref: IFS + real, parameter :: mmv = 1.80153e-2 ! water vapor molar mass (kg/mol), ref: IFS + + real, parameter :: rdgas = 287.05 ! gas constant for dry air (J/kg/K): ref: GFDL, GFS + real, parameter :: rvgas = 461.50 ! gas constant for water vapor (J/kg/K): ref: GFDL, GFS + + real, parameter :: zvir = rvgas / rdgas - 1. ! 0.6077667316114637 + real, parameter :: eps = rdgas / rvgas ! 0.6219934994582882 + real, parameter :: epsm1 = rdgas / rvgas - 1. ! -0.3780065005417118 + + real, parameter :: tice = 273.15 ! freezing temperature (K): ref: GFDL, GFS + + integer, parameter :: es_table_length = 2621 + real , parameter :: es_table_tmin = tice - 160. + real (kind = r8), parameter :: delt = 0.1 + real (kind = r8), parameter :: rdelt = 1.0/delt + + real, parameter :: cp_air = 1004.6 ! heat capacity of dry air at constant pressure (J/kg/K): ref: GFDL, GFS + real, parameter :: cv_air = cp_air - rdgas ! 717.55, heat capacity of dry air at constant volume (J/kg/K): ref: GFDL, GFS + real, parameter :: cp_vap = 4.0 * rvgas ! 1846.0885419672554, heat capacity of water vapor at constnat pressure (J/kg/K) + real, parameter :: cv_vap = 3.0 * rvgas ! 1384.5664064754415, heat capacity of water vapor at constant volume (J/kg/K) + + real, parameter :: c_ice = 2.106e3 ! heat capacity of ice at 0 deg C (J/kg/K), ref: IFS + real, parameter :: c_liq = 4.218e3 ! heat capacity of water at 0 deg C (J/kg/K), ref: IFS + + real, parameter :: dc_vap = cp_vap - c_liq ! - 2371.9114580327446, isobaric heating / cooling (J/kg/K) + real, parameter :: dc_ice = c_liq - c_ice ! 2112.0, isobaric heating / colling (J/kg/K) + real, parameter :: d2_ice = cp_vap - c_ice ! - 259.9114580327446, isobaric heating / cooling (J/kg/K) + + real, parameter :: hlv = 2.5e6 ! latent heat of evaporation at 0 deg C (J/kg): ref: GFDL, GFS + real, parameter :: hlf = 3.3358e5 ! latent heat of fusion at 0 deg C (J/kg): ref: GFDL, GFS + + real, parameter :: lats = hlv + hlf + real, parameter :: lat2 = lats * lats + + real, parameter :: visd = 1.717e-5 ! dynamics viscosity of air at 0 deg C and 1000 hPa (Mason, 1971) (kg/m/s) + real, parameter :: visk = 1.35e-5 ! kinematic viscosity of air at 0 deg C and 1000 hPa (Mason, 1971) (m^2/s) + real, parameter :: vdifu = 2.25e-5 ! diffusivity of water vapor in air at 0 deg C and 1000 hPa (Mason, 1971) (m^2/s) + real, parameter :: tcond = 2.40e-2 ! thermal conductivity of air at 0 deg C and 1000 hPa (Mason, 1971) (J/m/s/K) + + real, parameter :: rho0 = 1.0 ! reference air density (kg/m^3), ref: IFS + real, parameter :: cdg = 3.15121 ! drag coefficient of graupel (Locatelli and Hobbs, 1974) + real, parameter :: cdh = 0.5 ! drag coefficient of hail (Heymsfield and Wright, 2014) + + real (kind = r8), parameter :: lv0 = hlv - dc_vap * tice ! 3148711.3338762247, evaporation latent heat coeff. at 0 deg K (J/kg) + real (kind = r8), parameter :: li0 = hlf - dc_ice * tice ! - 242413.92000000004, fussion latent heat coeff. at 0 deg K (J/kg) + real (kind = r8), parameter :: li2 = lv0 + li0 ! 2906297.413876225, sublimation latent heat coeff. at 0 deg K (J/kg) + + real (kind = r8), parameter :: e00 = 611.21 ! saturation vapor pressure at 0 deg C (Pa), ref: IFS + + ! ----------------------------------------------------------------------- + ! predefined parameters + ! ----------------------------------------------------------------------- + + real, parameter :: qpmin = 1.e-8 !< min value for suspended rain/snow/liquid/ice precip + real, parameter :: qvmin = 1.e-20 !< min value for water vapor (treated as zero) + real, parameter :: qcmin = 1.0e-12 ! min value for cloud condensates (kg/kg) + real, parameter :: qfmin = 1.0e-8 ! min value for sedimentation (kg/kg) + + real, parameter :: dz_min = 1.0e-2 ! used for correcting flipped height (m) + + real, parameter :: rhow = 1.0e3 ! density of cloud water (kg/m^3) + real, parameter :: rhoi = 9.17e2 ! density of cloud ice (kg/m^3) + real, parameter :: rhor = 1.0e3 ! density of rain (Lin et al. 1983) (kg/m^3) + real, parameter :: rhos = 1.0e2 ! density of snow (Lin et al. 1983) (kg/m^3) + real, parameter :: rhog = 4.0e2 ! density of graupel (Rutledge and Hobbs 1984) (kg/m^3) + real, parameter :: rhoh = 9.17e2 ! density of hail (Lin et al. 1983) (kg/m^3) + + real, parameter :: dt_fr = 8.0 ! t_wfr - dt_fr: minimum temperature water can exist (Moore and Molinero 2011) + + real, parameter :: rc = (4. / 3.) * pi * rhor + + real (kind = r8), parameter :: one_r8 = 1.0 ! constant 1 + + ! ----------------------------------------------------------------------- + ! namelist parameters + ! ----------------------------------------------------------------------- + + integer :: ntimes = 2 ! cloud microphysics sub cycles + + integer :: nconds = 1 ! condensation sub cycles + + integer :: cfflag = 1 ! cloud fraction scheme + ! 1: GFDL cloud scheme + ! 2: Xu and Randall (1996) + ! 3: Park et al. (2016) + ! 4: Gultepe and Isaac (2007) + + integer :: icloud_f = 0 ! GFDL cloud scheme + ! 0: subgrid variability based scheme + ! 1: same as 0, but for old fvgfs implementation + ! 2: binary cloud scheme + ! 3: extension of 0 + + integer :: irain_f = 0 ! cloud water to rain autoconversion scheme + ! 0: subgrid variability based scheme + ! 1: no subgrid varaibility + + integer :: inflag = 1 ! ice nucleation scheme + ! 1: Hong et al. (2004) + ! 2: Meyers et al. (1992) + ! 3: Meyers et al. (1992) + ! 4: Cooper (1986) + ! 5: Fletcher (1962) + + integer :: igflag = 3 ! ice generation scheme + ! 1: WSM6 + ! 2: WSM6 with 0 at 0 C + ! 3: WSM6 with 0 at 0 C and fixed value at - 10 C + ! 4: combination of 1 and 3 + + integer :: ifflag = 3 ! ice fall scheme + ! 1: Deng and Mace (2008) + ! 2: Heymsfield and Donner (1990) + ! 3: Combination of Deng and Mace (2008) and Mishra et al (2014, JGR) + + integer :: rewflag = 1 ! cloud water effective radius scheme + ! 1: Martin et al. (1994) + ! 2: Martin et al. (1994), GFDL revision + ! 4: effective radius + + integer :: reiflag = 5 ! cloud ice effective radius scheme + ! 1: Heymsfield and Mcfarquhar (1996) + ! 2: Donner et al. (1997) + ! 3: Fu (2007) + ! 4: Kristjansson et al. (2000) + ! 5: Wyser (1998) + ! 6: Sun and Rikus (1999), Sun (2001) + ! 7: effective radius + + integer :: rerflag = 1 ! rain effective radius scheme + ! 1: effective radius + + integer :: resflag = 1 ! snow effective radius scheme + ! 1: effective radius + + integer :: regflag = 1 ! graupel effective radius scheme + ! 1: effective radius + + integer :: radr_flag = 1 ! radar reflectivity for rain + ! 1: Mark Stoelinga (2005) + ! 2: Smith et al. (1975), Tong and Xue (2005) + ! 3: Marshall-Palmer formula (https://en.wikipedia.org/wiki/DBZ_(meteorology)) + + integer :: rads_flag = 1 ! radar reflectivity for snow + ! 1: Mark Stoelinga (2005) + ! 2: Smith et al. (1975), Tong and Xue (2005) + ! 3: Marshall-Palmer formula (https://en.wikipedia.org/wiki/DBZ_(meteorology)) + + integer :: radg_flag = 1 ! radar reflectivity for graupel + ! 1: Mark Stoelinga (2005) + ! 2: Smith et al. (1975), Tong and Xue (2005) + ! 3: Marshall-Palmer formula (https://en.wikipedia.org/wiki/DBZ_(meteorology)) + + integer :: sedflag = 1 ! sedimentation scheme + ! 1: implicit scheme + ! 2: explicit scheme + ! 3: lagrangian scheme + ! 4: combined implicit and lagrangian scheme + + integer :: vdiffflag = 2 ! wind difference scheme in accretion + ! 1: Wisner et al. (1972) + ! 2: Mizuno (1990) + ! 3: Murakami (1990) + + logical :: do_sedi_uv = .true. ! transport of horizontal momentum in sedimentation + logical :: do_sedi_w = .false. ! transport of vertical momentum in sedimentation + logical :: do_sedi_heat = .true. ! transport of heat in sedimentation + logical :: do_sedi_melt = .true. ! melt cloud ice, snow, and graupel during sedimentation + + logical :: do_qa = .false. ! do inline cloud fraction + logical :: rad_snow = .true. ! include snow in cloud fraciton calculation + logical :: rad_graupel = .true. ! include graupel in cloud fraction calculation + logical :: rad_rain = .true. ! include rain in cloud fraction calculation + logical :: do_cld_adj = .true. ! do cloud fraction adjustment + + logical :: do_ref = .false. ! do radar calculations + + logical :: z_slope_liq = .true. ! use linear mono slope for autocconversions + logical :: z_slope_ice = .true. ! use linear mono slope for autocconversions + + logical :: use_rhc_cevap = .false. ! cap of rh for cloud water evaporation + logical :: use_rhc_revap = .false. ! cap of rh for rain evaporation + + logical :: const_vw = .false. ! if .ture., the constants are specified by v * _fac + logical :: const_vi = .false. ! if .ture., the constants are specified by v * _fac + logical :: const_vs = .false. ! if .ture., the constants are specified by v * _fac + logical :: const_vg = .false. ! if .ture., the constants are specified by v * _fac + logical :: const_vr = .false. ! if .ture., the constants are specified by v * _fac + + logical :: liq_ice_combine = .false. ! combine all liquid water, combine all solid water + logical :: snow_grauple_combine = .true. ! combine snow and graupel + + logical :: prog_ccn = .true. ! do prognostic ccn (Yi Ming's method) + logical :: prog_cin = .false. ! do prognostic cin + + logical :: fix_negative = .true. ! fix negative water species + + logical :: do_evap_timescale = .true. ! whether to apply a timescale to evaporation + logical :: do_cond_timescale = .true. ! whether to apply a timescale to condensation + + logical :: do_hail = .false. ! use hail parameters instead of graupel + + logical :: consv_checker = .false. ! turn on energy and water conservation checker + + logical :: do_warm_rain_mp = .false. ! do warm rain cloud microphysics only + + logical :: do_wbf = .false. ! do Wegener Bergeron Findeisen process + + logical :: do_bigg = .false. ! do Bigg process + + logical :: do_psd_water_fall = .false. ! calculate cloud water terminal velocity based on PSD + logical :: do_psd_ice_fall = .false. ! calculate cloud ice terminal velocity based on PSD + + logical :: do_psd_water_num = .false. ! calculate cloud water number concentration based on PSD + logical :: do_psd_ice_num = .true. ! calculate cloud ice number concentration based on PSD + + logical :: do_new_acc_water = .true. ! perform the new accretion for cloud water + logical :: do_new_acc_ice = .false. ! perform the new accretion for cloud ice + + logical :: cp_heating = .false. ! update temperature based on constant pressure + + logical :: delay_cond_evap = .true. ! do condensation evaporation only at the last time step + + logical :: do_subgrid_proc = .true. ! do temperature sentive high vertical resolution processes + + logical :: fast_fr_mlt = .true. ! do freezing and melting in fast microphysics + logical :: fast_dep_sub = .true. ! do deposition and sublimation in fast microphysics + + logical :: do_mp_diag = .false. ! enable microphysical quantities diagnostic + + real :: mp_time = 150.0 ! maximum microphysics time step (s) + + real :: n0w_sig = 1.2 ! intercept parameter (significand) of cloud water (Lin et al. 1983) (1/m^4) (Martin et al. 1994) + real :: n0i_sig = 1.2 ! intercept parameter (significand) of cloud ice (Lin et al. 1983) (1/m^4) (McFarquhar et al. 2015) + real :: n0r_sig = 8.0 ! intercept parameter (significand) of rain (Lin et al. 1983) (1/m^4) (Marshall and Palmer 1948) + real :: n0s_sig = 3.0 ! intercept parameter (significand) of snow (Lin et al. 1983) (1/m^4) (Gunn and Marshall 1958) + real :: n0g_sig = 4.0 ! intercept parameter (significand) of graupel (Rutledge and Hobbs 1984) (1/m^4) (Houze et al. 1979) + real :: n0h_sig = 4.0 ! intercept parameter (significand) of hail (Lin et al. 1983) (1/m^4) (Federer and Waldvogel 1975) + + real :: n0w_exp = 66 ! intercept parameter (exponent) of cloud water (Lin et al. 1983) (1/m^4) (Martin et al. 1994) + real :: n0i_exp = 10 ! intercept parameter (exponent) of cloud ice (Lin et al. 1983) (1/m^4) (McFarquhar et al. 2015) + real :: n0r_exp = 6 ! intercept parameter (exponent) of rain (Lin et al. 1983) (1/m^4) (Marshall and Palmer 1948) + real :: n0s_exp = 6 ! intercept parameter (exponent) of snow (Lin et al. 1983) (1/m^4) (Gunn and Marshall 1958) + real :: n0g_exp = 6 ! intercept parameter (exponent) of graupel (Rutledge and Hobbs 1984) (1/m^4) (Houze et al. 1979) + real :: n0h_exp = 4 ! intercept parameter (exponent) of hail (Lin et al. 1983) (1/m^4) (Federer and Waldvogel 1975) + + real :: muw = 11.0 ! shape parameter of cloud water in Gamma distribution (Martin et al. 1994) + real :: mui = 1.0 ! shape parameter of cloud ice in Gamma distribution (McFarquhar et al. 2015) + real :: mur = 1.0 ! shape parameter of rain in Gamma distribution (Marshall and Palmer 1948) + real :: mus = 1.0 ! shape parameter of snow in Gamma distribution (Gunn and Marshall 1958) + real :: mug = 1.0 ! shape parameter of graupel in Gamma distribution (Houze et al. 1979) + real :: muh = 1.0 ! shape parameter of hail in Gamma distribution (Federer and Waldvogel 1975) + + real :: alinw = 3.e7 ! "a" in Lin et al. (1983) for cloud water (Ikawa and Saito 1990) + real :: alini = 11.72 ! "a" in Lin et al. (1983) for cloud ice (Ikawa and Saita 1990) + real :: alinr = 842.0 ! "a" in Lin et al. (1983) for rain (Liu and Orville 1969) + real :: alins = 4.8 ! "a" in Lin et al. (1983) for snow (straka 2009) + real :: aling = 1.0 ! "a" in Lin et al. (1983), similar to a, but for graupel (Pruppacher and Klett 2010) + real :: alinh = 1.0 ! "a" in Lin et al. (1983), similar to a, but for hail (Pruppacher and Klett 2010) + + real :: blinw = 2.0 ! "b" in Lin et al. (1983) for cloud water (Ikawa and Saito 1990) + real :: blini = 0.41 ! "b" in Lin et al. (1983) for cloud ice (Ikawa and Saita 1990) + real :: blinr = 0.8 ! "b" in Lin et al. (1983) for rain (Liu and Orville 1969) + real :: blins = 0.25 ! "b" in Lin et al. (1983) for snow (straka 2009) + real :: bling = 0.5 ! "b" in Lin et al. (1983), similar to b, but for graupel (Pruppacher and Klett 2010) + real :: blinh = 0.5 ! "b" in Lin et al. (1983), similar to b, but for hail (Pruppacher and Klett 2010) + + real :: tice_mlt = 273.16 ! can set ice melting temperature to 268 based on observation (Kay et al. 2016) (K) + + real :: t_min = 178.0 ! minimum temperature to freeze - dry all water vapor (K) + real :: t_sub = 184.0 ! minimum temperature for sublimation of cloud ice (K) + + real :: rh_inc = 0.30 ! rh increment for complete evaporation of cloud water and cloud ice + real :: rh_inr = 0.30 ! rh increment for minimum evaporation of rain + + ! simple process timescales + real :: tau_r2g = 900.0 ! rain freezing to graupel time scale (s) + real :: tau_i2s = 600.0 ! cloud ice to snow autoconversion time scale (s) + real :: tau_l2r = 900.0 ! cloud water to rain autoconversion time scale (s) + ! other timescales + real :: tau_v2l = 120.0 ! water vapor to cloud water condensation time scale (s) + real :: tau_l2v = 300.0 ! cloud water to water vapor evaporation time scale (s) + real :: tau_revp = 600.0 ! rain evaporation time scale (s) + real :: tau_frez = 600.0 ! cloud liquid freezing time scale (s) + real :: tau_imlt = 600.0 ! cloud ice melting time scale (s) + real :: tau_smlt = 900.0 ! snow melting time scale (s) + real :: tau_gmlt = 1200.0 ! graupel melting time scale (s) + ! subgridz timescales + real :: tau_wbf = 300.0 ! graupel melting time scale (s) + + real :: ccn_o = 90.0 ! ccn over ocean (1/cm^3) + real :: ccn_l = 270.0 ! ccn over land (1/cm^3) + + real :: rthreshu = 7.0e-6 ! unstable critical cloud drop radius (micro m) + real :: rthreshs = 10.0e-6 ! stable critical cloud drop radius (micro m) + + logical :: in_cloud = .true. ! use in-cloud autoconversion + + real :: cld_min = 0.05 ! minimum cloud fraction + + real :: qi_lim = 1.0 ! cloud ice limiter (0: no, 1: full, >1: extra) to prevent large ice build up + + real :: ql_mlt = 2.0e-3 ! maximum cloud water allowed from melted cloud ice (kg/kg) + real :: qs_mlt = 1.0e-6 ! maximum cloud water allowed from melted snow (kg/kg) + + real :: ql0_max = 2.0e-3 ! maximum cloud water value (autoconverted to rain) (kg/kg) + real :: qi0_max = 9.82679e-5 ! maximum cloud ice value (autoconverted to snow) (kg/m^3) + + real :: qi0_crt = 1.0e-4 ! cloud ice to snow autoconversion threshold (kg/m^3) + real :: qs0_crt = 0.6e-3 ! snow to graupel autoconversion threshold (0.6e-3 in Purdue Lin scheme) (kg/m^3) + + real :: c_paut = 0.5 ! cloud water to rain autoconversion efficiency + + ! collection efficiencies for accretion + ! Dry processes (frozen to/from frozen) + real :: c_psaci = 0.05 ! cloud ice to snow accretion efficiency (was 0.1 in ZETAC) + real :: c_pgaci = 0.01 ! cloud ice to graupel accretion efficiency (was 0.1 in ZETAC) + real :: c_pgacs = 0.01 ! snow to graupel accretion efficiency (was 0.1 in ZETAC) + ! Wet processes (liquid to/from frozen) + real :: c_psacw = 1.0 ! cloud water to snow accretion efficiency + real :: c_pracw = 1.0 ! cloud water to rain accretion efficiency + real :: c_praci = 1.0 ! cloud ice to rain accretion efficiency + real :: c_pgacw = 0.01 ! cloud water to graupel accretion efficiency + real :: c_pracs = 1.0 ! snow to rain accretion efficiency + real :: c_psacr = 1.0 ! rain to snow accretion efficiency + real :: c_pgacr = 0.01 ! rain to graupel accretion efficiency + + real :: is_fac = 0.2 ! cloud ice sublimation temperature factor + real :: ss_fac = 0.2 ! snow sublimation temperature factor + real :: gs_fac = 0.2 ! graupel sublimation temperature factor + + real :: rh_fac_evap = 10.0 ! cloud water evaporation relative humidity factor + real :: rh_fac_cond = 10.0 ! cloud water condensation relative humidity factor + + real :: sed_fac = 1.0 ! coefficient for sedimentation fall, scale from 1.0 (implicit) to 0.0 (lagrangian) + + real :: vw_fac = 1.0 + real :: vi_fac = 1.0 + real :: vs_fac = 1.0 + real :: vg_fac = 1.0 + real :: vr_fac = 1.0 + real :: vh_fac = 1.0 + + real :: vw_min = 0.0 !< minimum fall speed for cloud water (m/s) + real :: vi_min = 0.01 !< minimum fall speed or constant fall speed + real :: vs_min = 1. !< minimum fall speed or constant fall speed + real :: vg_min = 3. !< minimum fall speed or constant fall speed + real :: vr_min = 4. !< minimum fall speed or constant fall speed + real :: vh_min = 9. !< minimum fall speed or constant fall speed + + real :: vw_max = 0.01 !< max fall speed for cloud water (m/s) + real :: vi_max = 1.0 !< max fall speed for ice + real :: vs_max = 2.0 !< max fall speed for snow + real :: vg_max = 9.0 !< max fall speed for graupel + real :: vr_max = 12.0 !< max fall speed for rain + real :: vh_max = 19.0 !< max fall speed for hail + + real :: xr_a = 0.25 ! p value in Xu and Randall (1996) + real :: xr_b = 100.0 ! alpha_0 value in Xu and Randall (1996) + real :: xr_c = 0.49 ! gamma value in Xu and Randall (1996) + + real :: te_err = 1.e-5 ! 64bit: 1.e-14, 32bit: 1.e-7; turn off to save computer time + real :: tw_err = 1.e-8 ! 64bit: 1.e-14, 32bit: 1.e-7; turn off to save computer time + + real :: rh_thres = 0.75 ! minimum relative humidity for cloud fraction + real :: rhc_cevap = 0.85 ! maximum relative humidity for cloud water evaporation + real :: rhc_revap = 0.85 ! maximum relative humidity for rain evaporation + + real :: f_dq_p = 3.0 ! cloud fraction adjustment for supersaturation + real :: f_dq_m = 1.0 ! cloud fraction adjustment for undersaturation + + real :: fi2s_fac = 1.00 ! maximum sink of cloud ice to form snow: 0-1 + real :: fi2g_fac = 1.00 ! maximum sink of cloud ice to form graupel: 0-1 + real :: fs2g_fac = 0.75 ! maximum sink of snow to form graupel: 0-1 + + real :: beta = 1.22 ! defined in Heymsfield and Mcfarquhar (1996) + + real :: rewmin = 5.0, rewmax = 10.0 ! minimum and maximum effective radius for cloud water (micron) + real :: reimin = 10.0, reimax = 150.0 ! minimum and maximum effective radius for cloud ice (micron) + real :: rermin = 10.0, rermax = 10000.0 ! minimum and maximum effective radius for rain (micron) + real :: resmin = 150.0, resmax = 10000.0 ! minimum and maximum effective radius for snow (micron) + real :: regmin = 150.0, regmax = 10000.0 ! minimum and maximum effective radius for graupel + !real :: rewmax = 15.0, rermin = 15.0 ! Kokhanovsky (2004) + + real :: rewfac = 1.0 ! this is a tuning parameter to compromise the inconsistency between + ! GFDL MP's PSD and cloud water radiative property's PSD assumption. + ! after the cloud water radiative property's PSD is rebuilt, + ! this parameter should be 1.0. + real :: reifac = 1.0 ! this is a tuning parameter to compromise the inconsistency between + ! GFDL MP's PSD and cloud ice radiative property's PSD assumption. + ! after the cloud ice radiative property's PSD is rebuilt, + ! this parameter should be 1.0. + + ! ----------------------------------------------------------------------- + ! local shared variables + ! ----------------------------------------------------------------------- + + real :: acco (3, 10), acc (20) + real :: cracs, csacr, cgacr, cgacs, csacw, craci, csaci, cgacw, cgaci, cracw + real :: cssub (5), cgsub (5), crevp (5), cgfr (2), csmlt (4), cgmlt (4) + + real :: t_wfr, fac_rc, c_air, c_vap, d0_vap + + real :: srf_type, cnv_fraction, onemsig, fac_eis + + real (kind = r8) :: lv00, li00, li20, cpaut0, cpaut + real (kind = r8) :: d1_vap, d1_ice, c1_vap, c1_liq, c1_ice + real (kind = r8) :: normw, normr, normi, norms, normg, normh + real (kind = r8) :: expow, expor, expoi, expos, expog, expoh + real (kind = r8) :: pcaw, pcar, pcai, pcas, pcag, pcah + real (kind = r8) :: pcbw, pcbr, pcbi, pcbs, pcbg, pcbh + real (kind = r8) :: edaw, edar, edai, edas, edag, edah + real (kind = r8) :: edbw, edbr, edbi, edbs, edbg, edbh + real (kind = r8) :: oeaw, oear, oeai, oeas, oeag, oeah + real (kind = r8) :: oebw, oebr, oebi, oebs, oebg, oebh + real (kind = r8) :: rraw, rrar, rrai, rras, rrag, rrah + real (kind = r8) :: rrbw, rrbr, rrbi, rrbs, rrbg, rrbh + real (kind = r8) :: tvaw, tvar, tvai, tvas, tvag, tvah + real (kind = r8) :: tvbw, tvbr, tvbi, tvbs, tvbg, tvbh + + real, allocatable :: table0 (:), table1 (:), table2 (:), table3 (:), table4 (:) + real, allocatable :: des0 (:), des1 (:), des2 (:), des3 (:), des4 (:) + + ! ----------------------------------------------------------------------- + ! namelist + ! ----------------------------------------------------------------------- + + namelist / gfdl_mp_nml / & + t_min, t_sub, tau_r2g, tau_smlt, tau_gmlt, vw_min, vi_min, & + vr_min, vs_min, vg_min, vh_min, ql_mlt, do_qa, fix_negative, vw_max, vi_max, vs_max, & + vh_max, vg_max, vr_max, qs_mlt, qs0_crt, ql0_max, qi0_max, qi0_crt, ifflag, & + rh_inc, rh_inr, const_vw, const_vi, const_vs, const_vg, const_vr, rthreshu, rthreshs, & + ccn_l, ccn_o, igflag, c_paut, tau_imlt, tau_v2l, tau_l2v, tau_i2s, & + tau_l2r, qi_lim, do_hail, inflag, c_psacw, c_psaci, c_pracs, & + c_psacr, c_pgacr, c_pgacs, c_pgacw, c_pgaci, z_slope_liq, z_slope_ice, & + prog_ccn, c_pracw, c_praci, rad_snow, rad_graupel, rad_rain, cld_min, & + prog_cin, sedflag, sed_fac, do_sedi_uv, do_sedi_w, do_sedi_heat, icloud_f, & + irain_f, xr_a, xr_b, xr_c, ntimes, tau_revp, tice_mlt, do_cond_timescale, & + mp_time, consv_checker, te_err, tw_err, use_rhc_cevap, use_rhc_revap, tau_wbf, & + do_warm_rain_mp, rh_thres, f_dq_p, f_dq_m, do_cld_adj, rhc_cevap, & + rhc_revap, beta, liq_ice_combine, rewflag, reiflag, rerflag, resflag, & + regflag, rewmin, rewmax, reimin, reimax, rermin, rermax, resmin, & + resmax, regmin, regmax, fs2g_fac, fi2s_fac, fi2g_fac, do_sedi_melt, & + radr_flag, rads_flag, radg_flag, do_wbf, do_psd_water_fall, do_psd_ice_fall, & + n0w_sig, n0i_sig, n0r_sig, n0s_sig, n0g_sig, n0h_sig, n0w_exp, n0i_exp, & + n0r_exp, n0s_exp, n0g_exp, n0h_exp, muw, mui, mur, mus, mug, muh, & + alinw, alini, alinr, alins, aling, alinh, blinw, blini, blinr, blins, bling, blinh, & + do_new_acc_water, do_new_acc_ice, is_fac, ss_fac, gs_fac, rh_fac_evap, rh_fac_cond, & + snow_grauple_combine, do_psd_water_num, do_psd_ice_num, vdiffflag, rewfac, reifac, & + cp_heating, nconds, do_evap_timescale, delay_cond_evap, do_subgrid_proc, & + fast_fr_mlt, fast_dep_sub, do_mp_diag + +contains + +! ======================================================================= +! GFDL cloud microphysics initialization +! ======================================================================= + +subroutine gfdl_mp_init (hydrostatic) + + implicit none + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + logical, intent (in) :: hydrostatic + + character (len = 64) :: fn_nml = 'input.nml' + + ! ----------------------------------------------------------------------- + ! local variables + ! ----------------------------------------------------------------------- + + integer :: nlunit + integer :: ios + logical :: exists + + ! ----------------------------------------------------------------------- + ! read namelist + ! ----------------------------------------------------------------------- + +#ifdef INTERNAL_FILE_NML + read (fn_nml, nml = gfdl_mp_nml, iostat = ios) +#else + inquire (file = trim (fn_nml), exist = exists) + if (.not. exists) then + write (6, *) 'gfdl_mp :: namelist file: ', trim (fn_nml), ' does not exist' + stop + else + open(NEWUNIT=nlunit,file=trim(fn_nml), form='formatted',access='sequential',iostat=ios) + if(ios /= 0) stop 'open namelist file gfdl_mp:input.nml failed, bailing out...' + rewind (nlunit, iostat=ios) + if(ios /= 0) stop 'rewind namelist file gfdl_mp:input.nml failed, bailing out...' + ! Read Main namelist + read (nlunit,gfdl_mp_nml,iostat=ios) + if(ios /= 0) stop 'read namelist gfdl_mp:input.nml:gfdl_mp_nml failed, bailing out...' + close(nlunit, iostat=ios) + if(ios /= 0) stop 'close namelist file gfdl_mp:input.nml failed, bailing out...' + endif +#endif + + ! ----------------------------------------------------------------------- + ! write namelist to log file + ! ----------------------------------------------------------------------- + + if (MAPL_AM_I_ROOT()) then + write (*, *) " ================================================================== " + write (*, *) " gfdl_mp_nml" + write (*, nml = gfdl_mp_nml) + write (*, *) " ================================================================== " + endif + + ! ----------------------------------------------------------------------- + ! initialize microphysics variables + ! ----------------------------------------------------------------------- + + if (.not. tables_are_initialized) call qs_init + + call setup_mp + + ! ----------------------------------------------------------------------- + ! define various heat capacities and latent heat coefficients at 0 deg K + ! ----------------------------------------------------------------------- + + call setup_mhc_lhc (hydrostatic) + +end subroutine gfdl_mp_init + +! ======================================================================= +! GFDL cloud microphysics driver +! ======================================================================= + +!subroutine gfdl_mp_driver (qv, ql, qr, qi, qs, qg, qa, zet, qnl, qni, pt, wa, & +! ua, va, delz, delp, dtm, rhcrit, hs, cnv_frc, eis, area, srf_type, water, rain, ice, snow, graupel, & +! hydrostatic, is, ie, ks, ke, q_con, cappa, consv_te, adj_vmr, te, dte, & +! prefluxw, prefluxr, prefluxi, prefluxs, prefluxg, mppcw, mppew, mppe1, & +! mpper, mppdi, mppd1, mppds, mppdg, mppsi, mpps1, mppss, mppsg, mppfw, & +! mppfr, mppmi, mppms, mppmg, mppm1, mppm2, mppm3, mppar, mppas, mppag, & +! mpprs, mpprg, mppxr, mppxs, mppxg, last_step, do_inline_mp, & +! use_cond, moist_kappa) + +subroutine gfdl_mp_driver (qv, ql, qr, qi, qs, qg, qa, qnl, qni, pt, wa, & + ua, va, delz, delp, dtm, rhcrit, hs, cnv_frc, eis, area, srft, & + water, rain, ice, snow, graupel, hydrostatic, is, ie, ks, ke, ktop, & + qv_dt, ql_dt, qr_dt, qi_dt, qs_dt, qg_dt, qa_dt, & + pt_dt, ua_dt, va_dt, wa_dt, & + prefluxw, prefluxr, prefluxi, prefluxs, prefluxg) + + implicit none + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + integer, intent (in) :: is, ie, ks, ke, ktop + + logical, intent (in) :: hydrostatic + + real, intent (in) :: dtm + + real, intent (in), dimension (is:ie) :: hs, cnv_frc, eis, area, srft + + real, intent (in), dimension (is:ie, ks:ke) :: rhcrit, qnl, qni + + real, intent (in), dimension (is:ie, ks:ke) :: delp, delz, pt, ua, va, wa + real, intent (in), dimension (is:ie, ks:ke) :: qv, ql, qr, qi, qs, qg, qa + + real, intent (out), dimension (is:ie, ks:ke) :: qv_dt, ql_dt, qr_dt, qi_dt, qs_dt, qg_dt, qa_dt, pt_dt, ua_dt, va_dt, wa_dt + real, intent (out), dimension (is:ie, ks:ke) :: prefluxw, prefluxr, prefluxi, prefluxs, prefluxg + + real, intent (out), dimension (is:ie) :: water, rain, ice, snow, graupel +! real, intent (inout), dimension (is:ie) :: mppcw, mppew, mppe1, mpper, mppdi +! real, intent (inout), dimension (is:ie) :: mppd1, mppds, mppdg, mppsi, mpps1 +! real, intent (inout), dimension (is:ie) :: mppss, mppsg, mppfw, mppfr, mppar +! real, intent (inout), dimension (is:ie) :: mppas, mppag, mpprs, mpprg, mppxr +! real, intent (inout), dimension (is:ie) :: mppxs, mppxg, mppmi, mppms, mppmg +! real, intent (inout), dimension (is:ie) :: mppm1, mppm2, mppm3 + +! real, intent (inout), dimension (is:, ks:) :: q_con, cappa + + real, dimension (is:ie, ks:ke) :: adj_vmr, te, zet, q_con, cappa + + real (kind = r8), dimension (is:ie) :: dte + + logical :: consv_te = .false. + logical :: do_inline_mp = .false. + logical :: last_step = .true. + logical :: use_cond = .true. + logical :: moist_kappa = .true. + real, dimension (is:ie) :: mppcw, mppew, mppe1, mpper, mppdi + real, dimension (is:ie) :: mppd1, mppds, mppdg, mppsi, mpps1 + real, dimension (is:ie) :: mppss, mppsg, mppfw, mppfr, mppar + real, dimension (is:ie) :: mppas, mppag, mpprs, mpprg, mppxr + real, dimension (is:ie) :: mppxs, mppxg, mppmi, mppms, mppmg + real, dimension (is:ie) :: mppm1, mppm2, mppm3 + + ! ----------------------------------------------------------------------- + ! init to 0.0 + ! ----------------------------------------------------------------------- + + water = 0.0 + rain = 0.0 + ice = 0.0 + snow = 0.0 + graupel = 0.0 + + qv_dt = 0.0 + ql_dt = 0.0 + qr_dt = 0.0 + qi_dt = 0.0 + qs_dt = 0.0 + qg_dt = 0.0 + qa_dt = 0.0 + pt_dt = 0.0 + ua_dt = 0.0 + va_dt = 0.0 + wa_dt = 0.0 + + prefluxw = 0.0 + prefluxr = 0.0 + prefluxi = 0.0 + prefluxs = 0.0 + prefluxg = 0.0 + + mppcw = 0.0 + mppew = 0.0 + mppe1 = 0.0 + mpper = 0.0 + mppdi = 0.0 + + mppd1 = 0.0 + mppds = 0.0 + mppdg = 0.0 + mppsi = 0.0 + mpps1 = 0.0 + + mppss = 0.0 + mppsg = 0.0 + mppfw = 0.0 + mppfr = 0.0 + mppar = 0.0 + + mppas = 0.0 + mppag = 0.0 + mpprs = 0.0 + mpprg = 0.0 + mppxr = 0.0 + + mppxs = 0.0 + mppxg = 0.0 + mppmi = 0.0 + mppms = 0.0 + mppmg = 0.0 + + mppm1 = 0.0 + mppm2 = 0.0 + mppm3 = 0.0 + + ! ----------------------------------------------------------------------- + ! major cloud microphysics driver + ! ----------------------------------------------------------------------- + + call mpdrv (hydrostatic, ua, va, wa, delp, pt, qv, ql, qr, qi, qs, qg, qa, & + zet, qnl, qni, delz, is, ie, ktop, ke, dtm, water, rain, ice, snow, graupel, & + rhcrit, hs, cnv_frc, eis, area, srft, q_con, cappa, consv_te, adj_vmr, te, dte, prefluxw, prefluxr, & + prefluxi, prefluxs, prefluxg, & + qv_dt, ql_dt, qr_dt, qi_dt, qs_dt, qg_dt, qa_dt, pt_dt, ua_dt, va_dt, wa_dt, & + mppcw, mppew, mppe1, mpper, mppdi, mppd1, & + mppds, mppdg, mppsi, mpps1, mppss, mppsg, mppfw, mppfr, mppmi, mppms, & + mppmg, mppm1, mppm2, mppm3, mppar, mppas, mppag, mpprs, mpprg, mppxr, & + mppxs, mppxg, last_step, do_inline_mp, .false., .true., & + use_cond, moist_kappa) + +end subroutine gfdl_mp_driver + +! ======================================================================= +! GFDL cloud microphysics end +! ======================================================================= + +subroutine gfdl_mp_end + + implicit none + + ! ----------------------------------------------------------------------- + ! free up memory + ! ----------------------------------------------------------------------- + + if (allocated (table0)) deallocate (table0) + if (allocated (table1)) deallocate (table1) + if (allocated (table2)) deallocate (table2) + if (allocated (table3)) deallocate (table3) + if (allocated (table4)) deallocate (table4) + if (allocated (des0)) deallocate (des0) + if (allocated (des1)) deallocate (des1) + if (allocated (des2)) deallocate (des2) + if (allocated (des3)) deallocate (des3) + if (allocated (des4)) deallocate (des4) + + tables_are_initialized = .false. + +end subroutine gfdl_mp_end + +! ======================================================================= +! setup cloud microphysics parameters +! ======================================================================= + +subroutine setup_mp + + implicit none + + integer :: i, k + + real :: gcon, hcon, scm3, pisq, act (20), ace (20), occ (3), aone + + ! ----------------------------------------------------------------------- + ! complete freezing temperature + ! ----------------------------------------------------------------------- + + if (do_warm_rain_mp) then + t_wfr = t_min + else + t_wfr = tice - 40.0 + endif + + ! ----------------------------------------------------------------------- + ! cloud water autoconversion, Hong et al. (2004) + ! ----------------------------------------------------------------------- + + aone = 2. / 9. * (3. / 4.) ** (4. / 3.) / pi ** (1. / 3.) + cpaut0 = c_paut * aone * grav / visd + + ! ----------------------------------------------------------------------- + ! terminal velocities parameters, Lin et al. (1983) + ! ----------------------------------------------------------------------- + + gcon = (4. * grav * rhog / (3. * cdg * rho0)) ** 0.5 + hcon = (4. * grav * rhoh / (3. * cdh * rho0)) ** 0.5 + + ! ----------------------------------------------------------------------- + ! part of the slope parameters + ! ----------------------------------------------------------------------- + + normw = pi * rhow * n0w_sig * gamma (muw + 3) + normi = pi * rhoi * n0i_sig * gamma (mui + 3) + normr = pi * rhor * n0r_sig * gamma (mur + 3) + norms = pi * rhos * n0s_sig * gamma (mus + 3) + normg = pi * rhog * n0g_sig * gamma (mug + 3) + normh = pi * rhoh * n0h_sig * gamma (muh + 3) + + expow = exp (n0w_exp / (muw + 3) * log (10.)) + expoi = exp (n0i_exp / (mui + 3) * log (10.)) + expor = exp (n0r_exp / (mur + 3) * log (10.)) + expos = exp (n0s_exp / (mus + 3) * log (10.)) + expog = exp (n0g_exp / (mug + 3) * log (10.)) + expoh = exp (n0h_exp / (muh + 3) * log (10.)) + + ! ----------------------------------------------------------------------- + ! parameters for particle concentration (pc), effective diameter (ed), + ! optical extinction (oe), radar reflectivity factor (rr), and + ! mass-weighted terminal velocity (tv) + ! ----------------------------------------------------------------------- + + pcaw = exp (3 / (muw + 3) * log (n0w_sig)) * gamma (muw) * exp (3 * n0w_exp / (muw + 3) * log (10.)) + pcai = exp (3 / (mui + 3) * log (n0i_sig)) * gamma (mui) * exp (3 * n0i_exp / (mui + 3) * log (10.)) + pcar = exp (3 / (mur + 3) * log (n0r_sig)) * gamma (mur) * exp (3 * n0r_exp / (mur + 3) * log (10.)) + pcas = exp (3 / (mus + 3) * log (n0s_sig)) * gamma (mus) * exp (3 * n0s_exp / (mus + 3) * log (10.)) + pcag = exp (3 / (mug + 3) * log (n0g_sig)) * gamma (mug) * exp (3 * n0g_exp / (mug + 3) * log (10.)) + pcah = exp (3 / (muh + 3) * log (n0h_sig)) * gamma (muh) * exp (3 * n0h_exp / (muh + 3) * log (10.)) + + pcbw = exp (muw / (muw + 3) * log (pi * rhow * gamma (muw + 3))) + pcbi = exp (mui / (mui + 3) * log (pi * rhoi * gamma (mui + 3))) + pcbr = exp (mur / (mur + 3) * log (pi * rhor * gamma (mur + 3))) + pcbs = exp (mus / (mus + 3) * log (pi * rhos * gamma (mus + 3))) + pcbg = exp (mug / (mug + 3) * log (pi * rhog * gamma (mug + 3))) + pcbh = exp (muh / (muh + 3) * log (pi * rhoh * gamma (muh + 3))) + + edaw = exp (- 1. / (muw + 3) * log (n0w_sig)) * (muw + 2) * exp (- n0w_exp / (muw + 3) * log (10.)) + edai = exp (- 1. / (mui + 3) * log (n0i_sig)) * (mui + 2) * exp (- n0i_exp / (mui + 3) * log (10.)) + edar = exp (- 1. / (mur + 3) * log (n0r_sig)) * (mur + 2) * exp (- n0r_exp / (mur + 3) * log (10.)) + edas = exp (- 1. / (mus + 3) * log (n0s_sig)) * (mus + 2) * exp (- n0s_exp / (mus + 3) * log (10.)) + edag = exp (- 1. / (mug + 3) * log (n0g_sig)) * (mug + 2) * exp (- n0g_exp / (mug + 3) * log (10.)) + edah = exp (- 1. / (muh + 3) * log (n0h_sig)) * (muh + 2) * exp (- n0h_exp / (muh + 3) * log (10.)) + + edbw = exp (1. / (muw + 3) * log (pi * rhow * gamma (muw + 3))) + edbi = exp (1. / (mui + 3) * log (pi * rhoi * gamma (mui + 3))) + edbr = exp (1. / (mur + 3) * log (pi * rhor * gamma (mur + 3))) + edbs = exp (1. / (mus + 3) * log (pi * rhos * gamma (mus + 3))) + edbg = exp (1. / (mug + 3) * log (pi * rhog * gamma (mug + 3))) + edbh = exp (1. / (muh + 3) * log (pi * rhoh * gamma (muh + 3))) + + oeaw = exp (1. / (muw + 3) * log (n0w_sig)) * pi * gamma (muw + 2) * & + exp (n0w_exp / (muw + 3) * log (10.)) + oeai = exp (1. / (mui + 3) * log (n0i_sig)) * pi * gamma (mui + 2) * & + exp (n0i_exp / (mui + 3) * log (10.)) + oear = exp (1. / (mur + 3) * log (n0r_sig)) * pi * gamma (mur + 2) * & + exp (n0r_exp / (mur + 3) * log (10.)) + oeas = exp (1. / (mus + 3) * log (n0s_sig)) * pi * gamma (mus + 2) * & + exp (n0s_exp / (mus + 3) * log (10.)) + oeag = exp (1. / (mug + 3) * log (n0g_sig)) * pi * gamma (mug + 2) * & + exp (n0g_exp / (mug + 3) * log (10.)) + oeah = exp (1. / (muh + 3) * log (n0h_sig)) * pi * gamma (muh + 2) * & + exp (n0h_exp / (muh + 3) * log (10.)) + + oebw = 2 * exp ((muw + 2) / (muw + 3) * log (pi * rhow * gamma (muw + 3))) + oebi = 2 * exp ((mui + 2) / (mui + 3) * log (pi * rhoi * gamma (mui + 3))) + oebr = 2 * exp ((mur + 2) / (mur + 3) * log (pi * rhor * gamma (mur + 3))) + oebs = 2 * exp ((mus + 2) / (mus + 3) * log (pi * rhos * gamma (mus + 3))) + oebg = 2 * exp ((mug + 2) / (mug + 3) * log (pi * rhog * gamma (mug + 3))) + oebh = 2 * exp ((muh + 2) / (muh + 3) * log (pi * rhoh * gamma (muh + 3))) + + rraw = exp (- 3 / (muw + 3) * log (n0w_sig)) * gamma (muw + 6) * & + exp (- 3 * n0w_exp / (muw + 3) * log (10.)) + rrai = exp (- 3 / (mui + 3) * log (n0i_sig)) * gamma (mui + 6) * & + exp (- 3 * n0i_exp / (mui + 3) * log (10.)) + rrar = exp (- 3 / (mur + 3) * log (n0r_sig)) * gamma (mur + 6) * & + exp (- 3 * n0r_exp / (mur + 3) * log (10.)) + rras = exp (- 3 / (mus + 3) * log (n0s_sig)) * gamma (mus + 6) * & + exp (- 3 * n0s_exp / (mus + 3) * log (10.)) + rrag = exp (- 3 / (mug + 3) * log (n0g_sig)) * gamma (mug + 6) * & + exp (- 3 * n0g_exp / (mug + 3) * log (10.)) + rrah = exp (- 3 / (muh + 3) * log (n0h_sig)) * gamma (muh + 6) * & + exp (- 3 * n0h_exp / (muh + 3) * log (10.)) + + rrbw = exp ((muw + 6) / (muw + 3) * log (pi * rhow * gamma (muw + 3))) + rrbi = exp ((mui + 6) / (mui + 3) * log (pi * rhoi * gamma (mui + 3))) + rrbr = exp ((mur + 6) / (mur + 3) * log (pi * rhor * gamma (mur + 3))) + rrbs = exp ((mus + 6) / (mus + 3) * log (pi * rhos * gamma (mus + 3))) + rrbg = exp ((mug + 6) / (mug + 3) * log (pi * rhog * gamma (mug + 3))) + rrbh = exp ((muh + 6) / (muh + 3) * log (pi * rhoh * gamma (muh + 3))) + + tvaw = exp (- blinw / (muw + 3) * log (n0w_sig)) * alinw * gamma (muw + blinw + 3) * & + exp (- blinw * n0w_exp / (muw + 3) * log (10.)) + tvai = exp (- blini / (mui + 3) * log (n0i_sig)) * alini * gamma (mui + blini + 3) * & + exp (- blini * n0i_exp / (mui + 3) * log (10.)) + tvar = exp (- blinr / (mur + 3) * log (n0r_sig)) * alinr * gamma (mur + blinr + 3) * & + exp (- blinr * n0r_exp / (mur + 3) * log (10.)) + tvas = exp (- blins / (mus + 3) * log (n0s_sig)) * alins * gamma (mus + blins + 3) * & + exp (- blins * n0s_exp / (mus + 3) * log (10.)) + tvag = exp (- bling / (mug + 3) * log (n0g_sig)) * aling * gamma (mug + bling + 3) * & + exp (- bling * n0g_exp / (mug + 3) * log (10.)) * gcon + tvah = exp (- blinh / (muh + 3) * log (n0h_sig)) * alinh * gamma (muh + blinh + 3) * & + exp (- blinh * n0h_exp / (muh + 3) * log (10.)) * hcon + + tvbw = exp (blinw / (muw + 3) * log (pi * rhow * gamma (muw + 3))) * gamma (muw + 3) + tvbi = exp (blini / (mui + 3) * log (pi * rhoi * gamma (mui + 3))) * gamma (mui + 3) + tvbr = exp (blinr / (mur + 3) * log (pi * rhor * gamma (mur + 3))) * gamma (mur + 3) + tvbs = exp (blins / (mus + 3) * log (pi * rhos * gamma (mus + 3))) * gamma (mus + 3) + tvbg = exp (bling / (mug + 3) * log (pi * rhog * gamma (mug + 3))) * gamma (mug + 3) + tvbh = exp (blinh / (muh + 3) * log (pi * rhoh * gamma (muh + 3))) * gamma (muh + 3) + + ! ----------------------------------------------------------------------- + ! Schmidt number, Sc ** (1 / 3) in Lin et al. (1983) + ! ----------------------------------------------------------------------- + + scm3 = exp (1. / 3. * log (visk / vdifu)) + + pisq = pi * pi + + ! ----------------------------------------------------------------------- + ! accretion between cloud water, cloud ice, rain, snow, and graupel or hail, Lin et al. (1983) + ! ----------------------------------------------------------------------- + + cracw = pi * n0r_sig * alinr * gamma (2 + mur + blinr) / & + (4. * exp ((2 + mur + blinr) / (mur + 3) * log (normr))) * & + exp ((1 - blinr) * log (expor)) + craci = pi * n0r_sig * alinr * gamma (2 + mur + blinr) / & + (4. * exp ((2 + mur + blinr) / (mur + 3) * log (normr))) * & + exp ((1 - blinr) * log (expor)) + csacw = pi * n0s_sig * alins * gamma (2 + mus + blins) / & + (4. * exp ((2 + mus + blins) / (mus + 3) * log (norms))) * & + exp ((1 - blins) * log (expos)) + csaci = pi * n0s_sig * alins * gamma (2 + mus + blins) / & + (4. * exp ((2 + mus + blins) / (mus + 3) * log (norms))) * & + exp ((1 - blins) * log (expos)) + if (do_hail) then + cgacw = pi * n0h_sig * alinh * gamma (2 + muh + blinh) * hcon / & + (4. * exp ((2 + muh + blinh) / (muh + 3) * log (normh))) * & + exp ((1 - blinh) * log (expoh)) + cgaci = pi * n0h_sig * alinh * gamma (2 + muh + blinh) * hcon / & + (4. * exp ((2 + muh + blinh) / (muh + 3) * log (normh))) * & + exp ((1 - blinh) * log (expoh)) + else + cgacw = pi * n0g_sig * aling * gamma (2 + mug + bling) * gcon / & + (4. * exp ((2 + mug + bling) / (mug + 3) * log (normg))) * & + exp ((1 - bling) * log (expog)) + cgaci = pi * n0g_sig * aling * gamma (2 + mug + bling) * gcon / & + (4. * exp ((2 + mug + bling) / (mug + 3) * log (normg))) * & + exp ((1 - bling) * log (expog)) + endif + + if (do_new_acc_water) then + + cracw = pisq * n0r_sig * n0w_sig * rhow / 24. + csacw = pisq * n0s_sig * n0w_sig * rhow / 24. + if (do_hail) then + cgacw = pisq * n0h_sig * n0w_sig * rhow / 24. + else + cgacw = pisq * n0g_sig * n0w_sig * rhow / 24. + endif + + endif + + if (do_new_acc_ice) then + + craci = pisq * n0r_sig * n0i_sig * rhoi / 24. + csaci = pisq * n0s_sig * n0i_sig * rhoi / 24. + if (do_hail) then + cgaci = pisq * n0h_sig * n0i_sig * rhoi / 24. + else + cgaci = pisq * n0g_sig * n0i_sig * rhoi / 24. + endif + + endif + + cracw = cracw * c_pracw + craci = craci * c_praci + csacw = csacw * c_psacw + csaci = csaci * c_psaci + cgacw = cgacw * c_pgacw + cgaci = cgaci * c_pgaci + + ! ----------------------------------------------------------------------- + ! accretion between cloud water, cloud ice, rain, snow, and graupel or hail, Lin et al. (1983) + ! ----------------------------------------------------------------------- + + cracs = pisq * n0r_sig * n0s_sig * rhos / 24. + csacr = pisq * n0s_sig * n0r_sig * rhor / 24. + if (do_hail) then + cgacr = pisq * n0h_sig * n0r_sig * rhor / 24. + cgacs = pisq * n0h_sig * n0s_sig * rhos / 24. + else + cgacr = pisq * n0g_sig * n0r_sig * rhor / 24. + cgacs = pisq * n0g_sig * n0s_sig * rhos / 24. + endif + + cracs = cracs * c_pracs + csacr = csacr * c_psacr + cgacr = cgacr * c_pgacr + cgacs = cgacs * c_pgacs + + ! act / ace / acc: + ! 1 - 2: racs (s - r) + ! 3 - 4: sacr (r - s) + ! 5 - 6: gacr (r - g) + ! 7 - 8: gacs (s - g) + ! 9 - 10: racw (w - r) + ! 11 - 12: raci (i - r) + ! 13 - 14: sacw (w - s) + ! 15 - 16: saci (i - s) + ! 17 - 18: sacw (w - g) + ! 19 - 20: saci (i - g) + + act (1) = norms + act (2) = normr + act (3) = act (2) + act (4) = act (1) + act (5) = act (2) + if (do_hail) then + act (6) = normh + else + act (6) = normg + endif + act (7) = act (1) + act (8) = act (6) + act (9) = normw + act (10) = act (2) + act (11) = normi + act (12) = act (2) + act (13) = act (9) + act (14) = act (1) + act (15) = act (11) + act (16) = act (1) + act (17) = act (9) + act (18) = act (6) + act (19) = act (11) + act (20) = act (6) + + ace (1) = expos + ace (2) = expor + ace (3) = ace (2) + ace (4) = ace (1) + ace (5) = ace (2) + if (do_hail) then + ace (6) = expoh + else + ace (6) = expog + endif + ace (7) = ace (1) + ace (8) = ace (6) + ace (9) = expow + ace (10) = ace (2) + ace (11) = expoi + ace (12) = ace (2) + ace (13) = ace (9) + ace (14) = ace (1) + ace (15) = ace (11) + ace (16) = ace (1) + ace (17) = ace (9) + ace (18) = ace (6) + ace (19) = ace (11) + ace (20) = ace (6) + + acc (1) = mus + acc (2) = mur + acc (3) = acc (2) + acc (4) = acc (1) + acc (5) = acc (2) + if (do_hail) then + acc (6) = muh + else + acc (6) = mug + endif + acc (7) = acc (1) + acc (8) = acc (6) + acc (9) = muw + acc (10) = acc (2) + acc (11) = mui + acc (12) = acc (2) + acc (13) = acc (9) + acc (14) = acc (1) + acc (15) = acc (11) + acc (16) = acc (1) + acc (17) = acc (9) + acc (18) = acc (6) + acc (19) = acc (11) + acc (20) = acc (6) + + occ (1) = 1. + occ (2) = 2. + occ (3) = 1. + + do i = 1, 3 + do k = 1, 10 + acco (i, k) = occ (i) * gamma (6 + acc (2 * k - 1) - i) * gamma (acc (2 * k) + i - 1) / & + (exp ((6 + acc (2 * k - 1) - i) / (acc (2 * k - 1) + 3) * log (act (2 * k - 1))) * & + exp ((acc (2 * k) + i - 1) / (acc (2 * k) + 3) * log (act (2 * k)))) * & + exp ((i - 3) * log (ace (2 * k - 1))) * exp ((4 - i) * log (ace (2 * k))) + enddo + enddo + + ! ----------------------------------------------------------------------- + ! rain evaporation, snow sublimation, and graupel or hail sublimation, Lin et al. (1983) + ! ----------------------------------------------------------------------- + + crevp (1) = 2. * pi * vdifu * tcond * rvgas * n0r_sig * gamma (1 + mur) / & + exp ((1 + mur) / (mur + 3) * log (normr)) * exp (2.0 * log (expor)) + crevp (2) = 0.78 + crevp (3) = 0.31 * scm3 * sqrt (alinr / visk) * gamma ((3 + 2 * mur + blinr) / 2) / & + exp ((3 + 2 * mur + blinr) / (mur + 3) / 2 * log (normr)) * & + exp ((1 + mur) / (mur + 3) * log (normr)) / gamma (1 + mur) * & + exp ((- 1 - blinr) / 2. * log (expor)) + crevp (4) = tcond * rvgas + crevp (5) = vdifu + + cssub (1) = 2. * pi * vdifu * tcond * rvgas * n0s_sig * gamma (1 + mus) / & + exp ((1 + mus) / (mus + 3) * log (norms)) * exp (2.0 * log (expos)) + cssub (2) = 0.78 + cssub (3) = 0.31 * scm3 * sqrt (alins / visk) * gamma ((3 + 2 * mus + blins) / 2) / & + exp ((3 + 2 * mus + blins) / (mus + 3) / 2 * log (norms)) * & + exp ((1 + mus) / (mus + 3) * log (norms)) / gamma (1 + mus) * & + exp ((- 1 - blins) / 2. * log (expos)) + cssub (4) = tcond * rvgas + cssub (5) = vdifu + + if (do_hail) then + cgsub (1) = 2. * pi * vdifu * tcond * rvgas * n0h_sig * gamma (1 + muh) / & + exp ((1 + muh) / (muh + 3) * log (normh)) * exp (2.0 * log (expoh)) + cgsub (2) = 0.78 + cgsub (3) = 0.31 * scm3 * sqrt (alinh * hcon / visk) * gamma ((3 + 2 * muh + blinh) / 2) / & + exp (1. / (muh + 3) * (3 + 2 * muh + blinh) / 2 * log (normh)) * & + exp (1. / (muh + 3) * (1 + muh) * log (normh)) / gamma (1 + muh) * & + exp ((- 1 - blinh) / 2. * log (expoh)) + else + cgsub (1) = 2. * pi * vdifu * tcond * rvgas * n0g_sig * gamma (1 + mug) / & + exp ((1 + mug) / (mug + 3) * log (normg)) * exp (2.0 * log (expog)) + cgsub (2) = 0.78 + cgsub (3) = 0.31 * scm3 * sqrt (aling * gcon / visk) * gamma ((3 + 2 * mug + bling) / 2) / & + exp ((3 + 2 * mug + bling) / (mug + 3) / 2 * log (normg)) * & + exp ((1 + mug) / (mug + 3) * log (normg)) / gamma (1 + mug) * & + exp ((- 1 - bling) / 2. * log (expog)) + endif + cgsub (4) = tcond * rvgas + cgsub (5) = vdifu + + ! ----------------------------------------------------------------------- + ! snow melting, Lin et al. (1983) + ! ----------------------------------------------------------------------- + + csmlt (1) = 2. * pi * tcond * n0s_sig * gamma (1 + mus) / & + exp ((1 + mus) / (mus + 3) * log (norms)) * exp (2.0 * log (expos)) + csmlt (2) = 2. * pi * vdifu * n0s_sig * gamma (1 + mus) / & + exp ((1 + mus) / (mus + 3) * log (norms)) * exp (2.0 * log (expos)) + csmlt (3) = cssub (2) + csmlt (4) = cssub (3) + + ! ----------------------------------------------------------------------- + ! graupel or hail melting, Lin et al. (1983) + ! ----------------------------------------------------------------------- + + if (do_hail) then + cgmlt (1) = 2. * pi * tcond * n0h_sig * gamma (1 + muh) / & + exp ((1 + muh) / (muh + 3) * log (normh)) * exp (2.0 * log (expoh)) + cgmlt (2) = 2. * pi * vdifu * n0h_sig * gamma (1 + muh) / & + exp ((1 + muh) / (muh + 3) * log (normh)) * exp (2.0 * log (expoh)) + else + cgmlt (1) = 2. * pi * tcond * n0g_sig * gamma (1 + mug) / & + exp ((1 + mug) / (mug + 3) * log (normg)) * exp (2.0 * log (expog)) + cgmlt (2) = 2. * pi * vdifu * n0g_sig * gamma (1 + mug) / & + exp ((1 + mug) / (mug + 3) * log (normg)) * exp (2.0 * log (expog)) + endif + cgmlt (3) = cgsub (2) + cgmlt (4) = cgsub (3) + + ! ----------------------------------------------------------------------- + ! rain freezing, Lin et al. (1983) + ! ----------------------------------------------------------------------- + + cgfr (1) = 1.e2 / 36 * pisq * n0r_sig * rhor * gamma (6 + mur) / & + exp ((6 + mur) / (mur + 3) * log (normr)) * exp (- 3.0 * log (expor)) + cgfr (2) = 0.66 + +end subroutine setup_mp + +! ======================================================================= +! define various heat capacities and latent heat coefficients at 0 deg K +! ======================================================================= + +subroutine setup_mhc_lhc (hydrostatic) + + implicit none + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + logical, intent (in) :: hydrostatic + + if (hydrostatic) then + c_air = cp_air + c_vap = cp_vap + do_sedi_w = .false. + else + c_air = cv_air + c_vap = cv_vap + endif + d0_vap = c_vap - c_liq + + ! scaled constants (to reduce float point errors for 32-bit) + + d1_vap = d0_vap / c_air + d1_ice = dc_ice / c_air + + if (hydrostatic) then + lv00 = (hlv - d0_vap * tice) / c_air + else +#ifdef ENG_CNV_OLD + lv00 = (hlv - d0_vap * tice) / c_air +#else + lv00 = (hlv - d0_vap * tice - rvgas * tice) / c_air +#endif + endif + li00 = (hlf - dc_ice * tice) / c_air + li20 = lv00 + li00 + + c1_vap = c_vap / c_air + c1_liq = c_liq / c_air + c1_ice = c_ice / c_air + +end subroutine setup_mhc_lhc + +! ======================================================================= +! major cloud microphysics driver +! ======================================================================= + +subroutine mpdrv (hydrostatic, ua, va, wa, delp, pt, qv, ql, qr, qi, qs, qg, qa, & + zet, qnl, qni, delz, is, ie, ks, ke, dtm, water, rain, ice, snow, graupel, & + rhcrit, hs, cnv_frc, eis, area, srft, q_con, cappa, consv_te, adj_vmr, te, dte, prefluxw, prefluxr, & + prefluxi, prefluxs, prefluxg, & + qv_dt, ql_dt, qr_dt, qi_dt, qs_dt, qg_dt, qa_dt, pt_dt, ua_dt, va_dt, wa_dt, & + mppcw, mppew, mppe1, mpper, mppdi, mppd1, & + mppds, mppdg, mppsi, mpps1, mppss, mppsg, mppfw, mppfr, mppmi, mppms, & + mppmg, mppm1, mppm2, mppm3, mppar, mppas, mppag, mpprs, mpprg, mppxr, & + mppxs, mppxg, last_step, do_inline_mp, do_mp_fast, do_mp_full, & + use_cond, moist_kappa) + + implicit none + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + integer, intent (in) :: is, ie, ks, ke + + logical, intent (in) :: hydrostatic, last_step, consv_te, do_inline_mp + logical, intent (in) :: do_mp_fast, do_mp_full, use_cond, moist_kappa + + real, intent (in) :: dtm + + real, intent (in), dimension (is:ie) :: hs, cnv_frc, eis, area, srft + + real, intent (in), dimension (:, :) :: rhcrit, qnl, qni + + real, intent (in ), dimension (:, :) :: delp, delz, pt, ua, va, wa + real, intent (in ), dimension (:, :) :: qv, ql, qr, qi, qs, qg, qa + real, intent (inout), dimension (:, :) :: zet + real, intent (inout), dimension (:, :) :: prefluxw, prefluxr, prefluxi, prefluxs, prefluxg + real, intent (inout), dimension (:, :) :: qv_dt, ql_dt, qr_dt, qi_dt, qs_dt, qg_dt, qa_dt, pt_dt, ua_dt, va_dt, wa_dt + + real, intent (inout), dimension (:, :) :: q_con, cappa + + real, intent (inout), dimension (is:ie) :: water, rain, ice, snow, graupel + real, intent (inout), dimension (is:ie) :: mppcw, mppew, mppe1, mpper, mppdi + real, intent (inout), dimension (is:ie) :: mppd1, mppds, mppdg, mppsi, mpps1 + real, intent (inout), dimension (is:ie) :: mppss, mppsg, mppfw, mppfr, mppar + real, intent (inout), dimension (is:ie) :: mppas, mppag, mpprs, mpprg, mppxr + real, intent (inout), dimension (is:ie) :: mppxs, mppxg, mppmi, mppms, mppmg + real, intent (inout), dimension (is:ie) :: mppm1, mppm2, mppm3 + + real, intent ( out), dimension (:, :) :: te, adj_vmr + + real (kind = r8), intent (out), dimension (is:ie) :: dte + + ! ----------------------------------------------------------------------- + ! local variables + ! ----------------------------------------------------------------------- + + integer :: i, k + + real :: ccn0, cin0, q1, q2 + real :: convt, rdt, dts, q_cond, tmp, nl, ni + + real, dimension (ks:ke) :: h_var + real, dimension (ks:ke) :: q_liq, q_sol, dp, dz, dp0 + real, dimension (ks:ke) :: qvz, qlz, qrz, qiz, qsz, qgz, qaz, zez + real, dimension (ks:ke) :: den, pz, denfac, ccn, cin + real, dimension (ks:ke) :: u, v, w + + real, dimension (ks:ke) :: pcw, edw, oew, rrw, tvw + real, dimension (ks:ke) :: pci, edi, oei, rri, tvi + real, dimension (ks:ke) :: pcr, edr, oer, rrr, tvr + real, dimension (ks:ke) :: pcs, eds, oes, rrs, tvs + real, dimension (ks:ke) :: pcg, edg, oeg, rrg, tvg + + real (kind = r8) :: con_r8, c8, cp8 + + real (kind = r8), dimension (is:ie, ks:ke) :: te_beg_d, te_end_d, tw_beg_d, tw_end_d + real (kind = r8), dimension (is:ie, ks:ke) :: te_beg_m, te_end_m, tw_beg_m, tw_end_m + + real (kind = r8), dimension (is:ie) :: te_b_beg_d, te_b_end_d, tw_b_beg_d, tw_b_end_d, te_loss + real (kind = r8), dimension (is:ie) :: te_b_beg_m, te_b_end_m, tw_b_beg_m, tw_b_end_m + + real (kind = r8), dimension (ks:ke) :: tz, tzuv, tzw + + ! ----------------------------------------------------------------------- + ! time steps + ! ----------------------------------------------------------------------- + + ntimes = max (ntimes, int (dtm / min (dtm, mp_time))) + dts = dtm / real (ntimes) + rdt = 1.0 / dtm + + ! ----------------------------------------------------------------------- + ! initialization of total energy difference + ! ----------------------------------------------------------------------- + + dte = 0.0 + adj_vmr = 1.0 + + ! ----------------------------------------------------------------------- + ! unit convert to mm/day + ! ----------------------------------------------------------------------- + + convt = 86400. * rgrav / dtm + + do i = is, ie + + ! ----------------------------------------------------------------------- + ! diagnosed convective fraction and surface type (input) + ! ----------------------------------------------------------------------- + cnv_fraction = cnv_frc(i) + srf_type = srft(i) + + ! ----------------------------------------------------------------------- + ! 1 minus sigma used to control resolution sensitive parameters + ! ----------------------------------------------------------------------- + onemsig = 1.0 - sigma(sqrt(area(i))) + + ! ----------------------------------------------------------------------- + ! Use estimated inversion strength to determine stable vs unstable areas + ! ----------------------------------------------------------------------- + if (srf_type < 2.0) then ! exclude snow/ice covered regions + fac_eis = min(1.0,eis(i)/10.0)**2 ! Estimated inversion strength determine stable regime + else + fac_eis = 0.0 + endif + + ! ----------------------------------------------------------------------- + ! adjust autoconversion rates and thresholds for stable vs unstable + ! ----------------------------------------------------------------------- + cpaut = cpaut0 * ( 0.75*fac_eis + (1.0-fac_eis)) + fac_rc = rc * (rthreshs*fac_eis + rthreshu*(1.0-fac_eis)) ** 3 + + ! ----------------------------------------------------------------------- + ! conversion of temperature + ! ----------------------------------------------------------------------- + + if (do_inline_mp) then + do k = ks, ke + q_cond = ql (i, k) + qr (i, k) + qi (i, k) + qs (i, k) + qg (i, k) + tz (k) = pt (i, k) / ((1. + zvir * qv (i, k)) * (1. - q_cond)) + enddo + else + do k = ks, ke + tz (k) = pt (i, k) + enddo + endif + + ! ----------------------------------------------------------------------- + ! calculate base total energy + ! ----------------------------------------------------------------------- + + if (consv_te) then + if (hydrostatic) then + do k = ks, ke + te (i, k) = - c_air * tz (k) * delp (i, k) + enddo + else + do k = ks, ke + te (i, k) = - mte (qv (i, k), ql (i, k), qr (i, k), qi (i, k), & + qs (i, k), qg (i, k), tz (k), delp (i, k), .true.) * grav + enddo + endif + endif + + ! ----------------------------------------------------------------------- + ! total energy checker + ! ----------------------------------------------------------------------- + + if (consv_checker) then + call mtetw (ks, ke, qv (i, ks:), ql (i, ks:), qr (i, ks:), qi (i, ks:), & + qs (i, ks:), qg (i, ks:), tz, ua (i, ks:), va (i, ks:), wa (i, ks:), & + delp (i, :), dte (i), 0.0, water (i), rain (i), ice (i), & + snow (i), graupel (i), 0.0, 0.0, dtm, te_beg_m (i, ks:), & + tw_beg_m (i, :), te_b_beg_m (i), tw_b_beg_m (i), .true., hydrostatic) + endif + + do k = ks, ke + + ! ----------------------------------------------------------------------- + ! convert specific ratios to mass mixing ratios + ! ----------------------------------------------------------------------- + + qvz (k) = qv (i, k) + qlz (k) = ql (i, k) + qrz (k) = qr (i, k) + qiz (k) = qi (i, k) + qsz (k) = qs (i, k) + qgz (k) = qg (i, k) + qaz (k) = qa (i, k) + zez (k) = zet (i, k) + + if (do_inline_mp) then + q_cond = qlz (k) + qrz (k) + qiz (k) + qsz (k) + qgz (k) + con_r8 = one_r8 - (qvz (k) + q_cond) + else + con_r8 = one_r8 - qvz (k) + endif + + ! dp0: original moist air_mass + dp0 (k) = delp (i, k) + ! dp: dry air_mass + dp (k) = delp (i, k) * con_r8 + con_r8 = one_r8 / con_r8 + + qvz (k) = qvz (k) * con_r8 + qlz (k) = qlz (k) * con_r8 + qrz (k) = qrz (k) * con_r8 + qiz (k) = qiz (k) * con_r8 + qsz (k) = qsz (k) * con_r8 + qgz (k) = qgz (k) * con_r8 + + ! ----------------------------------------------------------------------- + ! dry air density and layer-mean pressure thickness + ! ----------------------------------------------------------------------- + + dz (k) = delz (i, k) + den (k) = - dp (k) / (grav * dz (k)) + pz (k) = den (k) * rdgas * tz (k) + + ! ----------------------------------------------------------------------- + ! for sedi_momentum transport + ! ----------------------------------------------------------------------- + + u (k) = ua (i, k) + v (k) = va (i, k) + if (.not. hydrostatic) then + w (k) = wa (i, k) + endif + + enddo + + do k = ks, ke + denfac (k) = sqrt (den (ke) / den (k)) + enddo + + ! ----------------------------------------------------------------------- + ! total energy checker + ! ----------------------------------------------------------------------- + + if (consv_checker) then + call mtetw (ks, ke, qvz, qlz, qrz, qiz, qsz, qgz, tz, u, v, w, & + dp, dte (i), 0.0, water (i), rain (i), ice (i), snow (i), & + graupel (i), 0.0, 0.0, dtm, te_beg_d (i, :), tw_beg_d (i, :), & + te_b_beg_d (i), tw_b_beg_d (i), .false., hydrostatic) + endif + + ! ----------------------------------------------------------------------- + ! cloud condensation nuclei (CCN), cloud ice nuclei (CIN) + ! ----------------------------------------------------------------------- + + if (prog_ccn) then + do k = ks, ke + ! ! boucher and lohmann (1995) + ! nl = min (1., abs (hs (i)) / (10. * grav)) * & + ! (10. ** 2.24 * (qnl (i, k) * den (k) * 1.e9) ** 0.257) + & + ! (1. - min (1., abs (hs (i)) / (10. * grav))) * & + ! (10. ** 2.06 * (qnl (i, k) * den (k) * 1.e9) ** 0.48) + ! ccn (k) = max (10.0, nl) * 1.e6 + ! ccn (k) = ccn (k) / den (k) + ! qnl import from GEOS has units # / m^3 + ccn (k) = qnl (i, k) / den (k) + enddo + else + ccn0 = (ccn_l * min (1., abs (hs (i)) / (10. * grav)) + & + ccn_o * (1. - min (1., abs (hs (i)) / (10. * grav)))) * 1.e6 + do k = ks, ke + ccn (k) = ccn0 / den (k) + enddo + endif + + if (prog_cin) then + do k = ks, ke + ! ni = qni (i, k) + ! cin (k) = max (10.0, ni) * 1.e6 + ! cin (k) = cin (k) / den (k) + ! qni import fro GEOS has units # / m^3 + cin (k) = qni (i, k) / den (k) + enddo + else + cin0 = 0. + do k = ks, ke + cin (k) = cin0 / den (k) + enddo + endif + + ! ----------------------------------------------------------------------- + ! import horizontal subgrid variability with pressure dependence + ! total water subgrid deviation in horizontal direction + ! default area dependent form: use dx ~ 100 km as the base + ! ----------------------------------------------------------------------- + do k = ks, ke + h_var(k) = min(0.30,1.0 - rhcrit(i,k)) ! restricted to 70% + enddo + + ! ----------------------------------------------------------------------- + ! fix negative water species from outside + ! ----------------------------------------------------------------------- + + if (fix_negative) & + call neg_adj (ks, ke, tz, dp, qaz, qvz, qlz, qrz, qiz, qsz, qgz, mppcw (i), & + mppfr (i), convt) + + ! ----------------------------------------------------------------------- + ! fast microphysics loop + ! ----------------------------------------------------------------------- + + if (do_mp_fast) then + + call mp_fast (ks, ke, tz, qaz, qvz, qlz, qrz, qiz, qsz, qgz, dtm, dp, den, & + ccn, cin, mppcw (i), mppew (i), mppdi (i), mppds (i), mppdg (i), & + mppsi (i), mppss (i), mppsg (i), mppfw (i), mppfr (i), mppmi (i), & + mppms (i), mppar (i), mppas (i), denfac, convt, last_step) + + endif + + ! ----------------------------------------------------------------------- + ! full microphysics loop + ! ----------------------------------------------------------------------- + + if (do_mp_full) then + + call mp_full (ks, ke, ntimes, tz, qaz, qvz, qlz, qrz, qiz, qsz, qgz, dp, dz, & + u, v, w, den, denfac, ccn, cin, dts, h_var, dte (i), & + water (i), rain (i), ice (i), snow (i), graupel (i), prefluxw (i, ks:), & + prefluxr (i, ks:), prefluxi (i, ks:), prefluxs (i, ks:), prefluxg (i, ks:), & + mppcw (i), mppew (i), mppe1 (i), mpper (i), mppdi (i), mppd1 (i), & + mppds (i), mppdg (i), mppsi (i), mpps1 (i), mppss (i), mppsg (i), & + mppfw (i), mppfr (i), mppmi (i), mppms (i), mppmg (i), mppm1 (i), & + mppm2 (i), mppm3 (i), mppar (i), mppas (i), mppag (i), mpprs (i), & + mpprg (i), mppxr (i), mppxs (i), mppxg (i), convt, last_step) + + endif + + ! ----------------------------------------------------------------------- + ! cloud fraction diagnostic + ! ----------------------------------------------------------------------- + + if (do_qa .and. last_step) then + call cloud_fraction (ks, ke, pz, den, qvz, qlz, qrz, qiz, qsz, qgz, qaz, & + tz, sqrt(area (i)), h_var) + endif + + ! ----------------------------------------------------------------------- + ! radar reflectivity diagnostic + ! ----------------------------------------------------------------------- + + if (do_ref .and. last_step) then + call rad_ref (ks, ke, qrz, qsz, qgz, tz, den, denfac, zez) + endif + + ! ======================================================================= + ! calculation of particle concentration (pc), effective diameter (ed), + ! optical extinction (oe), radar reflectivity factor (rr), and + ! mass-weighted terminal velocity (tv) + ! ======================================================================= + + if (do_mp_diag) then + + pcw (:) = 0.0 + edw (:) = 0.0 + oew (:) = 0.0 + rrw (:) = 0.0 + tvw (:) = 0.0 + pci (:) = 0.0 + edi (:) = 0.0 + oei (:) = 0.0 + rri (:) = 0.0 + tvi (:) = 0.0 + pcr (:) = 0.0 + edr (:) = 0.0 + oer (:) = 0.0 + rrr (:) = 0.0 + tvr (:) = 0.0 + pcs (:) = 0.0 + eds (:) = 0.0 + oes (:) = 0.0 + rrs (:) = 0.0 + tvs (:) = 0.0 + pcg (:) = 0.0 + edg (:) = 0.0 + oeg (:) = 0.0 + rrg (:) = 0.0 + tvg (:) = 0.0 + + do k = ks, ke + if (qlz (k) .gt. qcmin) then + call cal_pc_ed_oe_rr_tv (qlz (k), den (k), blinw, muw, pcaw, pcbw, pcw (k), & + edaw, edbw, edw (k), oeaw, oebw, oew (k), rraw, rrbw, rrw (k), & + tvaw, tvbw, tvw (k)) + endif + if (qiz (k) .gt. qcmin) then + call cal_pc_ed_oe_rr_tv (qiz (k), den (k), blini, mui, pcai, pcbi, pci (k), & + edai, edbi, edi (k), oeai, oebi, oei (k), rrai, rrbi, rri (k), & + tvai, tvbi, tvi (k)) + endif + if (qrz (k) .gt. qcmin) then + call cal_pc_ed_oe_rr_tv (qrz (k), den (k), blinr, mur, pcar, pcbr, pcr (k), & + edar, edbr, edr (k), oear, oebr, oer (k), rrar, rrbr, rrr (k), & + tvar, tvbr, tvr (k)) + endif + if (qsz (k) .gt. qcmin) then + call cal_pc_ed_oe_rr_tv (qsz (k), den (k), blins, mus, pcas, pcbs, pcs (k), & + edas, edbs, eds (k), oeas, oebs, oes (k), rras, rrbs, rrs (k), & + tvas, tvbs, tvs (k)) + endif + if (do_hail) then + if (qgz (k) .gt. qcmin) then + call cal_pc_ed_oe_rr_tv (qgz (k), den (k), blinh, muh, pcah, pcbh, pcg (k), & + edah, edbh, edg (k), oeah, oebh, oeg (k), rrah, rrbh, rrg (k), & + tvah, tvbh, tvg (k)) + endif + else + if (qgz (k) .gt. qcmin) then + call cal_pc_ed_oe_rr_tv (qgz (k), den (k), bling, mug, pcag, pcbg, pcg (k), & + edag, edbg, edg (k), oeag, oebg, oeg (k), rrag, rrbg, rrg (k), & + tvag, tvbg, tvg (k)) + endif + endif + enddo + + endif + + ! ----------------------------------------------------------------------- + ! momentum transportation during sedimentation + ! update temperature before delp and q update + ! ----------------------------------------------------------------------- + if (do_sedi_uv .and. do_sedi_heat) then + do k = ks, ke + c8 = mhc (qvz (k), qlz (k), qrz (k), qiz (k), qsz (k), qgz (k)) * c_air + tzuv (k) = 0.5 * (ua (i, k) ** 2 + va (i, k) ** 2 - (u (k) ** 2 + v (k) ** 2)) / c8 + tz (k) = tz (k) + tzuv (k) + enddo + endif + + if (do_sedi_w .and. do_sedi_heat) then + do k = ks, ke + c8 = mhc (qvz (k), qlz (k), qrz (k), qiz (k), qsz (k), qgz (k)) * c_air + tzw (k) = 0.5 * (wa (i, k) ** 2 - w (k) ** 2) / c8 + tz (k) = tz (k) + tzw (k) + enddo + endif + + ! ----------------------------------------------------------------------- + ! total energy checker + ! ----------------------------------------------------------------------- + + if (consv_checker) then + call mtetw (ks, ke, qvz, qlz, qrz, qiz, qsz, qgz, tz, u, v, w, & + dp, dte (i), 0.0, water (i), rain (i), ice (i), snow (i), & + graupel (i), 0.0, 0.0, dtm, te_end_d (i, :), tw_end_d (i, :), & + te_b_end_d (i), tw_b_end_d (i), .false., hydrostatic, te_loss (i)) + endif + + if (fix_negative) & + call neg_adj (ks, ke, tz, dp, qaz, qvz, qlz, qrz, qiz, qsz, qgz, mppcw (i), & + mppfr (i), convt) + + do k = ks, ke + + ! ----------------------------------------------------------------------- + ! convert mass mixing ratios back to specific ratios + ! ----------------------------------------------------------------------- + + if (do_inline_mp) then + q_cond = qlz (k) + qrz (k) + qiz (k) + qsz (k) + qgz (k) + con_r8 = one_r8 + qvz (k) + q_cond + else + con_r8 = one_r8 + qvz (k) + endif + + dp (k) = dp (k) * con_r8 + con_r8 = one_r8 / con_r8 + qvz (k) = qvz (k) * con_r8 + qlz (k) = qlz (k) * con_r8 + qrz (k) = qrz (k) * con_r8 + qiz (k) = qiz (k) * con_r8 + qsz (k) = qsz (k) * con_r8 + qgz (k) = qgz (k) * con_r8 + + q1 = qv (i, k) + ql (i, k) + qr (i, k) + qi (i, k) + qs (i, k) + qg (i, k) + q2 = qvz (k) + qlz (k) + qrz (k) + qiz (k) + qsz (k) + qgz (k) + adj_vmr (i, k) = ((one_r8 - q1) / (one_r8 - q2)) / (one_r8 + q2 - q1) + + zet (i, k) = zez (k) + +! Don't update the state +! qv (i, k) = qvz (k) +! ql (i, k) = qlz (k) +! qr (i, k) = qrz (k) +! qi (i, k) = qiz (k) +! qs (i, k) = qsz (k) +! qg (i, k) = qgz (k) +! qa (i, k) = qaz (k) +! Instead return tendencies + qv_dt (i, k) = rdt * (qvz (k) - qv (i, k)) + ql_dt (i, k) = rdt * (qlz (k) - ql (i, k)) + qr_dt (i, k) = rdt * (qrz (k) - qr (i, k)) + qi_dt (i, k) = rdt * (qiz (k) - qi (i, k)) + qs_dt (i, k) = rdt * (qsz (k) - qs (i, k)) + qg_dt (i, k) = rdt * (qgz (k) - qg (i, k)) + qa_dt (i, k) = rdt * (qaz (k) - qa (i, k)) + + ! ----------------------------------------------------------------------- + ! calculate some more variables needed outside + ! ----------------------------------------------------------------------- + + q_liq (k) = qlz (k) + qrz (k) + q_sol (k) = qiz (k) + qsz (k) + qgz (k) + q_cond = q_liq (k) + q_sol (k) + con_r8 = one_r8 - (qvz (k) + q_cond) + c8 = mhc (con_r8, qvz (k), q_liq (k), q_sol (k)) * c_air + + if (use_cond) q_con (i, k) = q_cond + if (moist_kappa) then + tmp = rdgas * (1. + zvir * qvz (k)) + cappa (i, k) = tmp / (tmp + c8) + endif + + enddo + + ! ----------------------------------------------------------------------- + ! momentum transportation during sedimentation + ! update temperature after delp and q update + ! ----------------------------------------------------------------------- + + if (do_sedi_uv) then + if (do_sedi_heat) then + do k = ks, ke + tz (k) = tz (k) - tzuv (k) + q_liq (k) = qlz (k) + qrz (k) + q_sol (k) = qiz (k) + qsz (k) + qgz (k) + q_cond = q_liq (k) + q_sol (k) + con_r8 = one_r8 - (qvz (k) + q_cond) + c8 = mhc (con_r8, qvz (k), q_liq (k), q_sol (k)) * c_air + tzuv (k) = (0.5 * (ua (i, k) ** 2 + va (i, k) ** 2) * dp0 (k) - & + 0.5 * (u (k) ** 2 + v (k) ** 2) * dp (k)) / c8 / dp (k) + tz (k) = tz (k) + tzuv (k) + enddo + endif + do k = ks, ke +! Don't update the state +! ua (i, k) = u (k) +! va (i, k) = v (k) +! Instead return tendencies + ua_dt (i, k) = rdt * (u (k) - ua (i, k)) + va_dt (i, k) = rdt * (v (k) - va (i, k)) + enddo + endif + + if (do_sedi_w) then + if (do_sedi_heat) then + do k = ks, ke + tz (k) = tz (k) - tzw (k) + q_liq (k) = qlz (k) + qrz (k) + q_sol (k) = qiz (k) + qsz (k) + qgz (k) + q_cond = q_liq (k) + q_sol (k) + con_r8 = one_r8 - (qvz (k) + q_cond) + c8 = mhc (con_r8, qvz (k), q_liq (k), q_sol (k)) * c_air + tzw (k) = (0.5 * (wa (i, k) ** 2) * dp0 (k) - & + 0.5 * (w (k) ** 2) * dp (k)) / c8 / dp (k) + tz (k) = tz (k) + tzw (k) + enddo + endif + do k = ks, ke +! Don't update the state +! wa (i, k) = w (k) +! Instead return tendencies + wa_dt (i, k) = rdt * (w (k) - wa (i, k)) + enddo + endif + + ! ----------------------------------------------------------------------- + ! total energy checker + ! ----------------------------------------------------------------------- + + if (consv_checker) then + call mtetw (ks, ke, qvz, qlz, qrz, qiz, qsz, qgz, tz, u, v, w, & + dp, dte (i), 0.0, water (i), rain (i), ice (i), snow (i), & + graupel (i), 0.0, 0.0, dtm, te_end_m (i, :), tw_end_m (i, :), & + te_b_end_m (i), tw_b_end_m (i), .true., hydrostatic) + endif + + ! ----------------------------------------------------------------------- + ! calculate total energy loss or gain + ! ----------------------------------------------------------------------- + + if (consv_te) then + if (hydrostatic) then + do k = ks, ke + te (i, k) = te (i, k) + c_air * tz (k) * dp (k) + enddo + else + do k = ks, ke + te (i, k) = te (i, k) + mte (qvz (k), qlz (k), qrz (k), qiz (k), & + qsz (k), qgz (k), tz (k), dp (k), .true.) * grav + enddo + endif + endif + + ! ----------------------------------------------------------------------- + ! conversion of temperature + ! ----------------------------------------------------------------------- + + if (do_inline_mp) then + do k = ks, ke + q_cond = qlz (k) + qrz (k) + qiz (k) + qsz (k) + qgz (k) + if (cp_heating) then + con_r8 = one_r8 - (qvz (k) + q_cond) + c8 = mhc (con_r8, qvz (k), q_liq (k), q_sol (k)) * c_air + cp8 = con_r8 * cp_air + qvz (k) * cp_vap + q_liq (k) * c_liq + q_sol (k) * c_ice +! Don't update the state +! dz (k) = dz (k) / pt (i, k) +! pt (i, k) = pt (i, k) + (tz (k) * ((1. + zvir * qvz (k)) * (1. - q_cond)) - pt (i, k)) * c8 / cp8 +! dz (k) = dz (k) * pt (i, k) +! Instead return tendencies + pt_dt (i, k) = rdt * (tz (k) * ((1. + zvir * qvz (k)) * (1. - q_cond)) - pt (i, k)) * c8 / cp8 + else +! Don't update the state +! pt (i, k) = tz (k) * ((1. + zvir * qvz (k)) * (1. - q_cond)) +! Instead return tendencies + pt_dt (i, k) = rdt * (tz (k) * ((1. + zvir * qvz (k)) * (1. - q_cond)) - pt (i, k) ) + endif + enddo + else + do k = ks, ke + q_liq (k) = qlz (k) + qrz (k) + q_sol (k) = qiz (k) + qsz (k) + qgz (k) + q_cond = q_liq (k) + q_sol (k) + con_r8 = one_r8 - (qvz (k) + q_cond) + c8 = mhc (con_r8, qvz (k), q_liq (k), q_sol (k)) * c_air +! Don't update the state +! pt (i, k) = pt (i, k) + (tz (k) - pt (i, k)) * c8 / cp_air +! Instead return tendencies + pt_dt (i, k) = rdt * (tz (k) - pt (i, k)) * c8 / cp_air + enddo + endif + + ! ----------------------------------------------------------------------- + ! total energy checker + ! ----------------------------------------------------------------------- + + if (consv_checker) then + if (abs (sum (te_end_d (i, :)) + te_b_end_d (i) - sum (te_beg_d (i, :)) - te_b_beg_d (i)) / & + (sum (te_beg_d (i, :)) + te_b_beg_d (i)) .gt. te_err) then + print*, "GFDL-MP-DRY TE: ", & + !(sum (te_beg_d (i, :)) + te_b_beg_d (i)), & + !(sum (te_end_d (i, :)) + te_b_end_d (i)), & + (sum (te_end_d (i, :)) + te_b_end_d (i) - sum (te_beg_d (i, :)) - te_b_beg_d (i)) / & + (sum (te_beg_d (i, :)) + te_b_beg_d (i)) + endif + if (abs (sum (tw_end_d (i, :)) + tw_b_end_d (i) - sum (tw_beg_d (i, :)) - tw_b_beg_d (i)) / & + (sum (tw_beg_d (i, :)) + tw_b_beg_d (i)) .gt. tw_err) then + print*, "GFDL-MP-DRY TW: ", & + !(sum (tw_beg_d (i, :)) + tw_b_beg_d (i)), & + !(sum (tw_end_d (i, :)) + tw_b_end_d (i)), & + (sum (tw_end_d (i, :)) + tw_b_end_d (i) - sum (tw_beg_d (i, :)) - tw_b_beg_d (i)) / & + (sum (tw_beg_d (i, :)) + tw_b_beg_d (i)) + endif + !print*, "GFDL MP TE DRY LOSS (%) : ", te_loss (i) / (sum (te_beg_d (i, :)) + te_b_beg_d (i)) * 100.0 + if (abs (sum (te_end_m (i, :)) + te_b_end_m (i) - sum (te_beg_m (i, :)) - te_b_beg_m (i)) / & + (sum (te_beg_m (i, :)) + te_b_beg_m (i)) .gt. te_err) then + print*, "GFDL-MP-WET TE: ", & + !(sum (te_beg_m (i, :)) + te_b_beg_m (i)), & + !(sum (te_end_m (i, :)) + te_b_end_m (i)), & + (sum (te_end_m (i, :)) + te_b_end_m (i) - sum (te_beg_m (i, :)) - te_b_beg_m (i)) / & + (sum (te_beg_m (i, :)) + te_b_beg_m (i)) + endif + if (abs (sum (tw_end_m (i, :)) + tw_b_end_m (i) - sum (tw_beg_m (i, :)) - tw_b_beg_m (i)) / & + (sum (tw_beg_m (i, :)) + tw_b_beg_m (i)) .gt. tw_err) then + print*, "GFDL-MP-WET TW: ", & + !(sum (tw_beg_m (i, :)) + tw_b_beg_m (i)), & + !(sum (tw_end_m (i, :)) + tw_b_end_m (i)), & + (sum (tw_end_m (i, :)) + tw_b_end_m (i) - sum (tw_beg_m (i, :)) - tw_b_beg_m (i)) / & + (sum (tw_beg_m (i, :)) + tw_b_beg_m (i)) + endif + !print*, "GFDL MP TE WET LOSS (%) : ", te_loss_0 (i) / (sum (te_beg_m (i, :)) + te_b_beg_m (i)) * 100.0 + endif + + enddo ! i loop + +end subroutine mpdrv + +! ======================================================================= +! fix negative water species +! ======================================================================= + +subroutine neg_adj (ks, ke, tz, dp, qa, qv, ql, qr, qi, qs, qg, mppcw, mppfr, convt) + + implicit none + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + integer, intent (in) :: ks, ke + + real, intent (in) :: convt + + real, intent (in), dimension (ks:ke) :: dp + + real (kind = r8), intent (inout), dimension (ks:ke) :: tz + + real, intent (inout), dimension (ks:ke) :: qa, qv, ql, qr, qi, qs, qg + + real, intent (inout) :: mppcw, mppfr + + ! ----------------------------------------------------------------------- + ! local variables + ! ----------------------------------------------------------------------- + + integer :: k + + real :: dq, sink + + real, dimension (ks:ke) :: q_liq, q_sol, lcpk, icpk, tcpk, tcp3 + + real (kind = r8), dimension (ks:ke) :: cvm, te8 + + ! ----------------------------------------------------------------------- + ! calculate moist heat capacity and latent heat coefficients + ! ----------------------------------------------------------------------- + + call cal_mhc_lhc (ks, ke, qv, ql, qr, qi, qs, qg, q_liq, q_sol, cvm, te8, tz, & + lcpk, icpk, tcpk, tcp3) + + do k = ks, ke + + ! ----------------------------------------------------------------------- + ! fix negative solid-phase hydrometeors + ! ----------------------------------------------------------------------- + + ! if cloud ice < 0, borrow from snow + if (qi (k) .lt. 0.) then + sink = min (- qi (k), max (0., qs (k))) + call update_qq (qa (k), qv (k), ql (k), qr (k), qi (k), qs (k), qg (k), & + 0., 0., 0., sink, - sink, 0.) + endif + + ! if snow < 0, borrow from graupel + if (qs (k) .lt. 0.) then + sink = min (- qs (k), max (0., qg (k))) + call update_qq (qa (k), qv (k), ql (k), qr (k), qi (k), qs (k), qg (k), & + 0., 0., 0., 0., sink, - sink) + endif + + ! if graupel < 0, borrow from rain + if (qg (k) .lt. 0.) then + sink = min (- qg (k), max (0., qr (k))) + mppfr = mppfr + sink * dp (k) * convt + call update_qt (qa (k), qv (k), ql (k), qr (k), qi (k), qs (k), qg (k), & + 0., 0., - sink, 0., 0., sink, te8 (k), cvm (k), tz (k), & + lcpk (k), icpk (k), tcpk (k), tcp3 (k)) + endif + + ! ----------------------------------------------------------------------- + ! fix negative liquid-phase hydrometeors + ! ----------------------------------------------------------------------- + + ! if rain < 0, borrow from cloud water + if (qr (k) .lt. 0.) then + sink = min (- qr (k), max (0., ql (k))) + call update_qq (qa (k), qv (k), ql (k), qr (k), qi (k), qs (k), qg (k), & + 0., - sink, sink, 0., 0., 0.) + endif + + ! if cloud water < 0, borrow from water vapor + if (ql (k) .lt. 0.) then + sink = min (- ql (k), max (0., qv (k))) + mppcw = mppcw + sink * dp (k) * convt + call update_qt (qa (k), qv (k), ql (k), qr (k), qi (k), qs (k), qg (k), & + - sink, sink, 0., 0., 0., 0., te8 (k), cvm (k), tz (k), & + lcpk (k), icpk (k), tcpk (k), tcp3 (k)) + endif + + enddo + + ! ----------------------------------------------------------------------- + ! fix negative water vapor + ! ----------------------------------------------------------------------- + + ! if water vapor < 0, borrow water vapor from below + do k = ks, ke - 1 + if (qv (k) .lt. 0.) then + qv (k + 1) = qv (k + 1) + qv (k) * dp (k) / dp (k + 1) + qv (k) = 0. + endif + enddo + + ! if water vapor < 0, borrow water vapor from above + if (qv (ke) .lt. 0. .and. qv (ke - 1) .gt. 0.) then + dq = min (- qv (ke) * dp (ke), qv (ke - 1) * dp (ke - 1)) + qv (ke - 1) = qv (ke - 1) - dq / dp (ke - 1) + qv (ke) = qv (ke) + dq / dp (ke) + endif + +end subroutine neg_adj + +! ======================================================================= +! full microphysics loop +! ======================================================================= + +subroutine mp_full (ks, ke, ntimes, tz, qa, qv, ql, qr, qi, qs, qg, dp, dz, u, v, w, & + den, denfac, ccn, cin, dts, h_var, dte, water, rain, ice, & + snow, graupel, prefluxw, prefluxr, prefluxi, prefluxs, prefluxg, mppcw, & + mppew, mppe1, mpper, mppdi, mppd1, mppds, mppdg, mppsi, mpps1, mppss, & + mppsg, mppfw, mppfr, mppmi, mppms, mppmg, mppm1, mppm2, mppm3, mppar, & + mppas, mppag, mpprs, mpprg, mppxr, mppxs, mppxg, convt, last_step) + + implicit none + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + logical, intent (in) :: last_step + + integer, intent (in) :: ks, ke, ntimes + + real, intent (in) :: dts, convt + + real, intent (in), dimension (ks:ke) :: h_var, dp, dz, den, denfac + + real, intent (inout), dimension (ks:ke) :: qa, qv, ql, qr, qi, qs, qg, u, v, w, ccn, cin + real, intent (inout), dimension (ks:ke) :: prefluxw, prefluxr, prefluxi, prefluxs, prefluxg + + real (kind = r8), intent (inout), dimension (ks:ke) :: tz + + real, intent (inout) :: water, rain, ice, snow, graupel + real, intent (inout) :: mppcw, mppew, mppe1, mpper, mppdi + real, intent (inout) :: mppd1, mppds, mppdg, mppsi, mpps1 + real, intent (inout) :: mppss, mppsg, mppfw, mppfr, mppar + real, intent (inout) :: mppas, mppag, mpprs, mpprg, mppxr + real, intent (inout) :: mppxs, mppxg, mppmi, mppms, mppmg + real, intent (inout) :: mppm1, mppm2, mppm3 + + real (kind = r8), intent (inout) :: dte + + ! ----------------------------------------------------------------------- + ! local variables + ! ----------------------------------------------------------------------- + + integer :: n + + real :: w1, r1, i1, s1, g1 + + real, dimension (ks:ke) :: vtw, vtr, vti, vts, vtg, pfw, pfr, pfi, pfs, pfg + + do n = 1, ntimes + + ! ----------------------------------------------------------------------- + ! sedimentation of cloud ice, snow, graupel or hail, and rain + ! ----------------------------------------------------------------------- + + call sedimentation (dts, ks, ke, tz, qv, ql, qr, qi, qs, qg, dz, dp, vtw, & + vtr, vti, vts, vtg, w1, r1, i1, s1, g1, pfw, pfr, pfi, pfs, pfg, u, v, & + w, den, denfac, dte, mppm1, mppm2, mppm3, convt) + + water = water + w1 * convt + rain = rain + r1 * convt + ice = ice + i1 * convt + snow = snow + s1 * convt + graupel = graupel + g1 * convt + + prefluxw = prefluxw + pfw * convt + prefluxr = prefluxr + pfr * convt + prefluxi = prefluxi + pfi * convt + prefluxs = prefluxs + pfs * convt + prefluxg = prefluxg + pfg * convt + + ! ----------------------------------------------------------------------- + ! warm rain cloud microphysics + ! ----------------------------------------------------------------------- + + call warm_rain (dts, ks, ke, dp, dz, tz, qa, qv, ql, qr, qi, qs, qg, den, & + denfac, vtw, vtr, ccn, h_var, mpper, mppar, mppxr, convt) + + ! ----------------------------------------------------------------------- + ! ice cloud microphysics + ! ----------------------------------------------------------------------- + + call ice_cloud (ks, ke, dp, tz, qa, qv, ql, qr, qi, qs, qg, den, denfac, vtw, & + vtr, vti, vts, vtg, dts, h_var, mppfw, mppfr, mppmi, mppms, mppmg, mppas, & + mppag, mpprs, mpprg, mppxs, mppxg, convt) + + if (do_subgrid_proc) then + + ! ----------------------------------------------------------------------- + ! temperature sentive high vertical resolution processes + ! ----------------------------------------------------------------------- + + call subgrid_z_proc (ks, ke, den, denfac, dts, h_var, tz, qa, qv, ql, qr, & + qi, qs, qg, dp, ccn, cin, mppcw, mppew, mppe1, mppdi, mppd1, mppds, & + mppdg, mppsi, mpps1, mppss, mppsg, mppfw, convt, last_step) + + endif + + enddo + +end subroutine mp_full + +! ======================================================================= +! fast microphysics loop +! ======================================================================= + +subroutine mp_fast (ks, ke, tz, qa, qv, ql, qr, qi, qs, qg, dtm, dp, den, ccn, & + cin, mppcw, mppew, mppdi, mppds, mppdg, mppsi, mppss, mppsg, mppfw, & + mppfr, mppmi, mppms, mppar, mppas, denfac, convt, last_step) + + implicit none + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + logical, intent (in) :: last_step + + integer, intent (in) :: ks, ke + + real, intent (in) :: dtm, convt + + real, intent (in), dimension (ks:ke) :: dp, den, denfac + + real, intent (inout), dimension (ks:ke) :: qa, qv, ql, qr, qi, qs, qg, ccn, cin + + real (kind = r8), intent (inout), dimension (ks:ke) :: tz + + real, intent (inout) :: mppcw, mppew, mppdi, mppds, mppdg, mppsi, mppss, mppsg + real, intent (inout) :: mppfw, mppfr, mppmi, mppms, mppar, mppas + + ! ----------------------------------------------------------------------- + ! local variables + ! ----------------------------------------------------------------------- + + logical :: cond_evap + + integer :: n + + real, dimension (ks:ke) :: q_liq, q_sol, lcpk, icpk, tcpk, tcp3 + + real (kind = r8), dimension (ks:ke) :: cvm, te8 + + ! ----------------------------------------------------------------------- + ! calculate heat capacities and latent heat coefficients + ! ----------------------------------------------------------------------- + + call cal_mhc_lhc (ks, ke, qv, ql, qr, qi, qs, qg, q_liq, q_sol, cvm, te8, tz, & + lcpk, icpk, tcpk, tcp3) + + if (.not. do_warm_rain_mp .and. fast_fr_mlt) then + + ! ----------------------------------------------------------------------- + ! cloud ice melting to form cloud water and rain + ! ----------------------------------------------------------------------- + + call pimlt (ks, ke, dtm, qa, qv, ql, qr, qi, qs, qg, dp, tz, cvm, te8, den, & + lcpk, icpk, tcpk, tcp3, mppmi, convt) + + ! ----------------------------------------------------------------------- + ! enforce complete freezing below t_wfr + ! ----------------------------------------------------------------------- + + call pcomp (ks, ke, dtm, qa, qv, ql, qr, qi, qs, qg, dp, tz, cvm, te8, lcpk, icpk, & + tcpk, tcp3, mppfw, convt) + + endif + + ! ----------------------------------------------------------------------- + ! cloud water condensation and evaporation + ! ----------------------------------------------------------------------- + + if (delay_cond_evap) then + cond_evap = last_step + else + cond_evap = .true. + endif + + if (cond_evap) then + do n = 1, nconds + call pcond_pevap (ks, ke, dtm, qa, qv, ql, qr, qi, qs, qg, tz, dp, cvm, & + te8, den, lcpk, icpk, tcpk, tcp3, mppcw, mppew, convt) + enddo + endif + + if (.not. do_warm_rain_mp .and. fast_fr_mlt) then + + ! ----------------------------------------------------------------------- + ! cloud water homogeneous freezing to form cloud ice and snow + ! ----------------------------------------------------------------------- + + call pifr (ks, ke, dtm, qa, qv, ql, qr, qi, qs, qg, dp, tz, cvm, te8, den, & + lcpk, icpk, tcpk, tcp3, mppfw, convt) + + ! ----------------------------------------------------------------------- + ! Wegener Bergeron Findeisen process + ! ----------------------------------------------------------------------- + + call pwbf (ks, ke, dtm, qa, qv, ql, qr, qi, qs, qg, dp, tz, cvm, te8, den, & + lcpk, icpk, tcpk, tcp3, mppfw, convt) + + ! ----------------------------------------------------------------------- + ! Bigg freezing mechanism + ! ----------------------------------------------------------------------- + + call pbigg (ks, ke, dtm, qa, qv, ql, qr, qi, qs, qg, dp, tz, cvm, te8, den, ccn, & + lcpk, icpk, tcpk, tcp3, mppfw, convt) + + ! ----------------------------------------------------------------------- + ! rain freezing to form graupel + ! ----------------------------------------------------------------------- + + call pgfr_simp (ks, ke, dtm, qa, qv, ql, qr, qi, qs, qg, dp, tz, cvm, te8, & + lcpk, icpk, tcpk, tcp3, mppfr, convt) + + ! ----------------------------------------------------------------------- + ! snow melting to form cloud water and rain + ! ----------------------------------------------------------------------- + + call psmlt_simp (ks, ke, dtm, qa, qv, ql, qr, qi, qs, qg, dp, tz, cvm, te8, & + lcpk, icpk, tcpk, tcp3, mppms, convt) + + endif + + ! ----------------------------------------------------------------------- + ! cloud water to rain autoconversion + ! ----------------------------------------------------------------------- + + call praut_simp (ks, ke, dtm, dp, tz, qa, qv, ql, qr, qi, qs, qg, mppar, convt) + + if (.not. do_warm_rain_mp .and. fast_dep_sub) then + + ! ----------------------------------------------------------------------- + ! cloud ice deposition and sublimation + ! ----------------------------------------------------------------------- + + call pidep_pisub (ks, ke, dtm, qa, qv, ql, qr, qi, qs, qg, tz, dp, cvm, te8, den, & + lcpk, icpk, tcpk, tcp3, cin, mppdi, mppsi, convt) + + ! ----------------------------------------------------------------------- + ! cloud ice to snow autoconversion + ! ----------------------------------------------------------------------- + + call psaut_simp (ks, ke, dtm, qa, qv, ql, qr, qi, qs, qg, dp, tz, den, mppas, convt) + + ! ----------------------------------------------------------------------- + ! snow deposition and sublimation + ! ----------------------------------------------------------------------- + + call psdep_pssub (ks, ke, dtm, qa, qv, ql, qr, qi, qs, qg, tz, dp, cvm, te8, den, & + denfac, lcpk, icpk, tcpk, tcp3, mppds, mppss, convt) + + ! ----------------------------------------------------------------------- + ! graupel deposition and sublimation + ! ----------------------------------------------------------------------- + + call pgdep_pgsub (ks, ke, dtm, qa, qv, ql, qr, qi, qs, qg, tz, dp, cvm, te8, den, & + denfac, lcpk, icpk, tcpk, tcp3, mppdg, mppsg, convt) + + endif + +end subroutine mp_fast + +! ======================================================================= +! sedimentation of cloud ice, snow, graupel or hail, and rain +! ======================================================================= + +subroutine sedimentation (dts, ks, ke, tz, qv, ql, qr, qi, qs, qg, dz, dp, & + vtw, vtr, vti, vts, vtg, w1, r1, i1, s1, g1, pfw, pfr, pfi, pfs, pfg, & + u, v, w, den, denfac, dte, mppm1, mppm2, mppm3, convt) + + implicit none + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + integer, intent (in) :: ks, ke + + real, intent (in) :: dts, convt + + real, intent (in), dimension (ks:ke) :: dp, dz, den, denfac + + real, intent (inout), dimension (ks:ke) :: qv, ql, qr, qi, qs, qg, u, v, w + + real, intent (out) :: w1, r1, i1, s1, g1 + + real, intent (out), dimension (ks:ke) :: vtw, vtr, vti, vts, vtg, pfw, pfr, pfi, pfs, pfg + + real (kind = r8), intent (inout) :: dte + + real (kind = r8), intent (inout), dimension (ks:ke) :: tz + + real, intent (inout) :: mppm1, mppm2, mppm3 + + ! ----------------------------------------------------------------------- + ! local variables + ! ----------------------------------------------------------------------- + + integer :: k + + real, dimension (ks:ke) :: q_liq, q_sol, lcpk, icpk, tcpk, tcp3 + + real (kind = r8), dimension (ks:ke) :: te8, cvm + + w1 = 0. + r1 = 0. + i1 = 0. + s1 = 0. + g1 = 0. + + vtw = 0. + vtr = 0. + vti = 0. + vts = 0. + vtg = 0. + + pfw = 0. + pfr = 0. + pfi = 0. + pfs = 0. + pfg = 0. + + ! ----------------------------------------------------------------------- + ! calculate heat capacities and latent heat coefficients + ! ----------------------------------------------------------------------- + + call cal_mhc_lhc (ks, ke, qv, ql, qr, qi, qs, qg, q_liq, q_sol, cvm, te8, tz, & + lcpk, icpk, tcpk, tcp3) + + ! ----------------------------------------------------------------------- + ! terminal fall and melting of falling cloud ice into rain + ! ----------------------------------------------------------------------- + + if (do_psd_ice_fall) then + call term_rsg (ks, ke, qi, den, denfac, vi_fac, blini, mui, tvai, tvbi, vi_min, vi_max, const_vi, vti) + else + call term_ice (ks, ke, tz, qi, den, vi_fac, vi_min, vi_max, const_vi, vti) + endif + + if (do_sedi_melt) then + call sedi_melt (dts, ks, ke, tz, qv, ql, qr, qi, qs, qg, dz, dp, & + vti, r1, tau_imlt, icpk, "qi", mppm1, convt) + endif + + call terminal_fall (dts, ks, ke, tz, qv, ql, qr, qi, qs, qg, dz, dp, & + vti, i1, pfi, u, v, w, dte, "qi") + + pfi (ks) = max (0.0, pfi (ks)) + + ! ----------------------------------------------------------------------- + ! terminal fall and melting of falling snow into rain + ! ----------------------------------------------------------------------- + + call term_rsg (ks, ke, qs, den, denfac, vs_fac, blins, mus, tvas, tvbs, vs_min, vs_max, const_vs, vts) + + if (do_sedi_melt) then + call sedi_melt (dts, ks, ke, tz, qv, ql, qr, qi, qs, qg, dz, dp, & + vts, r1, tau_smlt, icpk, "qs", mppm2, convt) + endif + + call terminal_fall (dts, ks, ke, tz, qv, ql, qr, qi, qs, qg, dz, dp, & + vts, s1, pfs, u, v, w, dte, "qs") + + pfs (ks) = max (0.0, pfs (ks)) + + ! ----------------------------------------------------------------------- + ! terminal fall and melting of falling graupel into rain + ! ----------------------------------------------------------------------- + + if (do_hail) then + call term_rsg (ks, ke, qg, den, denfac, vh_fac, blinh, muh, tvah, tvbh, vh_min, vh_max, const_vg, vtg) + else + call term_rsg (ks, ke, qg, den, denfac, vg_fac, bling, mug, tvag, tvbg, vg_min, vg_max, const_vg, vtg) + endif + + if (do_sedi_melt) then + call sedi_melt (dts, ks, ke, tz, qv, ql, qr, qi, qs, qg, dz, dp, & + vtg, r1, tau_gmlt, icpk, "qg", mppm3, convt) + endif + + call terminal_fall (dts, ks, ke, tz, qv, ql, qr, qi, qs, qg, dz, dp, & + vtg, g1, pfg, u, v, w, dte, "qg") + + pfg (ks) = max (0.0, pfg (ks)) + + ! ----------------------------------------------------------------------- + ! terminal fall of cloud water + ! ----------------------------------------------------------------------- + + if (do_psd_water_fall) then + + call term_rsg (ks, ke, ql, den, denfac, vw_fac, blinw, muw, tvaw, tvbw, vw_min, vw_max, const_vw, vtw) + + call terminal_fall (dts, ks, ke, tz, qv, ql, qr, qi, qs, qg, dz, dp, & + vtw, w1, pfw, u, v, w, dte, "ql") + + pfw (ks) = max (0.0, pfw (ks)) + + endif + + ! ----------------------------------------------------------------------- + ! terminal fall of rain + ! ----------------------------------------------------------------------- + + call term_rsg (ks, ke, qr, den, denfac, vr_fac, blinr, mur, tvar, tvbr, vr_min, vr_max, const_vr, vtr) + + call terminal_fall (dts, ks, ke, tz, qv, ql, qr, qi, qs, qg, dz, dp, & + vtr, r1, pfr, u, v, w, dte, "qr") + + pfr (ks) = max (0.0, pfr (ks)) + +end subroutine sedimentation + +! ======================================================================= +! terminal velocity for cloud ice +! ======================================================================= + +subroutine term_ice (ks, ke, tz, q, den, v_fac, v_min, v_max, const_v, vt) + + implicit none + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + integer, intent (in) :: ks, ke + + logical, intent (in) :: const_v + + real, intent (in) :: v_fac, v_min, v_max + + real, intent (in), dimension (ks:ke) :: q, den + + real (kind = r8), intent (in), dimension (ks:ke) :: tz + + real, intent (out), dimension (ks:ke) :: vt + + ! ----------------------------------------------------------------------- + ! local variables + ! ----------------------------------------------------------------------- + + integer :: k + + real :: DIAM, C1, C0, lnP, tmp, pl, qden, viLSC, viCNV + + real, parameter :: aa = - 4.14122e-5 + real, parameter :: bb = - 0.00538922 + real, parameter :: cc = - 0.0516344 + real, parameter :: dd = 0.00216078 + real, parameter :: ee = 1.9714 + + real, parameter :: aaL = - 1.70704e-5 + real, parameter :: bbL = - 0.00319109 + real, parameter :: ccL = - 0.0169876 + real, parameter :: ddL = 0.00410839 + real, parameter :: eeL = 1.93644 + + real, dimension (ks:ke) :: tc + real :: zero=0.0 + + if (const_v) then + vt (:) = 0.5*(v_min+v_max) + else + do k = ks, ke + if (q (k) .lt. qfmin) then + vt (k) = 0.0 + else + tc (k) = tz (k) - tice + if (ifflag .eq. 1) then + qden = q (k) * den (k) + vt (k) = (3. + log10 (qden)) * (tc (k) * (aa * tc (k) + bb) + cc) + & + dd * tc (k) + ee + vt (k) = 0.01 * v_fac * exp (vt (k) * log (10.)) + endif + if (ifflag .eq. 2) then + qden = q (k) * den (k) + vt (k) = 3.29* v_fac * exp (0.16 * log (qden)) + endif + if (ifflag .eq. 3) then + qden = q (k) * den (k) * 1.e3 + ! Large-scale settling + viLSC = 10.0**(log10(qden) * (tc (k) * (aaL * tc (k) + bbL) + ccL) + ddL * tc (k) + eeL) + ! Convective settling + viCNV = MAX(10.0,(1.119*tc (k) + 14.21*log10(qden*1.e3) + 68.85)) + ! Combine + vt (k) = viLSC*(1.0-cnv_fraction) + viCNV*(cnv_fraction) + ! Include pressure sensitivity (eq 14 in https://doi.org/10.1175/JAS-D-12-0124.1) + pl = den (k) * rdgas * tz (k) ! dry air pressure + tmp = tz (k) + DIAM = 2.0*LDRADIUS4(pl/100.0,tmp,q(k),zero,zero,2)*1.e6 ! microns + lnP = log(pl/100.0) + C0 = -1.04 + 0.298*lnP + C1 = 0.67 - 0.097*lnP + ! apply pressure scaling + vt (k) = vt (k) * (C0 + C1*log(DIAM)) + vt (k) = 0.01 * v_fac * vt (k) + endif + vt (k) = min (v_max, max (v_min, vt (k))) + endif + enddo + endif + +end subroutine term_ice + +! ======================================================================= +! terminal velocity for rain, snow, and graupel, Lin et al. (1983) +! ======================================================================= + +subroutine term_rsg (ks, ke, q, den, denfac, v_fac, blin, mu, tva, tvb, v_min, v_max, const_v, vt) + + implicit none + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + integer, intent (in) :: ks, ke + + logical, intent (in) :: const_v + + real, intent (in) :: v_fac, v_min, blin, v_max, mu + + real (kind = r8), intent (in) :: tva, tvb + + real, intent (in), dimension (ks:ke) :: q, den, denfac + + real, intent (out), dimension (ks:ke) :: vt + + ! ----------------------------------------------------------------------- + ! local variables + ! ----------------------------------------------------------------------- + + integer :: k + + if (const_v) then + vt (:) = 0.5*(v_min+v_max) + else + do k = ks, ke + if (q (k) .lt. qfmin) then + vt (k) = 0.0 + else + call cal_pc_ed_oe_rr_tv (q (k), den (k), blin, mu, & + tva = tva, tvb = tvb, tv = vt (k)) + vt (k) = v_fac * vt (k) * denfac (k) + vt (k) = min (v_max, max (v_min, vt (k))) + endif + enddo + endif + +end subroutine term_rsg + +! ======================================================================= +! melting during sedimentation +! ======================================================================= + +subroutine sedi_melt (dts, ks, ke, tz, qv, ql, qr, qi, qs, qg, dz, dp, & + vt, r1, tau_mlt, icpk, qflag, mppm, convt) + + implicit none + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + integer, intent (in) :: ks, ke + + real, intent (in) :: dts, tau_mlt, convt + + real, intent (in), dimension (ks:ke) :: vt, dp, dz, icpk + + real, intent (inout), dimension (ks:ke) :: qv, ql, qr, qi, qs, qg + + real, intent (inout) :: r1, mppm + + real (kind = r8), intent (inout), dimension (ks:ke) :: tz + + character (len = 2), intent (in) :: qflag + + ! ----------------------------------------------------------------------- + ! local variables + ! ----------------------------------------------------------------------- + + integer :: k, m + + real :: dtime, sink, zs + + real, dimension (ks:ke) :: q + + real, dimension (ks:ke + 1) :: ze, zt + + real (kind = r8), dimension (ks:ke) :: cvm + + call zezt (ks, ke, dts, zs, dz, vt, ze, zt) + + select case (qflag) + case ("qi") + q = qi + case ("qs") + q = qs + case ("qg") + q = qg + case default + print *, "gfdl_mp: qflag error!" + end select + + ! ----------------------------------------------------------------------- + ! melting to rain + ! ----------------------------------------------------------------------- + + do k = ke - 1, ks, - 1 + if (vt (k) .lt. 1.e-10) cycle + if (q (k) .gt. qcmin) then + do m = k + 1, ke + if (zt (k + 1) .ge. ze (m)) exit + if (zt (k) .lt. ze (m + 1) .and. tz (m) .gt. tice) then + cvm (k) = mhc (qv (k), ql (k), qr (k), qi (k), qs (k), qg (k)) + cvm (m) = mhc (qv (m), ql (m), qr (m), qi (m), qs (m), qg (m)) + dtime = min (dts, (ze (m) - ze (m + 1)) / vt (k)) + dtime = min (1.0, dtime / tau_mlt) + sink = min (q (k) * dp (k) / dp (m), dtime * (tz (m) - tice) / icpk (m)) + mppm = mppm + sink * dp (k) * convt + q (k) = q (k) - sink * dp (m) / dp (k) + if (zt (k) .lt. zs) then + r1 = r1 + sink * dp (m) + else + qr (m) = qr (m) + sink + endif + select case (qflag) + case ("qi") + qi (k) = q (k) + case ("qs") + qs (k) = q (k) + case ("qg") + qg (k) = q (k) + case default + print *, "gfdl_mp: qflag error!" + end select + tz (k) = (tz (k) * cvm (k) - li00 * sink * dp (m) / dp (k)) / & + mhc (qv (k), ql (k), qr (k), qi (k), qs (k), qg (k)) + tz (m) = (tz (m) * cvm (m)) / & + mhc (qv (m), ql (m), qr (m), qi (m), qs (m), qg (m)) + endif + if (q (k) .lt. qcmin) exit + enddo + endif + enddo + +end subroutine sedi_melt + +! ======================================================================= +! terminal fall +! ======================================================================= + +subroutine terminal_fall (dts, ks, ke, tz, qv, ql, qr, qi, qs, qg, dz, dp, & + vt, x1, m1, u, v, w, dte, qflag) + + implicit none + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + integer, intent (in) :: ks, ke + + real, intent (in) :: dts + + real, intent (in), dimension (ks:ke) :: vt, dp, dz + + character (len = 2), intent (in) :: qflag + + real, intent (inout), dimension (ks:ke) :: qv, ql, qr, qi, qs, qg, u, v, w + + real, intent (inout) :: x1 + + real (kind = r8), intent (inout) :: dte + + real (kind = r8), intent (inout), dimension (ks:ke) :: tz + + real, intent (out), dimension (ks:ke) :: m1 + + ! ----------------------------------------------------------------------- + ! local variables + ! ----------------------------------------------------------------------- + + integer :: k + + logical :: no_fall + + real :: zs + + real, dimension (ks:ke) :: dm, q + + real, dimension (ks:ke + 1) :: ze, zt + + real (kind = r8), dimension (ks:ke) :: te1, te2 + + m1 = 0.0 + + call zezt (ks, ke, dts, zs, dz, vt, ze, zt) + + select case (qflag) + case ("ql") + q = ql + case ("qr") + q = qr + case ("qi") + q = qi + case ("qs") + q = qs + case ("qg") + q = qg + case default + print *, "gfdl_mp: qflag error!" + end select + + call check_column (ks, ke, q, no_fall) + + if (no_fall) return + + ! ----------------------------------------------------------------------- + ! momentum transportation during sedimentation + ! ----------------------------------------------------------------------- + + if (do_sedi_w) then + do k = ks, ke + dm (k) = dp (k) * (1. + qv (k) + ql (k) + qr (k) + qi (k) + qs (k) + qg (k)) + enddo + endif + + ! ----------------------------------------------------------------------- + ! energy change during sedimentation + ! ----------------------------------------------------------------------- + + do k = ks, ke + te1 (k) = mte (qv (k), ql (k), qr (k), qi (k), qs (k), qg (k), tz (k), dp (k), .false.) + enddo + + ! ----------------------------------------------------------------------- + ! sedimentation + ! ----------------------------------------------------------------------- + + select case (qflag) + case ("ql") + q = ql + case ("qr") + q = qr + case ("qi") + q = qi + case ("qs") + q = qs + case ("qg") + q = qg + case default + print *, "gfdl_mp: qflag error!" + end select + + if (sedflag .eq. 1) & + call implicit_fall (dts, ks, ke, ze, vt, dp, q, x1, m1) + if (sedflag .eq. 2) & + call explicit_fall (dts, ks, ke, ze, vt, dp, q, x1, m1) + if (sedflag .eq. 3) & + call lagrangian_fall (ks, ke, zs, ze, zt, dp, q, x1, m1) + if (sedflag .eq. 4) & + call implicit_lagrangian_fall (dts, ks, ke, zs, ze, zt, vt, dp, q, & + x1, m1, sed_fac) + + select case (qflag) + case ("ql") + ql = q + case ("qr") + qr = q + case ("qi") + qi = q + case ("qs") + qs = q + case ("qg") + qg = q + case default + print *, "gfdl_mp: qflag error!" + end select + + ! ----------------------------------------------------------------------- + ! energy change during sedimentation + ! ----------------------------------------------------------------------- + + do k = ks, ke + te2 (k) = mte (qv (k), ql (k), qr (k), qi (k), qs (k), qg (k), tz (k), dp (k), .false.) + enddo + dte = dte + sum (te1) - sum (te2) + + ! ----------------------------------------------------------------------- + ! momentum transportation during sedimentation + ! ----------------------------------------------------------------------- + + if (do_sedi_uv) then + call sedi_uv (ks, ke, m1, dp, u, v) + endif + + if (do_sedi_w) then + call sedi_w (ks, ke, m1, w, vt, dm) + endif + + ! ----------------------------------------------------------------------- + ! energy change during sedimentation heating + ! ----------------------------------------------------------------------- + + do k = ks, ke + te1 (k) = mte (qv (k), ql (k), qr (k), qi (k), qs (k), qg (k), tz (k), dp (k), .false.) + enddo + + ! ----------------------------------------------------------------------- + ! heat exchanges during sedimentation + ! ----------------------------------------------------------------------- + + if (do_sedi_heat) then + call sedi_heat (ks, ke, dp, m1, dz, tz, qv, ql, qr, qi, qs, qg, c_ice) + endif + + ! ----------------------------------------------------------------------- + ! energy change during sedimentation heating + ! ----------------------------------------------------------------------- + + do k = ks, ke + te2 (k) = mte (qv (k), ql (k), qr (k), qi (k), qs (k), qg (k), tz (k), dp (k), .false.) + enddo + dte = dte + sum (te1) - sum (te2) + +end subroutine terminal_fall + +! ======================================================================= +! calculate ze zt for sedimentation +! ======================================================================= + +subroutine zezt (ks, ke, dts, zs, dz, vt, ze, zt) + + implicit none + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + integer, intent (in) :: ks, ke + + real, intent (in) :: dts + + real, intent (in), dimension (ks:ke) :: dz, vt + + real, intent (out) :: zs + + real, intent (out), dimension (ks:ke + 1) :: ze, zt + + ! ----------------------------------------------------------------------- + ! local variables + ! ----------------------------------------------------------------------- + + integer :: k + + real :: dt5 + + dt5 = 0.5 * dts + zs = 0.0 + ze (ke + 1) = zs + do k = ke, ks, - 1 + ze (k) = ze (k + 1) - dz (k) + enddo + zt (ks) = ze (ks) + do k = ks + 1, ke + zt (k) = ze (k) - dt5 * (vt (k - 1) + vt (k)) + enddo + zt (ke + 1) = zs - dts * vt (ke) + do k = ks, ke + if (zt (k + 1) .ge. zt (k)) zt (k + 1) = zt (k) - dz_min + enddo + +end subroutine zezt + +! ======================================================================= +! check if water species is large enough to fall +! ======================================================================= + +subroutine check_column (ks, ke, q, no_fall) + + implicit none + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + integer, intent (in) :: ks, ke + + real, intent (in) :: q (ks:ke) + + logical, intent (out) :: no_fall + + ! ----------------------------------------------------------------------- + ! local variables + ! ----------------------------------------------------------------------- + + integer :: k + + no_fall = .true. + + do k = ks, ke + if (q (k) .gt. qfmin) then + no_fall = .false. + exit + endif + enddo + +end subroutine check_column + +! ======================================================================= +! warm rain cloud microphysics +! ======================================================================= + +subroutine warm_rain (dts, ks, ke, dp, dz, tz, qa, qv, ql, qr, qi, qs, qg, & + den, denfac, vtw, vtr, ccn, h_var, mpper, mppar, mppxr, convt) + + implicit none + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + integer, intent (in) :: ks, ke + + real, intent (in) :: dts, convt + + real, intent (in), dimension (ks:ke) :: h_var, dp, dz, den, denfac, vtw, vtr + + real, intent (inout), dimension (ks:ke) :: qa, qv, ql, qr, qi, qs, qg, ccn + + real (kind = r8), intent (inout), dimension (ks:ke) :: tz + + real, intent (inout) :: mpper, mppar, mppxr + + ! ----------------------------------------------------------------------- + ! rain evaporation to form water vapor + ! ----------------------------------------------------------------------- + + call prevp (ks, ke, dts, dp, tz, qa, qv, ql, qr, qi, qs, qg, den, denfac, & + h_var, mpper, convt) + + ! ----------------------------------------------------------------------- + ! rain accretion with cloud water + ! ----------------------------------------------------------------------- + + call pracw (ks, ke, dts, dp, tz, qa, qv, ql, qr, qi, qs, qg, den, denfac, vtw, & + vtr, mppxr, convt) + + ! ----------------------------------------------------------------------- + ! cloud water to rain autoconversion + ! ----------------------------------------------------------------------- + + call praut (ks, ke, dts, dp, tz, qa, qv, ql, qr, qi, qs, qg, den, ccn, h_var, & + mppar, convt) + +end subroutine warm_rain + +! ======================================================================= +! rain evaporation to form water vapor, Lin et al. (1983) +! ======================================================================= + +subroutine prevp (ks, ke, dts, dp, tz, qa, qv, ql, qr, qi, qs, qg, den, denfac, & + h_var, mpper, convt) + + implicit none + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + integer, intent (in) :: ks, ke + + real, intent (in) :: dts, convt + + real, intent (in), dimension (ks:ke) :: h_var, den, denfac, dp + + real (kind = r8), intent (inout), dimension (ks:ke) :: tz + + real, intent (inout), dimension (ks:ke) :: qa, qv, qr, ql, qi, qs, qg + + real, intent (inout) :: mpper + + ! ----------------------------------------------------------------------- + ! local variables + ! ----------------------------------------------------------------------- + + integer :: k + + real :: dqv, qsat, dqdt, tmp, t2, qden, q_plus, q_minus, sink + real :: qpz, dq, dqh, tin, fac_revp, rh_tem + + real, dimension (ks:ke) :: q_liq, q_sol, lcpk, icpk, tcpk, tcp3 + + real (kind = r8), dimension (ks:ke) :: cvm, te8 + + ! ----------------------------------------------------------------------- + ! time-scale factor + ! ----------------------------------------------------------------------- + + fac_revp = 1. + if (tau_revp .gt. 1.e-6) then + fac_revp = 1. - exp (- dts / tau_revp) + endif + + ! ----------------------------------------------------------------------- + ! calculate heat capacities and latent heat coefficients + ! ----------------------------------------------------------------------- + + call cal_mhc_lhc (ks, ke, qv, ql, qr, qi, qs, qg, q_liq, q_sol, cvm, te8, tz, & + lcpk, icpk, tcpk, tcp3) + + do k = ks, ke + + if (tz (k) .gt. t_wfr .and. qr (k) .gt. qpmin) then + + tin = (tz (k) * cvm (k) - lv00 * ql (k)) / mhc (qv (k) + ql (k), qr (k), q_sol (k)) + + ! ----------------------------------------------------------------------- + ! calculate supersaturation and subgrid variability of water + ! ----------------------------------------------------------------------- + + qpz = qv (k) + ql (k) + qsat = wqs (tin, den (k), dqdt) + dqv = qsat - qv (k) + + dqh = max (ql (k), h_var (k) * max (qpz, qcmin)) + dqh = min (dqh, 0.2 * qpz) + q_minus = qpz - dqh + q_plus = qpz + dqh + + ! ----------------------------------------------------------------------- + ! rain evaporation + ! ----------------------------------------------------------------------- + + if (dqv .gt. 0.0 .and. qsat .gt. q_minus) then + + if (qsat .gt. q_plus) then + dq = qsat - qpz + else + dq = 0.25 * (qsat - q_minus) ** 2 / dqh + endif + qden = qr (k) * den (k) + t2 = tin * tin + sink = psub (t2, dq, qden, qsat, crevp, den (k), denfac (k), blinr, mur, lcpk (k), cvm (k)) + sink = min (qr (k), dts * fac_revp * sink, dqv / (1. + lcpk (k) * dqdt)) + rh_tem = qpz / qsat + if (use_rhc_revap .and. rh_tem .ge. rhc_revap) then + sink = 0.0 + endif + + ! ----------------------------------------------------------------------- + ! alternative minimum evaporation in dry environmental air + ! ----------------------------------------------------------------------- + ! tmp = min (qr (k), dim (rh_rain * qsat, qv (k)) / (1. + lcpk (k) * dqdt)) + ! sink = max (sink, tmp) + + mpper = mpper + sink * dp (k) * convt + + call update_qt (qa (k), qv (k), ql (k), qr (k), qi (k), qs (k), qg (k), & + sink, 0., - sink, 0., 0., 0., te8 (k), cvm (k), tz (k), & + lcpk (k), icpk (k), tcpk (k), tcp3 (k)) + + endif + endif + + enddo ! k loop + +end subroutine prevp + +! ======================================================================= +! rain accretion with cloud water, Lin et al. (1983) +! ======================================================================= + +subroutine pracw (ks, ke, dts, dp, tz, qa, qv, ql, qr, qi, qs, qg, den, denfac, vtw, & + vtr, mppxr, convt) + + implicit none + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + integer, intent (in) :: ks, ke + + real, intent (in) :: dts, convt + + real, intent (in), dimension (ks:ke) :: den, denfac, vtw, vtr, dp + + real (kind = r8), intent (inout), dimension (ks:ke) :: tz + + real, intent (inout), dimension (ks:ke) :: qa, qv, qr, ql, qi, qs, qg + + real, intent (inout) :: mppxr + + ! ----------------------------------------------------------------------- + ! local variables + ! ----------------------------------------------------------------------- + + integer :: k + + real :: qden, sink + + do k = ks, ke + + if (tz (k) .gt. t_wfr .and. qr (k) .gt. qpmin .and. ql (k) .gt. qcmin) then + + qden = qr (k) * den (k) + if (do_new_acc_water) then + sink = dts * acr3d (vtr (k), vtw (k), ql (k), qr (k), cracw, acco (:, 5), & + acc (9), acc (10), den (k)) + else + sink = dts * acr2d (qden, cracw, denfac (k), blinr, mur) + sink = sink / (1. + sink) * ql (k) + endif + mppxr = mppxr + sink * dp (k) * convt + + call update_qq (qa (k), qv (k), ql (k), qr (k), qi (k), qs (k), qg (k), & + 0., - sink, sink, 0., 0., 0.) + + endif + + enddo + +end subroutine pracw + +! ======================================================================= +! cloud water to rain autoconversion, Hong et al. (2004) +! ======================================================================= + +subroutine praut (ks, ke, dts, dp, tz, qak, qvk, qlk, qrk, qik, qsk, qgk, den, ccn, h_var, & + mppar, convt) + + implicit none + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + integer, intent (in) :: ks, ke + + real, intent (in) :: dts, convt + + real, intent (in), dimension (ks:ke) :: h_var, den, dp + + real, intent (inout), dimension (ks:ke) :: qak, qvk, qlk, qrk, qik, qsk, qgk, ccn + + real (kind = r8), intent (inout), dimension (ks:ke) :: tz + + real, intent (inout) :: mppar + + ! ----------------------------------------------------------------------- + ! local variables + ! ----------------------------------------------------------------------- + + real, parameter :: so3 = 7.0 / 3.0 + real, parameter :: so1 = - 1.0 / 3.0 + + integer :: k + + real :: sink, dq, qc + + real, dimension (ks:ke) :: ql, dl, qadum, c_praut + + ! Use In-Cloud condensates + if (in_cloud) then + qadum = max(qak,qcmin) + else + qadum = 1.0 + endif + ql = qlk/qadum + + if (irain_f .eq. 0) then + + call linear_prof (ke - ks + 1, ql (ks), dl (ks), z_slope_liq, h_var) + + do k = ks, ke + + if (tz (k) .gt. t_wfr .and. ql (k) .gt. qcmin) then + + if (do_psd_water_num) then + call cal_pc_ed_oe_rr_tv (ql (k), den (k), blinw, muw, & + pca = pcaw, pcb = pcbw, pc = ccn (k)) + ccn (k) = ccn (k) / den (k) + endif + + qc = fac_rc * ccn (k) + dl (k) = min (max (qcmin, dl (k)), 0.5 * ql (k)) + dq = 0.5 * (ql (k) + dl (k) - qc) + + if (dq .gt. 0.) then + + c_praut (k) = cpaut * exp (so1 * log (ccn (k) * rhow)) + sink = min (1., dq / dl (k)) * dts * c_praut (k) * den (k) * & + exp (so3 * log (ql (k))) + sink = min (ql0_max/qadum(k), ql (k), sink) * qadum (k) + mppar = mppar + sink * dp (k) * convt + + call update_qq (qak (k), qvk (k), qlk (k), qrk (k), qik (k), qsk (k), qgk (k), & + 0., - sink, sink, 0., 0., 0.) + + endif + + endif + + enddo + + endif + + if (irain_f .eq. 1) then + + do k = ks, ke + + if (tz (k) .gt. t_wfr .and. ql (k) .gt. qcmin) then + + if (do_psd_water_num) then + call cal_pc_ed_oe_rr_tv (ql (k), den (k), blinw, muw, & + pca = pcaw, pcb = pcbw, pc = ccn (k)) + ccn (k) = ccn (k) / den (k) + endif + + qc = fac_rc * ccn (k) + dq = ql (k) - qc + + if (dq .gt. 0.) then + + c_praut (k) = cpaut * exp (so1 * log (ccn (k) * rhow)) + sink = min (dq, dts * c_praut (k) * den (k) * exp (so3 * log (ql (k)))) + sink = min (ql0_max/qadum(k), ql (k), sink) * qadum (k) + mppar = mppar + sink * dp (k) * convt + + call update_qq (qak (k), qvk (k), qlk (k), qrk (k), qik (k), qsk (k), qgk (k), & + 0., - sink, sink, 0., 0., 0.) + + endif + + endif + + enddo + + endif + +end subroutine praut + +! ======================================================================= +! ice cloud microphysics +! ======================================================================= + +subroutine ice_cloud (ks, ke, dp, tz, qa, qv, ql, qr, qi, qs, qg, den, denfac, vtw, & + vtr, vti, vts, vtg, dts, h_var, mppfw, mppfr, mppmi, mppms, mppmg, mppas, & + mppag, mpprs, mpprg, mppxs, mppxg, convt) + + implicit none + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + integer, intent (in) :: ks, ke + + real, intent (in) :: dts, convt + + real, intent (in), dimension (ks:ke) :: h_var, den, denfac, vtw, vtr, vti, vts, vtg, dp + + real, intent (inout), dimension (ks:ke) :: qa, qv, ql, qr, qi, qs, qg + + real (kind = r8), intent (inout), dimension (ks:ke) :: tz + + real, intent (inout) :: mppfw, mppfr, mppmi, mppms, mppmg, mppas, mppag + real, intent (inout) :: mpprs, mpprg, mppxs, mppxg + + ! ----------------------------------------------------------------------- + ! local variables + ! ----------------------------------------------------------------------- + + real, dimension (ks:ke) :: di, q_liq, q_sol, lcpk, icpk, tcpk, tcp3 + + real (kind = r8), dimension (ks:ke) :: cvm, te8 + + ! ----------------------------------------------------------------------- + ! calculate heat capacities and latent heat coefficients + ! ----------------------------------------------------------------------- + + call cal_mhc_lhc (ks, ke, qv, ql, qr, qi, qs, qg, q_liq, q_sol, cvm, te8, tz, & + lcpk, icpk, tcpk, tcp3) + + if (.not. do_warm_rain_mp) then + + ! ----------------------------------------------------------------------- + ! cloud ice/liq melt/freeze to form cloud water/ice and rain/snow + ! ----------------------------------------------------------------------- + + call pimltfrz (ks, ke, dts, qa, qv, ql, qr, qi, qs, qg, dp, tz, cvm, te8, den, & + lcpk, icpk, tcpk, tcp3, mppmi, mppfw, convt) + + ! ----------------------------------------------------------------------- + ! vertical subgrid variability + ! ----------------------------------------------------------------------- + + call linear_prof (ke - ks + 1, qi, di, z_slope_ice, h_var) + + ! ----------------------------------------------------------------------- + ! snow melting (includes snow accretion with cloud water and rain) to form cloud water and rain + ! ----------------------------------------------------------------------- + + call psmlt (ks, ke, dts, qa, qv, ql, qr, qi, qs, qg, dp, tz, cvm, te8, den, denfac, & + vtw, vtr, vts, lcpk, icpk, tcpk, tcp3, mppms, convt) + + ! ----------------------------------------------------------------------- + ! graupel melting (includes graupel accretion with cloud water and rain) to form rain + ! ----------------------------------------------------------------------- + + call pgmlt (ks, ke, dts, qa, qv, ql, qr, qi, qs, qg, dp, tz, cvm, te8, den, denfac, & + vtw, vtr, vtg, lcpk, icpk, tcpk, tcp3, mppmg, convt) + + ! ----------------------------------------------------------------------- + ! snow accretion with cloud ice + ! ----------------------------------------------------------------------- + + call psaci (ks, ke, dts, qa, qv, ql, qr, qi, qs, qg, dp, tz, den, denfac, vti, vts, & + mppxs, convt) + + ! ----------------------------------------------------------------------- + ! cloud ice to snow autoconversion + ! ----------------------------------------------------------------------- + + call psaut (ks, ke, dts, qa, qv, ql, qr, qi, qs, qg, dp, tz, den, di, mppas, convt) + + ! ----------------------------------------------------------------------- + ! graupel accretion with cloud ice + ! ----------------------------------------------------------------------- + + call pgaci (ks, ke, dts, qa, qv, ql, qr, qi, qs, qg, dp, tz, den, denfac, vti, vtg, & + mppxg, convt) + + ! ----------------------------------------------------------------------- + ! snow accretion with rain and rain freezing to form graupel + ! ----------------------------------------------------------------------- + + call psacr_pgfr (ks, ke, dts, qa, qv, ql, qr, qi, qs, qg, dp, tz, cvm, te8, den, & + denfac, vtr, vts, lcpk, icpk, tcpk, tcp3, mppfr, mpprs, convt) + + ! ----------------------------------------------------------------------- + ! graupel accretion with snow + ! ----------------------------------------------------------------------- + + call pgacs (ks, ke, dts, qa, qv, ql, qr, qi, qs, qg, dp, tz, den, vts, vtg, mppxg, convt) + + ! ----------------------------------------------------------------------- + ! snow to graupel autoconversion + ! ----------------------------------------------------------------------- + + call pgaut (ks, ke, dts, qa, qv, ql, qr, qi, qs, qg, dp, tz, den, mppag, convt) + + ! ----------------------------------------------------------------------- + ! graupel accretion with cloud water and rain + ! ----------------------------------------------------------------------- + + call pgacw_pgacr (ks, ke, dts, qa, qv, ql, qr, qi, qs, qg, dp, tz, cvm, te8, den, & + denfac, vtr, vtg, lcpk, icpk, tcpk, tcp3, mpprg, convt) + + endif ! do_warm_rain_mp + +end subroutine ice_cloud + + +subroutine pimltfrz (ks, ke, dts, qak, qvk, qlk, qrk, qik, qsk, qgk, dp, tz, cvm, te8, den, & + lcpk, icpk, tcpk, tcp3, mppmi, mppfw, convt) + + implicit none + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + integer, intent (in) :: ks, ke + + real, intent (in) :: dts, convt + + real (kind = r8), intent (in), dimension (ks:ke) :: te8 + + real, intent (in), dimension (ks:ke) :: den, dp + + real, intent (inout), dimension (ks:ke) :: qak, qvk, qlk, qrk, qik, qsk, qgk + real, intent (inout), dimension (ks:ke) :: lcpk, icpk, tcpk, tcp3 + + real (kind = r8), intent (inout), dimension (ks:ke) :: cvm, tz + + real, intent (inout) :: mppmi, mppfw + + ! ----------------------------------------------------------------------- + ! local variables + ! ----------------------------------------------------------------------- + + integer :: k + + real :: ql, qi, qim, qadum, newliq, newice + real :: tmp, sink, fac_imlt, fac_frez + + fac_imlt = 1. - exp (- dts / tau_imlt) + fac_frez = 1. - exp (- dts / tau_frez) + + do k = ks, ke + + if (tz (k) .gt. tice .and. qik (k) .gt. qcmin) then + + ! Use In-Cloud condensates + if (in_cloud) then + qadum = max(qak(k),qcmin) + else + qadum = 1.0 + endif + ql = qlk (k)/qadum + qi = qik (k)/qadum + + tmp = tz (k) + newliq = new_liq_condensate(tmp, ql, qi) + sink = fac_imlt * min (qi, newliq, (tz (k) - tice) / icpk (k)) + tmp = min (sink, dim (ql_mlt/qadum, ql)) + + tmp = tmp * qadum + sink = sink * qadum + mppmi = mppmi + sink * dp (k) * convt + + call update_qt (qak (k), qvk (k), qlk (k), qrk (k), qik (k), qsk (k), qgk (k), & + 0., tmp, sink - tmp, - sink, 0., 0., te8 (k), cvm (k), tz (k), & + lcpk (k), icpk (k), tcpk (k), tcp3 (k)) + + elseif (tz (k) <= tice .and. qlk (k) > qcmin) then + + ! Use In-Cloud condensates + if (in_cloud) then + qadum = max(qak(k),qcmin) + else + qadum = 1.0 + endif + ql = qlk (k)/qadum + qi = qik (k)/qadum + + tmp = tz (k) + newice = new_ice_condensate(tmp, ql, qi) + sink = fac_frez * min(ql, newice, ql * (tice - tz (k)) / icpk (k)) + qim = qi0_max / den (k) + tmp = min (sink, dim (qim/qadum, qi)) + + tmp = tmp*qadum + sink = sink*qadum + mppfw = mppfw + sink * dp (k) * convt + + call update_qt (qak (k), qvk (k), qlk (k), qrk (k), qik (k), qsk (k), qgk (k), & + 0., - sink, 0., tmp, sink - tmp, 0., te8 (k), cvm (k), tz (k), & + lcpk (k), icpk (k), tcpk (k), tcp3 (k)) + + endif + + enddo + +end subroutine pimltfrz + +! ======================================================================= +! cloud ice melting to form cloud water and rain, Lin et al. (1983) +! ======================================================================= + +subroutine pimlt (ks, ke, dts, qak, qvk, qlk, qrk, qik, qsk, qgk, dp, tz, cvm, te8, den, lcpk, icpk, & + tcpk, tcp3, mppmi, convt) + + implicit none + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + integer, intent (in) :: ks, ke + + real, intent (in) :: dts, convt + + real (kind = r8), intent (in), dimension (ks:ke) :: te8 + + real, intent (in), dimension (ks:ke) :: den, dp + + real, intent (inout), dimension (ks:ke) :: qak, qvk, qlk, qrk, qik, qsk, qgk + real, intent (inout), dimension (ks:ke) :: lcpk, icpk, tcpk, tcp3 + + real (kind = r8), intent (inout), dimension (ks:ke) :: cvm, tz + + real, intent (inout) :: mppmi + + ! ----------------------------------------------------------------------- + ! local variables + ! ----------------------------------------------------------------------- + + integer :: k + + real :: ql, qi, qadum, newliq + real :: tmp, sink, fac_imlt + + fac_imlt = 1. - exp (- dts / tau_imlt) + + do k = ks, ke + + if (tz (k) .gt. tice .and. qik (k) .gt. qcmin) then + + ! Use In-Cloud condensates + if (in_cloud) then + qadum = max(qak(k),qcmin) + else + qadum = 1.0 + endif + ql = qlk (k)/qadum + qi = qik (k)/qadum + + tmp = tz (k) + newliq = new_liq_condensate(tmp, ql, qi) + sink = fac_imlt * min (qi, newliq, (tz (k) - tice) / icpk (k)) + tmp = min (sink, dim (ql_mlt/qadum, ql)) + + tmp = tmp * qadum + sink = sink * qadum + mppmi = mppmi + sink * dp (k) * convt + + call update_qt (qak (k), qvk (k), qlk (k), qrk (k), qik (k), qsk (k), qgk (k), & + 0., tmp, sink - tmp, - sink, 0., 0., te8 (k), cvm (k), tz (k), & + lcpk (k), icpk (k), tcpk (k), tcp3 (k)) + + endif + + enddo + +end subroutine pimlt + +! ======================================================================= +! cloud water homogeneous freezing to form cloud ice and snow, Lin et al. (1983) +! ======================================================================= + +subroutine pifr (ks, ke, dts, qak, qvk, qlk, qrk, qik, qsk, qgk, dp, tz, cvm, te8, den, lcpk, icpk, & + tcpk, tcp3, mppfw, convt) + + implicit none + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + integer, intent (in) :: ks, ke + + real, intent (in) :: dts, convt + + real, intent (in), dimension (ks:ke) :: den, dp + + real (kind = r8), intent (in), dimension (ks:ke) :: te8 + + real, intent (inout), dimension (ks:ke) :: qak, qvk, qlk, qrk, qik, qsk, qgk + real, intent (inout), dimension (ks:ke) :: lcpk, icpk, tcpk, tcp3 + + real (kind = r8), intent (inout), dimension (ks:ke) :: cvm, tz + + real, intent (inout) :: mppfw + + ! ----------------------------------------------------------------------- + ! local variables + ! ----------------------------------------------------------------------- + + integer :: k + + real :: ql, qi, qadum, newice + real :: tmp, sink, qim, fac_frez + + fac_frez = 1. - exp (- dts / tau_frez) + + do k = ks, ke + + if (tz (k) .le. tice .and. qlk (k) .gt. qcmin) then + + ! Use In-Cloud condensates + if (in_cloud) then + qadum = max(qak(k),qcmin) + else + qadum = 1.0 + endif + ql = qlk (k)/qadum + qi = qik (k)/qadum + + tmp = tz (k) + newice = new_ice_condensate(tmp, ql, qi) + sink = fac_frez * min(ql, newice, ql * (tice - tz (k)) / icpk (k)) + qim = qi0_max / den (k) + tmp = min (sink, dim (qim/qadum, qi)) + + tmp = tmp*qadum + sink = sink*qadum + mppfw = mppfw + sink * dp (k) * convt + + call update_qt (qak (k), qvk (k), qlk (k), qrk (k), qik (k), qsk (k), qgk (k), & + 0., - sink, 0., tmp, sink - tmp, 0., te8 (k), cvm (k), tz (k), & + lcpk (k), icpk (k), tcpk (k), tcp3 (k)) + + endif + + enddo + +end subroutine pifr + +! ======================================================================= +! snow melting (includes snow accretion with cloud water and rain) to form cloud water and rain +! Lin et al. (1983) +! ======================================================================= + +subroutine psmlt (ks, ke, dts, qa, qv, ql, qr, qi, qs, qg, dp, tz, cvm, te8, den, denfac, & + vtw, vtr, vts, lcpk, icpk, tcpk, tcp3, mppms, convt) + + implicit none + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + integer, intent (in) :: ks, ke + + real, intent (in) :: dts, convt + + real, intent (in), dimension (ks:ke) :: den, denfac, vtw, vtr, vts, dp + + real (kind = r8), intent (in), dimension (ks:ke) :: te8 + + real, intent (inout), dimension (ks:ke) :: qa, qv, ql, qr, qi, qs, qg + real, intent (inout), dimension (ks:ke) :: lcpk, icpk, tcpk, tcp3 + + real (kind = r8), intent (inout), dimension (ks:ke) :: cvm, tz + + real, intent (inout) :: mppms + + ! ----------------------------------------------------------------------- + ! local variables + ! ----------------------------------------------------------------------- + + integer :: k + + real :: tc, factor, tmp, sink, qden, dqdt, tin, dq, qsi + real :: psacw, psacr, pracs + + do k = ks, ke + + tc = tz (k) - tice + + if (tc .ge. 0. .and. qs (k) .gt. qpmin) then + + psacw = 0. + qden = qs (k) * den (k) + if (ql (k) .gt. qcmin) then + if (do_new_acc_water) then + psacw = acr3d (vts (k), vtw (k), ql (k), qs (k), csacw, acco (:, 7), & + acc (13), acc (14), den (k)) + else + factor = acr2d (qden, csacw, denfac (k), blins, mus) + psacw = factor / (1. + dts * factor) * ql (k) + endif + endif + + psacr = 0. + pracs = 0. + if (qr (k) .gt. qpmin) then + psacr = min (acr3d (vts (k), vtr (k), qr (k), qs (k), csacr, acco (:, 2), & + acc (3), acc (4), den (k)), qr (k) / dts) + pracs = acr3d (vtr (k), vts (k), qs (k), qr (k), cracs, acco (:, 1), & + acc (1), acc (2), den (k)) + endif + + tin = tz (k) + qsi = iqs (tin, den (k), dqdt) + dq = qsi - qv (k) + sink = max (0., pmlt (tc, dq, qden, psacw, psacr, csmlt, den (k), denfac (k), blins, mus, & + lcpk (k), icpk (k), cvm (k))) + + sink = min (qs (k), (sink + pracs) * dts, tc / icpk (k)) + tmp = min (sink, dim (qs_mlt, ql (k))) + mppms = mppms + sink * dp (k) * convt + + call update_qt (qa (k), qv (k), ql (k), qr (k), qi (k), qs (k), qg (k), & + 0., tmp, sink - tmp, 0., - sink, 0., te8 (k), cvm (k), tz (k), & + lcpk (k), icpk (k), tcpk (k), tcp3 (k)) + + endif + + enddo + +end subroutine psmlt + +! ======================================================================= +! graupel melting (includes graupel accretion with cloud water and rain) to form rain +! Lin et al. (1983) +! ======================================================================= + +subroutine pgmlt (ks, ke, dts, qa, qv, ql, qr, qi, qs, qg, dp, tz, cvm, te8, den, denfac, & + vtw, vtr, vtg, lcpk, icpk, tcpk, tcp3, mppmg, convt) + + implicit none + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + integer, intent (in) :: ks, ke + + real, intent (in) :: dts, convt + + real, intent (in), dimension (ks:ke) :: den, denfac, vtw, vtr, vtg, dp + + real (kind = r8), intent (in), dimension (ks:ke) :: te8 + + real, intent (inout), dimension (ks:ke) :: qa, qv, ql, qr, qi, qs, qg + real, intent (inout), dimension (ks:ke) :: lcpk, icpk, tcpk, tcp3 + + real (kind = r8), intent (inout), dimension (ks:ke) :: cvm, tz + + real, intent (inout) :: mppmg + + ! ----------------------------------------------------------------------- + ! local variables + ! ----------------------------------------------------------------------- + + integer :: k + + real :: tc, factor, sink, qden, dqdt, tin, dq, qsi + real :: pgacw, pgacr + real :: oms_cgacw, oms_cgacr + + oms_cgacw = onemsig*cgacw + oms_cgacr = onemsig*cgacr + + do k = ks, ke + + tc = tz (k) - tice + + if (tc .ge. 0. .and. qg (k) .gt. qpmin) then + + pgacw = 0. + qden = qg (k) * den (k) + if (ql (k) .gt. qcmin) then + if (do_new_acc_water) then + pgacw = acr3d (vtg (k), vtw (k), ql (k), qg (k), oms_cgacw, acco (:, 9), & + acc (17), acc (18), den (k)) + else + if (do_hail) then + factor = acr2d (qden, oms_cgacw, denfac (k), blinh, muh) + else + factor = acr2d (qden, oms_cgacw, denfac (k), bling, mug) + endif + pgacw = factor / (1. + dts * factor) * ql (k) + endif + endif + + pgacr = 0. + if (qr (k) .gt. qpmin) then + pgacr = min (acr3d (vtg (k), vtr (k), qr (k), qg (k), oms_cgacr, acco (:, 3), & + acc (5), acc (6), den (k)), qr (k) / dts) + endif + + tin = tz (k) + qsi = iqs (tin, den (k), dqdt) + dq = qsi - qv (k) + if (do_hail) then + sink = max (0., pmlt (tc, dq, qden, pgacw, pgacr, cgmlt, den (k), denfac (k), & + blinh, muh, lcpk (k), icpk (k), cvm (k))) + else + sink = max (0., pmlt (tc, dq, qden, pgacw, pgacr, cgmlt, den (k), denfac (k), & + bling, mug, lcpk (k), icpk (k), cvm (k))) + endif + + sink = min (qg (k), sink * dts, tc / icpk (k)) + mppmg = mppmg + sink * dp (k) * convt + + call update_qt (qa (k), qv (k), ql (k), qr (k), qi (k), qs (k), qg (k), & + 0., 0., sink, 0., 0., - sink, te8 (k), cvm (k), tz (k), & + lcpk (k), icpk (k), tcpk (k), tcp3 (k)) + + endif + + enddo + +end subroutine pgmlt + +! ======================================================================= +! snow accretion with cloud ice, Lin et al. (1983) +! ======================================================================= + +subroutine psaci (ks, ke, dts, qa, qv, ql, qr, qi, qs, qg, dp, tz, den, denfac, vti, & + vts, mppxs, convt) + + implicit none + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + integer, intent (in) :: ks, ke + + real, intent (in) :: dts, convt + + real, intent (in), dimension (ks:ke) :: den, denfac, vti, vts, dp + + real, intent (inout), dimension (ks:ke) :: qa, qv, ql, qr, qi, qs, qg + + real (kind = r8), intent (inout), dimension (ks:ke) :: tz + + real, intent (inout) :: mppxs + + ! ----------------------------------------------------------------------- + ! local variables + ! ----------------------------------------------------------------------- + + integer :: k + + real :: tc, factor, sink, qden + + do k = ks, ke + + tc = tz (k) - tice + + if (tc .lt. 0. .and. qi (k) .gt. qcmin) then + + sink = 0. + qden = qs (k) * den (k) + if (qs (k) .gt. qpmin) then + if (do_new_acc_ice) then + sink = dts * acr3d (vts (k), vti (k), qi (k), qs (k), csaci, acco (:, 8), & + acc (15), acc (16), den (k)) + else + factor = dts * acr2d (qden, csaci, denfac (k), blins, mus) + sink = factor / (1. + factor) * qi (k) + endif + endif + + sink = min (fi2s_fac * qi (k), sink) + mppxs = mppxs + sink * dp (k) * convt + + call update_qq (qa (k), qv (k), ql (k), qr (k), qi (k), qs (k), qg (k), & + 0., 0., 0., - sink, sink, 0.) + + endif + + enddo + +end subroutine psaci + +! ======================================================================= +! cloud ice to snow autoconversion, Lin et al. (1983) +! ======================================================================= + +subroutine psaut (ks, ke, dts, qak, qvk, qlk, qrk, qik, qsk, qgk, dp, tz, den, dik, mppas, convt) + + implicit none + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + integer, intent (in) :: ks, ke + + real, intent (in) :: dts, convt + + real, intent (in), dimension (ks:ke) :: den, dp + + real, intent (inout), dimension (ks:ke) :: qak, qvk, qlk, qrk, qik, qsk, qgk, dik + + real (kind = r8), intent (inout), dimension (ks:ke) :: tz + + real, intent (inout) :: mppas + + ! ----------------------------------------------------------------------- + ! local variables + ! ----------------------------------------------------------------------- + + integer :: k + + real :: tc, sink, fac_i2s, q_plus, qim, dq, tmp + + real :: di, qi, critical_qi_factor, qadum + + ! qi0_crt (ice to snow conversion) has strong resolution dependence + ! account for this using onemsig to convert more ice to snow at coarser resolutions + critical_qi_factor = qi0_crt*(1.e-1*(1.0-onemsig) + onemsig) + + fac_i2s = 1. - exp (- dts / tau_i2s) + + do k = ks, ke + + tc = tz (k) - tice + + if (tc .lt. 0. .and. qik (k) .gt. qcmin) then + + ! Use In-Cloud condensates + if (in_cloud) then + qadum = max(qak(k),qcmin) + else + qadum = 1.0 + endif + qi = qik (k)/qadum + di = dik (k)/qadum + + sink = 0. + di = max (di, qcmin) + q_plus = qi + di + ! Use of ice_fraction here is critical to producing the proper snow in reflectivity vs too much cloud ice + qim = ice_fraction(real(tz(k)), cnv_fraction, srf_type) * critical_qi_factor / qadum / den (k) + if (q_plus .gt. (qim + qcmin)) then + if (qim .gt. (qi - di)) then + dq = (0.25 * (q_plus - qim) ** 2) / di + else + dq = qi - qim + endif + sink = fac_i2s * exp (0.025 * tc) * dq + endif + sink = min (fi2s_fac * qi, sink) * qadum + mppas = mppas + sink * dp (k) * convt + + call update_qq (qak (k), qvk (k), qlk (k), qrk (k), qik (k), qsk (k), qgk (k), & + 0., 0., 0., - sink, sink, 0.) + + endif + + enddo + +end subroutine psaut + +! ======================================================================= +! graupel accretion with cloud ice, Lin et al. (1983) +! ======================================================================= + +subroutine pgaci (ks, ke, dts, qa, qv, ql, qr, qi, qs, qg, dp, tz, den, denfac, vti, & + vtg, mppxg, convt) + + implicit none + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + integer, intent (in) :: ks, ke + + real, intent (in) :: dts, convt + + real, intent (in), dimension (ks:ke) :: den, denfac, vti, vtg, dp + + real, intent (inout), dimension (ks:ke) :: qa, qv, ql, qr, qi, qs, qg + + real (kind = r8), intent (inout), dimension (ks:ke) :: tz + + real, intent (inout) :: mppxg + + ! ----------------------------------------------------------------------- + ! local variables + ! ----------------------------------------------------------------------- + + integer :: k + + real :: tc, factor, sink, qden + + do k = ks, ke + + tc = tz (k) - tice + + if (tc .lt. 0. .and. qi (k) .gt. qcmin) then + + sink = 0. + qden = qg (k) * den (k) + if (qg (k) .gt. qpmin) then + if (do_new_acc_ice) then + sink = dts * acr3d (vtg (k), vti (k), qi (k), qg (k), cgaci, acco (:, 10), & + acc (19), acc (20), den (k)) + else + if (do_hail) then + factor = dts * acr2d (qden, cgaci, denfac (k), blinh, muh) + else + factor = dts * acr2d (qden, cgaci, denfac (k), bling, mug) + endif + sink = factor / (1. + factor) * qi (k) + endif + endif + + sink = min (fi2g_fac * qi (k), sink) + mppxg = mppxg + sink * dp (k) * convt + + call update_qq (qa (k), qv (k), ql (k), qr (k), qi (k), qs (k), qg (k), & + 0., 0., 0., - sink, 0., sink) + + endif + + enddo + +end subroutine pgaci + +! ======================================================================= +! snow accretion with rain and rain freezing to form graupel, Lin et al. (1983) +! ======================================================================= + +subroutine psacr_pgfr (ks, ke, dts, qa, qv, ql, qr, qi, qs, qg, dp, tz, cvm, te8, den, & + denfac, vtr, vts, lcpk, icpk, tcpk, tcp3, mppfr, mpprs, convt) + + implicit none + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + integer, intent (in) :: ks, ke + + real, intent (in) :: dts, convt + + real, intent (in), dimension (ks:ke) :: den, denfac, vtr, vts, dp + + real (kind = r8), intent (in), dimension (ks:ke) :: te8 + + real, intent (inout), dimension (ks:ke) :: qa, qv, ql, qr, qi, qs, qg + real, intent (inout), dimension (ks:ke) :: lcpk, icpk, tcpk, tcp3 + + real (kind = r8), intent (inout), dimension (ks:ke) :: cvm, tz + + real, intent (inout) :: mppfr, mpprs + + ! ----------------------------------------------------------------------- + ! local variables + ! ----------------------------------------------------------------------- + + integer :: k + + real :: tc, factor, sink + real :: psacr, pgfr + + do k = ks, ke + + tc = tz (k) - tice + + if (tc .lt. 0. .and. qr (k) .gt. qpmin) then + + psacr = 0. + if (qs (k) .gt. qpmin) then + psacr = dts * acr3d (vts (k), vtr (k), qr (k), qs (k), csacr, acco (:, 2), & + acc (3), acc (4), den (k)) + endif + + pgfr = dts * cgfr (1) / den (k) * (exp (- cgfr (2) * tc) - 1.) * & + exp ((6 + mur) / (mur + 3) * log (6 * qr (k) * den (k))) + + sink = psacr + pgfr + factor = min (sink, qr (k), - tc / icpk (k)) / max (sink, qcmin) + psacr = factor * psacr + pgfr = factor * pgfr + mpprs = mpprs + psacr * dp (k) * convt + mppfr = mppfr + pgfr * dp (k) * convt + + sink = min (qr (k), psacr + pgfr) + + call update_qt (qa (k), qv (k), ql (k), qr (k), qi (k), qs (k), qg (k), & + 0., 0., - sink, 0., psacr, pgfr, te8 (k), cvm (k), tz (k), & + lcpk (k), icpk (k), tcpk (k), tcp3 (k)) + + endif + + enddo + +end subroutine psacr_pgfr + +! ======================================================================= +! graupel accretion with snow, Lin et al. (1983) +! ======================================================================= + +subroutine pgacs (ks, ke, dts, qa, qv, ql, qr, qi, qs, qg, dp, tz, den, vts, vtg, & + mppxg, convt) + + implicit none + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + integer, intent (in) :: ks, ke + + real, intent (in) :: dts, convt + + real, intent (in), dimension (ks:ke) :: den, vts, vtg, dp + + real, intent (inout), dimension (ks:ke) :: qa, qv, ql, qr, qi, qs, qg + + real (kind = r8), intent (inout), dimension (ks:ke) :: tz + + real, intent (inout) :: mppxg + + ! ----------------------------------------------------------------------- + ! local variables + ! ----------------------------------------------------------------------- + + integer :: k + + real :: sink + + do k = ks, ke + + if (tz (k) .lt. tice .and. qs (k) .gt. qpmin .and. qg (k) .gt. qpmin) then + + sink = dts * acr3d (vtg (k), vts (k), qs (k), qg (k), cgacs, acco (:, 4), & + acc (7), acc (8), den (k)) + sink = min (fs2g_fac * qs (k), sink) + mppxg = mppxg + sink * dp (k) * convt + + call update_qq (qa (k), qv (k), ql (k), qr (k), qi (k), qs (k), qg (k), & + 0., 0., 0., 0., - sink, sink) + + endif + + enddo + +end subroutine pgacs + +! ======================================================================= +! snow to graupel autoconversion, Lin et al. (1983) +! ======================================================================= + +subroutine pgaut (ks, ke, dts, qa, qv, ql, qr, qi, qs, qg, dp, tz, den, mppag, convt) + + implicit none + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + integer, intent (in) :: ks, ke + + real, intent (in) :: dts, convt + + real, intent (in), dimension (ks:ke) :: den, dp + + real, intent (inout), dimension (ks:ke) :: qa, qv, ql, qr, qi, qs, qg + + real (kind = r8), intent (inout), dimension (ks:ke) :: tz + + real, intent (inout) :: mppag + + ! ----------------------------------------------------------------------- + ! local variables + ! ----------------------------------------------------------------------- + + integer :: k + + real :: tc, factor, sink, qsm + + do k = ks, ke + + tc = tz (k) - tice + + if (tc .lt. 0. .and. qs (k) .gt. qpmin) then + + sink = 0 + qsm = qs0_crt / den (k) + if (qs (k) .gt. qsm) then + factor = dts * 1.e-3 * exp (0.09 * tc) + sink = factor / (1. + factor) * (qs (k) - qsm) + endif + + sink = min (fs2g_fac * qs (k), sink) + mppag = mppag + sink * dp (k) * convt + + call update_qq (qa (k), qv (k), ql (k), qr (k), qi (k), qs (k), qg (k), & + 0., 0., 0., 0., - sink, sink) + + endif + + enddo + +end subroutine pgaut + +! ======================================================================= +! graupel accretion with cloud water and rain, Lin et al. (1983) +! ======================================================================= + +subroutine pgacw_pgacr (ks, ke, dts, qa, qv, ql, qr, qi, qs, qg, dp, tz, cvm, te8, & + den, denfac, vtr, vtg, lcpk, icpk, tcpk, tcp3, mpprg, convt) + + implicit none + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + integer, intent (in) :: ks, ke + + real, intent (in) :: dts, convt + + real, intent (in), dimension (ks:ke) :: den, denfac, vtr, vtg, dp + + real (kind = r8), intent (in), dimension (ks:ke) :: te8 + + real, intent (inout), dimension (ks:ke) :: qa, qv, ql, qr, qi, qs, qg + real, intent (inout), dimension (ks:ke) :: lcpk, icpk, tcpk, tcp3 + + real (kind = r8), intent (inout), dimension (ks:ke) :: cvm, tz + + real, intent (inout) :: mpprg + + ! ----------------------------------------------------------------------- + ! local variables + ! ----------------------------------------------------------------------- + + integer :: k + + real :: tc, factor, sink, qden + real :: pgacw, pgacr + real :: oms_cgacw, oms_cgacr + + oms_cgacw = onemsig*cgacw + oms_cgacr = onemsig*cgacr + + do k = ks, ke + + tc = tz (k) - tice + + if (tc .lt. 0. .and. qg (k) .gt. qpmin) then + + pgacw = 0. + if (ql (k) .gt. qcmin) then + qden = qg (k) * den (k) + if (do_hail) then + factor = dts * acr2d (qden, oms_cgacw, denfac (k), blinh, muh) + else + factor = dts * acr2d (qden, oms_cgacw, denfac (k), bling, mug) + endif + pgacw = factor / (1. + factor) * ql (k) + endif + + pgacr = 0. + if (qr (k) .gt. qpmin) then + pgacr = min (dts * acr3d (vtg (k), vtr (k), qr (k), qg (k), oms_cgacr, acco (:, 3), & + acc (5), acc (6), den (k)), qr (k)) + endif + + sink = pgacr + pgacw + factor = min (sink, dim (tice, tz (k)) / icpk (k)) / max (sink, qcmin) + pgacr = factor * pgacr + pgacw = factor * pgacw + + sink = pgacr + pgacw + mpprg = mpprg + sink * dp (k) * convt + + call update_qt (qa (k), qv (k), ql (k), qr (k), qi (k), qs (k), qg (k), & + 0., - pgacw, - pgacr, 0., 0., sink, te8 (k), cvm (k), tz (k), & + lcpk (k), icpk (k), tcpk (k), tcp3 (k)) + + endif + + enddo + +end subroutine pgacw_pgacr + +! ======================================================================= +! temperature sentive high vertical resolution processes +! ======================================================================= + +subroutine subgrid_z_proc (ks, ke, den, denfac, dts, h_var, tz, qa, qv, ql, qr, & + qi, qs, qg, dp, ccn, cin, mppcw, mppew, mppe1, mppdi, mppd1, mppds, & + mppdg, mppsi, mpps1, mppss, mppsg, mppfw, convt, last_step) + + implicit none + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + logical, intent (in) :: last_step + + integer, intent (in) :: ks, ke + + real, intent (in) :: dts, convt + + real, intent (in), dimension (ks:ke) :: h_var, den, denfac, dp + + real, intent (inout), dimension (ks:ke) :: qa, qv, ql, qr, qi, qs, qg, ccn, cin + + real, intent (inout) :: mppcw, mppew, mppe1, mppdi, mppd1, mppds + real, intent (inout) :: mppdg, mppsi, mpps1, mppss, mppsg, mppfw + + real (kind = r8), intent (inout), dimension (ks:ke) :: tz + + ! ----------------------------------------------------------------------- + ! local variables + ! ----------------------------------------------------------------------- + + logical :: cond_evap + + integer :: n + + real, dimension (ks:ke) :: q_liq, q_sol, q_cond, lcpk, icpk, tcpk, tcp3 + + real (kind = r8), dimension (ks:ke) :: cvm, te8 + + ! ----------------------------------------------------------------------- + ! calculate heat capacities and latent heat coefficients + ! ----------------------------------------------------------------------- + + call cal_mhc_lhc (ks, ke, qv, ql, qr, qi, qs, qg, q_liq, q_sol, cvm, te8, tz, & + lcpk, icpk, tcpk, tcp3) + + ! ----------------------------------------------------------------------- + ! instant processes (include deposition, evaporation, and sublimation) + ! ----------------------------------------------------------------------- + + if (.not. do_warm_rain_mp) then + + call pinst (ks, ke, qa, qv, ql, qr, qi, qs, qg, tz, dp, cvm, te8, dts, den, & + lcpk, icpk, tcpk, tcp3, h_var, mppe1, mppd1, mpps1, convt) + + endif + +#ifdef SKIP + ! WMP - something here causes large warm temperature spikes + ! WMP - partial evap is moved into pinst call above + ! WMP - ignoring condensation for now + ! ----------------------------------------------------------------------- + ! cloud water condensation and evaporation + ! ----------------------------------------------------------------------- + + if (delay_cond_evap) then + cond_evap = last_step + else + cond_evap = .true. + endif + + if (cond_evap) then + do n = 1, nconds + call pcond_pevap (ks, ke, dts, qa, qv, ql, qr, qi, qs, qg, tz, dp, cvm, & + te8, den, lcpk, icpk, tcpk, tcp3, mppcw, mppew, convt) + enddo + endif +#endif + + if (.not. do_warm_rain_mp) then + + ! ----------------------------------------------------------------------- + ! enforce complete freezing below t_wfr + ! ----------------------------------------------------------------------- + + call pcomp (ks, ke, dts, qa, qv, ql, qr, qi, qs, qg, dp, tz, cvm, te8, lcpk, icpk, & + tcpk, tcp3, mppfw, convt) + + ! ----------------------------------------------------------------------- + ! Wegener Bergeron Findeisen process + ! ----------------------------------------------------------------------- + + call pwbf (ks, ke, dts, qa, qv, ql, qr, qi, qs, qg, dp, tz, cvm, te8, den, lcpk, & + icpk, tcpk, tcp3, mppfw, convt) + + ! ----------------------------------------------------------------------- + ! Bigg freezing mechanism + ! ----------------------------------------------------------------------- + + call pbigg (ks, ke, dts, qa, qv, ql, qr, qi, qs, qg, dp, tz, cvm, te8, den, ccn, & + lcpk, icpk, tcpk, tcp3, mppfw, convt) + + ! ----------------------------------------------------------------------- + ! cloud ice deposition and sublimation + ! ----------------------------------------------------------------------- + + call pidep_pisub (ks, ke, dts, qa, qv, ql, qr, qi, qs, qg, tz, dp, cvm, te8, den, & + lcpk, icpk, tcpk, tcp3, cin, mppdi, mppsi, convt) + + ! ----------------------------------------------------------------------- + ! snow deposition and sublimation + ! ----------------------------------------------------------------------- + + call psdep_pssub (ks, ke, dts, qa, qv, ql, qr, qi, qs, qg, tz, dp, cvm, te8, den, & + denfac, lcpk, icpk, tcpk, tcp3, mppds, mppss, convt) + + ! ----------------------------------------------------------------------- + ! graupel deposition and sublimation + ! ----------------------------------------------------------------------- + + call pgdep_pgsub (ks, ke, dts, qa, qv, ql, qr, qi, qs, qg, tz, dp, cvm, te8, den, & + denfac, lcpk, icpk, tcpk, tcp3, mppdg, mppsg, convt) + + endif + +end subroutine subgrid_z_proc + +! ======================================================================= +! instant processes (include deposition, evaporation, and sublimation) +! ======================================================================= + +subroutine pinst (ks, ke, qa, qv, ql, qr, qi, qs, qg, tz, dp, cvm, te8, dts, den, & + lcpk, icpk, tcpk, tcp3, h_var, mppe1, mppd1, mpps1, convt) + + implicit none + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + integer, intent (in) :: ks, ke + + real, intent (in) :: dts, convt + + real, intent (in), dimension (ks:ke) :: h_var, den, dp + + real (kind = r8), intent (in), dimension (ks:ke) :: te8 + + real, intent (inout), dimension (ks:ke) :: qa, qv, ql, qr, qi, qs, qg + real, intent (inout), dimension (ks:ke) :: lcpk, icpk, tcpk, tcp3 + + real (kind = r8), intent (inout), dimension (ks:ke) :: cvm, tz + + real, intent (inout) :: mppe1, mppd1, mpps1 + + ! ----------------------------------------------------------------------- + ! local variables + ! ----------------------------------------------------------------------- + + integer :: k + + real :: sink, subl, tin, qpz, rh, dqdt, qsw, qsi, rh_adj + real :: dq, factor, fac_l2v, rh_tem + + fac_l2v = 1. - exp (- dts / tau_l2v) + + do k = ks, ke + + ! ----------------------------------------------------------------------- + ! instant deposit all water vapor to cloud ice when temperature is super low + ! ----------------------------------------------------------------------- + + if (tz (k) .lt. t_min) then + + sink = dim (qv (k), qcmin) + mppd1 = mppd1 + sink * dp (k) * convt + + qa (k) = 1.0 + + call update_qt (qa (k), qv (k), ql (k), qr (k), qi (k), qs (k), qg (k), & + - sink, 0., 0., sink, 0., 0., te8 (k), cvm (k), tz (k), & + lcpk (k), icpk (k), tcpk (k), tcp3 (k)) + + endif + + ! ----------------------------------------------------------------------- + ! instant evaporation / sublimation of all clouds when rh < rh_adj + ! ----------------------------------------------------------------------- + + qpz = qv (k) + ql (k) + qi (k) + tin = (te8 (k) - lv00 * qpz + li00 * (qs (k) + qg (k))) / & + mhc (qpz, qr (k), qs (k) + qg (k)) + + if (tin .gt. t_sub + 6.) then + + ! initialize to 0s + sink = 0.0 + subl = 0.0 + + rh_adj = 1. - h_var(k) - rh_inc + qsi = iqs (tin, den (k), dqdt) + rh = qpz / qsi + if (rh .lt. rh_adj) then + ! instant evap of all liquid & ice + sink = ql (k) + subl = qi (k) + else + ! partial evap of liquid + tin = tz (k) + qsw = wqs (tin, den (k), dqdt) + rh_tem = qpz / qsw + dq = qsw - qv (k) + if (dq > qvmin) then + if (do_evap_timescale) then + factor = min (1., fac_l2v * (rh_fac_evap * dq / qsw)) + else + factor = 1. + endif + sink = min (ql (k), factor * ql(k) / (1. + tcp3 (k) * dqdt)) + if (use_rhc_cevap .and. rh_tem .ge. rhc_cevap) then + sink = 0. + endif + endif + ! nothing for ice + subl = 0.0 + endif + + sink = sink*onemsig ! resolution dependent evap 0:1 coarse:fine + subl = subl*onemsig ! resolution dependent subl 0:1 coarse:fine + + mppe1 = mppe1 + sink * dp (k) * convt + mpps1 = mpps1 + subl * dp (k) * convt + + call update_qt (qa (k), qv (k), ql (k), qr (k), qi (k), qs (k), qg (k), & + sink + subl, - sink, 0., - subl, 0., 0., te8 (k), cvm (k), tz (k), & + lcpk (k), icpk (k), tcpk (k), tcp3 (k)) + + endif + + enddo + +end subroutine pinst + +! ======================================================================= +! cloud water condensation and evaporation, Hong and Lim (2006) +! ======================================================================= + +subroutine pcond_pevap (ks, ke, dts, qa, qv, ql, qr, qi, qs, qg, tz, dp, cvm, te8, & + den, lcpk, icpk, tcpk, tcp3, mppcw, mppew, convt) + + implicit none + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + integer, intent (in) :: ks, ke + + real, intent (in) :: dts, convt + + real, intent (in), dimension (ks:ke) :: den, dp + + real (kind = r8), intent (in), dimension (ks:ke) :: te8 + + real, intent (inout), dimension (ks:ke) :: qa, qv, ql, qr, qi, qs, qg + real, intent (inout), dimension (ks:ke) :: lcpk, icpk, tcpk, tcp3 + + real (kind = r8), intent (inout), dimension (ks:ke) :: cvm, tz + + real, intent (inout) :: mppcw, mppew + + ! ----------------------------------------------------------------------- + ! local variables + ! ----------------------------------------------------------------------- + + integer :: k + + real :: sink, tin, qpz, dqdt, qsw, rh_tem, dq, factor, fac_l2v, fac_v2l + + fac_l2v = 1. - exp (- dts / tau_l2v) + fac_v2l = 1. - exp (- dts / tau_v2l) + + do k = ks, ke + + sink = 0.0 + tin = tz (k) + qsw = wqs (tin, den (k), dqdt) + qpz = qv (k) + ql (k) + qi (k) + rh_tem = qpz / qsw + dq = qsw - qv (k) + if (dq .gt. 0.) then + if (do_evap_timescale) then + factor = min (1., fac_l2v * (rh_fac_evap * dq / qsw)) + else + factor = 1. + endif + sink = min (ql (k), factor * dq / (1. + tcp3 (k) * dqdt)) + if (use_rhc_cevap .and. rh_tem .ge. rhc_cevap) then + sink = 0. + endif + mppew = mppew + sink * dp (k) * convt + else + if (do_cond_timescale) then + factor = min (1., fac_v2l * (rh_fac_cond * (- dq) / qsw)) + else + factor = 1. + endif + sink = - min (qv (k), factor * (- dq) / (1. + tcp3 (k) * dqdt)) + mppcw = mppcw - sink * dp (k) * convt + endif + sink = sink*onemsig ! resolution dependent evap 0:1 coarse:fine + + call update_qt (qa (k), qv (k), ql (k), qr (k), qi (k), qs (k), qg (k), & + sink, - sink, 0., 0., 0., 0., te8 (k), cvm (k), tz (k), & + lcpk (k), icpk (k), tcpk (k), tcp3 (k)) + + enddo + +end subroutine pcond_pevap + +! ======================================================================= +! enforce complete freezing below t_wfr, Lin et al. (1983) +! ======================================================================= + +subroutine pcomp (ks, ke, dts, qa, qv, ql, qr, qi, qs, qg, dp, tz, cvm, te8, lcpk, icpk, & + tcpk, tcp3, mppfw, convt) + + implicit none + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + integer, intent (in) :: ks, ke + + real, intent (in) :: dts, convt + + real, intent (in), dimension (ks:ke) :: dp + + real (kind = r8), intent (in), dimension (ks:ke) :: te8 + + real, intent (inout), dimension (ks:ke) :: qa, qv, ql, qr, qi, qs, qg + real, intent (inout), dimension (ks:ke) :: lcpk, icpk, tcpk, tcp3 + + real (kind = r8), intent (inout), dimension (ks:ke) :: cvm, tz + + real, intent (inout) :: mppfw + + ! ----------------------------------------------------------------------- + ! local variables + ! ----------------------------------------------------------------------- + + integer :: k + + real :: fac_frez, ifrac, sink + + fac_frez = 1. - exp (- dts / tau_frez) + + do k = ks, ke + + ifrac = ice_fraction(real(tz(k)),cnv_fraction,srf_type) + if (ifrac .eq. 1. .and. ql (k) .gt. qcmin) then + + sink = fac_frez * min(ql (k), ql (k) * (tice - tz (k)) / icpk (k)) + mppfw = mppfw + sink * dp (k) * convt + + call update_qt (qa (k), qv (k), ql (k), qr (k), qi (k), qs (k), qg (k), & + 0., - sink, 0., sink, 0., 0., te8 (k), cvm (k), tz (k), & + lcpk (k), icpk (k), tcpk (k), tcp3 (k)) + + endif + + enddo + +end subroutine pcomp + +! ======================================================================= +! Wegener Bergeron Findeisen process, Storelvmo and Tan (2015) +! ======================================================================= + +subroutine pwbf (ks, ke, dts, qa, qv, ql, qr, qi, qs, qg, dp, tz, cvm, te8, den, lcpk, & + icpk, tcpk, tcp3, mppfw, convt) + + implicit none + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + integer, intent (in) :: ks, ke + + real, intent (in) :: dts, convt + + real, intent (in), dimension (ks:ke) :: den, dp + + real (kind = r8), intent (in), dimension (ks:ke) :: te8 + + real, intent (inout), dimension (ks:ke) :: qa, qv, ql, qr, qi, qs, qg + real, intent (inout), dimension (ks:ke) :: lcpk, icpk, tcpk, tcp3 + + real (kind = r8), intent (inout), dimension (ks:ke) :: cvm, tz + + real, intent (inout) :: mppfw + + ! ----------------------------------------------------------------------- + ! local variables + ! ----------------------------------------------------------------------- + + integer :: k + + real :: tc, tin, sink, dqdt, qsw, qsi, qim, tmp, fac_wbf + + real :: critical_qi_factor + + if (.not. do_wbf) return + + ! qi0_crt (ice to snow conversion) has strong resolution dependence + ! account for this using onemsig to convert more ice to snow at coarser resolutions + critical_qi_factor = qi0_crt*(1.e-1*(1.0-onemsig) + onemsig) + + fac_wbf = 1. - exp (- dts / tau_wbf) + + do k = ks, ke + + tc = tice - tz (k) + + tin = tz (k) + qsw = wqs (tin, den (k), dqdt) + qsi = iqs (tin, den (k), dqdt) + + if (tc .gt. 0. .and. ql (k) .gt. qcmin .and. qi (k) .gt. qcmin .and. & + qv (k) .gt. qsi .and. qv (k) .lt. qsw) then + + sink = min (fac_wbf * ql (k), tc / icpk (k)) + qim = critical_qi_factor / den (k) + tmp = min (sink, dim (qim, qi (k))) + mppfw = mppfw + sink * dp (k) * convt + + call update_qt (qa (k), qv (k), ql (k), qr (k), qi (k), qs (k), qg (k), & + 0., - sink, 0., tmp, sink - tmp, 0., te8 (k), cvm (k), tz (k), & + lcpk (k), icpk (k), tcpk (k), tcp3 (k)) + + endif + + enddo + +end subroutine pwbf + +! ======================================================================= +! Bigg freezing mechanism, Bigg (1953) +! ======================================================================= + +subroutine pbigg (ks, ke, dts, qa, qv, ql, qr, qi, qs, qg, dp, tz, cvm, te8, den, ccn, & + lcpk, icpk, tcpk, tcp3, mppfw, convt) + + implicit none + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + integer, intent (in) :: ks, ke + + real, intent (in) :: dts, convt + + real, intent (in), dimension (ks:ke) :: den, dp + + real (kind = r8), intent (in), dimension (ks:ke) :: te8 + + real, intent (inout), dimension (ks:ke) :: qa, qv, ql, qr, qi, qs, qg, ccn + real, intent (inout), dimension (ks:ke) :: lcpk, icpk, tcpk, tcp3 + + real (kind = r8), intent (inout), dimension (ks:ke) :: cvm, tz + + real, intent (inout) :: mppfw + + ! ----------------------------------------------------------------------- + ! local variables + ! ----------------------------------------------------------------------- + + integer :: k + + real :: sink, tc + + if (.not. do_bigg) return + + do k = ks, ke + + tc = tice - tz (k) + + if (tc .gt. 0 .and. ql (k) .gt. qcmin) then + + if (do_psd_water_num) then + call cal_pc_ed_oe_rr_tv (ql (k), den (k), blinw, muw, & + pca = pcaw, pcb = pcbw, pc = ccn (k)) + ccn (k) = ccn (k) / den (k) + endif + + sink = 100. / (rhow * ccn (k)) * dts * (exp (0.66 * tc) - 1.) * ql (k) ** 2 + sink = min (ql (k), sink, tc / icpk (k)) + mppfw = mppfw + sink * dp (k) * convt + + call update_qt (qa (k), qv (k), ql (k), qr (k), qi (k), qs (k), qg (k), & + 0., - sink, 0., sink, 0., 0., te8 (k), cvm (k), tz (k), & + lcpk (k), icpk (k), tcpk (k), tcp3 (k)) + + endif + + enddo + +end subroutine pbigg + +! ======================================================================= +! cloud ice deposition and sublimation, Hong et al. (2004) +! ======================================================================= + +subroutine pidep_pisub (ks, ke, dts, qa, qv, ql, qr, qi, qs, qg, tz, dp, cvm, te8, & + den, lcpk, icpk, tcpk, tcp3, cin, mppdi, mppsi, convt) + + implicit none + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + integer, intent (in) :: ks, ke + + real, intent (in) :: dts, convt + + real, intent (in), dimension (ks:ke) :: den, dp + + real (kind = r8), intent (in), dimension (ks:ke) :: te8 + + real, intent (inout), dimension (ks:ke) :: qa, qv, ql, qr, qi, qs, qg, cin + real, intent (inout), dimension (ks:ke) :: lcpk, icpk, tcpk, tcp3 + + real (kind = r8), intent (inout), dimension (ks:ke) :: cvm, tz + + real, intent (out) :: mppdi, mppsi + + ! ----------------------------------------------------------------------- + ! local variables + ! ----------------------------------------------------------------------- + + integer :: k + + real :: sink, tin, dqdt, qsi, dq, pidep, tmp, tc, qi_gen, qi_crt + + do k = ks, ke + + if (tz (k) .lt. tice) then + + pidep = 0. + tin = tz (k) + qsi = iqs (tin, den (k), dqdt) + dq = qv (k) - qsi + tmp = min( qi (k), dq / (1. + tcpk (k) * dqdt) ) + + if (qi (k) .gt. qcmin) then + if (do_psd_ice_num) then + call cal_pc_ed_oe_rr_tv (qi (k), den (k), blini, mui, & + pca = pcai, pcb = pcbi, pc = cin (k)) + cin (k) = cin (k) / den (k) + elseif (.not. prog_cin) then + if (inflag .eq. 1) & + cin (k) = 5.38e7 * exp (0.75 * log (qi (k) * den (k))) + if (inflag .eq. 2) & + cin (k) = exp (- 2.80 + 0.262 * (tice - tz (k))) * 1000.0 + if (inflag .eq. 3) & + cin (k) = exp (- 0.639 + 12.96 * (qv (k) / qsi - 1.0)) * 1000.0 + if (inflag .eq. 4) & + cin (k) = 5.e-3 * exp (0.304 * (tice - tz (k))) * 1000.0 + if (inflag .eq. 5) & + cin (k) = 1.e-5 * exp (0.5 * (tice - tz (k))) * 1000.0 + endif + pidep = dts * dq * 4.0 * 11.9 * exp (0.5 * log (qi (k) * den (k) * cin (k))) / & + (qsi * den (k) * (tcpk (k) * cvm (k)) ** 2 / (tcond * rvgas * tz (k) ** 2) + & + 1. / vdifu) + endif + + if (dq .gt. 0.) then + tc = tice - tz (k) + qi_gen = 4.92e-11 * exp (1.33 * log (1.e3 * exp (0.1 * tc))) + if (igflag .eq. 1) & + qi_crt = qi_gen / den (k) + if (igflag .eq. 2) & + qi_crt = qi_gen * min (qi_lim, 0.1 * tc) / den (k) + if (igflag .eq. 3) & + qi_crt = 1.82e-6 * min (qi_lim, 0.1 * tc) / den (k) + if (igflag .eq. 4) & + qi_crt = max (qi_gen, 1.82e-6) * min (qi_lim, 0.1 * tc) / den (k) + sink = min (tmp, max (qi_crt - qi (k), pidep), tc / tcpk (k)) + mppdi = mppdi + sink * dp (k) * convt + else + pidep = pidep * min (1., dim (tz (k), t_sub) * is_fac) + sink = max (pidep, tmp, - qi (k)) + sink = sink*onemsig ! resolution dependent subl 0:1 coarse:fine + mppsi = mppsi - sink * dp (k) * convt + endif + + call update_qt (qa (k), qv (k), ql (k), qr (k), qi (k), qs (k), qg (k), & + - sink, 0., 0., sink, 0., 0., te8 (k), cvm (k), tz (k), & + lcpk (k), icpk (k), tcpk (k), tcp3 (k)) + + endif + + enddo + +end subroutine pidep_pisub + +! ======================================================================= +! snow deposition and sublimation, Lin et al. (1983) +! ======================================================================= + +subroutine psdep_pssub (ks, ke, dts, qa, qv, ql, qr, qi, qs, qg, tz, dp, cvm, te8, & + den, denfac, lcpk, icpk, tcpk, tcp3, mppds, mppss, convt) + + implicit none + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + integer, intent (in) :: ks, ke + + real, intent (in) :: dts, convt + + real, intent (in), dimension (ks:ke) :: den, dp, denfac + + real (kind = r8), intent (in), dimension (ks:ke) :: te8 + + real, intent (inout), dimension (ks:ke) :: qa, qv, ql, qr, qi, qs, qg + real, intent (inout), dimension (ks:ke) :: lcpk, icpk, tcpk, tcp3 + + real (kind = r8), intent (inout), dimension (ks:ke) :: cvm, tz + + real, intent (out) :: mppds, mppss + + ! ----------------------------------------------------------------------- + ! local variables + ! ----------------------------------------------------------------------- + + integer :: k + + real :: sink, tin, dqdt, qsi, qden, t2, dq, pssub + + do k = ks, ke + + if (qs (k) .gt. qpmin) then + + tin = tz (k) + qsi = iqs (tin, den (k), dqdt) + qden = qs (k) * den (k) + t2 = tz (k) * tz (k) + dq = qsi - qv (k) + pssub = psub (t2, dq, qden, qsi, cssub, den (k), denfac (k), blins, mus, tcpk (k), cvm (k)) + pssub = dts * pssub + dq = dq / (1. + tcpk (k) * dqdt) + if (pssub .gt. 0.) then + sink = min (pssub * min (1., dim (tz (k), t_sub) * ss_fac), qs (k)) + mppss = mppss + sink * dp (k) * convt + else + sink = 0. + if (tz (k) .le. tice) then + sink = max (pssub, dq, (tz (k) - tice) / tcpk (k)) + endif + mppds = mppds - sink * dp (k) * convt + endif + + call update_qt (qa (k), qv (k), ql (k), qr (k), qi (k), qs (k), qg (k), & + sink, 0., 0., 0., - sink, 0., te8 (k), cvm (k), tz (k), & + lcpk (k), icpk (k), tcpk (k), tcp3 (k)) + + endif + + enddo + +end subroutine psdep_pssub + +! ======================================================================= +! graupel deposition and sublimation, Lin et al. (1983) +! ======================================================================= + +subroutine pgdep_pgsub (ks, ke, dts, qa, qv, ql, qr, qi, qs, qg, tz, dp, cvm, te8, & + den, denfac, lcpk, icpk, tcpk, tcp3, mppdg, mppsg, convt) + + implicit none + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + integer, intent (in) :: ks, ke + + real, intent (in) :: dts, convt + + real, intent (in), dimension (ks:ke) :: den, dp, denfac + + real (kind = r8), intent (in), dimension (ks:ke) :: te8 + + real, intent (inout), dimension (ks:ke) :: qa, qv, ql, qr, qi, qs, qg + real, intent (inout), dimension (ks:ke) :: lcpk, icpk, tcpk, tcp3 + + real (kind = r8), intent (inout), dimension (ks:ke) :: cvm, tz + + real, intent (out) :: mppdg, mppsg + + ! ----------------------------------------------------------------------- + ! local variables + ! ----------------------------------------------------------------------- + + integer :: k + + real :: sink, tin, dqdt, qsi, qden, t2, dq, pgsub + + do k = ks, ke + + if (qg (k) .gt. qpmin) then + + tin = tz (k) + qsi = iqs (tin, den (k), dqdt) + qden = qg (k) * den (k) + t2 = tz (k) * tz (k) + dq = qsi - qv (k) + if (do_hail) then + pgsub = psub (t2, dq, qden, qsi, cgsub, den (k), denfac (k), & + blinh, muh, tcpk (k), cvm (k)) + else + pgsub = psub (t2, dq, qden, qsi, cgsub, den (k), denfac (k), & + bling, mug, tcpk (k), cvm (k)) + endif + pgsub = dts * pgsub + dq = dq / (1. + tcpk (k) * dqdt) + if (pgsub .gt. 0.) then + sink = min (pgsub * min (1., dim (tz (k), t_sub) * gs_fac), qg (k)) + mppsg = mppsg + sink * dp (k) * convt + else + sink = 0. + if (tz (k) .le. tice) then + sink = max (pgsub, dq, (tz (k) - tice) / tcpk (k)) + endif + mppdg = mppdg - sink * dp (k) * convt + endif + + call update_qt (qa (k), qv (k), ql (k), qr (k), qi (k), qs (k), qg (k), & + sink, 0., 0., 0., 0., - sink, te8 (k), cvm (k), tz (k), & + lcpk (k), icpk (k), tcpk (k), tcp3 (k)) + + endif + + enddo + +end subroutine pgdep_pgsub + +! ======================================================================= +! cloud fraction diagnostic +! ======================================================================= + +subroutine cloud_fraction (ks, ke, pz, den, qv, ql, qr, qi, qs, qg, qa, tz, gsize, h_var) + + implicit none + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + integer, intent (in) :: ks, ke + + real, intent (in) :: gsize + + real, intent (in), dimension (ks:ke) :: pz, den, h_var + + real (kind = r8), intent (in), dimension (ks:ke) :: tz + + real, intent (inout), dimension (ks:ke) :: qv, ql, qr, qi, qs, qg, qa + + ! ----------------------------------------------------------------------- + ! local variables + ! ----------------------------------------------------------------------- + + integer :: k + + real :: q_plus, q_minus + real :: rh, rqi, tin, qsw, qsi, qpz, qstar, sigma, gam + real :: dqdt, dq, liq, ice + real :: qa10, qa100 + + real, dimension (ks:ke) :: q_liq, q_sol, q_cond, lcpk, icpk, tcpk, tcp3 + + real (kind = r8), dimension (ks:ke) :: cvm, te8 + + ! ----------------------------------------------------------------------- + ! calculate heat capacities and latent heat coefficients + ! ----------------------------------------------------------------------- + + call cal_mhc_lhc (ks, ke, qv, ql, qr, qi, qs, qg, q_liq, q_sol, cvm, te8, tz, & + lcpk, icpk, tcpk, tcp3) + + do k = ks, ke + + ! combine water species + + ice = q_sol (k) + q_sol (k) = qi (k) + if (rad_snow) then + q_sol (k) = qi (k) + qs (k) + if (rad_graupel) then + q_sol (k) = qi (k) + qs (k) + qg (k) + endif + endif + + liq = q_liq (k) + q_liq (k) = ql (k) + if (rad_rain) then + q_liq (k) = ql (k) + qr (k) + endif + + q_cond (k) = q_liq (k) + q_sol (k) + qpz = qv (k) + q_cond (k) + + ! use the "liquid - frozen water temperature" (tin) to compute saturated specific humidity + + ice = ice - q_sol (k) + liq = liq - q_liq (k) + tin = (te8 (k) - lv00 * qpz + li00 * ice) / mhc (qpz, liq, ice) + + ! calculate saturated specific humidity + + if (tin .le. t_wfr) then + qstar = iqs (tin, den (k), dqdt) + elseif (tin .ge. tice) then + qstar = wqs (tin, den (k), dqdt) + else + qsi = iqs (tin, den (k), dqdt) + qsw = wqs (tin, den (k), dqdt) + if (q_cond (k) .gt. qcmin) then + rqi = q_sol (k) / q_cond (k) + else + rqi = (tice - tin) / (tice - t_wfr) + endif + qstar = rqi * qsi + (1. - rqi) * qsw + endif + + ! cloud schemes + + rh = qpz / qstar + + if (cfflag .eq. 1) then + if (rh .gt. rh_thres .and. qpz .gt. qcmin) then + + dq = h_var (k) * qpz + if (do_cld_adj) then + q_plus = qpz + dq * f_dq_p * min (1.0, max (0.0, (pz (k) - 200.e2) / & + (1000.e2 - 200.e2))) + else + q_plus = qpz + dq * f_dq_p + endif + q_minus = qpz - dq * f_dq_m + + if (icloud_f .eq. 2) then + if (qstar .lt. qpz) then + qa (k) = 1. + else + qa (k) = 0. + endif + elseif (icloud_f .eq. 3) then + if (qstar .lt. qpz) then + qa (k) = 1. + else + if (qstar .lt. q_plus) then + qa (k) = (q_plus - qstar) / (dq * f_dq_p) + else + qa (k) = 0. + endif + if (q_cond (k) .gt. qcmin) then + qa (k) = max (cld_min, qa (k)) + endif + qa (k) = min (1., qa (k)) + endif + else + if (qstar .lt. q_minus) then + qa (k) = 1. + else + if (qstar .lt. q_plus) then + if (icloud_f .eq. 0) then + qa (k) = (q_plus - qstar) / (dq * f_dq_p + dq * f_dq_m) + else + qa (k) = (q_plus - qstar) / ((dq * f_dq_p + dq * f_dq_m) * & + (1. - q_cond (k))) + endif + else + qa (k) = 0. + endif + if (q_cond (k) .gt. qcmin) then + qa (k) = max (cld_min, qa (k)) + endif + qa (k) = min (1., qa (k)) + endif + endif + else + qa (k) = 0. + endif + endif + + if (cfflag .eq. 2) then + if (rh .ge. 1.0) then + qa (k) = 1.0 + elseif (rh .gt. rh_thres .and. q_cond (k) .gt. qcmin) then + qa (k) = exp (xr_a * log (rh)) * (1.0 - exp (- xr_b * max (0.0, q_cond (k)) / & + max (1.e-5, exp (xr_c * log (max (1.e-10, 1.0 - rh) * qstar))))) + qa (k) = max (0.0, min (1., qa (k))) + else + qa (k) = 0.0 + endif + endif + + if (cfflag .eq. 3) then + if (q_cond (k) .gt. qcmin) then + qa (k) = 1. / 50. * (5.77 * (100. - gsize / 1000.) * & + exp (1.07 * log (max (qcmin * 1000., q_cond (k) * 1000.))) + & + 4.82 * (gsize / 1000. - 50.) * & + exp (0.94 * log (max (qcmin * 1000., q_cond (k) * 1000.)))) + qa (k) = qa (k) * (0.92 / 0.96 * q_liq (k) / q_cond (k) + & + 1.0 / 0.96 * q_sol (k) / q_cond (k)) + qa (k) = max (0.0, min (1., qa (k))) + else + qa (k) = 0.0 + endif + endif + + if (cfflag .eq. 4) then + sigma = 0.28 + exp (0.49 * log (max (qcmin * 1000., q_cond (k) * 1000.))) + gam = max (0.0, q_cond (k) * 1000.) / sigma + if (gam .lt. 0.18) then + qa10 = 0. + elseif (gam .gt. 2.0) then + qa10 = 1.0 + else + qa10 = - 0.1754 + 0.9811 * gam - 0.2223 * gam ** 2 + 0.0104 * gam ** 3 + qa10 = max (0.0, min (1., qa10)) + endif + if (gam .lt. 0.12) then + qa100 = 0. + elseif (gam .gt. 1.85) then + qa100 = 1.0 + else + qa100 = - 0.0913 + 0.7213 * gam + 0.1060 * gam ** 2 - 0.0946 * gam ** 3 + qa100 = max (0.0, min (1., qa100)) + endif + qa (k) = qa10 + (log10 (gsize / 1000.) - 1) * (qa100 - qa10) + qa (k) = max (0.0, min (1., qa (k))) + endif + + enddo + +end subroutine cloud_fraction + +! ======================================================================= +! piecewise parabolic lagrangian scheme +! this subroutine is the same as map1_q2 in fv_mapz_mod. +! ======================================================================= + +subroutine lagrangian_fall (ks, ke, zs, ze, zt, dp, q, precip, m1) + + implicit none + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + integer, intent (in) :: ks, ke + + real, intent (in) :: zs + + real, intent (in), dimension (ks:ke + 1) :: ze, zt + + real, intent (in), dimension (ks:ke) :: dp + + real, intent (inout), dimension (ks:ke) :: q + + real, intent (inout) :: precip + + real, intent (out), dimension (ks:ke) :: m1 + + ! ----------------------------------------------------------------------- + ! local variables + ! ----------------------------------------------------------------------- + + integer :: k, k0, n, m + + real :: a4 (4, ks:ke), pl, pr, delz, esl + + real, parameter :: r3 = 1. / 3., r23 = 2. / 3. + + real, dimension (ks:ke) :: qm, dz + + ! ----------------------------------------------------------------------- + ! density: + ! ----------------------------------------------------------------------- + + do k = ks, ke + dz (k) = zt (k) - zt (k + 1) + q (k) = q (k) * dp (k) + a4 (1, k) = q (k) / dz (k) + qm (k) = 0. + enddo + + ! ----------------------------------------------------------------------- + ! construct vertical profile with zt as coordinate + ! ----------------------------------------------------------------------- + + call cs_profile (a4 (1, ks), dz (ks), ke - ks + 1) + + k0 = ks + do k = ks, ke + do n = k0, ke + if (ze (k) .le. zt (n) .and. ze (k) .ge. zt (n + 1)) then + pl = (zt (n) - ze (k)) / dz (n) + if (zt (n + 1) .le. ze (k + 1)) then + ! entire new grid is within the original grid + pr = (zt (n) - ze (k + 1)) / dz (n) + qm (k) = a4 (2, n) + 0.5 * (a4 (4, n) + a4 (3, n) - a4 (2, n)) * (pr + pl) - & + a4 (4, n) * r3 * (pr * (pr + pl) + pl ** 2) + qm (k) = qm (k) * (ze (k) - ze (k + 1)) + k0 = n + goto 555 + else + qm (k) = (ze (k) - zt (n + 1)) * (a4 (2, n) + 0.5 * (a4 (4, n) + & + a4 (3, n) - a4 (2, n)) * (1. + pl) - a4 (4, n) * (r3 * (1. + pl * (1. + pl)))) + if (n .lt. ke) then + do m = n + 1, ke + ! locate the bottom edge: ze (k + 1) + if (ze (k + 1) .lt. zt (m + 1)) then + qm (k) = qm (k) + q (m) + else + delz = zt (m) - ze (k + 1) + esl = delz / dz (m) + qm (k) = qm (k) + delz * (a4 (2, m) + 0.5 * esl * & + (a4 (3, m) - a4 (2, m) + a4 (4, m) * (1. - r23 * esl))) + k0 = m + goto 555 + endif + enddo + endif + goto 555 + endif + endif + enddo + 555 continue + enddo + + m1 (ks) = q (ks) - qm (ks) + do k = ks + 1, ke + m1 (k) = m1 (k - 1) + q (k) - qm (k) + enddo + precip = precip + m1 (ke) + + ! ----------------------------------------------------------------------- + ! convert back to * dry * mixing ratio: + ! dp must be dry air_mass (because moist air mass will be changed due to terminal fall) . + ! ----------------------------------------------------------------------- + + do k = ks, ke + q (k) = qm (k) / dp (k) + enddo + +end subroutine lagrangian_fall + +! ======================================================================= +! vertical profile reconstruction +! this subroutine is the same as cs_profile in fv_mapz_mod where iv = 0 and kord = 9 +! ======================================================================= + +subroutine cs_profile (a4, del, km) + + implicit none + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + integer, intent (in) :: km + + real, intent (in) :: del (km) + + real, intent (inout) :: a4 (4, km) + + ! ----------------------------------------------------------------------- + ! local variables + ! ----------------------------------------------------------------------- + + integer :: k + + logical :: extm (km) + + real :: gam (km), q (km + 1), d4, bet, a_bot, grat, pmp, lac + real :: pmp_1, lac_1, pmp_2, lac_2, da1, da2, a6da + + grat = del (2) / del (1) ! grid ratio + bet = grat * (grat + 0.5) + q (1) = (2. * grat * (grat + 1.) * a4 (1, 1) + a4 (1, 2)) / bet + gam (1) = (1. + grat * (grat + 1.5)) / bet + + do k = 2, km + d4 = del (k - 1) / del (k) + bet = 2. + 2. * d4 - gam (k - 1) + q (k) = (3. * (a4 (1, k - 1) + d4 * a4 (1, k)) - q (k - 1)) / bet + gam (k) = d4 / bet + enddo + + a_bot = 1. + d4 * (d4 + 1.5) + q (km + 1) = (2. * d4 * (d4 + 1.) * a4 (1, km) + a4 (1, km - 1) - a_bot * q (km)) & + / (d4 * (d4 + 0.5) - a_bot * gam (km)) + + do k = km, 1, - 1 + q (k) = q (k) - gam (k) * q (k + 1) + enddo + + ! ----------------------------------------------------------------------- + ! apply constraints + ! ----------------------------------------------------------------------- + + do k = 2, km + gam (k) = a4 (1, k) - a4 (1, k - 1) + enddo + + ! ----------------------------------------------------------------------- + ! top: + ! ----------------------------------------------------------------------- + + q (1) = max (q (1), 0.) + q (2) = min (q (2), max (a4 (1, 1), a4 (1, 2))) + q (2) = max (q (2), min (a4 (1, 1), a4 (1, 2)), 0.) + + ! ----------------------------------------------------------------------- + ! interior: + ! ----------------------------------------------------------------------- + + do k = 3, km - 1 + if (gam (k - 1) * gam (k + 1) .gt. 0.) then + ! apply large - scale constraints to all fields if not local max / min + q (k) = min (q (k), max (a4 (1, k - 1), a4 (1, k))) + q (k) = max (q (k), min (a4 (1, k - 1), a4 (1, k))) + else + if (gam (k - 1) .gt. 0.) then + ! there exists a local max + q (k) = max (q (k), min (a4 (1, k - 1), a4 (1, k))) + else + ! there exists a local min + q (k) = min (q (k), max (a4 (1, k - 1), a4 (1, k))) + ! positive-definite + q (k) = max (q (k), 0.0) + endif + endif + enddo + + ! ----------------------------------------------------------------------- + ! bottom: + ! ----------------------------------------------------------------------- + + q (km) = min (q (km), max (a4 (1, km - 1), a4 (1, km))) + q (km) = max (q (km), min (a4 (1, km - 1), a4 (1, km)), 0.) + q (km + 1) = max (q (km + 1), 0.) + + do k = 1, km + a4 (2, k) = q (k) + a4 (3, k) = q (k + 1) + enddo + + do k = 1, km + if (k .eq. 1 .or. k .eq. km) then + extm (k) = (a4 (2, k) - a4 (1, k)) * (a4 (3, k) - a4 (1, k)) .gt. 0. + else + extm (k) = gam (k) * gam (k + 1) .lt. 0. + endif + enddo + + ! ----------------------------------------------------------------------- + ! apply constraints + ! f (s) = al + s * [ (ar - al) + a6 * (1 - s) ] (0 <= s <= 1) + ! always use monotonic mapping + ! ----------------------------------------------------------------------- + + ! ----------------------------------------------------------------------- + ! top: + ! ----------------------------------------------------------------------- + + a4 (2, 1) = max (0., a4 (2, 1)) + + ! ----------------------------------------------------------------------- + ! Huynh's 2nd constraint for interior: + ! ----------------------------------------------------------------------- + + do k = 3, km - 2 + if (extm (k)) then + ! positive definite constraint only if true local extrema + if (a4 (1, k) .lt. qcmin .or. extm (k - 1) .or. extm (k + 1)) then + a4 (2, k) = a4 (1, k) + a4 (3, k) = a4 (1, k) + endif + else + a4 (4, k) = 6. * a4 (1, k) - 3. * (a4 (2, k) + a4 (3, k)) + if (abs (a4 (4, k)) .gt. abs (a4 (2, k) - a4 (3, k))) then + ! check within the smooth region if subgrid profile is non - monotonic + pmp_1 = a4 (1, k) - 2.0 * gam (k + 1) + lac_1 = pmp_1 + 1.5 * gam (k + 2) + a4 (2, k) = min (max (a4 (2, k), min (a4 (1, k), pmp_1, lac_1)), & + max (a4 (1, k), pmp_1, lac_1)) + pmp_2 = a4 (1, k) + 2.0 * gam (k) + lac_2 = pmp_2 - 1.5 * gam (k - 1) + a4 (3, k) = min (max (a4 (3, k), min (a4 (1, k), pmp_2, lac_2)), & + max (a4 (1, k), pmp_2, lac_2)) + endif + endif + enddo + + do k = 1, km - 1 + a4 (4, k) = 6. * a4 (1, k) - 3. * (a4 (2, k) + a4 (3, k)) + enddo + + k = km - 1 + if (extm (k)) then + a4 (2, k) = a4 (1, k) + a4 (3, k) = a4 (1, k) + a4 (4, k) = 0. + else + da1 = a4 (3, k) - a4 (2, k) + da2 = da1 ** 2 + a6da = a4 (4, k) * da1 + if (a6da .lt. - da2) then + a4 (4, k) = 3. * (a4 (2, k) - a4 (1, k)) + a4 (3, k) = a4 (2, k) - a4 (4, k) + elseif (a6da .gt. da2) then + a4 (4, k) = 3. * (a4 (3, k) - a4 (1, k)) + a4 (2, k) = a4 (3, k) - a4 (4, k) + endif + endif + + call cs_limiters (km - 1, a4) + + ! ----------------------------------------------------------------------- + ! bottom: + ! ----------------------------------------------------------------------- + + a4 (2, km) = a4 (1, km) + a4 (3, km) = a4 (1, km) + a4 (4, km) = 0. + +end subroutine cs_profile + +! ======================================================================= +! cubic spline (cs) limiters or boundary conditions +! a positive-definite constraint (iv = 0) is applied to tracers in every layer, +! adjusting the top-most and bottom-most interface values to enforce positive. +! this subroutine is the same as cs_limiters in fv_mapz_mod where iv = 0. +! ======================================================================= + +subroutine cs_limiters (km, a4) + + implicit none + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + integer, intent (in) :: km + + real, intent (inout) :: a4 (4, km) ! ppm array + + ! ----------------------------------------------------------------------- + ! local variables + ! ----------------------------------------------------------------------- + + integer :: k + + real, parameter :: r12 = 1. / 12. + + do k = 1, km + if (a4 (1, k) .le. 0.) then + a4 (2, k) = a4 (1, k) + a4 (3, k) = a4 (1, k) + a4 (4, k) = 0. + else + if (abs (a4 (3, k) - a4 (2, k)) .lt. - a4 (4, k)) then + if ((a4 (1, k) + 0.25 * (a4 (3, k) - a4 (2, k)) ** 2 / a4 (4, k) + & + a4 (4, k) * r12) .lt. 0.) then + ! local minimum is negative + if (a4 (1, k) .lt. a4 (3, k) .and. a4 (1, k) .lt. a4 (2, k)) then + a4 (3, k) = a4 (1, k) + a4 (2, k) = a4 (1, k) + a4 (4, k) = 0. + elseif (a4 (3, k) .gt. a4 (2, k)) then + a4 (4, k) = 3. * (a4 (2, k) - a4 (1, k)) + a4 (3, k) = a4 (2, k) - a4 (4, k) + else + a4 (4, k) = 3. * (a4 (3, k) - a4 (1, k)) + a4 (2, k) = a4 (3, k) - a4 (4, k) + endif + endif + endif + endif + enddo + +end subroutine cs_limiters + +! ======================================================================= +! time-implicit monotonic scheme +! ======================================================================= + +subroutine implicit_fall (dts, ks, ke, ze, vt, dp, q, precip, m1) + + implicit none + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + integer, intent (in) :: ks, ke + + real, intent (in) :: dts + + real, intent (in), dimension (ks:ke + 1) :: ze + + real, intent (in), dimension (ks:ke) :: vt, dp + + real, intent (inout), dimension (ks:ke) :: q + + real, intent (inout) :: precip + + real, intent (out), dimension (ks:ke) :: m1 + + ! ----------------------------------------------------------------------- + ! local variables + ! ----------------------------------------------------------------------- + + integer :: k + + real, dimension (ks:ke) :: dz, qm, dd + + do k = ks, ke + dz (k) = ze (k) - ze (k + 1) + dd (k) = dts * vt (k) + q (k) = q (k) * dp (k) + enddo + + qm (ks) = q (ks) / (dz (ks) + dd (ks)) + do k = ks + 1, ke + qm (k) = (q (k) + qm (k - 1) * dd (k - 1)) / (dz (k) + dd (k)) + enddo + + do k = ks, ke + qm (k) = qm (k) * dz (k) + enddo + + m1 (ks) = q (ks) - qm (ks) + do k = ks + 1, ke + m1 (k) = m1 (k - 1) + q (k) - qm (k) + enddo + precip = precip + m1 (ke) + + do k = ks, ke + q (k) = qm (k) / dp (k) + enddo + +end subroutine implicit_fall + +! ======================================================================= +! time-explicit monotonic scheme +! ======================================================================= + +subroutine explicit_fall (dts, ks, ke, ze, vt, dp, q, precip, m1) + + implicit none + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + integer, intent (in) :: ks, ke + + real, intent (in) :: dts + + real, intent (in), dimension (ks:ke + 1) :: ze + + real, intent (in), dimension (ks:ke) :: vt, dp + + real, intent (inout), dimension (ks:ke) :: q + + real, intent (inout) :: precip + + real, intent (out), dimension (ks:ke) :: m1 + + ! ----------------------------------------------------------------------- + ! local variables + ! ----------------------------------------------------------------------- + + integer :: n, k, nstep + + real, dimension (ks:ke) :: dz, qm, q0, dd + + do k = ks, ke + dz (k) = ze (k) - ze (k + 1) + dd (k) = dts * vt (k) + q0 (k) = q (k) * dp (k) + enddo + + nstep = 1 + int (maxval (dd / dz)) + do k = ks, ke + dd (k) = dd (k) / nstep + q (k) = q0 (k) + enddo + + do n = 1, nstep + qm (ks) = q (ks) - q (ks) * dd (ks) / dz (ks) + do k = ks + 1, ke + qm (k) = q (k) - q (k) * dd (k) / dz (k) + q (k - 1) * dd (k - 1) / dz (k - 1) + enddo + q = qm + enddo + + m1 (ks) = q0 (ks) - qm (ks) + do k = ks + 1, ke + m1 (k) = m1 (k - 1) + q0 (k) - qm (k) + enddo + precip = precip + m1 (ke) + + do k = ks, ke + q (k) = qm (k) / dp (k) + enddo + +end subroutine explicit_fall + +! ======================================================================= +! combine time-implicit monotonic scheme with the piecewise parabolic lagrangian scheme +! ======================================================================= + +subroutine implicit_lagrangian_fall (dts, ks, ke, zs, ze, zt, vt, dp, q, & + precip, flux, sed_fac) + + implicit none + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + integer, intent (in) :: ks, ke + + real, intent (in) :: zs, dts, sed_fac + + real, intent (in), dimension (ks:ke + 1) :: ze, zt + + real, intent (in), dimension (ks:ke) :: vt, dp + + real, intent (inout), dimension (ks:ke) :: q + + real, intent (inout) :: precip + + real, intent (out), dimension (ks:ke) :: flux + + ! ----------------------------------------------------------------------- + ! local variables + ! ----------------------------------------------------------------------- + + real :: pre0, pre1 + + real, dimension (ks:ke) :: q0, q1, m0, m1 + + q0 = q + pre0 = precip + + call implicit_fall (dts, ks, ke, ze, vt, dp, q0, pre0, m0) + + q1 = q + pre1 = precip + + call lagrangian_fall (ks, ke, zs, ze, zt, dp, q1, pre1, m1) + + q = q0 * sed_fac + q1 * (1.0 - sed_fac) + flux = m0 * sed_fac + m1 * (1.0 - sed_fac) + precip = pre0 * sed_fac + pre1 * (1.0 - sed_fac) + +end subroutine implicit_lagrangian_fall + +! ======================================================================= +! vertical subgrid variability used for cloud ice and cloud water autoconversion +! edges: qe == qbar + / - dm +! ======================================================================= + +subroutine linear_prof (km, q, dm, z_var, h_var) + + implicit none + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + integer, intent (in) :: km + + logical, intent (in) :: z_var + + real, intent (in) :: q (km), h_var (km) + + real, intent (out) :: dm (km) + + ! ----------------------------------------------------------------------- + ! local variables + ! ----------------------------------------------------------------------- + + integer :: k + + real :: dq (km) + + if (z_var) then + do k = 2, km + dq (k) = 0.5 * (q (k) - q (k - 1)) + enddo + dm (1) = 0. + ! ----------------------------------------------------------------------- + ! use twice the strength of the positive definiteness limiter (Lin et al. 1994) + ! ----------------------------------------------------------------------- + do k = 2, km - 1 + dm (k) = 0.5 * min (abs (dq (k) + dq (k + 1)), 0.5 * q (k)) + if (dq (k) * dq (k + 1) .le. 0.) then + if (dq (k) .gt. 0.) then + dm (k) = min (dm (k), dq (k), - dq (k + 1)) + else + dm (k) = 0. + endif + endif + enddo + dm (km) = 0. + ! ----------------------------------------------------------------------- + ! impose a presumed background horizontal variability that is proportional to the value itself + ! ----------------------------------------------------------------------- + do k = 1, km + dm (k) = max (dm (k), 0.0, h_var (k) * q (k)) + enddo + else + do k = 1, km + dm (k) = max (0.0, h_var (k) * q (k)) + enddo + endif + +end subroutine linear_prof + +! ======================================================================= +! accretion function, Lin et al. (1983) +! ======================================================================= + +function acr2d (qden, c, denfac, blin, mu) + + implicit none + + real :: acr2d + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + real, intent (in) :: qden, c, denfac, blin, mu + + acr2d = denfac * c * exp ((2 + mu + blin) / (mu + 3) * log (6 * qden)) + +end function acr2d + +! ======================================================================= +! accretion function, Lin et al. (1983) +! ======================================================================= + +function acr3d (v1, v2, q1, q2, c, acco, acc1, acc2, den) + + implicit none + + real :: acr3d + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + real, intent (in) :: v1, v2, c, den, q1, q2, acco (3), acc1, acc2 + + ! ----------------------------------------------------------------------- + ! local variables + ! ----------------------------------------------------------------------- + + integer :: i + + real :: t1, t2, tmp, vdiff + + t1 = exp (1. / (acc1 + 3) * log (6 * q1 * den)) + t2 = exp (1. / (acc2 + 3) * log (6 * q2 * den)) + + if (vdiffflag .eq. 1) vdiff = abs (v1 - v2) + if (vdiffflag .eq. 2) vdiff = sqrt ((1.20 * v1 - 0.95 * v2) ** 2. + 0.08 * v1 * v2) + if (vdiffflag .eq. 3) vdiff = sqrt ((1.00 * v1 - 1.00 * v2) ** 2. + 0.04 * v1 * v2) + + acr3d = c * vdiff / den + + tmp = 0 + do i = 1, 3 + tmp = tmp + acco (i) * exp ((6 + acc1 - i) * log (t1)) * exp ((acc2 + i - 1) * log (t2)) + enddo + + acr3d = acr3d * tmp + +end function acr3d + +! ======================================================================= +! ventilation coefficient, Lin et al. (1983) +! ======================================================================= + +function vent_coeff (qden, c1, c2, denfac, blin, mu) + + implicit none + + real :: vent_coeff + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + real, intent (in) :: qden, c1, c2, denfac, blin, mu + + vent_coeff = c1 + c2 * exp ((3 + 2 * mu + blin) / (mu + 3) / 2 * log (6 * qden)) * & + sqrt (denfac) / exp ((1 + mu) / (mu + 3) * log (6 * qden)) + +end function vent_coeff + +! ======================================================================= +! sublimation or deposition function, Lin et al. (1983) +! ======================================================================= + +function psub (t2, dq, qden, qsat, c, den, denfac, blin, mu, cpk, cvm) + + implicit none + + real :: psub + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + real, intent (in) :: t2, dq, qden, qsat, c (5), den, denfac, blin, cpk, mu + + real (kind = r8), intent (in) :: cvm + + psub = c (1) * t2 * dq * exp ((1 + mu) / (mu + 3) * log (6 * qden)) * & + vent_coeff (qden, c (2), c (3), denfac, blin, mu) / & + (c (4) * t2 + c (5) * (cpk * cvm) ** 2 * qsat * den) + +end function psub + +! ======================================================================= +! melting function, Lin et al. (1983) +! ======================================================================= + +function pmlt (tc, dq, qden, pxacw, pxacr, c, den, denfac, blin, mu, lcpk, icpk, cvm) + + implicit none + + real :: pmlt + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + real, intent (in) :: tc, dq, qden, pxacw, pxacr, c (4), den, denfac, blin, lcpk, icpk, mu + + real (kind = r8), intent (in) :: cvm + + pmlt = (c (1) / (icpk * cvm) * tc / den - c (2) * lcpk / icpk * dq) * & + exp ((1 + mu) / (mu + 3) * log (6 * qden)) * & + vent_coeff (qden, c (3), c (4), denfac, blin, mu) + & + c_liq / (icpk * cvm) * tc * (pxacw + pxacr) + +end function pmlt + +! ======================================================================= +! sedimentation of horizontal momentum +! ======================================================================= + +subroutine sedi_uv (ks, ke, m1, dp, u, v) + + implicit none + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + integer, intent (in) :: ks, ke + + real, intent (in), dimension (ks:ke) :: m1, dp + + real, intent (inout), dimension (ks:ke) :: u, v + + ! ----------------------------------------------------------------------- + ! local variables + ! ----------------------------------------------------------------------- + + integer :: k + + do k = ks + 1, ke + u (k) = (dp (k) * u (k) + m1 (k - 1) * u (k - 1)) / (dp (k) + m1 (k - 1)) + v (k) = (dp (k) * v (k) + m1 (k - 1) * v (k - 1)) / (dp (k) + m1 (k - 1)) + enddo + +end subroutine sedi_uv + +! ======================================================================= +! sedimentation of vertical momentum +! ======================================================================= + +subroutine sedi_w (ks, ke, m1, w, vt, dm) + + implicit none + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + integer, intent (in) :: ks, ke + + real, intent (in), dimension (ks:ke) :: m1, vt, dm + + real, intent (inout), dimension (ks:ke) :: w + + ! ----------------------------------------------------------------------- + ! local variables + ! ----------------------------------------------------------------------- + + integer :: k + + w (ks) = w (ks) + m1 (ks) * vt (ks) / dm (ks) + do k = ks + 1, ke + w (k) = (dm (k) * w (k) + m1 (k - 1) * (w (k - 1) - vt (k - 1)) + m1 (k) * vt (k)) / & + (dm (k) + m1 (k - 1)) + enddo + +end subroutine sedi_w + +! ======================================================================= +! sedimentation of heat +! ======================================================================= + +subroutine sedi_heat (ks, ke, dm, m1, dz, tz, qv, ql, qr, qi, qs, qg, cw) + + implicit none + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + integer, intent (in) :: ks, ke + + real, intent (in) :: cw + + real, intent (in), dimension (ks:ke) :: dm, m1, dz, qv, ql, qr, qi, qs, qg + + real (kind = r8), intent (inout), dimension (ks:ke) :: tz + + ! ----------------------------------------------------------------------- + ! local variables + ! ----------------------------------------------------------------------- + + integer :: k + + real, dimension (ks:ke) :: dgz, cv0 + + do k = ks + 1, ke + dgz (k) = - 0.5 * grav * (dz (k - 1) + dz (k)) + cv0 (k) = dm (k) * (cv_air + qv (k) * cv_vap + (qr (k) + ql (k)) * c_liq + & + (qi (k) + qs (k) + qg (k)) * c_ice) + cw * (m1 (k) - m1 (k - 1)) + enddo + + do k = ks + 1, ke + tz (k) = (cv0 (k) * tz (k) + m1 (k - 1) * (cw * tz (k - 1) + dgz (k))) / & + (cv0 (k) + cw * m1 (k - 1)) + enddo + +end subroutine sedi_heat + +! ======================================================================= +! fast saturation adjustments +! ======================================================================= +#ifdef GFDL_ONLY +subroutine fast_sat_adj (dtm, is, ie, ks, ke, hydrostatic, consv_te, & + adj_vmr, te, dte, qv, ql, qr, qi, qs, qg, qa, zet, qnl, qni, hs, delz, & + pt, delp, q_con, cappa, gsize, mppcw, mppew, mppe1, mpper, mppdi, & + mppd1, mppds, mppdg, mppsi, mpps1, mppss, mppsg, mppfw, mppfr, & + mppmi, mppms, mppmg, mppm1, mppm2, mppm3, mppar, mppas, mppag, & + mpprs, mpprg, mppxr, mppxs, mppxg, last_step, do_sat_adj, & + use_cond, moist_kappa) + + implicit none + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + integer, intent (in) :: is, ie, ks, ke + + logical, intent (in) :: hydrostatic, last_step, consv_te, do_sat_adj + logical, intent (in) :: use_cond, moist_kappa + + real, intent (in) :: dtm + + real, intent (in), dimension (is:ie) :: hs, gsize + + real, intent (in), dimension (is:ie, ks:ke) :: qnl, qni + + real, intent (inout), dimension (is:ie, ks:ke) :: delp, delz, pt, te + real, intent (inout), dimension (is:ie, ks:ke) :: qv, ql, qr, qi, qs, qg, qa, zet + + real, intent (inout), dimension (is:, ks:) :: q_con, cappa + + real, intent (inout), dimension (is:ie) :: mppcw, mppew, mppe1, mpper, mppdi + real, intent (inout), dimension (is:ie) :: mppd1, mppds, mppdg, mppsi, mpps1 + real, intent (inout), dimension (is:ie) :: mppss, mppsg, mppfw, mppfr, mppar + real, intent (inout), dimension (is:ie) :: mppas, mppag, mpprs, mpprg, mppxr + real, intent (inout), dimension (is:ie) :: mppxs, mppxg, mppmi, mppms, mppmg + real, intent (inout), dimension (is:ie) :: mppm1, mppm2, mppm3 + + real, intent (out), dimension (is:ie, ks:ke) :: adj_vmr + + real (kind = r8), intent (out), dimension (is:ie) :: dte + + ! ----------------------------------------------------------------------- + ! local variables + ! ----------------------------------------------------------------------- + + real, dimension (is:ie, ks:ke) :: ua, va, wa, prefluxw, prefluxr, prefluxi, prefluxs, prefluxg + + real, dimension (is:ie) :: water, rain, ice, snow, graupel + + ! ----------------------------------------------------------------------- + ! initialization + ! ----------------------------------------------------------------------- + + ua = 0.0 + va = 0.0 + wa = 0.0 + + water = 0.0 + rain = 0.0 + ice = 0.0 + snow = 0.0 + graupel = 0.0 + + prefluxw = 0.0 + prefluxr = 0.0 + prefluxi = 0.0 + prefluxs = 0.0 + prefluxg = 0.0 + + ! ----------------------------------------------------------------------- + ! major cloud microphysics driver + ! ----------------------------------------------------------------------- + + call mpdrv (hydrostatic, ua, va, wa, delp, pt, qv, ql, qr, qi, qs, qg, qa, & + zet, qnl, qni, delz, is, ie, ks, ke, dtm, water, rain, ice, snow, graupel, & + gsize, hs, q_con, cappa, consv_te, adj_vmr, te, dte, prefluxw, prefluxr, & + prefluxi, prefluxs, prefluxg, mppcw, mppew, mppe1, mpper, mppdi, mppd1, & + mppds, mppdg, mppsi, mpps1, mppss, mppsg, mppfw, mppfr, mppmi, mppms, & + mppmg, mppm1, mppm2, mppm3, mppar, mppas, mppag, mpprs, mpprg, mppxr, & + mppxs, mppxg, last_step, .true., do_sat_adj, .false., & + use_cond, moist_kappa) + +end subroutine fast_sat_adj +#endif + +! ======================================================================= +! rain freezing to form graupel, simple version +! ======================================================================= + +subroutine pgfr_simp (ks, ke, dts, qa, qv, ql, qr, qi, qs, qg, dp, tz, cvm, te8, & + lcpk, icpk, tcpk, tcp3, mppfr, convt) + + implicit none + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + integer, intent (in) :: ks, ke + + real, intent (in) :: dts, convt + + real, intent (in), dimension (ks:ke) :: dp + + real (kind = r8), intent (in), dimension (ks:ke) :: te8 + + real, intent (inout), dimension (ks:ke) :: qa, qv, ql, qr, qi, qs, qg + real, intent (inout), dimension (ks:ke) :: lcpk, icpk, tcpk, tcp3 + + real (kind = r8), intent (inout), dimension (ks:ke) :: cvm, tz + + real, intent (inout) :: mppfr + + ! ----------------------------------------------------------------------- + ! local variables + ! ----------------------------------------------------------------------- + + integer :: k + + real :: tc, sink, fac_r2g + + fac_r2g = 1. - exp (- dts / tau_r2g) + + do k = ks, ke + + tc = tz (k) - tice + + if (tc .lt. 0. .and. qr (k) .gt. qpmin) then + + sink = (- tc * 0.025) ** 2 * qr (k) + sink = min (qr (k), sink, - fac_r2g * tc / icpk (k)) + mppfr = mppfr + sink * dp (k) * convt + + call update_qt (qa (k), qv (k), ql (k), qr (k), qi (k), qs (k), qg (k), & + 0., 0., - sink, 0., 0., sink, te8 (k), cvm (k), tz (k), & + lcpk (k), icpk (k), tcpk (k), tcp3 (k)) + + endif + + enddo + +end subroutine pgfr_simp + +! ======================================================================= +! snow melting to form cloud water and rain, simple version +! ======================================================================= + +subroutine psmlt_simp (ks, ke, dts, qa, qv, ql, qr, qi, qs, qg, dp, tz, cvm, te8, & + lcpk, icpk, tcpk, tcp3, mppms, convt) + + implicit none + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + integer, intent (in) :: ks, ke + + real, intent (in) :: dts, convt + + real (kind = r8), intent (in), dimension (ks:ke) :: te8 + + real, intent (in), dimension (ks:ke) :: dp + + real, intent (inout), dimension (ks:ke) :: qa, qv, ql, qr, qi, qs, qg + real, intent (inout), dimension (ks:ke) :: lcpk, icpk, tcpk, tcp3 + + real (kind = r8), intent (inout), dimension (ks:ke) :: cvm, tz + + real, intent (inout) :: mppms + + ! ----------------------------------------------------------------------- + ! local variables + ! ----------------------------------------------------------------------- + + integer :: k + + real :: tc, tmp, sink, fac_smlt + + fac_smlt = 1. - exp (- dts / tau_smlt) + + do k = ks, ke + + tc = tz (k) - tice + + if (tc .ge. 0. .and. qs (k) .gt. qpmin) then + + sink = (tc * 0.1) ** 2 * qs (k) + sink = min (qs (k), sink, fac_smlt * tc / icpk (k)) + tmp = min (sink, dim (qs_mlt, ql (k))) + mppms = mppms + sink * dp (k) * convt + + call update_qt (qa (k), qv (k), ql (k), qr (k), qi (k), qs (k), qg (k), & + 0., tmp, sink - tmp, 0., - sink, 0., te8 (k), cvm (k), tz (k), & + lcpk (k), icpk (k), tcpk (k), tcp3 (k)) + + endif + + enddo + +end subroutine psmlt_simp + +! ======================================================================= +! cloud water to rain autoconversion, simple version +! ======================================================================= + +subroutine praut_simp (ks, ke, dts, dp, tz, qa, qv, ql, qr, qi, qs, qg, mppar, convt) + + implicit none + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + integer, intent (in) :: ks, ke + + real, intent (in) :: dts, convt + + real, intent (in), dimension (ks:ke) :: dp + + real, intent (inout), dimension (ks:ke) :: qa, qv, ql, qr, qi, qs, qg + + real (kind = r8), intent (inout), dimension (ks:ke) :: tz + + real, intent (inout) :: mppar + + ! ----------------------------------------------------------------------- + ! local variables + ! ----------------------------------------------------------------------- + + integer :: k + + real :: tc, sink, fac_l2r + + fac_l2r = 1. - exp (- dts / tau_l2r) + + do k = ks, ke + + tc = tz (k) - t_wfr + + if (tc .gt. 0 .and. ql (k) .gt. ql0_max) then + + sink = fac_l2r * (ql (k) - ql0_max) + mppar = mppar + sink * dp (k) * convt + + call update_qq (qa (k), qv (k), ql (k), qr (k), qi (k), qs (k), qg (k), & + 0., - sink, sink, 0., 0., 0.) + + endif + + enddo + +end subroutine praut_simp + +! ======================================================================= +! cloud ice to snow autoconversion, simple version +! ======================================================================= + +subroutine psaut_simp (ks, ke, dts, qa, qv, ql, qr, qi, qs, qg, dp, tz, den, mppas, convt) + + implicit none + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + integer, intent (in) :: ks, ke + + real, intent (in) :: dts, convt + + real, intent (in), dimension (ks:ke) :: den, dp + + real, intent (inout), dimension (ks:ke) :: qa, qv, ql, qr, qi, qs, qg + + real (kind = r8), intent (inout), dimension (ks:ke) :: tz + + real, intent (inout) :: mppas + + ! ----------------------------------------------------------------------- + ! local variables + ! ----------------------------------------------------------------------- + + integer :: k + + real :: tc, sink, fac_i2s, qim + + fac_i2s = 1. - exp (- dts / tau_i2s) + + do k = ks, ke + + tc = tz (k) - tice + + qim = qi0_max / den (k) + + if (tc .lt. 0. .and. qi (k) .gt. qim) then + + sink = fac_i2s * (qi (k) - qim) + mppas = mppas + sink * dp (k) * convt + + call update_qq (qa (k), qv (k), ql (k), qr (k), qi (k), qs (k), qg (k), & + 0., 0., 0., - sink, sink, 0.) + + endif + + enddo + +end subroutine psaut_simp + +! ======================================================================= +! cloud radii diagnosis built for gfdl cloud microphysics +! ======================================================================= + +subroutine cld_eff_rad (is, ie, ks, ke, lsm, p, delp, t, qv, qw, qi, qr, qs, qg, qa, & + qcw, qci, qcr, qcs, qcg, rew, rei, rer, res, reg, cld, cloud, & + cnvw, cnvi, cnvc) + + implicit none + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + integer, intent (in) :: is, ie, ks, ke + + real, intent (in), dimension (is:ie) :: lsm + + real, intent (in), dimension (is:ie, ks:ke) :: delp, t, p, cloud + real, intent (in), dimension (is:ie, ks:ke) :: qv, qw, qi, qr, qs, qg, qa + + real, intent (in), dimension (is:ie, ks:ke), optional :: cnvw, cnvi, cnvc + + real, intent (inout), dimension (is:ie, ks:ke) :: qcw, qci, qcr, qcs, qcg + real, intent (inout), dimension (is:ie, ks:ke) :: rew, rei, rer, res, reg + real, intent (inout), dimension (is:ie, ks:ke) :: cld + + ! ----------------------------------------------------------------------- + ! local variables + ! ----------------------------------------------------------------------- + + integer :: i, k, ind + + real, dimension (is:ie, ks:ke) :: qmw, qmr, qmi, qms, qmg + + real :: dpg, rho, ccnw, mask, cor, tc, bw + real :: lambdaw, lambdar, lambdai, lambdas, lambdag, rei_fac + + real :: retab (138) = (/ & + 0.05000, 0.05000, 0.05000, 0.05000, 0.05000, 0.05000, & + 0.05500, 0.06000, 0.07000, 0.08000, 0.09000, 0.10000, & + 0.20000, 0.30000, 0.40000, 0.50000, 0.60000, 0.70000, & + 0.80000, 0.90000, 1.00000, 1.10000, 1.20000, 1.30000, & + 1.40000, 1.50000, 1.60000, 1.80000, 2.00000, 2.20000, & + 2.40000, 2.60000, 2.80000, 3.00000, 3.20000, 3.50000, & + 3.80000, 4.10000, 4.40000, 4.70000, 5.00000, 5.30000, & + 5.60000, 5.92779, 6.26422, 6.61973, 6.99539, 7.39234, & + 7.81177, 8.25496, 8.72323, 9.21800, 9.74075, 10.2930, & + 10.8765, 11.4929, 12.1440, 12.8317, 13.5581, 14.2319, & + 15.0351, 15.8799, 16.7674, 17.6986, 18.6744, 19.6955, & + 20.7623, 21.8757, 23.0364, 24.2452, 25.5034, 26.8125, & + 27.7895, 28.6450, 29.4167, 30.1088, 30.7306, 31.2943, & + 31.8151, 32.3077, 32.7870, 33.2657, 33.7540, 34.2601, & + 34.7892, 35.3442, 35.9255, 36.5316, 37.1602, 37.8078, & + 38.4720, 39.1508, 39.8442, 40.5552, 41.2912, 42.0635, & + 42.8876, 43.7863, 44.7853, 45.9170, 47.2165, 48.7221, & + 50.4710, 52.4980, 54.8315, 57.4898, 60.4785, 63.7898, & + 65.5604, 71.2885, 75.4113, 79.7368, 84.2351, 88.8833, & + 93.6658, 98.5739, 103.603, 108.752, 114.025, 119.424, & + 124.954, 130.630, 136.457, 142.446, 148.608, 154.956, & + 161.503, 168.262, 175.248, 182.473, 189.952, 197.699, & + 205.728, 214.055, 222.694, 231.661, 240.971, 250.639 /) + + qmw = qw + qmi = qi + qmr = qr + qms = qs + qmg = qg + cld = cloud + + ! ----------------------------------------------------------------------- + ! merge convective cloud to total cloud + ! ----------------------------------------------------------------------- + + if (present (cnvw)) then + qmw = qmw + cnvw + endif + if (present (cnvi)) then + qmi = qmi + cnvi + endif + if (present (cnvc)) then + cld = cnvc + (1 - cnvc) * cld + endif + + ! ----------------------------------------------------------------------- + ! combine liquid and solid phases + ! ----------------------------------------------------------------------- + + if (liq_ice_combine) then + do i = is, ie + do k = ks, ke + qmw (i, k) = qmw (i, k) + qmr (i, k) + qmr (i, k) = 0.0 + qmi (i, k) = qmi (i, k) + qms (i, k) + qmg (i, k) + qms (i, k) = 0.0 + qmg (i, k) = 0.0 + enddo + enddo + endif + + ! ----------------------------------------------------------------------- + ! combine snow and graupel + ! ----------------------------------------------------------------------- + + if (snow_grauple_combine) then + do i = is, ie + do k = ks, ke + qms (i, k) = qms (i, k) + qmg (i, k) + qmg (i, k) = 0.0 + enddo + enddo + endif + + + do i = is, ie + + do k = ks, ke + + qmw (i, k) = max (qmw (i, k), qcmin) + qmi (i, k) = max (qmi (i, k), qcmin) + qmr (i, k) = max (qmr (i, k), qcmin) + qms (i, k) = max (qms (i, k), qcmin) + qmg (i, k) = max (qmg (i, k), qcmin) + + cld (i, k) = min (max (cld (i, k), 0.0), 1.0) + + mask = min (max (lsm (i), 0.0), 2.0) + + dpg = abs (delp (i, k)) / grav + rho = p (i, k) / (rdgas * t (i, k) * (1. + zvir * qv (i, k))) + + tc = t (i, k) - tice + + if (rewflag .eq. 1) then + + ! ----------------------------------------------------------------------- + ! cloud water (Martin et al. 1994) + ! ----------------------------------------------------------------------- + + if (prog_ccn) then + ! boucher and lohmann (1995) + ccnw = (1.0 - abs (mask - 1.0)) * & + (10. ** 2.24 * (qa (i, k) * rho * 1.e9) ** 0.257) + & + abs (mask - 1.0) * & + (10. ** 2.06 * (qa (i, k) * rho * 1.e9) ** 0.48) + else + ccnw = ccn_o * abs (mask - 1.0) + ccn_l * (1.0 - abs (mask - 1.0)) + endif + + if (qmw (i, k) .gt. qcmin) then + qcw (i, k) = dpg * qmw (i, k) * 1.0e3 + rew (i, k) = exp (1.0 / 3.0 * log ((3.0 * qmw (i, k) * rho) / & + (4.0 * pi * rhow * ccnw))) * 1.0e4 + rew (i, k) = max (rewmin, min (rewmax, rew (i, k))) + else + qcw (i, k) = 0.0 + rew (i, k) = rewmin + endif + + endif + + if (rewflag .eq. 2) then + + ! ----------------------------------------------------------------------- + ! cloud water (Martin et al. 1994, gfdl revision) + ! ----------------------------------------------------------------------- + + if (prog_ccn) then + ! boucher and lohmann (1995) + ccnw = (1.0 - abs (mask - 1.0)) * & + (10. ** 2.24 * (qa (i, k) * rho * 1.e9) ** 0.257) + & + abs (mask - 1.0) * & + (10. ** 2.06 * (qa (i, k) * rho * 1.e9) ** 0.48) + else + ccnw = 1.077 * ccn_o * abs (mask - 1.0) + 1.143 * ccn_l * (1.0 - abs (mask - 1.0)) + endif + + if (qmw (i, k) .gt. qcmin) then + qcw (i, k) = dpg * qmw (i, k) * 1.0e3 + rew (i, k) = exp (1.0 / 3.0 * log ((3.0 * qmw (i, k) * rho) / & + (4.0 * pi * rhow * ccnw))) * 1.0e4 + rew (i, k) = max (rewmin, min (rewmax, rew (i, k))) + else + qcw (i, k) = 0.0 + rew (i, k) = rewmin + endif + + endif + + if (rewflag .eq. 4) then + + ! ----------------------------------------------------------------------- + ! cloud water derived from PSD + ! ----------------------------------------------------------------------- + + if (qmw (i, k) .gt. qcmin) then + qcw (i, k) = dpg * qmw (i, k) * 1.0e3 + call cal_pc_ed_oe_rr_tv (qmw (i, k), rho, blinw, muw, & + eda = edaw, edb = edbw, ed = rew (i, k)) + rew (i, k) = rewfac * 0.5 * rew (i, k) * 1.0e6 + rew (i, k) = max (rewmin, min (rewmax, rew (i, k))) + else + qcw (i, k) = 0.0 + rew (i, k) = rewmin + endif + + endif + + if (reiflag .eq. 1) then + + ! ----------------------------------------------------------------------- + ! cloud ice (Heymsfield and Mcfarquhar 1996) + ! ----------------------------------------------------------------------- + + if (qmi (i, k) .gt. qcmin) then + qci (i, k) = dpg * qmi (i, k) * 1.0e3 + rei_fac = log (1.0e3 * qmi (i, k) * rho) + if (tc .lt. - 50) then + rei (i, k) = beta / 9.917 * exp (0.109 * rei_fac) * 1.0e3 + elseif (tc .lt. - 40) then + rei (i, k) = beta / 9.337 * exp (0.080 * rei_fac) * 1.0e3 + elseif (tc .lt. - 30) then + rei (i, k) = beta / 9.208 * exp (0.055 * rei_fac) * 1.0e3 + else + rei (i, k) = beta / 9.387 * exp (0.031 * rei_fac) * 1.0e3 + endif + rei (i, k) = max (reimin, min (reimax, rei (i, k))) + else + qci (i, k) = 0.0 + rei (i, k) = reimin + endif + + endif + + if (reiflag .eq. 2) then + + ! ----------------------------------------------------------------------- + ! cloud ice (Donner et al. 1997) + ! ----------------------------------------------------------------------- + + if (qmi (i, k) .gt. qcmin) then + qci (i, k) = dpg * qmi (i, k) * 1.0e3 + if (tc .le. - 55) then + rei (i, k) = 15.41627 + elseif (tc .le. - 50) then + rei (i, k) = 16.60895 + elseif (tc .le. - 45) then + rei (i, k) = 32.89967 + elseif (tc .le. - 40) then + rei (i, k) = 35.29989 + elseif (tc .le. - 35) then + rei (i, k) = 55.65818 + elseif (tc .le. - 30) then + rei (i, k) = 85.19071 + elseif (tc .le. - 25) then + rei (i, k) = 72.35392 + else + rei (i, k) = 92.46298 + endif + rei (i, k) = max (reimin, min (reimax, rei (i, k))) + else + qci (i, k) = 0.0 + rei (i, k) = reimin + endif + + endif + + if (reiflag .eq. 3) then + + ! ----------------------------------------------------------------------- + ! cloud ice (Fu 2007) + ! ----------------------------------------------------------------------- + + if (qmi (i, k) .gt. qcmin) then + qci (i, k) = dpg * qmi (i, k) * 1.0e3 + rei (i, k) = 47.05 + tc * (0.6624 + 0.001741 * tc) + rei (i, k) = max (reimin, min (reimax, rei (i, k))) + else + qci (i, k) = 0.0 + rei (i, k) = reimin + endif + + endif + + if (reiflag .eq. 4) then + + ! ----------------------------------------------------------------------- + ! cloud ice (Kristjansson et al. 2000) + ! ----------------------------------------------------------------------- + + if (qmi (i, k) .gt. qcmin) then + qci (i, k) = dpg * qmi (i, k) * 1.0e3 + ind = min (max (int (t (i, k) - 136.0), 44), 138 - 1) + cor = t (i, k) - int (t (i, k)) + rei (i, k) = retab (ind) * (1. - cor) + retab (ind + 1) * cor + rei (i, k) = max (reimin, min (reimax, rei (i, k))) + else + qci (i, k) = 0.0 + rei (i, k) = reimin + endif + + endif + + if (reiflag .eq. 5) then + + ! ----------------------------------------------------------------------- + ! cloud ice (Wyser 1998) + ! ----------------------------------------------------------------------- + + if (qmi (i, k) .gt. qcmin) then + qci (i, k) = dpg * qmi (i, k) * 1.0e3 + bw = - 2. + 1.e-3 * log10 (rho * qmi (i, k) / 50.e-3) * & + exp (1.5 * log (max (1.e-10, - tc))) + rei (i, k) = 377.4 + bw * (203.3 + bw * (37.91 + 2.3696 * bw)) + rei (i, k) = max (reimin, min (reimax, rei (i, k))) + else + qci (i, k) = 0.0 + rei (i, k) = reimin + endif + + endif + + if (reiflag .eq. 6) then + + ! ----------------------------------------------------------------------- + ! cloud ice (Sun and Rikus 1999, Sun 2001) + ! ----------------------------------------------------------------------- + + if (qmi (i, k) .gt. qcmin) then + qci (i, k) = dpg * qmi (i, k) * 1.0e3 + rei_fac = log (1.0e3 * qmi (i, k) * rho) + rei (i, k) = 45.8966 * exp (0.2214 * rei_fac) + & + 0.7957 * exp (0.2535 * rei_fac) * (tc + 190.0) + rei (i, k) = (1.2351 + 0.0105 * tc) * rei (i, k) + rei (i, k) = max (reimin, min (reimax, rei (i, k))) + else + qci (i, k) = 0.0 + rei (i, k) = reimin + endif + + endif + + if (reiflag .eq. 7) then + + ! ----------------------------------------------------------------------- + ! cloud ice derived from PSD + ! ----------------------------------------------------------------------- + + if (qmi (i, k) .gt. qcmin) then + qci (i, k) = dpg * qmi (i, k) * 1.0e3 + call cal_pc_ed_oe_rr_tv (qmi (i, k), rho, blini, mui, & + eda = edai, edb = edbi, ed = rei (i, k)) + rei (i, k) = reifac * 0.5 * rei (i, k) * 1.0e6 + rei (i, k) = max (reimin, min (reimax, rei (i, k))) + else + qci (i, k) = 0.0 + rei (i, k) = reimin + endif + + endif + + if (rerflag .eq. 1) then + + ! ----------------------------------------------------------------------- + ! rain derived from PSD + ! ----------------------------------------------------------------------- + + if (qmr (i, k) .gt. qcmin) then + qcr (i, k) = dpg * qmr (i, k) * 1.0e3 + call cal_pc_ed_oe_rr_tv (qmr (i, k), rho, blinr, mur, & + eda = edar, edb = edbr, ed = rer (i, k)) + rer (i, k) = 0.5 * rer (i, k) * 1.0e6 + rer (i, k) = max (rermin, min (rermax, rer (i, k))) + else + qcr (i, k) = 0.0 + rer (i, k) = rermin + endif + + endif + + if (resflag .eq. 1) then + + ! ----------------------------------------------------------------------- + ! snow derived from PSD + ! ----------------------------------------------------------------------- + + if (qms (i, k) .gt. qcmin) then + qcs (i, k) = dpg * qms (i, k) * 1.0e3 + call cal_pc_ed_oe_rr_tv (qms (i, k), rho, blins, mus, & + eda = edas, edb = edbs, ed = res (i, k)) + res (i, k) = 0.5 * res (i, k) * 1.0e6 + res (i, k) = max (resmin, min (resmax, res (i, k))) + else + qcs (i, k) = 0.0 + res (i, k) = resmin + endif + + endif + + if (regflag .eq. 1) then + + ! ----------------------------------------------------------------------- + ! graupel derived from PSD + ! ----------------------------------------------------------------------- + + if (qmg (i, k) .gt. qcmin) then + qcg (i, k) = dpg * qmg (i, k) * 1.0e3 + if (do_hail) then + call cal_pc_ed_oe_rr_tv (qmg (i, k), rho, blinh, muh, & + eda = edah, edb = edbh, ed = reg (i, k)) + else + call cal_pc_ed_oe_rr_tv (qmg (i, k), rho, bling, mug, & + eda = edag, edb = edbg, ed = reg (i, k)) + endif + reg (i, k) = 0.5 * reg (i, k) * 1.0e6 + reg (i, k) = max (regmin, min (regmax, reg (i, k))) + else + qcg (i, k) = 0.0 + reg (i, k) = regmin + endif + + endif + + enddo + + enddo + +end subroutine cld_eff_rad + +! ======================================================================= +! radar reflectivity +! ======================================================================= + +subroutine rad_ref (ks, ke, qr, qs, qg, tz, den, denfac, dbz) + + implicit none + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + integer, intent (in) :: ks, ke + + real (kind = r8), intent (in), dimension (ks:ke) :: tz + + real, intent (in), dimension (ks:ke) :: den, denfac, qr, qs, qg + + real, intent (out), dimension (ks:ke) :: dbz + + ! ----------------------------------------------------------------------- + ! local variables + ! ----------------------------------------------------------------------- + + integer :: k + + real, parameter :: alpha = 0.176 / 0.930, mp_const = 200 * exp (1.6 * log (3.6e6)) + ! Ki**2 = 0.176, Kl**2 = 0.930 + + real (kind = r8) :: z_e + real :: qden, fac_r, fac_s, fac_g + + real, dimension (ks:ke) :: vtr, vts, vtg + + ! ----------------------------------------------------------------------- + ! initialization + ! ----------------------------------------------------------------------- + + dbz = - 20. + + ! ----------------------------------------------------------------------- + ! fall speed + ! ----------------------------------------------------------------------- + + if (radr_flag .eq. 3) then + call term_rsg (ks, ke, qr, den, denfac, vr_fac, blinr, mur, tvar, tvbr, vr_min, vr_max, const_vr, vtr) + vtr = vtr / rhor + endif + + if (rads_flag .eq. 3) then + call term_rsg (ks, ke, qs, den, denfac, vs_fac, blins, mus, tvas, tvbs, vs_min, vs_max, const_vs, vts) + vts = vts / rhos + endif + + if (radg_flag .eq. 3) then + if (do_hail) then + call term_rsg (ks, ke, qg, den, denfac, vh_fac, blinh, muh, tvah, tvbh, vh_min, vh_max, const_vg, vtg) + vtg = vtg / rhoh + else + call term_rsg (ks, ke, qg, den, denfac, vg_fac, bling, mug, tvag, tvbg, vg_min, vg_max, const_vg, vtg) + vtg = vtg / rhog + endif + endif + + ! ----------------------------------------------------------------------- + ! radar reflectivity + ! ----------------------------------------------------------------------- + + do k = ks, ke + z_e = 0. + + qden = den (k) * qr (k) + if (qr (k) .gt. qpmin) then + call cal_pc_ed_oe_rr_tv (qr (k), den (k), blinr, mur, rra = rrar, rrb = rrbr, rr = fac_r) + else + fac_r = 0.0 + endif + if (radr_flag .eq. 1 .or. radr_flag .eq. 2) then + z_e = z_e + fac_r * 1.e18 + endif + if (radr_flag .eq. 3) then + z_e = z_e + mp_const * exp (1.6 * log (qden * vtr (k))) + endif + + qden = den (k) * qs (k) + if (qs (k) .gt. qpmin) then + call cal_pc_ed_oe_rr_tv (qs (k), den (k), blins, mus, rra = rras, rrb = rrbs, rr = fac_s) + else + fac_s = 0.0 + endif + if (rads_flag .eq. 1) then + if (tz (k) .lt. tice) then + z_e = z_e + fac_s * 1.e18 * alpha * (rhos / rhoi) ** 2 + else + z_e = z_e + fac_s * 1.e18 * alpha * (rhos / rhoi) ** 2 / alpha + endif + endif + if (rads_flag .eq. 2) then + if (tz (k) .lt. tice) then + z_e = z_e + fac_s * 1.e18 * alpha * (rhos / rhoi) ** 2 + else + z_e = z_e + fac_s * 1.e18 + endif + endif + if (rads_flag .eq. 3) then + z_e = z_e + mp_const * exp (1.6 * log (qden * vts (k))) + endif + + qden = den (k) * qg (k) + if (do_hail) then + if (qg (k) .gt. qpmin) then + call cal_pc_ed_oe_rr_tv (qg (k), den (k), blinh, muh, rra = rrah, rrb = rrbh, rr = fac_g) + else + fac_g = 0.0 + endif + if (radg_flag .eq. 1) then + if (tz (k) .lt. tice) then + z_e = z_e + fac_g * 1.e18 * alpha * (rhoh / rhoi) ** 2 + else + z_e = z_e + fac_g * 1.e18 * alpha * (rhoh / rhoi) ** 2 / alpha + endif + endif + if (radg_flag .eq. 2) then + if (tz (k) .lt. tice) then + z_e = z_e + fac_g * 1.e18 * alpha * (rhoh / rhoi) ** 2 + else + z_e = z_e + (fac_g * 1.e18) ** 0.95 + endif + endif + else + if (qg (k) .gt. qpmin) then + call cal_pc_ed_oe_rr_tv (qg (k), den (k), bling, mug, rra = rrag, rrb = rrbg, rr = fac_g) + else + fac_g = 0.0 + endif + if (radg_flag .eq. 1) then + if (tz (k) .lt. tice) then + z_e = z_e + fac_g * 1.e18 * alpha * (rhog / rhoi) ** 2 + else + z_e = z_e + fac_g * 1.e18 * alpha * (rhog / rhoi) ** 2 / alpha + endif + endif + if (radg_flag .eq. 2) then + if (tz (k) .lt. tice) then + z_e = z_e + fac_g * 1.e18 * alpha * (rhog / rhoi) ** 2 + else + z_e = z_e + (fac_g * 1.e18) ** 0.95 + endif + endif + endif + if (radg_flag .eq. 3) then + z_e = z_e + mp_const * exp (1.6 * log (qden * vtg (k))) + endif + + dbz (k) = 10. * log10 (max (0.01, z_e)) + enddo + +end subroutine rad_ref + +! ======================================================================= +! moist heat capacity, 3 input variables +! ======================================================================= + +function mhc3 (qv, q_liq, q_sol) + + implicit none + + real (kind = r8) :: mhc3 + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + real, intent (in) :: qv, q_liq, q_sol + + ! ----------------------------------------------------------------------- + ! local variables + ! ----------------------------------------------------------------------- + + mhc3 = one_r8 + qv * c1_vap + q_liq * c1_liq + q_sol * c1_ice + +end function mhc3 + +! ======================================================================= +! moist heat capacity, 4 input variables +! ======================================================================= + +function mhc4 (qd, qv, q_liq, q_sol) + + implicit none + + real (kind = r8) :: mhc4 + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + real, intent (in) :: qv, q_liq, q_sol + + real (kind = r8), intent (in) :: qd + + ! ----------------------------------------------------------------------- + ! local variables + ! ----------------------------------------------------------------------- + + mhc4 = qd + qv * c1_vap + q_liq * c1_liq + q_sol * c1_ice + +end function mhc4 + +! ======================================================================= +! moist heat capacity, 6 input variables +! ======================================================================= + +function mhc6 (qv, ql, qr, qi, qs, qg) + + implicit none + + real (kind = r8) :: mhc6 + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + real, intent (in) :: qv, ql, qr, qi, qs, qg + + ! ----------------------------------------------------------------------- + ! local variables + ! ----------------------------------------------------------------------- + + real :: q_liq, q_sol + + q_liq = ql + qr + q_sol = qi + qs + qg + mhc6 = mhc (qv, q_liq, q_sol) + +end function mhc6 + +! ======================================================================= +! moist total energy +! ======================================================================= + +function mte (qv, ql, qr, qi, qs, qg, tk, dp, moist_q) + + implicit none + + real (kind = r8) :: mte + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + logical, intent (in) :: moist_q + + real, intent (in) :: qv, ql, qr, qi, qs, qg, dp + + real (kind = r8), intent (in) :: tk + + ! ----------------------------------------------------------------------- + ! local variables + ! ----------------------------------------------------------------------- + + real :: q_liq, q_sol, q_cond + + real (kind = r8) :: cvm, con_r8 + + q_liq = ql + qr + q_sol = qi + qs + qg + q_cond = q_liq + q_sol + con_r8 = one_r8 - (qv + q_cond) + if (moist_q) then + cvm = mhc (con_r8, qv, q_liq, q_sol) + else + cvm = mhc (qv, q_liq, q_sol) + endif + mte = rgrav * cvm * c_air * tk * dp + +end function mte + +! ======================================================================= +! moist total energy and total water +! ======================================================================= + +subroutine mtetw (ks, ke, qv, ql, qr, qi, qs, qg, tz, ua, va, wa, delp, & + dte, vapor, water, rain, ice, snow, graupel, sen, stress, dts, & + te, tw, te_b, tw_b, moist_q, hydrostatic, te_loss) + + implicit none + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + integer, intent (in) :: ks, ke + + logical, intent (in) :: moist_q, hydrostatic + + real, intent (in) :: vapor, water, rain, ice, snow, graupel, dts, sen, stress + + real, intent (in), dimension (ks:ke) :: qv, ql, qr, qi, qs, qg, ua, va, wa, delp + + real (kind = r8), intent (in) :: dte + + real (kind = r8), intent (in), dimension (ks:ke) :: tz + + real (kind = r8), intent (out) :: te_b, tw_b + + real (kind = r8), intent (out), optional :: te_loss + + real (kind = r8), intent (out), dimension (ks:ke) :: te, tw + + ! ----------------------------------------------------------------------- + ! local variables + ! ----------------------------------------------------------------------- + + integer :: k + + real :: q_cond + + real (kind = r8) :: con_r8 + + real, dimension (ks:ke) :: q_liq, q_sol + + real (kind = r8), dimension (ks:ke) :: cvm + + do k = ks, ke + q_liq (k) = ql (k) + qr (k) + q_sol (k) = qi (k) + qs (k) + qg (k) + q_cond = q_liq (k) + q_sol (k) + con_r8 = one_r8 - (qv (k) + q_cond) + if (moist_q) then + cvm (k) = mhc (con_r8, qv (k), q_liq (k), q_sol (k)) + else + cvm (k) = mhc (qv (k), q_liq (k), q_sol (k)) + endif + te (k) = (cvm (k) * tz (k) + lv00 * qv (k) - li00 * q_sol (k)) * c_air + if (hydrostatic) then + te (k) = te (k) + 0.5 * (ua (k) ** 2 + va (k) ** 2) + else + te (k) = te (k) + 0.5 * (ua (k) ** 2 + va (k) ** 2 + wa (k) ** 2) + endif + te (k) = rgrav * te (k) * delp (k) + tw (k) = rgrav * (qv (k) + q_cond) * delp (k) + enddo + te_b = (dte + (lv00 * c_air * vapor - li00 * c_air * (ice + snow + graupel)) * dts / 86400 + sen * dts + stress * dts) + tw_b = (vapor + water + rain + ice + snow + graupel) * dts / 86400 + + if (present (te_loss)) then + ! total energy change due to sedimentation and its heating + te_loss = dte + endif + +end subroutine mtetw + +! ======================================================================= +! calculate heat capacities and latent heat coefficients +! ======================================================================= + +subroutine cal_mhc_lhc (ks, ke, qv, ql, qr, qi, qs, qg, q_liq, q_sol, & + cvm, te8, tz, lcpk, icpk, tcpk, tcp3) + + implicit none + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + integer, intent (in) :: ks, ke + + real, intent (in), dimension (ks:ke) :: qv, ql, qr, qi, qs, qg + + real (kind = r8), intent (in), dimension (ks:ke) :: tz + + real, intent (out), dimension (ks:ke) :: q_liq, q_sol, lcpk, icpk, tcpk, tcp3 + + real (kind = r8), intent (out), dimension (ks:ke) :: cvm, te8 + + ! ----------------------------------------------------------------------- + ! local variables + ! ----------------------------------------------------------------------- + + integer :: k + + do k = ks, ke + q_liq (k) = ql (k) + qr (k) + q_sol (k) = qi (k) + qs (k) + qg (k) + cvm (k) = mhc (qv (k), q_liq (k), q_sol (k)) + te8 (k) = cvm (k) * tz (k) + lv00 * qv (k) - li00 * q_sol (k) + lcpk (k) = (lv00 + d1_vap * tz (k)) / cvm (k) + icpk (k) = (li00 + d1_ice * tz (k)) / cvm (k) + tcpk (k) = (li20 + (d1_vap + d1_ice) * tz (k)) / cvm (k) + tcp3 (k) = lcpk (k) + icpk (k) * min (1., dim (tice, tz (k)) / (tice - t_wfr)) + enddo + +end subroutine cal_mhc_lhc + +! ======================================================================= +! update hydrometeors +! ======================================================================= + +subroutine update_qq (qa, qv, ql, qr, qi, qs, qg, dqv, dql, dqr, dqi, dqs, dqg) + + implicit none + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + real, intent (in) :: dqv, dql, dqr, dqi, dqs, dqg + + real, intent (inout) :: qa, qv, ql, qr, qi, qs, qg + + real :: qc0 + + ! save previous total condensate + if (.not. do_qa) qc0 = max(ql+qi,qcmin) + + qv = qv + dqv + ql = ql + dql + qr = qr + dqr + qi = qi + dqi + qs = qs + dqs + qg = qg + dqg + + ! total new condensate / old condensate + if (.not. do_qa) qa = max(0.0, min(1.0, qa*(ql+qi)/qc0)) + +end subroutine update_qq + +! ======================================================================= +! update hydrometeors and temperature +! ======================================================================= + +subroutine update_qt (qa, qv, ql, qr, qi, qs, qg, dqv, dql, dqr, dqi, dqs, dqg, te8, & + cvm, tk, lcpk, icpk, tcpk, tcp3) + + implicit none + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + real, intent (in) :: dqv, dql, dqr, dqi, dqs, dqg + + real (kind = r8), intent (in) :: te8 + + real, intent (inout) :: qa, qv, ql, qr, qi, qs, qg + + real, intent (out) :: lcpk, icpk, tcpk, tcp3 + + real (kind = r8), intent (out) :: cvm, tk + + real :: qc0 + + ! save previous total condensate + if (.not. do_qa) qc0 = max(ql+qi,qcmin) + + qv = qv + dqv + ql = ql + dql + qr = qr + dqr + qi = qi + dqi + qs = qs + dqs + qg = qg + dqg + + ! total new condensate / old condensate + if (.not. do_qa) qa = max(0.0, min(1.0, qa*(ql+qi)/qc0)) + + cvm = mhc (qv, ql, qr, qi, qs, qg) + tk = (te8 - lv00 * qv + li00 * (qi + qs + qg)) / cvm + + lcpk = (lv00 + d1_vap * tk) / cvm + icpk = (li00 + d1_ice * tk) / cvm + tcpk = (li20 + (d1_vap + d1_ice) * tk) / cvm + tcp3 = lcpk + icpk * min (1., dim (tice, tk) / (tice - t_wfr)) + +end subroutine update_qt + +! ======================================================================= +! calculation of particle concentration (pc), effective diameter (ed), +! optical extinction (oe), radar reflectivity factor (rr), and +! mass-weighted terminal velocity (tv) +! ======================================================================= + +subroutine cal_pc_ed_oe_rr_tv (q, den, blin, mu, pca, pcb, pc, eda, edb, ed, & + oea, oeb, oe, rra, rrb, rr, tva, tvb, tv) + + implicit none + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + real, intent (in) :: blin, mu + + real, intent (in) :: q, den + + real (kind = r8), intent (in), optional :: pca, pcb, eda, edb, oea, oeb, rra, rrb, tva, tvb + + real, intent (out), optional :: pc, ed, oe, rr, tv + + if (present (pca) .and. present (pcb) .and. present (pc)) then + pc = pca / pcb * exp (mu / (mu + 3) * log (6 * den * q)) + endif + if (present (eda) .and. present (edb) .and. present (ed)) then + ed = eda / edb * exp (1. / (mu + 3) * log (6 * den * q)) + endif + if (present (oea) .and. present (oeb) .and. present (oe)) then + oe = oea / oeb * exp ((mu + 2) / (mu + 3) * log (6 * den * q)) + endif + if (present (rra) .and. present (rrb) .and. present (rr)) then + rr = rra / rrb * exp ((mu + 6) / (mu + 3) * log (6 * den * q)) + endif + if (present (tva) .and. present (tvb) .and. present (tv)) then + tv = tva / tvb * exp (blin / (mu + 3) * log (6 * den * q)) + endif + +end subroutine cal_pc_ed_oe_rr_tv + +! ======================================================================= +! prepare saturation water vapor pressure tables +! ======================================================================= + +subroutine qs_init + + implicit none + + integer :: i + + if (.not. tables_are_initialized) then + + if (.not. allocated (table0)) allocate (table0 (es_table_length)) + if (.not. allocated (table1)) allocate (table1 (es_table_length)) + if (.not. allocated (table2)) allocate (table2 (es_table_length)) + if (.not. allocated (table3)) allocate (table3 (es_table_length)) + if (.not. allocated (table4)) allocate (table4 (es_table_length)) + + if (.not. allocated (des0)) allocate (des0 (es_table_length)) + if (.not. allocated (des1)) allocate (des1 (es_table_length)) + if (.not. allocated (des2)) allocate (des2 (es_table_length)) + if (.not. allocated (des3)) allocate (des3 (es_table_length)) + if (.not. allocated (des4)) allocate (des4 (es_table_length)) + + call qs_table0 (es_table_length) + call qs_table1 (es_table_length) + call qs_table2 (es_table_length) + call qs_table3 (es_table_length) + call qs_table4 (es_table_length) + + do i = 1, es_table_length - 1 + des0 (i) = max (0., table0 (i + 1) - table0 (i)) + des1 (i) = max (0., table1 (i + 1) - table1 (i)) + des2 (i) = max (0., table2 (i + 1) - table2 (i)) + des3 (i) = max (0., table3 (i + 1) - table3 (i)) + des4 (i) = max (0., table4 (i + 1) - table4 (i)) + enddo + des0 (es_table_length) = des0 (es_table_length - 1) + des1 (es_table_length) = des1 (es_table_length - 1) + des2 (es_table_length) = des2 (es_table_length - 1) + des3 (es_table_length) = des3 (es_table_length - 1) + des4 (es_table_length) = des4 (es_table_length - 1) + + tables_are_initialized = .true. + + endif + +end subroutine qs_init + +! ======================================================================= +! saturation water vapor pressure table, core function +! ======================================================================= + +subroutine qs_table_core (n, n_blend, do_smith_table, table) + + implicit none + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + integer, intent (in) :: n, n_blend + + logical, intent (in) :: do_smith_table + + real, intent (out), dimension (n) :: table + + ! ----------------------------------------------------------------------- + ! local variables + ! ----------------------------------------------------------------------- + + integer :: i + integer, parameter :: n_min = 1600 + + real :: ifrac + real (kind = r8) :: tmin, tem, esh + real (kind = r8) :: wice, wh2o, fac0, fac1, fac2 + real (kind = r8) :: esbasw, tbasw, esbasi, a, b, c, d, e + real (kind = r8) :: esupc (n_blend) + + esbasw = 1013246.0 + tbasw = tice + 100. + esbasi = 6107.1 + tmin = tice - n_min * delt + + ! ----------------------------------------------------------------------- + ! compute es over ice between - (n_min * delt) deg C and 0 deg C + ! ----------------------------------------------------------------------- + + if (do_smith_table) then + do i = 1, n_min + tem = tmin + delt * real (i - 1) + a = - 9.09718 * (tice / tem - 1.) + b = - 3.56654 * log10 (tice / tem) + c = 0.876793 * (1. - tem / tice) + e = log10 (esbasi) + table (i) = 0.1 * exp ((a + b + c + e) * log (10.)) + enddo + else + do i = 1, n_min + tem = tmin + delt * real (i - 1) + fac0 = (tem - tice) / (tem * tice) + fac1 = fac0 * li2 + fac2 = (d2_ice * log (tem / tice) + fac1) / rvgas + table (i) = e00 * exp (fac2) + enddo + endif + + ! ----------------------------------------------------------------------- + ! compute es over water between - (n_blend * delt) deg C and [ (n - n_min - 1) * delt] deg C + ! ----------------------------------------------------------------------- + + if (do_smith_table) then + do i = 1, n - n_min + n_blend + tem = tice + delt * (real (i - 1) - n_blend) + a = - 7.90298 * (tbasw / tem - 1.) + b = 5.02808 * log10 (tbasw / tem) + c = - 1.3816e-7 * (exp ((1. - tem / tbasw) * 11.344 * log (10.)) - 1.) + d = 8.1328e-3 * (exp ((tbasw / tem - 1.) * (- 3.49149) * log (10.)) - 1.) + e = log10 (esbasw) + esh = 0.1 * exp ((a + b + c + d + e) * log (10.)) + if (i .le. n_blend) then + esupc (i) = esh + else + table (i + n_min - n_blend) = esh + endif + enddo + else + do i = 1, n - n_min + n_blend + tem = tice + delt * (real (i - 1) - n_blend) + fac0 = (tem - tice) / (tem * tice) + fac1 = fac0 * lv0 + fac2 = (dc_vap * log (tem / tice) + fac1) / rvgas + esh = e00 * exp (fac2) + if (i .le. n_blend) then + esupc (i) = esh + else + table (i + n_min - n_blend) = esh + endif + enddo + endif + + ! ----------------------------------------------------------------------- + ! derive blended es over ice and supercooled water between - (n_blend * delt) deg C and 0 deg C + ! ----------------------------------------------------------------------- + + do i = 1, n_blend + tem = tice + delt * (real (i - 1) - n_blend) + ! WMP impose CALIPSO ice polynomial for mixed phase + ifrac = ice_fraction(real(tem),0.0,0.0) + wice = ifrac + wh2o = 1.0 - wice + table (i + n_min - n_blend) = wice * table (i + n_min - n_blend) + wh2o * esupc (i) + enddo + +end subroutine qs_table_core + +! ======================================================================= +! saturation water vapor pressure table 0, water only +! useful for idealized experiments +! it can also be used in warm rain microphyscis only +! ======================================================================= + +subroutine qs_table0 (n) + + implicit none + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + integer, intent (in) :: n + + ! ----------------------------------------------------------------------- + ! local variables + ! ----------------------------------------------------------------------- + + integer :: i + + real (kind = r8) :: tem, fac0, fac1, fac2 + + ! ----------------------------------------------------------------------- + ! compute es over water only + ! ----------------------------------------------------------------------- + + do i = 1, n + tem = es_table_tmin + delt * real (i - 1) + fac0 = (tem - tice) / (tem * tice) + fac1 = fac0 * lv0 + fac2 = (dc_vap * log (tem / tice) + fac1) / rvgas + table0 (i) = e00 * exp (fac2) + enddo + +end subroutine qs_table0 + +! ======================================================================= +! saturation water vapor pressure table 1, water and ice +! blended between -20 deg C and 0 deg C +! the most realistic saturation water vapor pressure for the full temperature range +! ======================================================================= + +subroutine qs_table1 (n) + + implicit none + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + integer, intent (in) :: n + + call qs_table_core (n, 200, .false., table1) + +end subroutine qs_table1 + +! ======================================================================= +! saturation water vapor pressure table 2, water and ice +! same as table 1, but the blending is replaced with smoothing around 0 deg C +! it is not designed for mixed-phase cloud microphysics +! used for ice microphysics (< 0 deg C) or warm rain microphysics (> 0 deg C) +! ======================================================================= + +subroutine qs_table2 (n) + + implicit none + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + integer, intent (in) :: n + + call qs_table_core (n, 0, .false., table2) + +end subroutine qs_table2 + +! ======================================================================= +! saturation water vapor pressure table 3, water and ice +! blended between -20 deg C and 0 deg C +! the same as table 1, but from smithsonian meteorological tables page 350 +! ======================================================================= + +subroutine qs_table3 (n) + + implicit none + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + integer, intent (in) :: n + + call qs_table_core (n, 200, .true., table3) + +end subroutine qs_table3 + +! ======================================================================= +! saturation water vapor pressure table 4, water and ice +! same as table 3, but the blending is replaced with smoothing around 0 deg C +! the same as table 2, but from smithsonian meteorological tables page 350 +! ======================================================================= + +subroutine qs_table4 (n) + + implicit none + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + integer, intent (in) :: n + + call qs_table_core (n, 0, .true., table4) + +end subroutine qs_table4 + +! ======================================================================= +! compute the saturated water pressure, core function +! ======================================================================= + +function es_core (tk, table, des) + + implicit none + + real :: es_core + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + real, intent (in) :: tk + + real, intent (in), dimension (es_table_length) :: table, des + + ! ----------------------------------------------------------------------- + ! local variables + ! ----------------------------------------------------------------------- + + integer :: it + real :: ap1 + + ap1 = rdelt * dim (tk, es_table_tmin) + 1. + ap1 = min (real(es_table_length), ap1) + it = ap1 + es_core = table (it) + (ap1 - it) * des (it) + +end function es_core + +! ======================================================================= +! compute the saturated specific humidity, core function +! ======================================================================= + +function qs_core (tk, den, dqdt, table, des) + + implicit none + + real :: qs_core + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + real, intent (in) :: tk, den + + real, intent (in), dimension (es_table_length) :: table, des + + real, intent (out) :: dqdt + + ! ----------------------------------------------------------------------- + ! local variables + ! ----------------------------------------------------------------------- + + integer :: it + real :: ap1 + + ap1 = rdelt * dim (tk, es_table_tmin) + 1. + ap1 = min (real(es_table_length), ap1) + qs_core = es_core (tk, table, des) / (rvgas * tk * den) + it = ap1 - 0.5 + dqdt = rdelt * (des (it) + (ap1 - it) * (des (it + 1) - des (it))) / (rvgas * tk * den) + +end function qs_core + +! ======================================================================= +! compute the saturated water pressure based on table 0, water only +! useful for idealized experiments +! it can also be used in warm rain microphyscis only +! ======================================================================= + +function wes_t (tk) + + implicit none + + real :: wes_t + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + real, intent (in) :: tk + + wes_t = es_core (tk, table0, des0) + +end function wes_t + +! ======================================================================= +! compute the saturated water pressure based on table 1, water and ice +! the most realistic saturation water vapor pressure for the full temperature range +! ======================================================================= + +function mes_t (tk) + + implicit none + + real :: mes_t + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + real, intent (in) :: tk + + mes_t = es_core (tk, table1, des1) + +end function mes_t + +! ======================================================================= +! compute the saturated water pressure based on table 2, water and ice +! it is not designed for mixed-phase cloud microphysics +! used for ice microphysics (< 0 deg C) or warm rain microphysics (> 0 deg C) +! ======================================================================= + +function ies_t (tk) + + implicit none + + real :: ies_t + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + real, intent (in) :: tk + + ies_t = es_core (tk, table2, des2) + +end function ies_t + +! ======================================================================= +! compute the saturated specific humidity based on table 0, water only +! useful for idealized experiments +! it can also be used in warm rain microphyscis only +! ======================================================================= + +function wqs_trho (tk, den, dqdt) + + implicit none + + real :: wqs_trho + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + real, intent (in) :: tk, den + + real, intent (out) :: dqdt + + wqs_trho = qs_core (tk, den, dqdt, table0, des0) + +end function wqs_trho + +! ======================================================================= +! compute the saturated specific humidity based on table 1, water and ice +! the most realistic saturation water vapor pressure for the full temperature range +! ======================================================================= + +function mqs_trho (tk, den, dqdt) + + implicit none + + real :: mqs_trho + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + real, intent (in) :: tk, den + + real, intent (out) :: dqdt + + mqs_trho = qs_core (tk, den, dqdt, table1, des1) + +end function mqs_trho + +! ======================================================================= +! compute the saturated specific humidity based on table 2, water and ice +! it is not designed for mixed-phase cloud microphysics +! used for ice microphysics (< 0 deg C) or warm rain microphysics (> 0 deg C) +! ======================================================================= + +function iqs_trho (tk, den, dqdt) + + implicit none + + real :: iqs_trho + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + real, intent (in) :: tk, den + + real, intent (out) :: dqdt + + iqs_trho = qs_core (tk, den, dqdt, table2, des2) + +end function iqs_trho + +! ======================================================================= +! compute the saturated specific humidity based on table 0, water only +! useful for idealized experiments +! it can also be used in warm rain microphyscis only +! ======================================================================= + +function wqs_ptqv (tk, pa, qv, dqdt) + + implicit none + + real :: wqs_ptqv + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + real, intent (in) :: tk, pa, qv + + real, intent (out) :: dqdt + + ! ----------------------------------------------------------------------- + ! local variables + ! ----------------------------------------------------------------------- + + real :: den + + den = pa / (rdgas * tk * (1. + zvir * qv)) + + wqs_ptqv = wqs (tk, den, dqdt) + +end function wqs_ptqv + +! ======================================================================= +! compute the saturated specific humidity based on table 1, water and ice +! the most realistic saturation water vapor pressure for the full temperature range +! ======================================================================= + +function mqs_ptqv (tk, pa, qv, dqdt) + + implicit none + + real :: mqs_ptqv + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + real, intent (in) :: tk, pa, qv + + real, intent (out) :: dqdt + + ! ----------------------------------------------------------------------- + ! local variables + ! ----------------------------------------------------------------------- + + real :: den + + den = pa / (rdgas * tk * (1. + zvir * qv)) + + mqs_ptqv = mqs (tk, den, dqdt) + +end function mqs_ptqv + +! ======================================================================= +! compute the saturated specific humidity based on table 2, water and ice +! it is not designed for mixed-phase cloud microphysics +! used for ice microphysics (< 0 deg C) or warm rain microphysics (> 0 deg C) +! ======================================================================= + +function iqs_ptqv (tk, pa, qv, dqdt) + + implicit none + + real :: iqs_ptqv + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + real, intent (in) :: tk, pa, qv + + real, intent (out) :: dqdt + + ! ----------------------------------------------------------------------- + ! local variables + ! ----------------------------------------------------------------------- + + real :: den + + den = pa / (rdgas * tk * (1. + zvir * qv)) + + iqs_ptqv = iqs (tk, den, dqdt) + +end function iqs_ptqv + +! ======================================================================= +! compute the saturated specific humidity based on table 1, water and ice +! the most realistic saturation water vapor pressure for the full temperature range +! it is the 3d version of "mqs" +! ======================================================================= + +subroutine mqs3d (im, km, ks, tk, pa, qv, qs, dqdt) + + implicit none + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + integer, intent (in) :: im, km, ks + + real, intent (in), dimension (im, ks:km) :: tk, pa, qv + + real, intent (out), dimension (im, ks:km) :: qs + + real, intent (out), dimension (im, ks:km), optional :: dqdt + + ! ----------------------------------------------------------------------- + ! local variables + ! ----------------------------------------------------------------------- + + integer :: i, k + + real :: dqdt0 + + if (present (dqdt)) then + do k = ks, km + do i = 1, im + qs (i, k) = mqs (tk (i, k), pa (i, k), qv (i, k), dqdt (i, k)) + enddo + enddo + else + do k = ks, km + do i = 1, im + qs (i, k) = mqs (tk (i, k), pa (i, k), qv (i, k), dqdt0) + enddo + enddo + endif + +end subroutine mqs3d + +! ======================================================================= +! compute wet buld temperature, core function +! Knox et al. (2017) +! ======================================================================= + +function wet_bulb_core (qv, tk, den, lcp) + + implicit none + + real :: wet_bulb_core + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + real, intent (in) :: qv, tk, den, lcp + + ! ----------------------------------------------------------------------- + ! local variables + ! ----------------------------------------------------------------------- + + logical :: do_adjust = .false. + + real :: factor = 1. / 3. + real :: qsat, tp, dqdt + + wet_bulb_core = tk + qsat = wqs (wet_bulb_core, den, dqdt) + tp = factor * (qsat - qv) / (1. + lcp * dqdt) * lcp + wet_bulb_core = wet_bulb_core - tp + + if (do_adjust .and. tp .gt. 0.0) then + qsat = wqs (wet_bulb_core, den, dqdt) + tp = (qsat - qv) / (1. + lcp * dqdt) * lcp + wet_bulb_core = wet_bulb_core - tp + endif + +end function wet_bulb_core + +! ======================================================================= +! compute wet buld temperature, dry air case +! ======================================================================= + +function wet_bulb_dry (qv, tk, den) + + implicit none + + real :: wet_bulb_dry + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + real, intent (in) :: qv, tk, den + + ! ----------------------------------------------------------------------- + ! local variables + ! ----------------------------------------------------------------------- + + real :: lcp + + lcp = hlv / cp_air + + wet_bulb_dry = wet_bulb_core (qv, tk, den, lcp) + +end function wet_bulb_dry + +! ======================================================================= +! compute wet buld temperature, moist air case +! ======================================================================= + +function wet_bulb_moist (qv, ql, qi, qr, qs, qg, tk, den) + + implicit none + + real :: wet_bulb_moist + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + real, intent (in) :: qv, ql, qi, qr, qs, qg, tk, den + + ! ----------------------------------------------------------------------- + ! local variables + ! ----------------------------------------------------------------------- + + real :: lcp, q_liq, q_sol + + real (kind = r8) :: cvm + + q_liq = ql + qr + q_sol = qi + qs + qg + cvm = mhc (qv, q_liq, q_sol) + lcp = (lv00 + d1_vap * tk) / cvm + + wet_bulb_moist = wet_bulb_core (qv, tk, den, lcp) + +end function wet_bulb_moist + +real function new_liq_condensate(tk, qlk, qik) + + real, intent(in) :: tk, qlk, qik + real :: ptc, ifrac + + ifrac = ice_fraction(tk,cnv_fraction, srf_type) + new_liq_condensate = min(max(0.0,(1.0-ifrac)*(qlk+qik) - qlk),qik) + +end function new_liq_condensate + +real function new_ice_condensate(tk, qlk, qik) + + real, intent(in) :: tk, qlk, qik + real :: ptc, ifrac + + ifrac = ice_fraction(tk,cnv_fraction, srf_type) + new_ice_condensate = min(max(0.0,ifrac*(qlk+qik) - qik),qlk) + +end function new_ice_condensate + +end module gfdl_mp_mod diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/module_mp_nssl_2mom.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/module_mp_nssl_2mom.F90 new file mode 100644 index 000000000..409bf4019 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/module_mp_nssl_2mom.F90 @@ -0,0 +1,19959 @@ +!> \file module_mp_nssl_2mom.F90 + +!--------------------------------------------------------------------- +! code snapshot: "Feb 24 2022" at "14:27:57" +!--------------------------------------------------------------------- +!--------------------------------------------------------------------- +! IMPORTANT: Best results are attained using the 5th-order WENO (Weighted Essentially Non-Oscillatory) advection option (4) for scalars: +! moist_adv_opt = 4, +! scalar_adv_opt = 4, (can also use option 3, which is WENO without the positive definite filter) +! The WENO-5 scheme provides a 5th-order (horizontal and vertical) adaptive weighting of components that +! better preserve monotinicity in strong gradients. The standard 5th-order formulation is prone to undershoots +! (negative values) of mass and number concentrations at cloud edges. The WENO scheme helps +! to prevent undershoots and results in less noise at cloud and reflectivity boundaries. This is particularly +! useful for multi-moment schemes to preserve relationships between mass and number concentration. An option is also available +! for WENO-5 advection of momentum, but this can result in excessive damping of poorly-resolved features. For both scalar and momentum +! the steps 1 and 2 of the Runge-Kutta time integration use standare 5th-order advection, and the WENO-5 is applied on the 3rd (final) +! RK step. Option 3 applies the WENO-5, and option 4 adds the positive definite filter (as also used in option 1). +! +! WENO references: Jiang and Shu, 1996, J. Comp. Phys. v. 126, 202-223; Shu 2003, Int. J. Comp. Fluid Dyn. v. 17 107-118; +! +!>\ingroup mod_mp_nssl2m +!! This module provides a 2-moment bulk microphysics scheme described by +!! Mansell, Zeigler, and Bruning (2010, JAS) +!! +!! This module provides a 2-moment bulk microphysics scheme based on a combination of +!! Straka and Mansell (2005, JAM) and Zeigler (1985, JAS) and modified/upgraded in +!! in Mansell, Zeigler, and Bruning (2010, JAS). Two-moment adaptive sedimentation +!! follows Mansell (2010, JAS), using parameter infall = 4. +!! +!! Added info on graupel density and soaking is in Mansell and Ziegler (2013, JAS) +!! +!! Average graupel particle density is predicted, which affects fall speed as well. +!! Hail density prediction is by default disabled in this version, but may be enabled +!! at some point if there is interest. +!! +!! Maintainer: Ted Mansell, National Severe Storms Laboratory +!! +!! Microphysics References: +!! +!! Mansell, E. R., C. L. Ziegler, and E. C. Bruning, 2010: Simulated electrification of a small +!! thunderstorm with two-moment bulk microphysics. J. Atmos. Sci., 67, 171-194, doi:10. 1175/2009JAS2965.1. +!! +!! Mansell, E. R. and C. L. Ziegler, 2013: Aerosol effects on simulated storm electrification and +!! precipitation in a two-moment bulk microphysics model. J. Atmos. Sci., 70 (7), 2032-2050, +!! doi:10.1175/JAS-D-12-0264.1. +!! +!! Ziegler, C. L., 1985: Retrieval of thermal and microphysical variables in observed convective storms. +!! Part I: Model development and preliminary testing. J. Atmos. Sci., 42, 1487-1509. +!! +!! Sedimentation reference: +!! +!! Mansell, E. R., 2010: On sedimentation and advection in multimoment bulk microphysics. +!! J. Atmos. Sci., 67, 3084-3094, doi:10.1175/2010JAS3341.1. +! +! Possible parameters to adjust: +! +! ccn : base cloud condensation nuclei concentration (use namelist.input value "nssl_cccn") +! alphah, alphahl : Size distribution shape parameters for graupel (h) and hail (hl) +! infall : changes sedimentation options to see effects (see below) +! +! lightning model references: +! +! Fierro, A. O., E.R. Mansell, C. Ziegler and D. R. MacGorman 2013: The +! implementation of an explicit charging and discharge lightning scheme +! within the WRF-ARW model: Benchmark simulations of a continental squall line, a +! tropical cyclone and a winter storm. Monthly Weather Review, Volume 141, 2390-2415 +! +! Mansell et al. 2005: Charge structure and lightning sensitivity in a simulated +! multicell thunderstorm. J. Geophys. Res., 110, D12101, doi:10.1029/2004JD005287 +! +! Note: Some parameters below apply to unreleased features. +! +! +!--------------------------------------------------------------------- +! Sept. 2021: +! Fixes: +! Restored previous formulation of snow reflectivity, as it was realized that the last change incorrectly assumed a fixed +! density independent of size. Generally lower snow reflectivity values as a result (no effect on microphysics) +! Other: +! Generic fall speed coeffecients (axx,bxx) to accomodate future frozen drops category (no effect) +! Reordered collection coefficients (dab1lh) to be consistent (no effect) +! Switched to full calculation of rain number loss via collection by graupel (chacr; to be consisted with collection by hail) (minor effects) +!--------------------------------------------------------------------- +! April 2021: +! Fixes: +! Fall speed air density factor limited to air density of 0.05 (for very high model top) to mitigate excessive fall speeds +! Fixed issue of spurious creation of large concentrations of very small droplets and transient large condensation (also increased minimum droplet size) +! Fixed issue of negligible "seed" values of graupel from Bigg freezing at relatively high temperatures (thanks to S. Lasher-Trapp) +! Minor bug fix in effective radius calculation of snow. (thanks to T. Iguchi) +! Updates: +! Enabled regeneration of CCN by droplet evaporation and background restore (default time constant of 3600s) +! Updated the routine that handles single-moment variables on the first time step. This sets a higher threshold for meaningful mixing ratios and sets a more realistic droplet concentration (also activating CCN as needed). +! Enabled radar reflectivity from cloud ice (new formulation) ( idbzci = 1 ) +! Added internal option for ice crystal nucleation by DeMott et al. (2010, PNAS) (inucopt=4) +! Allow greater fraction of hail to melt in one time step +! Reduced minimum number concentration from 1e-4 to 1e-8 (based on CAPS input) +! Added internal namelist for easier access to internal variables for development/testing and easier setup for ensemble microphysics diversity +! (namelist read is disabled by default) +! Increased resolution of lookup table for incomplete gamma functions +! +!--------------------------------------------------------------------- +! Sept. 2019: +! Bug fixes: +! - Effective radius calculation was only done at history times. Now every time step (though should be just before radiation is called) +! - Snow reflectivity: Previous "fix" was incorrect and yields snow dBZ that is too low. Reverted to old version which was correct +! - Incorrectly updated a state value in the reflectivity code. (Could cause small differences if reflectivity is not calculated) +! Updates: +! - Added code hints to use the "axtra2d" array to communicate rates from the microphysics routine into any 3d arrays that are passed in to the driver. +! - Graupel and hail drag coefficients are returned from fall speed subroutine to use in ventilation coeffs. for consistency (minor change) +! - Added (compile) option flag to turn on diagnosis of cloud droplet shape parameter based on number concentration +! - Added (compile) option flag icracr to turn off rain self-collection +! - Added compile options 'depfac' and 'meltfac' to adjust deposition/sublimation and melting (not freezing) rates of graupel/hail by a constant factor (for experimentation). Default value is 1.0 +! - Put limit on snow volume (2 cm) in aggregation rate +!--------------------------------------------------------------------- +! WRF 4.0 update: +! Major: +! Fixed excessive sublimation that could occur in very strong downdrafts (3.9.1.1 update) +! +! Minor: +! icefallopt=3 : New ice crystal fall speed that has faster speeds for small ice particles. Main effect +! is on anvil clouds to help them decay a bit faster. Old behavior can be recovered with icefallopt=1 +! Cosmetic: removed stray single quotes because some preprocessors complain about unclosed quotes even in comments +! +!--------------------------------------------------------------------- +! WRF 3.9.1.1 update: +! +! Added a check on overdepletion of ice by sublimation, which could sometimes result in water supersaturation +! Bug fix: setting of t7 used 'dn' instead of 'dn1' (Thanks to Chunxi Zhang) +! +!--------------------------------------------------------------------- +! WRF 3.9 updates: +! +! 2-moment scheme now creates number concentration tendencies from cumulus scheme mass mixing ratio rates +! Renamed internal gamma function routine from 'gamma' to 'gamma_sp' to avoid name conflicts +! Restored older settings that allow snow aggregation starting at T > -25C +! Adjusted Meyers number of activated nuclei by the local air density to compensate for using data at surface +! Minor updates to rain-ice crystal and hail-rain collection efficiencies +! +! +! Reduced minimum mean snow diameter from 100 microns to 10 microns +! +!--------------------------------------------------------------------- +! WRF 3.8 updates: +! Fixed issue with reflectivity conservation for graupel melting into rain. Rain number concentrations were too low, +! resulting in excessive reflectivity of a couple dBZ +! Changed default value of iusewetgraupel to 1 (turns off diagnostic meltwater on graupel for reflectivity) +! Apply a 70 m/s fall speed limit for sedimentation +! Changed vapor ice nucleation to Meyers-Ferrier method (original scheme) +! New method for Bigg freezing (ibiggopt=2) +! Reduced snow aggregration efficiency and restricted aggregation to higher temperatures (assuming dendrites and mechanical aggregation) +! Increased maximum graupel-droplet collection efficiency when hail is turned off (nssl_2momg) +! Updates for compatibility with WRF-NMM +! Added calculation of hail number concentration in calcnfromq (creates number concentration from mixing ratio +! when starting from an analysis). And fixed error in graupel intercept +! Bug fix in snow fall speeds +! Further fix in snow reflectivity +! Use diameter of maximum mass rather than mean diamter when checking maximum size +! Helped performance in sedimentation with flag "do_accurate_sedimentation" to control recalculation of fall speeds when +! more than one sub-time step is needed (often happens with large time steps and small dz near the ground): +! = .true. : recalculates fall speed after each substep (more accurate) +! = .false. : (default) reuses fall speeds calculated on the first substep (typical for most schemes), theoretically could cause an occasional glitch, but none seen in practice +! Increased maximum mean droplet radius from 40 to 60 microns, which alleviates spurious number concentration increases at low CCN concentration. +! Removed a duplicate factor from hail reflectivity that was causing a loss of about 6 dBZ (since WRF 3.5). +! +!--------------------------------------------------------------------- + + + +!>\defgroup mod_nsslmp NSSL 2-moment microphysics modules +!!\ingroup nsslmp testphrase one +!! Module for NSSL cloud physics +MODULE module_mp_nssl_2mom + IMPLICIT NONE + + public nssl_2mom_driver + public nssl_2mom_init + public nssl_2mom_init_const + public calc_eff_radius + public calcnfromq + private gamma_sp,gamxinf,GAML02, GAML02d300, GAML02d500, fqvs, fqis + private gamma_dp, gamxinfdp, gamma_dpr + private delbk, delabk + private gammadp + + logical, private :: cleardiag = .false. + PRIVATE + +#if ( WRF_CHEM == 1 ) + integer, parameter :: wrfchem_flag = 1 +#else + integer, parameter :: wrfchem_flag = 0 +#endif + + LOGICAL, PRIVATE:: is_aerosol_aware = .false. + + logical, private :: turn_on_cin = .false. + + integer, private :: eqtset = 1 ! Flag for use with cm1 to use alternate equation set (changes latent heating rates) + ! value of > 2 invokes the equivalent version of eqtset=2 that applies updates to both theta and Pi. + double precision, parameter, public :: zscale = 1.0d0 ! 1.000e-10 + double precision, parameter, public :: zscaleinv = 1.0d0/zscale ! 1.000e-10 + + + real, parameter :: warmonly = 0.0 ! testing parameter, set to 1.0 to reduce to warm-rain physics (ice variables stay zero) + + logical, parameter :: lwsm6 = .false. ! act like wsm6 for some single moment interactions + +! some constants from WSM6 + real, parameter :: dimax = 500.e-6 ! limited maximum value for the cloud-ice diamter + real, parameter :: roqimax = 2.08e22*dimax**8 + +! Params for dbz: + integer :: iuseferrier = 1 ! =1: use dry graupel only from Ferrier 1994; = 0: Use Smith (wet graupel) + integer :: idbzci = 1 + integer :: iusewetgraupel = 1 ! =1 to turn on use of QHW for graupel reflectivity (only for ZVDM -- mixedphase) + ! =2 turn on for graupel density less than 300. only + integer :: iusewethail = 0 ! =1 to turn on use of QHW for graupel reflectivity (only for ZVDM -- mixedphase) + integer :: iusewetsnow = 0 ! =1 to turn on diagnosed bright band; =2 'old' snow reflectivity (dry), =3 'old' snow dbz + brightband +! microphysics + + real, private :: rho_qr = 1000., cnor = 8.0e5 ! cnor is set in namelist!! rain params + real, private :: rho_qs = 100., cnos = 3.0e6 ! set in namelist!! snow params + real, private :: rho_qh = 500., cnoh = 4.0e5 ! set in namelist!! graupel params + real, private :: rho_qhl= 900., cnohl = 4.0e4 ! set in namelist!! hail params + + real, private :: hdnmn = 170.0 ! minimum graupel density (for variable density graupel) + real, private :: hldnmn = 500.0 ! minimum hail density (for variable density hail) + + real :: cnohmn = 1.e-2 ! minimum intercept for 2-moment graupel (alphah < 0.5) + real :: cnohlmn = 1.e-2 ! minimum intercept for 2-moment hail (alphahl < 0.5) + +! Autoconversion parameters + + real , private :: qcmincwrn = 2.0e-3 ! qc threshold for autonconversion (LFO; for 10ICE use qminrncw for ircnw != 5) + real , private :: cwdiap = 20.0e-6 ! threshold diameter of cloud drops (Ferrier 1994 autoconversion) + real , private :: cwdisp = 0.15 ! assume droplet dispersion parameter (can be 0.3 for maritime) + real , private :: ccn = 0.6e+09 ! set in namelist!! Central plains CCN value + real , public :: qccn ! ccn "mixing ratio" + real , private :: old_qccn = -1.0 + integer, private :: iauttim = 1 ! 10-ice rain delay flag + real , private :: auttim = 300. ! 10-ice rain delay time + real , private :: qcwmntim = 1.0e-5 ! 10-ice rain delay min qc for time accrual + +#if (NMM_CORE == 1) +! NMM WRF core does not have special boundary conditions for CCN, therefore set invertccn to true + logical, parameter :: invertccn = .true. ! =true for base state of ccn=0, =false for ccn initialized in the base state +#else + logical, parameter :: invertccn = .false. ! =true for base state of ccn=0, =false for ccn initialized in the base state +#endif + logical :: switchccn = .false. + real :: old_cccn = -1.0 + logical :: restoreccn = .true. ! whether or not to nudge CCN back to base state (qccn) (only applies if CCNA is NOT predicted) + real :: ccntimeconst = 3600. ! time constant for CCN restore (either for CCNA or when restoreccn = true) + +! sedimentation flags +! itfall -> 0 = 1st order fallout (other options removed) +! iscfall, infall -> fallout options for charge and number concentration, respectively +! 1 = mass-weighted fall speed; 2 = number-weighted fallspeed. + integer, private :: itfall = 0 + integer, private :: iscfall = 1 + integer, private :: irfall = -1 + logical, private :: do_accurate_sedimentation = .true. ! if true, recalculate fall speeds on sub time steps; (more expensive) + ! if false, reuse fall speeds on multiple steps (can have a noticeable speedup) + ! Mainly is an issue for small dz near the surface. + integer, private :: interval_sedi_vt = 2 ! interval for recalculating Vt in sedimentation subloop (only when do_accurate_sedimentation = .true.) + integer, private :: infall = 4 ! 0 -> uses number-wgt for N; NO correction applied (results in excessive size sorting) + ! 1 -> uses mass-weighted fallspeed for N ALWAYS + ! 2 -> uses number-wgt for N and mass-weighted correction for N (Method II in Mansell, 2010 JAS) + ! 3 -> uses number-wgt for N and Z-weighted correction for N (Method I in Mansell, 2010 JAS) + ! 4 -> Hybrid of 2 and 3: Uses minimum N from each method (z-wgt and m-wgt corrections) (Method I+II in Mansell, 2010 JAS) + ! 5 -> uses number-wgt for N and uses average of N-wgt and q-wgt instead of Max. + real, private :: rainfallfac = 1.0 ! factor to adjust rain fall speed (single moment only) + real, private :: icefallfac = 1.5 ! factor to adjust ice fall speed + real, private :: snowfallfac = 1.25 ! factor to adjust snow fall speed + real, private :: graupelfallfac = 1.0 ! factor to adjust graupel fall speed + real, private :: hailfallfac = 1.0 ! factor to adjust hail fall speed + integer, private :: icefallopt = 3 ! 1= default, 2 = Ferrier ice fall speed; 3 = adjusted Ferrier (slightly high Vt) + integer, private :: icdx = 3 ! (graupel) 0=Ferrier; 1=leave drag coef. cd fixed; 2=vary by density, 4=set by user with cdxmin,cdxmax,etc. + integer, private :: icdxhl = 3 ! (hail) 0=Ferrier; 1=leave drag coef. cd fixed; 2=vary by density, 4=set by user with cdxmin,cdxmax,etc. + real , private :: cdhmin = 0.45, cdhmax = 0.8 ! defaults for graupel (icdx=4) + real , private :: cdhdnmin = 500., cdhdnmax = 800.0 ! defaults for graupel (icdx=4) + real , private :: cdhlmin = 0.45, cdhlmax = 0.6 ! defaults for hail (icdx=4) + real , private :: cdhldnmin = 500., cdhldnmax = 800.0 ! defaults for hail (icdx=4) + real , private :: vtmaxsed = 70. ! Limit on fall speed (m/s, all moments) for sedimentation calculations. Not applied to fall speeds for microphysical rates + + integer :: rssflg = 1 ! Rain size-sorting allowed (1, default), or disallowed (0). If 0, sets N and Z-weighted fall speeds to q-weighted value + integer :: sssflg = 1 ! As above but for snow + integer :: hssflg = 1 ! As above but for graupel + integer :: hlssflg = 1 ! As above but for hail + +! input flags + + integer, private :: ndebug = -1, ncdebug = 0 + integer, private :: ipconc = 5 + integer, private :: inucopt = 0 + integer, private :: ichaff = 0 + integer, parameter :: ilimit = 0 + + real, private :: constccw = -1. + + real, private :: cimn = 1.0e3, cimx = 1.0e6 + + real , private :: rhofrz = 900 ! density of freezing drops + real , private :: ifrzg = 1.0 ! fraction of frozen drops (Bigg freezing) going to graupel. 1=freeze all rain to graupel, 0=freeze all to hail + real , private :: ifiacrg = 1.0 ! fraction of frozen drops (3-component freezing qiacr) going to graupel. 1=freeze all rain to graupel, 0=freeze all to hail + real , private :: ifrzs = 1.0 ! fraction of small frozen drops going to snow. 1=freeze rain to snow, 0=freeze to cloud ice + real , private :: ffrzs = 0.0 ! fraction of other initiated cloud ice going to snow. 1=freeze rain to snow, 0=freeze to cloud ice + real , private :: f2h = 1.0 ! fraction of cloud ice conversion going to graupel (vs. frozen drops). For testing + integer, private :: irwfrz = 1 ! compute total rain that can freeze (checks heat budget) + integer, private :: irimtim = 0 ! future use +! integer, private :: infdo = 1 ! 1 = calculate number-weighted fall speeds + + integer, private :: irimdenopt = 1 ! = 1 for default Macklin; = 2 for experimental Cober and List (1993) + real , private :: rimc1 = 300.0, rimc2 = 0.44 ! rime density coeff. and power (Default Heymsfield and Pflaum, 1985) + real , private :: rimc3 = 170.0 ! minimum rime density + real :: rimc4 = 900.0 ! maximum rime density + real , private :: rimtim = 120.0 ! cut-off rime time (10ICE) + real , private :: eqtot = 1.0e-9 ! threshold for mass budget reporting + real, private :: rimdenvwgt = 0.0 ! weight (0-1) given to number-weighted fall speed when calculating rime density + + integer, private :: ireadmic = 0 + + integer, private :: idiagnosecnu = 0 ! =1 to diagnose cnu based on Chandrakar et al. 2016 data; =2 for Geoffroy et al. (2010, ACP) + integer, private :: iccwflg = 1 ! sets max size of first droplets in parcel to 4 micron radius (in two-moment liquid) + ! (first nucleation is done with a KW sat. adj. step) + integer, private :: issfilt = 0 ! flag to turn on filtering of supersaturation field + integer, private :: icnuclimit = 0 ! limit droplet nucleation based on Konwar et al. (2012) and Chandrakar et al. (2016) + integer, private :: irenuc = 2 ! =1 to always allow renucleation of droplets within the cloud + ! =2 renucleation following Twomey/Cohard&Pinty + ! =7 New renucleation that requires prediction of the number of activated nuclei + ! i.e., not only at cloud base + integer, private :: irenuc3d = 0 ! =1 to include horizontal gradient in renucleation of droplets within the cloud + real :: renucfrac = 0.0 ! = 0 : cnuc = cwccn + ! = 1 : cnuc = actual available CCN + ! otherwise cnuc = cwccn*(1. - renufrac) + ccnc(1:ngscnt)*renucfrac + real :: ssf2kmax = 10. ! max value for ssf**cck in irenuc=4 or 5 + real , private :: cck = 0.6 ! exponent in Twomey expression + real , private :: ciintmx = 1.0e6 ! limit on ice concentration from primary nucleation + + real , private :: cwccn ! , cwmasn,cwmasx + real , private :: ccwmx + + integer, private :: idocw = 1, idorw = 1, idoci = 1, idoir = 1, idoip = 1, idosw = 1 + integer, private :: idogl = 1, idogm = 1, idogh = 1, idofw = 1, idohw = 1, idohl = 1 +! integer, private :: ido(3:14) = / 12*1 / + + +! 0,2, 5.00e-10, 1, 0, 0, 0 : itype1,itype2,cimas0,icfn,ihrn,ibfc,iacr + integer, private :: itype1 = 0, itype2 = 2 ! controls Hallett-Mossop process + integer, private :: icenucopt = 1 ! =1 Meyers/Ferrier primary ice nucleation; =2 Thompson/Cooper, =3 Phillips (Meyers/Demott), =4 DeMott (2010) + real, private :: naer = 1.0e6 ! background large aerosol conc. for DeMott + integer, private :: icfn = 2 ! contact freezing: 0 = off; 1 = hack (ok for single moment); 2 = full Cotton/Meyers version + integer, private :: ihrn = 0 ! Hobbs-Rangno ice multiplication (Ferrier, 1994; use in 10-ice only) + integer, private :: ibfc = 1 ! Flag to use Bigg freezing on droplets (0 = off (uses alternate freezing), 1 = on) + real, private :: cwfrz2snowfrac = 0.0 ! fraction of freezing droplet mass to send to snow + real, private :: cwfrz2snowratio = 5. ! Assumed number of frozen droplets in a cluster + integer, private :: iremoveqwfrz = 1 ! Whether to remove (=1) or not (=0) the newly-frozen cloud droplets (ibfc=1) from the CWC used for charge separation + integer, private :: iacr = 2 ! Flag for drop contact freezing with crytals + ! (0=off; 1=drops > 500micron diameter; 2 = > 300micron) + integer, private :: icracr = 1 ! Flag to turn rain self-collection on/off (=0 to turn off) + integer, private :: ibfr = 2 ! Flag for Bigg freezing conversion of freezing drops to graupel + ! (1=min graupel size is vr1mm; 2=use min size of dfrz, 5= as for 2 and apply dbz conservation) + integer, private :: ibiggopt = 2 ! 1 = old Bigg; 2 = experimental Bigg (only for imurain = 1, however) + integer :: ibiggsmallrain = 0 ! 1 = When rain is too small, freeze none to graupel and send all to snow (experimental) + integer, private :: iacrsize = 5 ! assumed min size of drops freezing by capture + ! 1: > 500 micron diam + ! 2: > 300 micron + ! 3: > 40 micron + ! 4: all sizes + ! 5: > 150 micron (only for imurain = 1) + real , private :: cimas0 = 6.62e-11 ! default mass of Hallett-Mossop crystals + ! 6.62e-11kg results in half the diam. (60 microns) of old default value of 5.0e-10 + real , private :: cimas1 = 6.88e-13 ! default mass of new ice crystals + real , private :: splintermass = 6.88e-13 + real , private :: cfnfac = 0.1 ! Hack factor that goes with icfn=1 + integer, private :: iscni = 4 ! default option for ice crystal aggregation/conversion to snow + real , private :: fscni = 1.0 ! factor for calculating cscni + logical, private :: imeyers5 = .false. ! .false.=off, true=on for Meyers ice nucleation for temp > -5 C + real , private :: dmincw = 15.0e-6 ! minimum droplet diameter for collection for iehw=3 + integer, private :: iehw = 1 ! 0 -> ehw=ehw0; 1 -> old ehw; 2 -> test ehw with Mason table data + integer, private :: iefw = 1 ! 0 -> ehw=ehw0; 1 -> old ehw; 2 -> test ehw with Mason table data + integer, private :: iehlw = 1 ! 0 -> ehlw=ehlw0; 1 -> old ehlw; 2 -> test ehlw with Mason table data + ! For ehw/ehlw = 1, ehw0/ehlw0 act as maximum limit on collection efficiency (defaults are 1.0) + integer, private :: ierw = 1 ! for single-moment rain (LFO/Z) + integer, private :: iehr0c = 0 ! 0 -> no collection for T > 0C; 1 -> turn on collection/shedding for T > 0C + integer, private :: iehlr0c = 0 ! 0 -> no collection for T > 0C; 1 -> turn on collection/shedding for T > 0C + real , private :: ehw0 = 0.9 ! constant or max assumed graupel-droplet collection efficiency + real , private :: erw0 = 1.0 ! constant assumed rain-droplet collection efficiency + real , private :: ehlw0 = 0.9 ! constant or max assumed hail-droplet collection efficiency + real , private :: efw0 = 0.5 ! constant or max assumed graupel-droplet collection efficiency + real :: ehr0 = 1.0 ! constant or max assumed graupel-rain collection efficiency + real :: efr0 = 1.0 ! constant or max assumed graupel-rain collection efficiency + real :: ehlr0 = 1.0 ! constant or max assumed hail-rain collection efficiency + real , private :: exwmindiam = 0.0 ! minimum diameter of droplets for riming. If set > 0, will exclude that fraction of mass/number from accretion (idea from Furtado and Field 2017 JAS but also Fierro and Mansell 2017) + + + real , private :: esilfo0 = 1.0 ! factor for LFO collection efficiency of snow for cloud ice. + real , private :: ehslfo0 = 1.0 ! factor for LFO collection efficiency of hail/graupel for snow. + + integer, private :: ircnw = 5 ! single-moment warm-rain autoconversion option. 5= Ferrier 1994. + real , private :: qminrncw = 2.0e-3 ! qc threshold for rain autoconversion (NA for ircnw=5) + + integer, private :: iqcinit = 2 ! For ZVDxx schemes, flag to choose which way to initialize droplets + ! 1 = Soong-Ogura adjustment + ! 2 = Saturation adjustment to value of ssmxinit + ! 3 = KW adjustment + + real , private :: ssmxinit = 0.4 ! saturation percentage to adjust down to for initial cloud + ! formation (ZVDxx scheme only) + + real , private :: ewfac = 1.0 ! hack factor applied to graupel and hail collection eff. for droplets + real , private :: eii0 = 0.1 ,eii1 = 0.1 ! graupel-crystal coll. eff. parameters: eii0*exp(eii1*min(temcg(mgs),0.0)) + ! set eii1 = 0 to get a constant value of eii0 + real , private :: eii0hl = 0.2 ,eii1hl = 0.0 ! hail-crystal coll. eff. parameters: eii0hl*exp(eii1hl*min(temcg(mgs),0.0)) + ! set eii1hl = 0 to get a constant value of eii0hl + real , private :: eri0 = 0.1 ! rain efficiency to collect ice crystals + real , private :: eri_cimin = 10.e-6 ! minimum ice crystal diameter for collection by rain + real , private :: esi0 = 0.1 ! linear factor in snow-ice collection efficiency + real , private :: ehs0 = 0.1, ehs1 = 0.1 ! graupel-snow coll. eff. parameters: ehs0*exp(ehs1*min(temcg(mgs),0.0)) + ! set ehs1 = 0 to get a constant value of ehs0 + real , private :: ess0 = 0.5, ess1 = 0.05 ! snow aggregation coefficients: ess0*exp(ess1*min(temcg(mgs),0.0)) + ! set ess1 = 0 to get a constant value of ess0 + real , private :: esstem1 = -15. ! lower temperature where snow aggregation turns on + real , private :: esstem2 = -10. ! higher temperature for linear ramp of ess from zero at esstem1 to formula value at esstem2 + real , private :: essrmax = 0.02 ! maximum snow radius (meters) for csacs + real , private :: essfrac1 = 0.5 ! snow mass fraction 1 for aggregation roll-off + real , private :: essfrac2 = 0.75 ! snow mass fraction 2 for aggregation roll-off + integer, private :: iessec0flag = 0 ! flag to activate aggregation roll-off + real , private :: ehsfrac = 1.0 ! multiplier for graupel collection efficiency in wet growth + real , private :: ehimin = 0.0 ! Minimum collection efficiency (graupel - ice crystal) + real , private :: ehimax = 1.0 ! Maximum collection efficiency (graupel - ice crystal) + real , private :: ehsmax = 0.5 ! Maximum collection efficiency (graupel - snow) + real , private :: ecollmx = 0.5 ! Maximum collision efficiency for graup/hail with ice; used only for charging rates + integer, private :: iglcnvi = 1 ! flag for riming conversion from cloud ice to rimed ice/graupel + integer, private :: iglcnvs = 2 ! flag for conversion from snow to rimed ice/graupel + + real , private :: rz ! reflectivity conservation factor for graupel/rain + ! now calculated in icezvd_dr.F from alphah and rnu + ! currently only used for graupel melting to rain + real , private :: rzhl ! reflectivity conservation factor for hail/rain + ! now calculated in icezvd_dr.F from alphahl and rnu + + real , private :: rzs ! reflectivity conservation factor for snow(imusnow=3) with rain (imurain=1) + + real , private :: alphahacx = 0.0 ! assumed minimum shape parameter for zhacw and zhacr + + real , private :: fconv = 1.0 ! factor to boost max graupel depletion by riming conversions in 10ICE + + real , private :: rg0 = 400.0 ! reference graupel density for graupel fall speed + + integer, private :: rcond = 2 ! (Z only) rcond = 2 includes rain condensation in loop with droplet condensation + ! 0 = no condensation on rain; 1 = bulk condensation on rain + integer, parameter, private :: icond = 1 ! (Z only) icond = 1 calculates ice deposition (crystals and snow) BEFORE droplet condensation + ! icond = 2 does not work (intended to calc. dep in loop with droplet cond.) + + real , private :: dfrz = 0.15e-3 ! 0.25e-3 ! minimum diameter of frozen drops from Bigg freezing (used for vfrz) for iacr > 1 + ! and for ciacrf for iacr=4 + real , private :: dmlt = 3.0e-3 ! maximum diameter for rain melting from graupel and hail + real , private :: dshd = 1.0e-3 ! nominal diameter for rain drops shed from graupel/hail + integer, private :: ished2cld = 0 ! 1: Send shed liquid (from wet growth) to cloud droplets + + integer, private :: ihmlt = 2 ! 1=old melting with vmlt; 2=new melting using mean volume diam of graupel/hail + integer, private :: imltshddmr = 2 ! 0 (default)=mean diameter of drops produced during melting+shedding as before (using mean diameter of graupel/hail + ! and max mean diameter of rain) + ! 1=new method where mean diameter of rain during melting is adjusted linearly downward + ! toward 3 mm for large (> sheddiam) graupel and hail, to take into account shedding of + ! smaller drops. sheddiam0 controls the size of graupel/hail above which the assumed + ! mean diameter of rain is set to 3 mm + ! Only valid for ihmlt = 2 for ZVD(H) but also applies to ZVD(H)M + ! 2 = method that sets the resulting rain size ( vshdgs ) according to the mass-weighted diameter of the ice + + real :: mltdiam1 = 9.0e-3, mltdiam2 = 16.0e-3, mltdiam3 = 19.0e-3, mltdiam4 = 200.0e-3, mltdiam05 = 4.5e-3 + + integer, private :: nsplinter = 0 ! number of ice splinters per freezing drop, if negative, then per resulting graupel particle + real, private :: lawson_splinter_fac = 2.5e-11 ! constant in Lawson et al. (2015, JAS) for ice particle production from freezing drops + integer, private :: isnwfrac = 0 ! 0= no snow fragmentation; 1 = turn on snow fragmentation (Schuur, 2000) + +! integer, private :: denscale = 1 ! 1=scale num. conc. and charge by air density for advection, 0=turn off for comparison + + real, private :: qhdpvdn = -1. + real, private :: qhacidn = -1. + + logical, private :: mixedphase = .false. ! .false.=off, true=on to include mixed phase graupel + integer, private :: imixedphase = 0 + logical, private :: qsdenmod = .false. ! true = modify snow density by linear interpolation of snow and rain density + logical, private :: qhdenmod = .false. ! true = modify graupel density by linear interpolation of graupel and rain density + logical, private :: qsvtmod = .false. ! true = modify snow fall speed by linear interpolation of snow and rain vt + real , private :: sheddiam = 8.0e-03 ! minimum diameter of graupel before shedding occurs + real :: sheddiamlg = 10.0e-03 ! diameter of hail to use fwmlarge + real :: sheddiam0 = 20.0e-03 ! diameter of hail at which all water is shed + + integer :: ifwmhopt = 2 ! option for calculating maximum liquid fraction when fwmh and/or fwmhl is set to -1 + ! 1 = maximum based on size of maximum mass diameter + ! 2 = integrate over spectrum for maximum liquid (experimental) + + integer :: ihxw2rain = 0 ! = 0 no transfer + ! = 1 transfer completely melted (99.5%) graupel/hail to rain when fwmh/fwmhl is set to -1. + + real , private :: fwms = 0.5 ! maximum liquid water fraction on snow + real , private :: fwmh = 0.5 ! maximum liquid water fraction on graupel + real , private :: fwmhl = 0.5 ! maximum liquid water fraction on hail + real :: fwmlarge = 0.2 ! maximum liquid water fraction on hail larger than sheddiam + integer :: ifwmfall = 0 ! whether to interpolate toward rain fall speed for graupel and hail + ! when diam < sheddiam and liquid fraction is predicted (0=no, 1=yes) + + logical :: rescale_high_alpha = .false. ! whether to rescale number. conc. when alpha = alphamax (3-moment only) + logical :: rescale_low_alpha = .true. ! whether to rescale Z (graupel/hail) when alpha = alphamin (3-moment only) + logical :: rescale_low_alphar = .true. ! whether to rescale Z for rain when alpha = alphamin (3-moment only) + logical :: rescale_low_alphah = .true. ! whether to rescale Z for rain when alpha = alphamin (3-moment only) + logical :: rescale_low_alphahl = .true. ! whether to rescale Z for rain when alpha = alphamin (3-moment only) + + real, parameter :: alpharmax = 8. ! limited for rwvent calculation + + integer, private :: ihlcnh = 1 ! which graupel -> hail conversion to use + ! 1 = Milbrandt and Yau (2005) using Ziegler 1985 wet growth diameter + ! 2 = Straka and Mansell (2005) conversion using size threshold + real, private :: hlcnhdia = 1.e-3 ! threshold diameter for graupel -> hail conversion for ihlcnh = 1 option. + real, private :: hlcnhqmin = 0.1e-3 ! minimum graupel mass content for graupel -> hail conversion (ihlcnh = 1) + real , private :: hldia1 = 20.0e-3 ! threshold diameter for graupel -> hail conversion for ihlcnh = 2 option. + integer, private :: iusedw = 0 ! flag to use experimental wet growth ice diameter for gr -> hl conversion (=1 turns on) + real , private :: dwmin = 0.0 ! Minimum diameter with iusedw (can stay at 0 or be set to something larger) + real , private :: dwtempmin = 242. ! lowest temperature to allow wet growth conversion to hail + real , private :: dwehwmin = 0. ! Minimum ehw to use to find wet growth diameter (if > ehw0, then wet growth diam becomes smaller) + real , private :: dg0thresh = 0.15 ! graupel wet growth diameter above which we say do not bother + integer :: icvhl2h = 0 ! allow conversion of hail back to graupel when hail density gets close to minimum allowed + + integer, private :: imurain = 1 ! 3 for gamma-volume, 1 for gamma-diameter DSD for rain. + integer, private :: imusnow = 3 ! 3 for gamma-volume, 1 for gamma-diameter DSD for snow (=1 NOT IMPLEMENTED!!). + integer, private :: iturbenhance = 0 ! warm-rain collision enhancement + ! 1 = enhance autoconversion only + ! 2 = add rain collection of cloud + ! 3 = add rain self-collection + integer, private :: isedonly = 0 ! 1= only do sedimentation and skip other microphysics + integer, private :: iferwisventr = 2 ! =1 for Ferrier rwvent, =2 for Wisner rwvent (imurain=1) + integer, private :: izwisventr = 2 ! =1 for old Ziegler rwvent, =2 for Wisner-style rwvent (imurain=3) + integer :: iresetmoments = 0 ! if >0, then set all moments to zero when one of them is zero (3-moment only) + integer, private :: imaxdiaopt = 3 + ! = 1 use mean diameter for breakup + ! = 2 use maximum mass diameter for breakup + ! = 3 use mass-weighted diameter for breakup + integer, private :: dmrauto = 0 + ! = -1 no limiter on crcnw + ! = 0 limit crcnw when qr > 1.2*L (Cohard-Pinty 2002) + ! = 1 DTD version based on MY code + ! = 2 DTD mass-weighted version based on MY code + ! = 3 Milbrandt version (from Cohard and Pinty code + integer :: dmropt = 0 ! extra option for crcnw + integer :: dmhlopt = 1 ! options for graupel -> conversion + integer :: irescalerainopt = 3 ! 0 = default option + ! 1 = qx(mgs,lc) > qxmin(lc) + ! 2 = qx(mgs,lc) > qxmin(lc) .and. wvel(mgs) < 3.0 + ! 3 = temcg(mgs) > 0.0.and. qx(mgs,lc) > qxmin(lc) .and. wvel(mgs) < 3.0 + real :: rescale_wthresh = 3.0 + real :: rescale_tempthresh = 0.0 + real, parameter :: alpharaut = 0.0 ! MY2005 for autoconversion + real :: cxmin = 1.e-8 ! threshold cutoff for number concentration + real :: zxmin = 1.e-28 ! threshold cutoff for reflectivity moment + + integer :: ithompsoncnoh = 0 ! For single moment graupel only + ! 0 = fixed intercept + ! 1 = intercept based on graupel mass + + integer :: ivhmltsoak = 1 ! 0=off, 1=on : flag to simulate soaking (graupel/hail) during melting + ! when liquid fraction is not predicted + logical :: iwetsoak = .true. ! soak and freeze during wet growth or not + integer, private :: ioldlimiter = 0 ! test switch for new(=0) or old(=1) size limiter at the end of GS for 3-moment categories + integer, private :: isnowfall = 2 ! Option for choosing between snow fall speed parameters + ! 1 = original Zrnic et al. (Mansell et al. 2010) + ! 2 = Ferrier 1994 (results in slower fall speeds) + + integer, private :: isnowdens = 1 ! Option for choosing between snow density options + ! 1 = constant of 100 kg m^-3 + ! 2 = Option based on Cox + + integer, private :: ibiggsnow = 3 ! 1 = switch conversion over to snow for small frozen drops from Bigg freezing + ! 2 = switch conversion over to snow for small frozen drops from rain-ice interaction + ! 3 = switch conversion over to snow for small frozen drops from both + real :: biggsnowdiam = -1.0 ! If >0, use for ibiggsnow threshold + + integer, private :: ixtaltype = 1 ! =1 column, =2 disk (similar to Takahashi) + + real, private :: takshedsize1 = 0.15 ! diameter (cm) of drop shed from ice with D > 1.9 cm + real, private :: takshedsize2 = 0.3 ! diameter (cm) of drop shed from ice with D < 1.9 cm and D > 0.8 cm + real, private :: takshedsize3 = 0.45 ! diameter (cm) of drop shed from ice with D < 1.6 cm and D > 0.8 cm + integer, private :: numshedregimes = 3 + + real, private :: evapfac = 1.0 ! Multiplier on rain evaporation rate + real, private :: depfac = 1.0 ! Multiplier on graupel/hail deposition/sublimation rate + real,private,parameter :: meltfac = 1.0 ! Multiplier on graupel/hail melting rate + + integer, private :: ibinhmlr = 0 ! =1 use incomplete gammas to determine melting from larger and smaller sizes of graupel, and appropriate shed drop sizes + ! =2 to test melting by temporary bins + integer, private :: ibinhlmlr = 0 ! =1 use incomplete gammas to determine melting from larger and smaller sizes of hail, and appropriate shed drop sizes + ! =2 to test melting by temporary bins + integer, private :: ibinnum = 2 ! number of bins for melting of smaller ice (for ibinhmlr = 1) + integer, private :: iqhacrmlr = 1 ! turn on/off qhacrmlr + integer, private :: iqhlacrmlr = 1 ! turn on/off qhlacrmlr + real, private :: binmlrmxdia = 40.e-3 ! threshold diameter (graupel/hail) to switch bin-bulk melting to use standard chmlr + real, private :: binmlrzrrfac = 1.0 ! factor for reflectivity change ice that sheds while melting + real, private :: snowmeltdia = 0 ! If nonzero, sets the size of rain drops from melting snow. + real, private :: delta_alphamlr = 0.5 ! offset from alphamax at which melting does not further collapse the shape parameter + + integer :: iqvsopt = 0 ! =0 use old default for tabqvs; =1 use Bolton formulation (Rogers and Yau) + + integer :: imaxsupopt = 4 ! how to treat saturation adjustment in two-moment droplets + ! 1 = add droplets with same mean mass as current droplets + ! 2 = add droplets with minimum radius of 30 microns + ! 3 = only add 1.5*cxmin to number concentration (allow max size to apply) + ! 4 = add droplets with minimum radius of 20 microns + real :: maxsupersat = 1.9 ! maximum supersaturation ratio, above which a saturation adustment is done + real :: maxlowtempss = 1.08 ! Sat. ratio threshold for allowing droplet nucleation at T < tfrh + real :: ssmxuf = 4.0 ! supersaturation at which to start using "ultrafine" CCN (if ccnuf > 0.) + + + integer, parameter :: icespheres = 0 ! turn ice spheres (frozen droplets) on (1) or off (0). NOT COMPLETE IN WRF/ARPS/CM1 CODE! + integer, parameter :: lqmx = 30 + integer, parameter :: lt = 1 + integer, parameter :: lv = 2 + integer, parameter :: lc = 3 + integer, parameter :: lr = 4 + integer, parameter :: li = 5 + integer, private :: lis = 0 + integer, private :: ls = 6 + integer, private :: lh = 7 + integer, private :: lf = 0 + integer, private :: lhl = 0 + + integer, private :: lccn = 9 ! 0 or 9, other indices adjusted accordingly + integer, private :: lccnuf = 0 + integer, private :: lccna = 0 + integer, private :: lcina = 0 + integer, private :: lcin = 0 + integer, private :: lnc = 9 + integer, private :: lnr = 10 + integer, private :: lni = 11 + integer, private :: lnis = 0 + integer, private :: lns = 12 + integer, private :: lnh = 13 + integer, private :: lnf = 0 + integer, private :: lnhl = 0 + integer, private :: lnhf = 0 + integer, private :: lnhlf = 0 + integer, private :: lss = 0 + integer :: lvh = 15 + + integer, private :: lhab = 8 + integer, private :: lg = 7 + +! Particle volume + + integer :: lvi = 0 + integer :: lvs = 0 + integer :: lvgl = 0 + integer :: lvgm = 0 + integer :: lvgh = 0 + integer :: lvf = 0 +! integer :: lvh = 16 + integer :: lvhl = 0 + +! liquid water fraction (not predicted here but tested for) + integer :: lhw = 0 + integer :: lfw = 0 + integer :: lsw = 0 + integer :: lhlw = 0 + integer :: lhwlg = 0 + integer :: lhlwlg = 0 + +! reflectivity (6th moment) ! not predicted here but may be tested against + + integer :: lzr = 0 + integer :: lzi = 0 + integer :: lzs = 0 + integer :: lzgl = 0 + integer :: lzgm = 0 + integer :: lzgh = 0 + integer :: lzf = 0 + integer :: lzh = 0 + integer :: lzhl = 0 + +! Space charge + + integer :: lscw = 0 + integer :: lscr = 0 + integer :: lsci = 0 + integer :: lscis = 0 + integer :: lscs = 0 + integer :: lsch = 0 + integer :: lscf = 0 + integer :: lschl = 0 + integer :: lscwi = 0 + integer :: lscpi = 0 + integer :: lscni = 0 + integer :: lscpli = 0 + integer :: lscnli = 0 + integer :: lschab = 0 + + integer :: lscb = 0 + integer :: lsce = 0 + integer :: lsceq = 0 + +! integer, parameter :: lscmx = 100 + + integer :: lne = 0 ! last varible for transforming + + real :: cnoh0 = 4.0e+5 + real :: hwdn1 = 700.0 + + real :: alphai = 0.0 ! shape parameter for ZIEG ice crystals ! not currently used + real :: alphas = 0.0 ! shape parameter for ZIEG snow ! used only for single moment + real :: alphar = 0.0 ! shape parameter for rain (imurain=1 only) + real, private :: alphah = 0.0 ! set in namelist!! shape parameter for ZIEG graupel + real, private :: alphahl = 1.0 ! set in namelist!! shape parameter for ZIEG hail + + real :: dmuh = 1.0 ! power in exponential part (graupel) + real :: dmuhl = 1.0 ! power in exponential part (hail) + + real, private :: alphamax = 15. + real, private :: alphamin = 0. + real, parameter :: rnumin = -0.8 + real, parameter :: rnumax = 15.0 + + + real :: cnu = 0.0 ! default value of droplet shape parameter. Can be diagnosed by setting idiagnosecnu=1 + real, parameter :: rnu = -0.8, snu = -0.8, cinu = 0.0 +! parameter ( cnu = 0.0, rnu = -0.8, snu = -0.8, cinu = 0.0 ) + + real xnu(lc:lqmx) ! 1st shape parameter (mass) + real xmu(lc:lqmx) ! 2nd shape parameter (mass) + real dnu(lc:lqmx) ! 1st shape parameter (diameter) + real dmu(lc:lqmx) ! 2nd shape parameter (diameter) + + real ax(lc:lqmx) + real bx(lc:lqmx) + real fx(lc:lqmx) + + real da0 (lc:lqmx) ! collection coefficients from Seifert 2005 + real dab0(lc:lqmx,lc:lqmx) ! collection coefficients from Seifert 2005 + real dab1(lc:lqmx,lc:lqmx) ! collection coefficients from Seifert 2005 + real da1 (lc:lqmx) ! collection coefficients from Seifert 2005 + real bb (lc:lqmx) + +! put ipelec here for now.... + integer :: ipelec = 0 + integer :: isaund = 0 + logical :: idoniconly = .false. + integer, private :: elec_on_time = -1 ! time (seconds) to turn on charge separation. + integer, private :: elec_ramp_time = 0 ! time (interval) for linear ramp after elec_on_time + ! (i.e., linear factor on chg sep to smoothly turn on elec) + ! full charging rate is achieved at time = elec_on_time + elec_ramp_time + integer :: jchgs = 3 ! number of points near boundary where charging is turned off (to keep lightning from getting wonky) + integer :: jchgn = 2 + integer :: ichge = 3 + integer :: ichgw = 2 + real :: charging_border = 4000. ! width of no-charging zone from boundary + real, private :: delqnw = -1.0e-10!-1.0e-12 ! + real, private :: delqxw = 1.0e-10! 1.0e-12 ! + real :: tindmn = 233, tindmx = 298.0 ! min and max temperatures where inductive charging is allowed + +! +! gamma function lookup table +! + integer ngm0,ngm1,ngm2 + parameter (ngm0=3001,ngm1=500,ngm2=500) + double precision, parameter :: dgam = 0.01, dgami = 100. + double precision gmoi(0:ngm0) ! ,gmod(0:ngm1,0:ngm2),gmdi(0:ngm1,0:ngm2) + + integer, parameter :: nqiacralpha = 240 !480 ! 240 ! 120 ! 15 + integer, parameter :: nqiacrratio = 100 ! 500 !50 ! 25 +! real, parameter :: maxratiolu = 25. + real, parameter :: maxratiolu = 100. ! 25. + real, parameter :: maxalphalu = 15. + real, parameter :: minalphalu = -0.95 + real, parameter :: dqiacralpha = maxalphalu/Float(nqiacralpha), dqiacrratio = maxratiolu/Float(nqiacrratio) + real, parameter :: dqiacrratioinv = 1./dqiacrratio, dqiacralphainv = 1./dqiacralpha + integer, parameter :: ialpstart = minalphalu*dqiacralphainv + real :: ciacrratio(0:nqiacrratio,ialpstart:nqiacralpha) + real :: qiacrratio(0:nqiacrratio,ialpstart:nqiacralpha) + real :: ziacrratio(0:nqiacrratio,ialpstart:nqiacralpha) + double precision :: gamxinflu(0:nqiacrratio,ialpstart:nqiacralpha,12,2) ! last index for graupel (1) or hail (2) +! real :: ciacrratio(0:nqiacrratio,0:nqiacralpha) +! real :: qiacrratio(0:nqiacrratio,0:nqiacralpha) +! real :: ziacrratio(0:nqiacrratio,0:nqiacralpha) +! double precision :: gamxinflu(0:nqiacrratio,0:nqiacralpha,12,2) ! last index for graupel (1) or hail (2) + + integer, parameter :: ngdnmm = 9 + real :: mmgraupvt(ngdnmm,3) ! Milbrandt and Morrison (2013) fall speed coefficients for graupel/hail + + DATA mmgraupvt(:,1) / 50., 150., 250., 350., 450., 550., 650., 750., 850./ + DATA mmgraupvt(:,2) / 62.923, 94.122, 114.74, 131.21, 145.26, 157.71, 168.98, 179.36, 189.02 / + DATA mmgraupvt(:,3) / 0.67819, 0.63789, 0.62197, 0.61240, 0.60572, 0.60066, 0.59663, 0.59330, 0.59048 / + + integer lsc(lc:lqmx) + integer ln(lc:lqmx) + integer ipc(lc:lqmx) + integer lvol(lc:lqmx) + integer lz(lc:lqmx) + integer lliq(li:lqmx) + integer denscale(lc:lqmx) ! flag for density scaling (mixing ratio conversion) + + integer ido(lc:lqmx) + logical ldovol + + real xdn0(lc:lqmx) + real xdnmx(lc:lqmx), xdnmn(lc:lqmx) + real cdx(lc:lqmx) + real cno(lc:lqmx) + real xvmn(lc:lqmx), xvmx(lc:lqmx) + real qxmin(lc:lqmx) + real qxmin_init(lc:lqmx) + + integer nqsat + parameter (nqsat=1000001) ! (nqsat=20001) + real fqsat,fqsati + parameter (fqsat=0.002,fqsati=1./fqsat) + real tabqvs(nqsat),tabqis(nqsat),dtabqvs(nqsat),dtabqis(nqsat) + +! +! constants +! + real, parameter :: ar = 841.99666 ! rain terminal velocity power law coefficient (LFO) + real, parameter :: br = 0.8 ! rain terminal velocity power law coefficient (LFO) + real, parameter :: aradcw = -0.27544 ! + real, parameter :: bradcw = 0.26249e+06 ! + real, parameter :: cradcw = -1.8896e+10 ! + real, parameter :: dradcw = 4.4626e+14 ! + real, parameter :: bta1 = 0.6 ! beta-1 constant used for ice nucleation by deposition (Ferrier 94, among others) + real, parameter :: cnit = 1.0e-02 ! No for ice nucleation by deposition (Cotton et al. 86) + real, parameter :: dragh = 0.60 ! coefficient used to adjust fall speed for hail versus graupel (Pruppacher and Klett 78) + real, parameter :: dnz00 = 1.225 ! reference/MSL air density + real, parameter :: rho00 = 1.225 ! reference/MSL air density +! cs = 4.83607122 ! snow terminal velocity power law coefficient (LFO) +! ds = 0.25 ! snow terminal velocity power law coefficient (LFO) +! new values for cs and ds + real, parameter :: cs = 12.42 ! snow terminal velocity power law coefficient + real, parameter :: ds = 0.42 ! snow terminal velocity power law coefficient + real :: cp608 = 0.608 ! constant used in conversion of T to Tv + real :: gr = 9.8 + + real, parameter :: pi = 3.141592653589793 + real, parameter :: piinv = 1./pi + real, parameter :: pid4 = pi/4.0 + +! +! max and min mean volumes +! + real xvrmn, xvrmx0 ! min, max rain volumes + real xvsmn, xvsmx ! min, max snow volumes + real xvfmn, xvfmx ! min, max frozen drop volumes + real xvgmn, xvgmx ! min, max graupel volumes + real xvhmn, xvhmn0, xvhmx, xvhmx0 ! min, max hail volumes + real xvhlmn, xvhlmx ! min, max lg hail volumes + + real, parameter :: dhlmn = 0.3e-3, dhlmx = 40.e-3 + real, parameter :: dhmn0 = 0.3e-3 + real, private :: dhmn = dhmn0, dhmx = -1. + + real, parameter :: cwradn = 2.0e-6, xcradmn = cwradn ! minimum radius + real, parameter :: cwradx = 60.e-6, xcradmx = cwradx ! maximum radius + real, parameter :: cwc1 = 6.0/(pi*1000.) + +! parameter( xvcmn=4.188e-18 ) ! mks min volume = 3 micron radius + real, parameter :: xvcmn=0.523599*(2.*cwradn)**3 ! mks min volume = 2.5 micron radius + real, parameter :: xvcmx=0.523599*(2.*xcradmx)**3 ! mks min volume = 2.5 micron radius + real, parameter :: cwmasn = 1000.*xvcmn ! minimum mass, defined by radius of 5.0e-6 + real, parameter :: cwmasx = 1000.*xvcmx ! maximum mass, defined by radius of 50.0e-6 + real, parameter :: cwmasn5 = 1000.*0.523599*(2.*5.0e-6)**3 ! 5.23e-13 + + real, parameter :: xvimn=0.523599*(2.*5.e-6)**3 ! mks min volume = 5 micron radius + real, parameter :: xvimx=0.523599*(2.*1.e-3)**3 ! mks max volume = 1 mm radius (solid sphere approx) + + real, private :: xvdmx = -1.0 ! 3.0e-3 + real :: xvrmx + parameter( xvrmn=0.523599*(80.e-6)**3, xvrmx0=0.523599*(6.e-3)**3 ) !( was 4.1887e-9 ) ! mks + parameter( xvsmn=0.523599*(0.01e-3)**3, xvsmx=0.523599*(10.e-3)**3 ) !( was 4.1887e-9 ) ! mks + parameter( xvfmn=0.523599*(0.1e-3)**3, xvfmx=0.523599*(10.e-3)**3 ) ! mks xvfmx = (pi/6)*(10mm)**3 + parameter( xvgmn=0.523599*(0.1e-3)**3, xvgmx=0.523599*(10.e-3)**3 ) ! mks xvfmx = (pi/6)*(10mm)**3 + parameter( xvhmn0=0.523599*(0.3e-3)**3, xvhmx0=0.523599*(20.e-3)**3 ) ! mks xvfmx = (pi/6)*(20mm)**3 + parameter( xvhlmn=0.523599*(dhlmn)**3, xvhlmx=0.523599*(dhlmx)**3 ) ! mks xvfmx = (pi/6)*(40mm)**3 + +! +! electrical permitivity of air C / (N m**2) - check the units +! + real eperao + parameter (eperao = 8.8592e-12 ) + + real ec,eci ! fundamental unit of charge + parameter (ec = 1.602e-19) + parameter (eci = 1.0/ec) + + real :: scwppmx = 20.0e-12 + real :: scippmx = 20.0e-12 +! +! constants +! + real, parameter :: c1f3 = 1.0/3.0 + + real, parameter :: cai = 21.87455 + real, parameter :: caw = 17.2693882 + real, parameter :: cbi = 7.66 + real, parameter :: cbw = 35.86 + + real, parameter :: cbwbolton = 29.65 ! constants for Bolton formulation + real, parameter :: cawbolton = 17.67 + + real, parameter :: tfrh = 233.15 + real :: tfr = 273.15 + + real :: cp = 1004.0, rd = 287.04 + real :: rw = 461.5 ! gas const. for water vapor + REAL, PRIVATE :: cpl = 4190.0 + REAL, PRIVATE :: cpigb = 2106.0 + real :: cpi + real :: cap + real :: tfrcbw + real :: tfrcbi + real :: rovcp + + real, parameter :: poo = 1.0e+05 + real, parameter :: advisc0 = 1.832e-05 ! reference dynamic viscosity (SMT; see Beard & Pruppacher 71) + real, parameter :: advisc1 = 1.718e-05 ! dynamic viscosity constant used in thermal conductivity calc + real, parameter :: tka0 = 2.43e-02 ! reference thermal conductivity + + ! GHB: Needed for eqtset=2 in cm1 +! REAL, PRIVATE :: cv = cp - rd + real, private, parameter :: cv = 717.0 ! specific heat at constant volume - air + REAL, PRIVATE, parameter :: cvv = 1408.5 + ! GHB + + real, parameter :: bfnu0 = (rnu + 2.0)/(rnu + 1.0) + real :: ventr, ventrn, ventc, c1sw + + + real :: cckm,ccne,ccnefac,cnexp,CCNE0 + + integer, public :: na = 9 + integer :: nxtra = 1 + real gf4p5, gf4ds, gf4br + real gsnow1, gsnow53, gsnow73 + real gfcinu1, gfcinu1p47, gfcinu2p47 + real gfcinu1p22,gfcinu2p22 + real gfcinu1p18,gfcinu2p18 + + real :: cwchtmp0 = 1.0 + real :: cwchltmp0 = 1.0 + + real :: esctot = 1.0e-13 + + integer iexy(lc:lqmx,lc:lqmx) + integer :: ieswi = 1, ieswc = 1, ieswr = 0 + integer :: iehlsw = 1, iehli = 1, iehlc = 1, iehlr = 0 + integer :: iehwsw = 1, iehwi = 1, iehwc = 1, iehwr = 0 + + logical, parameter :: do_satadj_for_wrfchem = .true. + + +! Note to users: Many of these options are for development and not guaranteed to perform well. +! Some may not be functional depending on the version of the code. +! Some may be useful for ensemble physics diversity. Feel free to contact me if you have questions +! in that regard. + NAMELIST /nssl_mp_params/ & + ndebug, ncdebug,& + iusewetgraupel, & + iusewethail, & + iusewetsnow, & + idbzci, & + vtmaxsed, & + itfall,iscfall, & + infall, & + rssflg, & + sssflg, & + hssflg, & + hlssflg, & + irimdenopt,rimdenvwgt, & + rimc1, rimc2, rimc3, rimc4, & + idiagnosecnu, & + icnuclimit, & + irenuc, & + restoreccn, ccntimeconst, cck, & + switchccn, old_cccn, & + ciintmx, & + itype1, itype2, & + icenucopt, & + naer, & + icfn, & + ibfc, iacr, icracr, & + cwfrz2snowfrac, cwfrz2snowratio, & + ibfr, & + ibiggopt, & + ibiggsmallrain, & + ifrzg,ifiacrg, & + ifrzs,ffrzs, & + iacrsize, & + cimas0, cimas1, cfnfac, & + splintermass, & + ewfac, & + eii0, eii1, & + eri0, esi0, & + eri_cimin, & + eii0hl, eii1hl, & + ehs0, ehs1, & + ess0, ess1, & + esstem1,esstem2, & + ircnw, qminrncw,& ! single-moment only + iglcnvi, & + iglcnvs, & + alphahacx, & + fconv, & + eqtot, & + imeyers5, & + iehw, & + ierw, & + iehr0c,iehlr0c, & + alphai, & + alphar, & + alphas, & ! note that alphah and alphahl come through physics namelist + cnu, & + iscni,fscni, & + dfrz, & + dmlt, & + rainfallfac, & + icefallfac, & + snowfallfac, & + graupelfallfac, & + hailfallfac, & + icefallopt, & + icdx,icdxhl, & + cdhmin, cdhmax, & + cdhdnmin, cdhdnmax, & + cdhlmin, cdhlmax, & + cdhldnmin, cdhldnmax, & + ihmlt, & + ehimin, & + ehimax, & + ehsmax, & + ecollmx, & + ehw0, ehlw0, & + ehr0, ehlr0, & + erw0, & + exwmindiam, & + nsplinter, & + lawson_splinter_fac, & + iqcinit, & + ssmxinit, & + xvdmx, & + dhmn, dhmx, & + fwms,fwmh,fwmhl, & + ifwmhopt, & + ihxw2rain, & + fwmlarge, & + ifwmfall, & + iturbenhance, & + qsdenmod,qhdenmod, & + qsvtmod, & + alphamin,alphamax, & + isnwfrac, & + rescale_low_alpha, & + rescale_low_alphar, & + rescale_low_alphah, & + rescale_low_alphahl, & + rescale_high_alpha, & + ihlcnh, hldia1,iusedw, dwehwmin, dwmin, dwtempmin, & + icvhl2h, hldnmn,hdnmn, & + hlcnhdia, hlcnhqmin, & + isedonly, & + iresetmoments, & + cxmin, zxmin, & + imurain, & + iferwisventr, & + izwisventr, & + qhdpvdn, & + qhacidn, & + sheddiam,sheddiamlg, & + sheddiam0, & + mltdiam1,mltdiam2,mltdiam3,mltdiam4,mltdiam05, & + imaxdiaopt, & + ithompsoncnoh, & + cnohmn, & + ivhmltsoak, & + ioldlimiter, & + isnowfall, & + isnowdens, & + ibiggsnow, & + ixtaltype, & + evapfac, & + depfac, & + dmrauto,irescalerainopt, dmropt,dmhlopt, & + rescale_tempthresh, rescale_wthresh, & + ibinhmlr,ibinhlmlr,imltshddmr, binmlrmxdia, binmlrzrrfac,ibinnum, & + iqhacrmlr, iqhlacrmlr, & + snowmeltdia, & + delta_alphamlr, & + iqvsopt, & + maxsupersat, & + do_accurate_sedimentation, interval_sedi_vt +! ##################################################################### +! ##################################################################### + + CONTAINS + +! ##################################################################### +! ##################################################################### + + +!>\ingroup mod_nsslmp +!! This function is for saturation vapor pressure with respect to liquid water + REAL FUNCTION fqvs(t) + implicit none + real :: t + fqvs = exp(caw*(t-273.15)/(t-cbw)) + END FUNCTION fqvs + +!>\ingroup mod_nsslmp +!! This function is for saturation vapor pressure with respect to ice + REAL FUNCTION fqis(t) + implicit none + real :: t + fqis = exp(cai*(t-273.15)/(t-cbi)) + END FUNCTION fqis + + + + +! ##################################################################### +! ##################################################################### + + +!>\ingroup mod_nsslmp +!! NSSL MP subroutine to initialize physical constants provided by host model + SUBROUTINE nssl_2mom_init_const( & + con_g, con_rd, con_cp, con_rv, con_t0c, con_cliq, con_csol, con_eps ) + + implicit none + real, intent(in) :: con_g, con_rd, con_cp, con_rv, & + con_t0c, con_cliq, con_csol, con_eps + + cp608 = con_eps ! 0.608 ! constant used in conversion of T to Tv + gr = con_g + tfr = con_t0c + cp = con_cp + rd = con_rd + rw = con_rv + cpl = con_cliq ! 4190.0 + cpigb = con_csol ! 2106.0 + cpi = 1./cp + cap = rd/cp + tfrcbw = tfr - cbw + tfrcbi = tfr - cbi + rovcp = rd/cp + + + + RETURN + END SUBROUTINE nssl_2mom_init_const +! ##################################################################### +! ##################################################################### +!>\ingroup mod_nsslmp +!! NSSL MP setup routine (sets local options and array indices) + SUBROUTINE nssl_2mom_init( & + & ims,ime, jms,jme, kms,kme, nssl_params, ipctmp, mixphase,ihvol,idoniconlytmp, & + & nssl_graupelfallfac, & + & nssl_hailfallfac, & + & nssl_ehw0, & + & nssl_ehlw0, & + & nssl_icdx, & + & nssl_icdxhl, & + & nssl_icefallfac, & + & nssl_snowfallfac, & + & errmsg, errflg, & + & myrank, mpiroot & + ) + + implicit none + + real, intent(in), optional :: & + & nssl_graupelfallfac, & + & nssl_hailfallfac, & + & nssl_ehw0, & + & nssl_ehlw0, & + & nssl_icefallfac, & + & nssl_snowfallfac + integer, intent(in), optional :: & + & nssl_icdx, & + & nssl_icdxhl, myrank, mpiroot + + ! CCPP error handling + character(len=*), intent( out) :: errmsg + integer, intent( out) :: errflg + integer, intent(in) :: ims,ime, jms,jme, kms,kme + real, intent(in), dimension(20) :: nssl_params + + + + integer, intent(in) :: ipctmp,mixphase,ihvol + logical, optional, intent(in) :: idoniconlytmp + + logical :: wrote_namelist = .false. + logical :: wrf_dm_on_monitor + + double precision :: arg + real :: temq + integer :: igam + integer :: i,il,j,l + integer :: ltmp + integer :: isub + real :: bxh,bxhl + + real :: alp,ratio + double precision :: x,y,y2,y7 + logical :: turn_on_ccna, turn_on_cina + integer :: istat + + + errmsg = '' + errflg = 0 + turn_on_ccna = .false. + turn_on_cina = .false. +! +! set some global values from namelist input +! + + ccn = Abs( nssl_params(1) ) + alphah = nssl_params(2) + alphahl = nssl_params(3) + cnoh = nssl_params(4) + cnohl = nssl_params(5) + cnor = nssl_params(6) + cnos = nssl_params(7) + rho_qh = nssl_params(8) + rho_qhl = nssl_params(9) + rho_qs = nssl_params(10) + alphar = nssl_params(15) + +! ipelec = Nint(nssl_params(11)) +! isaund = Nint(nssl_params(12)) + IF ( present(nssl_graupelfallfac) ) graupelfallfac = nssl_graupelfallfac + IF ( present(nssl_hailfallfac) ) hailfallfac = nssl_hailfallfac + IF ( present(nssl_ehw0) ) ehw0 = nssl_ehw0 + IF ( present(nssl_ehlw0) ) ehlw0 = nssl_ehlw0 + IF ( present(nssl_icdx) ) icdx = nssl_icdx + IF ( present(nssl_icdxhl) ) icdxhl = nssl_icdxhl + IF ( present(nssl_icefallfac) ) icefallfac = nssl_icefallfac + IF ( present(nssl_snowfallfac) ) snowfallfac = nssl_snowfallfac + + + IF ( Nint(nssl_params(13)) == 1 ) THEN + ! hack to switch CCN field to CCNA (activated ccn) +! invertccn = .true. + turn_on_ccna = .true. + irenuc = 7 + ENDIF + + + + + + IF ( .false. ) THEN ! set to true to enable internal namelist read + open(15,file='input.nml',status='old',form='formatted',action='read') + rewind(15) + read(15,NML=nssl_mp_params,iostat=istat) + close(15) + IF ( present ( myrank ) .and. present ( mpiroot ) ) THEN + IF ( myrank == mpiroot ) THEN + IF ( istat /= 0 ) THEN + write(0,*) 'NSSL_2MOM_INIT: PROBLEM WITH NSSL_MP_PARAMS namelist: not found or bad token' + ENDIF + +! write(0,*) 'iusewetsnow = ',iusewetsnow + + open(15,file='nssl_mp_params.out',status='unknown',form='formatted') + write(15,NML=nssl_mp_params) + close(15) + ENDIF + ENDIF + ENDIF + + + + IF ( irenuc >= 5 ) THEN + turn_on_ccna = .true. + ENDIF + + cwccn = ccn + + lhab = 8 + lhl = 8 + IF ( icespheres >= 1 ) THEN + lhab = lhab + 1 + lis = li + 1 + ls = ls + 1 + lh = lh + 1 + lhl = lhl + 1 + ENDIF + IF ( ihvol <= -1 .or. ihvol == 2 ) THEN + IF ( ihvol == -1 .or. ihvol == -2 ) THEN + lhab = lhab - 1 ! turns off hail + lhl = 0 + ! past me thought it would be a good idea to change graupel factors when hail is off.... + ! ehw0 = 0.75 + ! iehw = 2 + ! dfrz = Max( dfrz, 0.5e-3 ) + ENDIF + IF ( ihvol == -2 .or. ihvol == 2 ) THEN ! ice crystals are turned off + ! a value of -3 means to turn off ice crystals but turn on hail + renucfrac = 1.0 + ffrzs = 1.0 + ! idoci = 0 ! try this later + ENDIF + ENDIF + + IF ( iresetmoments == 0 ) iresetmoments = 1 ! lhl +! write(0,*) 'wrf_init: lhab,lhl = ',lhab,lhl + +! IF ( ipelec > 0 ) idonic = .true. + +! +! Build lookup table for saturation mixing ratio (Soong and Ogura 73) +! + + do l = 1,nqsat + temq = 163.15 + (l-1)*fqsat + IF ( iqvsopt == 0 ) THEN + tabqvs(l) = exp(caw*(temq-273.15)/(temq-cbw)) + dtabqvs(l) = ((-caw*(-273.15 + temq))/(temq - cbw)**2 + & + & caw/(temq - cbw))*tabqvs(l) + ELSE + tabqvs(l) = exp(caw*(temq-273.15)/(temq-cbw)) + dtabqvs(l) = ((-cawbolton*(-273.15 + temq))/(temq - cbwbolton)**2 + & + & cawbolton/(temq - cbwbolton))*tabqvs(l) + ENDIF + tabqis(l) = exp(cai*(temq-273.15)/(temq-cbi)) + dtabqis(l) = ((-cai*(-273.15 + temq))/(temq - cbi)**2 + & + & cai/(temq - cbi))*tabqis(l) + end do + + bx(lr) = 0.85 + ax(lr) = 1647.81 + fx(lr) = 135.477 + + IF ( icdx == 6 ) THEN + bx(lh) = 0.6 ! Milbrandt and Morrison (2013) for density of 550. + ax(lh) = 157.71 + ELSEIF ( icdx > 0 ) THEN + bx(lh) = 0.5 + ax(lh) = 75.7149 + ELSE + bx(lh) = 0.37 ! 0.6 ! Ferrier 1994 + ax(lh) = 19.3 + ENDIF +! bx(lh) = 0.6 + + IF ( lhl .gt. 1 ) THEN + IF ( icdxhl == 6 ) THEN + bx(lhl) = 0.593 ! Milbrandt and Morrison (2013) for density of 750. + ax(lhl) = 179.36 + ELSEIF (icdxhl > 0 ) THEN + bx(lhl) = 0.5 + ax(lhl) = 75.7149 + ELSE + ax(lhl) = 206.984 ! Ferrier 1994 + bx(lhl) = 0.6384 + ENDIF + ENDIF + +! fill in the complete gamma function lookup table + gmoi(0) = 1.d32 + do igam = 1,ngm0 + arg = dgam*igam + gmoi(igam) = gamma_dp(arg) + end do + + ! build lookup table to compute the number and mass fractions of rain drops + ! (imurain=1) greater than a given diameter. Used for qiacr and ciacr + ! Uses incomplete gamma functions + ! The terms with bxh or bxhl will be off if the actual bxh or bxhl is different from the base value (icdx=6 option) + + bxh = bx(lh) + bxhl = bx(Max(lh,lhl)) + +! DO j = 0,nqiacralpha + DO j = ialpstart,nqiacralpha + alp = float(j)*dqiacralpha + y = gamma_dpr(1.+alp) + y2 = gamma_dpr(2.+alp) + DO i = 0,nqiacrratio + ratio = float(i)*dqiacrratio + x = gamxinfdp( 1.+alp, ratio ) +! write(0,*) 'i, x/y = ',i, x/y + ciacrratio(i,j) = x/y + + ! graupel (.,.,.,1) + gamxinflu(i,j,1,1) = x/y + gamxinflu(i,j,2,1) = gamxinfdp( 2.0+alp, ratio )/y + gamxinflu(i,j,3,1) = gamxinfdp( 2.5+alp+0.5*bxh, ratio )/y + gamxinflu(i,j,5,1) = (gamma_dpr(5.0+alp) - gamxinfdp( 5.0+alp, ratio ))/y + gamxinflu(i,j,6,1) = (gamma_dpr(5.5+alp+0.5*bxh) - gamxinfdp( 5.5+alp+0.5*bxh, ratio ))/y + gamxinflu(i,j,9,1) = gamxinfdp( 1.0+alp, ratio )/y + gamxinflu(i,j,10,1)= gamxinfdp( 4.0+alp, ratio )/y + + gamxinflu(i,j,12,1) = gamxinfdp( 2.0+alp, ratio )/y2 + + ! hail (.,.,.,2) + gamxinflu(i,j,1,2) = gamxinflu(i,j,1,1) + gamxinflu(i,j,2,2) = gamxinflu(i,j,2,1) + gamxinflu(i,j,3,2) = gamxinfdp( 2.5+alp+0.5*bxhl, ratio )/y + gamxinflu(i,j,5,2) = gamxinflu(i,j,5,1) + gamxinflu(i,j,6,2) = (gamma_dpr(5.5+alp+0.5*bxhl) - gamxinfdp( 5.5+alp+0.5*bxhl, ratio ))/y + gamxinflu(i,j,9,2) = gamxinflu(i,j,9,1) + gamxinflu(i,j,10,2)= gamxinflu(i,j,10,1) + + IF ( alp > 1.1 ) THEN +! gamxinflu(i,j,7,1) = gamxinfdp( alp - 1., ratio )/y + gamxinflu(i,j,7,1) = (gamma_dpr(alp - 1.) - gamxinfdp( alp - 1., ratio ))/y +! gamxinflu(i,j,8,1) = gamxinfdp( alp - 0.5 + 0.5*bxh, ratio )/y + gamxinflu(i,j,8,1) = (gamma_dpr(alp - 0.5 + 0.5*bxh) - gamxinfdp( alp - 0.5 + 0.5*bxh, ratio ))/y +! gamxinflu(i,j,8,2) = gamxinfdp( alp - 0.5 + 0.5*bxhl, ratio )/y + gamxinflu(i,j,8,2) = (gamma_dpr(alp - 0.5 + 0.5*bxhl) - gamxinfdp( alp - 0.5 + 0.5*bxhl, ratio ))/y + ELSE +! gamxinflu(i,j,7,1) = gamxinfdp( .1, ratio )/y + gamxinflu(i,j,7,1) = (gamma_dpr(0.1) - gamxinfdp( 0.1, ratio ) )/y +! gamxinflu(i,j,8,1) = gamxinfdp( 1.1 - 0.5 + 0.5*bxh, ratio )/y +! gamxinflu(i,j,8,2) = gamxinfdp( 1.1 - 0.5 + 0.5*bxhl, ratio )/y + gamxinflu(i,j,8,1) = (gamma_dpr(1.1 - 0.5 + 0.5*bxh) - gamxinfdp( 1.1 - 0.5 + 0.5*bxh, ratio ) )/y + gamxinflu(i,j,8,2) = (gamma_dpr(1.1 - 0.5 + 0.5*bxhl) - gamxinfdp( 1.1 - 0.5 + 0.5*bxhl, ratio ) )/y + ENDIF + + gamxinflu(i,j,7,2) = gamxinflu(i,j,7,1) + + ENDDO + ENDDO + ciacrratio(0,:) = 1.0 + + DO j = ialpstart,nqiacralpha + alp = float(j)*dqiacralpha + y = gamma_sp(4.+alp) + y7 = gamma_sp(7.+alp) + DO i = 0,nqiacrratio + ratio = float(i)*dqiacrratio + + ! mass fraction + x = gamxinfdp( 4.+alp, ratio ) +! write(0,*) 'i, x/y = ',i, x/y + qiacrratio(i,j) = x/y + gamxinflu(i,j,4,1) = x/y + gamxinflu(i,j,4,2) = x/y + + ! reflectivity fraction + x = gamxinfdp( 7.+alp, ratio ) + ziacrratio(i,j) = x/y7 + gamxinflu(i,j,11,1) = x/y7 + gamxinflu(i,j,11,2) = x/y7 + + ENDDO + ENDDO + qiacrratio(0,:) = 1.0 + + + isub = Min( 0, Max(-1,ihvol) ) ! is -1 or 0 + + lccn = 0 + lccna = 0 + lnc = 0 + lnr = 0 + lni = 0 + lnis = 0 + lns = 0 + lnh = 0 + lnhl = 0 + lvh = 0 + lvhl = 0 + lzr = 0 + lzh = 0 + lzhl = 0 + lsw = 0 + lhw = 0 + lhlw = 0 + + denscale(:) = 0 + +! lccn = 9 + + ipconc = ipctmp + + IF ( ipconc == 0 ) THEN + IF ( ihvol >= 0 ) THEN + lvh = 9 + ltmp = 9 + denscale(lvh) = 1 + ELSE ! no hail + ltmp = lhab + lhl = 0 + ENDIF + ELSEIF ( ipconc == 5 ) THEN + lccn = lhab+1 ! 9 + lnc = lhab+2 ! 10 + lnr = lhab+3 ! 11 + lni = lhab+4 !12 + lns = lhab+5 !13 + lnh = lhab+6 !14 + ltmp = lnh + IF ( ihvol >= 0 ) THEN + ltmp = ltmp + 1 + lnhl = ltmp ! lhab+7 ! 15 + ENDIF + ltmp = ltmp + 1 + lvh = ltmp ! lhab+8 + isub ! 16 + isub ! isub adjusts to 15 if hail is off +! ltmp = lvh + denscale(lccn:lvh) = 1 + IF ( ihvol >= 1 ) THEN + ltmp = ltmp + 1 + lvhl = ltmp +! ltmp = lvhl + denscale(lvhl) = 1 + ENDIF + IF ( mixedphase ) THEN + ltmp = ltmp + 1 + lsw = ltmp + ltmp = ltmp + 1 + lhw = ltmp + IF ( lhl > 1 ) THEN + ltmp = ltmp + 1 + lhlw = ltmp + ENDIF +! ltmp = lhlw + ENDIF + ELSEIF ( ipconc >= 6 ) THEN + errmsg = 'NSSL microphysics has not been compiled for 3-moment. Sorry.' + errflg = 1 + return + lccn = lhab+1 ! 9 + lnc = lhab+2 ! 10 + lnr = lhab+3 ! 11 + lni = lhab+4 !12 + lns = lhab+5 !13 + lnh = lhab+6 !14 + ltmp = lnh + IF ( lhl > 0 ) THEN + ltmp = ltmp + 1 + lnhl = ltmp ! lhab+7 ! 15 + ENDIF + ltmp = ltmp + 1 + lvh = ltmp ! lhab+8 + isub ! 16 + isub ! isub adjusts to 15 if hail is off +! ltmp = lvh + denscale(lccn:lvh) = 1 + IF ( ihvol >= 1 ) THEN + ltmp = ltmp + 1 + lvhl = ltmp +! ltmp = lvhl + denscale(lvhl) = 1 + ENDIF + + IF ( ipconc == 6 ) THEN + ltmp = ltmp + 1 + lzh = ltmp + ELSEIF ( ipconc == 7 ) THEN + ltmp = ltmp + 1 + lzh = ltmp + ltmp = ltmp + 1 + lzr = ltmp + ELSEIF ( ipconc == 8 ) THEN + ltmp = ltmp + 1 + lzh = ltmp + ltmp = ltmp + 1 + lzr = ltmp + ltmp = ltmp + 1 + IF ( lhl > 1 ) THEN + ltmp = ltmp + 1 + lzhl = ltmp + ENDIF + ENDIF +! ltmp = lvh + ! denscale(lccn:lvh) = 1 + IF ( ihvol >= 1 ) THEN + lvhl = ltmp+1 + ltmp = lvhl + denscale(lvhl) = 1 + ENDIF + IF ( mixedphase ) THEN + ltmp = ltmp + 1 + lsw = ltmp + ltmp = ltmp + 1 + lhw = ltmp + IF ( lhl > 1 ) THEN + ltmp = ltmp + 1 + lhlw = ltmp + ENDIF +! ltmp = lhlw + ENDIF + ELSE + errmsg = 'nssl_2mom_init: Invalid value of ipctmp' + errflg = 1 + RETURN + ENDIF + + + + + ! write(0,*) 'wrf_init: irenuc, turn_on_ccna = ',irenuc, turn_on_ccna + IF ( turn_on_ccna ) THEN + ltmp = ltmp + 1 + lccna = ltmp + denscale(ltmp) = 1 + ENDIF + + IF ( turn_on_cina ) THEN + ltmp = ltmp + 1 + lcina = ltmp + denscale(ltmp) = 1 + ENDIF + + IF ( turn_on_cin .or. is_aerosol_aware ) THEN + ltmp = ltmp + 1 + lcin = ltmp + denscale(ltmp) = 1 +!debug write(0,*) 'Setting lcin to ',lcin + ENDIF + na = ltmp + + ln(lc) = lnc + ln(lr) = lnr + ln(li) = lni + ln(ls) = lns + ln(lh) = lnh + IF ( lhl .gt. 1 ) ln(lhl) = lnhl + + ipc(lc) = 2 + ipc(lr) = 3 + ipc(li) = 1 + ipc(ls) = 4 + ipc(lh) = 5 + IF ( lhl .gt. 1 ) ipc(lhl) = 5 + + ldovol = .false. + lvol(:) = 0 + lvol(li) = lvi + lvol(ls) = lvs + lvol(lh) = lvh + IF ( lhl .gt. 1 .and. lvhl .gt. 1 ) lvol(lhl) = lvhl + + lne = Max(lnh,lnhl) + lne = Max(lne,lvh) + lne = Max(lne,lvhl) + lne = Max(lne,na) + + lsc(:) = 0 + lsc(lc) = lscw + lsc(lr) = lscr + lsc(li) = lsci + lsc(ls) = lscs + lsc(lh) = lsch + IF ( lhl .gt. 1 ) lsc(lhl) = lschl + + + DO il = lc,lhab + ldovol = ldovol .or. ( lvol(il) .gt. 1 ) + ENDDO + +! write(0,*) 'nssl_2mom_init: ldovol = ',ldovol + + lz(:) = 0 + lz(lr) = lzr + lz(li) = lzi + lz(ls) = lzs + lz(lh) = lzh + IF ( lhl .gt. 1 .and. lzhl > 1 ) lz(lhl) = lzhl + + lliq(:) = 0 + lliq(ls) = lsw + lliq(lh) = lhw + IF ( lhl .gt. 1 ) lliq(lhl) = lhlw + IF ( mixedphase ) THEN +! write(0,*) 'lsw,lhw,lhlw = ',lsw,lhw,lhlw + ENDIF + + + + xnu(lc) = cnu + xmu(lc) = 1. + + IF ( imurain == 3 ) THEN + xnu(lr) = rnu + xmu(lr) = 1. + ELSEIF ( imurain == 1 ) THEN + xnu(lr) = (alphar - 2.0)/3.0 + xmu(lr) = 1./3. + ENDIF + + xnu(li) = cinu + xmu(li) = 1. + + IF ( lis >= 1 ) THEN + xnu(lis) = 0.0 + xmu(lis) = 1. + ENDIF + + dnu(lc) = 3.*xnu(lc) + 2. ! alphac + dmu(lc) = 3.*xmu(lc) + + dnu(lr) = 3.*xnu(lr) + 2. ! alphar + dmu(lr) = 3.*xmu(lr) + + xnu(ls) = snu + xmu(ls) = 1. + + dnu(ls) = 3.*xnu(ls) + 2. ! -0.4 ! alphas + dmu(ls) = 3.*xmu(ls) + + + dnu(lh) = alphah + dmu(lh) = dmuh + + xnu(lh) = (dnu(lh) - 2.)/3. + xmu(lh) = dmuh/3. + + + IF ( imurain == 3 ) THEN ! rain is gamma of volume + rz = ((4. + alphah)*(5. + alphah)*(6. + alphah)*(1. + xnu(lr)))/ & + & ((1 + alphah)*(2 + alphah)*(3 + alphah)*(2. + xnu(lr))) + +! IF ( ipconc .lt. 5 ) alphahl = alphah + + rzhl = ((4. + alphahl)*(5. + alphahl)*(6. + alphahl)*(1. + xnu(lr)))/ & + & ((1. + alphahl)*(2. + alphahl)*(3. + alphahl)*(2. + xnu(lr))) + + rzs = 1. ! assume rain and snow are both gamma volume + + ELSE ! rain is gamma of diameter + + rz = ((4. + alphah)*(5. + alphah)*(6. + alphah)*(1. + alphar)*(2. + alphar)*(3. + alphar))/ & + & ((1 + alphah)*(2 + alphah)*(3 + alphah)*(4. + alphar)*(5. + alphar)*(6. + alphar)) + + rzhl = ((4. + alphahl)*(5. + alphahl)*(6. + alphahl)*(1. + alphar)*(2. + alphar)*(3. + alphar))/ & + & ((1 + alphahl)*(2 + alphahl)*(3 + alphahl)*(4. + alphar)*(5. + alphar)*(6. + alphar)) + + + rzs = & + & ((1. + alphar)*(2. + alphar)*(3. + alphar)*(2. + xnu(ls)))/ & + & ((4. + alphar)*(5. + alphar)*(6. + alphar)*(1. + xnu(ls))) + + + ENDIF + + IF ( ipconc <= 5 ) THEN + imltshddmr = Min(1, imltshddmr) + ibinhmlr = 0 + ibinhlmlr = 0 + ENDIF + + IF ( ipconc > 5 .and. (ibinhmlr == 0 .and. ibinhlmlr == 0 ) ) THEN + imltshddmr = Min(1, imltshddmr) + ENDIF + +! write(0,*) 'rz,rzhl = ', rz,rzhl + + IF ( ipconc .lt. 4 ) THEN + + dnu(ls) = alphas + dmu(ls) = 1. + + xnu(ls) = (dnu(ls) - 2.)/3. + xmu(ls) = 1./3. + + + ENDIF + + IF ( lhl .gt. 1 ) THEN + + dnu(lhl) = alphahl + dmu(lhl) = dmuhl + + xnu(lhl) = (dnu(lhl) - 2.)/3. + xmu(lhl) = dmuhl/3. + + ENDIF + + cno(lc) = 1.0e+08 + IF ( li .gt. 1 ) cno(li) = 1.0e+08 + cno(lr) = cnor + IF ( ls .gt. 1 ) cno(ls) = cnos ! 8.0e+06 + IF ( lh .gt. 1 ) cno(lh) = cnoh ! 4.0e+05 + IF ( lhl .gt. 1 ) cno(lhl) = cnohl ! 4.0e+05 +! +! density maximums and minimums +! + xdnmx(:) = 900.0 + + xdnmx(lr) = 1000.0 + xdnmx(lc) = 1000.0 + xdnmx(li) = 917.0 + xdnmx(ls) = 300.0 + xdnmx(lh) = 900.0 + IF ( lhl .gt. 1 ) xdnmx(lhl) = 900.0 +! + xdnmn(:) = 900.0 + + xdnmn(lr) = 1000.0 + xdnmn(lc) = 1000.0 + xdnmn(li) = 100.0 + xdnmn(ls) = 100.0 + xdnmn(lh) = hdnmn + IF ( lhl .gt. 1 ) xdnmn(lhl) = hldnmn + + xdn0(:) = 900.0 + + xdn0(lc) = 1000.0 + xdn0(li) = 900.0 + xdn0(lr) = 1000.0 + xdn0(ls) = rho_qs ! 100.0 + xdn0(lh) = rho_qh ! (0.5)*(xdnmn(lh)+xdnmx(lh)) + IF ( lhl .gt. 1 ) xdn0(lhl) = rho_qhl ! 800.0 + +! +! Set terminal velocities... +! also set drag coefficients +! + cdx(lr) = 0.60 + cdx(lh) = 0.8 ! 1.0 ! 0.45 + cdx(ls) = 2.00 + IF ( lhl .gt. 1 ) cdx(lhl) = 0.45 + + ido(lc) = idocw + ido(lr) = idorw + ido(li) = idoci + ido(ls) = idosw + ido(lh) = idohw + IF ( lhl .gt. 1 ) ido(lhl) = idohl + + IF ( irfall .lt. 0 ) irfall = infall + IF ( lzr > 0 ) irfall = 0 + + qccn = ccn/rho00 + IF ( old_cccn > 0.0 ) THEN + old_qccn = old_cccn/rho00 + ELSE + old_qccn = qccn + ENDIF +! xvcmx = (4./3.)*pi*xcradmx**3 + +! set max rain diameter + IF ( xvdmx .gt. 0.0 ) THEN + xvrmx = 0.523599*(xvdmx)**3 + ELSE + xvrmx = xvrmx0 + ENDIF + + IF ( dhmn <= 0.0 ) THEN + xvhmn = xvhmn0 +! xvhmn = Min(xvhmn0, 0.523599*(dfrz)**3 ) + ELSE + xvhmn = 0.523599*(dhmn)**3 +! xvhmn = 0.523599*(Min(dhmn,dfrz))**3 + ENDIF + + IF ( dhmx <= 0.0 ) THEN + xvhmx = xvhmx0 + ELSE + xvhmx = 0.523599*(dhmx)**3 + ENDIF + + IF ( qhdpvdn < 0. ) qhdpvdn = xdnmn(lh) + IF ( qhacidn < 0. ) qhacidn = xdnmn(lh) + +! load max/min diameters + xvmn(lc) = xvcmn + xvmn(li) = xvimn + xvmn(lr) = xvrmn + xvmn(ls) = xvsmn + xvmn(lh) = xvhmn + + xvmx(lc) = xvcmx + xvmx(li) = xvimx + xvmx(lr) = xvrmx + xvmx(ls) = xvsmx + xvmx(lh) = xvhmx + + IF ( lhl .gt. 1 ) THEN + xvmn(lhl) = xvhlmn + xvmx(lhl) = xvhlmx + ENDIF + +! +! cloud water constants in mks units +! +! cwmasn = 4.25e-15 ! radius of 1.0e-6 +! cwmasn = 5.23e-13 ! minimum mass, defined by radius of 5.0e-6 +! cwmasn5 = 5.23e-13 +! cwradn = 5.0e-6 ! minimum radius +! cwmasx = 5.25e-10 ! maximum mass, defined by radius of 50.0e-6 +! mwfac = 6.0**(1./3.) + IF ( ipconc .ge. 2 ) THEN +! cwmasn = xvmn(lc)*1000. ! minimum mass, defined by minimum droplet volume +! cwradn = 1.0e-6 ! minimum radius +! cwmasx = xvmx(lc)*1000. ! maximum mass, defined by maximum droplet volume + + ENDIF +! rwmasn = xvmn(lr)*1000. ! minimum mass, defined by minimum rain volume +! rwmasx = xvmx(lr)*1000. ! maximum mass, defined by maximum rain volume + + IF ( lhl < 1 ) ifrzg = 1 + + ventr = 1. + IF ( imurain == 3 ) THEN +! IF ( izwisventr == 1 ) THEN + ventr = Gamma_sp(rnu + 4./3.)/((rnu + 1.)**(1./3.)*Gamma_sp(rnu + 1.)) ! Ziegler 1985 +! ELSE + ventrn = Gamma_sp(rnu + 1.5 + br/6.)/(Gamma_sp(rnu + 1.)*(rnu + 1.)**((1.+br)/6. + 1./3.) ) ! adapted from Wisner et al. 1972; for second term in rwvent +! ventr = Gamma_sp(rnu + 4./3.)/((rnu + 1.)**(1./3.)*Gamma_sp(rnu + 1.)) ! Ziegler 1985, still use for first term in rwvent +! ventr = Gamma_sp(rnu + 4./3.)/Gamma_sp(rnu + 1.) +! ENDIF + ELSE ! imurain == 1 +! IF ( iferwisventr == 1 ) THEN + ventr = Gamma_sp(2. + alphar) ! Ferrier 1994 +! ELSEIF ( iferwisventr == 2 ) THEN + ventrn = Gamma_sp(alphar + 2.5 + br/2.)/Gamma_sp(alphar + 1.) ! adapted from Wisner et al. 1972 +! ENDIF + ENDIF + ventc = Gamma_sp(cnu + 4./3.)/(cnu + 1.)**(1./3.)/Gamma_sp(cnu + 1.) + c1sw = Gamma_sp(snu + 4./3.)*(snu + 1.0)**(-1./3.)/gamma_sp(snu + 1.0) + + ! set threshold mixing ratios + + qxmin(:) = 1.0e-12 + + qxmin(lc) = 1.e-9 + qxmin(lr) = 1.e-7 + IF ( li > 1 ) qxmin(li) = 1.e-12 + IF ( ls > 1 ) qxmin(ls) = 1.e-7 + IF ( lh > 1 ) qxmin(lh) = 1.e-7 + IF ( lhl .gt. 1 ) qxmin(lhl) = 1.e-7 + + IF ( lc .gt. 1 .and. lnc .gt. 1 ) qxmin(lc) = 1.0e-13 + IF ( lr .gt. 1 .and. lnr .gt. 1 ) qxmin(lr) = 1.0e-12 + + IF ( li .gt. 1 .and. lni .gt. 1 ) qxmin(li ) = 1.0e-13 + IF ( ls .gt. 1 .and. lns .gt. 1 ) qxmin(ls ) = 1.0e-13 + IF ( lh .gt. 1 .and. lnh .gt. 1 ) qxmin(lh ) = 1.0e-12 + IF ( lhl.gt. 1 .and. lnhl.gt. 1 ) qxmin(lhl) = 1.0e-12 + + qxmin_init(:) = 1.0e-8 ! threshold for considering single-moment initial condition mixing ratios + ! constants for droplet nucleation + + cckm = cck-1. + ccnefac = (1.63/(cck * beta(3./2., cck/2.)))**(cck/(cck + 2.0)) + cnexp = (3./2.)*cck/(cck+2.0) +! ccne is all the factors with w in eq. A7 in Mansell et al. 2010 (JAS). The constant changes +! if k (cck) is changed! + ccne = ccnefac*1.e6*(1.e-6*Abs(cwccn))**(2./(2.+cck)) + ccne0 = ccnefac*1.e6*(1.e-6)**(2./(2.+cck)) +! write(0,*) 'cwccn, cck, ccne = ',cwccn,cck,ccne,ccnefac,cnexp + IF ( cwccn .lt. 0.0 ) THEN + cwccn = Abs(cwccn) + ccwmx = 50.e9 ! cwccn + ELSE + ccwmx = 50.e9 ! cwccn ! *1.4 + ENDIF + +! +! +! Set collection coefficients (Seifert and Beheng 05) +! + bb(:) = 1.0/3.0 + bb(li) = 0.3429 + DO il = lc,lhab + da0(il) = delbk(bb(il), xnu(il), xmu(il), 0) + da1(il) = delbk(bb(il), xnu(il), xmu(il), 1) + +! write(0,*) 'il, da0, da1, xnu, xmu = ', il, da0(il), da1(il), xnu(il), xmu(il) + ENDDO + + dab0(:,:) = 0.0 + dab1(:,:) = 0.0 + + DO il = lc,lhab + DO j = lc,lhab + IF ( il .ne. j ) THEN + + dab0(il,j) = delabk(bb(il), bb(j), xnu(il), xnu(j), xmu(il), xmu(j), 0) + dab1(il,j) = delabk(bb(il), bb(j), xnu(il), xnu(j), xmu(il), xmu(j), 1) + +! write(0,*) 'il, j, dab0, dab1 = ',il, j, dab0(il,j), dab1(il,j) + ENDIF + ENDDO + ENDDO + + gf4br = gamma_sp(4.0+br) + gf4ds = gamma_sp(4.0+ds) + gf4p5 = gamma_sp(4.0+0.5) + gfcinu1 = gamma_sp(cinu + 1.0) + gfcinu1p47 = gamma_sp(cinu + 1.47167) + gfcinu2p47 = gamma_sp(cinu + 2.47167) + gfcinu1p22 = gamma_sp(cinu + 1.22117) + gfcinu2p22 = gamma_sp(cinu + 2.22117) + gfcinu1p18 = gamma_sp(cinu + 1.18333) + gfcinu2p18 = gamma_sp(cinu + 2.18333) + + gsnow1 = gamma_sp(snu + 1.0) + gsnow53 = gamma_sp(snu + 5./3.) + gsnow73 = gamma_sp(snu + 7./3.) + + IF ( lh .gt. 1 ) cwchtmp0 = 6.0/pi*gamma_sp( (xnu(lh) + 1.)/xmu(lh) )/gamma_sp( (xnu(lh) + 2.)/xmu(lh) ) + IF ( lhl .gt. 1 ) cwchltmp0 = 6.0/pi*gamma_sp( (xnu(lhl) + 1)/xmu(lhl) )/gamma_sp( (xnu(lhl) + 2)/xmu(lhl) ) + + + iexy(:,:)=0; ! sets to zero the ones Imight have forgotten + +! snow + iexy(ls,li) = ieswi + iexy(ls,lc) = ieswc ; iexy(ls,lr) = ieswr ; + +! graupel + iexy(lh,ls) = iehwsw ; iexy(lh,li) = iehwi ; + iexy(lh,lc) = iehwc ; iexy(lh,lr) = iehwr ; + +! hail + IF (lhl .gt. 1 ) THEN + iexy(lhl,ls) = iehlsw ; iexy(lhl,li) = iehli ; + iexy(lhl,lc) = iehlc ; iexy(lhl,lr) = iehlr ; + ENDIF + +! IF ( icefallfac /= 1.0 ) write(0,*) 'icefallfac = ',icefallfac +! IF ( snowfallfac /= 1.0 ) write(0,*) 'snowfallfac = ',snowfallfac + + + RETURN +END SUBROUTINE nssl_2mom_init + +! ##################################################################### +! ##################################################################### + +!>\ingroup mod_nsslmp +!! Driver subroutine that copies state data to local 2D arrays for microphysics calls +SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw, chl, & + cn, vhw, vhl, cna, cni, f_cn, f_cna, f_cina, & + zrw, zhw, zhl, & + qsw, qhw, qhlw, & + tt, th, pii, p, w, dn, dz, dtp, itimestep, & + RAINNC,RAINNCV, & + dx, dy, & + axtra, & + SNOWNC, SNOWNCV, GRPLNC, GRPLNCV, & + SR,HAILNC, HAILNCV, & + tkediss, & + re_cloud, re_ice, re_snow, re_rain, & + has_reqc, has_reqi, has_reqs, has_reqr, & + rainncw2, rainnci2, & + dbz, vzf,compdbz, & + rscghis_2d,rscghis_2dp,rscghis_2dn, & + scr,scw,sci,scs,sch,schl,sctot, & + elec_physics, & + induc,elecz,scion,sciona, & + noninduc,noninducp,noninducn, & + pcc2, pre2, depsubr, & + mnucf2, melr2, ctr2, & + rim1_2, rim2_2,rim3_2, & + nctr2, nnuccd2, nnucf2, & + effc2,effr2,effi2, & + effs2, effg2, & + fc2, fr2,fi2,fs2,fg2, & + fnc2, fnr2,fni2,fns2,fng2, & +! qcond,qdep,qfrz,qrauto,qhcnvi,qhcollw,qscollw, & +! ncauto, niinit,nifrz, & +! re_liquid, re_graupel, re_hail, re_icesnow, & +! vtcloud, vtrain, vtsnow, vtgraupel, vthail, & + ipelectmp, & + diagflag,ke_diag, & + errmsg, errflg, & + nssl_progn, & ! wrf-chem +! 20130903 acd_mb_washout start + wetscav_on, rainprod, evapprod, & ! wrf-chem +! 20130903 acd_mb_washout end + cu_used, qrcuten, qscuten, qicuten, qccuten, & ! hm added + ids,ide, jds,jde, kds,kde, & ! domain dims + ims,ime, jms,jme, kms,kme, & ! memory dims + its,ite, jts,jte, kts,kte) ! tile dims + + + + implicit none + + + !Subroutine arguments: + + integer, intent(in):: & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte + real, dimension(ims:ime, kms:kme, jms:jme), intent(inout):: & + qv,qc,qr,qs,qh + ! tt is air temperature -- used by CCPP instead of th (theta) + real, dimension(ims:ime, kms:kme, jms:jme), optional, intent(inout):: & + th, tt, & + zrw, zhw, zhl, & + qsw, qhw, qhlw, & + qi,qhl,ccw,crw,cci,csw,chw,chl,vhw,vhl + real, dimension(ims:ime, kms:kme, jms:jme), optional, intent(inout):: dbz, vzf, cn, cna, cni + real, dimension(ims:ime, jms:jme), optional, intent(inout):: compdbz + real, dimension(ims:ime, jms:jme), optional, intent(inout):: rscghis_2d, & ! 2D accumulation arrays for vertically-integrated charging rate + rscghis_2dp, & ! 2D accumulation arrays for vertically-integrated charging rate (positive only) + rscghis_2dn ! 2D accumulation arrays for vertically-integrated charging rate (negative only) +! real, dimension(ims:ime, kms:kme, jms:jme), optional, intent(inout)::rscghis_3d + integer, optional, intent(in) :: elec_physics + real, dimension(ims:ime, kms:kme, jms:jme), optional, intent(inout):: & + scr,scw,sci,scs,sch,schl,sciona,sctot ! space charge + real, dimension(ims:ime, kms:kme, jms:jme), optional, intent(inout):: & + induc,noninduc,noninducp,noninducn ! charging rates: inductive, noninductive (all, positive, negative to graupel) + real, dimension(ims:ime, kms:kme, jms:jme), optional, intent(in) :: elecz ! elecsave = Ez + real, dimension(ims:ime, kms:kme, jms:jme,2),optional, intent(inout) :: scion + real, dimension(ims:ime, kms:kme, jms:jme), intent(in):: p,w,dz,dn + + real, dimension(ims:ime, kms:kme, jms:jme), intent(in):: pii + real, dimension(ims:ime, kms:kme, jms:jme), optional, intent(inout):: & + pcc2, pre2, depsubr, & + mnucf2, melr2, ctr2, & + rim1_2, rim2_2,rim3_2, & + nctr2, nnuccd2, nnucf2, & + effc2,effr2,effi2, & + effs2, effg2, & + fc2, fr2,fi2,fs2,fg2, & + fnc2, fnr2,fni2,fns2,fng2 +! qcond,qdep,qfrz,qrauto,qhcnvi,qhcollw,qscollw, & +! ncauto, niinit,nifrz, & +! re_liquid, re_graupel, re_hail, re_icesnow, & +! vtcloud, vtrain, vtsnow, vtgraupel, vthail + + real, dimension(ims:ime, kms:kme, jms:jme), optional, intent(inout) :: axtra + +! WRF variables + real, dimension(ims:ime, jms:jme), intent(inout):: & + RAINNC,RAINNCV ! accumulated precip (NC) and rate (NCV) + real, dimension(ims:ime, jms:jme), optional, intent(inout):: & + SNOWNC,SNOWNCV,GRPLNC,GRPLNCV,SR ! accumulated precip (NC) and rate (NCV) + real, dimension(ims:ime, jms:jme), optional, intent(inout):: & + HAILNC,HAILNCV ! accumulated precip (NC) and rate (NCV) + integer, parameter :: nproc = 1 + REAL, DIMENSION(ims:ime, kms:kme, jms:jme), optional, INTENT(INOUT):: re_cloud, re_ice, re_snow, re_rain + REAL, DIMENSION(ims:ime, kms:kme, jms:jme), optional, INTENT(IN):: tkediss + INTEGER, INTENT(IN), optional :: has_reqc, has_reqi, has_reqs, has_reqr + real, dimension(ims:ime, jms:jme), intent(out), optional :: & + rainncw2, rainnci2 ! liquid rain, ice, accumulation rates + real, optional, intent(in) :: dx,dy + real, intent(in):: dtp + integer, intent(in):: itimestep !, ccntype + logical, optional, intent(in) :: diagflag, f_cna, f_cn, f_cina + integer, optional, intent(in) :: ipelectmp, ke_diag + + ! CCPP error handling + character(len=*), intent( out) :: errmsg + integer, intent( out) :: errflg + + LOGICAL, INTENT(IN), OPTIONAL :: nssl_progn ! flags for wrf-chem + +! REAL, DIMENSION(ims:ime, kms:kme, jms:jme), optional,INTENT(INOUT):: qndrop + LOGICAL :: flag_qndrop ! wrf-chem + LOGICAL :: flag_qnifa , flag_qnwfa + logical :: flag + real :: cinchange, t7max,testmax,wmax + +! 20130903 acd_ck_washout start +! rainprod - total tendency of conversion of cloud water/ice and graupel to rain (kg kg-1 s-1) +! evapprod - tendency of evaporation of rain (kg kg-1 s-1) +! 20130903 acd_ck_washout end + REAL, DIMENSION(ims:ime, kms:kme, jms:jme), optional,INTENT(INOUT):: rainprod, evapprod + +! qrcuten, rain tendency from parameterized cumulus convection +! qscuten, snow tendency from parameterized cumulus convection +! qicuten, cloud ice tendency from parameterized cumulus convection +! mu : air mass in column + REAL, DIMENSION(ims:ime, kms:kme, jms:jme), optional, INTENT(IN):: qrcuten, qscuten, qicuten, qccuten + INTEGER, optional, intent(in) :: cu_used + LOGICAL, optional, intent(in) :: wetscav_on + +! +! local variables +! + real, dimension(its:ite, 1, kts:kte) :: elec2 ! ez = elecsave slab +! real, dimension(its:ite, 1, kts:kte,2) :: scion2 ! 1=- , 2=+ + real, dimension(its:ite, kts:kte) :: rainprod2d, evapprod2d,tke2d + real, dimension(its:ite, 1, kts:kte, na) :: an, ancuten + real, dimension(its:ite, 1, kts:kte, nxtra) :: axtra2d + real, dimension(its:ite, 1, kts:kte) :: t0,t1,t2,t3,t4,t5,t6,t7,t8,t9 + real, dimension(its:ite, 1, kts:kte) :: dn1,t00,t77,ssat,pn,wn,dz2d,dz2dinv,dbz2d,vzf2d + real, dimension(its:ite, 1, na) :: xfall + real, dimension(kts:kte, nproc) :: thproclocal + integer, parameter :: nor = 0, ng = 0 + integer :: nx,ny,nz + integer ix,jy,kz,i,j,k,il,n + integer :: infdo + real :: ssival, ssifac, t8s, t9s, qvapor + integer :: ltemq + double precision :: dp1 + integer :: jye, lnb + integer :: imx,kmx + real :: dbzmx,refl + integer :: vzflag0 = 0 + logical :: makediag + real :: dx1,dy1 + real, parameter :: cnin20 = 1.0e3 + real, parameter :: cnin10 = 5.0e1 + real, parameter :: cnin1a = 4.5 + real, parameter :: cnin2a = 12.96 + real, parameter :: cnin2b = 0.639 + + double precision :: cwmass1,cwmass2 + double precision :: rwmass1,rwmass2 + double precision :: icemass1,icemass2 + double precision :: swmass1,swmass2 + double precision :: grmass1,grmass2 + double precision :: hlmass1,hlmass2 + double precision :: wvol5,wvol10 + real :: tmp,dv,dv1,tmpchg + real :: rdt + + double precision :: dt1,dt2 + double precision :: timesed,timesed1,timesed2,timesed3, timegs, timenucond, timedbz,zmaxsed + double precision :: timevtcalc,timesetvt + + logical :: f_cnatmp, f_cinatmp + logical :: has_wetscav + + integer :: kediagloc + integer :: iunit + + real :: ycent, y, emissrate, emissrate0, emissrate1, z, fac, factot + real :: fach(kts:kte) + + logical, parameter :: debugdriver = .false. + +#ifdef MPI + +#if defined(MPI) + integer, parameter :: ntot = 50 + double precision mpitotindp(ntot), mpitotoutdp(ntot) + INTEGER :: mpi_error_code = 1 +#endif +#endif + + +! ------------------------------------------------------------------- + + errmsg = '' + errflg = 0 + + rdt = 1.0/dtp + + IF ( debugdriver ) write(0,*) 'N2M: entering routine' + + flag_qndrop = .false. + flag_qnifa = .false. + flag_qnwfa = .false. + + IF ( PRESENT ( nssl_progn ) ) flag_qndrop = nssl_progn + + + + + ! --- + + IF ( present( f_cna ) ) THEN + f_cnatmp = f_cna + ELSE + f_cnatmp = .false. + ENDIF + + IF ( present( f_cina ) ) THEN + f_cinatmp = f_cina + ELSE + f_cinatmp = .false. + ENDIF + + IF ( present( vzf ) ) vzflag0 = 1 + + IF ( present( ipelectmp ) ) THEN + ipelec = ipelectmp + ELSE + ipelec = 0 + ENDIF +! IF ( present( dbz ) ) THEN +! DO jy = jts,jte +! DO kz = kts,kte +! DO ix = its,ite +! dbz(ix,kz,jy) = 0.0 +! ENDDO +! ENDDO +! ENDDO +! ENDIF + + IF ( present( dx ) .and. present( dy ) ) THEN + dx1 = dx + dy1 = dy + ELSE + dx1 = 1.0 + dy1 = 1.0 + ENDIF + + + makediag = .true. + IF ( present( diagflag ) ) THEN + makediag = diagflag .or. itimestep == 1 + ENDIF + + IF ( debugdriver ) write(0,*) 'N2M: makediag = ',makediag + + + nx = ite-its+1 + ny = 1 ! set up as 2D slabs + nz = kte-kts+1 + + IF ( .not. present( cn ) ) THEN + renucfrac = 1.0 + ENDIF + + + + +! ENDIF ! itimestep == 1 + + +! sedimentation settings + + infdo = 2 + + IF ( infall .ne. 1 .or. iscfall .ge. 2 ) THEN + infdo = 1 + ELSE + infdo = 0 + ENDIF + + IF ( infall .ge. 3 .or. ipconc .ge. 6 ) THEN + infdo = 2 + ENDIF + + + IF ( present( HAILNCV ) .and. lhl < 1 ) THEN ! for WRF 3.1 compatibility + HAILNCV(its:ite,jts:jte) = 0. + ENDIF + + tke2d(:,:) = 0.0 ! initialize if not used + + lnb = Max(lh,lhl)+1 ! lnc +! IF ( lccn > 1 ) lnb = lccn + + jye = jte + + IF ( present( compdbz ) .and. makediag ) THEN + DO jy = jts,jye + DO ix = its,ite + compdbz(ix,jy) = -3.0 + ENDDO + ENDDO + ENDIF + + zmaxsed = 0.0d0 + timevtcalc = 0.0d0 + timesetvt = 0.0d0 + timesed = 0.0d0 + timesed1 = 0.0d0 + timesed2 = 0.0d0 + timesed3 = 0.0d0 + timegs = 0.0d0 + timenucond = 0.0d0 + + + + IF ( debugdriver ) write(0,*) 'N2M: jy loop 1, lhl,na = ',lhl,na,present(qhl) + + ancuten(its:ite,1,kts:kte,:) = 0.0 + thproclocal(:,:) = 0.0 + + DO jy = jts,jye + + xfall(:,:,:) = 0.0 + +! write(0,*) 'N2M: load an, jy,lccn = ',jy,lccn,qccn + + IF ( present( pcc2 ) .and. makediag ) THEN + axtra2d(its:ite,1,kts:kte,:) = 0.0 + ENDIF + + ! copy from 3D array to 2D slab + + DO kz = kts,kte + DO ix = its,ite + + IF ( present( tt ) ) THEN + an(ix,1,kz,lt) = tt(ix,kz,jy)/pii(ix,kz,jy) + ELSE + an(ix,1,kz,lt) = th(ix,kz,jy) + ENDIF + + + an(ix,1,kz,lv) = qv(ix,kz,jy) + an(ix,1,kz,lc) = qc(ix,kz,jy) + an(ix,1,kz,lr) = qr(ix,kz,jy) + IF ( present( qi ) ) THEN + an(ix,1,kz,li) = qi(ix,kz,jy) + ELSE + an(ix,1,kz,li) = 0.0 + ENDIF + an(ix,1,kz,ls) = qs(ix,kz,jy) + an(ix,1,kz,lh) = qh(ix,kz,jy) + IF ( lhl > 1 ) an(ix,1,kz,lhl) = qhl(ix,kz,jy) + IF ( lccn > 1 ) THEN + IF ( is_aerosol_aware .and. flag_qnwfa ) THEN + ! + ELSEIF ( present( cn ) ) THEN + IF ( lccna > 1 .and. .not. ( present( cna ) .and. f_cnatmp ) ) THEN + an(ix,1,kz,lccna) = cn(ix,kz,jy) + an(ix,1,kz,lccn) = qccn ! cn(ix,kz,jy) + ELSE + an(ix,1,kz,lccn) = cn(ix,kz,jy) + ENDIF + ELSE + IF ( lccna == 0 .and. ( .not. f_cnatmp ) ) THEN + an(ix,1,kz,lccn) = qccn - ccw(ix,kz,jy) + ELSE + an(ix,1,kz,lccn) = qccn + ENDIF + + ENDIF + ENDIF + + IF ( lccna > 1 ) THEN + IF ( present( cna ) .and. f_cnatmp ) THEN + an(ix,1,kz,lccna) = cna(ix,kz,jy) + ENDIF + ENDIF + + IF ( lcina > 1 ) THEN + IF ( present( cni ) .and. f_cinatmp ) THEN + an(ix,1,kz,lcina) = cni(ix,kz,jy) + ENDIF + ENDIF + + IF ( ipconc >= 5 ) THEN + an(ix,1,kz,lnc) = ccw(ix,kz,jy) + IF ( constccw > 0.0 ) THEN + an(ix,1,kz,lnc) = constccw + ENDIF + an(ix,1,kz,lnr) = crw(ix,kz,jy) + IF ( present( cci ) ) THEN + an(ix,1,kz,lni) = cci(ix,kz,jy) + ELSE + an(ix,1,kz,lni) = 0.0 + ENDIF + an(ix,1,kz,lns) = csw(ix,kz,jy) + an(ix,1,kz,lnh) = chw(ix,kz,jy) + IF ( lhl > 1 ) an(ix,1,kz,lnhl) = chl(ix,kz,jy) + ENDIF + IF ( lvh > 0 ) an(ix,1,kz,lvh) = vhw(ix,kz,jy) + IF ( lvhl > 0 .and. present( vhl ) ) an(ix,1,kz,lvhl) = vhl(ix,kz,jy) + + + + + + + IF ( present( tt ) ) THEN + t0(ix,1,kz) = tt(ix,kz,jy) ! temperature (Kelvin) + ELSE + t0(ix,1,kz) = th(ix,kz,jy)*pii(ix,kz,jy) ! temperature (Kelvin) + ENDIF + t1(ix,1,kz) = 0.0 + t2(ix,1,kz) = 0.0 + t3(ix,1,kz) = 0.0 + t4(ix,1,kz) = 0.0 + t5(ix,1,kz) = 0.0 + t6(ix,1,kz) = 0.0 + t7(ix,1,kz) = 0.0 + t8(ix,1,kz) = 0.0 + t9(ix,1,kz) = 0.0 + t00(ix,1,kz) = 380.0/p(ix,kz,jy) + t77(ix,1,kz) = pii(ix,kz,jy) + dbz2d(ix,1,kz) = 0.0 + vzf2d(ix,1,kz) = 0.0 + + dn1(ix,1,kz) = dn(ix,kz,jy) + pn(ix,1,kz) = p(ix,kz,jy) + wn(ix,1,kz) = w(ix,kz,jy) +! wmax = Max(wmax,wn(ix,1,kz)) + dz2d(ix,1,kz) = dz(ix,kz,jy) + dz2dinv(ix,1,kz) = 1./dz(ix,kz,jy) + + ltemq = Int( (t0(ix,1,kz)-163.15)/fqsat+1.5 ) + ltemq = Min( nqsat, Max(1,ltemq) ) +! +! saturation mixing ratio +! + t8s = t00(ix,1,kz)*tabqvs(ltemq) !saturation mixing ratio wrt water + t9s = t00(ix,1,kz)*tabqis(ltemq) !saturation mixing ratio wrt ice + +! +! calculate rate of nucleation +! + ssival = Min(t8s,max(an(ix,1,kz,lv),0.0))/t9s ! qv/qvi + + if ( ssival .gt. 1.0 ) then +! + IF ( icenucopt == 1 ) THEN + + if ( t0(ix,1,kz).le.268.15 ) then + + dp1 = dn1(ix,1,kz)/rho00*cnin20*exp( Min( 57.0 ,(cnin2a*(ssival-1.0)-cnin2b) ) ) + t7(ix,1,kz) = Min(dp1, 1.0d30) + end if + +! +! Default value of imeyers5 turns off nucleation by Meyer at higher temperatures +! This is really from Ferrier (1994), eq. 4.31 - 4.34 + IF ( imeyers5 ) THEN + if ( t0(ix,1,kz).lt.tfr .and. t0(ix,1,kz).gt.268.15 ) then + qvapor = max(an(ix,1,kz,lv),0.0) + ssifac = 0.0 + if ( (qvapor-t9s) .gt. 1.0e-5 ) then + if ( (t8s-t9s) .gt. 1.0e-5 ) then + ssifac = (qvapor-t9s) /(t8s-t9s) + ssifac = ssifac**cnin1a + end if + end if + t7(ix,1,kz) = dn1(ix,1,kz)/rho00*cnin10*ssifac*exp(-(t0(ix,1,kz)-tfr)*bta1) + end if + ENDIF + +! t7max = Max(t7max, t7(ix,1,kz) ) + + ELSEIF ( icenucopt == 2 ) THEN ! Thompson/Cooper; Note Thompson 2004 has constants of + ! 0.005 and 0.304 because the line function was estimated from Cooper plot + ! Here, the fit line values from Cooper 1986 are converted. Very little difference + ! in practice + + t7(ix,1,kz) = 1000.*0.00446684*exp(0.3108*(273.16 - Max(233.0, t0(ix,1,kz) ) ) ) ! factor of 1000 to convert L**-1 to m**-3 + +! write(0,*) 'Cooper t7,ssival = ',ix,kz,t7(ix,1,kz),ssival + + ELSEIF ( icenucopt == 3 ) THEN ! Phillips (Meyers/DeMott) + + if ( t0(ix,1,kz).le.268.15 .and. t0(ix,1,kz) > 243.15 ) then ! Meyers with factor of Psi=0.06 + + dp1 = 0.06*cnin20*exp( Min( 57.0 ,(cnin2a*(ssival-1.0)-cnin2b) ) ) + t7(ix,1,kz) = Min(dp1, 1.0d30) + elseif ( t0(ix,1,kz) <= 243.15 ) then ! Phillips estimate of DeMott et al (2003) data + dp1 = 1000.*( exp( Min( 57.0 ,cnin2a*(ssival-1.1) ) ) )**0.3 + t7(ix,1,kz) = Min(dp1, 1.0d30) + + end if + + ELSEIF ( icenucopt == 4 ) THEN ! DeMott 2010 + + IF ( t0(ix,jy,kz) < 268.16 .and. t0(ix,jy,kz) > 223.15 .and. ssival > 1.001 ) THEN ! + + ! a = 0.0000594, b = 3.33, c = 0.0264, d = 0.0033, + ! nint = a*(-Tc)**b * naer**(c*(-Tc) + d) + ! nint has units of per (standard) liter, so mult by 1.e3 and scale by dn/rho00 + ! naer needs units of cm**-3, so mult by 1.e-6 + + ! dp1 = 1.e3*0.0000594*(273.16 - t0(ix,jy,kz))**3.33 * (1.e-6*cin*dn(ix,jy,kz))**(0.0264*(273.16 - t0(ix,jy,kz)) + 0.0033) + dp1 = 1.e3*dn(ix,jy,kz)/rho00*0.0000594*(273.16 - t0(ix,jy,kz))**3.33 * (1.e-6*naer)**(0.0264*(273.16 - t0(ix,jy,kz)) + 0.0033) + t7(ix,jy,kz) = Min(dp1, 1.0d30) + + ELSE + t7(ix,jy,kz) = 0.0 + ENDIF + + ENDIF ! icenucopt + + +! + end if ! ( ssival .gt. 1.0 ) +! + + ENDDO ! ix + ENDDO ! kz + + has_wetscav = .false. + IF ( wrfchem_flag > 0 ) THEN + IF ( PRESENT( wetscav_on ) ) THEN + has_wetscav = wetscav_on + IF ( has_wetscav ) THEN + IF ( PRESENT( rainprod ) ) rainprod2d(its:ite,kts:kte) = 0 + IF ( PRESENT( evapprod ) ) evapprod2d(its:ite,kts:kte) = 0 + ENDIF + ENDIF + ENDIF + + + ! transform from number mixing ratios to number conc. + + DO il = lnb,na + IF ( denscale(il) == 1 ) THEN + DO kz = kts,kte + DO ix = its,ite + an(ix,1,kz,il) = an(ix,1,kz,il)*dn(ix,kz,jy) + ENDDO + ENDDO + ENDIF + ENDDO ! il + +! sedimentation + xfall(:,:,:) = 0.0 + + IF ( .true. ) THEN + + +! #ifndef CM1 +! for real cases when hydrometeor mixing ratios have been initialized without concentrations + IF ( itimestep == 1 .and. ipconc > 0 ) THEN + call calcnfromq(nx,ny,nz,an,na,nor,nor,dn1) + ENDIF +! IF ( itimestep == 3 .and. ipconc > 0 ) THEN +! call calcnfromq(nx,ny,nz,an,na,nor,nor,dn1) +! ENDIF +! #endif + + IF ( present(cu_used) .and. & + ( present( qrcuten ) .or. present( qscuten ) .or. & + present( qicuten ) .or. present( qccuten ) ) ) THEN + + IF ( cu_used == 1 ) THEN + DO kz = kts,kte + DO ix = its,ite + + IF ( present( qrcuten ) ) ancuten(ix,1,kz,lr) = dtp*qrcuten(ix,kz,jy) + IF ( present( qscuten ) ) ancuten(ix,1,kz,ls) = dtp*qscuten(ix,kz,jy) + IF ( present( qicuten ) ) ancuten(ix,1,kz,li) = dtp*qicuten(ix,kz,jy) + IF ( present( qccuten ) ) ancuten(ix,1,kz,lc) = dtp*qccuten(ix,kz,jy) + + ENDDO + ENDDO + + call calcnfromcuten(nx,ny,nz,ancuten,an,na,nor,nor,dn1) + + + ENDIF + + ENDIF + + + call sediment1d(dtp,nx,ny,nz,an,na,nor,nor,xfall,dn1,dz2d,dz2dinv, & + & t0,t7,infdo,jy,its,jts & + & ,timesed1,timesed2,timesed3,zmaxsed,timesetvt) + + +! copy xfall to appropriate places... + + IF ( debugdriver ) write(0,*) 'N2M: end sediment, jy = ',jy + + DO ix = its,ite + IF ( lhl > 1 ) THEN + RAINNCV(ix,jy) = dtp*dn1(ix,1,1)*(xfall(ix,1,lr) + xfall(ix,1,ls)*1000./xdn0(lr) + & + & xfall(ix,1,lh)*1000./xdn0(lr) + xfall(ix,1,lhl)*1000./xdn0(lr) ) + ELSE + RAINNCV(ix,jy) = dtp*dn1(ix,1,1)*(xfall(ix,1,lr) + xfall(ix,1,ls)*1000./xdn0(lr) + & + & xfall(ix,1,lh)*1000./xdn0(lr) ) + ENDIF + IF ( present ( rainncw2 ) ) THEN ! rain only + rainncw2(ix,jy) = rainncw2(ix,jy) + dtp*dn1(ix,1,1)*xfall(ix,1,lr) + ENDIF + IF ( present ( rainnci2 ) ) THEN ! ice only + IF ( lhl > 1 ) THEN + rainnci2(ix,jy) =rainnci2(ix,jy) + dtp*dn1(ix,1,1)*(xfall(ix,1,ls)*1000./xdn0(lr) + & + & xfall(ix,1,lh)*1000./xdn0(lr) + xfall(ix,1,lhl)*1000./xdn0(lr) ) + ELSE + rainnci2(ix,jy) = rainnci2(ix,jy) + dtp*dn1(ix,1,1)*(xfall(ix,1,ls)*1000./xdn0(lr) + & + & xfall(ix,1,lh)*1000./xdn0(lr) ) + ENDIF + ENDIF + IF ( present( SNOWNCV ) ) SNOWNCV(ix,jy) = dtp*dn1(ix,1,1)*xfall(ix,1,ls)*1000./xdn0(lr) + IF ( present( GRPLNCV ) ) THEN + IF ( lhl > 1 .and. .not. present( HAILNC) ) THEN ! if no separate hail accum, then add to graupel + GRPLNCV(ix,jy) = dtp*dn1(ix,1,1)*(xfall(ix,1,lh) + xfall(ix,1,lhl)) *1000./xdn0(lr) + ELSE + GRPLNCV(ix,jy) = dtp*dn1(ix,1,1)*xfall(ix,1,lh)*1000./xdn0(lr) + ENDIF + ENDIF + RAINNC(ix,jy) = RAINNC(ix,jy) + RAINNCV(ix,jy) + + IF ( present (SNOWNC) .and. present (SNOWNCV) ) SNOWNC(ix,jy) = SNOWNC(ix,jy) + SNOWNCV(ix,jy) + IF ( lhl > 1 ) THEN +!#ifdef CM1 +! IF ( .true. ) THEN +!#else + IF ( present( HAILNC ) ) THEN +!#endif + HAILNCV(ix,jy) = dtp*dn1(ix,1,1)*xfall(ix,1,lhl)*1000./xdn0(lr) + HAILNC(ix,jy) = HAILNC(ix,jy) + HAILNCV(ix,jy) +! ELSEIF ( present( GRPLNCV ) ) THEN ! if no separate hail accum, then add to graupel +! GRPLNCV(ix,jy) = GRPLNCV(ix,jy) + dtp*dn1(ix,1,1)*xfall(ix,1,lhl)*1000./xdn0(lr) + ENDIF + ENDIF + IF ( present( GRPLNCV ) ) GRPLNC(ix,jy) = GRPLNC(ix,jy) + GRPLNCV(ix,jy) + IF ( present( SR ) .and. present (SNOWNCV) .and. present(GRPLNCV) ) THEN + IF ( present( HAILNC ) ) THEN + SR(ix,jy) = (SNOWNCV(ix,jy)+HAILNCV(ix,jy)+GRPLNCV(ix,jy))/(RAINNCV(ix,jy)+1.e-12) + ELSE + SR(ix,jy) = (SNOWNCV(ix,jy)+GRPLNCV(ix,jy))/(RAINNCV(ix,jy)+1.e-12) + ENDIF + ENDIF + ENDDO + + ENDIF ! .false. + + IF ( isedonly /= 1 ) THEN + ! call nssl_2mom_gs: main gather-scatter routine to calculate microphysics + + IF ( debugdriver ) write(0,*) 'N2M: gs, jy = ',jy +! IF ( isedonly /= 2 ) THEN + + + call nssl_2mom_gs & + & (nx,ny,nz,na,jy & + & ,nor,nor & + & ,dtp,dz2d & + & ,t0,t1,t2,t3,t4,t5,t6,t7,t8,t9 & + & ,an,dn1,t77 & + & ,pn,wn,0 & + & ,t00,t77, & + & ventr,ventc,c1sw,1,ido, & + & xdnmx,xdnmn, & +! & ln,ipc,lvol,lz,lliq, & + & cdx, & + & xdn0,dbz2d,tke2d, & + & thproclocal,nproc,dx1,dy1, & + & timevtcalc,axtra2d, makediag & + & ,has_wetscav, rainprod2d, evapprod2d & + & ,errmsg,errflg & + & ,elec2,its,ids,ide,jds,jde & + & ) + + + + + ENDIF ! isedonly /= 1 + + ! droplet nucleation/condensation/evaporation + IF ( .true. ) THEN + CALL NUCOND & + & (nx,ny,nz,na,jy & + & ,nor,nor,dtp,nx & + & ,dz2d & + & ,t0,t9 & + & ,an,dn1,t77 & + & ,pn,wn & + & ,axtra2d, makediag & + & ,ssat,t00,t77,flag_qndrop) + + + ENDIF + + + + IF ( present( pcc2 ) .and. makediag ) THEN + DO kz = kts,kte + DO ix = its,ite +! example of using the 'axtra2d' array to get rates out of the microphysics routine for output. +! Search for 'axtra' to find example code below +! pcc2(ix,kz,jy) = axtra2d(ix,1,kz,1) + + ENDDO + ENDDO + ENDIF + + +! compute diagnostic S-band reflectivity if needed + IF ( present( dbz ) .and. makediag ) THEN + ! calc dbz + + IF ( .true. ) THEN + IF ( present(ke_diag) ) THEN + kediagloc = ke_diag + ELSE + kediagloc = nz + ENDIF + call radardd02(nx,ny,nz,nor,na,an,t0, & + & dbz2d,dn1,nz,cnoh,rho_qh,ipconc,kediagloc, 0) + ENDIF ! .false. + + + DO kz = kts,kediagloc ! kte + DO ix = its,ite + dbz(ix,kz,jy) = dbz2d(ix,1,kz) + IF ( present( vzf ) ) THEN + vzf(ix,kz,jy) = vzf2d(ix,1,kz) + IF ( dbz2d(ix,1,kz) <= 0.0 ) THEN + vzf(ix,kz,jy) = 0.0 + ELSEIF ( dbz2d(ix,1,kz) <= 15.0 ) THEN + refl = 10**(0.1*dbz2d(ix,1,kz)) + vzf(ix,kz,jy) = Min( vzf2d(ix,1,kz), 2.6 * Max(0.0,refl)**0.107 * (1.2/dn1(ix,1,kz))**0.4 ) + ENDIF + ENDIF + IF ( present( compdbz ) ) THEN + compdbz(ix,jy) = Max( compdbz(ix,jy), dbz2d(ix,1,kz) ) + ENDIF + ENDDO + ENDDO + + ENDIF + + + +! Following Greg Thompson, calculation for effective radii. Used by RRTMG LW/SW schemes if enabled in module_physics_init.F + IF ( present( has_reqc ).and. present( has_reqi ) .and. present( has_reqs ) .and. & + present( re_cloud ).and. present( re_ice ) .and. present( re_snow ) ) THEN + IF ( has_reqc.ne.0 .or. has_reqi.ne.0 .or. has_reqs.ne.0) THEN + DO kz = kts,kte + DO ix = its,ite + re_cloud(ix,kz,jy) = 2.51E-6 + re_ice(ix,kz,jy) = 10.01E-6 + re_snow(ix,kz,jy) = 25.E-6 + t1(ix,1,kz) = 2.51E-6 + t2(ix,1,kz) = 10.01E-6 + t3(ix,1,kz) = 25.E-6 + t4(ix,1,kz) = 50.e-6 + ENDDO + ENDDO + + + call calc_eff_radius & + & (nx,ny,nz,na,jy & + & ,nor,nor & + & ,t1=t1,t2=t2,t3=t3,t4=t4 & + & ,an=an,dn=dn1 ) + + DO kz = kts,kte + DO ix = its,ite + re_cloud(ix,kz,jy) = MAX(2.51E-6, MIN(t1(ix,1,kz), 50.E-6)) + re_ice(ix,kz,jy) = MAX(10.01E-6, MIN(t2(ix,1,kz), 200.E-6)) + re_snow(ix,kz,jy) = MAX(25.E-6, MIN(t3(ix,1,kz), 999.E-6)) + ! check for case where snow needs to be treated as cloud ice (for rrtmg radiation) + IF ( .not. present(qi) ) re_ice(ix,kz,jy) = MAX(10.E-6, MIN(t3(ix,1,kz), 200.E-6)) + ENDDO + ENDDO + + IF ( present(has_reqr) .and. present( re_rain ) ) THEN + IF ( has_reqr /= 0 ) THEN + DO kz = kts,kte + DO ix = its,ite + re_rain(ix,kz,jy) = MAX(50.E-6, MIN(t4(ix,1,kz), 2999.E-6)) + ENDDO + ENDDO + ENDIF + ENDIF + + ENDIF + ENDIF + + + + +! transform concentrations back to mixing ratios + DO il = lnb,na + IF ( denscale(il) == 1 ) THEN + DO kz = kts,kte + DO ix = its,ite + an(ix,1,kz,il) = an(ix,1,kz,il)/dn(ix,kz,jy) + ENDDO + ENDDO + ENDIF + ENDDO ! il + + ! copy 2D slabs back to 3D + + + DO kz = kts,kte + DO ix = its,ite + + IF ( present( tt ) ) THEN + tt(ix,kz,jy) = t0(ix,1,kz) + ELSE + th(ix,kz,jy) = an(ix,1,kz,lt) + ENDIF + + qv(ix,kz,jy) = an(ix,1,kz,lv) + qc(ix,kz,jy) = an(ix,1,kz,lc) + qr(ix,kz,jy) = an(ix,1,kz,lr) + IF ( present(qi) ) qi(ix,kz,jy) = an(ix,1,kz,li) + qs(ix,kz,jy) = an(ix,1,kz,ls) + qh(ix,kz,jy) = an(ix,1,kz,lh) + IF ( lhl > 1 ) qhl(ix,kz,jy) = an(ix,1,kz,lhl) + + IF ( lccn > 1 .and. is_aerosol_aware .and. flag_qnwfa ) THEN + ! not used here + ELSEIF ( present( cn ) .and. lccn > 1 .and. .not. flag_qndrop) THEN + IF ( lccna > 1 .and. .not. ( present( cna ) .and. f_cnatmp ) ) THEN + cn(ix,kz,jy) = Max(0.0, an(ix,1,kz,lccna) ) + ELSE + cn(ix,kz,jy) = an(ix,1,kz,lccn) + ENDIF + ENDIF + IF ( lccna > 1 ) THEN + IF ( present( cna ) .and. f_cnatmp ) THEN + cna(ix,kz,jy) = Max(0.0, an(ix,1,kz,lccna) ) + ENDIF + ENDIF + + IF ( lcina > 1 ) THEN + IF ( present( cni ) .and. f_cinatmp ) THEN + cni(ix,kz,jy) = Max(0.0, an(ix,1,kz,lcina) ) + ENDIF + ENDIF + + IF ( ipconc >= 5 ) THEN + + ccw(ix,kz,jy) = an(ix,1,kz,lnc) + crw(ix,kz,jy) = an(ix,1,kz,lnr) + IF ( present( cci ) ) cci(ix,kz,jy) = an(ix,1,kz,lni) + csw(ix,kz,jy) = an(ix,1,kz,lns) + chw(ix,kz,jy) = an(ix,1,kz,lnh) + IF ( lhl > 1 ) chl(ix,kz,jy) = an(ix,1,kz,lnhl) + ENDIF + + + + + IF ( lvh > 0 ) vhw(ix,kz,jy) = an(ix,1,kz,lvh) + IF ( lvhl > 0 .and. present( vhl ) ) vhl(ix,kz,jy) = an(ix,1,kz,lvhl) + +#if ( WRF_CHEM == 1 ) + IF ( has_wetscav ) THEN + IF ( PRESENT( rainprod ) ) rainprod(ix,kz,jy) = rainprod2d(ix,kz) + IF ( PRESENT( evapprod ) ) evapprod(ix,kz,jy) = evapprod2d(ix,kz) + ENDIF +#endif + + ENDDO + ENDDO + + ENDDO ! jy + + + + + + + + RETURN +END SUBROUTINE nssl_2mom_driver + +! ##################################################################### +! ##################################################################### + +!>\ingroup mod_nsslmp +!! Single-precision complete gamma function + REAL FUNCTION GAMMA_SP(xx) + + implicit none + real xx + integer j + +! Double precision ser,stp,tmp,x,y,cof(6) + + real*8 ser,stp,tmp,x,y,cof(6) + SAVE cof,stp + DATA cof,stp/76.18009172947146d+0, & + & -86.50532032941677d0, & + & 24.01409824083091d0, & + & -1.231739572450155d0, & + & 0.1208650973866179d-2,& + & -0.5395239384953d-5, & + & 2.5066282746310005d0/ + + IF ( xx <= 0.0 ) THEN + write(0,*) 'Argument to gamma must be > 0!! xx = ',xx + ENDIF + + x = xx + y = x + tmp = x + 5.5d0 + tmp = (x + 0.5d0)*Log(tmp) - tmp + ser = 1.000000000190015d0 + DO j=1,6 + y = y + 1.0d0 + ser = ser + cof(j)/y + END DO + gamma_sp = Exp(tmp + log(stp*ser/x)) + + RETURN + END FUNCTION GAMMA_SP + +! ##################################################################### + +!>\ingroup mod_nsslmp +!! Douple-precision complete gamma function (single precision input) + DOUBLE PRECISION FUNCTION GAMMA_DPR(x) + ! dp gamma with real input + implicit none + real :: x + double precision :: xx + + xx = x + + gamma_dpr = gamma_dp(xx) + + return + end FUNCTION GAMMA_DPR + + + + +! ##################################################################### + +!>\ingroup mod_nsslmp +!! single-precision incomplete gamma function (single precision args) + real function GAMXINF(A1,X1) + +! =================================================== +! Purpose: Compute the incomplete gamma function +! from x to infinity +! Input : a --- Parameter ( a 170 ) +! x --- Argument +! Output: GIM --- gamma(a,x) t=x,Infinity +! Routine called: GAMMA for computing gamma(x) +! =================================================== + +! IMPLICIT DOUBLE PRECISION (A-H,O-Z) + implicit none + real :: a1,x1 + double precision :: xam,dlog,s,r,ga,t0,a,x + integer :: k + double precision :: gin, gim + + a = a1 + x = x1 + IF ( x1 <= 0.0 ) THEN + gamxinf = GAMMA_SP(A1) + return + ENDIF + XAM=-X+A*DLOG(X) + IF (XAM.GT.700.0.OR.A.GT.170.0) THEN + WRITE(*,*)'a and/or x too large' + ENDIF + IF (X.EQ.0.0) THEN + GIN=0.0 + GIM = GAMMA_SP(A1) + ELSE IF (X.LE.1.0+A) THEN + S=1.0D0/A + R=S + DO 10 K=1,60 + R=R*X/(A+K) + S=S+R + IF (DABS(R/S).LT.1.0D-15) GO TO 15 +10 CONTINUE +15 GIN=DEXP(XAM)*S + ga = GAMMA_SP(A1) + GIM=GA-GIN + ELSE IF (X.GT.1.0+A) THEN + T0=0.0D0 + DO 20 K=60,1,-1 + T0=(K-A)/(1.0D0+K/(X+T0)) +20 CONTINUE + GIM=DEXP(XAM)/(X+T0) +! GA = GAMMA_SP(A1) +! GIN=GA-GIM + ENDIF + + gamxinf = GIM + return + END function GAMXINF + +! ##################################################################### + +!>\ingroup mod_nsslmp +!! Double-precision incomplete gamma function (single precision args) + double precision function GAMXINFDP(A1,X1) + +! =================================================== +! Purpose: Compute the incomplete gamma function +! from x to infinity +! Input : a --- Parameter ( a < 170 ) +! x --- Argument +! Output: GIM --- Gamma(a,x) t=x,Infinity +! Routine called: GAMMA for computing gamma_dp(x) +! =================================================== + +! IMPLICIT DOUBLE PRECISION (A-H,O-Z) + implicit none + real :: a1,x1 +! dont declare gamma_dp because it is within the module +! double precision :: gamma_dp + double precision :: xam,dlog,s,r,ga,t0,a,x + integer :: k + double precision :: gin, gim + + a = a1 + x = x1 + IF ( x1 <= 0.0 ) THEN + gamxinfdp = GAMMA_DP(A) + return + ENDIF + XAM=-X+A*DLOG(X) + IF (XAM.GT.700.0.OR.A.GT.170.0) THEN + WRITE(*,*)'a and/or x too large' + ENDIF + IF (X.EQ.0.0) THEN + GIN=0.0 + GIM = GAMMA_dp(A) + ELSE IF (X.LE.1.0+A) THEN + S=1.0D0/A + R=S + DO 10 K=1,60 + R=R*X/(A+K) + S=S+R + IF (DABS(R/S).LT.1.0D-15) GO TO 15 +10 CONTINUE +15 GIN=DEXP(XAM)*S + ga = GAMMA_DP(A) + GIM=GA-GIN + ELSE IF (X.GT.1.0+A) THEN + T0=0.0D0 + DO 20 K=60,1,-1 + T0=(K-A)/(1.0D0+K/(X+T0)) +20 CONTINUE + GIM=DEXP(XAM)/(X+T0) +! GA = GAMMA_dp(A) +! GIN=GA-GIM + ENDIF + + gamxinfdp = GIM + return + END function GAMXINFDP + + +! ##################################################################### + +!>\ingroup mod_nsslmp +!! Function to interpolate from a table of incomplete gamma function values + real function gaminterp(ratio, alp, luindex, ilh) + + implicit none + + real, intent(in) :: ratio, alp + integer, intent(in) :: ilh ! 1 = graupel, 2 = hail + integer, intent(in) :: luindex ! which argument: + ! gamxinflu(i,j,1,1) = x/y + ! gamxinflu(i,j,2,1) = gamxinf( 2.0+alp, ratio )/y + ! gamxinflu(i,j,3,1) = gamxinf( 2.5+alp+0.5*bxh, ratio )/y + ! gamxinflu(i,j,5,1) = gamxinf( 5.0+alp, ratio )/y + ! gamxinflu(i,j,6,1) = gamxinf( 5.5+alp+0.5*bxh, ratio )/y + + + real :: delx, dely, tmp1, tmp2, temp3 + integer :: i,j,ip1,jp1 !,ilh + +! ilh = Abs(ilh0) + + + i = Min(nqiacrratio,Int(ratio*dqiacrratioinv)) + j = Int(Max(0.0,Min(maxalphalu,alp))*dqiacralphainv) + delx = Min(maxratiolu,ratio) - float(i)*dqiacrratio + dely = alp - float(j)*dqiacralpha + ip1 = Min( i+1, nqiacrratio ) + jp1 = Min( j+1, nqiacralpha ) + + ! interpolate along x, i.e., ratio; + tmp1 = gamxinflu(i,j,luindex,ilh) + delx*dqiacrratioinv* & + & (gamxinflu(ip1,j,luindex,ilh) - gamxinflu(i,j,luindex,ilh)) + tmp2 = gamxinflu(i,jp1,luindex,ilh) + delx*dqiacrratioinv* & + & (gamxinflu(ip1,jp1,luindex,ilh) - gamxinflu(i,jp1,luindex,ilh)) + + ! interpolate along alpha; + + gaminterp = (tmp1 + dely*dqiacralphainv*(tmp2 - tmp1)) + + ! debug +! IF ( ilh0 < 0 ) THEN +! write(0,*) 'gaminterp: ',i,j,ilh,ratio,delx,dely,gamxinflu(i,j,luindex,ilh),tmp1,tmp2 +! ENDIF + + END FUNCTION gaminterp +! ##################################################################### + +!**************************** GAML02 *********************** +! This calculates Gamma(0.2,x)/Gamma[0.2], where is a ratio +! It is used for qiacr with the gamma of volume to calculate what +! fraction of drops exceed a certain size (this version is for 40 micron drops) +! ********************************************************** +!>\ingroup mod_nsslmp +!! Function calculates Gamma(0.2,x)/Gamma[0.2] for 40 micro drops ( imurain == 3 ) + real FUNCTION GAML02(x) + implicit none + integer ig, i, ii, n, np + real x + integer ng + parameter(ng=12) + real gamxg(ng), xg(ng) + DATA xg/0.01,0.02,0.025,0.04,0.075,0.1,0.25,0.5,0.75,1.,2.,10./ + DATA gamxg/ & + & 7.391019203578037e-8,0.02212726874591478,0.06959352407989682, & + & 0.2355654024970809,0.46135930387500346,0.545435791452399, & + & 0.7371571313308203, & + & 0.8265676632204345,0.8640182781845841,0.8855756211304151, & + & 0.9245079225301251, & + & 0.9712578342732681/ + IF ( x .ge. xg(ng) ) THEN + gaml02 = xg(ng) + RETURN + ENDIF + IF ( x .lt. xg(1) ) THEN + gaml02 = 0.0 + RETURN + ENDIF + DO ii = 1,ng-1 + i = ng - ii + n = i + np = n + 1 + IF ( x .ge. xg(i) ) THEN +! GOTO 2 + gaml02 = gamxg(N)+((X-XG(N))/(XG(NP)-XG(N)))* & + & ( gamxg(NP) - gamxg(N) ) + RETURN + ENDIF + ENDDO + RETURN + END FUNCTION GAML02 + +!**************************** GAML02d300 *********************** +! This calculates Gamma(0.2,x)/Gamma[0.2], where is a ratio +! It is used for qiacr with the gamma of volume to calculate what +! fraction of drops exceed a certain size (this version is for 300 micron drops) (see zieglerstuff.nb) +! ********************************************************** +!>\ingroup mod_nsslmp +!! Function calculates fraction of drops larger than 300 microns ( imurain == 3 ) + real FUNCTION GAML02d300(x) + implicit none + integer ig, i, ii, n, np + real x + integer ng + parameter(ng=9) + real gamxg(ng), xg(ng) + DATA xg/0.04,0.075,0.1,0.25,0.5,0.75,1.,2.,10./ + DATA gamxg/ & + & 0.0, & + & 7.391019203578011e-8,0.0002260640810600053, & + & 0.16567071824457152, & + & 0.4231369044918005,0.5454357914523988, & + & 0.6170290936864555, & + & 0.7471346054110058,0.9037156157718299 / + IF ( x .ge. xg(ng) ) THEN + GAML02d300 = xg(ng) + RETURN + ENDIF + IF ( x .lt. xg(1) ) THEN + GAML02d300 = 0.0 + RETURN + ENDIF + DO ii = 1,ng-1 + i = ng - ii + n = i + np = n + 1 + IF ( x .ge. xg(i) ) THEN +! GOTO 2 + GAML02d300 = gamxg(N)+((X-XG(N))/(XG(NP)-XG(N)))* & + & ( gamxg(NP) - gamxg(N) ) + RETURN + ENDIF + ENDDO + RETURN + END FUNCTION GAML02d300 +!c + +! ##################################################################### +! ##################################################################### + +!**************************** GAML02 *********************** +! This calculates Gamma(0.2,x)/Gamma[0.2], where is a ratio +! It is used for qiacr with the gamma of volume to calculate what +! fraction of drops exceed a certain size (this version is for 500 micron drops) (see zieglerstuff.nb) +! ********************************************************** +!>\ingroup mod_nsslmp +!! Function calculates Gamma(0.2,x)/Gamma[0.2] for 500 micro drops ( imurain == 3 ) + real FUNCTION GAML02d500(x) + implicit none + integer ig, i, ii, n, np + real x + integer ng + parameter(ng=9) + real gamxg(ng), xg(ng) + DATA xg/0.04,0.075,0.1,0.25,0.5,0.75,1.,2.,10./ + DATA gamxg/ & + & 0.0,0.0, & + & 2.2346039e-13, 0.0221272687459, & + & 0.23556540, 0.38710348, & + & 0.48136183,0.6565833, & + & 0.86918315 / + IF ( x .ge. xg(ng) ) THEN + GAML02d500 = xg(ng) + RETURN + ENDIF + IF ( x .lt. xg(1) ) THEN + GAML02d500 = 0.0 + RETURN + ENDIF + DO ii = 1,ng-1 + i = ng - ii + n = i + np = n + 1 + IF ( x .ge. xg(i) ) THEN +! GOTO 2 + GAML02d500 = gamxg(N)+((X-XG(N))/(XG(NP)-XG(N)))* & + & ( gamxg(NP) - gamxg(N) ) + RETURN + ENDIF + ENDDO + RETURN + END FUNCTION GAML02d500 +!c + +! ##################################################################### + +! ##################################################################### + + + real function BETA(P,Q) +! +! ========================================== +! Purpose: Compute the beta function B(p,q) +! Input : p --- Parameter ( p > 0 ) +! q --- Parameter ( q > 0 ) +! Output: BT --- B(p,q) +! Routine called: GAMMA for computing gamma(x) +! ========================================== +! +! IMPLICIT real (A-H,O-Z) + implicit none + double precision p1,gp,q1,gq, ppq,gpq + real p,q + + p1 = p + q1 = q + CALL GAMMADP(P1,GP) + CALL GAMMADP(Q1,GQ) + PPQ=P1+Q1 + CALL GAMMADP(PPQ,GPQ) + beta=GP*GQ/GPQ + RETURN + END function BETA + +! ##################################################################### +! ##################################################################### + +!>\ingroup mod_nsslmp +!! Douple-precision complete gamma function (double precision argument) + DOUBLE PRECISION FUNCTION GAMMA_DP(xx) + + implicit none + double precision xx + integer j + +! Double precision ser,stp,tmp,x,y,cof(6) + + real*8 ser,stp,tmp,x,y,cof(6) + SAVE cof,stp + DATA cof,stp/76.18009172947146d+0, & + & -86.50532032941677d0, & + & 24.01409824083091d0, & + & -1.231739572450155d0, & + & 0.1208650973866179d-2,& + & -0.5395239384953d-5, & + & 2.5066282746310005d0/ + + x = xx + y = x + tmp = x + 5.5d0 + tmp = (x + 0.5d0)*Log(tmp) - tmp + ser = 1.000000000190015d0 + DO j=1,6 + y = y + 1.0d0 + ser = ser + cof(j)/y + END DO + gamma_dp = Exp(tmp + log(stp*ser/x)) + + RETURN + END function gamma_dp +! ##################################################################### + +!>\ingroup mod_nsslmp +!! Double-precision complete gamma function subroutine (used by beta function routine) + SUBROUTINE GAMMADP(X,GA) +! +! ================================================== +! Purpose: Compute gamma function Gamma(x) +! Input : x --- Argument of Gamma(x) +! ( x is not equal to 0,-1,-2,...) +! Output: GA --- gamma(x) +! ================================================== +! +! IMPLICIT DOUBLE PRECISION (A-H,O-Z) + implicit none + + double precision, parameter :: PI=3.141592653589793D0 + double precision :: x,ga,z,r,gr + integer :: k,m1,m + + double precision :: G(26) + + IF (X.EQ.INT(X)) THEN + IF (X.GT.0.0D0) THEN + GA=1.0D0 + M1=X-1 + DO K=2,M1 + GA=GA*K + ENDDO + ELSE + GA=1.0D+300 + ENDIF + ELSE + IF (DABS(X).GT.1.0D0) THEN + Z=DABS(X) + M=INT(Z) + R=1.0D0 + DO K=1,M + R=R*(Z-K) + ENDDO + Z=Z-M + ELSE + Z=X + ENDIF + DATA G/1.0D0,0.5772156649015329D0, & + & -0.6558780715202538D0, -0.420026350340952D-1, & + & 0.1665386113822915D0,-.421977345555443D-1, & + & -.96219715278770D-2, .72189432466630D-2, & + & -.11651675918591D-2, -.2152416741149D-3, & + & .1280502823882D-3, -.201348547807D-4, & + & -.12504934821D-5, .11330272320D-5, & + & -.2056338417D-6, .61160950D-8, & + & .50020075D-8, -.11812746D-8, & + & .1043427D-9, .77823D-11, & + & -.36968D-11, .51D-12, & + & -.206D-13, -.54D-14, .14D-14, .1D-15/ + GR=G(26) + DO K=25,1,-1 + GR=GR*Z+G(K) + ENDDO + GA=1.0D0/(GR*Z) + IF (DABS(X).GT.1.0D0) THEN + GA=GA*R + IF (X.LT.0.0D0) GA=-PI/(X*GA*DSIN(PI*X)) + ENDIF + ENDIF + RETURN + END SUBROUTINE GAMMADP + + +! ##################################################################### +! ##################################################################### +! +! +! ##################################################################### +!>\ingroup mod_nsslmp +!! Function calculates collection coefficients following Siefert (2006) + Function delbk(bb,nu,mu,k) +! +! Purpose: Caluculates collection coefficients following Siefert (2006) +! +! delbk is equation (90) (b collecting b -- self-collection) +! mass-diameter relationship: D = a*x**(b), where x = particle mass +! general distribution: n(x) = A*x**(nu)*Exp(-lam*x**(mu)) +! where +! A = mu*N/(Gamma((nu+1)/mu)) *lam**((nu+1)/mu) +! +! lam = ( Gamma((nu+1)/mu)/Gamma((nu+2)/mu) * xbar )**(-mu) +! +! where xbar = L/N (mass content)/(number concentration) = q*rhoa/N +! + + implicit none + real delbk + real nu, mu, bb + integer k + + real tmp, del + real x1, x2, x3, x4 + integer i + + tmp = ((1.0 + nu)/mu) + i = Int(dgami*(tmp)) + del = tmp - dgam*i + x1 = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami + + tmp = ((2.0 + nu)/mu) + i = Int(dgami*(tmp)) + del = tmp - dgam*i + x2 = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami + + tmp = ((1.0 + 2.0*bb + k + nu)/mu) + i = Int(dgami*(tmp)) + del = tmp - dgam*i + x3 = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami + +! delbk = & +! & ((Gamma_sp((1.0 + nu)/mu)/Gamma_sp((2.0 + nu)/mu))**(2.0*bb + k)* & +! & Gamma_sp((1.0 + 2.0*bb + k + nu)/mu))/Gamma_sp((1.0 + nu)/mu) + + delbk = & + & ((x1/x2)**(2.0*bb + k)* & + & x3)/x1 + + RETURN + END Function delbk + +! ##################################################################### +! +! +! ##################################################################### +! Equation (91) in Seifert and Beheng (2006) ("a" collecting "b") +!>\ingroup mod_nsslmp +!! Function calculates collection coefficients following Siefert (2006) + Function delabk(ba,bb,nua,nub,mua,mub,k) + + implicit none + real delabk + real nua, mua, ba + integer k + real nub, mub, bb + + integer i + real tmp,del + + real g1pnua, g2pnua, g1pbapnua, g1pbbpk, g1pnub, g2pnub + + tmp = (1. + nua)/mua + i = Int(dgami*(tmp)) + del = tmp - dgam*i + IF ( i+1 > ngm0 ) THEN + write(0,*) 'delabk: i+1 > ngm0!!!!',i,ngm0,nua,mua,tmp + ENDIF + g1pnua = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami +! write(91,*) 'delabk: g1pnua,gamma = ',g1pnua,Gamma_sp((1. + nua)/mua) + + tmp = ((2. + nua)/mua) + i = Int(dgami*(tmp)) + del = tmp - dgam*i + g2pnua = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami + + tmp = ((1. + ba + nua)/mua) + i = Int(dgami*(tmp)) + del = tmp - dgam*i + g1pbapnua = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami + + tmp = ((1. + nub)/mub) + i = Int(dgami*(tmp)) + del = tmp - dgam*i + g1pnub = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami + + tmp = ((2 + nub)/mub) + i = Int(dgami*(tmp)) + del = tmp - dgam*i + g2pnub = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami + + tmp = ((1. + bb + k + nub)/mub) + i = Int(dgami*(tmp)) + del = tmp - dgam*i + g1pbbpk = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami + + delabk = & + & (2.*(g1pnua/g2pnua)**ba* & + & g1pbapnua* & + & (g1pnub/g2pnub)**(bb + k)* & + & g1pbbpk)/ & + & (g1pnua*g1pnub) + + RETURN + END Function delabk + + +!>\ingroup mod_nsslmp +!! Sedimentation driver subroutine. Calls fallout column by column + subroutine sediment1d(dtp,nx,ny,nz,an,na,nor,norz,xfall,dn,dz3d,dz3dinv, & + & t0,t7,infdo,jslab,its,jts, & + & timesed1,timesed2,timesed3,zmaxsed,timesetvt) ! used for timing +! +! Sedimentation driver -- column by column +! +! Written by ERM 10/2011 +! +! +! + implicit none + + integer nx,ny,nz,nor,norz,ngt,jgs,na,ia + integer id ! =1 use density, =0 no density + integer :: its,jts ! SW point of local tile + + integer ng1 + parameter(ng1 = 1) + + real an(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz,na) + real dn(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz) + real dz3d(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz) + real dz3dinv(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz) + real t0(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz) + real t7(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz) + +! real gz(-nor+ng1:nz+nor),z1d(-nor+ng1:nz+nor,4) + real dtp + real xfall(nx,ny,na) ! array for stuff landing on the ground + real xfall0(nx,ny) ! dummy array + integer infdo + integer jslab ! which line of xfall to use + + integer ix,jy,kz,ndfall,n,k,il,in + real tmp, vtmax, dtptmp, dtfrac + real, parameter :: dz = 200. + + real :: xvt(nz+1,nx,3,lc:lhab) ! (nx,nz,2,lc:lhab) ! 1=mass-weighted, 2=number-weighted + real :: tmpn(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-norz+ng1:nz+norz) + real :: tmpn2(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-norz+ng1:nz+norz) + real :: z(-nor+ng1:nx+nor,-norz+ng1:nz+norz,lr:lhab) + real :: db1(nx,nz+1),dtz1(nz+1,nx,0:1),dz2dinv(nz+1,nx),db1inv(nx,nz+1) + + real :: rhovtzx(nz,nx) + + double precision :: timesed1,timesed2,timesed3, zmaxsed,timesetvt,dummy + double precision :: dt1,dt2,dt3,dt4 + + integer,parameter :: ngs = 128 + integer :: ngscnt,mgs,ipconc0 + + real :: qx(ngs,lv:lhab) + real :: qxw(ngs,ls:lhab) + real :: cx(ngs,lc:lhab) + real :: xv(ngs,lc:lhab) + real :: vtxbar(ngs,lc:lhab,3) + real :: xmas(ngs,lc:lhab) + real :: xdn(ngs,lc:lhab) + real :: xdia(ngs,lc:lhab,3) + real :: vx(ngs,li:lhab) + real :: alpha(ngs,lc:lhab) + real :: zx(ngs,lr:lhab) + logical :: hasmass(nx,lc+1:lhab) + + integer igs(ngs),kgs(ngs) + + real rho0(ngs),temcg(ngs) + + real temg(ngs) + + real rhovt(ngs) + + real cwnc(ngs),cinc(ngs) + real fadvisc(ngs),cwdia(ngs),cipmas(ngs) + + real cimasn,cimasx,cnina(ngs),cimas(ngs) + + real cnostmp(ngs) + + +!----------------------------------------------------------------------------- + + integer :: ixb, jyb, kzb + integer :: ixe, jye, kze + integer :: plo, phi + + logical :: debug_mpi = .TRUE. + +! ################################################################### + + + + + kzb = 1 + kze = nz + + ixb = 1 + ixe = nx + + + jy = 1 + jgs = jy + + +! +! zero the precip flux arrays (2d) +! + + xvt(:,:,:,:) = 0.0 + + if ( ndebug .gt. 0 ) write(0,*) 'dbg = 3a' + + + DO kz = kzb,kze + DO ix = ixb,ixe + db1(ix,kz) = dn(ix,jy,kz) + db1inv(ix,kz) = 1./dn(ix,jy,kz) + rhovtzx(kz,ix) = Sqrt(rho00*Min(1.0/0.05, db1inv(ix,kz))) ! prevent excessive rhovt + ENDDO + ENDDO + + DO kz = kzb,kze + DO ix = ixb,ixe + dtz1(kz,ix,0) = dz3dinv(ix,jy,kz) + dtz1(kz,ix,1) = dz3dinv(ix,jy,kz)*db1inv(ix,kz) + dz2dinv(kz,ix) = dz3dinv(ix,jy,kz) + ENDDO + ENDDO + + IF ( lzh .gt. 1 ) THEN + DO kz = kzb,kze + DO ix = ixb,ixe + an(ix,jy,kz,lzh) = Max( 0., an(ix,jy,kz,lzh) ) + ENDDO + ENDDO + ENDIF + + + DO il = lc+1,lhab + DO ix = ixb,ixe +! hasmass(ix,il) = Any( an(ix,jy,:,il) > qxmin(il) ) + ENDDO + ENDDO + + + + + if (ndebug .gt. 0 ) write(0,*) 'dbg = 3a2' + +! loop over columns + DO ix = ixb,ixe + + dummy = 0.d0 + + + call ziegfall1d(nx,ny,nz,nor,norz,na,dtp,jgs,ix, & + & xvt, rhovtzx, & + & an,dn,ipconc,t0,t7,cwmasn,cwmasx, & + & cwradn, & + & qxmin,xdnmx,xdnmn,cdx,cno,xdn0,xvmn,xvmx, & + & ngs,qx,qxw,cx,xv,vtxbar,xmas,xdn,xdia,vx,alpha,zx,igs,kgs, & + & rho0,temcg,temg,rhovt,cwnc,cinc,fadvisc,cwdia,cipmas,cnina,cimas, & + & cnostmp, & + & infdo,0 & + & ) + + +! loop over each species and do sedimentation for all moments + DO il = lc,lhab + IF ( ido(il) == 0 ) CYCLE + +! IF ( .not. hasmass(ix,il) ) CYCLE + +! plo = nz +! phi = 0 + + + vtmax = 0.0 + + do kz = kzb,kze + + ! apply limit vtmaxsed (08/20/2015) + xvt(kz,ix,1,il) = Min( vtmaxsed, xvt(kz,ix,1,il) ) + xvt(kz,ix,2,il) = Min( vtmaxsed, xvt(kz,ix,2,il) ) + xvt(kz,ix,3,il) = Min( vtmaxsed, xvt(kz,ix,3,il) ) + + vtmax = Max(vtmax,xvt(kz,ix,1,il)*dz2dinv(kz,ix)) + vtmax = Max(vtmax,xvt(kz,ix,2,il)*dz2dinv(kz,ix)) + vtmax = Max(vtmax,xvt(kz,ix,3,il)*dz2dinv(kz,ix)) + +! IF ( dtp*xvt(kz,ix,1,il)*dz2dinv(kz,ix) >= 0.7 .or. & +! & dtp*xvt(kz,ix,2,il)*dz2dinv(kz,ix) >= 0.7 .or. & +! & dtp*xvt(kz,ix,3,il)*dz2dinv(kz,ix) >= 0.7 ) THEN +! +! zmaxsed = Max(zmaxsed, float(kz) ) +!! plo = Min(plo,kz) +!! phi = Max(phi,kz) +! +! ENDIF + + ENDDO + + IF ( vtmax == 0.0 ) CYCLE + + + + IF ( dtp*vtmax .lt. 0.7 ) THEN ! check whether multiple steps are needed. + ndfall = 1 + ELSE + IF ( dtp > 20.0 ) THEN ! more stringent subdivision for large time steps + ndfall = Max(2, Int(dtp*vtmax/0.7) + 1) + ELSE ! more relaxed for small time steps, but might still be a problem for very thin vertical layers near the ground + ndfall = 1+Int(dtp*vtmax + 0.301) + ENDIF + ENDIF + + IF ( ndfall .gt. 1 ) THEN + dtptmp = dtp/Real(ndfall) +! write(0,*) 'subdivide fallout on its,jts,ix,plo,phi = ',its,jts,ix,plo,phi +! write(0,*) 'for il,jsblab,c,ndfall = ',il,jslab,dtp*vtmax,ndfall + ELSE + dtptmp = dtp + ENDIF + + dtfrac = dtptmp/dtp + + + DO n = 1,ndfall + + IF ( do_accurate_sedimentation .and. n .ge. 2 .and. ( n == interval_sedi_vt*(n/interval_sedi_vt) ) ) THEN +! +! zero the precip flux arrays (2d) +! + + dummy = 0.d0 + + xvt(kzb:kze,ix,1:3,il) = 0.0 ! reset to zero because routine will only compute points with q > qmin + + call ziegfall1d(nx,ny,nz,nor,norz,na,dtp,jgs,ix, & + & xvt, rhovtzx, & + & an,dn,ipconc,t0,t7,cwmasn,cwmasx, & + & cwradn, & + & qxmin,xdnmx,xdnmn,cdx,cno,xdn0,xvmn,xvmx, & + & ngs,qx,qxw,cx,xv,vtxbar,xmas,xdn,xdia,vx,alpha,zx,igs,kgs, & + & rho0,temcg,temg,rhovt,cwnc,cinc,fadvisc,cwdia,cipmas,cnina,cimas, & + & cnostmp, & + & infdo,il) + + + DO kz = kzb,kze + ! apply limit vtmaxsed (08/20/2015) + xvt(kz,ix,1,il) = Min( vtmaxsed, xvt(kz,ix,1,il) ) + xvt(kz,ix,2,il) = Min( vtmaxsed, xvt(kz,ix,2,il) ) + xvt(kz,ix,3,il) = Min( vtmaxsed, xvt(kz,ix,3,il) ) + ENDDO + + + + + ENDIF ! (n .ge. 2) + + + IF ( il >= lr .and. ( infall .eq. 3 .or. infall .eq. 4 ) .and. ln(il) > 0 ) THEN + IF ( (il .eq. lr .and. irfall .eq. infall .and. lzr < 1) .or. (il .ge. lh .and. lz(il) .lt. 1 ) ) THEN + call calczgr1d(nx,ny,nz,nor,na,an,ixe,kze, & + & z,db1,jgs,ipconc, dnu(il), il, ln(il), qxmin(il), xvmn(il), xvmx(il), lvol(il), xdn0(il), ix ) + ENDIF + ENDIF + + if (ndebug .gt. 0 ) write(0,*) 'dbg = 1b' + +! mixing ratio + + call fallout1d(nx,ny,nz,nor,na,dtptmp,dtfrac,jgs,xvt(1,1,1,il), & + & an,db1,il,1,xfall,dtz1,ix) + + + if (ndebug .gt. 0 ) write(0,*) 'dbg = 3c' + +! volume + + IF ( ldovol .and. il >= li ) THEN + IF ( lvol(il) .gt. 1 ) THEN + call fallout1d(nx,ny,nz,nor,na,dtptmp,dtfrac,jgs,xvt(1,1,1,il), & + & an,db1,lvol(il),0,xfall,dtz1,ix) + ENDIF + ENDIF + + + if (ndebug .gt. 0 ) write(0,*) 'dbg = 3d' + + + IF ( ipconc .gt. 0 ) THEN !{ + IF ( ipconc .ge. ipc(il) ) THEN + + IF ( ( infall .ge. 2 .or. (infall .eq. 0 .and. il .lt. lh) ) .and. lz(il) .lt. 1) THEN !{ +! +! load number conc. into tmpn to do fallout by mass-weighted mean fall speed +! to put a lower bound on number conc. +! + + IF ( ( infall .eq. 3 .or. infall .eq. 4 ) .and. ( il .eq. lh .or. il .eq. lhl .or. & + & ( il .eq. lr .and. irfall .eq. infall) ) ) THEN + + DO kz = kzb,kze +! DO ix = ixb,ixe + tmpn2(ix,jy,kz) = z(ix,kz,il) +! ENDDO + ENDDO + DO kz = kzb,kze +! DO ix = ixb,ixe + tmpn(ix,jy,kz) = an(ix,jy,kz,ln(il)) +! ENDDO + ENDDO + + ELSE + + DO kz = kzb,kze +! DO ix = ixb,ixe + tmpn(ix,jy,kz) = an(ix,jy,kz,ln(il)) +! ENDDO + ENDDO + + ENDIF + + ENDIF !} + + + if (ndebug .gt. 0 ) write(0,*) 'dbg = 3f' + + in = 2 + IF ( infall .eq. 1 ) in = 1 + + call fallout1d(nx,ny,nz,nor,na,dtptmp,dtfrac,jgs,xvt(1,1,in,il), & + & an,db1,ln(il),0,xfall,dtz1,ix) + + + IF ( lz(il) .lt. 1 ) THEN ! if not 3-moment, run one of the correction schemes + IF ( (infall .ge. 2 .or. infall .eq. 3) .and. .not. (infall .eq. 0 .and. il .ge. lh) & + & .and. ( il .eq. lr .or. (il .ge. li .and. il .le. lhab) )) THEN +! : .or. il .eq. lhl )) THEN + + xfall0(:,jgs) = 0.0 + + IF ( ( infall .eq. 3 .or. infall .eq. 4 ) .and. & + & ( il .ge. lh .or. (il .eq. lr .and. irfall .eq. infall) ) ) THEN + call fallout1d(nx,ny,nz,nor,1,dtptmp,dtfrac,jgs,xvt(1,1,3,il), & + & tmpn2,db1,1,0,xfall0,dtz1,ix) + call fallout1d(nx,ny,nz,nor,1,dtptmp,dtfrac,jgs,xvt(1,1,1,il), & + & tmpn,db1,1,0,xfall0,dtz1,ix) + ELSE + call fallout1d(nx,ny,nz,nor,1,dtptmp,dtfrac,jgs,xvt(1,1,1,il), & + & tmpn,db1,1,0,xfall0,dtz1,ix) + ENDIF + + IF ( ( infall .eq. 3 .or. infall .eq. 4 ) .and. ( (il .eq. lr .and. irfall .eq. infall) & + & .or. il .ge. lh ) ) THEN +! "Method I" - dbz correction + + call calcnfromz1d(nx,ny,nz,nor,na,an,tmpn2,ixe,kze, & + & z,db1,jgs,ipconc, dnu(il), il, ln(il), qxmin(il), xvmn(il), xvmx(il),tmpn, & + & lvol(il), rho_qh, infall, ix) + + ELSEIF ( infall .eq. 5 .and. il .ge. lh .or. ( il == lr .and. irfall == 5 ) ) THEN + + DO kz = kzb,kze +! DO ix = ixb,ixe + an(ix,jgs,kz,ln(il)) = Max( an(ix,jgs,kz,ln(il)), 0.5* ( an(ix,jgs,kz,ln(il)) + tmpn(ix,jy,kz) )) + +! ENDDO + ENDDO + + ELSEIF ( .not. (il .eq. lr .and. irfall .eq. 0) ) THEN +! "Method II" M-wgt N-fallout correction + + DO kz = kzb,kze +! DO ix = ixb,ixe + + an(ix,jgs,kz,ln(il)) = Max( an(ix,jgs,kz,ln(il)), tmpn(ix,jy,kz) ) + +! ENDDO + ENDDO + ENDIF + ENDIF ! lz(il) .lt. 1 + + + ENDIF + ENDIF + + + ENDIF !} + + + ENDDO ! n=1,ndfall + ENDDO ! il + + ENDDO ! ix + + + + + RETURN + END SUBROUTINE SEDIMENT1D + + +! ##################################################################### + +! +! ##################################################################### + + +! +!-------------------------------------------------------------------------- +! +!-------------------------------------------------------------------------- +! +!>\ingroup mod_nsslmp +!! Column sedimentation fallout subroutine + subroutine fallout1d(nx,ny,nz,nor,na,dtp,dtfrac,jgs,vt, & + & a,db1,ia,id,xfall,dtz1,ixcol) +! +! First-order, upwind fallout scheme +! +! Written by ERM 6/10/2011 +! +! +! + implicit none + + integer nx,ny,nz,nor,ngt,jgs,na,ia + integer id ! =1 use density, =0 no density + integer ng1 + parameter(ng1 = 1) + integer :: ixcol + +! real dz3dinv(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-nor+ng1:nz+nor) +! real a(nx,ny,nz,na) + real a(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-nor+ng1:nz+nor,na) ! quantity to be 'advected' + real vt(nz+1,nx) ! terminal speed for a + real dtp,dtfrac + real cmax + real xfall(nx,ny,na) ! array for stuff landing on the ground + real db1(nx,nz+1),dtz1(nz+1,nx,0:1) + +! Local + + integer ix,jy,kz,n,k + integer iv1,iv2 + real tmp + integer imn,imx,kmn,kmx + real qtmp1(nz+1) + +!----------------------------------------------------------------------------- + + integer :: ixb, jyb, kzb + integer :: ixe, jye, kze + + logical :: debug_mpi = .TRUE. + +! ################################################################### + + jy = 1 + + iv1 = 0 + iv2 = 0 + + imn = nx + imx = 1 + kmn = nz + kmx = 1 + + cmax = 0.0 + + kzb = 1 + kze = nz + + ixb = ixcol + ixe = ixcol + ix = ixcol + + qtmp1(nz+1) = 0.0 + + DO kz = kzb,kze +! DO ix = ixb,ixe +! cmax = Max(cmax, vt(ix,kz)*dz3dinv(ix,jy,kz)) + + IF ( id == 1 ) THEN + qtmp1(kz) = a(ix,jgs,kz,ia)*vt(kz,ix)*db1(ix,kz) + ELSE + qtmp1(kz) = a(ix,jgs,kz,ia)*vt(kz,ix) + ENDIF + + IF ( a(ix,jgs,kz,ia) .ne. 0.0 ) THEN +! imn = Min(ix,imn) +! imx = Max(ix,imx) + kmn = Min(kz,kmn) + kmx = Max(kz,kmx) + ENDIF +! ENDDO + ENDDO + + kmn = Max(1,kmn-1) + +! first check if fallout is worth doing +! IF ( cmax .eq. 0.0 .or. imn .gt. imx ) THEN +! RETURN +! ENDIF + + IF ( kmn == 1 ) THEN + + kz = 1 +! do ix = imn,imx ! 1,nx-1 + xfall(ix,jy,ia) = xfall(ix,jy,ia) + a(ix,jgs,kz,ia)*vt(kz,ix)*dtfrac +! enddo + + ENDIF + + do kz = 1,nz +! do ix = 1,nx + a(ix,jgs,kz,ia) = a(ix,jgs,kz,ia) + dtp*dtz1(kz,ix,id)*(qtmp1(kz+1) - qtmp1(kz) ) +! enddo + enddo + + + RETURN + END SUBROUTINE FALLOUT1D + +! ############################################################################## +! ############################################################################## + +!>\ingroup mod_nsslmp +!! Calculates temporary reflectivity moment for adaptive size-sorting limiter + subroutine calczgr1d(nx,ny,nz,nor,na,a,ixe,kze, & + & z,db,jgs,ipconc, alpha, l,ln, qmin, xvmn,xvmx, lvol, rho_qx, ixcol) + + + implicit none + + integer nx,ny,nz,nor,na,ngt,jgs + integer :: ixcol + integer, parameter :: norz = 3 + real a(-nor+1:nx+nor,-nor+1:ny+nor,-nor+1:nz+nor,na) + real z(-nor+1:nx+nor,-nor+1:nz+nor,lr:lhab) ! reflectivity + real db(nx,nz+1) ! air density +! real gt(-nor+1:nx+nor,-nor+1:ny+nor,-nor+1:nz+nor,ngt) + + integer ixe,kze + real alpha + real qmin + real xvmn,xvmx + integer ipconc + integer l ! index for q + integer ln ! index for N + integer lvol ! index for volume + real rho_qx + + + integer ix,jy,kz + real vr,qr,nrx,rd,xv,g1,zx,chw,xdn + + + jy = jgs + ix = ixcol + + IF ( l .eq. lh .or. l .eq. lhl .or. ( l .eq. lr .and. imurain == 1 ) ) THEN + + + DO kz = 1,kze + + + + IF ( a(ix,jy,kz,l) .gt. qmin .and. a(ix,jy,kz,ln) .gt. 1.e-15 ) THEN + + IF ( lvol .gt. 1 ) THEN + IF ( a(ix,jy,kz,lvol) .gt. 0.0 ) THEN + xdn = db(ix,kz)*a(ix,jy,kz,l)/a(ix,jy,kz,lvol) + xdn = Min( 900., Max( hdnmn, xdn ) ) + ELSE + xdn = rho_qx + ENDIF + ELSE + xdn = rho_qx + ENDIF + + IF ( l == lr ) xdn = 1000. + + qr = a(ix,jy,kz,l) + xv = db(ix,kz)*a(ix,jy,kz,l)/(xdn*a(ix,jy,kz,ln)) + chw = a(ix,jy,kz,ln) + + IF ( xv .lt. xvmn .or. xv .gt. xvmx ) THEN + xv = Min( xvmx, Max( xvmn,xv ) ) + chw = db(ix,kz)*a(ix,jy,kz,l)/(xv*xdn) + ENDIF + + g1 = (6.0 + alpha)*(5.0 + alpha)*(4.0 + alpha)/ & + & ((3.0 + alpha)*(2.0 + alpha)*(1.0 + alpha)) + zx = g1*db(ix,kz)**2*(a(ix,jy,kz,l))*a(ix,jy,kz,l)/chw +! z(ix,kz,l) = 1.e18*zx*(6./(pi*1000.))**2 + z(ix,kz,l) = zx*(6./(pi*1000.))**2 + + +! IF ( ny.eq.2 .and. kz .ge. 25 .and. kz .le. 29 .and. z(ix,kz,l) .gt. 0. ) THEN +! write(*,*) 'calczgr: z,dbz,xdn = ',ix,kz,z(ix,kz,l),10*log10(z(ix,kz,l)),xdn +! ENDIF + + ELSE + + z(ix,kz,l) = 0.0 + + ENDIF + + ENDDO + + ELSEIF ( l .eq. lr .and. imurain == 3) THEN + + xdn = 1000. + + DO kz = 1,kze + IF ( a(ix,jy,kz,l) .gt. qmin .and. a(ix,jy,kz,ln) .gt. 1.e-15 ) THEN + + vr = db(ix,kz)*a(ix,jy,kz,l)/(xdn*a(ix,jy,kz,ln)) +! z(ix,kz,l) = 3.6e18*(rnu+2.0)*a(ix,jy,kz,ln)*vr**2/(rnu+1.0) + z(ix,kz,l) = 3.6*(rnu+2.0)*a(ix,jy,kz,ln)*vr**2/(rnu+1.0) +! qr = a(ix,jy,kz,lr) +! nrx = a(ix,jy,kz,lnr) + + ELSE + + z(ix,kz,l) = 0.0 + + ENDIF + + + ENDDO + + ENDIF + + RETURN + + END subroutine calczgr1d + +! ############################################################################## +! ############################################################################## +! +! Subroutine to correct number concentration to prevent reflectivity growth by +! sedimentation in 2-moment ZXX scheme. +! Calculation is in a slab (constant jgs) +! + +!>\ingroup mod_nsslmp +!! Subroutine to correct number concentration to prevent reflectivity growth + subroutine calcnfromz1d(nx,ny,nz,nor,na,a,t0,ixe,kze, & + & z0,db,jgs,ipconc, alpha, l,ln, qmin, xvmn,xvmx,t1, & + & lvol, rho_qx, infall, ixcol) + + + implicit none + + integer nx,ny,nz,nor,na,ngt,jgs,ixcol + + real a(-nor+1:nx+nor,-nor+1:ny+nor,-nor+1:nz+nor,na) ! sedimented N and q + real t0(-nor+1:nx+nor,-nor+1:ny+nor,-nor+1:nz+nor) ! sedimented reflectivity + real t1(-nor+1:nx+nor,-nor+1:ny+nor,-nor+1:nz+nor) ! sedimented N (by Vm) +! real gt(-nor+1:nx+nor,-nor+1:ny+nor,-nor+1:nz+nor,ngt) + real z0(-nor+1:nx+nor,-nor+1:nz+nor,lr:lhab) ! initial reflectivity + + real db(nx,nz+1) ! air density + + integer ixe,kze + real alpha + real qmin + real xvmn,xvmx + integer ipconc + integer l ! index for q + integer ln ! index for N + integer lvol ! index for volume + real rho_qx + integer infall + + + integer ix,jy,kz + double precision vr,qr,nrx,rd,g1,zx,chw,z,znew,zt,zxt + real xv,xdn + integer :: ndbz, nmwgt, nnwgt, nwlessthanz + + ndbz = 0 + nmwgt = 0 + nnwgt = 0 + nwlessthanz = 0 + + + + jy = jgs + ix = ixcol + + IF ( l .eq. lh .or. l .eq. lhl .or. ( l == lr .and. imurain == 1 ) ) THEN + + g1 = (6.0 + alpha)*(5.0 + alpha)*(4.0 + alpha)/ & + & ((3.0 + alpha)*(2.0 + alpha)*(1.0 + alpha)) + + DO kz = 1,kze + + + IF ( t0(ix,jy,kz) .gt. 0. ) THEN ! { + + IF ( lvol .gt. 1 ) THEN + IF ( a(ix,jy,kz,lvol) .gt. 0.0 ) THEN + xdn = db(ix,kz)*a(ix,jy,kz,l)/a(ix,jy,kz,lvol) + xdn = Min( 900., Max( hdnmn, xdn ) ) + ELSE + xdn = rho_qx + ENDIF + ELSE + xdn = rho_qx + ENDIF + + IF ( l == lr ) xdn = 1000. + + qr = a(ix,jy,kz,l) + xv = db(ix,kz)*a(ix,jy,kz,l)/(xdn*a(ix,jy,kz,ln)) + chw = a(ix,jy,kz,ln) + + IF ( xv .lt. xvmn .or. xv .gt. xvmx ) THEN + xv = Min( xvmx, Max( xvmn,xv ) ) + chw = db(ix,kz)*a(ix,jy,kz,l)/(xv*xdn) + ENDIF + + zx = g1*db(ix,kz)**2*( a(ix,jy,kz,l))*a(ix,jy,kz,l)/chw + z = zx*(6./(pi*1000.))**2 + + + IF ( (z .gt. t0(ix,jy,kz) .and. z .gt. 0.0 .and. & + & t0(ix,jy,kz) .gt. z0(ix,kz,l) )) THEN !{ + + zx = t0(ix,jy,kz)/((6./(pi*1000.))**2) + + nrx = g1*db(ix,kz)**2*( a(ix,jy,kz,l))*a(ix,jy,kz,l)/zx + IF ( infall .eq. 3 ) THEN + IF ( nrx .gt. a(ix,jy,kz,ln) ) THEN + ndbz = ndbz + 1 + IF ( t1(ix,jy,kz) .lt. ndbz ) nwlessthanz = nwlessthanz + 1 + ELSE + nnwgt = nnwgt + 1 + ENDIF + a(ix,jy,kz,ln) = Max( real(nrx), a(ix,jy,kz,ln) ) + ELSE + IF ( nrx .gt. a(ix,jy,kz,ln) .and. t1(ix,jy,kz) .gt. a(ix,jy,kz,ln) ) THEN + IF ( nrx .lt. t1(ix,jy,kz) ) THEN + ndbz = ndbz + 1 + ELSE + nmwgt = nmwgt + 1 + IF ( t1(ix,jy,kz) .lt. ndbz ) nwlessthanz = nwlessthanz + 1 + ENDIF + ELSE + nnwgt = nnwgt + 1 + ENDIF + + a(ix,jy,kz,ln) = Max(Min( real(nrx), t1(ix,jy,kz) ), a(ix,jy,kz,ln) ) + ENDIF + + ELSE ! } { + IF ( t1(ix,jy,kz) .gt. 0 .and. a(ix,jy,kz,ln) .gt. 0 ) THEN + IF ( t1(ix,jy,kz) .gt. a(ix,jy,kz,ln) ) THEN + nmwgt = nmwgt + 1 + ELSE + nnwgt = nnwgt + 1 + ENDIF + ENDIF + a(ix,jy,kz,ln) = Max(t1(ix,jy,kz), a(ix,jy,kz,ln) ) + nrx = a(ix,jy,kz,ln) + + + + ENDIF ! } + + ! } + ELSE ! { + IF ( t1(ix,jy,kz) .gt. 0 .and. a(ix,jy,kz,ln) .gt. 0 ) THEN + IF ( t1(ix,jy,kz) .gt. a(ix,jy,kz,ln) ) THEN + nmwgt = nmwgt + 1 + ELSE + nnwgt = nnwgt + 1 + ENDIF + ENDIF + ENDIF! } + + ENDDO + + + ELSEIF ( l .eq. lr .and. imurain == 3) THEN + + xdn = 1000. + + DO kz = 1,kze + IF ( t0(ix,jy,kz) .gt. 0. ) THEN + + vr = db(ix,kz)*a(ix,jy,kz,l)/(xdn*a(ix,jy,kz,ln)) + z = 3.6*(rnu+2.0)*a(ix,jy,kz,ln)*vr**2/(rnu+1.0) + + IF ( z .gt. t0(ix,jy,kz) .and. z .gt. 0.0 .and. & + & t0(ix,jy,kz) .gt. 0.0 & + & .and. t0(ix,jy,kz) .gt. z0(ix,kz,l) ) THEN + + vr = db(ix,kz)*a(ix,jy,kz,l)/(xdn) + chw = a(ix,jy,kz,ln) + nrx = 3.6*(rnu+2.0)*vr**2/((rnu+1.0)*t0(ix,jy,kz)) + IF ( infall .eq. 3 ) THEN + a(ix,jy,kz,ln) = Max( real(nrx), a(ix,jy,kz,ln) ) + ELSEIF ( infall .eq. 4 ) THEN + a(ix,jy,kz,ln) = Max( Min( real(nrx), t1(ix,jy,kz)), a(ix,jy,kz,ln) ) + ENDIF + + ELSE + + a(ix,jy,kz,ln) = Max(t1(ix,jy,kz), a(ix,jy,kz,ln) ) + + ENDIF + + ELSE + + a(ix,jy,kz,ln) = Max(t1(ix,jy,kz), a(ix,jy,kz,ln) ) + + ENDIF + + + ENDDO + + ENDIF + + RETURN + + END subroutine calcnfromz1d + + +! ############################################################################## +! ############################################################################## +! +! Subroutine to calculate number concentrations from initial state that has only mixing ratio. +! Output N will be in #/m^3 in 'an' array, since sedimentation is done next. +! Output ccw,cci etc. will be in #/kg + +! +! 10.27.2015: Added hail calculation +! +!>\ingroup mod_nsslmp +!! Subroutine to calculate number concentrations from initial state that has only mixing ratio. + subroutine calcnfromq(nx,ny,nz,an,na,nor,norz,dn, & + & qcw,qci,qsw,qrw,qhw,qhl, & + & ccw,cci,csw,crw,chw,chl, & + & cccn,cccna, vhw,vhl,qv,spechum, invertccn_flag, cwmasin ) + + + + implicit none + + integer nx,ny,nz,nor,norz,na,ngt,jgs,ixcol + + real an(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz,na) ! scalars (q, N, Z) + + real dn(nx,nz+1) ! air density + + real, optional, dimension(nx,nz), intent(inout) :: qcw,qci,qsw,qrw,qhw,qhl, & + ccw,cci,csw,crw,chw,chl, & + cccn,cccna,vhw,vhl,qv, spechum + logical, optional, intent(in) :: invertccn_flag + real, optional :: cwmasin + + integer ixe,kze + real alpha + real qmin + real xvmn,xvmx + integer ipconc + integer lvol ! index for volume + integer infall + + + integer ix,jy,kz + double precision vr,q,nrx,nrx2,rd,g1h,g1hl,g1r,g1s,zx,z,znew,zt,zxt,n1,laminv1 + double precision :: zr, zs, zh, dninv + real, parameter :: xn0s = 3.0e6, xn0r = 8.0e6, xn0h = 2.0e5, xn0hl = 4.0e4 + real, parameter :: xdnr = 1000., xdns = 100. ,xdnh = 700.0, xdnhl = 900.0 + real, parameter :: zhlfac = 1./(pi*xdnhl*xn0hl) + real, parameter :: zhfac = 1./(pi*xdnh*xn0h) + real, parameter :: zrfac = 1./(pi*xdnr*xn0r) + real, parameter :: zsfac = 1./(pi*xdns*xn0s) + real, parameter :: g0 = (6.0)*(5.0)*(4.0)/((3.0)*(2.0)*(1.0)) + real, parameter :: xims=900.*0.523599*(2.*50.e-6)**3 ! mks (100 micron diam solid sphere approx) + real, parameter :: xgms=xdnh*0.523599*(300.e-6)**3 ! mks (300 micron diam sphere approx) + real, parameter :: cwmas09 = 1000.*0.523599*(2.*9.e-6)**3 ! mass of 9-micron radius droplet + + real xv,xdn,cwmasinv + integer :: ndbz, nmwgt, nnwgt, nwlessthanz + double precision :: mixconv, mixconvqv, qsmax,qsmax2,qsmax3,qsmax4 + logical :: invertccn_local + +! ------------------------------------------------------------------ + + IF ( present( invertccn_flag ) ) THEN + invertccn_local = invertccn_flag + ELSE + invertccn_local = .false. + ENDIF + + IF ( present( cwmasin ) ) THEN + cwmasinv = 1.0/cwmasin + ELSE + cwmasinv = 1.0/cwmas09 + ENDIF + + jy = 1 + + + g1h = (6.0 + alphah)*(5.0 + alphah)*(4.0 + alphah)/ & + & ((3.0 + alphah)*(2.0 + alphah)*(1.0 + alphah)) + + g1hl = (6.0 + alphahl)*(5.0 + alphahl)*(4.0 + alphahl)/ & + & ((3.0 + alphahl)*(2.0 + alphahl)*(1.0 + alphahl)) + + IF ( imurain == 3 ) THEN + g1r = (rnu+2.0)/(rnu+1.0) + ELSE ! imurain == 1 + g1r = (6.0 + alphar)*(5.0 + alphar)*(4.0 + alphar)/ & + & ((3.0 + alphar)*(2.0 + alphar)*(1.0 + alphar)) + ENDIF + + g1s = (snu+2.0)/(snu+1.0) + qsmax = 0 + qsmax2 = 0 + qsmax3 = 0 + qsmax4 = 0 +! IF ( .not. present( qcw ) ) THEN + DO kz = 1,nz + DO ix = 1,nx ! ixcol + +! qv_mp = spechum/(1.0_kind_phys-spechum) +! IF ( convertdry ) THEN +! qc_mp = qc/(1.0_kind_phys-spechum) + mixconv = 1 + IF ( present( spechum ) ) THEN ! convert to "dry" mixing ratios + an(ix,jy,kz,lv) = spechum(ix,kz)/(1.0d0 - spechum(ix,kz)) + mixconv = 1.0d0/(1.0d0 - spechum(ix,kz)) + ELSE + mixconv = 1.0d0 + ENDIF + IF ( present( qv ) ) an(ix,jy,kz,lv) = qv(ix,kz) ! assume qv is "dry" mixing ratio if passed in + IF ( present( qcw ) ) an(ix,jy,kz,lc) = qcw(ix,kz)*mixconv + IF ( present( qrw ) ) an(ix,jy,kz,lr) = qrw(ix,kz)*mixconv + IF ( present( qci ) ) an(ix,jy,kz,li) = qci(ix,kz)*mixconv + IF ( present( qsw ) ) THEN + an(ix,jy,kz,ls) = qsw(ix,kz)*mixconv +! qsmax = Max( qsmax, qsw(ix,kz) ) +! qsmax2 = Max( qsmax2, an(ix,jy,kz,ls) ) + ENDIF + IF ( present( qhw ) ) an(ix,jy,kz,lh) = qhw(ix,kz)*mixconv + IF ( lhl > 1 .and. present( qhl ) ) an(ix,jy,kz,lhl) = qhl(ix,kz)*mixconv + IF ( present( ccw ) ) an(ix,jy,kz,lnc) = ccw(ix,kz)*mixconv*dn(ix,kz) + IF ( present( crw ) ) an(ix,jy,kz,lnr) = crw(ix,kz)*mixconv*dn(ix,kz) + IF ( present( cci ) ) an(ix,jy,kz,lni) = cci(ix,kz)*mixconv*dn(ix,kz) + IF ( present( csw ) ) an(ix,jy,kz,lns) = csw(ix,kz)*mixconv*dn(ix,kz) + IF ( present( chw ) ) an(ix,jy,kz,lnh) = chw(ix,kz)*mixconv*dn(ix,kz) + IF ( lhl > 1 .and. present( chl ) ) an(ix,jy,kz,lnhl) = chl(ix,kz)*mixconv*dn(ix,kz) + IF ( lvh > 1 .and. present( vhw ) ) an(ix,jy,kz,lvh) = vhw(ix,kz)*mixconv + IF ( lvhl > 1 .and. present( vhl ) ) an(ix,jy,kz,lvhl) = vhl(ix,kz)*mixconv + IF ( lccn > 1 .and. present( cccn ) ) an(ix,jy,kz,lccn) = cccn(ix,kz)*mixconv*dn(ix,kz) + IF ( lccna > 1 .and. present( cccna ) ) an(ix,jy,kz,lccna) = cccna(ix,kz)*mixconv + + dninv = 1./dn(ix,kz) + +! IF ( .not. present( qcw ) ) THEN + ! Cloud droplets + + IF ( lnc > 1 ) THEN + IF ( an(ix,jy,kz,lnc) <= cxmin .and. an(ix,jy,kz,lc) > qxmin_init(lc) ) THEN + + an(ix,jy,kz,lnc) = Min(qccn, an(ix,jy,kz,lc)*cwmasinv )*dn(ix,kz) + + IF ( invertccn_local ) THEN + an(ix,jy,kz,lccn) = an(ix,jy,kz,lccn) + an(ix,jy,kz,lnc) + ELSE + + IF ( lccn > 1 .and. lccna < 1 ) THEN + an(ix,jy,kz,lccn) = an(ix,jy,kz,lccn) - an(ix,jy,kz,lnc) + ENDIF + IF ( lccna > 1 ) THEN + an(ix,jy,kz,lccna) = an(ix,jy,kz,lccna) + an(ix,jy,kz,lnc) + ENDIF + ENDIF + + ELSEIF ( an(ix,jy,kz,lc) <= qxmin(lc) .or. & + ( an(ix,jy,kz,lnc) <= cxmin .and. an(ix,jy,kz,lc) <= qxmin_init(lc)) ) THEN + + an(ix,jy,kz,lv) = an(ix,jy,kz,lv) + an(ix,jy,kz,lc) + an(ix,jy,kz,lnc) = 0.0 + an(ix,jy,kz,lc) = 0.0 + + ENDIF + ENDIF + + ! Cloud ice + + IF ( lni > 1 ) THEN + IF ( an(ix,jy,kz,lni) <= cxmin .and. an(ix,jy,kz,li) > qxmin_init(li) ) THEN + an(ix,jy,kz,lni) = dn(ix,kz)*an(ix,jy,kz,li)/xims + + ELSEIF ( an(ix,jy,kz,li) <= qxmin(li) .or. & + ( an(ix,jy,kz,lni) <= cxmin .and. an(ix,jy,kz,li) <= qxmin_init(li)) ) THEN + an(ix,jy,kz,lv) = an(ix,jy,kz,lv) + an(ix,jy,kz,li) + an(ix,jy,kz,lni) = 0.0 + an(ix,jy,kz,li) = 0.0 + ENDIF + ENDIF + + ! rain + + IF ( lnr > 1 ) THEN + IF ( an(ix,jy,kz,lnr) <= 0.1*cxmin .and. an(ix,jy,kz,lr) > qxmin_init(lr) ) THEN + + q = an(ix,jy,kz,lr) + + laminv1 = (dn(ix,kz) * q * zrfac)**(0.25) ! inverse of slope + + n1 = laminv1*xn0r ! number concentration for inv. exponential single moment input + + nrx = n1*g1r/g0 ! number concentration for different shape parameter + + an(ix,jy,kz,lnr) = nrx ! *dninv ! convert to number mixing ratio + + ELSEIF ( an(ix,jy,kz,lr) <= qxmin(lr) .or. & + ( an(ix,jy,kz,lnr) <= cxmin .and. an(ix,jy,kz,lr) <= qxmin_init(lr)) ) THEN + an(ix,jy,kz,lv) = an(ix,jy,kz,lv) + an(ix,jy,kz,lr) + an(ix,jy,kz,lnr) = 0.0 + an(ix,jy,kz,lr) = 0.0 + ENDIF + ENDIF + + ! snow + IF ( lns > 1 ) THEN + IF ( an(ix,jy,kz,lns) <= 0.1*cxmin .and. an(ix,jy,kz,ls) > qxmin_init(ls) ) THEN + + q = an(ix,jy,kz,ls) + + laminv1 = (dn(ix,kz) * q * zsfac)**(0.25) ! inverse of slope + + n1 = laminv1*xn0s ! number concentration for inv. exponential single moment input + + nrx = n1*g1s/g0 ! number concentration for different shape parameter + + an(ix,jy,kz,lns) = nrx ! *dninv ! convert to number mixing ratio + + ELSEIF ( an(ix,jy,kz,ls) <= qxmin(ls) .or. & + ( an(ix,jy,kz,lns) <= cxmin .and. an(ix,jy,kz,ls) <= qxmin_init(ls)) ) THEN + an(ix,jy,kz,lv) = an(ix,jy,kz,lv) + an(ix,jy,kz,ls) + an(ix,jy,kz,lns) = 0.0 + an(ix,jy,kz,ls) = 0.0 + + ENDIF + ENDIF + + ! graupel + + IF ( lnh > 1 ) THEN + IF ( an(ix,jy,kz,lnh) <= 0.1*cxmin .and. an(ix,jy,kz,lh) > qxmin_init(lh) ) THEN + IF ( lvh > 1 ) THEN + IF ( an(ix,jy,kz,lvh) <= 0.0 ) THEN + an(ix,jy,kz,lvh) = an(ix,jy,kz,lh)/xdnh + ENDIF + ENDIF + + q = an(ix,jy,kz,lh) + + laminv1 = (dn(ix,kz) * q * zhfac)**(0.25) ! inverse of slope + + n1 = laminv1*xn0h ! number concentration for inv. exponential single moment input + + nrx = n1*g1h/g0 ! number concentration for different shape parameter + + nrx2 = dn(ix,kz) * q / xgms + + nrx = Min( nrx, nrx2 ) + + IF ( nrx > cxmin ) THEN + an(ix,jy,kz,lnh) = nrx ! *dninv ! convert to number mixing ratio + ELSE + an(ix,jy,kz,lh) = 0.0 + an(ix,jy,kz,lnh) = 0.0 + an(ix,jy,kz,lvh) = 0.0 + ENDIF + + ELSEIF ( an(ix,jy,kz,lh) <= qxmin(lh) .or. & + ( an(ix,jy,kz,lnh) <= cxmin .and. an(ix,jy,kz,lh) <= qxmin_init(lh)) ) THEN + + an(ix,jy,kz,lv) = an(ix,jy,kz,lv) + an(ix,jy,kz,lh) + an(ix,jy,kz,lh) = 0.0 + + ENDIF + ENDIF + + ! hail + + IF ( lnhl > 1 .and. lhl > 1 ) THEN + IF ( an(ix,jy,kz,lnhl) <= 0.1*cxmin .and. an(ix,jy,kz,lhl) > qxmin_init(lhl) ) THEN + IF ( lvhl > 1 ) THEN + IF ( an(ix,jy,kz,lvhl) <= 0.0 ) THEN + an(ix,jy,kz,lvhl) = an(ix,jy,kz,lhl)/xdnhl + ENDIF + ENDIF + + q = an(ix,jy,kz,lhl) + + laminv1 = (dn(ix,kz) * q * zhlfac)**(0.25) ! inverse of slope + + n1 = laminv1*xn0hl ! number concentration for inv. exponential single moment input + + nrx = n1*g1hl/g0 ! number concentration for different shape parameter + + an(ix,jy,kz,lnhl) = nrx ! *dninv ! convert to number mixing ratio + + + ELSEIF ( an(ix,jy,kz,lhl) <= qxmin(lhl) .or. & + ( an(ix,jy,kz,lnhl) <= cxmin .and. an(ix,jy,kz,lhl) <= qxmin_init(lhl)) ) THEN + + an(ix,jy,kz,lv) = an(ix,jy,kz,lv) + an(ix,jy,kz,lhl) + an(ix,jy,kz,lhl) = 0.0 + + ENDIF + ENDIF + + +! ENDIF + +! spechum = qv_mp/(1.0_kind_phys+qv_mp) +! IF ( convertdry ) THEN +! qc = qc_mp/(1.0_kind_phys+qv_mp) + mixconvqv = 1 + IF ( present( spechum ) ) THEN ! convert back to "dry+vapor" mixing ratios + !an(ix,jy,kz,lv) = spechum(ix,kz)/(1.0d0 - spechum(ix,kz)) + mixconvqv = 1.0d0/(1.0d0 + an(ix,jy,kz,lv)) + spechum(ix,kz) = an(ix,jy,kz,lv)*mixconvqv + ELSE + mixconvqv = 1.0d0 + ENDIF + + IF ( present( qv ) ) qv(ix,kz) = an(ix,jy,kz,lv) + IF ( present( qcw ) ) qcw(ix,kz) = an(ix,jy,kz,lc)*mixconvqv + IF ( present( qrw ) ) qrw(ix,kz) = an(ix,jy,kz,lr)*mixconvqv + IF ( present( qci ) ) qci(ix,kz) = an(ix,jy,kz,li)*mixconvqv + IF ( present( qsw ) ) THEN + qsw(ix,kz) = an(ix,jy,kz,ls)*mixconvqv +! qsmax3 = Max( qsmax3, qsw(ix,kz) ) +! qsmax4 = Max( qsmax4, an(ix,jy,kz,ls) ) + ENDIF + IF ( present( qhw ) ) qhw(ix,kz) = an(ix,jy,kz,lh)*mixconvqv + IF ( lhl > 1 .and. present( qhl ) ) qhl(ix,kz) = an(ix,jy,kz,lhl)*mixconvqv + IF ( present( ccw ) ) ccw(ix,kz) = an(ix,jy,kz,lnc)*mixconvqv*dninv + IF ( present( crw ) ) crw(ix,kz) = an(ix,jy,kz,lnr)*mixconvqv*dninv + IF ( present( cci ) ) cci(ix,kz) = an(ix,jy,kz,lni)*mixconvqv*dninv + IF ( present( csw ) ) csw(ix,kz) = an(ix,jy,kz,lns)*mixconvqv*dninv + IF ( present( chw ) ) chw(ix,kz) = an(ix,jy,kz,lnh)*mixconvqv*dninv + IF ( lhl > 1 .and. present( chl ) ) chl(ix,kz) = an(ix,jy,kz,lnhl)*mixconvqv*dninv + IF ( lvh > 1 .and. present( vhw ) ) vhw(ix,kz) = an(ix,jy,kz,lvh)*mixconvqv + IF ( lvhl > 1 .and. present( vhl ) ) vhl(ix,kz) = an(ix,jy,kz,lvhl)*mixconvqv + IF ( lccn > 1 .and. present( cccn ) ) cccn(ix,kz) = an(ix,jy,kz,lccn)*mixconvqv*dninv + IF ( lccna > 1 .and. present( cccna ) ) cccna(ix,kz) = an(ix,jy,kz,lccna)*mixconvqv + + + ENDDO ! ix + ENDDO ! kz +! ELSE +! write(0,*) 'calcnfromq: lv = ',lv,lc,lr,li,ls,lh,lvh,lhl,lccn,lccna +! write(0,*) 'calcnfromq: nx,ny,nz,na = ',nx,ny,nz,na +! +! ENDIF + +! IF ( present( qsw ) ) THEN +! write(0,*) 'calcnfromq: qsmax = ',qsmax,qsmax2,qsmax3,qsmax4 +! ENDIF + + RETURN + + END subroutine calcnfromq + +! ############################################################################## +! ############################################################################## +! +! Subroutine to calculate number concentrations from convection parameterization rates that have only mixing ratio. +! N will be in #/kg, NOT #/m^3, since sedimentation is done next. +! + +! +! 10.27.2015: Added hail calculation +! +!>\ingroup mod_nsslmp +!! Subroutine to calculate number concentrations from convection parameterization rates that have only mixing ratio. + subroutine calcnfromcuten(nx,ny,nz,an,anold,na,nor,norz,dn) + + + implicit none + + integer nx,ny,nz,nor,norz,na,ngt,jgs,ixcol + + real an(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz,na) ! scalars (q, N, Z) from CUTEN arrays + real anold(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz,na) ! scalars (q, N, Z) + + real dn(nx,nz+1) ! air density + + integer ixe,kze + real alpha + real qmin + real xvmn,xvmx + integer ipconc + integer lvol ! index for volume + integer infall + + + integer ix,jy,kz + double precision vr,q,nrx,rd,g1h,g1hl,g1r,g1s,zx,chw,z,znew,zt,zxt,n1,laminv1 + double precision :: zr, zs, zh, dninv + real, parameter :: xn0s = 3.0e6, xn0r = 8.0e6, xn0h = 4.0e4, xn0hl = 4.0e4 + real, parameter :: xdnr = 1000., xdns = 100. ,xdnh = 700.0, xdnhl = 900.0 + real, parameter :: zhlfac = 1./(pi*xdnhl*xn0hl) + real, parameter :: zhfac = 1./(pi*xdnh*xn0h) + real, parameter :: zrfac = 1./(pi*xdnr*xn0r) + real, parameter :: zsfac = 1./(pi*xdns*xn0s) + real, parameter :: g0 = (6.0)*(5.0)*(4.0)/((3.0)*(2.0)*(1.0)) + real, parameter :: xims=900.*0.523599*(2.*50.e-6)**3 ! mks (100 micron diam solid sphere approx) + real, parameter :: xcms=1000.*0.523599*(2.*7.5e-6)**3 ! mks (100 micron diam solid sphere approx) + + real :: xmass,xv,xdn + integer :: ndbz, nmwgt, nnwgt, nwlessthanz + +! ------------------------------------------------------------------ + + + jy = 1 + + + g1h = (6.0 + alphah)*(5.0 + alphah)*(4.0 + alphah)/ & + & ((3.0 + alphah)*(2.0 + alphah)*(1.0 + alphah)) + + g1hl = (6.0 + alphahl)*(5.0 + alphahl)*(4.0 + alphahl)/ & + & ((3.0 + alphahl)*(2.0 + alphahl)*(1.0 + alphahl)) + + IF ( imurain == 3 ) THEN + g1r = (rnu+2.0)/(rnu+1.0) + ELSE ! imurain == 1 + g1r = (6.0 + alphar)*(5.0 + alphar)*(4.0 + alphar)/ & + & ((3.0 + alphar)*(2.0 + alphar)*(1.0 + alphar)) + ENDIF + + g1s = (snu+2.0)/(snu+1.0) + + DO kz = 1,nz + DO ix = 1,nx ! ixcol + + dninv = 1./dn(ix,kz) + + ! Cloud droplets + + IF ( lnc > 1 ) THEN +! IF ( an(ix,jy,kz,lnc) <= 0.1*cxmin .and. an(ix,jy,kz,lc) > qxmin(lc) ) THEN + IF ( an(ix,jy,kz,lnc) > qxmin(lc) ) THEN + anold(ix,jy,kz,lnc) = anold(ix,jy,kz,lnc) + an(ix,jy,kz,lc)/xcms + ENDIF + ENDIF + + ! Cloud ice + + IF ( lni > 1 ) THEN + IF ( an(ix,jy,kz,lni) > qxmin(li) ) THEN + anold(ix,jy,kz,lni) = anold(ix,jy,kz,lni) + an(ix,jy,kz,li)/xims + ENDIF + ENDIF + + ! rain + + IF ( lnr > 1 ) THEN + IF ( an(ix,jy,kz,lr) > qxmin(lr) ) THEN ! adding rain mass from CU scheme + + IF ( .true. .or. (anold(ix,jy,kz,lr) - an(ix,jy,kz,lr)) < qxmin(lr) .or. anold(ix,jy,kz,lnr) < cxmin ) THEN + + q = an(ix,jy,kz,lr) + + laminv1 = (dn(ix,kz) * q * zrfac)**(0.25) ! inverse of slope + + n1 = laminv1*xn0r ! number concentration for inv. exponential single moment input + + nrx = n1*g1r/g0 ! number concentration for different shape parameter + + anold(ix,jy,kz,lnr) = anold(ix,jy,kz,lnr) + nrx ! *dninv ! convert to number mixing ratio + + ELSE + ! assume mean particle mass of pre-existing snow + xmass = anold(ix,jy,kz,lr)/anold(ix,jy,kz,lnr) + anold(ix,jy,kz,lnr) = anold(ix,jy,kz,lnr) + an(ix,jy,kz,lr)/xmass + ENDIF + + ENDIF + ENDIF + + ! snow + IF ( lns > 1 ) THEN + IF ( an(ix,jy,kz,ls) > qxmin(ls) ) THEN ! adding snow mass from CU scheme + + IF ( .true. .or. (anold(ix,jy,kz,ls) - an(ix,jy,kz,ls)) < qxmin(ls) .or. anold(ix,jy,kz,lns) < cxmin ) THEN + + ! assume that there was no snow before this + + q = an(ix,jy,kz,ls) + + laminv1 = (dn(ix,kz) * q * zsfac)**(0.25) ! inverse of slope + + n1 = laminv1*xn0s ! number concentration for inv. exponential single moment input + + nrx = n1*g1s/g0 ! number concentration for different shape parameter + + anold(ix,jy,kz,lns) = anold(ix,jy,kz,lns) + nrx ! *dninv ! convert to number mixing ratio + + ELSE + ! assume mean particle mass of pre-existing snow + xmass = anold(ix,jy,kz,ls)/anold(ix,jy,kz,lns) + anold(ix,jy,kz,lns) = anold(ix,jy,kz,lns) + an(ix,jy,kz,ls)/xmass + ENDIF + + ENDIF + ENDIF + + ! graupel + +! IF ( lnh > 1 ) THEN +! IF ( an(ix,jy,kz,lnh) <= 0.1*cxmin .and. an(ix,jy,kz,lh) > qxmin(lh) ) THEN +! IF ( lvh > 1 ) THEN +! IF ( an(ix,jy,kz,lvh) <= 0.0 ) THEN +! an(ix,jy,kz,lvh) = an(ix,jy,kz,lh)/xdnh +! ENDIF +! ENDIF +! +! q = an(ix,jy,kz,lh) +! +! laminv1 = (dn(ix,kz) * q * zhfac)**(0.25) ! inverse of slope +! +! n1 = laminv1*xn0h ! number concentration for inv. exponential single moment input +! +! nrx = n1*g1h/g0 ! number concentration for different shape parameter +! +! an(ix,jy,kz,lnh) = nrx ! *dninv ! convert to number mixing ratio +! +! ENDIF +! ENDIF +! +! ! hail +! +! IF ( lnhl > 1 .and. lhl > 1 ) THEN +! IF ( an(ix,jy,kz,lnhl) <= 0.1*cxmin .and. an(ix,jy,kz,lhl) > qxmin(lhl) ) THEN +! IF ( lvhl > 1 ) THEN +! IF ( an(ix,jy,kz,lvhl) <= 0.0 ) THEN +! an(ix,jy,kz,lvhl) = an(ix,jy,kz,lhl)/xdnhl +! ENDIF +! ENDIF +! +! q = an(ix,jy,kz,lhl) +! +! laminv1 = (dn(ix,kz) * q * zhlfac)**(0.25) ! inverse of slope +! +! n1 = laminv1*xn0hl ! number concentration for inv. exponential single moment input +! +! nrx = n1*g1hl/g0 ! number concentration for different shape parameter +! +! an(ix,jy,kz,lnhl) = nrx ! *dninv ! convert to number mixing ratio +! +! ENDIF +! ENDIF + + ENDDO ! ix + ENDDO ! kz + + RETURN + + END subroutine calcnfromcuten + +! ##################################################################### +! ##################################################################### + +!>\ingroup mod_nsslmp +!! Subroutine to calculate effective radii for use by radiation routines + SUBROUTINE calc_eff_radius & + & (nx,ny,nz,na,jyslab & + & ,nor,norz & + & ,t1,t2,t3,t4 & + & ,qcw,qci,qsw,qrw & + & ,ccw,cci,csw,crw & + & ,an,dn ) + + implicit none + + integer, parameter :: ng1 = 1 + integer :: nx,ny,nz,na + integer :: ng + integer :: nor,norz, jyslab ! ,nht,ngt,igsr + real :: dtp ! time step + + +! +! external temporary arrays +! + + real,optional :: t1(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz) + real,optional :: t2(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz) + real,optional :: t3(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz) + real,optional :: t4(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz) + + real, optional :: an(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz,na) + real dn(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz) + real, optional, dimension(nx,nz) :: qcw,qci,qsw,qrw,ccw,cci,csw,crw + + + + + + ! local + + real pb(-norz+ng1:nz+norz) + real pinit(-norz+ng1:nz+norz) + +! +! declarations microphysics and for gather/scatter +! + integer nxmpb,nzmpb,nxz + integer mgs,ngs,numgs,inumgs + parameter (ngs=1) + integer ngscnt,igs(ngs),kgs(ngs) + real rho0(ngs) + + integer ix,kz,i,n, kp1 + integer :: jy, jgs + integer ixb,ixe,jyb,jye,kzb,kze + + integer itile,jtile,ktile + integer ixend,jyend,kzend,kzbeg + integer nxend,nyend,nzend,nzbeg + + real :: qx(ngs,lv:lhab) + real :: cx(ngs,lc:lhab) + real :: xv(ngs,lc:lhab) + real :: xmas(ngs,lc:lhab) + real :: xdn(ngs,lc:lhab) + real :: xdia(ngs,lc:lhab,3) + real :: alpha(ngs,lc:lhab) + + real :: gamc1,gamc2,gami1,gami2,gams1,gams2,gamr1,gamr2 + real :: factor_c, factor_i, factor_s, factor_r + real :: lam_c, lam_i, lam_s, lam_r + integer :: il + + +! ------------------------------------------------------------------------------- + itile = nx + jtile = ny + ktile = nz + ixend = nx + jyend = ny + kzend = nz + nxend = nx + 1 + nyend = ny + 1 + nzend = nz + kzbeg = 1 + nzbeg = 1 + + jy = 1 + pb(:) = 0.0 + pinit(:) = 0.0 + + gamc1 = Gamma_sp(2. + cnu) + gamc2 = 1. ! Gamma[1 + alphac] + gami1 = Gamma_sp(2. + cinu) + gami2 = 1. ! Gamma[1 + alphac] + gams1 = Gamma_sp(2. + snu) + gams2 = Gamma_sp(1. + snu) + gamr1 = Gamma_sp(2. + rnu) + gamr2 = Gamma_sp(1. + rnu) + + factor_c = (1. + cnu)*Gamma_sp(1. + cnu)/Gamma_sp(5./3. + cnu) + factor_i = (1. + cinu)*Gamma_sp(1. + cinu)/Gamma_sp(5./3. + cinu) + factor_s = (1. + snu)*Gamma_sp(1. + snu)/Gamma_sp(5./3. + snu) + + IF ( present(t4) ) THEN + IF ( imurain == 3 ) THEN + factor_r = (1. + rnu)*Gamma_sp(1. + rnu)/Gamma_sp(5./3. + rnu) + ELSE + factor_r = ((Pi*(alphar+3.)*(alphar+1.)*(alphar+1.))/6.)**(1./3.) + ENDIF + ENDIF + +! +! jy = 1 ! working on a 2d slab +!! VERY IMPORTANT: SET jgs = jy + + jgs = jy + + mgs = 1 + DO kz = 1,nz + DO ix = 1,nx ! ixcol + + rho0(mgs) = dn(ix,jy,kz) + IF ( present( an ) ) THEN + DO il = lc,ls + qx(mgs,il) = max(an(ix,jy,kz,il), 0.0) + cx(mgs,il) = max(an(ix,jy,kz,ln(il)), 0.0) + ENDDO + ELSE + qx(mgs,:) = 0.0 + cx(mgs,:) = 0.0 + IF ( present(qcw) ) qx(mgs,lc) = qcw(ix,kz) + IF ( present(qci) ) qx(mgs,li) = qci(ix,kz) + IF ( present(qsw) ) qx(mgs,ls) = qsw(ix,kz) + IF ( present(qrw) ) qx(mgs,lr) = qrw(ix,kz) + IF ( present(ccw) ) cx(mgs,lc) = ccw(ix,kz)*rho0(mgs) + IF ( present(cci) ) cx(mgs,li) = cci(ix,kz)*rho0(mgs) + IF ( present(csw) ) cx(mgs,ls) = csw(ix,kz)*rho0(mgs) + IF ( present(crw) ) cx(mgs,lr) = crw(ix,kz)*rho0(mgs) + + ENDIF + + IF ( present( t1 ) .and. qx(mgs,lc) > qxmin(lc) .and. cx(mgs,lc) > cxmin ) THEN +! Lambda for cloud droplets + lam_c = ((cx(mgs,lc)*(Pi/6.)*xdn0(lc)*Gamc1)/(qx(mgs,lc)*rho0(mgs)*Gamc2))**(1./3.) + t1(ix,jy,kz) = 0.5*factor_c/lam_c + ENDIF + + IF ( present( t2 ) .and. qx(mgs,li) > qxmin(li) .and. cx(mgs,li) > cxmin ) THEN +! Lambda for cloud ice + lam_i = ((cx(mgs,li)*(Pi/6.)*xdn0(li)*Gami1)/(qx(mgs,li)*rho0(mgs)*Gami2))**(1./3.) + t2(ix,jy,kz) = 0.5*factor_i/lam_i + ENDIF + + IF ( present( t3 ) .and. qx(mgs,ls) > qxmin(ls) .and. cx(mgs,ls) > cxmin ) THEN +! Lambda for snow + lam_s = ((cx(mgs,ls)*(Pi/6.)*xdn0(ls)*Gams1)/(qx(mgs,ls)*rho0(mgs)*Gams2))**(1./3.) + t3(ix,jy,kz) = 0.5*factor_s/lam_s + ENDIF + + IF ( present( t4 ) .and. present(qrw) .and. present(crw) ) THEN + IF ( qx(mgs,lr) > Max(1.e-8,qxmin(lr)) .and. cx(mgs,lr) > cxmin ) THEN + IF ( imurain == 1 ) THEN ! gamma-diameter +! Lambda for rain + lam_r = factor_r *((xdn0(lr)*cx(mgs,lr))/(qx(mgs,lr)*rho0(mgs)))**(1./3.) + t4(ix,jy,kz) = 0.5*(alphar+3.)/lam_r + ELSE ! gamma-volume +! Lambda for rain + lam_r = ((cx(mgs,lr)*(Pi/6.)*xdn0(lr)*Gamr1)/(qx(mgs,lr)*rho0(mgs)*Gamr2))**(1./3.) + t4(ix,jy,kz) = 0.5*factor_r/lam_r + ENDIF + ENDIF + ENDIF + + + ENDDO ! ix + ENDDO ! kz + + RETURN + END SUBROUTINE calc_eff_radius + + +! ##################################################################### +! ##################################################################### + +!>\ingroup mod_nsslmp +!! Subroutine that returns the maximum possible condensation + SUBROUTINE QVEXCESS(ngs,mgs,qwvp0,qv0,qcw1,pres,thetap0,theta0, & + & qvex,pi0,tabqvs,nqsat,fqsat,cbw,fcqv1,felvcp,ss1,pk,ngscnt) + +!##################################################################### +! Purpose: find the amount of vapor that can be condensed to liquid +!##################################################################### + + implicit none + + integer ngs,mgs,ngscnt + + real theta2temp + + real qvex + + integer nqsat + real fqsat, cbw + + real ss1 ! 'target' supersaturation +! +! input arrays +! + real qv0(ngs), qcw1(ngscnt), pres(ngs), qwvp0(mgs) + real thetap0(ngs), theta0(ngs) + real fcqv1(ngs), felvcp(ngs), pi0(ngs) + real pk(ngs) + + real tabqvs(nqsat) +! +! Local stuff +! + + integer itertd + integer ltemq + real gamss + real theta(ngs), qvap(ngs), pqs(ngs), qcw(ngs), qwv(ngs) + real qcwtmp(ngs), qss(ngs), qvs(ngs), qwvp(ngs) + real dqcw(ngs), dqwv(ngs), dqvcnd(ngs) + real temg(ngs), temcg(ngs), thetap(ngs) + + real tfr + parameter ( tfr = 273.15 ) + +! real poo,cap +! parameter ( cap = rd/cp, poo = 1.0e+05 ) +! +! +! Modified Straka adjustment (nearly identical to Tao et al. 1989 MWR) +! +! +! +! set up temperature and vapor arrays +! + pqs(mgs) = (380.0)/(pres(mgs)) + thetap(mgs) = thetap0(mgs) + theta(mgs) = thetap(mgs) + theta0(mgs) + qwvp(mgs) = qwvp0(mgs) + qvap(mgs) = max( (qwvp0(mgs) + qv0(mgs)), 0.0 ) + temg(mgs) = theta(mgs)*pk(mgs) ! ( pres(mgs) / poo ) ** cap +! temg(mgs) = theta2temp( theta(mgs), pres(mgs) ) +! +! +! +! reset temporaries for cloud particles and vapor +! + + qwv(mgs) = max( 0.0, qvap(mgs) ) + qcw(mgs) = max( 0.0, qcw1(mgs) ) +! +! + qcwtmp(mgs) = qcw(mgs) + temcg(mgs) = temg(mgs) - tfr + ltemq = (temg(mgs)-163.15)/fqsat+1.5 + ltemq = Min( nqsat, Max(1,ltemq) ) + + qvs(mgs) = pqs(mgs)*tabqvs(ltemq) + qss(mgs) = (0.01*ss1 + 1.0)*qvs(mgs) +! +! iterate adjustment +! + do itertd = 1,2 +! +! +! calculate super-saturation +! + dqcw(mgs) = 0.0 + dqwv(mgs) = ( qwv(mgs) - qss(mgs) ) +! +! evaporation and sublimation adjustment +! + if( dqwv(mgs) .lt. 0. ) then ! subsaturated + if( qcw(mgs) .gt. -dqwv(mgs) ) then ! check if qc can make up all of the deficit + dqcw(mgs) = dqwv(mgs) + dqwv(mgs) = 0. + else ! otherwise make all qc available for evap + dqcw(mgs) = -qcw(mgs) + dqwv(mgs) = dqwv(mgs) + qcw(mgs) + end if +! + qwvp(mgs) = qwvp(mgs) - ( dqcw(mgs) ) ! add to perturbation vapor +! + qcw(mgs) = qcw(mgs) + dqcw(mgs) + + thetap(mgs) = thetap(mgs) + & + & 1./pi0(mgs)* & + & (felvcp(mgs)*dqcw(mgs) ) + + end if ! dqwv(mgs) .lt. 0. (end of evap/sublim) +! +! condensation/deposition +! + IF ( dqwv(mgs) .ge. 0. ) THEN +! + dqvcnd(mgs) = dqwv(mgs)/(1. + fcqv1(mgs)*qss(mgs)/ & + & ((temg(mgs)-cbw)**2)) +! +! + dqcw(mgs) = dqvcnd(mgs) +! + thetap(mgs) = thetap(mgs) + & + & (felvcp(mgs)*dqcw(mgs) ) & + & / (pi0(mgs)) + qwvp(mgs) = qwvp(mgs) - ( dqvcnd(mgs) ) + qcw(mgs) = qcw(mgs) + dqcw(mgs) +! + END IF ! dqwv(mgs) .ge. 0. + + theta(mgs) = thetap(mgs) + theta0(mgs) + temg(mgs) = theta(mgs)*pk(mgs) ! ( pres(mgs) / poo ) ** cap +! temg(mgs) = theta2temp( theta(mgs), pres(mgs) ) + qvap(mgs) = Max((qwvp(mgs) + qv0(mgs)), 0.0) + temcg(mgs) = temg(mgs) - tfr +! tqvcon = temg(mgs)-cbw + ltemq = (temg(mgs)-163.15)/fqsat+1.5 + ltemq = Min( nqsat, Max(1,ltemq) ) + qvs(mgs) = pqs(mgs)*tabqvs(ltemq) + qcw(mgs) = max( 0.0, qcw(mgs) ) + qwv(mgs) = max( 0.0, qvap(mgs)) + qss(mgs) = (0.01*ss1 + 1.0)*qvs(mgs) + end do +! +! end the saturation adjustment iteration loop +! +! + qvex = Max(0.0, qcw(mgs) - qcw1(mgs) ) + + RETURN + END SUBROUTINE QVEXCESS + +! ##################################################################### +! ##################################################################### + + + + + +! +! ############################################################################## +! +!>\ingroup mod_nsslmp +!! Mean hydrometeor size and fall speed calculations + SUBROUTINE setvtz(ngscnt,qx,qxmin,qxw,cx,rho0,rhovt,xdia,cno,cnostmp, & + & xmas,vtxbar,xdn,xvmn0,xvmx0,xv,cdx,cdxgs, & + & ipconc1,ndebug1,ngs,nz,kgs,fadvisc, & + & cwmasn,cwmasx,cwradn,cnina,cimna,cimxa, & + & itype1a,itype2a,temcg,infdo,alpha,ildo,axx,bxx) +! & itype1a,itype2a,temcg,infdo,alpha,ildo,axh,bxh,axhl,bxhl) + + + implicit none + + integer ngscnt,ngs0,ngs,nz +! integer infall ! whether to calculate number-weighted fall speeds + + real xv(ngs,lc:lhab) + real qx(ngs,lv:lhab) + real qxw(ngs,ls:lhab) + real cx(ngs,lc:lhab) + real vtxbar(ngs,lc:lhab,3) + real xmas(ngs,lc:lhab) + real xdn(ngs,lc:lhab) + real cdxgs(ngs,lc:lhab) + real xdia(ngs,lc:lhab,3) + real xvmn0(lc:lhab), xvmx0(lc:lhab) + real qxmin(lc:lhab) + real cdx(lc:lhab) + real alpha(ngs,lc:lhab) + + real rho0(ngs),rhovt(ngs),temcg(ngs) + real cno(lc:lhab) + real cnostmp(ngs) + + real cwc1, cimna, cimxa + real cnina(ngs) + integer kgs(ngs) + real fadvisc(ngs) + real fsw + + integer ipconc1 + integer ndebug1 + + integer, intent (in) :: itype1a,itype2a,infdo + integer, intent (in) :: ildo ! which species to do, or all if ildo=0 + + real :: axx(ngs,lh:lhab),bxx(ngs,lh:lhab) +!! real :: axh(ngs),bxh(ngs) +! real :: axhl(ngs),bxhl(ngs) + +! Local vars + + + + real swmasmx, dtmp + real cd + real cwc0 ! ,cwc1 + real :: cwch(ngscnt), cwchl(ngscnt) + real :: cwchtmp,cwchltmp,xnutmp + real pii + real cimasx,cimasn + real cwmasn,cwmasx,cwradn + real cwrad + real vr,rnux + real alp + + real ccimx + + integer mgs + + real arx,frx,vtrain,fw + real fwlo,fwhi,rfwdiff + real ar,br,cs,ds +! real gf4p5, gf4ds, gf4br, ifirst, gf1ds +! real gfcinu1, gfcinu1p47, gfcinu2p47 + real gr + real rwrad,rwdia + real mwfac + integer il + +! save gf4p5, gf4ds, gf4br, ifirst, gf1ds +! save gfcinu1, gfcinu1p47, gfcinu2p47 +! data ifirst /0/ + + real bta1,cnit + parameter ( bta1 = 0.6, cnit = 1.0e-02 ) + real x,y,tmp,del + real aax,bbx,delrho + integer :: indxr + real mwt, nwt, zwt + real, parameter :: rho00 = 1.225 + integer i + real xvbarmax + + integer l1, l2 + + +! +! set values +! +! cwmasn = 5.23e-13 ! radius of 5.0e-6 +! cwradn = 5.0e-6 +! cwmasx = 5.25e-10 ! radius of 50.0e-6 + + fwlo = 0.2 ! water fraction to start weighting toward rain fall speed + fwhi = 0.4 ! water fraction at which rain fall speed only is used + rfwdiff = 1./(fwhi - fwlo) + +! pi = 4.0*atan(1.0) + pii = piinv ! 1.0/pi + + arx = 10. + frx = 516.575 ! raind fit parameters for arx*(1 - Exp(-fx*d)), where d is rain diameter in meters. + + ar = 841.99666 + br = 0.8 + gr = 9.8 +! new values for cs and ds + cs = 12.42 + ds = 0.42 + + IF ( ildo == 0 ) THEN + l1 = lc + l2 = lhab + ELSE + l1 = ildo + l2 = ildo + ENDIF + +! IF ( ifirst .eq. 0 ) THEN +! ifirst = 1 +! gf4br = gamma(4.0+br) +! gf4ds = gamma(4.0+ds) +!! gf1ds = gamma(1.0+ds) +! gf4p5 = gamma(4.0+0.5) +! gfcinu1 = gamma(cinu + 1.0) +! gfcinu1p47 = gamma(cinu + 1.47167) +! gfcinu2p47 = gamma(cinu + 2.47167) + + IF ( lh .gt. 1 ) THEN + IF ( dmuh == 1.0 ) THEN + cwchtmp = ((3. + dnu(lh))*(2. + dnu(lh))*(1.0 + dnu(lh)))**(-1./3.) + ELSE + cwchtmp = 6.0*pii*gamma_sp( (xnu(lh) + 1.)/xmu(lh) )/gamma_sp( (xnu(lh) + 2.)/xmu(lh) ) + ENDIF + ENDIF + IF ( lhl .gt. 1 ) THEN + IF ( dmuhl == 1.0 ) THEN + cwchltmp = ((3. + dnu(lhl))*(2. + dnu(lhl))*(1.0 + dnu(lhl)))**(-1./3.) + ELSE + cwchltmp = 6.0*pii*gamma_sp( (xnu(lhl) + 1)/xmu(lhl) )/gamma_sp( (xnu(lhl) + 2)/xmu(lhl) ) + ENDIF + ENDIF + + IF ( ipconc .le. 5 ) THEN + IF ( lh .gt. 1 ) cwch(:) = cwchtmp + IF ( lhl .gt. 1 ) cwchl(:) = cwchltmp + ELSE + DO mgs = 1,ngscnt + + IF ( lh .gt. 1 .and. ( ildo == 0 .or. ildo == lh ) ) THEN + IF ( qx(mgs,lh) .gt. qxmin(lh) ) THEN + IF ( dmuh == 1.0 ) THEN + cwch(mgs) = ((3. + alpha(mgs,lh))*(2. + alpha(mgs,lh))*(1.0 + alpha(mgs,lh)))**(-1./3.) + ELSE + xnutmp = (alpha(mgs,lh) - 2.0)/3.0 + cwch(mgs) = 6.0*pii*gamma_sp( (xnutmp + 1.)/xmu(lh) )/gamma_sp( (xnutmp + 2.)/xmu(lh) ) + ENDIF + ELSE + cwch(mgs) = cwchtmp + ENDIF + ENDIF + IF ( lhl .gt. 1 .and. ( ildo == 0 .or. ildo == lhl ) ) THEN + IF ( qx(mgs,lhl) .gt. qxmin(lhl) ) THEN + IF ( dmuhl == 1.0 ) THEN + cwchl(mgs) = ((3. + alpha(mgs,lhl))*(2. + alpha(mgs,lhl))*(1.0 + alpha(mgs,lhl)))**(-1./3.) + ELSE + xnutmp = (alpha(mgs,lhl) - 2.0)/3.0 + cwchl(mgs) = 6.0*pii*gamma_sp( (xnutmp + 1)/xmu(lhl) )/gamma_sp( (xnutmp + 2)/xmu(lhl) ) + ENDIF + ELSE + cwchl(mgs) = cwchltmp + ENDIF + ENDIF + + ENDDO + + ENDIF + + + cimasn = Min( cimas0, 6.88e-13) + cimasx = 1.0e-8 + ccimx = 5000.0e3 ! max of 5000 per liter + + cwc1 = 6.0/(pi*1000.) + cwc0 = pii ! 6.0*pii + mwfac = 6.0**(1./3.) + + + if (ndebug1 .gt. 0 ) write(0,*) 'SETVTZ: Set scale diameter' +! + + +! +! cloud water variables +! ################################################################ +! +! DROPLETS +! +! + if ( ndebug1 .gt. 0 ) write(0,*) 'SETVTZ: Set cloud water variables' + + IF ( ildo == 0 .or. ildo == lc ) THEN + + do mgs = 1,ngscnt + xv(mgs,lc) = 0.0 + + IF ( qx(mgs,lc) .gt. qxmin(lc) ) THEN !{ + + IF ( ipconc .ge. 2 ) THEN + IF ( cx(mgs,lc) .gt. cxmin) THEN !{ + xmas(mgs,lc) = & + & min( max(qx(mgs,lc)*rho0(mgs)/cx(mgs,lc),cwmasn),cwmasx ) + xv(mgs,lc) = xmas(mgs,lc)/xdn(mgs,lc) + ELSE + cx(mgs,lc) = Max( cxmin, rho0(mgs)*qx(mgs,lc)/cwmasx ) + xmas(mgs,lc) = Min( max(qx(mgs,lc)*rho0(mgs)/cx(mgs,lc),cwmasn),cwmasx ) + xv(mgs,lc) = xmas(mgs,lc)/xdn(mgs,lc) + + ENDIF + ELSE + IF ( ipconc .lt. 2 ) THEN + cx(mgs,lc) = rho0(mgs)*ccn/rho00 ! scales to local density, relative to standard air density + ENDIF + IF ( qx(mgs,lc) .gt. qxmin(lc) .and. cx(mgs,lc) .gt. 0.01 ) THEN !{ + xmas(mgs,lc) = & + & min( max(qx(mgs,lc)*rho0(mgs)/cx(mgs,lc),xdn(mgs,lc)*xvmn(lc)), & + & xdn(mgs,lc)*xvmx(lc) ) + + xv(mgs,lc) = xmas(mgs,lc)/xdn(mgs,lc) + cx(mgs,lc) = qx(mgs,lc)*rho0(mgs)/xmas(mgs,lc) + + ELSEIF ( qx(mgs,lc) .gt. qxmin(lc) .and. cx(mgs,lc) .le. 1.0e-9 ) THEN + cx(mgs,lc) = Max( cxmin, rho0(mgs)*qx(mgs,lc)/cwmasx ) + xmas(mgs,lc) = & + & min( max(qx(mgs,lc)*rho0(mgs)/cx(mgs,lc),cwmasn),cwmasx ) + xv(mgs,lc) = xmas(mgs,lc)/xdn(mgs,lc) + + ELSEIF ( qx(mgs,lc) .gt. qxmin(lc) .and. cx(mgs,lc) .le. 0.01 ) THEN + xmas(mgs,lc) = xdn(mgs,lc)*4.*pi/3.*(5.0e-6)**3 + cx(mgs,lc) = rho0(mgs)*qx(mgs,lc)/xmas(mgs,lc) + xv(mgs,lc) = xmas(mgs,lc)/xdn(mgs,lc) + + ELSE + xmas(mgs,lc) = cwmasn + xv(mgs,lc) = xmas(mgs,lc)/1000. +! do not define ccw here! it can feed back to ccn!!! cx(mgs,lc) = 0.0 ! cwnc(mgs) + ENDIF !} + ENDIF !} +! IF ( ipconc .lt. 2 ) THEN +! xmas(mgs,lc) = & +! & min( max(qx(mgs,lc)*rho0(mgs)/cwnc(mgs),cwmasn),cwmasx ) +! cx(mgs,lc) = Max(1.0,qx(mgs,lc)*rho0(mgs)/xmas(mgs,lc)) +! ELSE +! cwnc(mgs) = an(igs(mgs),jgs,kgs(mgs),lnc) +! cx(mgs,lc) = cwnc(mgs) +! ENDIF + xdia(mgs,lc,1) = (xmas(mgs,lc)*cwc1)**(1./3.) + xdia(mgs,lc,2) = xdia(mgs,lc,1)**2 + xdia(mgs,lc,3) = xdia(mgs,lc,1) + cwrad = 0.5*xdia(mgs,lc,1) + IF ( fadvisc(mgs) > 0.0 ) THEN + vtxbar(mgs,lc,1) = & + & (2.0*gr*xdn(mgs,lc) *(cwrad**2)) & + & /(9.0*fadvisc(mgs)) + ELSE + vtxbar(mgs,lc,1) = 0.0 + ENDIF + + + ELSE + xmas(mgs,lc) = cwmasn + xv(mgs,lc) = xmas(mgs,lc)/xdn(mgs,lc) + IF ( qx(mgs,lc) <= 0.0 ) cx(mgs,lc) = 0.0 + IF ( ipconc .le. 1 ) cx(mgs,lc) = 0.01 + xdia(mgs,lc,1) = 2.*cwradn + xdia(mgs,lc,2) = 4.*cwradn**2 + xdia(mgs,lc,3) = xdia(mgs,lc,1) + vtxbar(mgs,lc,1) = 0.0 + + ENDIF !} qcw .gt. qxmin(lc) + + end do + + ENDIF + + + +! +! cloud ice variables +! columns +! +! ################################################################ +! +! CLOUD ICE +! + if ( ndebug1 .gt. 0 ) write(0,*) 'SETVTZ: Set cip' + + IF ( li .gt. 1 .and. ( ildo == 0 .or. ildo == li ) ) THEN + do mgs = 1,ngscnt + xdn(mgs,li) = 900.0 + IF ( ipconc .eq. 0 ) THEN +! cx(mgs,li) = min(cnit*exp(-temcg(mgs)*bta1),1.e+09) + cx(mgs,li) = cnina(mgs) + IF ( cimna .gt. 1.0 ) THEN + cx(mgs,li) = Max(cimna,cx(mgs,li)) + ENDIF + IF ( cimxa .gt. 1.0 ) THEN + cx(mgs,li) = Min(cimxa,cx(mgs,li)) + ENDIF +! erm 3/28/2002 + IF ( itype1a .ge. 1 .or. itype2a .ge. 1 ) THEN + cx(mgs,li) = Max(cx(mgs,li),qx(mgs,li)*rho0(mgs)/cimasx) + cx(mgs,li) = Min(cx(mgs,li),qx(mgs,li)*rho0(mgs)/cimasn) + ENDIF +! + cx(mgs,li) = max(1.0e-20,cx(mgs,li)) +! cx(mgs,li) = Min(ccimx, cx(mgs,li)) + + + ELSEIF ( ipconc .ge. 1 ) THEN + IF ( qx(mgs,li) .gt. qxmin(li) ) THEN + cx(mgs,li) = Max(cx(mgs,li),qx(mgs,li)*rho0(mgs)/cimasx) + cx(mgs,li) = Min(cx(mgs,li),qx(mgs,li)*rho0(mgs)/cimasn) +! cx(mgs,li) = Max(1.0,cx(mgs,li)) + ENDIF + ENDIF + + IF ( qx(mgs,li) .gt. qxmin(li) ) THEN + xmas(mgs,li) = & + & max( qx(mgs,li)*rho0(mgs)/cx(mgs,li), cimasn ) +! & min( max(qx(mgs,li)*rho0(mgs)/cx(mgs,li),cimasn),cimasx ) + +! if ( temcg(mgs) .gt. 0.0 ) then +! xdia(mgs,li,1) = 0.0 +! else + if ( xmas(mgs,li) .gt. 0.0 ) THEN ! cimasn ) then +!c xdia(mgs,li,1) = 0.4892*(xmas(mgs,li)**(0.4554)) +! xdia(mgs,li,1) = 0.1871*(xmas(mgs,li)**(0.3429)) + +! xdia(mgs,li,1) = (132.694*5.40662/xmas(mgs,li))**(-1./2.9163) ! for inverse exponential distribution + IF ( ixtaltype == 1 ) THEN ! column + xdia(mgs,li,1) = 0.1871*(xmas(mgs,li)**(0.3429)) + xdia(mgs,li,3) = 0.1871*(xmas(mgs,li)**(0.3429)) + ELSEIF ( ixtaltype == 2 ) THEN ! disk + xdia(mgs,li,1) = 0.277823*xmas(mgs,li)**0.359971 + xdia(mgs,li,3) = 0.277823*xmas(mgs,li)**0.359971 + ENDIF + end if +! end if +! xdia(mgs,li,1) = max(xdia(mgs,li,1), 5.e-6) +! xdia(mgs,li,1) = min(xdia(mgs,li,1), 1000.e-6) + + IF ( ipconc .ge. 0 ) THEN +! vtxbar(mgs,li,1) = rhovt(mgs)*49420.*40.0005/5.40662*xdia(mgs,li,1)**(1.415) ! mass-weighted +! vtxbar(mgs,li,1) = (4.942e4)*(xdia(mgs,li,1)**(1.4150)) + xv(mgs,li) = xmas(mgs,li)/xdn(mgs,li) + IF ( icefallopt == 1 ) THEN ! default ice fall + IF ( ixtaltype == 1 ) THEN ! column + tmp = (67056.6300748612*rhovt(mgs))/ & + & (((1.0 + cinu)/xv(mgs,li))**0.4716666666666667*gfcinu1) + vtxbar(mgs,li,2) = tmp*gfcinu1p47 + vtxbar(mgs,li,1) = tmp*gfcinu2p47/(1. + cinu) + vtxbar(mgs,li,3) = vtxbar(mgs,li,1) + ELSEIF ( ixtaltype == 2 ) THEN ! disk -- but just use Ferrier (1994) snow fall speeds for now + vtxbar(mgs,li,1) = 11.9495*rhovt(mgs)*(xv(mgs,li))**(0.14) + vtxbar(mgs,li,2) = 7.02909*rhovt(mgs)*(xv(mgs,li))**(0.14) + vtxbar(mgs,li,3) = vtxbar(mgs,li,1) + + ENDIF + + ELSEIF ( icefallopt == 2 ) THEN ! ! Ferrier ice fall speed + tmp = (82.3166*rhovt(mgs))/ & + & (((1.0 + cinu)/xv(mgs,li))**0.22117*gfcinu1) + vtxbar(mgs,li,2) = tmp*gfcinu1p22 + vtxbar(mgs,li,1) = tmp*gfcinu2p22/(1. + cinu) + vtxbar(mgs,li,3) = vtxbar(mgs,li,1) + + ELSEIF ( icefallopt == 3 ) THEN ! ! Adjusted Ferrier (smaller exponent of 0.55 instead of 0.6635) + + tmp = (47.6273*rhovt(mgs))/ & + & (((1.0 + cinu)/xv(mgs,li))**0.18333*gfcinu1) + vtxbar(mgs,li,2) = tmp*gfcinu1p18 + vtxbar(mgs,li,1) = tmp*gfcinu2p18/(1. + cinu) + vtxbar(mgs,li,3) = vtxbar(mgs,li,1) + + ENDIF +! vtxbar(mgs,li,1) = vtxbar(mgs,li,2)*(1.+cinu)/(1. + cinu) +! xdn(mgs,li) = min(max(769.8*xdia(mgs,li,1)**(-0.0140),300.0),900.0) +! xdn(mgs,li) = 900.0 + xdia(mgs,li,2) = xdia(mgs,li,1)**2 +! vtxbar(mgs,li,1) = vtxbar(mgs,li,1)*rhovt(mgs) + ELSE + xdia(mgs,li,1) = max(xdia(mgs,li,1), 10.e-6) + xdia(mgs,li,1) = min(xdia(mgs,li,1), 1000.e-6) + vtxbar(mgs,li,1) = (4.942e4)*(xdia(mgs,li,1)**(1.4150)) +! xdn(mgs,li) = min(max(769.8*xdia(mgs,li,1)**(-0.0140),300.0),900.0) + xdn(mgs,li) = 900.0 + xdia(mgs,li,2) = xdia(mgs,li,1)**2 + vtxbar(mgs,li,1) = vtxbar(mgs,li,1)*rhovt(mgs) + xv(mgs,li) = xmas(mgs,li)/xdn(mgs,li) + ENDIF ! ipconc gt 3 + ELSE + xmas(mgs,li) = 1.e-13 + IF ( qx(mgs,li) <= 0.0 ) cx(mgs,li) = 0.0 + xdn(mgs,li) = 900.0 + xdia(mgs,li,1) = 1.e-7 + xdia(mgs,li,2) = (1.e-14) + xdia(mgs,li,3) = 1.e-7 + vtxbar(mgs,li,1) = 0.0 +! cicap(mgs) = 0.0 +! ciat(mgs) = 0.0 + ENDIF + + IF ( icefallfac /= 1.0 ) THEN + vtxbar(mgs,li,1) = icefallfac*vtxbar(mgs,li,1) + vtxbar(mgs,li,2) = icefallfac*vtxbar(mgs,li,2) + vtxbar(mgs,li,3) = icefallfac*vtxbar(mgs,li,3) + ENDIF + + + + end do + + ENDIF ! li .gt. 1 + + +! ################################################################ +! +! RAIN +! + +! + IF ( ildo == 0 .or. ildo == lr ) THEN + do mgs = 1,ngscnt + if ( qx(mgs,lr) .gt. qxmin(lr) ) then + +! IF ( qx(mgs,lr) .gt. 10.0e-3 ) & +! & write(0,*) 'RAIN1: ',igs(mgs),kgs(mgs),qx(mgs,lr) + + if ( ipconc .ge. 3 ) then + xv(mgs,lr) = rho0(mgs)*qx(mgs,lr)/(xdn(mgs,lr)*Max(1.0e-11,cx(mgs,lr))) + xvbarmax = xvmx(lr) + IF ( imaxdiaopt == 1 ) THEN + xvbarmax = xvmx(lr) + ELSEIF ( imaxdiaopt == 2 ) THEN ! test against maximum mass diameter + IF ( imurain == 1 ) THEN + xvbarmax = xvmx(lr)/((3. + alpha(mgs,lr))**3/((3. + alpha(mgs,lr))*(2. + alpha(mgs,lr))*(1. + alpha(mgs,lr)))) + ELSEIF ( imurain == 3 ) THEN + + ENDIF + ELSEIF ( imaxdiaopt == 3 ) THEN ! test against mass-weighted diameter + IF ( imurain == 1 ) THEN + xvbarmax = xvmx(lr)/((4. + alpha(mgs,lr))**3/((3. + alpha(mgs,lr))*(2. + alpha(mgs,lr))*(1. + alpha(mgs,lr)))) + ELSEIF ( imurain == 3 ) THEN + + ENDIF + ENDIF + + IF ( xv(mgs,lr) .gt. xvbarmax ) THEN + xv(mgs,lr) = xvbarmax + cx(mgs,lr) = rho0(mgs)*qx(mgs,lr)/(xvbarmax*xdn(mgs,lr)) + ELSEIF ( xv(mgs,lr) .lt. xvmn(lr) ) THEN + xv(mgs,lr) = xvmn(lr) + cx(mgs,lr) = rho0(mgs)*qx(mgs,lr)/(xvmn(lr)*xdn(mgs,lr)) + ENDIF + + + xmas(mgs,lr) = xv(mgs,lr)*xdn(mgs,lr) + xdia(mgs,lr,3) = (xmas(mgs,lr)*cwc1)**(1./3.) ! xdia(mgs,lr,1) + IF ( imurain == 3 ) THEN +! xdia(mgs,lr,1) = (6.*pii*xv(mgs,lr)/(alpha(mgs,lr)+1.))**(1./3.) + xdia(mgs,lr,1) = xdia(mgs,lr,3) ! formulae for Ziegler (1985) use mean volume diameter, not lambda**(-1) + ELSE ! imurain == 1, Characteristic diameter (1/lambda) + xdia(mgs,lr,1) = (6.*pii*xv(mgs,lr)/((alpha(mgs,lr)+3.)*(alpha(mgs,lr)+2.)*(alpha(mgs,lr)+1.)))**(1./3.) + ENDIF +! rwrad(mgs) = 0.5*xdia(mgs,lr,1) + +! Inverse exponential version: +! xdia(mgs,lr,1) = +! & (qx(mgs,lr)*rho0(mgs) +! & /(pi*xdn(mgs,lr)*cx(mgs,lr)))**(0.333333) + ELSE + xdia(mgs,lr,1) = & + & (qx(mgs,lr)*rho0(mgs)/(pi*xdn(mgs,lr)*cno(lr)))**(0.25) + xmas(mgs,lr) = xdn(mgs,lr)*(pi/6.)*xdia(mgs,lr,1)**3 + xdia(mgs,lr,3) = (xmas(mgs,lr)*cwc1)**(1./3.) + cx(mgs,lr) = cno(lr)*xdia(mgs,lr,1) + xv(mgs,lr) = rho0(mgs)*qx(mgs,lr)/(xdn(mgs,lr)*cx(mgs,lr)) + end if + else + xdia(mgs,lr,1) = 1.e-9 + xdia(mgs,lr,3) = 1.e-9 + xmas(mgs,lr) = xdn(mgs,lr)*(pi/6.)*xdia(mgs,lr,1)**3 +! rwrad(mgs) = 0.5*xdia(mgs,lr,1) + end if + xdia(mgs,lr,2) = xdia(mgs,lr,1)**2 +! xmas(mgs,lr) = xdn(mgs,lr)*(pi/6.)*xdia(mgs,lr,1)**3 + end do + + ENDIF +! ################################################################ +! +! SNOW +! + + IF ( ls .gt. 1 .and. ( ildo == 0 .or. ildo == ls ) ) THEN + + do mgs = 1,ngscnt + if ( qx(mgs,ls) .gt. qxmin(ls) ) then + if ( ipconc .ge. 4 ) then ! + + xmas(mgs,ls) = rho0(mgs)*qx(mgs,ls)/(Max(1.0e-9,cx(mgs,ls))) + swmasmx = 13.7e-6 +! IF ( xmas(mgs,ls) > swmasmx ) THEN +! xmas(mgs,ls) = swmasmx +! cx(mgs,ls) = rho0(mgs)*qx(mgs,ls)/(xmas(mgs,ls)) +! ENDIF + + IF ( isnowdens == 2 ) THEN ! Set values according to Cox relationship + + xdn(mgs,ls) = 0.0346159*Sqrt(cx(mgs,ls)/(qx(mgs,ls)*rho0(mgs)) ) + xdn(mgs,ls) = Max( 100.0, xdn(mgs,ls) ) ! limit snow to 100. to keep other equations in line + + IF ( xdn(mgs,ls) <= 900. ) THEN + dtmp = Sqrt( xmas(mgs,ls)/0.069 ) ! diameter (meters) of mean mass particle using Cox 1998 relation (m = p d^2) + xv(mgs,ls) = 28.8887*xmas(mgs,ls)**(3./2.) + ELSE ! at small sizes, assume ice spheres + xdn(mgs,ls) = 900. + xv(mgs,ls) = rho0(mgs)*qx(mgs,ls)/(xdn(mgs,ls)*Max(1.0e-9,cx(mgs,ls))) + dtmp = (xv(mgs,ls)*cwc0*6.0)**(1./3.) + ENDIF + + ELSE ! leave xdn(ls) at default value + xv(mgs,ls) = rho0(mgs)*qx(mgs,ls)/(xdn(mgs,ls)*Max(1.0e-9,cx(mgs,ls))) + dtmp = (xv(mgs,ls)*cwc0*6.0)**(1./3.) + ENDIF + + xdia(mgs,ls,1) = dtmp ! (xv(mgs,ls)*cwc0*6.0)**(1./3.) + + IF ( xv(mgs,ls) .lt. xvmn(ls) .and. isnowdens == 1) THEN + xv(mgs,ls) = Max( xvmn(ls),xv(mgs,ls) ) + xmas(mgs,ls) = xv(mgs,ls)*xdn(mgs,ls) + cx(mgs,ls) = rho0(mgs)*qx(mgs,ls)/(xmas(mgs,ls)) + xdia(mgs,ls,1) = (xv(mgs,ls)*cwc0*6.0)**(1./3.) + ENDIF + + IF ( xv(mgs,ls) .gt. xvmx(ls)*Max(1.,100./Min(100.,xdn(mgs,ls))) ) THEN + xv(mgs,ls) = Min( xvmx(ls), Max( xvmn(ls),xv(mgs,ls) ) ) + xmas(mgs,ls) = 0.106214*xv(mgs,ls)**(2./3.) + cx(mgs,ls) = rho0(mgs)*qx(mgs,ls)/(xmas(mgs,ls)) + xdn(mgs,ls) = 0.0346159*Sqrt(cx(mgs,ls)/(qx(mgs,ls)*rho0(mgs)) ) + xdia(mgs,ls,1) = Sqrt( xmas(mgs,ls)/0.069 ) + ENDIF + + xdia(mgs,ls,3) = xdia(mgs,ls,1) + + ELSE + xdia(mgs,ls,1) = & + & (qx(mgs,ls)*rho0(mgs)/(pi*xdn(mgs,ls)*cnostmp(mgs)))**(0.25) + cx(mgs,ls) = cnostmp(mgs)*xdia(mgs,ls,1) + xv(mgs,ls) = rho0(mgs)*qx(mgs,ls)/(xdn(mgs,ls)*cx(mgs,ls)) + xdia(mgs,ls,3) = (xv(mgs,ls)*cwc0*6.0)**(1./3.) + end if + else + xdia(mgs,ls,1) = 1.e-9 + xdia(mgs,ls,3) = 1.e-9 + cx(mgs,ls) = 0.0 + + IF ( isnowdens == 2 ) THEN ! Set values according to Cox relationship + xdn(mgs,ls) = 90. + ENDIF + + end if + xdia(mgs,ls,2) = xdia(mgs,ls,1)**2 +! swdia3(mgs) = xdia(mgs,ls,2)*xdia(mgs,ls,1) +! xmas(mgs,ls) = xdn(mgs,ls)*(pi/6.)*swdia3(mgs) + end do + + ENDIF ! ls .gt 1 +! +! +! ################################################################ +! +! GRAUPEL +! + + IF ( lh .gt. 1 .and. ( ildo == 0 .or. ildo == lh ) ) THEN + + do mgs = 1,ngscnt + if ( qx(mgs,lh) .gt. qxmin(lh) ) then + if ( ipconc .ge. 5 ) then + + xv(mgs,lh) = rho0(mgs)*qx(mgs,lh)/(xdn(mgs,lh)*Max(1.0e-9,cx(mgs,lh))) + xmas(mgs,lh) = xv(mgs,lh)*xdn(mgs,lh) + + IF ( xv(mgs,lh) .lt. xvmn(lh) .or. xv(mgs,lh) .gt. xvmx(lh) ) THEN + xv(mgs,lh) = Min( xvmx(lh), Max( xvmn(lh),xv(mgs,lh) ) ) + xmas(mgs,lh) = xv(mgs,lh)*xdn(mgs,lh) + cx(mgs,lh) = rho0(mgs)*qx(mgs,lh)/(xmas(mgs,lh)) + ENDIF + + xdia(mgs,lh,3) = (xv(mgs,lh)*6.*pii)**(1./3.) ! mwfac*xdia(mgs,lh,1) ! (xv(mgs,lh)*cwc0*6.0)**(1./3.) + IF ( dmuh == 1.0 ) THEN + xdia(mgs,lh,1) = cwch(mgs)*xdia(mgs,lh,3) + ELSE + xdia(mgs,lh,1) = (xv(mgs,lh)*cwch(mgs))**(1./3.) + ENDIF + + ELSE + xdia(mgs,lh,1) = & + & (qx(mgs,lh)*rho0(mgs)/(pi*xdn(mgs,lh)*cno(lh)))**(0.25) + cx(mgs,lh) = cno(lh)*xdia(mgs,lh,1) + xv(mgs,lh) = Max(xvmn(lh), rho0(mgs)*qx(mgs,lh)/(xdn(mgs,lh)*cx(mgs,lh)) ) + xdia(mgs,lh,3) = (xv(mgs,lh)*6./pi)**(1./3.) + end if + else + xdia(mgs,lh,1) = 1.e-9 + xdia(mgs,lh,3) = 1.e-9 + end if + xdia(mgs,lh,2) = xdia(mgs,lh,1)**2 +! hwdia3(mgs) = xdia(mgs,lh,2)*xdia(mgs,lh,1) +! xmas(mgs,lh) = xdn(mgs,lh)*(pi/6.)*hwdia3(mgs) + end do + + ENDIF + +! +! ################################################################ +! +! HAIL +! + + IF ( lhl .gt. 1 .and. ( ildo == 0 .or. ildo == lhl ) ) THEN + + do mgs = 1,ngscnt + if ( qx(mgs,lhl) .gt. qxmin(lhl) ) then + if ( ipconc .ge. 5 ) then + + xv(mgs,lhl) = rho0(mgs)*qx(mgs,lhl)/(xdn(mgs,lhl)*Max(1.0e-9,cx(mgs,lhl))) + xmas(mgs,lhl) = xv(mgs,lhl)*xdn(mgs,lhl) +! write(0,*) 'setvt: xv = ',xv(mgs,lhl),xdn(mgs,lhl),cx(mgs,lhl),xmas(mgs,lhl),qx(mgs,lhl) + + IF ( xv(mgs,lhl) .lt. xvmn(lhl) .or. xv(mgs,lhl) .gt. xvmx(lhl) ) THEN + xv(mgs,lhl) = Min( xvmx(lhl), Max( xvmn(lhl),xv(mgs,lhl) ) ) + xmas(mgs,lhl) = xv(mgs,lhl)*xdn(mgs,lhl) + cx(mgs,lhl) = rho0(mgs)*qx(mgs,lhl)/(xmas(mgs,lhl)) + ENDIF + + xdia(mgs,lhl,3) = (xv(mgs,lhl)*6./pi)**(1./3.) ! mwfac*xdia(mgs,lh,1) ! (xv(mgs,lh)*cwc0*6.0)**(1./3.) + IF ( dmuhl == 1.0 ) THEN + xdia(mgs,lhl,1) = cwchl(mgs)*xdia(mgs,lhl,3) + ELSE + xdia(mgs,lhl,1) = (xv(mgs,lhl)*cwchl(mgs))**(1./3.) + ENDIF + +! write(0,*) 'setvt: xv = ',xv(mgs,lhl),xdn(mgs,lhl),cx(mgs,lhl),xdia(mgs,lhl,3) + ELSE + xdia(mgs,lhl,1) = & + & (qx(mgs,lhl)*rho0(mgs)/(pi*xdn(mgs,lhl)*cno(lhl)))**(0.25) + cx(mgs,lhl) = cno(lhl)*xdia(mgs,lhl,1) + xv(mgs,lhl) = Max(xvmn(lhl), rho0(mgs)*qx(mgs,lhl)/(xdn(mgs,lhl)*cx(mgs,lhl)) ) + xdia(mgs,lhl,3) = (xv(mgs,lhl)*6./pi)**(1./3.) + end if + else + xdia(mgs,lhl,1) = 1.e-9 + xdia(mgs,lhl,3) = 1.e-9 + end if + xdia(mgs,lhl,2) = xdia(mgs,lhl,1)**2 +! hwdia3(mgs) = xdia(mgs,lh,2)*xdia(mgs,lh,1) +! xmas(mgs,lh) = xdn(mgs,lh)*(pi/6.)*hwdia3(mgs) + end do + + ENDIF +! +! +! +! Set terminal velocities... +! also set drag coefficients (moved to start of subroutine) +! +! cdx(lr) = 0.60 +! cdx(lh) = 0.45 +! cdx(lhl) = 0.45 +! cdx(lf) = 0.45 +! cdx(lgh) = 0.60 +! cdx(lgm) = 0.80 +! cdx(lgl) = 0.80 +! cdx(lir) = 2.00 +! + if ( ndebug1 .gt. 0 ) write(0,*) 'SETVTZ: Set terminal velocities' +! +! +! ################################################################ +! +! RAIN +! + IF ( ildo == 0 .or. ildo == lr ) THEN + do mgs = 1,ngscnt + if ( qx(mgs,lr) .gt. qxmin(lr) ) then + IF ( ipconc .lt. 3 ) THEN + vtxbar(mgs,lr,1) = rainfallfac*(ar*gf4br/6.0)*(xdia(mgs,lr,1)**br)*rhovt(mgs) +! write(91,*) 'vtxbar: ',vtxbar(mgs,lr,1),mgs,gf4br,xdia(mgs,lr,1),rhovt(mgs) + ELSE + + IF ( imurain == 1 ) THEN ! DSD of Diameter + + ! using functional form of arx*(1 - Exp(-frx*diameter) ), with arx = arx = 10. + ! and frx = 516.575 ! raind fit parameters for arx*(1 - Exp(-fx*d)), where d is rain diameter in meters. + ! Similar form as in Atlas et al. (1973), who had 9.65 - 10.3*Exp[-600 * d] + + + alp = alpha(mgs,lr) + + vtxbar(mgs,lr,1) = rhovt(mgs)*arx*(1.0 - (1.0 + frx*xdia(mgs,lr,1))**(-alp - 4.0) ) ! mass weighted + + IF ( infdo .ge. 1 .and. rssflg == 1 ) THEN + vtxbar(mgs,lr,2) = rhovt(mgs)*arx*(1.0 - (1.0 + frx*xdia(mgs,lr,1))**(-alp - 1.0) ) ! number weighted + ELSE + vtxbar(mgs,lr,2) = vtxbar(mgs,lr,1) + ENDIF + + IF ( infdo .ge. 2 .and. rssflg == 1 ) THEN + vtxbar(mgs,lr,3) = rhovt(mgs)*arx*(1.0 - (1.0 + frx*xdia(mgs,lr,1))**(-alp - 7.0) ) ! z-weighted + ELSE + vtxbar(mgs,lr,3) = vtxbar(mgs,lr,1) + ENDIF + +! write(91,*) 'setvt: alp,vn,vm,vz = ',alp,vtxbar(mgs,lr,2), vtxbar(mgs,lr,1), vtxbar(mgs,lr,3),alpha(mgs,lr) + + ELSEIF ( imurain == 3 ) THEN ! DSD of Volume + + IF ( lzr < 1 ) THEN ! not 3-moment rain + rwdia = Min( xdia(mgs,lr,1), 8.0e-3 ) + + vtxbar(mgs,lr,1) = rhovt(mgs)*6.0*pii*( 0.04771 + 3788.0*rwdia - & + & 1.105e6*rwdia**2 + 1.412e8*rwdia**3 - 6.527e9*rwdia**4) + + IF ( infdo .ge. 1 ) THEN + IF ( rssflg >= 1 ) THEN + vtxbar(mgs,lr,2) = (0.09112 + 2714.0*rwdia - 4.872e5*rwdia**2 + & + & 4.495e7*rwdia**3 - 1.626e9*rwdia**4)*rhovt(mgs) + ELSE + vtxbar(mgs,lr,2) = vtxbar(mgs,lr,1) + ENDIF + ENDIF + + IF ( infdo .ge. 2 ) THEN ! Z-weighted fall speed + vtxbar(mgs,lr,3) = rhovt(mgs)*( & + & 0.0911229 + & + & 9246.494*(rwdia) - & + & 3.2839926e6*(rwdia**2) + & + & 4.944093e8*(rwdia**3) - & + & 2.631718e10*(rwdia**4) ) + ENDIF + + ELSE ! 3-moment rain, gamma-volume + + vr = xv(mgs,lr) + rnux = alpha(mgs,lr) + + IF ( infdo .ge. 1 .and. rssflg == 1) THEN ! number-weighted; DTD: added size-sorting flag + vtxbar(mgs,lr,2) = rhovt(mgs)* & + & (((1. + rnux)/vr)**(-1.333333)* & + & (0.0911229*((1. + rnux)/vr)**1.333333*Gamma_sp(1. + rnux) + & + & (5430.3131*(1. + rnux)*Gamma_sp(4./3. + rnux))/ & + & vr - 1.0732802e6*((1. + rnux)/vr)**0.6666667* & + & Gamma_sp(1.666667 + rnux) + & + & 8.584110982429507e7*((1. + rnux)/vr)**(1./3.)* & + & Gamma_sp(2. + rnux) - & + & 2.3303765697228556e9*Gamma_sp(7./3. + rnux)))/ & + & Gamma_sp(1. + rnux) + ENDIF + +! mass-weighted + vtxbar(mgs,lr,1) = rhovt(mgs)* & + & (0.0911229*(1 + rnux)**1.3333333333333333*Gamma_sp(2. + rnux) + & + & 5430.313059683277*(1 + rnux)*vr**0.3333333333333333* & + & Gamma_sp(2.333333333333333 + rnux) - & + & 1.0732802065650471e6*(1 + rnux)**0.6666666666666666*vr**0.6666666666666666* & + & Gamma_sp(2.6666666666666667 + rnux) + & + & 8.584110982429507e7*(1 + rnux)**0.3333333333333333*vr*Gamma_sp(3 + rnux) - & + & 2.3303765697228556e9*vr**1.3333333333333333* & + & Gamma_sp(3.333333333333333 + rnux))/ & + & ((1 + rnux)**2.333333333333333*Gamma_sp(1 + rnux)) + + IF(infdo .ge. 1 .and. rssflg == 0) THEN ! No size-sorting, set N-weighted fall speed to mass-weighted + vtxbar(mgs,lr,2) = vtxbar(mgs,lr,1) + ENDIF + + IF ( infdo .ge. 2 .and. rssflg == 1) THEN ! Z-weighted fall speed + vtxbar(mgs,lr,3) = rhovt(mgs)* & + & ((1. + rnux)*(0.0911229*(1 + rnux)**1.3333333333333333*Gamma_sp(3. + rnux) + & + & 5430.313059683277*(1 + rnux)*vr**0.3333333333333333* & + & Gamma_sp(3.3333333333333335 + rnux) - & + & 1.0732802065650471e6*(1 + rnux)**0.6666666666666666* & + & vr**0.6666666666666666*Gamma_sp(3.6666666666666665 + rnux) + & + & 8.5841109824295e7*(1 + rnux)**0.3333333333333333*vr*Gamma_sp(4. + rnux) - & + & 2.3303765697228556e9*vr**1.3333333333333333* & + & Gamma_sp(4.333333333333333 + rnux)))/ & + & ((1 + rnux)**3.3333333333333335*(2 + rnux)*Gamma_sp(1 + rnux)) + +! write(0,*) 'setvt: mgs,lzr,infdo = ',mgs,lzr,infdo +! write(0,*) 'vt1,2,3 = ',vtxbar(mgs,lr,1),vtxbar(mgs,lr,2),vtxbar(mgs,lr,3) + + ELSEIF (infdo .ge. 2) THEN ! No size-sorting, set Z-weighted fall speed to mass-weighted + vtxbar(mgs,lr,3) = vtxbar(mgs,lr,1) + ENDIF + + + ENDIF + ENDIF ! imurain + +! IF ( rwrad*mwfac .gt. 6.0e-4 ) THEN +! vtxbar(mgs,lr,1) = 20.1*Sqrt(100.*rwrad*mwfac)*rhovt(mgs) +! ELSE +! vtxbar(mgs,lr,1) = 80.0e2*rwrad*rhovt(mgs)*mwfac +! ENDIF +! IF ( rwrad .gt. 6.0e-4 ) THEN +! vtxbar(mgs,lr,2) = 20.1*Sqrt(100.*rwrad)*rhovt(mgs) +! ELSE +! vtxbar(mgs,lr,2) = 80.0e2*rwrad*rhovt(mgs) +! ENDIF + ENDIF ! ipconc + else ! qr < qrmin + vtxbar(mgs,lr,1) = 0.0 + vtxbar(mgs,lr,2) = 0.0 + end if + end do + if ( ndebug1 .gt. 0 ) write(0,*) 'SETVTZ: Set rain vt' + + ENDIF +! +! ################################################################ +! +! SNOW !Zrnic et al. (1993) +! + IF ( ls .gt. 1 .and. ( ildo == 0 .or. ildo == ls ) ) THEN + do mgs = 1,ngscnt + if ( qx(mgs,ls) .gt. qxmin(ls) ) then + IF ( ipconc .ge. 4 ) THEN + if ( mixedphase .and. qsvtmod ) then + else + IF ( isnowfall == 1 ) THEN + ! original (Zrnic et al. 1993) + vtxbar(mgs,ls,1) = 5.72462*rhovt(mgs)*(xv(mgs,ls))**(1./12.) + ELSEIF ( isnowfall == 2 ) THEN + ! Ferrier: + IF ( isnowdens == 1 ) THEN + vtxbar(mgs,ls,1) = 11.9495*rhovt(mgs)*(xv(mgs,ls))**(0.14) + ELSE + vtxbar(mgs,ls,1) = 11.9495*rhovt(mgs)*(xv(mgs,ls)*xdn(mgs,ls)/100.)**(0.14) + ENDIF + ELSEIF ( isnowfall == 3 ) THEN + ! Cox, mass distrib: + vtxbar(mgs,ls,1) = 50.092*rhovt(mgs)*(xmas(mgs,ls))**(0.2635) + ENDIF + + IF(Abs(sssflg) >= 1) THEN + IF ( isnowfall == 1 ) THEN + vtxbar(mgs,ls,2) = 4.04091*rhovt(mgs)*(xv(mgs,ls))**(1./12.) + ELSEIF ( isnowfall == 2 ) THEN + ! Ferrier: + IF ( isnowdens == 1 ) THEN + vtxbar(mgs,ls,2) = 7.02909*rhovt(mgs)*(xv(mgs,ls))**(0.14) ! bug fix 11/15/2015: was rewriting to mass fall speed vtxbar(mgs,ls,1) + ELSE + vtxbar(mgs,ls,2) = 7.02909*rhovt(mgs)*(xv(mgs,ls)*xdn(mgs,ls)/100.)**(0.14) ! bug fix 11/15/2015: was rewriting to mass fall speed vtxbar(mgs,ls,1) + ENDIF + ELSEIF ( isnowfall == 3 ) THEN + ! Cox, mass distrib: + vtxbar(mgs,ls,2) = 21.6147*rhovt(mgs)*(xmas(mgs,ls))**(0.2635) + ENDIF + ELSE + vtxbar(mgs,ls,2) = vtxbar(mgs,ls,1) + ENDIF + IF ( infdo >= 2 ) THEN + IF ( isnowfall == 1 ) THEN + vtxbar(mgs,ls,3) = 6.12217*rhovt(mgs)*(xv(mgs,ls))**(1./12.) ! Zrnic et al 93 + ELSEIF ( isnowfall == 2 ) THEN + vtxbar(mgs,ls,3) = 13.3436*rhovt(mgs)*(xv(mgs,ls))**(0.14) ! Ferrier 94 + ELSEIF ( isnowfall == 3 ) THEN + ! Cox, mass distrib: + vtxbar(mgs,ls,3) = 61.0914*rhovt(mgs)*(xmas(mgs,ls))**(0.2635) + ENDIF + ENDIF + + IF ( sssflg < 0 .and. temcg(mgs) > Abs(sssflg) ) THEN ! above a given temperature, effectively turn off size sorting + vtxbar(mgs,ls,2) = vtxbar(mgs,ls,1) + vtxbar(mgs,ls,3) = vtxbar(mgs,ls,1) + ENDIF + + endif + ELSE ! single-moment: + vtxbar(mgs,ls,1) = (cs*gf4ds/6.0)*(xdia(mgs,ls,1)**ds)*rhovt(mgs) + vtxbar(mgs,ls,2) = vtxbar(mgs,ls,1) + ENDIF + else + vtxbar(mgs,ls,1) = 0.0 + end if + + IF ( snowfallfac /= 1.0 ) THEN + vtxbar(mgs,ls,1) = snowfallfac*vtxbar(mgs,ls,1) + vtxbar(mgs,ls,2) = snowfallfac*vtxbar(mgs,ls,2) + vtxbar(mgs,ls,3) = snowfallfac*vtxbar(mgs,ls,3) + ENDIF + + + end do + if ( ndebug1 .gt. 0 ) write(0,*) 'SETVTZ: Set snow vt' + + ENDIF ! ls .gt. 1 +! +! +! ################################################################ +! +! GRAUPEL !Wisner et al. (1972) +! + IF ( lh .gt. 1 .and. ( ildo == 0 .or. ildo == lh ) ) THEN + + do mgs = 1,ngscnt + vtxbar(mgs,lh,1) = 0.0 + if ( qx(mgs,lh) .gt. qxmin(lh) ) then + cd = cdx(lh) + IF ( icdx .eq. 1 ) THEN + cd = cdx(lh) + ELSEIF ( icdx .eq. 2 ) THEN +! cd = Max(0.6, Min(1.0, 0.6 + 0.4*(xdnmx(lh) - xdn(mgs,lh))/(xdnmx(lh)-xdnmn(lh)) ) ) +! cd = Max(0.6, Min(1.0, 0.6 + 0.4*(900.0 - xdn(mgs,lh))/(900. - 300.) ) ) + cd = Max(0.45, Min(1.0, 0.45 + 0.35*(800.0 - Max( 500., Min( 800.0, xdn(mgs,lh) ) ) )/(800. - 500.) ) ) +! cd = Max(0.55, Min(1.0, 0.55 + 0.25*(800.0 - Max( 500., Min( 800.0, xdn(mgs,lh) ) ) )/(800. - 500.) ) ) + ELSEIF ( icdx .eq. 3 ) THEN +! cd = Max(0.45, Min(1.0, 0.45 + 0.55*(800.0 - Max( 300., Min( 800.0, xdn(mgs,lh) ) ) )/(800. - 300.) ) ) + cd = Max(0.45, Min(1.2, 0.45 + 0.55*(800.0 - Max( hdnmn, Min( 800.0, xdn(mgs,lh) ) ) )/(800. - 170.0) ) ) + ELSEIF ( icdx .eq. 4 ) THEN + cd = Max(cdhmin, Min(cdhmax, cdhmin + (cdhmax-cdhmin)* & + & (cdhdnmax - Max( cdhdnmin, Min( cdhdnmax, xdn(mgs,lh) ) ) )/(cdhdnmax - cdhdnmin) ) ) + ELSEIF ( icdx .eq. 5 ) THEN + cd = cdx(lh)*(xdn(mgs,lh)/rho_qh)**(2./3.) + ELSEIF ( icdx .eq. 6 ) THEN ! Milbrandt and Morrison (2013) + indxr = Int( (xdn(mgs,lh)-50.)/100. ) + 1 + indxr = Min( ngdnmm, Max(1,indxr) ) + + + delrho = Max( 0.0, 0.01*(xdn(mgs,lh) - mmgraupvt(indxr,1)) ) + IF ( indxr < ngdnmm ) THEN + + axx(mgs,lh) = mmgraupvt(indxr,2) + delrho*(mmgraupvt(indxr+1,2) - mmgraupvt(indxr,2) ) + bxx(mgs,lh) = mmgraupvt(indxr,3) + delrho*(mmgraupvt(indxr+1,3) - mmgraupvt(indxr,3) ) + + + ELSE + axx(mgs,lh) = mmgraupvt(indxr,2) + bxx(mgs,lh) = mmgraupvt(indxr,3) + ENDIF + + aax = axx(mgs,lh) + bbx = bxx(mgs,lh) + + cd = Max(0.45, Min(1.2, 0.45 + 0.55*(800.0 - Max( hdnmn, Min( 800.0, xdn(mgs,lh) ) ) )/(800. - 170.0) ) ) + + ELSEIF ( icdx <= 0 ) THEN ! + aax = ax(lh) + bbx = bx(lh) + cd = Max(0.45, Min(1.2, 0.45 + 0.55*(800.0 - Max( hdnmn, Min( 800.0, xdn(mgs,lh) ) ) )/(800. - 170.0) ) ) + ELSE + cd = Max(0.45, Min(1.2, 0.45 + 0.55*(800.0 - Max( hdnmn, Min( 800.0, xdn(mgs,lh) ) ) )/(800. - 170.0) ) ) + ENDIF + + cdxgs(mgs,lh) = cd + IF ( alpha(mgs,lh) .eq. 0.0 .and. icdx > 0 .and. icdx /= 6 ) THEN +! axx(mgs,lh) = (gf4p5/6.0)* & +! & Sqrt( (xdn(mgs,lh)*4.0*gr) / & +! & (3.0*cd*rho0(mgs)) ) + axx(mgs,lh) = Sqrt(4.0*xdn(mgs,lh)*gr/(3.0*cd*rho00)) + bxx(mgs,lh) = 0.5 + vtxbar(mgs,lh,1) = (gf4p5/6.0)* rhovt(mgs)*axx(mgs,lh) * Sqrt(xdia(mgs,lh,1)) +! vtxbar(mgs,lh,1) = (gf4p5/6.0)* & +! & Sqrt( (xdn(mgs,lh)*xdia(mgs,lh,1)*4.0*gr) / & +! & (3.0*cd*rho0(mgs)) ) + ELSE + IF ( icdx /= 6 ) bbx = bx(lh) + tmp = 4. + alpha(mgs,lh) + bbx + i = Int(dgami*(tmp)) + del = tmp - dgam*i + x = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami + + tmp = 4. + alpha(mgs,lh) + i = Int(dgami*(tmp)) + del = tmp - dgam*i + y = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami + +! aax = Max( 1.0, Min(2.0, (xdn(mgs,lh)/400.) ) ) +! vtxbar(mgs,lh,1) = rhovt(mgs)*aax*ax(lh)*(xdia(mgs,lh,1)**bx(lh)*x)/y + + IF ( icdx > 0 .and. icdx /= 6) THEN + aax = Sqrt(4.0*xdn(mgs,lh)*gr/(3.0*cd*rho00)) + vtxbar(mgs,lh,1) = rhovt(mgs)*aax* Sqrt(xdia(mgs,lh,1)) * x/y + axx(mgs,lh) = aax + bxx(mgs,lh) = bbx + ELSEIF (icdx == 6 ) THEN + vtxbar(mgs,lh,1) = rhovt(mgs)*aax* xdia(mgs,lh,1)**bbx * x/y + ELSE ! icdx < 0 + axx(mgs,lh) = ax(lh) + bxx(mgs,lh) = bx(lh) + vtxbar(mgs,lh,1) = rhovt(mgs)*ax(lh)*(xdia(mgs,lh,1)**bx(lh)*x)/y + ENDIF + +! & Gamma_sp(4.0 + dnu(lh) + 0.6))/Gamma_sp(4. + dnu(lh)) + ENDIF + + IF ( lwsm6 .and. ipconc == 0 ) THEN +! vtxbar(mgs,lh,1) = (330.*gf4ds/6.0)*(xdia(mgs,ls,1)**ds)*rhovt(mgs) + vtxbar(mgs,lh,1) = (330.*gf4br/6.0)*(xdia(mgs,lh,1)**br)*rhovt(mgs) + ENDIF + + end if + end do + if ( ndebug1 .gt. 0 ) write(0,*) 'SETVTZ: Set hail vt' + + ENDIF ! lh .gt. 1 +! +! +! ################################################################ +! +! HAIL +! + IF ( lhl .gt. 1 .and. ( ildo == 0 .or. ildo == lhl ) ) THEN + + do mgs = 1,ngscnt + vtxbar(mgs,lhl,1) = 0.0 + if ( qx(mgs,lhl) .gt. qxmin(lhl) ) then + + IF ( icdxhl .eq. 1 ) THEN + cd = cdx(lhl) + ELSEIF ( icdxhl .eq. 3 ) THEN +! cd = Max(0.45, Min(1.0, 0.45 + 0.55*(800.0 - Max( 300., Min( 800.0, xdn(mgs,lhl) ) ) )/(800. - 300.) ) ) + cd = Max(0.45, Min(1.2, 0.45 + 0.55*(800.0 - Max( hldnmn, Min( 800.0, xdn(mgs,lhl) ) ) )/(800. - 170.0) ) ) + ELSEIF ( icdxhl .eq. 4 ) THEN + cd = Max(cdhlmin, Min(cdhlmax, cdhlmin + (cdhlmax-cdhlmin)* & + & (cdhldnmax - Max( cdhldnmin, Min( cdhldnmax, xdn(mgs,lhl) ) ) )/(cdhldnmax - cdhldnmin) ) ) + ELSEIF ( icdxhl .eq. 5 ) THEN + cd = cdx(lh)*(xdn(mgs,lhl)/rho_qh)**(2./3.) + ELSEIF ( icdxhl .eq. 6 ) THEN ! Milbrandt and Morrison (2013) + indxr = Int( (xdn(mgs,lhl)-50.)/100. ) + 1 + indxr = Min( ngdnmm, Max(1,indxr) ) + + + delrho = Max( 0.0, 0.01*(xdn(mgs,lhl) - mmgraupvt(indxr,1)) ) + IF ( indxr < ngdnmm ) THEN + + axx(mgs,lhl) = mmgraupvt(indxr,2) + delrho*(mmgraupvt(indxr+1,2) - mmgraupvt(indxr,2) ) + bxx(mgs,lhl) = mmgraupvt(indxr,3) + delrho*(mmgraupvt(indxr+1,3) - mmgraupvt(indxr,3) ) + + + ELSE + axx(mgs,lhl) = mmgraupvt(indxr,2) + bxx(mgs,lhl) = mmgraupvt(indxr,3) + ENDIF + + aax = axx(mgs,lhl) + bbx = bxx(mgs,lhl) + + cd = Max(0.45, Min(1.2, 0.45 + 0.55*(800.0 - Max( hldnmn, Min( 800.0, xdn(mgs,lhl) ) ) )/(800. - 170.0) ) ) + + ELSE +! cd = Max(0.6, Min(1.0, 0.6 + 0.4*(900.0 - xdn(mgs,lhl))/(900. - 300.) ) ) +! cd = Max(0.5, Min(0.8, 0.5 + 0.3*(xdnmx(lhl) - xdn(mgs,lhl))/(xdnmx(lhl)-xdnmn(lhl)) ) ) +! cd = Max(0.45, Min(0.6, 0.45 + 0.15*(800.0 - Max( 500., Min( 800.0, xdn(mgs,lhl) ) ) )/(800. - 500.) ) ) + cd = Max(0.45, Min(1.2, 0.45 + 0.55*(800.0 - Max( hldnmn, Min( 800.0, xdn(mgs,lhl) ) ) )/(800. - 170.0) ) ) + ENDIF + + cdxgs(mgs,lhl) = cd + + IF ( alpha(mgs,lhl) .eq. 0.0 .and. icdxhl > 0 .and. icdxhl /= 6) THEN +! axx(mgs,lhl) = (gf4p5/6.0)* & +! & Sqrt( (xdn(mgs,lhl)*4.0*gr) / & +! & (3.0*cd*rho0(mgs)) ) + axx(mgs,lhl) = Sqrt(4.0*xdn(mgs,lhl)*gr/(3.0*cd*rho00)) + bxx(mgs,lhl) = 0.5 + vtxbar(mgs,lhl,1) = (gf4p5/6.0)* rhovt(mgs)*axx(mgs,lhl) * Sqrt(xdia(mgs,lhl,1)) + ELSE + IF ( icdxhl /= 6 ) bbx = bx(lhl) + tmp = 4. + alpha(mgs,lhl) + bbx + i = Int(dgami*(tmp)) + del = tmp - dgam*i + x = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami + + tmp = 4. + alpha(mgs,lhl) + i = Int(dgami*(tmp)) + del = tmp - dgam*i + y = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami + + IF ( icdxhl > 0 .and. icdxhl /= 6) THEN + aax = Sqrt(4.0*xdn(mgs,lhl)*gr/(3.0*cd*rho00)) + vtxbar(mgs,lhl,1) = rhovt(mgs)*aax* Sqrt(xdia(mgs,lhl,1)) * x/y + axx(mgs,lhl) = aax + bxx(mgs,lhl) = bbx + ELSEIF ( icdxhl == 6 ) THEN + vtxbar(mgs,lhl,1) = rhovt(mgs)*aax* (xdia(mgs,lhl,1))**bbx * x/y + ELSE + axx(mgs,lhl) = ax(lhl) + bxx(mgs,lhl) = bx(lhl) + vtxbar(mgs,lhl,1) = rhovt(mgs)*(ax(lhl)*xdia(mgs,lhl,1)**bx(lhl)*x)/y + ENDIF + +! & Gamma_sp(4.0 + dnu(lh) + 0.6))/Gamma_sp(4. + dnu(lh)) + ENDIF + + + end if + end do + if ( ndebug1 .gt. 0 ) write(0,*) 'SETVTZ: Set hail vt' + + ENDIF ! lhl .gt. 1 + + + IF ( infdo .ge. 1 ) THEN + +! DO il = lc,lhab +! IF ( il .ne. lr ) THEN + DO mgs = 1,ngscnt + IF ( ildo == 0 .or. ildo == lc ) THEN + vtxbar(mgs,lc,2) = vtxbar(mgs,lc,1) + ENDIF + IF ( li .gt. 1 ) THEN +! vtxbar(mgs,li,2) = rhovt(mgs)*49420.*1.25447*xdia(mgs,li,1)**(1.415) ! n-wgt (Ferrier 94) +! vtxbar(mgs,li,2) = vtxbar(mgs,li,1) + +! test print stuff... +! IF ( xdia(mgs,li,1) .gt. 200.e-6 ) THEN +! tmp = (xv(mgs,li)*cwc0)**(1./3.) +! x = rhovt(mgs)*49420.*40.0005/5.40662*tmp**(1.415) +! y = rhovt(mgs)*49420.*1.25447*tmp**(1.415) +! write(6,*) 'Ice fall: ',vtxbar(mgs,li,1),x,y,tmp,xdia(mgs,li,1) +! ENDIF + ENDIF +! vtxbar(mgs,ls,2) = vtxbar(mgs,ls,1) + ENDDO + + IF ( lg .gt. lr ) THEN + + DO il = lg,lhab + IF ( ildo == 0 .or. ildo == il ) THEN + + DO mgs = 1,ngscnt + IF ( qx(mgs,il) .gt. qxmin(il) ) THEN + IF ( (il .eq. lh .and. hssflg == 1) .or. ( lhl .gt. 1 .and. il .eq. lhl .and. hlssflg == 1) ) THEN ! DTD: added flag for size-sorting + + ! DTD: allow for setting of number-weighted and z-weighted fall speeds to the mass-weighted value, + ! effectively turning off size-sorting + + IF ( il .eq. lh ) THEN ! { + + IF ( icdx .eq. 1 ) THEN + cd = cdx(lh) + ELSEIF ( icdx .eq. 2 ) THEN +! cd = Max(0.6, Min(1.0, 0.6 + 0.4*(xdnmx(lh) - xdn(mgs,lh))/(xdnmx(lh)-xdnmn(lh)) ) ) +! cd = Max(0.6, Min(1.0, 0.6 + 0.4*(900.0 - xdn(mgs,lh))/(900. - 300.) ) ) + cd = Max(0.45, Min(1.0, 0.45 + 0.35*(800.0 - Max( 500., Min( 800.0, xdn(mgs,lh) ) ) )/(800. - 500.) ) ) +! cd = Max(0.55, Min(1.0, 0.55 + 0.25*(800.0 - Max( 500., Min( 800.0, xdn(mgs,lh) ) ) )/(800. - 500.) ) ) + ELSEIF ( icdx .eq. 3 ) THEN +! cd = Max(0.45, Min(1.0, 0.45 + 0.55*(800.0 - Max( 170.0, Min( 800.0, xdn(mgs,lh) ) ) )/(800. - 170.0) ) ) + cd = Max(0.45, Min(1.2, 0.45 + 0.55*(800.0 - Max( hdnmn, Min( 800.0, xdn(mgs,lh) ) ) )/(800. - 170.0) ) ) + ELSEIF ( icdx .eq. 4 ) THEN + cd = Max(cdhmin, Min(cdhmax, cdhmin + (cdhmax-cdhmin)* & + & (cdhdnmax - Max( cdhdnmin, Min( cdhdnmax, xdn(mgs,lh) ) ) )/(cdhdnmax - cdhdnmin) ) ) + ELSEIF ( icdx .eq. 5 ) THEN + cd = cdx(lh)*(xdn(mgs,lh)/rho_qh)**(2./3.) + ELSEIF ( icdx .eq. 6 ) THEN ! Milbrandt and Morrison (2013) + aax = axx(mgs,lh) + bbx = bxx(mgs,lh) + ELSEIF ( icdx <= 0 ) THEN ! + aax = ax(lh) + bbx = bx(lh) + ENDIF + + ELSEIF ( lhl .gt. 1 .and. il .eq. lhl ) THEN + + IF ( icdxhl .eq. 1 ) THEN + cd = cdx(lhl) + ELSEIF ( icdxhl .eq. 3 ) THEN +! cd = Max(0.45, Min(1.0, 0.45 + 0.55*(800.0 - Max( 300., Min( 800.0, xdn(mgs,lhl) ) ) )/(800. - 300.) ) ) + cd = Max(0.45, Min(1.2, 0.45 + 0.55*(800.0 - Max( hldnmn, Min( 800.0, xdn(mgs,lhl) ) ) )/(800. - 170.0) ) ) + ELSEIF ( icdxhl .eq. 4 ) THEN + cd = Max(cdhlmin, Min(cdhlmax, cdhlmin + (cdhlmax-cdhlmin)* & + & (cdhldnmax - Max( cdhldnmin, Min( cdhldnmax, xdn(mgs,lhl) ) ) )/(cdhldnmax - cdhldnmin) ) ) + ELSEIF ( icdxhl == 5 ) THEN +! cd = Max(0.6, Min(1.0, 0.6 + 0.4*(900.0 - xdn(mgs,lhl))/(900. - 300.) ) ) +! cd = Max(0.5, Min(0.8, 0.5 + 0.3*(xdnmx(lhl) - xdn(mgs,lhl))/(xdnmx(lhl)-xdnmn(lhl)) ) ) + cd = Max(0.45, Min(0.6, 0.45 + 0.15*(800.0 - Max( 500., Min( 800.0, xdn(mgs,lhl) ) ) )/(800. - 500.) ) ) + ELSEIF ( icdxhl .eq. 6 ) THEN ! Milbrandt and Morrison (2013) + aax = axx(mgs,lhl) + bbx = bxx(mgs,lhl) + ENDIF + + ENDIF ! } + + IF ( alpha(mgs,il) .eq. 0. .and. infdo .lt. 2 .and. & + ( ( il==lh .and. icdx > 0 .and. icdx /= 6) .or. ( il==lhl .and. icdxhl > 0 .and. icdxhl /= 6 ) ) ) THEN ! { + vtxbar(mgs,il,2) = & + & Sqrt( (xdn(mgs,il)*xdia(mgs,il,1)*pi*gr) / & + & (3.0*cd*Max(0.05,rho0(mgs))) ) + + ELSE + IF ( il == lh .and. icdx /= 6 ) bbx = bx(il) + IF ( il == lhl .and. icdxhl /= 6 ) bbx = bx(il) + tmp = 1. + alpha(mgs,il) + bbx + i = Int(dgami*(tmp)) + del = tmp - dgam*i + x = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami + + tmp = 1. + alpha(mgs,il) + i = Int(dgami*(tmp)) + del = tmp - dgam*i + y = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami + + IF ( il .eq. lh .or. il .eq. lhl) THEN ! { + IF ( ( il==lh .and. icdx > 0 ) ) THEN + IF ( icdx /= 6 ) THEN + aax = Sqrt(4.0*xdn(mgs,il)*gr/(3.0*cd*rho00)) + vtxbar(mgs,il,2) = rhovt(mgs)*aax* xdia(mgs,il,1)**bx(il) * x/y + ELSE ! (icdx == 6 ) THEN + vtxbar(mgs,il,2) = rhovt(mgs)*aax* xdia(mgs,il,1)**bbx * x/y + ENDIF + + ELSEIF ( ( il==lhl .and. icdxhl > 0 ) ) THEN + IF ( icdxhl /= 6 ) THEN + aax = Sqrt(4.0*xdn(mgs,il)*gr/(3.0*cd*rho00)) + vtxbar(mgs,il,2) = rhovt(mgs)*aax* xdia(mgs,il,1)**bx(il) * x/y + ELSE ! ( icdxhl == 6 ) + vtxbar(mgs,il,2) = rhovt(mgs)*aax* xdia(mgs,il,1)**bbx * x/y + ENDIF + ELSE ! get here if il==lh and icdx < 0 -- or -- il==lhl and icdxhl < 0 + aax = ax(il) + vtxbar(mgs,il,2) = rhovt(mgs)*ax(il)*(xdia(mgs,il,1)**bx(il)*x)/y + ENDIF +! vtxbar(mgs,il,2) = & +! & rhovt(mgs)*(xdn(mgs,il)/400.)*(75.715*xdia(mgs,il,1)**0.6* & +! & x)/y +! vtxbar(mgs,il,2) = & +! & rhovt(mgs)*(xdn(mgs,il)/400.)*(ax(il)*xdia(mgs,il,1)**bx(il)* & +! & x)/y + IF ( infdo .ge. 2 ) THEN ! Z-weighted + + tmp = 7. + alpha(mgs,il) + bbx + i = Int(dgami*(tmp)) + del = tmp - dgam*i + x = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami + + tmp = 7. + alpha(mgs,il) + i = Int(dgami*(tmp)) + del = tmp - dgam*i + y = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami + + vtxbar(mgs,il,3) = rhovt(mgs)* & + & (aax*(xdia(mgs,il,1) )**bbx * & + & x)/y +! & Gamma(7.0 + alpha(mgs,il) + bbx)/Gamma(7. + alpha(mgs,il)) + IF ( .not. (vtxbar(mgs,il,1) > -1. .and. vtxbar(mgs,il,1) < 200. ) .or. & + .not. (vtxbar(mgs,il,3) > -1. .and. vtxbar(mgs,il,3) < 200. ) ) THEN + write(0,*) 'Setvtz: problem with vtxbar1/3: ',il,vtxbar(mgs,il,1),vtxbar(mgs,il,3),aax,bbx,x,y + write(0,*) 'q, number, diam1,3(mm) = ', qx(mgs,il),cx(mgs,il),1000.*xdia(mgs,il,1),1000.*xdia(mgs,il,3) + ! call commasmpi_abort() + ENDIF +! & (aax*(1.0/xdia(mgs,il,1) )**(- bx(il))* & +! & Gamma_sp(7.0 + alpha(mgs,il) + bx(il)))/Gamma_sp(7. + alpha(mgs,il)) + ENDIF + + if ( ndebug1 .gt. 0 ) write(0,*) 'SETVTZ: Set hail vt3' + + ELSE ! hail + vtxbar(mgs,il,2) = & + & rhovt(mgs)*(ax(il)*xdia(mgs,il,1)**bx(il)* & + & x)/y + + IF ( infdo .ge. 2 ) THEN ! Z-weighted + vtxbar(mgs,il,3) = rhovt(mgs)* & + & (aax*(1.0/xdia(mgs,il,1) )**(- bbx)* & + & Gamma_sp(7.0 + alpha(mgs,il) + bbx))/Gamma_sp(7. + alpha(mgs,il)) +! & (ax(il)*(1.0/xdia(mgs,il,1) )**(- bx(il))* & +! & Gamma_sp(7.0 + alpha(mgs,il) + bx(il)))/Gamma_sp(7. + alpha(mgs,il)) + ENDIF + + if ( ndebug1 .gt. 0 ) write(0,*) 'SETVTZ: Set hail vt4' + + ENDIF ! } +! & Gamma_sp(1.0 + dnu(il) + 0.6)/Gamma_sp(1. + dnu(il)) + ENDIF ! } + +! IF ( infdo .ge. 2 ) THEN ! Z-weighted +! vtxbar(mgs,il,3) = rhovt(mgs)* & +! & (ax(il)*(1.0/xdia(mgs,il,1) )**(- bx(il))* & +! & Gamma_sp(7.0 + alpha(mgs,il) + bx(il)))/Gamma_sp(7. + alpha(mgs,il)) +! ENDIF + +! IF ( lhl .gt. 1 .and. il .eq. lhl ) THEN +! write(0,*) 'setvt: ',qx(mgs,il),xdia(mgs,il,1),xdia(mgs,il,3),dnu(il),ax(il),bx(il) +! ENDIF + ELSEIF ( (il .eq. lh .and. hssflg == 0) .or. ( lhl .gt. 1 .and. il .eq. lhl .and. hlssflg == 0) ) THEN ! no size-sorting for graupel or hail + vtxbar(mgs,il,2) = vtxbar(mgs,il,1) + vtxbar(mgs,il,3) = vtxbar(mgs,il,1) + ELSE ! not lh or lhl + vtxbar(mgs,il,2) = & + & Sqrt( (xdn(mgs,il)*xdia(mgs,il,1)*pi*gr) / & + & (3.0*cdx(il)*Max(0.05,rho0(mgs))) ) + vtxbar(mgs,il,3) = vtxbar(mgs,il,1) + + if ( ndebug1 .gt. 0 ) write(0,*) 'SETVTZ: Set graupel vt5' + + + ENDIF + ELSE ! qx < qxmin + vtxbar(mgs,il,2) = 0.0 + + if ( ndebug1 .gt. 0 ) write(0,*) 'SETVTZ: Set graupel vt6' + + ENDIF + ENDDO ! mgs + + if ( ndebug1 .gt. 0 ) write(0,*) 'SETVTZ: Set graupel vt7' + + ENDIF + ENDDO ! il + + if ( ndebug1 .gt. 0 ) write(0,*) 'SETVTZ: Set graupel vt8' + + ENDIF ! lg .gt. 1 + +! ENDIF +! ENDDO + + if ( ndebug1 .gt. 0 ) write(0,*) 'SETVTZ: Set graupel vt9' + +! DO mgs = 1,ngscnt +! IF ( qx(mgs,lr) > qxmin(lr) ) THEN +! write(0,*) 'setvt2: mgs,lzr,infdo = ',mgs,lzr,infdo +! write(0,*) 'vt1,2,3 = ',vtxbar(mgs,lr,1),vtxbar(mgs,lr,2),vtxbar(mgs,lr,3) +! ENDIF +! ENDDO + + ENDIF ! infdo .ge. 1 + + IF ( lh > 0 .and. graupelfallfac /= 1.0 ) THEN + DO mgs = 1,ngscnt + vtxbar(mgs,lh,1) = graupelfallfac*vtxbar(mgs,lh,1) + vtxbar(mgs,lh,2) = graupelfallfac*vtxbar(mgs,lh,2) + vtxbar(mgs,lh,3) = graupelfallfac*vtxbar(mgs,lh,3) + axx(mgs,lh) = graupelfallfac*axx(mgs,lh) + ENDDO + ENDIF + + IF ( lhl > 0 .and. hailfallfac /= 1.0 ) THEN + DO mgs = 1,ngscnt + vtxbar(mgs,lhl,1) = hailfallfac*vtxbar(mgs,lhl,1) + vtxbar(mgs,lhl,2) = hailfallfac*vtxbar(mgs,lhl,2) + vtxbar(mgs,lhl,3) = hailfallfac*vtxbar(mgs,lhl,3) + axx(mgs,lhl) = hailfallfac*axx(mgs,lhl) + ENDDO + ENDIF + + if ( ndebug1 .gt. 0 ) write(0,*) 'SETVTZ: END OF ROUTINE' + +!############ SETVTZ ############################ + + RETURN + END SUBROUTINE setvtz +!-------------------------------------------------------------------------- + +! +! ############################################################################## + +! +! subroutine to calculate fall speeds of hydrometeors +! + +!>\ingroup mod_nsslmp +!! Column-wise front end to setvtz for sedimentation + subroutine ziegfall1d(nx,ny,nz,nor,norz,na,dtp,jgs,ixcol, & + & xvt, rhovtzx, & + & an,dn,ipconc0,t0,t7,cwmasn,cwmasx, & + & cwradn, & + & qxmin,xdnmx,xdnmn,cdx,cno,xdn0,xvmn,xvmx, & + & ngs,qx,qxw,cx,xv,vtxbar,xmas,xdn,xdia,vx,alpha,zx,igs,kgs, & + & rho0,temcg,temg,rhovt,cwnc,cinc,fadvisc,cwdia,cipmas,cnina,cimas, & + & cnostmp, & + & infdo,ildo,timesetvt) + +! 12.16.2005: .F version use in transitional SWM model +! +! 10.10.2003: Added cimn and cimx to setting for cci and cip. +! +! TO DO LIST: +! +! need to set up values for: +! : cipdia,cidia,cwdia,cwmas,vtwbar, +! : rho0,temcg,cip,cci +! +! and need to put fallspeed values in cwvt etc. +! + + implicit none + integer ng1 + parameter(ng1 = 1) + + integer, intent(in) :: ixcol ! which column to return + integer, intent(in) :: ildo + + integer nx,ny,nz,nor,norz,ngt,jgs,na + real an(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-nor+ng1:nz+nor,na) + real dn(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-nor+ng1:nz+nor) + real t0(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-nor+ng1:nz+nor) + real t7(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-nor+ng1:nz+nor) + real dtp,dtz1 + + real :: rhovtzx(nz,nx) + + integer ndebugzf + parameter (ndebugzf = 0) + + integer ix,jy,kz,i,j,k,il + integer infdo +! +! + real xvt(nz+1,nx,3,lc:lhab) ! 1=mass-weighted, 2=number-weighted + + real qxmin(lc:lhab) + real xdn0(lc:lhab) + real xvmn(lc:lhab), xvmx(lc:lhab) + double precision,optional :: timesetvt + + integer :: ngs + integer :: ngscnt,mgs,ipconc0 +! parameter ( ngs=200 ) + + real :: qx(ngs,lv:lhab) + real :: qxw(ngs,ls:lhab) + real :: cx(ngs,lc:lhab) + real :: xv(ngs,lc:lhab) + real :: vtxbar(ngs,lc:lhab,3) + real :: xmas(ngs,lc:lhab) + real :: xdn(ngs,lc:lhab) + real :: cdxgs(ngs,lc:lhab) + real :: xdia(ngs,lc:lhab,3) + real :: vx(ngs,li:lhab) + real :: alpha(ngs,lc:lhab) + real :: zx(ngs,lr:lhab) + + real xdnmx(lc:lhab), xdnmn(lc:lhab) + real :: axx(ngs,lh:lhab), bxx(ngs,lh:lhab) +! real axh(ngs),bxh(ngs),axhl(ngs),bxhl(ngs) + +! +! drag coefficients +! + real cdx(lc:lhab) +! +! Fixed intercept values for single moment scheme +! + real cno(lc:lhab) + + real cwccn0,cwmasn,cwmasx,cwradn +! real cwc0 + + integer nxmpb,nzmpb,nxz,numgs,inumgs + integer kstag + parameter (kstag=1) + + integer igs(ngs),kgs(ngs) + + real rho0(ngs),temcg(ngs) + + real temg(ngs) + + real rhovt(ngs) + + real cwnc(ngs),cinc(ngs) + real fadvisc(ngs),cwdia(ngs),cipmas(ngs) + +! real cimasn,cimasx, + real :: cnina(ngs),cimas(ngs) + + real :: cnostmp(ngs) + +! real pii +! +! +! general constants for microphysics +! + +! +! Miscellaneous +! + + logical flag + logical ldoliq + + + real chw, qr, z, rd, alp, z1, g1, vr, nrx, tmp + + real vtmax + real xvbarmax + + integer l1, l2 + + double precision :: dpt1, dpt2 + + +!----------------------------------------------------------------------------- +! MPI LOCAL VARIABLES + + integer :: ixb, jyb, kzb + integer :: ixe, jye, kze + + logical :: debug_mpi = .false. + + + if (ndebugzf .gt. 0 ) write(0,*) "ZIEGFALL: ENTERED SUBROUTINE" + +! ##################################################################### +! BEGIN EXECUTABLE +! ##################################################################### +! + +! constants +! + + ldoliq = .false. + IF ( ls .gt. 1 ) THEN + DO il = ls,lhab + ldoliq = ldoliq .or. ( lliq(il) .gt. 1 ) + ENDDO + ENDIF + +! poo = 1.0e+05 +! cp608 = 0.608 +! cp = 1004.0 +! cv = 717.0 +! dnz00 = 1.225 +! rho00 = 1.225 +! cs = 4.83607122 +! ds = 0.25 +! new values for cs and ds +! cs = 12.42 +! ds = 0.42 +! pi = 4.0*atan(1.0) +! pii = piinv ! 1./pi +! pid4 = pi/4.0 +! qccrit = 2.0e-03 +! qscrit = 6.0e-04 +! cwc0 = pii + +! +! +! general constants for microphysics +! + +! +! ci constants in mks units +! +! cimasn = 6.88e-13 +! cimasx = 1.0e-8 +! +! Set terminal velocities... +! also set drag coefficients +! + jy = jgs + nxmpb = ixcol + nzmpb = 1 + nxz = 1*nz +! ngs = nz + numgs = 1 + + IF ( ildo == 0 ) THEN + l1 = lc + l2 = lhab + ELSE + l1 = ildo + l2 = ildo + ENDIF + + + do inumgs = 1,numgs + ngscnt = 0 + + + do kz = nzmpb,nz + do ix = ixcol,ixcol + flag = .false. + + + DO il = l1,l2 + flag = flag .or. ( an(ix,jy,kz,il) .gt. qxmin(il) ) + ENDDO + + if ( flag ) then +! load temp quantities + + ngscnt = ngscnt + 1 + igs(ngscnt) = ix + kgs(ngscnt) = kz + if ( ngscnt .eq. ngs ) goto 1100 + end if + end do !!ix + nxmpb = 1 + end do !! kz + +! if ( jy .eq. (ny-jstag) ) iend = 1 + + 1100 continue + + if ( ngscnt .eq. 0 ) go to 9998 +! +! set temporaries for microphysics variables +! + + +! +! Reconstruct various quantities +! + do mgs = 1,ngscnt + + rho0(mgs) = dn(igs(mgs),jy,kgs(mgs)) + rhovt(mgs) = rhovtzx(kgs(mgs),ixcol) ! Sqrt(rho00/rho0(mgs)) + temg(mgs) = t0(igs(mgs),jy,kgs(mgs)) + temcg(mgs) = temg(mgs) - tfr + + +! + end do +! +! only need fadvisc for + IF ( lc .gt. 1 .and. (ildo == 0 .or. ildo == lc ) ) then + do mgs = 1,ngscnt + fadvisc(mgs) = advisc0*(416.16/(temg(mgs)+120.0))* & + & (temg(mgs)/296.0)**(1.5) + end do + ENDIF + + IF ( ipconc .eq. 0 ) THEN + do mgs = 1,ngscnt + cnina(mgs) = t7(igs(mgs),jgs,kgs(mgs)) + end do + ENDIF + + + IF ( ildo > 0 ) THEN + vtxbar(:,ildo,:) = 0.0 + ELSE + vtxbar(:,:,:) = 0.0 + ENDIF + +! do mgs = 1,ngscnt +! qx(mgs,lv) = max(an(igs(mgs),jy,kgs(mgs),lv), 0.0) +! ENDDO + DO il = l1,l2 + do mgs = 1,ngscnt + qx(mgs,il) = max(an(igs(mgs),jy,kgs(mgs),il), 0.0) + ENDDO + end do + + cnostmp(:) = cno(ls) + IF ( ipconc < 1 .and. lwsm6 .and. (ildo == 0 .or. ildo == ls )) THEN + DO mgs = 1,ngscnt + tmp = Min( 0.0, temcg(mgs) ) + cnostmp(mgs) = Min( 2.e8, 2.e6*exp(0.12*tmp) ) + ENDDO + ENDIF + + +! +! set concentrations +! + cx(:,:) = 0.0 + + if ( ipconc .ge. 1 .and. li .gt. 1 .and. (ildo == 0 .or. ildo == li ) ) then + do mgs = 1,ngscnt + cx(mgs,li) = Max(an(igs(mgs),jy,kgs(mgs),lni), 0.0) + end do + end if + if ( ipconc .ge. 2 .and. lc .gt. 1 .and. (ildo == 0 .or. ildo == lc ) ) then + do mgs = 1,ngscnt + cx(mgs,lc) = Max(an(igs(mgs),jy,kgs(mgs),lnc), 0.0) +! cx(mgs,lc) = Min( ccwmx, cx(mgs,lc) ) + end do + end if + if ( ipconc .ge. 3 .and. lr .gt. 1 .and. (ildo == 0 .or. ildo == lr ) ) then + do mgs = 1,ngscnt + cx(mgs,lr) = Max(an(igs(mgs),jy,kgs(mgs),lnr), 0.0) +! IF ( qx(mgs,lr) .le. qxmin(lr) ) THEN +! ELSE +! cx(mgs,lr) = Max( 0.0, cx(mgs,lr) ) +! ENDIF + end do + end if + if ( ipconc .ge. 4 .and. ls .gt. 1 .and. (ildo == 0 .or. ildo == ls ) ) then + do mgs = 1,ngscnt + cx(mgs,ls) = Max(an(igs(mgs),jy,kgs(mgs),lns), 0.0) +! IF ( qx(mgs,ls) .le. qxmin(ls) ) THEN +! ELSE +! cx(mgs,ls) = Max( 0.0, cx(mgs,ls) ) +! ENDIF + end do + end if + + if ( ipconc .ge. 5 .and. lh .gt. 1 .and. (ildo == 0 .or. ildo == lh ) ) then + do mgs = 1,ngscnt + + cx(mgs,lh) = Max(an(igs(mgs),jy,kgs(mgs),lnh), 0.0) +! IF ( qx(mgs,lh) .le. qxmin(lh) ) THEN +! ELSE +! cx(mgs,lh) = Max( 0.0, cx(mgs,lh) ) +! ENDIF + + end do + ENDIF + + if ( ipconc .ge. 5 .and. lhl .gt. 1 .and. (ildo == 0 .or. ildo == lhl ) ) then + do mgs = 1,ngscnt + + cx(mgs,lhl) = Max(an(igs(mgs),jy,kgs(mgs),lnhl), 0.0) +! IF ( qx(mgs,lhl) .le. qxmin(lhl) ) THEN +! cx(mgs,lhl) = 0.0 +! ELSEIF ( cx(mgs,lhl) .eq. 0.0 .and. qx(mgs,lhl) .lt. 3.0*qxmin(lhl) ) THEN +! qx(mgs,lhl) = 0.0 +! ELSE +! cx(mgs,lhl) = Max( 0.0, cx(mgs,lhl) ) +! ENDIF + + end do + end if + + do mgs = 1,ngscnt + xdn(mgs,lc) = xdn0(lc) + xdn(mgs,lr) = xdn0(lr) +! IF ( ls .gt. 1 .and. lvs .eq. 0 ) xdn(mgs,ls) = xdn0(ls) +! IF ( lh .gt. 1 .and. lvh .eq. 0 ) xdn(mgs,lh) = xdn0(lh) + IF ( li .gt. 1 ) xdn(mgs,li) = xdn0(li) + IF ( ls .gt. 1 ) xdn(mgs,ls) = xdn0(ls) + IF ( lh .gt. 1 ) xdn(mgs,lh) = xdn0(lh) + IF ( lhl .gt. 1 ) xdn(mgs,lhl) = xdn0(lhl) + end do + +! +! Set mean particle volume +! + IF ( ldovol .and. (ildo == 0 .or. ildo >= li ) ) THEN + + vx(:,:) = 0.0 + + DO il = l1,l2 + + IF ( lvol(il) .ge. 1 ) THEN + + DO mgs = 1,ngscnt + vx(mgs,il) = Max(an(igs(mgs),jy,kgs(mgs),lvol(il)), 0.0) + IF ( vx(mgs,il) .gt. rho0(mgs)*qxmin(il)*1.e-3 .and. qx(mgs,il) .gt. qxmin(il) ) THEN + xdn(mgs,il) = Min( xdnmx(il), Max( xdnmn(il), rho0(mgs)*qx(mgs,il)/vx(mgs,il) ) ) + ENDIF + ENDDO + + ENDIF + + ENDDO + + ENDIF + + DO il = lg,lhab + DO mgs = 1,ngscnt + alpha(mgs,il) = dnu(il) + ENDDO + ENDDO + + IF ( imurain == 1 ) THEN + alpha(:,lr) = alphar + ELSEIF ( imurain == 3 ) THEN + alpha(:,lr) = xnu(lr) + ENDIF + + + + + + + +! +! Set density +! + if (ndebugzf .gt. 0 ) write(0,*) 'ZIEGFALL: call setvtz' +! + + call setvtz(ngscnt,qx,qxmin,qxw,cx,rho0,rhovt,xdia,cno,cnostmp, & + & xmas,vtxbar,xdn,xvmn,xvmx,xv,cdx,cdxgs, & + & ipconc,ndebugzf,ngs,nz,kgs,fadvisc, & + & cwmasn,cwmasx,cwradn,cnina,cimn,cimx, & + & itype1,itype2,temcg,infdo,alpha,ildo,axx,bxx) +! & itype1,itype2,temcg,infdo,alpha,ildo,axh,bxh,axhl,bxhl) + + + +! +! put fall speeds into the x-z arrays +! + DO il = l1,l2 + do mgs = 1,ngscnt + + vtmax = 150.0 + + + IF ( vtxbar(mgs,il,2) .gt. vtxbar(mgs,il,1) .or. & + & ( vtxbar(mgs,il,1) .gt. vtxbar(mgs,il,3) .and. vtxbar(mgs,il,3) > 0.0) ) THEN + + + + vtxbar(mgs,il,1) = Max( vtxbar(mgs,il,1), vtxbar(mgs,il,2) ) + vtxbar(mgs,il,3) = Max( vtxbar(mgs,il,3), vtxbar(mgs,il,1) ) + + ENDIF + + + IF ( vtxbar(mgs,il,1) .gt. vtmax .or. vtxbar(mgs,il,2) .gt. vtmax .or. & + & vtxbar(mgs,il,3) .gt. vtmax ) THEN + + vtxbar(mgs,il,1) = Min(vtmax,vtxbar(mgs,il,1) ) + vtxbar(mgs,il,2) = Min(vtmax,vtxbar(mgs,il,2) ) + vtxbar(mgs,il,3) = Min(vtmax,vtxbar(mgs,il,3) ) + +! call commasmpi_abort() + ENDIF + + + xvt(kgs(mgs),igs(mgs),1,il) = vtxbar(mgs,il,1) + xvt(kgs(mgs),igs(mgs),2,il) = vtxbar(mgs,il,2) + IF ( infdo .ge. 2 ) THEN + xvt(kgs(mgs),igs(mgs),3,il) = vtxbar(mgs,il,3) + ELSE + xvt(kgs(mgs),igs(mgs),3,il) = 0.0 + ENDIF + +! xvt(kgs(mgs),igs(mgs),2,il) = xvt(kgs(mgs),igs(mgs),1,il) + + enddo + ENDDO + + + if (ndebugzf .gt. 0 ) write(0,*) 'ZIEGFALL: COPIED FALL SPEEDS' + + + + 9998 continue + + if (ndebugzf .gt. 0 ) write(0,*) 'ZIEGFALL: DONE WITH LOOP' + + if ( kz .gt. nz-1 ) then + go to 1200 + else + nzmpb = kz + end if + + if (ndebugzf .gt. 0 ) write(0,*) 'ZIEGFALL: SET NZMPB' + + end do !! inumgs + + if (ndebugzf .gt. 0 ) write(0,*) 'ZIEGFALL: SET NXMPB' + + 1200 continue + + +! ENDDO ! ix +! ENDDO ! kz + + + if (ndebugzf .gt. 0 ) write(0,*) "ZIEGFALL: EXITING SUBROUTINE" + + + RETURN + END subroutine ziegfall1d + +! ##################################################################### +! ##################################################################### + + +! ##################################################################### +! ##################################################################### + +! ############################################################################## +!>\ingroup mod_nsslmp +!! Radar reflectivity calculation. Assumes ideal Rayleigh scattering. + subroutine radardd02(nx,ny,nz,nor,na,an,temk, & + & dbz,db,nzdbz,cnoh0t,hwdn1t,ipconc,ke_diag, iunit) +! +! 11.13.2005: Changed values of indices for reordering of lip +! +! 07.13.2005: Fixed an error where cnoh was being used for graupel and frozen drops +! +! 01.24.2005: add ice crystal reflectivity using parameterization of +! Heymsfield (JAS, 1977). Could also try Ferrier for this, too. +! +! 09.28.2002 Test alterations for dry ice following Ferrier (1994) +! for equivalent melted diameter reflectivity. +! Converted to Fortran by ERM. +! +!Date: Tue, 21 Nov 2000 10:13:36 -0600 (CST) +!From: Matthew Gilmore +! +!PRO RF_SPEC ; Computes Radar Reflectivity +!COMMON MAINB, data, x1d, y1d, z1d, iconst, rconst, labels, nx, ny, nz, dshft +! +!;MODIFICATION HISTORY +!; 5/99 -Svelta Veleva introduces variable dielf (const_ki_x) as a (weak) +!; function of density. This leads to slight modification of dielf such +!; that the snow reflectivity is slightly increased - not a big effect. +!; This is believed to be more accurate than assuming the dielectric +!; constant for snow is the same as for hail in previous versions. +! +!;On 6/13/99 I added the VIL computation (k=0 in vil array) +!;On 6/15/99 I removed the number concentration dependencies as a function +!; of temperature (only use for ferrier!) +!;On 6/15/99 I added the Composite reflectivity (k=1 in VIL array) +!;On 6/15/99 I added the Severe Hail Index computation (k=2 in vil array) +!; +!; 6/99 - Veleva and Seo argue that since graupel is more similar to +!; snow (in number conc and size density) than it is to hail, we +!; should not weight wetted graupel with the .95 exponent correction +!; factor as in the case of hail. An if-statement checks the size +!; density for wet hail/graupel and treats them appropriately. +!; +!; 6/22/99 - Added function to compute height of max rf and 40 dbz echo top +!; Also added vilqr which is the model vertical integrated liquid only +!; using qr. Will need to check...does not seem consistent with vilZ +!; + + + implicit none + + character(LEN=15), parameter :: microp = 'ZVD' + integer nx,ny,nz,nor,na,ngt + integer nzdbz ! how many levels actually to process + + integer ng1,n10 + integer iunit + integer, parameter :: printyn = 0 + + parameter( ng1 = 1 ) + + real cnoh0t,hwdn1t + integer ke_diag + integer ipconc + real vr + + + integer imapz,mzdist + + integer vzflag + integer, parameter :: norz = 3 + real an(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-nor+ng1:nz+nor,na) + real db(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-nor+ng1:nz+nor) ! air density +! real gt(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-nor+ng1:nz+nor,ngt) + real temk(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-nor+ng1:nz+nor) ! air temperature (kelvin) + real dbz(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-nor+ng1:nz+nor) ! reflectivity + real gz(-nor+1:nz+nor) ! ,z1d(-nor+1:nz+nor,4) + +! real g,rgas,eta,inveta + real cr1, cr2 , hwdnsq,swdnsq + real rwdnsq, dhmin, qrmin, qsmin, qhmin, qhlmin, tfr, tfrh, zrc + real reflectmin, kw_sq + real const_ki_sn, const_ki_h, ki_sq_sn + real ki_sq_h, dielf_sn, dielf_h + real pi + logical ltest + +! Other data arrays + real gtmp (nx,nz) + real dtmp (nx,nz) + real tmp + + real*8 dtmps, dtmpr, dtmph, dtmphl, g1, zx, ze, x + + integer i,j,k,ix,jy,kz,ihcnt + + real*8 xcnoh, xcnos, dadh, dads, zhdryc, zsdryc, zhwetc,zswetc + real*8 dadr + real dbzmax,dbzmin + parameter ( dbzmin = 0 ) + + real cnow,cnoi,cnoip,cnoir,cnor,cnos + real cnogl,cnogm,cnogh,cnof,cnoh,cnohl + + real swdn, rwdn ,hwdn,gldn,gmdn,ghdn,fwdn,hldn + real swdn0 + + real rwdnmx,cwdnmx,cidnmx,xidnmx,swdnmx,gldnmx,gmdnmx + real ghdnmx,fwdnmx,hwdnmx,hldnmx + real rwdnmn,cwdnmn,cidnmn,xidnmn,swdnmn,gldnmn,gmdnmn + real ghdnmn,fwdnmn,hwdnmn,hldnmn + + real gldnsq,gmdnsq,ghdnsq,fwdnsq,hldnsq + + real dadgl,dadgm,dadgh,dadhl,dadf + real zgldryc,zglwetc,zgmdryc, zgmwetc,zghdryc,zghwetc + real zhldryc,zhlwetc,zfdryc,zfwetc + + real dielf_gl,dielf_gm,dielf_gh,dielf_hl,dielf_fw + + integer imx,jmx,kmx + + real swdia,gldia,gmdia,ghdia,fwdia,hwdia,hldia + + real csw,cgl,cgm,cgh,cfw,chw,chl + real xvs,xvgl,xvgm,xvgh,xvf,xvh,xvhl + + real cwc0 + integer izieg + integer ice10 + real rhos + parameter ( rhos = 0.1 ) + + real qxw,qxw1 ! temp value for liquid water on ice mixing ratio + real :: dnsnow + real qh + + real, parameter :: cwmasn = 5.23e-13 ! minimum mass, defined by radius of 5.0e-6 + real, parameter :: cwmasx = 5.25e-10 ! maximum mass, defined by radius of 50.0e-6 + real, parameter :: cwradn = 5.0e-6 ! minimum radius + + real cwnccn(nz) + + real :: vzsnow, vzrain, vzgraupel, vzhail + real :: ksq + real :: dtp + + +! ######################################################################### + + vzflag = 0 + + izieg = 0 + ice10 = 0 +! g=9.806 ! g: gravity constant +! rgas=287.04 ! rgas: gas constant for dry air +! rcp=rgas/cp ! rcp: gamma constant +! eta=0.622 +! inveta = 1./eta +! rcpinv = 1./rcp +! cpr=cp/rgas +! cvr=cv/rgas + pi = 4.0*ATan(1.) + cwc0 = piinv ! 1./pi ! 6.0/pi + + cnoh = cnoh0t + hwdn = hwdn1t + + rwdn = 1000.0 + swdn = 100.0 + + qrmin = 1.0e-05 + qsmin = 1.0e-06 + qhmin = 1.0e-05 + +! +! default slope intercepts +! + cnow = 1.0e+08 + cnoi = 1.0e+08 + cnoip = 1.0e+08 + cnoir = 1.0e+08 + cnor = 8.0e+06 + cnos = 8.0e+06 + cnogl = 4.0e+05 + cnogm = 4.0e+05 + cnogh = 4.0e+05 + cnof = 4.0e+05 + cnohl = 1.0e+03 + + + imx = 1 + jmx = 1 + kmx = 1 + i = 1 + + + IF ( microp(1:4) .eq. 'ZIEG' ) THEN ! na .ge. 14 .and. ipconc .ge. 3 ) THEN + +! write(0,*) 'Set reflectivity for ZIEG' + izieg = 1 + + hwdn = hwdn1t ! 500. + + + cnor = cno(lr) + cnos = cno(ls) + cnoh = cno(lh) + qrmin = qxmin(lr) + qsmin = qxmin(ls) + qhmin = qxmin(lh) + IF ( lhl .gt. 1 ) THEN + cnohl = cno(lhl) + qhlmin = qxmin(lhl) + ENDIF + + ELSEIF ( microp(1:3) .eq. 'ZVD' ) THEN ! na .ge. 14 .and. ipconc .ge. 3 ) THEN + + izieg = 1 + + swdn0 = swdn + + cnor = cno(lr) + cnos = cno(ls) + cnoh = cno(lh) + + qrmin = qxmin(lr) + qsmin = qxmin(ls) + qhmin = qxmin(lh) + IF ( lhl .gt. 1 ) THEN + cnohl = cno(lhl) + qhlmin = qxmin(lhl) + ENDIF +! write(*,*) 'radardbz: ',db(1,1,1),temk(1,1,1),an(1,1,1,lr),an(1,1,1,ls),an(1,1,1,lh) + + + ENDIF + + +! cdx(lr) = 0.60 +! +! IF ( lh > 1 ) THEN +! cdx(lh) = 0.8 ! 1.0 ! 0.45 +! cdx(ls) = 2.00 +! ENDIF +! +! IF ( lhl .gt. 1 ) cdx(lhl) = 0.45 +! +! xvmn(lc) = xvcmn +! xvmn(lr) = xvrmn +! +! xvmx(lc) = xvcmx +! xvmx(lr) = xvrmx +! +! IF ( lh > 1 ) THEN +! xvmn(ls) = xvsmn +! xvmn(lh) = xvhmn +! xvmx(ls) = xvsmx +! xvmx(lh) = xvhmx +! ENDIF +! +! IF ( lhl .gt. 1 ) THEN +! xvmn(lhl) = xvhlmn +! xvmx(lhl) = xvhlmx +! ENDIF +! +! xdnmx(lr) = 1000.0 +! xdnmx(lc) = 1000.0 +! IF ( lh > 1 ) THEN +! xdnmx(li) = 917.0 +! xdnmx(ls) = 300.0 +! xdnmx(lh) = 900.0 +! ENDIF +! IF ( lhl .gt. 1 ) xdnmx(lhl) = 900.0 +!! +! xdnmn(:) = 900.0 +! +! xdnmn(lr) = 1000.0 +! xdnmn(lc) = 1000.0 +! IF ( lh > 1 ) THEN +! xdnmn(li) = 100.0 +! xdnmn(ls) = 100.0 +! xdnmn(lh) = hdnmn +! ENDIF +! IF ( lhl .gt. 1 ) xdnmn(lhl) = 500.0 +! +! xdn0(:) = 900.0 +! +! xdn0(lc) = 1000.0 +! xdn0(lr) = 1000.0 +! IF ( lh > 1 ) THEN +! xdn0(li) = 900.0 +! xdn0(ls) = 100.0 ! 100.0 +! xdn0(lh) = hwdn1t ! (0.5)*(xdnmn(lh)+xdnmx(lh)) +! ENDIF +! IF ( lhl .gt. 1 ) xdn0(lhl) = 800.0 + +! +! slope intercepts +! +! cnow = 1.0e+08 +! cnoi = 1.0e+08 +! cnoip = 1.0e+08 +! cnoir = 1.0e+08 +! cnor = 8.0e+06 +! cnos = 8.0e+06 +! cnogl = 4.0e+05 +! cnogm = 4.0e+05 +! cnogh = 4.0e+05 +! cnof = 4.0e+05 +!c cnoh = 4.0e+04 +! cnohl = 1.0e+03 +! +! +! density maximums and minimums +! + rwdnmx = 1000.0 + cwdnmx = 1000.0 + cidnmx = 917.0 + xidnmx = 917.0 + swdnmx = 200.0 + gldnmx = 400.0 + gmdnmx = 600.0 + ghdnmx = 800.0 + fwdnmx = 900.0 + hwdnmx = 900.0 + hldnmx = 900.0 +! + rwdnmn = 1000.0 + cwdnmn = 1000.0 + xidnmn = 001.0 + cidnmn = 001.0 + swdnmn = 001.0 + gldnmn = 200.0 + gmdnmn = 400.0 + ghdnmn = 600.0 + fwdnmn = 700.0 + hwdnmn = 700.0 + hldnmn = 900.0 + + + gldn = (0.5)*(gldnmn+gldnmx) ! 300. + gmdn = (0.5)*(gmdnmn+gmdnmx) ! 500. + ghdn = (0.5)*(ghdnmn+ghdnmx) ! 700. + fwdn = (0.5)*(fwdnmn+fwdnmx) ! 800. + hldn = (0.5)*(hldnmn+hldnmx) ! 900. + + + cr1 = 7.2e+20 + cr2 = 7.295e+19 + hwdnsq = hwdn**2 + swdnsq = swdn**2 + rwdnsq = rwdn**2 + + gldnsq = gldn**2 + gmdnsq = gmdn**2 + ghdnsq = ghdn**2 + fwdnsq = fwdn**2 + hldnsq = hldn**2 + + dhmin = 0.005 + tfr = 273.16 + tfrh = tfr - 8.0 + zrc = cr1*cnor + reflectmin = 0.0 + kw_sq = 0.93 + dbzmax = dbzmin + + ihcnt=0 + + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! Dielectric Factor - Formulas implemented by Svetla Veleva +! following Battan, "Radar Meteorology" - p. 40 +! The result of these calculations is that the dielf numerator (ki_sq) without +! the density ratio is .2116 for hail if using 917 density and .25 for +! snow if using 220 density. +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + const_ki_sn = 0.5 - (0.5-0.46)/(917.-220.)*(swdn-220.) + const_ki_h = 0.5 - (0.5-0.46)/(917.-220.)*(hwdn-220.) + ki_sq_sn = (swdnsq/rwdnsq) * const_ki_sn**2 + ki_sq_h = (hwdnsq/rwdnsq) * const_ki_h**2 + dielf_sn = ki_sq_sn / kw_sq + dielf_h = ki_sq_h / kw_sq + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! Use the next line if you want to hardwire dielf for dry hail for both dry +! snow and dry hail. +! This would be equivalent to what Straka had originally. (i.e, .21/.93) +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + dielf_sn = (swdnsq/rwdnsq)*.21/ kw_sq + dielf_h = (hwdnsq/rwdnsq)*.21/ kw_sq + + dielf_gl = (gldnsq/rwdnsq)*.21/ kw_sq + dielf_gm = (gmdnsq/rwdnsq)*.21/ kw_sq + dielf_gh = (ghdnsq/rwdnsq)*.21/ kw_sq + dielf_hl = (hldnsq/rwdnsq)*.21/ kw_sq + dielf_fw = (fwdnsq/rwdnsq)*.21/ kw_sq + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! Notes on dielectric factors - from Eun-Kyoung Seo +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! constants for both snow and hail would be (x=s,h)..... +! xwdnsq/rwdnsq *0.21/kw_sq ! Straka/Smith - the original +! xwdnsq/rwdnsq *0.224 ! Ferrier - for particle sizes in equiv. drop diam +! xwdnsq/rwdnsq *0.176/kw_sq ! =0.189 in Smith - for particle sizes in equiv +! ice spheres +! xwdnsq/rwdnsq *0.208/kw_sq ! Smith 1984 - for particle sizes in equiv melted drop diameter +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + +! VIL algorithm constants +! Ztop = 10.**(56./10) !56 dbz is the max rf used by WATADS in cell vil + + +! Hail detection algorithm constants +! ZL = 40. +! ZU = 50. +! Ho = 3400. !WATADS Defaults +! Hm20 = 6200. !WATADS Defaults + +! DO kz = 1,Min(nzdbz,nz-1) + + DO jy=1,1 + + DO kz = 1,ke_diag ! nz + + DO ix=1,nx + dbz(ix,jy,kz) = 0.0 + + vzsnow = 0.0 + vzrain = 0.0 + vzgraupel = 0.0 + vzhail = 0.0 + + dtmph = 0.0 + dtmps = 0.0 + dtmphl = 0.0 + dtmpr = 0.0 + dadr = (db(ix,jy,kz)/(pi*rwdn*cnor))**(0.25) +!----------------------------------------------------------------------- +! Compute Rain Radar Reflectivity +!----------------------------------------------------------------------- + + dtmp(ix,kz) = 0.0 + gtmp(ix,kz) = 0.0 + IF ( an(ix,jy,kz,lr) .ge. qrmin ) THEN + IF ( ipconc .le. 2 ) THEN + gtmp(ix,kz) = dadr*an(ix,jy,kz,lr)**(0.25) + dtmp(ix,kz) = zrc*gtmp(ix,kz)**7 + ELSEIF ( an(ix,jy,kz,lnr) .gt. 1.e-3 ) THEN + IF ( imurain == 3 ) THEN + vr = db(ix,jy,kz)*an(ix,jy,kz,lr)/(1000.*an(ix,jy,kz,lnr)) + dtmp(ix,kz) = 3.6e18*(rnu+2.)*an(ix,jy,kz,lnr)*vr**2/(rnu+1.) + ELSE ! imurain == 1 + g1 = (6.0 + alphar)*(5.0 + alphar)*(4.0 + alphar)/((3.0 + alphar)*(2.0 + alphar)*(1.0 + alphar)) + zx = g1*(db(ix,jy,kz)*an(ix,jy,kz,lr))**2/an(ix,jy,kz,lnr) + ze =1.e18*zx*(6./(pi*1000.))**2 ! note: using 1000. here for water density + dtmp(ix,kz) = ze + ENDIF + ENDIF + dtmpr = dtmp(ix,kz) + ENDIF + +!----------------------------------------------------------------------- +! Compute snow and graupel reflectivity +! +! Lou modified to look at parcel temperature rather than base state +!----------------------------------------------------------------------- + + IF( lhab .gt. lr ) THEN + +! qs2d = reform(data[*,*,k,10],[nx*ny]) +! qh2d = reform(data[*,*,k,11],[nx*ny]) + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! Only use the following lines if running Straka GEMS microphysics +! (Sam 1-d version modified by L Wicker does not use this) +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! ;xcnoh = cnoh*exp(-0.025*(temp-tfr)) +! ;xcnos = cnos*exp(-0.038*(temp-tfr)) +! ;good = where(temp GT tfr, n_elements) +! ;IF n_elements NE 0 THEN xcnoh(good) = cnoh*exp(-0.075*(temp(good)-tfr)) +! ;IF n_elements NE 0 THEN xcnos(good) = cnos*exp(-0.088*(temp(good)-tfr)) + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! Only use the following lines if running Ferrier micro with No=No(T) +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! ; NOSE = -.15 +! ; NOGE = .0 +! ; xcnoh = cnoh*(1.>exp(NOGE*(temp-tfr)) ) +! ; xcnos = cnos*(1.>exp(NOSE*(temp-tfr)) ) + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! Use the following lines if Nos and Noh are constant +! (As in Svetla version of Ferrier, GCE Tao, and SAM 1-d) +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + xcnoh = cnoh + xcnos = cnos + +! +! Temporary fix for predicted number concentration -- need a +! more appropriate reflectivity equation! +! +! IF ( an(ix,jy,kz,lns) .lt. 0.1 ) THEN +! swdia = (xvrmn*cwc0)**(1./3.) +! xcnos = an(ix,jy,kz,ls)*db(ix,jy,kz)/(xvrmn*swdn*swdia) +! ELSE +! ! changed back to diameter of mean volume!!! +! swdia = +! > (an(ix,jy,kz,ls)*db(ix,jy,kz) +! > /(pi*swdn*an(ix,jy,kz,lns)))**(1./3.) +! +! xcnos = an(ix,jy,kz,lns)/swdia +! ENDIF + + IF ( ls .gt. 1 ) THEN ! { + + IF ( lvs .gt. 1 ) THEN + IF ( an(ix,jy,kz,lvs) .gt. 0.0 ) THEN + swdn = db(ix,jy,kz)*an(ix,jy,kz,ls)/an(ix,jy,kz,lvs) + swdn = Min( 300., Max( 100., swdn ) ) + ELSE + swdn = swdn0 + ENDIF + + ENDIF + + IF ( ipconc .ge. 5 ) THEN ! { + + xvs = db(ix,jy,kz)*an(ix,jy,kz,ls)/ & + & (swdn*Max(1.0e-3,an(ix,jy,kz,lns))) + IF ( xvs .lt. xvsmn .or. xvs .gt. xvsmx ) THEN + xvs = Min( xvsmx, Max( xvsmn,xvs ) ) + csw = db(ix,jy,kz)*an(ix,jy,kz,ls)/(xvs*swdn) + ENDIF + + swdia = (xvs*cwc0)**(1./3.) + xcnos = an(ix,jy,kz,ls)*db(ix,jy,kz)/(xvs*swdn*swdia) + + ENDIF ! } + ENDIF ! } + +! IF ( an(ix,jy,kz,lnh) .lt. 0.1 ) THEN +! hwdia = (xvrmn*cwc0)**(1./3.) +! xcnoh = an(ix,jy,kz,lh)*db(ix,jy,kz)/(xvrmn*hwdn*hwdia) +! ELSE +! ! changed back to diameter of mean volume!!! +! hwdia = +! > (an(ix,jy,kz,lh)*db(ix,jy,kz) +! > /(pi*hwdn*an(ix,jy,kz,lnh)))**(1./3.) +! +! xcnoh = an(ix,jy,kz,lnh)/hwdia +! ENDIF + + IF ( lh .gt. 1 ) THEN ! { + + IF ( lvh .gt. 1 ) THEN + IF ( an(ix,jy,kz,lvh) .gt. 0.0 ) THEN + hwdn = db(ix,jy,kz)*an(ix,jy,kz,lh)/an(ix,jy,kz,lvh) + hwdn = Min( 900., Max( hdnmn, hwdn ) ) + ELSE + hwdn = 500. ! hwdn1t + ENDIF + ELSE + hwdn = hwdn1t + ENDIF + + IF ( ipconc .ge. 5 ) THEN ! { + + xvh = db(ix,jy,kz)*an(ix,jy,kz,lh)/ & + & (hwdn*Max(1.0e-3,an(ix,jy,kz,lnh))) + IF ( xvh .lt. xvhmn .or. xvh .gt. xvhmx ) THEN + xvh = Min( xvhmx, Max( xvhmn,xvh ) ) + chw = db(ix,jy,kz)*an(ix,jy,kz,lh)/(xvh*hwdn) + ENDIF + + hwdia = (xvh*cwc0)**(1./3.) + xcnoh = an(ix,jy,kz,lh)*db(ix,jy,kz)/(xvh*hwdn*hwdia) + + ENDIF ! } ipconc .ge. 5 + + ENDIF ! } + + dadh = 0.0 + dadhl = 0.0 + dads = 0.0 + IF ( xcnoh .gt. 0.0 ) THEN + dadh = ( db(ix,jy,kz) /(pi*hwdn*xcnoh) )**(.25) + zhdryc = 0.224*cr2*(db(ix,jy,kz)/rwdn)**2/xcnoh ! dielf_h*cr1*xcnoh ! SV - equiv formula as before but + ! ratio of densities included in + ! dielf_h rather than here following + ! Battan. + ELSE + dadh = 0.0 + zhdryc = 0.0 + ENDIF + + IF ( xcnos .gt. 0.0 ) THEN + dads = ( db(ix,jy,kz) /(pi*swdn*xcnos) )**(.25) + zsdryc = 0.224*cr2*(db(ix,jy,kz)/rwdn)**2/xcnos ! dielf_sn*cr1*xcnos ! SV - similar change as above + ELSE + dads = 0.0 + zsdryc = 0.0 + ENDIF + zhwetc = zhdryc ! cr1*xcnoh !Hail/graupel version with .95 power bug removed + zswetc = zsdryc ! cr1*xcnos +! +! snow contribution +! + IF ( ls .gt. 1 ) THEN + + gtmp(ix,kz) = 0.0 + qxw = 0.0 + qxw1 = 0.0 + dtmps = 0.0 + IF ( an(ix,jy,kz,ls) .ge. qsmin ) THEN !{ + IF ( ipconc .ge. 4 ) THEN ! (Ferrier 94) !{ + + if (lsw .gt. 1) THEN + qxw = an(ix,jy,kz,lsw) + qxw1 = 0.0 + ELSEIF ( ( iusewetsnow == 1 .or. iusewetsnow == 3) .and. temk(ix,jy,kz) .gt. tfr+1. & + & .and. an(ix,jy,kz,ls) > an(ix,jy,kz,lr) .and. an(ix,jy,kz,lr) > qsmin) THEN + qxw = Min(0.5*an(ix,jy,kz,ls), an(ix,jy,kz,lr)) + qxw1 = qxw + ENDIF + + vr = xvs ! db(ix,jy,kz)*an(ix,jy,kz,lr)/(1000.*an(ix,jy,kz,lnr)) +! gtmp(ix,kz) = 3.6e18*(0.243*rhos**2/0.93)*(snu+2.)*an(ix,jy,kz,lns)*vr**2/(snu+1.) + + ksq = 0.189 ! Smith (1984, JAMC) for equiv. ice sphere + IF ( an(ix,jy,kz,lns) .gt. 1.e-7 ) THEN + ! IF ( .true. ) THEN + IF ( qxw > qsmin .or. iusewetsnow >= 2 ) THEN ! old version +! gtmp(ix,kz) = 3.6e18*(snu+2.)*( 0.224*an(ix,jy,kz,ls) + 0.776*qxw)*an(ix,jy,kz,ls)/ & +! & (an(ix,jy,kz,lns)*(snu+1.)*rwdn**2)*db(ix,jy,kz)**2 + gtmp(ix,kz) = 3.6e18*(snu+2.)*( 0.224*(an(ix,jy,kz,ls)+qxw1) + 0.776*qxw)*(an(ix,jy,kz,ls)+qxw1)/ & + & (an(ix,jy,kz,lns)*(snu+1.)*rwdn**2)*db(ix,jy,kz)**2 + + ELSE ! new form using a mass relationship m = p d^2 (instead of d^3 -- Cox 1988 QJRMS) so that density depends on size + ! p = 0.106214 for m = p v^(2/3) + dnsnow = 0.346159*sqrt(an(ix,jy,kz,lns)/(an(ix,jy,kz,ls)*db(ix,jy,kz)) ) + IF ( .true. .or. dnsnow < 900. ) THEN + gtmp(ix,kz) = 1.e18*323.3226* 0.106214**2*(ksq*an(ix,jy,kz,ls) + & + & (1.-ksq)*qxw)*an(ix,jy,kz,ls)*db(ix,jy,kz)**2*gsnow73/ & + & (an(ix,jy,kz,lns)*(917.)**2* gsnow1*(1.0+snu)**(4./3.)) + ELSE ! otherwise small enough to assume ice spheres? + gtmp(ix,kz) = (36./pi**2) * 1.e18*(snu+2.)*( 0.224*(an(ix,jy,kz,ls)+qxw1) + 0.776*qxw)*(an(ix,jy,kz,ls)+qxw1)/ & + & (an(ix,jy,kz,lns)*(snu+1.)*rwdn**2)*db(ix,jy,kz)**2 + ENDIF + + ENDIF + + ENDIF + +! tmp = Min(1.0,1.e3*(an(ix,jy,kz,ls))*db(ix,jy,kz)) +! gtmp(ix,kz) = Max( 1.0*gtmp(ix,kz), 750.0*(tmp)**1.98) + dtmps = gtmp(ix,kz) + dtmp(ix,kz) = dtmp(ix,kz) + gtmp(ix,kz) + ELSE ! }{ single-moment snow: + gtmp(ix,kz) = dads*an(ix,jy,kz,ls)**(0.25) + + IF ( gtmp(ix,kz) .gt. 0.0 ) THEN !{ + dtmps = zsdryc*an(ix,jy,kz,ls)**2/gtmp(ix,kz) + IF ( temk(ix,jy,kz) .lt. tfr ) THEN + dtmp(ix,kz) = dtmp(ix,kz) + & + & zsdryc*an(ix,jy,kz,ls)**2/gtmp(ix,kz) + ELSE + dtmp(ix,kz) = dtmp(ix,kz) + & + & zswetc*an(ix,jy,kz,ls)**2/gtmp(ix,kz) + ENDIF + ENDIF !} + ENDIF !} + + ENDIF !} + + ENDIF + + +! +! ice crystal contribution (Heymsfield, 1977, JAS) +! + IF ( li .gt. 1 .and. idbzci .ne. 0 ) THEN + + IF ( idbzci == 1 .and. lni > 0 ) THEN + ! assume spherical ice with density of 900 for dbz calc + IF ( an(ix,jy,kz,li) > qxmin(li) .and. an(ix,jy,kz,lni) > 1.0 ) THEN + vr = db(ix,jy,kz)*an(ix,jy,kz,li)/(900.*an(ix,jy,kz,lni)) + dtmp(ix,kz) = dtmp(ix,kz) + & + & 0.224*3.6e18*(cinu+2.)*an(ix,jy,kz,lni)*vr**2/(cinu+1.)*(900./1000.)**2 + ENDIF + + ELSEIF ( idbzci == 2 ) THEN +! +! ice crystal contribution (Heymsfield, 1977, JAS) +! + gtmp(ix,kz) = 0.0 + IF ( an(ix,jy,kz,li) .ge. 0.1e-3 ) THEN + gtmp(ix,kz) = Min(1.0,1.e3*(an(ix,jy,kz,li))*db(ix,jy,kz)) + dtmp(ix,kz) = dtmp(ix,kz) + 750.0*(gtmp(ix,kz))**1.98 + ENDIF + + ENDIF + + ENDIF + +! +! graupel/hail contribution +! + IF ( lh .gt. 1 ) THEN ! { + gtmp(ix,kz) = 0.0 + dtmph = 0.0 + qxw = 0.0 + + IF ( izieg .ge. 1 .and. ipconc .ge. 5 ) THEN + + ltest = .false. + + IF ( ltest .or. (an(ix,jy,kz,lh) .ge. qhmin .and. an(ix,jy,kz,lnh) .ge. cxmin )) THEN + + IF ( lvh .gt. 1 ) THEN + + IF ( an(ix,jy,kz,lvh) .gt. 0.0 ) THEN + hwdn = db(ix,jy,kz)*an(ix,jy,kz,lh)/an(ix,jy,kz,lvh) + hwdn = Min( 900., Max( 100., hwdn ) ) + ELSE + hwdn = 500. ! hwdn1t + ENDIF + + ENDIF + + chw = an(ix,jy,kz,lnh) + IF ( chw .gt. 0.0 ) THEN ! (Ferrier 94) + xvh = db(ix,jy,kz)*an(ix,jy,kz,lh)/(hwdn*Max(1.0e-3,chw)) + IF ( xvh .lt. xvhmn .or. xvh .gt. xvhmx ) THEN + xvh = Min( xvhmx, Max( xvhmn,xvh ) ) + chw = db(ix,jy,kz)*an(ix,jy,kz,lh)/(xvh*hwdn) + ENDIF + + qh = an(ix,jy,kz,lh) + + IF ( lhw .gt. 1 ) THEN + IF ( iusewetgraupel .eq. 1 ) THEN + qxw = an(ix,jy,kz,lhw) + ELSEIF ( iusewetgraupel .eq. 2 ) THEN + IF ( hwdn .lt. 300. ) THEN + qxw = an(ix,jy,kz,lhw) + ENDIF + ENDIF + ELSEIF ( iusewetgraupel .eq. 3 ) THEN + IF ( hwdn .lt. 300. .and. temk(ix,jy,kz) > tfr .and. an(ix,jy,kz,lr) > qhmin ) THEN + qxw = Min( an(ix,jy,kz,lh), an(ix,jy,kz,lr)) + qh = qh + qxw + ENDIF + ELSEIF ( iusewetgraupel == 4 .and. temk(ix,jy,kz) .gt. tfr+0.25 .and. an(ix,jy,kz,lh) > an(ix,jy,kz,lr) & + & .and. an(ix,jy,kz,lr) > qhmin) THEN + qxw = Min(0.5*an(ix,jy,kz,lh), an(ix,jy,kz,lr)) + qh = qh + qxw + + ENDIF + + IF ( lzh .gt. 1 ) THEN + ELSE + g1 = (6.0 + alphah)*(5.0 + alphah)*(4.0 + alphah)/((3.0 + alphah)*(2.0 + alphah)*(1.0 + alphah)) +! zx = g1*(db(ix,jy,kz)*an(ix,jy,kz,lh))**2/chw +! ze = 0.224*1.e18*zx*(6./(pi*1000.))**2 + zx = g1*db(ix,jy,kz)**2*( 0.224*qh + 0.776*qxw)*qh/chw + ze =1.e18*zx*(6./(pi*1000.))**2 + dtmp(ix,kz) = dtmp(ix,kz) + ze + dtmph = ze + ENDIF + + ENDIF + + ! IF ( an(ix,jy,kz,lh) .gt. 1.0e-3 ) write(0,*) 'Graupel Z : ',dtmph,ze + ENDIF + + ELSE + + dtmph = 0.0 + + IF ( an(ix,jy,kz,lh) .ge. qhmin ) THEN + gtmp(ix,kz) = dadh*an(ix,jy,kz,lh)**(0.25) + IF ( gtmp(ix,kz) .gt. 0.0 ) THEN + dtmph = zhdryc*an(ix,jy,kz,lh)**2/gtmp(ix,kz) + IF ( temk(ix,jy,kz) .lt. tfr ) THEN + dtmp(ix,kz) = dtmp(ix,kz) + & + & zhdryc*an(ix,jy,kz,lh)**2/gtmp(ix,kz) + ELSE +! IF ( hwdn .gt. 700.0 ) THEN + dtmp(ix,kz) = dtmp(ix,kz) + & + & zhdryc*an(ix,jy,kz,lh)**2/gtmp(ix,kz) +! +! & (zhwetc*gtmp(ix,kz)**7)**0.95 +! ELSE +! dtmp(ix,kz) = dtmp(ix,kz) + zhwetc*gtmp(ix,kz)**7 +! ENDIF + ENDIF + ENDIF + ENDIF + + + + ENDIF + + + ENDIF ! } + + ENDIF ! na .gt. 5 + + + IF ( izieg .ge. 1 .and. lhl .gt. 1 ) THEN + + hldn = 900.0 + gtmp(ix,kz) = 0.0 + dtmphl = 0.0 + qxw = 0.0 + + + IF ( lvhl .gt. 1 ) THEN + IF ( an(ix,jy,kz,lvhl) .gt. 0.0 ) THEN + hldn = db(ix,jy,kz)*an(ix,jy,kz,lhl)/an(ix,jy,kz,lvhl) + hldn = Min( 900., Max( 300., hldn ) ) + ELSE + hldn = 900. + ENDIF + ELSE + hldn = rho_qhl + ENDIF + + + IF ( ipconc .ge. 5 ) THEN + + ltest = .false. + + IF ( ltest .or. ( an(ix,jy,kz,lhl) .ge. qhlmin .and. an(ix,jy,kz,lnhl) .gt. 0.) ) THEN !{ + chl = an(ix,jy,kz,lnhl) + IF ( chl .gt. 0.0 ) THEN !{ + xvhl = db(ix,jy,kz)*an(ix,jy,kz,lhl)/ & + & (hldn*Max(1.0e-9,an(ix,jy,kz,lnhl))) + IF ( xvhl .lt. xvhlmn .or. xvhl .gt. xvhlmx ) THEN ! { + xvhl = Min( xvhlmx, Max( xvhlmn,xvhl ) ) + chl = db(ix,jy,kz)*an(ix,jy,kz,lhl)/(xvhl*hldn) + ! do not update state in dbz calc. ! an(ix,jy,kz,lnhl) = chl + ENDIF ! } + + IF ( lhlw .gt. 1 ) THEN + IF ( iusewethail .eq. 1 ) THEN + qxw = an(ix,jy,kz,lhlw) + ELSEIF ( iusewethail .eq. 2 ) THEN + IF ( hldn .lt. 300. ) THEN + qxw = an(ix,jy,kz,lhlw) + ENDIF + ENDIF + ENDIF + + IF ( lzhl .gt. 1 ) THEN !{ + ELSE !} + + g1 = (6.0 + alphahl)*(5.0 + alphahl)*(4.0 + alphahl)/((3.0 + alphahl)*(2.0 + alphahl)*(1.0 + alphahl)) + zx = g1*db(ix,jy,kz)**2*( 0.224*an(ix,jy,kz,lhl) + 0.776*qxw)*an(ix,jy,kz,lhl)/chl +! zx = g1*(db(ix,jy,kz)*an(ix,jy,kz,lhl))**2/chl + ze = 1.e18*zx*(6./(pi*1000.))**2 ! 3/28/2016 removed extra factor of 0.224 + dtmp(ix,kz) = dtmp(ix,kz) + ze + dtmphl = ze + + ENDIF !} + ENDIF!} + ! IF ( an(ix,jy,kz,lh) .gt. 1.0e-3 ) write(0,*) 'Graupel Z : ',dtmph,ze + ENDIF + + + ELSE + + + IF ( an(ix,jy,kz,lhl) .ge. qhlmin ) THEN ! { + dadhl = ( db(ix,jy,kz) /(pi*hldn*cnohl) )**(.25) + gtmp(ix,kz) = dadhl*an(ix,jy,kz,lhl)**(0.25) + IF ( gtmp(ix,kz) .gt. 0.0 ) THEN ! { + + zhldryc = 0.224*cr2*( db(ix,jy,kz)/rwdn)**2/cnohl + + dtmphl = zhldryc*an(ix,jy,kz,lhl)**2/gtmp(ix,kz) + + IF ( temk(ix,jy,kz) .lt. tfr ) THEN + dtmp(ix,kz) = dtmp(ix,kz) + & + & zhldryc*an(ix,jy,kz,lhl)**2/gtmp(ix,kz) + ELSE +! IF ( hwdn .gt. 700.0 ) THEN + dtmp(ix,kz) = dtmp(ix,kz) + & + & zhldryc*an(ix,jy,kz,lhl)**2/gtmp(ix,kz) +! +! : (zhwetc*gtmp(ix,kz)**7)**0.95 +! ELSE +! dtmp(ix,kz) = dtmp(ix,kz) + zhwetc*gtmp(ix,kz)**7 +! ENDIF + ENDIF + ENDIF ! } + + ENDIF ! } + + ENDIF ! ipconc .ge. 5 + + + ENDIF ! izieg .ge. 1 .and. lhl .gt. 1 + + + + IF ( dtmp(ix,kz) .gt. 0.0 ) THEN + dbz(ix,jy,kz) = Max(dbzmin, 10.0*Log10(dtmp(ix,kz)) ) + + IF ( dbz(ix,jy,kz) .gt. dbzmax ) THEN + dbzmax = Max(dbzmax,dbz(ix,jy,kz)) + imx = ix + jmx = jy + kmx = kz + ENDIF + ELSE + dbz(ix,jy,kz) = dbzmin + IF ( lh > 1 .and. lhl > 1) THEN + IF ( an(ix,jy,kz,lh) > 1.0e-3 ) THEN + write(0,*) 'radardbz: qr,qh,qhl = ',an(ix,jy,kz,lr), an(ix,jy,kz,lh),an(ix,jy,kz,lhl) + write(0,*) 'radardbz: dtmps,dtmph,dadh,dadhl,dtmphl = ',dtmps,dtmph,dadh,dadhl,dtmphl + + IF ( lzh>1 .and. lzhl>1 ) write(0,*) 'radardbz: zh, zhl = ',an(ix,jy,kz,lzh),an(ix,jy,kz,lzhl) + ENDIF + ENDIF + ENDIF + +! IF ( an(ix,jy,kz,lh) .gt. 1.e-4 .and. +! & dbz(ix,jy,kz) .le. 0.0 ) THEN +! write(0,*) 'dbz = ',dbz(ix,jy,kz) +! write(0,*) 'Hail intercept: ',xcnoh,ix,kz +! write(0,*) 'Hail,snow q: ',an(ix,jy,kz,lh),an(ix,jy,kz,ls) +! write(0,*) 'Hail,snow c: ',an(ix,jy,kz,lnh),an(ix,jy,kz,lns) +! write(0,*) 'dtmps,dtmph = ',dtmps,dtmph +! ENDIF + + IF ( ndebug>1 .and. .not. dtmp(ix,kz) .lt. 1.e30 .or. dbz(ix,jy,kz) > 190.0 ) THEN +! IF ( ix == 31 .and. kz == 20 .and. jy == 23 ) THEN +! write(0,*) 'my_rank = ',my_rank + write(0,*) 'ix,jy,kz = ',ix,jy,kz + write(0,*) 'dbz = ',dbz(ix,jy,kz) + write(0,*) 'db, zhdryc = ',db(ix,jy,kz),zhdryc + write(0,*) 'Hail intercept: ',xcnoh,ix,kz + write(0,*) 'Hail,snow q: ',an(ix,jy,kz,lh),an(ix,jy,kz,ls) + write(0,*) 'graupel density hwdn = ',hwdn + write(0,*) 'rain q: ',an(ix,jy,kz,lr) + write(0,*) 'ice q: ',an(ix,jy,kz,li) + IF ( lhl .gt. 1 ) write(0,*) 'Hail (lhl): ',an(ix,jy,kz,lhl) + IF (ipconc .ge. 3 ) write(0,*) 'rain c: ',an(ix,jy,kz,lnr) + IF ( lzr > 1 ) write(0,*) 'rain Z: ',an(ix,jy,kz,lzr) + IF ( ipconc .ge. 5 ) THEN + write(0,*) 'Hail,snow c: ',an(ix,jy,kz,lnh),an(ix,jy,kz,lns) + IF ( lhl .gt. 1 ) write(0,*) 'Hail (lnhl): ',an(ix,jy,kz,lnhl) + IF ( lzhl .gt. 1 ) THEN + write(0,*) 'Hail (lzhl): ',an(ix,jy,kz,lzhl) + write(0,*) 'chl,xvhl,dhl = ',chl,xvhl,(xvhl*6./3.14159)**(1./3.) + write(0,*) 'xvhlmn,xvhlmx = ',xvhlmn,xvhlmx + ENDIF + ENDIF + write(0,*) 'chw,xvh = ', chw,xvh + write(0,*) 'dtmps,dtmph,dadh,dadhl,dtmphl = ',dtmps,dtmph,dadh,dadhl,dtmphl + write(0,*) 'dtmpr = ',dtmpr + write(0,*) 'gtmp = ',gtmp(ix,kz),dtmp(ix,kz) + IF ( .not. (dbz(ix,jy,kz) .gt. -100 .and. dbz(ix,jy,kz) .lt. 200 ) ) THEN + write(0,*) 'dbz out of bounds!' + ENDIF + ENDIF + + + ENDDO ! ix + ENDDO ! kz + ENDDO ! jy + + + + +! write(0,*) 'na,lr = ',na,lr + IF ( printyn .eq. 1 ) THEN +! IF ( dbzmax .gt. dbzmin ) THEN + write(iunit,*) 'maxdbz,ijk = ',dbzmax,imx,jmx,kmx + write(iunit,*) 'qrw = ',an(imx,jmx,kmx,lr) + + IF ( lh .gt. 1 ) THEN + write(iunit,*) 'qi = ',an(imx,jmx,kmx,li) + write(iunit,*) 'qsw = ',an(imx,jmx,kmx,ls) + write(iunit,*) 'qhw = ',an(imx,jmx,kmx,lh) + IF ( lhl .gt. 1 ) write(iunit,*) 'qhl = ',an(imx,jmx,kmx,lhl) + ENDIF + + + ENDIF + + + RETURN + END subroutine radardd02 + + +! ############################################################################## +! ############################################################################## + + +!>\ingroup mod_nsslmp +!! Droplet nucleation routine. Explicit condensation/evaporation. Tiny mixing ratio cleanup. +! ##################################################################### +! ##################################################################### +! +! Subroutine for explicit cloud condensation and droplet nucleation +! + SUBROUTINE NUCOND & + & (nx,ny,nz,na,jyslab & + & ,nor,norz,dtp,nxi & + & ,dz3d & + & ,t0,t9 & + & ,an,dn,p2 & + & ,pn,w & + & ,axtra,io_flag & + & ,ssfilt,t00,t77,flag_qndrop & + & ) + + + implicit none + +! real :: cwmasn = 1000.*0.523599*(2.*2.e-6)**3 + integer :: nx,ny,nz,na,nxi + integer :: nor,norz, jyslab ! ,nht,ngt,igsr + real :: dtp ! time step + logical :: flag_qndrop + + integer, parameter :: ng1 = 1 + + +! +! external temporary arrays +! + real t00(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz) + real t77(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz) + + real t0(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz) +! real t1(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz) +! real t2(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz) +! real t3(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz) +! real t4(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz) +! real t5(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz) +! real t6(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz) +! real t7(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz) +! real t8(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz) + real t9(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz) + + + real p2(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz) ! perturbation Pi + real pn(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz) + real an(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz,na) + real dn(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz) + + real w(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz) +! real qv(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz) + + real ssfilt(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz) + + + real pb(-norz+ng1:nz+norz) + real pinit(-norz+ng1:nz+norz) + + real dz3d(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz) + + + ! local + + + real axtra(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-norz+ng1:nz+norz,nxtra) + logical :: io_flag + + real :: dv + +! +! declarations microphysics and for gather/scatter +! + real, parameter :: cwmas30 = 1000.*0.523599*(2.*30.e-6)**3 ! mass of 30-micron radius droplet, for sat. adj. + real, parameter :: cwmas20 = 1000.*0.523599*(2.*20.e-6)**3 ! mass of 20-micron radius droplet, for sat. adj. + integer nxmpb,nzmpb,nxz + integer mgs,ngs,numgs,inumgs + parameter (ngs=500) + integer ngscnt,igs(ngs),kgs(ngs) + integer kgsp(ngs),kgsm(ngs) + integer nsvcnt + + integer ix,kz,i,n, kp1, km1 + integer :: jy, jgs + integer ixb,ixe,jyb,jye,kzb,kze + + integer itile,jtile,ktile + integer ixend,jyend,kzend,kzbeg + integer nxend,nyend,nzend,nzbeg + +! +! Variables for Ziegler warm rain microphysics +! + + + real ccnc(ngs), ccna(ngs), cnuc(ngs), cwnccn(ngs) + real ccncuf(ngs) + real sscb ! 'cloud base' SS threshold + parameter ( sscb = 2.0 ) + integer idecss ! flag to turn on (=1) decay of ssmax when no cloud or ice crystals + parameter ( idecss = 1 ) + integer iba ! flag to do condensation/nucleation in 1st or 2nd loop + ! =0 to use ad to calculate SS + ! =1 to use an at end of main jy loop to calculate SS + parameter (iba = 1) + integer ifilt ! =1 to filter ssat, =0 to set ssfilt=ssat + parameter ( ifilt = 0 ) + real temp1,temp2 ! ,ssold + real :: ssmax(ngs) = 0.0 ! maximum SS experienced by a parcel + real ssmx + real dnnet,dqnet +! real cnu,rnu,snu,cinu +! parameter ( cnu = 0.0, rnu = -0.8, snu = -0.8, cinu = 0.0 ) + real ventrx(ngs) + real ventrxn(ngs) + real volb, t2s + real, parameter :: aa1 = 9.44e15, aa2 = 5.78e3 ! a1 in Ziegler + + real ec0, ex1, ft, rhoinv(ngs) + + real chw, g1, rd1 + + real ac1,bc, taus, c1,d1,e1,f1,p380,tmp,tmp2 ! , sstdy, super + real tmpmx, fw, qctmp + real x,y,del,r,alpr + double precision :: vent1,vent2 + real g1palp + real bs + real v1, v2 + real d1r, d1i, d1s, e1i + integer nc ! condensation step + real dtcon,dtcon1,dtcon2 ! condensation time step (dtcon*nc = dtp) + real delta + integer ltemq1,ltemq1m ! ,ltemq1m2 + real dqv,qv1,ss1,ss2,qvs1,dqvs,dtemp,dt1 ! temporaries for condensation + + real ssi1, ssi2, dqvi, dqvis, dqvii,qis1 + real dqvr, dqc, dqr, dqi, dqs + real qv1m,qvs1m,ss1m,ssi1m,qis1m + real cwmastmp + real dcloud,dcloud2 ! ,as, bs + real dcrit + real cn(ngs), cnuf(ngs) + real :: ccwmax + + integer ltemq + + integer il + + real es(ngs) ! ss(ngs), +! real eis(ngs) + real ssf(ngs),ssfkp1(ngs),ssfkm1(ngs),ssat0(ngs) + real, parameter :: ssfcut = 4.0 + real ssfjp1(ngs),ssfjm1(ngs) + real ssfip1(ngs),ssfim1(ngs) + + real supcb, supmx + parameter (supcb=0.5,supmx=238.0) + real r2dxm, r2dym, r2dzm + real dssdz, dssdy, dssdx +! real tqvcon + real epsi,d + parameter (epsi = 0.622, d = 0.266) + real r1,qevap ! ,slv + + real vr,nrx,qr,z1,z2,rdi,alp,xnutmp,xnuc + real ctmp, ccwtmp + real f5, qvs0 ! Kessler condensation factor + real :: t0p1, t0p3 + real qvex + +! real, dimension(ngs) :: temp, tempc, elv, elf, els, pqs, theta, temg, temcg + real dqvcnd(ngs),dqwv(ngs),dqcw(ngs),dqci(ngs) + real temp(ngs),tempc(ngs) + real temg(ngs),temcg(ngs),theta(ngs),qvap(ngs) ! ,tembzg(ngs) + real temgx(ngs),temcgx(ngs) + real qvs(ngs),qis(ngs),qss(ngs),pqs(ngs) + real felv(ngs),felf(ngs),fels(ngs) + real felvcp(ngs),felvpi(ngs) + real gamw(ngs),gams(ngs) ! qciavl(ngs), + real tsqr(ngs),ssi(ngs),ssw(ngs) + real cc3(ngs),cqv1(ngs),cqv2(ngs) + real qcwtmp(ngs),qtmp + + real fvent(ngs) !,fraci(ngs),fracl(ngs) + real fwvdf(ngs),ftka(ngs),fthdf(ngs) + real fadvisc(ngs),fakvisc(ngs) + real fci(ngs),fcw(ngs) + real fschm(ngs),fpndl(ngs) + + real pres(ngs),pipert(ngs) + real pk(ngs) + real rho0(ngs),pi0(ngs) + real rhovt(ngs) + real thetap(ngs),theta0(ngs),qwvp(ngs),qv0(ngs) + real thsave(ngs) + real qss0(ngs) + real fcqv1(ngs) + real wvel(ngs),wvelkm1(ngs) + + real wvdf(ngs),tka(ngs) + real advisc(ngs) + + real rwvent(ngs) + + + real :: qx(ngs,lv:lhab) + real :: cx(ngs,lc:lhab) + real :: xv(ngs,lc:lhab) + real :: xmas(ngs,lc:lhab) + real :: xdn(ngs,lc:lhab) + real :: xdia(ngs,lc:lhab,3) + real :: alpha(ngs,lc:lhab) + real :: zx(ngs,lr:lhab) + + + logical zerocx(lc:lqmx) + + logical :: lprint + + integer, parameter :: iunit = 0 + + real :: frac, hwdn, tmpg + + real :: cvm,cpm,rmm + + real, parameter :: cpv = 1885.0 ! specific heat of water vapor at constant pressure + + integer :: kstag + + integer :: count + + +! ------------------------------------------------------------------------------- + itile = nxi + jtile = ny + ktile = nz + ixend = nxi + jyend = ny + kzend = nz + nxend = nxi + 1 + nyend = ny + 1 + nzend = nz + kzbeg = 1 + nzbeg = 1 + + f5 = 237.3 * 17.27 * 2.5e6 / cp ! combined constants for rain condensation (Soong and Ogura 73) + + jy = 1 + kstag = 0 + pb(:) = 0.0 + pinit(:) = 0.0 + + IF ( ipconc <= 1 .or. isedonly == 2 ) GOTO 2200 + +! +! Ziegler nucleation +! + +! ssfilt(:,:,:) = 0.0 + ssmx = 0 + count = 0 + + do kz = 1,nz-kstag + do ix = 1,nxi + + temp1 = an(ix,jy,kz,lt)*t77(ix,jy,kz) + t0(ix,jy,kz) = temp1 + ltemq = Int( (temp1-163.15)/fqsat+1.5 ) + ltemq = Min( nqsat, Max(1,ltemq) ) + + c1 = t00(ix,jy,kz)*tabqvs(ltemq) + + IF ( c1 > 0. ) THEN + ssfilt(ix,jy,kz) = 100.*(an(ix,jy,kz,lv)/c1 - 1.0) ! from "new" values + ENDIF + + ENDDO + ENDDO + + +! +! jy = 1 ! working on a 2d slab +!! VERY IMPORTANT: SET jgs = jy + + jgs = jy + +! +!..Gather microphysics +! + if ( ndebug .gt. 0 ) write(0,*) 'ICEZVD_DR: Gather stage' + + nxmpb = 1 + nzmpb = 1 + nxz = nxi*nz + numgs = nxz/ngs + 1 + + + do 2000 inumgs = 1,numgs + + ngscnt = 0 + + + kzb = nzmpb + kze = nz-kstag + ! if (kzbeg .le. nzmpb .and. kzend .gt. nzmpb) kzb = nzmpb + + ixb = nxmpb + ixe = itile + + do kz = kzb,kze + do ix = nxmpb,nxi + + pqs(1) = 380.0/(pn(ix,jy,kz) + pb(kz)) + theta(1) = an(ix,jy,kz,lt) + temg(1) = t0(ix,jy,kz) + + temcg(1) = temg(1) - tfr + ltemq = (temg(1)-163.15)/fqsat+1.5 + ltemq = Min( nqsat, Max(1,ltemq) ) + qvs(1) = pqs(1)*tabqvs(ltemq) + qis(1) = pqs(1)*tabqis(ltemq) + + qss(1) = qvs(1) + + + if ( temg(1) .lt. tfr ) then + end if +! + if ( (temg(1) .gt. tfrh .or. an(ix,jy,kz,lv)/qvs(1) > maxlowtempss ) .and. & + & ( an(ix,jy,kz,lv) .gt. qss(1) .or. & + & an(ix,jy,kz,lc) .gt. qxmin(lc) .or. & + & ( an(ix,jy,kz,lr) .gt. qxmin(lr) .and. rcond == 2 ) & + & )) then + ngscnt = ngscnt + 1 + igs(ngscnt) = ix + kgs(ngscnt) = kz + if ( ngscnt .eq. ngs ) goto 2100 + end if + + end do !ix + + nxmpb = 1 + end do !kz +! if ( jy .eq. (ny-jstag) ) iend = 1 + 2100 continue + + if ( ngscnt .eq. 0 ) go to 29998 + + if (ndebug .gt. 0 ) write(0,*) 'ICEZVD_DR: dbg = 8' + +! write(0,*) 'NUCOND: dbg = 8, ngscnt,ssmx = ',ngscnt,ssmx + + + qx(:,:) = 0.0 + cx(:,:) = 0.0 + + xv(:,:) = 0.0 + xmas(:,:) = 0.0 + + IF ( imurain == 1 ) THEN + alpha(:,lr) = alphar + ELSEIF ( imurain == 3 ) THEN + alpha(:,lr) = xnu(lr) + ENDIF + +! +! define temporaries for state variables to be used in calculations +! + DO mgs = 1,ngscnt + qx(mgs,lv) = an(igs(mgs),jy,kgs(mgs),lv) + DO il = lc,lhab + qx(mgs,il) = max(an(igs(mgs),jy,kgs(mgs),il), 0.0) + ENDDO + + qcwtmp(mgs) = qx(mgs,lc) + + + theta0(mgs) = an(igs(mgs),jy,kgs(mgs),lt) ! + thetap(mgs) = 0.0 + theta(mgs) = an(igs(mgs),jy,kgs(mgs),lt) + qv0(mgs) = qx(mgs,lv) + qwvp(mgs) = qx(mgs,lv) - qv0(mgs) + + pres(mgs) = pn(igs(mgs),jy,kgs(mgs)) + pb(kgs(mgs)) + pipert(mgs) = p2(igs(mgs),jy,kgs(mgs)) + rho0(mgs) = dn(igs(mgs),jy,kgs(mgs)) + rhoinv(mgs) = 1.0/rho0(mgs) + rhovt(mgs) = Sqrt(rho00/rho0(mgs)) + pi0(mgs) = p2(igs(mgs),jy,kgs(mgs)) + pinit(kgs(mgs)) + temg(mgs) = t0(igs(mgs),jy,kgs(mgs)) +! pk(mgs) = t77(igs(mgs),jy,kgs(mgs)) ! ( pres(mgs) / poo ) ** cap + pk(mgs) = p2(igs(mgs),jy,kgs(mgs)) + pinit(kgs(mgs)) ! t77(igs(mgs),jy,kgs(mgs)) + temcg(mgs) = temg(mgs) - tfr + qss0(mgs) = (380.0)/(pres(mgs)) + pqs(mgs) = (380.0)/(pres(mgs)) + ltemq = (temg(mgs)-163.15)/fqsat+1.5 + ltemq = Min( nqsat, Max(1,ltemq) ) + qvs(mgs) = pqs(mgs)*tabqvs(ltemq) + qis(mgs) = pqs(mgs)*tabqis(ltemq) +! + qvap(mgs) = max( (qwvp(mgs) + qv0(mgs)), 0.0 ) + es(mgs) = 6.1078e2*tabqvs(ltemq) + qss(mgs) = qvs(mgs) + + + temgx(mgs) = min(temg(mgs),313.15) + temgx(mgs) = max(temgx(mgs),233.15) + felv(mgs) = 2500837.367 * (273.15/temgx(mgs))**((0.167)+(3.67e-4)*temgx(mgs)) +! + IF ( eqtset <= 1 ) THEN + felvcp(mgs) = felv(mgs)*cpi + ELSE ! equation set 2 in cm1 + tmp = qx(mgs,li)+qx(mgs,ls)+qx(mgs,lh) + IF ( lhl > 1 ) tmp = tmp + qx(mgs,lhl) + cvm = cv+cvv*qx(mgs,lv)+cpl*(qx(mgs,lc)+qx(mgs,lr)) & + +cpigb*(tmp) + cpm = cp+cpv*qx(mgs,lv)+cpl*(qx(mgs,lc)+qx(mgs,lr)) & + +cpigb*(tmp) + rmm=rd+rw*qx(mgs,lv) + + IF ( eqtset == 2 ) THEN + + felvcp(mgs) = (felv(mgs)-rw*temg(mgs))/cvm + + ELSE + felvcp(mgs) = (felv(mgs)*cv/(cp) - rw*temg(mgs)*(1.0-rovcp*cpm/rmm))/cvm + felvpi(mgs) = pi0(mgs)*rovcp*(felv(mgs)/(temg(mgs)) - rw*cpm/rmm)/cvm + ENDIF + + ENDIF + + temcgx(mgs) = min(temg(mgs),273.15) + temcgx(mgs) = max(temcgx(mgs),223.15) + temcgx(mgs) = temcgx(mgs)-273.15 + felf(mgs) = 333690.6098 + (2030.61425)*temcgx(mgs) - (10.46708312)*temcgx(mgs)**2 +! + fels(mgs) = felv(mgs) + felf(mgs) + fcqv1(mgs) = 4098.0258*felv(mgs)*cpi + + wvdf(mgs) = (2.11e-05)*((temg(mgs)/tfr)**1.94)* & + & (101325.0/(pb(kgs(mgs)) + pn(igs(mgs),jgs,kgs(mgs)))) ! diffusivity of water vapor, Hall and Pruppacher (76) + advisc(mgs) = advisc0*(416.16/(temg(mgs)+120.0))* & + & (temg(mgs)/296.0)**(1.5) ! dynamic viscosity (SMT; see Beard & Pruppacher 71) + tka(mgs) = tka0*advisc(mgs)/advisc1 ! thermal conductivity + + + ENDDO + + + +! +! load concentrations +! + if ( ipconc .ge. 1 ) then + do mgs = 1,ngscnt + cx(mgs,li) = Max(an(igs(mgs),jy,kgs(mgs),lni), 0.0) + end do + end if + if ( ipconc .ge. 2 ) then + do mgs = 1,ngscnt + cx(mgs,lc) = Max(an(igs(mgs),jy,kgs(mgs),lnc), 0.0) + cwnccn(mgs) = cwccn*rho0(mgs)/rho00 ! background ccn count + cn(mgs) = 0.0 + IF ( lss > 1 ) THEN + ssmax(mgs) = an(igs(mgs),jy,kgs(mgs),lss) + ELSE + ssmax(mgs) = 0.0 + ENDIF + IF ( lccn .gt. 1 ) THEN + ccnc(mgs) = an(igs(mgs),jy,kgs(mgs),lccn) + ELSE + ccnc(mgs) = cwnccn(mgs) + ENDIF + IF ( lccnuf .gt. 1 ) THEN + ccncuf(mgs) = an(igs(mgs),jy,kgs(mgs),lccnuf) + ELSE + ccncuf(mgs) = 0.0 + ENDIF + cnuf(mgs) = 0.0 + IF ( lccna > 1 ) THEN + ccna(mgs) = an(igs(mgs),jy,kgs(mgs),lccna) ! predicted count of activated ccn + ELSE + IF ( lccn > 1 ) THEN + ccna(mgs) = cwnccn(mgs) - ccnc(mgs) ! diagnose activated ccn as background value - remaining unactivated ccn + ELSE + ccna(mgs) = cx(mgs,lc) ! approximation of number of activated ccn + ENDIF + ENDIF + end do + end if + if ( ipconc .ge. 3 ) then + do mgs = 1,ngscnt + cx(mgs,lr) = Max(an(igs(mgs),jy,kgs(mgs),lnr), 0.0) + end do + end if + +! cnuc(1:ngscnt) = cwccn*rho0(mgs)/rho00*(1. - renucfrac) + ccnc(1:ngscnt)*renucfrac + DO mgs = 1,ngscnt + ! default value of renucfrac is 0.0 + IF ( irenuc /= 6 ) THEN + cnuc(mgs) = Max(ccnc(mgs),cwnccn(mgs))*(1. - renucfrac) + ccnc(mgs)*renucfrac + ELSE + cnuc(mgs) = Max(ccnc(mgs),cwnccn(mgs))*(1. - renucfrac) + Max(0.0,ccnc(mgs) - ccna(mgs))*renucfrac + ENDIF + IF ( renucfrac >= 0.999 ) THEN + IF ( temg(mgs) < 265. ) THEN + IF ( qx(mgs,lc) > 10.*qxmin(lc) .and. w(igs(mgs),jgs,kgs(mgs)) > 2.0 ) THEN + cnuc(mgs) = 0.0 ! Min(cnuc(mgs), 0.5*cx(mgs,lc) ) ! Hack to reduce nucleation at low temp in updraft when ccn are not predicted + ELSE + cnuc(mgs) = 0.1*cnuc(mgs) + ENDIF + ENDIF + ENDIF + ENDDO + +! Set density +! + if (ndebug .gt. 0 ) write(0,*) 'ICEZVD_DR: Set density' + + do mgs = 1,ngscnt + xdn(mgs,lc) = xdn0(lc) + xdn(mgs,lr) = xdn0(lr) + end do + + ventrx(:) = ventr + ventrxn(:) = ventrn + + + +! write(0,*) 'NUCOND: Set ssf variables, ssmxinit =',ssmxinit + ssmx = 0.0 + DO mgs = 1,ngscnt + + kp1 = Min(nz, kgs(mgs)+1 ) + wvel(mgs) = (0.5)*(w(igs(mgs),jgs,kp1) & + & +w(igs(mgs),jgs,kgs(mgs))) + wvelkm1(mgs) = (0.5)*(w(igs(mgs),jgs,kgs(mgs)) & + & +w(igs(mgs),jgs,Max(1,kgs(mgs)-1))) + + ssat0(mgs) = ssfilt(igs(mgs),jgs,kgs(mgs)) + ssf(mgs) = ssfilt(igs(mgs),jgs,kgs(mgs)) +! ssmx = Max( ssmx, ssf(mgs) ) + + + ssfkp1(mgs) = ssfilt(igs(mgs),jgs,Min(nz-1,kgs(mgs)+1)) + ssfkm1(mgs) = ssfilt(igs(mgs),jgs,Max(1,kgs(mgs)-1)) + + + ENDDO + + + +! +! cloud water variables +! + + if ( ndebug .gt. 0 )write(0,*) 'ICEZVD_DR: Set cloud water variables' + + do mgs = 1,ngscnt + xv(mgs,lc) = 0.0 + IF ( ipconc .ge. 2 .and. cx(mgs,lc) .gt. 1.0e6 ) THEN + xmas(mgs,lc) = & + & min( max(qx(mgs,lc)*rho0(mgs)/cx(mgs,lc),cwmasn),cwmasx ) + xv(mgs,lc) = xmas(mgs,lc)/xdn(mgs,lc) + ELSE + IF ( qx(mgs,lc) .gt. qxmin(lc) .and. cx(mgs,lc) .gt. cxmin ) THEN + xmas(mgs,lc) = & + & min( max(qx(mgs,lc)*rho0(mgs)/cx(mgs,lc),xdn(mgs,lc)*xvmn(lc)), & + & xdn(mgs,lc)*xvmx(lc) ) + + cx(mgs,lc) = qx(mgs,lc)*rho0(mgs)/xmas(mgs,lc) + + ELSEIF ( qx(mgs,lc) .gt. qxmin(lc) .and. cx(mgs,lc) .le. cxmin ) THEN +! xmas(mgs,lc) = xdn(mgs,lc)*4.*pi/3.*(5.0e-6)**3 +! cx(mgs,lc) = rho0(mgs)*qx(mgs,lc)/xmas(mgs,lc) + cx(mgs,lc) = Max( cxmin, rho0(mgs)*qx(mgs,lc)/cwmasx ) + xmas(mgs,lc) = & + & min( max(qx(mgs,lc)*rho0(mgs)/cx(mgs,lc),cwmasn),cwmasx ) + xv(mgs,lc) = xmas(mgs,lc)/xdn(mgs,lc) + + ELSE + xmas(mgs,lc) = cwmasn + ENDIF + ENDIF + xdia(mgs,lc,1) = (xmas(mgs,lc)*cwc1)**c1f3 + + + end do +! +! rain +! + do mgs = 1,ngscnt + if ( qx(mgs,lr) .gt. qxmin(lr) ) then + + if ( ipconc .ge. 3 ) then + xv(mgs,lr) = rho0(mgs)*qx(mgs,lr)/(xdn(mgs,lr)*Max(1.0e-9,cx(mgs,lr))) +! parameter( xvmn(lr)=2.8866e-13, xvmx(lr)=4.1887e-9 ) ! mks + IF ( xv(mgs,lr) .gt. xvmx(lr) ) THEN + xv(mgs,lr) = xvmx(lr) + cx(mgs,lr) = rho0(mgs)*qx(mgs,lr)/(xvmx(lr)*xdn(mgs,lr)) + ELSEIF ( xv(mgs,lr) .lt. xvmn(lr) ) THEN + xv(mgs,lr) = xvmn(lr) + cx(mgs,lr) = rho0(mgs)*qx(mgs,lr)/(xvmn(lr)*xdn(mgs,lr)) + ENDIF + + xmas(mgs,lr) = xv(mgs,lr)*xdn(mgs,lr) + xdia(mgs,lr,3) = (xmas(mgs,lr)*cwc1)**(1./3.) ! xdia(mgs,lr,1) + IF ( imurain == 3 ) THEN +! xdia(mgs,lr,1) = (6.*pii*xv(mgs,lr)/(alpha(mgs,lr)+1.))**(1./3.) + xdia(mgs,lr,1) = xdia(mgs,lr,3) ! formulae for Ziegler (1985) use mean volume diameter, not lambda**(-1) + ELSE ! imurain == 1, Characteristic diameter (1/lambda) + xdia(mgs,lr,1) = (6.*piinv*xv(mgs,lr)/((alpha(mgs,lr)+3.)*(alpha(mgs,lr)+2.)*(alpha(mgs,lr)+1.)))**(1./3.) + ENDIF +! rwrad(mgs) = 0.5*xdia(mgs,lr,1) + +! Inverse exponential version: +! xdia(mgs,lr,1) = +! > (qx(mgs,lr)*rho0(mgs) +! > /(pi*xdn(mgs,lr)*cx(mgs,lr)))**(0.333333) + ELSE + xdia(mgs,lr,1) = & + & (qx(mgs,lr)*rho0(mgs)/(pi*xdn(mgs,lr)*cno(lr)))**(0.25) + end if + else + xdia(mgs,lr,1) = 1.e-9 +! rwrad(mgs) = 0.5*xdia(mgs,lr,1) + end if + + end do + + +! +! Ventilation coefficients + + do mgs = 1,ngscnt + + + fadvisc(mgs) = advisc0*(416.16/(temg(mgs)+120.0))* & + & (temg(mgs)/296.0)**(1.5) + + fakvisc(mgs) = fadvisc(mgs)*rhoinv(mgs) + + fwvdf(mgs) = (2.11e-05)*((temg(mgs)/tfr)**1.94)* & + & (101325.0/(pres(mgs))) + + fschm(mgs) = (fakvisc(mgs)/fwvdf(mgs)) + + fvent(mgs) = (fschm(mgs)**(1./3.)) * (fakvisc(mgs)**(-0.5)) + + end do +! +! +! Ziegler nucleation +! +! +! cloud evaporation, condensation, and nucleation +! sqsat -> qss(mgs) + + DO mgs=1,ngscnt + dcloud = 0.0 + ! Skip points at low temperature if SS stays less than 1.08, + ! otherwise allow nucleation at low temp (will freeze at next time step) + IF ( temg(mgs) .le. tfrh .and. qx(mgs,lv)/qvs(mgs) < maxlowtempss ) THEN + CYCLE + ENDIF + + IF( ssat0(mgs) .GT. 0. .OR. ssf(mgs) .GT. 0. ) GO TO 620 +!6/4 IF( qvap(mgs) .EQ. qss(mgs) ) GO TO 631 +! +!.... EVAPORATION. QV IS LESS THAN qss(mgs). +!.... EVAPORATE CLOUD FIRST +! + IF ( qx(mgs,lc) .LE. 0. ) GO TO 631 +!.... CLOUD EVAPORATION. +! convert input 'cp' to cgs + R1=1./(1. + caw*(273.15 - cbw)*qss(mgs)*felv(mgs)/ & + & (cp*(temg(mgs) - cbw)**2)) + QEVAP= Min( qx(mgs,lc), R1*(qss(mgs)-qvap(mgs)) ) + + + IF ( qx(mgs,lc) .LT. QEVAP ) THEN ! GO TO 63 + qwvp(mgs) = qwvp(mgs) + qx(mgs,lc) + thetap(mgs) = thetap(mgs) - felv(mgs)*qx(mgs,lc)/(cp*pi0(mgs)) + IF ( io_flag .and. nxtra > 1 ) THEN + axtra(igs(mgs),jy,kgs(mgs),1) = -qx(mgs,lc)/dtp + ENDIF + qx(mgs,lc) = 0. + IF ( restoreccn ) THEN + IF ( irenuc <= 2 ) THEN + IF ( .not. invertccn ) THEN + ccnc(mgs) = Max( ccnc(mgs), Min( qccn*rho0(mgs), ccnc(mgs) + cx(mgs,lc) ) ) + ELSE + ccnc(mgs) = ccnc(mgs) + cx(mgs,lc) + ENDIF + ENDIF + IF ( lccna > 1 ) THEN + ccna(mgs) = ccna(mgs) - cx(mgs,lc) + ENDIF + ENDIF + cx(mgs,lc) = 0. + ELSE + qctmp = qx(mgs,lc) + qwvp(mgs) = qwvp(mgs) + QEVAP + qx(mgs,lc) = qx(mgs,lc) - QEVAP + IF ( qx(mgs,lc) .le. 0. ) THEN + IF ( restoreccn ) THEN + IF ( irenuc <= 2 ) THEN +! ccnc(mgs) = Max( ccnc(mgs), Min( qccn*rho0(mgs), ccnc(mgs) + cx(mgs,lc) ) ) +! ccnc(mgs) = ccnc(mgs) + cx(mgs,lc) + IF ( .not. invertccn ) THEN + ccnc(mgs) = Max( ccnc(mgs), Min( qccn*rho0(mgs), ccnc(mgs) + cx(mgs,lc) ) ) + ELSE + ccnc(mgs) = ccnc(mgs) + cx(mgs,lc) + ENDIF + ENDIF + IF ( lccna > 1 ) THEN + ccna(mgs) = ccna(mgs) - cx(mgs,lc) + ENDIF + ENDIF + cx(mgs,lc) = 0. + ELSE + tmp = 0.9*QEVAP*cx(mgs,lc)/qctmp ! let droplets get smaller but also remove some. A factor of 1.0 would maintain same size + IF ( restoreccn ) THEN + IF ( irenuc <= 2 ) THEN + ! ccnc(mgs) = Max( ccnc(mgs), Min( qccn*rho0(mgs), ccnc(mgs) + tmp ) ) +! ccnc(mgs) = ccnc(mgs) + tmp + IF ( .not. invertccn ) THEN + ccnc(mgs) = Max( ccnc(mgs), Min( qccn*rho0(mgs), ccnc(mgs) + tmp ) ) + ELSE + ccnc(mgs) = ccnc(mgs) + tmp + ENDIF + ENDIF + IF ( lccna > 1 ) THEN + ccna(mgs) = ccna(mgs) - tmp + ENDIF + ENDIF + cx(mgs,lc) = cx(mgs,lc) - tmp + ENDIF + thetap(mgs) = thetap(mgs) - felv(mgs)*QEVAP/(CP*pi0(mgs)) + IF ( io_flag .and. nxtra > 1 ) THEN + axtra(igs(mgs),jy,kgs(mgs),1) = -QEVAP/dtp + ENDIF + + ENDIF + + GO TO 631 + + + 620 CONTINUE + +!.... CLOUD CONDENSATION + + IF ( qx(mgs,lc) .GT. qxmin(lc) .and. cx(mgs,lc) .ge. 1. ) THEN + + + +! ac1 = xdn(mgs,lc)*elv(kgs(mgs))**2*epsi/ +! : (tka(kgs(mgs))*rw*temg(mgs)**2) +! took out xdn factor because it cancels later... + ac1 = felv(mgs)**2/(tka(mgs)*rw*temg(mgs)**2) + + +! bc = xdn(mgs,lc)*rw*temg(mgs)/ +! : (epsi*wvdf(kgs(mgs))*es(mgs)) +! took out xdn factor because it cancels later... + bc = rw*temg(mgs)/(wvdf(mgs)*es(mgs)) + +! bs = rho0(mgs)*((rd*temg(mgs)/(epsi*es(mgs)))+ +! : (epsi*elv(kgs(mgs))**2/(pres(mgs)*temg(mgs)*cp))) + +! taus = Min(dtp, xdn(mgs,lc)*rho0(mgs)*(ac1+bc)/ +! : (4*pi*0.89298*BS*0.5*xdia(mgs,lc,1)*cx(mgs,lc)*xdn(mgs,lc))) + +! + IF ( ssf(mgs) .gt. 0.0 .or. ssat0(mgs) .gt. 0.0 ) THEN + IF ( ny .le. 2 ) THEN +! write(0,*) 'undershoot: ',ssf(mgs), +! : ( (qx(mgs,lv) - dcloud)/c1 - 1.0)*100. + ENDIF + + + + IF ( qx(mgs,lc) .gt. qxmin(lc) ) THEN + + IF ( xdia(mgs,lc,1) .le. 0.0 ) THEN + xmas(mgs,lc) = cwmasn + xdia(mgs,lc,1) = (xmas(mgs,lc)*cwc1)**c1f3 + ENDIF + d1 = (1./(ac1 + bc))*4.0*pi*ventc & + & *0.5*xdia(mgs,lc,1)*cx(mgs,lc)*rhoinv(mgs) + + ELSE + d1 = 0.0 + ENDIF + + IF ( rcond .eq. 2 .and. qx(mgs,lr) .gt. qxmin(lr) .and. cx(mgs,lr) > 1.e-9 ) THEN + IF ( imurain == 3 ) THEN + IF ( izwisventr == 1 ) THEN + rwvent(mgs) = ventrx(mgs)*(1.6 + 124.9*(1.e-3*rho0(mgs)*qx(mgs,lr))**.2046) + ELSE ! izwisventr = 2 +! Following Wisner et al. (1972) but using gamma of volume. Note that Ferrier rain fall speed does not integrate with gamma of volume, so using Vr = ar*d^br + rwvent(mgs) = & + & (0.78*ventrx(mgs) + 0.308*ventrxn(mgs)*fvent(mgs) & + & *Sqrt((ar*rhovt(mgs))) & + & *(xdia(mgs,lr,1)**((1.0+br)/2.0)) ) + ENDIF + + ELSE ! imurain == 1 + + IF ( iferwisventr == 1 ) THEN + alpr = Min(alpharmax,alpha(mgs,lr) ) +! alpr = alpha(mgs,lr) + x = 1. + alpr + + tmp = 1 + alpr + i = Int(dgami*(tmp)) + del = tmp - dgam*i + g1palp = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami + + tmp = 2.5 + alpr + 0.5*bx(lr) + i = Int(dgami*(tmp)) + del = tmp - dgam*i + y = (gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami)/g1palp ! ratio of gamma functions + +! vent1 = dble(xdia(mgs,lr,1))**(-2. - alpr) ! Actually OK +! vent2 = dble(1./xdia(mgs,lr,1) + 0.5*fx(lr))**dble(2.5+alpr+0.5*bx(lr)) ! Actually OK + vent1 = dble(xdia(mgs,lr,1))**(0.5 + 0.5*bx(lr)) ! 2016.2.26 Changed for consistency with derivation (recast formula) + vent2 = dble(1. + 0.5*fx(lr)*xdia(mgs,lr,1))**dble(2.5+alpr+0.5*bx(lr)) + + + rwvent(mgs) = & + & 0.78*x + & + & 0.308*fvent(mgs)*y* & + & Sqrt(ax(lr)*rhovt(mgs))*(vent1/vent2) + + ELSEIF ( iferwisventr == 2 ) THEN + +! Following Wisner et al. (1972) but using gamma of volume. Note that Ferrier rain fall speed does not integrate with gamma of volume, so using Vr = ar*d^br + x = 1. + alpha(mgs,lr) + + rwvent(mgs) = & + & (0.78*x + 0.308*ventrxn(mgs)*fvent(mgs) & + & *Sqrt((ar*rhovt(mgs))) & + & *(xdia(mgs,lr,1)**((1.0+br)/2.0)) ) + + + ENDIF ! iferwisventr + + ENDIF ! imurain + + d1r = (1./(ac1 + bc))*4.0*pi*rwvent(mgs) & + & *0.5*xdia(mgs,lr,1)*cx(mgs,lr)*rhoinv(mgs) + ELSE + d1r = 0.0 + ENDIF + + + e1 = felvcp(mgs)/(pi0(mgs)) + f1 = pk(mgs) ! (pres(mgs)/poo)**cap + +! +! fifth trial to see what happens: +! + ltemq = (temg(mgs)-163.15)/fqsat+1.5 + ltemq = Min( nqsat, Max(1,ltemq) ) + ltemq1 = ltemq + temp1 = temg(mgs) + p380 = 380.0/pres(mgs) + +! taus = Max( 0.05*dtp, Min(taus, 0.25*dtp ) ) +! nc = NInt(dtp/Min(1.0,0.5*taus)) +! dtcon = dtp/float(nc) + ss1 = qx(mgs,lv)/qvs(mgs) + ss2 = ss1 + temp2 = temp1 + qv1 = qx(mgs,lv) + qvs1 = qvs(mgs) + qis1 = qis(mgs) + dt1 = 0.0 + + +! dtcon = Max(dtcon,0.2) +! nc = Nint(dtp/dtcon) + + ltemq1 = ltemq +! want to start out with a small time step to handle the steep slope +! and fast changes, then can switch to a larger step (dtcon2) for the +! rest of the big time step. +! base the initial time step (dtcon1) on the slope (delta) + IF ( Abs(ss1 - 1.0) .gt. 1.e-5 ) THEN + delta = 0.5*(qv1-qvs1)/(d1*(ss1 - 1.0)) + ELSE + delta = 0.1*dtp + ENDIF +! delta is the extrapolated time to get halfway from qv1 to qvs1 +! want at least 5 time steps to the halfway point, so multiply by 0.2 +! for the initial time step + dtcon1 = Min(0.05,0.2*delta) + nc = Max(5,2*NInt( (dtp-4.0*dtcon1)/delta)) + dtcon2 = (dtp-4.0*dtcon1)/nc + + n = 1 + dt1 = 0.0 + nc = 0 + dqc = 0.0 + dqr = 0.0 + dqi = 0.0 + dqs = 0.0 + dqvii = 0.0 + dqvis = 0.0 + + RK2c: DO WHILE ( dt1 .lt. dtp ) + nc = 0 + IF ( n .le. 4 ) THEN + dtcon = dtcon1 + ELSE + dtcon = dtcon2 + ENDIF + 609 dqv = -(ss1 - 1.)*d1*dtcon + dqvr = -(ss1 - 1.)*d1r*dtcon + dtemp = -0.5*e1*f1*(dqv + dqvr) +! write(0,*) 'RK2c dqv1 = ',dqv +! calculate midpoint values: + ! ltemq1m = ltemq1 + Nint(dtemp*fqsat + 0.5) + + ! 7.6.2016: Test full calc of ltemq + ltemq1m = (temp1+dtemp-163.15)*fqsati+1.5 + ltemq1m = Min( nqsat, Max(1,ltemq1m) ) + + IF ( ltemq1m .lt. 1 .or. ltemq1m .gt. nqsat ) THEN + write(0,*) 'STOP in nucond line 1192 ' + write(0,*) ' ltemq1m,icond = ',ltemq1m,icond + write(0,*) ' dtemp,e1,f1,dqv,dqvr = ', dtemp,e1,f1,dqv,dqvr + write(0,*) ' d1,d1r,dtcon,ss1 = ',d1,d1r,dtcon,ss1 + write(0,*) ' dqc, dqr = ',dqc,dqr + write(0,*) ' qv,qc,qr = ',qx(mgs,lv)*1000.,qx(mgs,lc)*1000.,qx(mgs,lr)*1000. + write(0,*) ' i, j, k = ',igs(mgs),jy,kgs(mgs) + write(0,*) ' dtcon1,dtcon2,delta = ',dtcon1,dtcon2,delta + write(0,*) ' nc,dtp = ',nc,dtp + write(0,*) ' rwvent,xdia,crw,ccw = ', rwvent(mgs),xdia(mgs,lr,1),cx(mgs,lr),cx(mgs,lc) + write(0,*) ' fvent,alphar = ',fvent(mgs),alpha(mgs,lr) + write(0,*) ' xvr,xmasr,xdnr,cwc1 = ',xv(mgs,lr),xmas(mgs,lr),xdn(mgs,lr),cwc1 + ENDIF + dqvs = dtemp*p380*dtabqvs(ltemq1m) + qv1m = qv1 + dqv + dqvr +! qv1mr = qv1r + dqvr + + qvs1m = qvs1 + dqvs + ss1m = qv1m/qvs1m + + ! check for undersaturation when no ice is present, if so, then reduce time step + IF ( ss1m .lt. 1. .and. (dqvii + dqvis) .eq. 0.0 ) THEN + dtcon = (0.5*dtcon) + IF ( dtcon .ge. dtcon1 ) THEN + GOTO 609 + ELSE + EXIT + ENDIF + ENDIF +! calculate full step: + dqv = -(ss1m - 1.)*d1*dtcon + dqvr = -(ss1m - 1.)*d1r*dtcon + + +! write(0,*) 'RK2a dqv1m = ',dqv + dtemp = -e1*f1*(dqv + dqvr) + + ! ltemq1 = ltemq1 + Nint(dtemp*fqsat + 0.5) + + ! 7.6.2016: Test full calc of ltemq + ltemq1 = (temp1+dtemp-163.15)*fqsati+1.5 + ltemq1 = Min( nqsat, Max(1,ltemq1) ) + + IF ( ltemq1 .lt. 1 .or. ltemq1 .gt. nqsat ) THEN + write(0,*) 'STOP in nucond line 1230 ' + write(0,*) ' ltemq1m,icond = ',ltemq1m,icond + write(0,*) ' dtemp,e1,dqv,dqvr = ', dtemp,e1,dqv,dqvr + ENDIF + dqvs = dtemp*p380*dtabqvs(ltemq1) + + qv1 = qv1 + dqv + dqvr + + dqc = dqc - dqv + dqr = dqr - dqvr + + qvs1 = qvs1 + dqvs + ss1 = qv1/qvs1 + temp1 = temp1 + dtemp + IF ( temp2 .eq. temp1 .or. ss2 .eq. ss1 .or. & + & ss1 .eq. 1.00 .or. & + & ( n .gt. 10 .and. ss1 .lt. 1.0005 ) ) THEN +! write(0,*) 'RK2c break' + EXIT + ELSE + ss2 = ss1 + temp2 = temp1 + dt1 = dt1 + dtcon + n = n + 1 + ENDIF + ENDDO RK2c + + + dcloud = dqc ! qx(mgs,lv) - qv1 + thetap(mgs) = thetap(mgs) + e1*(DCLOUD + dqr) + + + IF ( eqtset > 2 ) THEN + pipert(mgs) = pipert(mgs) + felvpi(mgs)*(DCLOUD + dqr) + ENDIF + IF ( io_flag .and. nxtra > 1 ) THEN + axtra(igs(mgs),jy,kgs(mgs),1) = DCLOUD/dtp + axtra(igs(mgs),jy,kgs(mgs),2) = axtra(igs(mgs),jy,kgs(mgs),2) + dqr/dtp + ENDIF + qwvp(mgs) = qwvp(mgs) - (DCLOUD + dqr) + qx(mgs,lc) = qx(mgs,lc) + DCLOUD + qx(mgs,lr) = qx(mgs,lr) + dqr +! t9(igs(mgs),jy,kgs(mgs)) = t9(igs(mgs),jy,kgs(mgs)) + (DCLOUD + dqr)/dtp*felv(mgs)/(cp*pi0(mgs)) !* & +!! & dx*dy*dz3d(igs(mgs),jy,kgs(mgs)) + + + theta(mgs) = thetap(mgs) + theta0(mgs) + temg(mgs) = theta(mgs)*f1 + ltemq = (temg(mgs)-163.15)/fqsat+1.5 + ltemq = Min( nqsat, Max(1,ltemq) ) + qvs(mgs) = pqs(mgs)*tabqvs(ltemq) +! es(mgs) = 6.1078e2*tabqvs(ltemq) + +! + + ENDIF ! dcloud .gt. 0. + + + ELSE ! qc .le. qxmin(lc) + +! IF ( ssf(mgs) .gt. 0.0 .and. .not. flag_qndrop ) THEN ! flag_qndrop turns off primary nucleation when using wrf-chem with progn=1 + IF ( ssf(mgs) .gt. 0.0 ) THEN ! .and. ssmax(mgs) .lt. sscb ) THEN ! except that wrf-chem does not seem to initialize qc for activated aerosols, so keep this, after all + + IF ( iqcinit == 1 ) THEN + + qvs0 = 380.*exp(17.27*(temg(mgs)-273.)/(temg(mgs)- 36.))/pk(mgs) + + dcloud = Max(0.0, (qx(mgs,lv)-qvs0) / (1.+qvs0*f5/(temg(mgs)-36.)**2) ) + + ELSEIF ( iqcinit == 3 ) THEN + R1=1./(1. + caw*(273.15 - cbw)*qss(mgs)*felvcp(mgs)/ & + & ((temg(mgs) - cbw)**2)) + DCLOUD=R1*(qvap(mgs) - qvs(mgs)) ! KW model adjustment; + ! this will put mass into qc if qv > sqsat exists + + ELSEIF ( iqcinit == 2 ) THEN +! R1=1./(1. + caw*(273.15 - cbw)*qss(mgs)*felv(mgs)/ +! : (cp*(temg(mgs) - cbw)**2)) +! DCLOUD=R1*(qvap(mgs) - qvs(mgs)) ! KW model adjustment; + ! this will put mass into qc if qv > sqsat exists + ssmx = ssmxinit + +! IF ( ssf(mgs) > ssmx .and. ssmax(mgs) < 3.0 ) THEN +! IF ( ssf(mgs) > ssmx .and. ccnc(mgs) > 1.0 ) THEN +! IF ( ssf(mgs) > ssmx .and. ssf(mgs) < 5.0 .and. ccnc(mgs) > 0.1*cwnccn(mgs) ) THEN ! this one works +! IF ( ssf(mgs) > ssmx .and. ssf(mgs) < 20.0 ) THEN ! test -- fails +! IF ( ssf(mgs) > ssmx .and. ssf(mgs) < 20.0 .and. ccnc(mgs) > 0.1*cwnccn(mgs)) THEN ! test -- is OK + IF ( ssf(mgs) > ssmx .and. ssf(mgs) < 20.0 .and. ccnc(mgs) > 0.05*cwnccn(mgs)) THEN ! test +! IF ( ssf(mgs) > ssmx ) THEN ! original condition + CALL QVEXCESS(ngs,mgs,qwvp,qv0,qx(1,lc),pres,thetap,theta0,dcloud, & + & pi0,tabqvs,nqsat,fqsat,cbw,fcqv1,felvcp,ssmx,pk,ngscnt) + ELSE + dcloud = 0.0 + ENDIF + ENDIF + ELSE + dcloud = 0.0 + ENDIF + + thetap(mgs) = thetap(mgs) + felvcp(mgs)*DCLOUD/(pi0(mgs)) + qwvp(mgs) = qwvp(mgs) - DCLOUD + qx(mgs,lc) = qx(mgs,lc) + DCLOUD + IF ( io_flag .and. nxtra > 1 ) THEN + axtra(igs(mgs),jy,kgs(mgs),1) = DCLOUD/dtp + ENDIF + theta(mgs) = thetap(mgs) + theta0(mgs) + temg(mgs) = theta(mgs)*pk(mgs) !( pres(mgs) / poo ) ** cap +! temg(mgs) = theta2temp( theta(mgs), pres(mgs) ) + ltemq = (temg(mgs)-163.15)/fqsat+1.5 + ltemq = Min( nqsat, Max(1,ltemq) ) + qvs(mgs) = pqs(mgs)*tabqvs(ltemq) +! es(mgs) = 6.1078e2*tabqvs(ltemq) + +!.... S. TWOMEY (1959) +! Note: get here if there is no previous cloud water and w > 0. + cn(mgs) = 0.0 + + IF ( ncdebug .ge. 1 ) THEN + write(iunit,*) 'at 613: ',qx(mgs,lc),cx(mgs,lc),wvel(mgs),ssmax(mgs),kgs(mgs) + ENDIF + + IF ( .not. flag_qndrop ) THEN ! { do not calculate number of droplets if using wrf-chem + + +! IF ( ssmax(mgs) .lt. sscb .and. qx(mgs,lc) .gt. qxmin(lc)) THEN + IF ( dcloud .gt. qxmin(lc) .and. wvel(mgs) > 0.0) THEN +! CN(mgs) = CCNE*wvel(mgs)**cnexp ! *Min(1.0,1./dtp) ! 0.3465 + CN(mgs) = CCNE0*cnuc(mgs)**(2./(2.+cck))*wvel(mgs)**cnexp ! *Min(1.0,1./dtp) ! 0.3465 + IF ( ny .le. 2 .and. cn(mgs) .gt. 0.0 & + & .and. ncdebug .ge. 1 ) THEN + write(iunit,*) 'CN: ',cn(mgs)*1.e-6, cx(mgs,lc)*1.e-6, qx(mgs,lc)*1.e3, & + & wvel(mgs), dcloud*1.e3 + IF ( cn(mgs) .gt. 1.0 ) write(iunit,*) 'cwrad = ', & + & 1.e6*(rho0(mgs)*qx(mgs,lc)/cn(mgs)*cwc1)**c1f3, & + & igs(mgs),kgs(mgs),temcg(mgs), & + & 1.e3*an(igs(mgs),jgs,kgs(mgs)-1,lc) + ENDIF + IF ( iccwflg .eq. 1 ) THEN + cn(mgs) = Min(cwccn*rho0(mgs)/rho00, Max(cn(mgs), & + & rho0(mgs)*qx(mgs,lc)/(xdn(mgs,lc)*(4.*pi/3.)*(4.e-6)**3))) + ENDIF + ELSE + cn(mgs) = 0.0 + dcloud = 0.0 +! cn(mgs) = Min(cwccn, & +! & rho0(mgs)*dcloud/(xdn(mgs,lc)*(4.*pi/3.)*(4.e-6)**3) ) + ENDIF + + IF ( cn(mgs) .gt. 0.0 ) THEN + IF ( cn(mgs) .gt. ccnc(mgs) ) THEN + cn(mgs) = ccnc(mgs) +! ccnc(mgs) = 0.0 + ENDIF +! cx(mgs,lc) = cx(mgs,lc) + cn(mgs) + IF ( irenuc <= 2 ) ccnc(mgs) = Max(0.0, ccnc(mgs) - cn(mgs)) + ccna(mgs) = ccna(mgs) + cn(mgs) + ENDIF + +! write(91,*) 'nuc1: cn, ix, kz = ',cn(mgs),igs(mgs),kgs(mgs),wvel(mgs),cnexp,ccnc(mgs) + + IF( CN(mgs) .GT. cx(mgs,lc) ) cx(mgs,lc) = CN(mgs) + IF( cx(mgs,lc) .GT. 0. .AND. qx(mgs,lc) .le. qxmin(lc) ) THEN + cx(mgs,lc) = 0. + ELSE + cx(mgs,lc) = Min(cx(mgs,lc),rho0(mgs)*Max(0.0,qx(mgs,lc))/cwmasn) + ENDIF + + ENDIF ! }.not. flag_qndrop + + GOTO 613 + + END IF ! qc .gt. 0. + +! ES=EES(PIB(K)*PT) +! SQSAT=EPSI*ES/(PB(K)*1000.-ES) + +!.... CLOUD NUCLEATION +! T=PIB(K)*PT +! ES=1.E3*PB(K)*QV/EPSI + + IF ( wvel(mgs) .le. 0. ) GO TO 616 + IF ( cx(mgs,lc) .le. 0. ) GO TO 613 !TWOMEY (1959) Nucleation + IF ( kzbeg-1+kgs(mgs) .GT. 1 .and. qx(mgs,lc) .le. qxmin(lc)) GO TO 613 !TWOMEY (1959) Nucleation + IF ( kzbeg-1+kgs(mgs) .eq. 1 .and. wvel(mgs) .gt. 0. ) GO TO 613 !TWOMEY (1959) Nucleation +!.... ATTEMPT ZIEGLER CLOUD NUCLEATION IN CLOUD INTERIOR UNLESS... + 616 IF ( ssf(mgs) .LE. SUPCB .AND. wvel(mgs) .GT. 0. ) GO TO 631 !... weakly saturated updraft + IF ( kzbeg-1+kgs(mgs) .GT. 1 .AND. kzbeg-1+kgs(mgs) .LT. nzend-1 .AND. & + & (ssfkp1(mgs) .GE. SUPMX .OR. & + & ssf(mgs) .GE. SUPMX .OR. & + & ssfkm1(mgs) .GE. SUPMX)) GO TO 631 !... too much vapour + IF (ssf(mgs) .LT. 1.E-10 .OR. ssf(mgs) .GE. SUPMX) GO TO 631 !... at the extremes for ss + +! +! get here if ( qc > 0 and ss > supcb) or (w < 0) +! + + if (ndebug .gt. 0) write(0,*) "ICEZVD_DR: Entered Ziegler Cloud Nucleation" !mpidebug + + DSSDZ=0. + r2dzm=0.50/dz3d(igs(mgs),jy,kgs(mgs)) + IF ( irenuc >= 0 .and. .not. flag_qndrop) THEN ! turn off nucleation when flag_qndrop (using WRF-CHEM for activation) + + IF ( irenuc < 2 ) THEN !{ + + IF ( kzend == nzend ) THEN + t0p3 = t0(igs(mgs),jgs,Min(kze,kgs(mgs)+3)) + t0p1 = t0(igs(mgs),jgs,Min(kze,kgs(mgs)+1)) + ELSE + t0p3 = t0(igs(mgs),jgs,kgs(mgs)+3) + t0p1 = t0(igs(mgs),jgs,kgs(mgs)+1) + ENDIF + + IF ( ( ssf(mgs) .gt. ssmax(mgs) .or. irenuc .eq. 1 ) & + & .and. ( ( lccn .lt. 1 .and. & + & cx(mgs,lc) .lt. cwccn*(Min(1.0,rho0(mgs)))) .or. & + & ( lccn .gt. 1 .and. ccnc(mgs) .gt. 0. ) ) & + & ) THEN + IF( kzbeg-1+kgs(mgs) .GT. 1 .AND. kzbeg-1+kgs(mgs) .LT. nzend-1 & + & .and. ssf(mgs) .gt. 0.0 & + & .and. ssfkp1(mgs) .LT. SUPMX .and. ssfkp1(mgs) .ge. 0.0 & + & .AND. ssfkm1(mgs) .LT. SUPMX .AND. ssfkm1(mgs) .ge. 0.0 & + & .AND. ssfkp1(mgs) .gt. ssfkm1(mgs) & + & .and. t0p3 .gt. 233.2) THEN + DSSDZ = (ssfkp1(mgs) - ssfkm1(mgs))*R2DZM +! +! otherwise check for cloud base condition with updraft: +! + ELSEIF( kzbeg-1+kgs(mgs) .GT. 1 .AND. kzbeg-1+kgs(mgs) .LT. nzend-1 & +! IF( kgs(mgs) .GT. 1 .AND. kgs(mgs) .LT. NZ-1 & !) + & .and. ssf(mgs) .gt. 0.0 .and. wvel(mgs) .gt. 0.0 & + & .and. ssfkp1(mgs) .gt. 0.0 & + & .AND. ssfkm1(mgs) .le. 0.0 .and. wvelkm1(mgs) .gt. 0.0 & + & .AND. ssf(mgs) .gt. ssfkm1(mgs) & + & .and. t0p1 .gt. 233.2) THEN + DSSDZ = 2.*(ssf(mgs) - ssfkm1(mgs))*R2DZM ! 1-sided difference + ENDIF + + ENDIF +! +!CLZ IF(wijk.LE.0.) CN=CCN*ssfilt(ix,jy,kz)**CCK +! note: CCN -> cwccn, DELT -> dtp + c1 = Max(0.0, rho0(mgs)*(qx(mgs,lv) - qss(mgs))/ & + & (xdn(mgs,lc)*(4.*pi/3.)*(4.e-6)**3)) + IF ( lccn .lt. 1 ) THEN + CN(mgs) = cwccn*rho0(mgs)/rho00*CCK*ssf(mgs)**CCKM*dtp* & + & Max(0.0, & + & (wvel(mgs)*DSSDZ) ) ! probably the vertical gradient dominates + ELSE + CN(mgs) = & + & Min(ccnc(mgs), cnuc(mgs)*CCK*ssf(mgs)**CCKM*dtp* & + & Max(0.0, & + & ( wvel(mgs)*DSSDZ) ) ) +! IF ( cn(mgs) .gt. 0 ) ccnc(mgs) = ccnc(mgs) - cn(mgs) + ENDIF + + IF ( cn(mgs) .gt. 0.0 ) THEN + IF ( ccnc(mgs) .lt. 5.e7 .and. cn(mgs) .ge. 5.e7 ) THEN + cn(mgs) = 5.e7 + ccnc(mgs) = 0.0 + ELSEIF ( cn(mgs) .gt. ccnc(mgs) ) THEN + cn(mgs) = ccnc(mgs) + ccnc(mgs) = 0.0 + ENDIF + cx(mgs,lc) = cx(mgs,lc) + cn(mgs) + ccnc(mgs) = Max(0.0, ccnc(mgs) - cn(mgs)) + ENDIF + + ELSEIF ( irenuc == 2 ) THEN !} { + ! simple Twomey scheme +! if (ndebug .gt. 0) write(0,*) 'ICEZVD_DR: Cloud reNucleation, wvel = ',wvel(mgs) + CN(mgs) = CCNE0*cnuc(mgs)**(2./(2.+cck))*Max(0.0,wvel(mgs))**cnexp ! *Min(1.0,1./dtp) ! 0.3465 +! ccne = ccnefac*1.e6*(1.e-6*Abs(cwccn))**(2./(2.+cck)) +!!! CN(mgs) = Max( 0.0, CN(mgs) - ccna(mgs) ) ! this was from + ! Philips, Donner et al. 2007, but results in too much limitation of + ! nucleation + CN(mgs) = Min(cn(mgs), ccnc(mgs)) + cn(mgs) = Min(cn(mgs), 0.5*dqc/cwmasn) ! limit the nucleation mass to half of the condensation mass + + IF ( .false. .and. ny <= 2 ) THEN + write(0,*) 'i,k, cwmasn = ',igs(mgs),kgs(mgs),cwmasn + write(0,*) 'wvel, cnuc, cn = ',wvel(mgs),cnuc(mgs),cn(mgs) + write(0,*) 'ccne0,cnexp,cck = ',ccne0,cnexp,cck + write(0,*) 'part1, part2 = ',CCNE0*cnuc(mgs)**(2./(2.+cck)), Max(0.0,wvel(mgs))**cnexp + write(0,*) 'ccnc, dqc, dqc/cwmasn = ',ccnc(mgs), dqc, 0.5*dqc/cwmasn + ENDIF + + IF ( icnuclimit > 0 ) THEN + tmp = ccnc(mgs) + cx(mgs,lc) + IF ( tmp < 330.34e6 ) THEN + ccwmax = 1.1173e6 * (1.e-6*tmp)**0.9504 + ELSE + ccwmax = 21.57e6 * (1.e-6*tmp)**0.44 + ENDIF + +! IF ( cn(mgs) > 0. ) THEN +! write(0,*) 'cn,tmp,ccwmax,cx,c-cx = ',cn(mgs),tmp,ccwmax,cx(mgs,lc),ccwmax - cx(mgs,lc) +! ENDIF + + cn(mgs) = Max( 0.0, Min( cn(mgs), ccwmax - cx(mgs,lc) ) ) + + ENDIF + + cx(mgs,lc) = cx(mgs,lc) + cn(mgs) + + ccnc(mgs) = Max(0.0, ccnc(mgs) - cn(mgs)) + + ELSEIF ( irenuc == 5 ) THEN !} { + + ! modification of Phillips Donner Garner 2007 +! if (ndebug .gt. 0) write(0,*) 'ICEZVD_DR: Cloud reNucleation, wvel = ',wvel(mgs) +! CN(mgs) = Min( 0.91*cnuc(mgs), CCNE0*cnuc(mgs)**(2./(2.+cck))*Max(0.0,wvel(mgs))**cnexp )! *Min(1.0,1./dtp) ! 0.3465 + CN(mgs) = Min( cnuc(mgs), CCNE0*cnuc(mgs)**(2./(2.+cck))*Max(0.0,wvel(mgs))**cnexp ) + + + IF ( ccna(mgs) >= cnuc(mgs) ) THEN ! apply limit after all "base" CCN have been depleted + temp1 = (theta0(mgs)+thetap(mgs))*pk(mgs) ! t77(ix,jy,kz) + ltemq = Int( (temp1-163.15)/fqsat+1.5 ) + ltemq = Min( nqsat, Max(1,ltemq) ) + + c1= pqs(mgs)*tabqvs(ltemq) + IF ( c1 > 0. ) THEN + ssf(mgs) = Max(0.0, 100.*((qv0(mgs) + qwvp(mgs))/c1 - 1.0) ) ! from "new" values + ELSE + ssf(mgs) = 0.0 + ENDIF + + + CN(mgs) = Max( cn(mgs), cnuc(mgs)*Min(ssf2kmax, ssf(mgs)**cck) ) ! this allows cn(mgs) > cnuc(mgs) + + ! cn(mgs) = Min( cn(mgs), cnuc(mgs) ) + +! IF ( ccna(mgs) >= cnuc(mgs) ) THEN ! apply limit after all "base" CCN have been depleted + CN(mgs) = Max( 0.0, CN(mgs) - ccna(mgs) ) ! this was from + + ELSE + CN(mgs) = Min( cn(mgs), cnuc(mgs) - ccna(mgs) ) ! no more than remaining "base" CCN + ENDIF + ! Philips, Donner et al. 2007, but results in too much limitation of + ! nucleation +! CN(mgs) = Min(cn(mgs), ccnc(mgs)) +! cn(mgs) = Min(cn(mgs), 0.5*dqc/cwmasn) ! limit the nucleation mass to half of the condensation mass + dcrit = 2.0*2.0e-6 + dcloud = 1000.*dcrit**3*Pi/6. + ! cn(mgs) = Min(cn(mgs), 0.5*dqc/dcloud) ! limit the nucleation mass to half of the condensation mass + ! check new droplet size: + ! tmp is number of droplets at diameter dcrit + tmp = Max(0.0, rho0(mgs)*qx(mgs,lc)/dcloud - cx(mgs,lc)) ! (cx(mgs,lc) + cn(mgs)) + cn(mgs) = Min(tmp, cn(mgs) ) + + + IF ( cn(mgs) > 0.0 ) THEN + cx(mgs,lc) = cx(mgs,lc) + cn(mgs) + + dcrit = 2.5e-7 + + dcloud = 1000.*dcrit**3*Pi/6.*cn(mgs) + qx(mgs,lc) = qx(mgs,lc) + DCLOUD + thetap(mgs) = thetap(mgs) + felvcp(mgs)*DCLOUD/(pi0(mgs)) + qwvp(mgs) = qwvp(mgs) - DCLOUD + ENDIF + ! 6/13/2016: Phillips et al. appears not to decrement CCN, but only increments CCNa. + ! This would allow an initially non-homogeneous (vertically, e.g.) initial value of CCN/rho_air + ! ccnc(mgs) = Max(0.0, ccnc(mgs) - cn(mgs)) + ELSEIF ( irenuc == 7 ) THEN !} { + + ! simple Twomey scheme but limit activation to try to do most activation near cloud base, but keep some CCN available for renuclation +! if (ndebug .gt. 0) write(0,*) 'ICEZVD_DR: Cloud reNucleation, wvel = ',wvel(mgs) + cn(mgs) = 0.0 +! IF ( ccna(mgs) < 0.7*cnuc(mgs) .and. ccnc(mgs) > 0.69*cnuc(mgs) - ccna(mgs)) THEN ! here, assume we are near cloud base and use Twomey formulation + IF ( ccna(mgs) < 0.9*cnuc(mgs) ) THEN ! { here, assume we are near cloud base and use Twomey formulation + CN(mgs) = Min( 0.91*cnuc(mgs), CCNE0*cnuc(mgs)**(2./(2.+cck))*Max(0.0,wvel(mgs))**cnexp )! *Min(1.0,1./dtp) ! 0.3465 +! IF ( cn(mgs) + ccna(mgs) > 0.71*cnuc ) THEN + ! prevent this branch from activating more than 70% of CCN + CN(mgs) = Min( CN(mgs), Max(0.0, (0.9*cnuc(mgs) - ccna(mgs) )) ) +! CN(mgs) = Min( CN(mgs), Max(0.0, 0.71*ccnc(mgs) - ccna(mgs) ) ) + ! write(0,*) '1: k,cn = ',kgs(mgs),cn(mgs),ssf(mgs) +!! IF ( ccncuf(mgs) > 0.0 .and. cn(mgs) < 1.e-3 .and. ssmax(mgs) > 1.0 ) THEN +! IF ( ccncuf(mgs) > 0.0 .and. ssf(mgs) > ssmxuf .and. ssmax(mgs) > ssmxuf ) THEN +! CNuf(mgs) = Min( ccncuf(mgs), CCNE0*ccncuf(mgs)**(2./(2.+cck))*Max(0.0,wvel(mgs))**cnexp )! *Min(1.0,1./dtp) ! 0.3465 + ! IF ( cnuf(mgs) >= 0.0 ) write(0,*) '1: cnuf, k = ',cnuf(mgs),ccncuf(mgs),kgs(mgs) +! ENDIF + + + ELSE ! }{ + ! if a large fraction of CCN have been activated, then assume we are in the cloud interior and use local SSw as in Phillips et al. 2007. + + temp1 = (theta0(mgs)+thetap(mgs))*pk(mgs) ! t77(ix,jy,kz) +! t0(ix,jy,kz) = temp1 + ltemq = Int( (temp1-163.15)/fqsat+1.5 ) + ltemq = Min( nqsat, Max(1,ltemq) ) + + ! c1 = t00(igs(mgs),jy,kgs(mgs))*tabqvs(ltemq) + c1= pqs(mgs)*tabqvs(ltemq) + + ssf(mgs) = 0.0 + IF ( c1 > 0. ) THEN + ssf(mgs) = 100.*(qx(mgs,lv)/c1 - 1.0) ! from "new" values + ENDIF + +! IF ( ssf(mgs) <= 1.0 .or. cnuc(mgs) > ccna(mgs) ) THEN + IF ( ssf(mgs) <= 1.0 ) THEN + CN(mgs) = cnuc(mgs)*Min(1.0, Max(0.0,ssf(mgs))**cck ) ! + ELSE + CN(mgs) = cnuc(mgs)*Min(2.0, Max(0.0,0.03*(ssf(mgs)-1.0)+1.)**cck ) ! +! write(0,*) 'iren7: ssf,ssmx = ',ssf(mgs),ssmax(mgs),cn(mgs),ccna(mgs),cnuc(mgs) +! write(0,*) 'c1,qv = ',c1,qx(mgs,lv),temp1,ltemq + ENDIF + + ! write(0,*) 'k,cn = ',kgs(mgs),cn(mgs),ssf(mgs) + ! write(0,*) 'ccn-ccna = ',cnuc(mgs) - ccna(mgs),ccnc(mgs) - ccna(mgs) +! IF ( ccncuf(mgs) > 0.0 .and. cn(mgs) < 1.e-3 .and. ssmax(mgs) > 1.0 ) THEN + IF ( ccncuf(mgs) > 0.0 .and. ssf(mgs) > ssmxuf .and. ssmax(mgs) > ssmxuf ) THEN + CNuf(mgs) = Min( ccncuf(mgs), CCNE0*ccncuf(mgs)**(2./(2.+cck))*Max(0.0,wvel(mgs))**cnexp )! *Min(1.0,1./dtp) ! 0.3465 + ! IF ( cnuf(mgs) >= 0.0 ) write(0,*) 'cnuf, k = ',cnuf(mgs),ccncuf(mgs),kgs(mgs) + ENDIF + + +! CN(mgs) = Min( Min(0.1,ssf(mgs)-1.)*cnuc(mgs), Max( 0.0, CN(mgs) - ccna(mgs) ) ) ! this was from +! CN(mgs) = Min( Min(0.5*cx(mgs,lc), Min(0.1,ssf(mgs)/100.)*cnuc(mgs)), Max( 0.0, CN(mgs) - ccna(mgs) ) ) ! this was from + + CN(mgs) = Min(0.01*cnuc(mgs), Max( 0.0, CN(mgs) - ccna(mgs) ) ) ! this was from + + ENDIF ! } +! ccne = ccnefac*1.e6*(1.e-6*Abs(cwccn))**(2./(2.+cck)) +!!! CN(mgs) = Max( 0.0, CN(mgs) - ccna(mgs) ) ! this was from + ! Philips, Donner et al. 2007, but results in too much limitation of + ! nucleation +! CN(mgs) = Min(cn(mgs), ccnc(mgs)) +! cn(mgs) = Min(cn(mgs), 0.5*dqc/cwmasn) ! limit the nucleation mass to half of the condensation mass + + + IF ( icnuclimit > 0 ) THEN +! max droplet conc. based on Chandrakar et al. (2016) and Konwar et al. (2012) + tmp = ccnc(mgs) - ccna(mgs) + cx(mgs,lc) + IF ( tmp < 330.34e6 ) THEN + ccwmax = 1.1173e6 * (1.e-6*tmp)**0.9504 + ELSE + ccwmax = 21.57e6 * (1.e-6*tmp)**0.44 + ENDIF + + cn(mgs) = Max( 0.0, Min( cn(mgs), ccwmax - cx(mgs,lc) ) ) + + ENDIF + + IF ( cn(mgs) + cnuf(mgs) > 0.0 ) THEN + + dcrit = 2.0*2.0e-6 + dcloud = 1000.*dcrit**3*Pi/6. + ! cn(mgs) = Min(cn(mgs), 0.5*dqc/dcloud) ! limit the nucleation mass to half of the condensation mass + ! check new droplet size: + ! tmp is number of droplets at diameter dcrit + tmp = Max(0.0, rho0(mgs)*qx(mgs,lc)/dcloud - cx(mgs,lc)) ! (cx(mgs,lc) + cn(mgs)) + cn(mgs) = Min(tmp, cn(mgs) ) + + cx(mgs,lc) = cx(mgs,lc) + cn(mgs) + cnuf(mgs) + + + ! create some small droplets at minimum size (CP 2000), although it adds very little liquid + + + dcrit = 2.0*2.5e-7 + dcloud = 1000.*dcrit**3*Pi/6.*(cn(mgs) + cnuf(mgs) ) + qx(mgs,lc) = qx(mgs,lc) + DCLOUD + thetap(mgs) = thetap(mgs) + felvcp(mgs)*DCLOUD/(pi0(mgs)) + qwvp(mgs) = qwvp(mgs) - DCLOUD + ! ccnc(mgs) = Max(0.0, ccnc(mgs) - cn(mgs)) + ccncuf(mgs) = Max(0.0, ccncuf(mgs) - cnuf(mgs)) + ENDIF + + ELSEIF ( irenuc == 8 ) THEN !} { + ! simple Twomey scheme +! if (ndebug .gt. 0) write(0,*) 'ICEZVD_DR: Cloud reNucleation, wvel = ',wvel(mgs) + + cn(mgs) = 0.0 + + IF ( ccnc(mgs) > 0. ) THEN + CN(mgs) = CCNE0*ccnc(mgs)**(2./(2.+cck))*Max(0.0,wvel(mgs))**cnexp ! *Min(1.0,1./dtp) ! 0.3465 +! ccne = ccnefac*1.e6*(1.e-6*Abs(cwccn))**(2./(2.+cck)) +!!! CN(mgs) = Max( 0.0, CN(mgs) - ccna(mgs) ) ! this was from + ! Philips, Donner et al. 2007, but results in too much limitation of + ! nucleation + CN(mgs) = Min(cn(mgs), ccnc(mgs)) + + ELSEIF ( cx(mgs,lc) < 0.01e9 ) THEN + + ! if a large fraction of CCN have been activated, then assume we are in the cloud interior and use local SSw as in Phillips et al. 2007. + + temp1 = (theta0(mgs)+thetap(mgs))*pk(mgs) ! t77(ix,jy,kz) +! t0(ix,jy,kz) = temp1 + ltemq = Int( (temp1-163.15)/fqsat+1.5 ) + ltemq = Min( nqsat, Max(1,ltemq) ) + + ! c1 = t00(igs(mgs),jy,kgs(mgs))*tabqvs(ltemq) + c1= pqs(mgs)*tabqvs(ltemq) + + ssf(mgs) = 0.0 + IF ( c1 > 0. ) THEN + ssf(mgs) = 100.*(qx(mgs,lv)/c1 - 1.0) ! from "new" values + ENDIF + +! IF ( ssf(mgs) <= 1.0 .or. cnuc(mgs) > ccna(mgs) ) THEN + IF ( ssf(mgs) <= 1.0 ) THEN + CN(mgs) = 0.0 + ELSE +! CN(mgs) = 0.01e9*rho0(mgs)/rho00*Min(2.0, Max(0.0,0.03*(ssf(mgs)-1.0)+1.)**cck ) - cx(mgs,lc) ! + CN(mgs) = 0.01e9*Min(2.0, Max(0.0,0.03*(ssf(mgs)-1.0)+1.)**cck ) - cx(mgs,lc) ! + ENDIF + + ENDIF + + IF ( cn(mgs) > 0.0 ) THEN + cx(mgs,lc) = cx(mgs,lc) + cn(mgs) + + ccnc(mgs) = Max(0.0, ccnc(mgs) - cn(mgs)) + + ! create some small droplets at minimum size (CP 2000), although it adds very little liquid + + dcrit = 2.0*2.5e-7 + + dcloud = 1000.*dcrit**3*Pi/6.*cn(mgs) + qx(mgs,lc) = qx(mgs,lc) + DCLOUD + thetap(mgs) = thetap(mgs) + felvcp(mgs)*DCLOUD/(pi0(mgs)) + qwvp(mgs) = qwvp(mgs) - DCLOUD + ! ccnc(mgs) = Max(0.0, ccnc(mgs) - cn(mgs)) + ENDIF + + + + ENDIF ! } + + ccna(mgs) = ccna(mgs) + cn(mgs) + + + + ENDIF ! irenuc >= 0 .and. .not. flag_qndrop + + IF( cx(mgs,lc) .GT. 0. .AND. qx(mgs,lc) .LE. qxmin(lc)) cx(mgs,lc)=0. + GO TO 631 +!.... NUCLEATION ON CLOUD INFLOW BOUNDARY POINT + + 613 CONTINUE + + 631 CONTINUE + +! +! Check for supersaturation greater than ssmx and adjust down +! + ssmx = maxsupersat + qv1 = qv0(mgs) + qwvp(mgs) + qvs1 = qvs(mgs) + +! IF ( flag_qndrop .and. do_satadj_for_wrfchem ) ssmx = 1.04 ! set lower threshold for progn=1 when using WRF-CHEM + + IF ( qv1 .gt. (ssmx*qvs1) ) THEN +! use line below to disable saturation adjustment when flag_qndrop is true +! IF ( qv1 .gt. (ssmx*qvs1) .and. .not. flag_qndrop ) THEN + + ss1 = qv1/qvs1 + + ssmx = 100.*(ssmx - 1.0) + + qvex = 0.0 + + CALL QVEXCESS(ngs,mgs,qwvp,qv0,qx(1,lc),pres,thetap,theta0,qvex, & + & pi0,tabqvs,nqsat,fqsat,cbw,fcqv1,felvcp,ssmx,pk,ngscnt) + + + + IF ( qvex .gt. 0.0 ) THEN + thetap(mgs) = thetap(mgs) + felvcp(mgs)*qvex/(pi0(mgs)) + IF ( io_flag .and. nxtra > 1 ) THEN + axtra(igs(mgs),jy,kgs(mgs),1) = axtra(igs(mgs),jy,kgs(mgs),1) + qvex/dtp + ENDIF + qwvp(mgs) = qwvp(mgs) - qvex + qx(mgs,lc) = qx(mgs,lc) + qvex + IF ( .not. flag_qndrop) THEN + IF ( imaxsupopt == 1 ) THEN + cn(mgs) = Min( Max(ccnc(mgs),cwnccn(mgs)), rho0(mgs)*qvex/Max( cwmasn5, xmas(mgs,lc) ) ) + ELSEIF ( imaxsupopt == 2 ) THEN + cn(mgs) = Min( Max(ccnc(mgs),cwnccn(mgs)), rho0(mgs)*qvex/Max( cwmasn5, Max(cwmas30,xmas(mgs,lc)) ) ) + ELSEIF ( imaxsupopt == 3 ) THEN + cn(mgs) = Min( Max(ccnc(mgs),cwnccn(mgs)), rho0(mgs)*qvex/Max( cwmasn5, Max(cwmasx,xmas(mgs,lc)) ) ) +! cn(mgs) = 1.5*cxmin + ELSEIF ( imaxsupopt == 4 ) THEN + cn(mgs) = Min( Max(ccnc(mgs),cwnccn(mgs)), rho0(mgs)*qvex/Max( cwmasn5, Max(cwmas20,xmas(mgs,lc)) ) ) + ENDIF + ccnc(mgs) = Max( 0.0, ccnc(mgs) - cn(mgs) ) + cx(mgs,lc) = cx(mgs,lc) + cn(mgs) + ENDIF + +! write(iunit,*) 'theta = ',theta0(mgs) + thetap(mgs) + +! temg(mgs) = theta(mgs)*( pres(mgs) / poo ) ** cap + + ENDIF + + + ENDIF + +! +! Calculate droplet volume and check if it is within bounds. +! Adjust if necessary +! +! if (ndebug .gt. 0) write(0,*) "ICEZVD_DR: check droplet volume" + + +! cx(mgs,lc) = Min( cwnccn(mgs), cx(mgs,lc) ) + IF( cx(mgs,lc) > cxmin .AND. qx(mgs,lc) .GT. qxmin(lc)) THEN +! SVC(mgs) = rho0(mgs)*qx(mgs,lc)/(cx(mgs,lc)*xdn(mgs,lc)) + xmas(mgs,lc) = rho0(mgs)*qx(mgs,lc)/(cx(mgs,lc)) + + IF ( xmas(mgs,lc) < cwmasn .or. xmas(mgs,lc) > cwmasx ) THEN + tmp = cx(mgs,lc) + xmas(mgs,lc) = Min( xmas(mgs,lc), cwmasx ) + xmas(mgs,lc) = Max( xmas(mgs,lc), cwmasn ) + cx(mgs,lc) = rho0(mgs)*qx(mgs,lc)/xmas(mgs,lc) +! IF ( cx(mgs,lc) > tmp*1.1 ) THEN +! write(0,*) 'nucond: kgs, ccw1,2 = ',kgs(mgs),tmp,cx(mgs,lc) +! ENDIF + ENDIF + ENDIF + + +! IF( cx(mgs,lc) .GT. 10.e6 .AND. qx(mgs,lc) .GT. qxmin(lc) ) GO TO 681 +! ccwtmp = cx(mgs,lc) +! cwmastmp = xmas(mgs,lc) +! xmas(mgs,lc) = Max(xmas(mgs,lc), cwmasn) +! IF (qx(mgs,lc) .GT. qxmin(lc) .AND. cx(mgs,lc) .le. 0.) THEN +! cx(mgs,lc) = Min(0.5*cwccn,rho0(mgs)*qx(mgs,lc)/xmas(mgs,lc)) +! xmas(mgs,lc) = rho0(mgs)*qx(mgs,lc)/cx(mgs,lc) +! ENDIF +! IF (cx(mgs,lc) .GT. 0. .AND. qx(mgs,lc) .GT. qxmin(lc)) & +! & xmas(mgs,lc) = rho0(mgs)*qx(mgs,lc)/cx(mgs,lc) +! IF (qx(mgs,lc) .GT. qxmin(lc) .AND. xmas(mgs,lc) .LT. cwmasn) & +! & xmas(mgs,lc) = cwmasn +! IF (qx(mgs,lc) .GT. qxmin(lc) .AND. xmas(mgs,lc) .GT. cwmasx) & +! & xmas(mgs,lc) = cwmasx +! IF ( qx(mgs,lc) .gt. qxmin(lc) ) THEN +! cx(mgs,lc) = rho0(mgs)*qx(mgs,lc)/Max(cwmasn,xmas(mgs,lc)) +! ENDIF +! +! +! 681 CONTINUE + + + IF ( ipconc .ge. 3 .and. rcond == 2 ) THEN + + + IF (cx(mgs,lr) .GT. 0. .AND. qx(mgs,lr) .GT. qxmin(lr)) & + & xv(mgs,lr)=rho0(mgs)*qx(mgs,lr)/(xdn(mgs,lr)*cx(mgs,lr)) + IF (xv(mgs,lr) .GT. xvmx(lr)) xv(mgs,lr) = xvmx(lr) + IF (xv(mgs,lr) .LT. xvmn(lr)) xv(mgs,lr) = xvmn(lr) + + ENDIF + + + + ENDDO ! mgs + + +! ################################################################ + DO mgs=1,ngscnt + IF ( lss > 1 .and. ssf(mgs) .gt. ssmax(mgs) & + & .and. ( idecss .eq. 0 .or. qx(mgs,lc) .gt. qxmin(lc)) ) THEN + ssmax(mgs) = ssf(mgs) + ENDIF + ENDDO +! + + do mgs = 1,ngscnt + an(igs(mgs),jy,kgs(mgs),lt) = theta0(mgs) + thetap(mgs) + an(igs(mgs),jy,kgs(mgs),lv) = qv0(mgs) + qwvp(mgs) +! tmp3d(igs(mgs),jy,kgs(mgs)) = tmp3d(igs(mgs),jy,kgs(mgs)) + t9(igs(mgs),jy,kgs(mgs)) ! pi0(mgs) ! wvdf(mgs) ! ssf(mgs) ! cn(mgs) +! + IF ( eqtset > 2 ) THEN + p2(igs(mgs),jy,kgs(mgs)) = pipert(mgs) + ENDIF + + if ( ido(lc) .eq. 1 ) then + an(igs(mgs),jy,kgs(mgs),lc) = qx(mgs,lc) + & + & min( an(igs(mgs),jy,kgs(mgs),lc), 0.0 ) +! qx(mgs,lc) = an(igs(mgs),jy,kgs(mgs),lc) + end if +! + + if ( ido(lr) .eq. 1 .and. rcond == 2 ) then + an(igs(mgs),jy,kgs(mgs),lr) = qx(mgs,lr) + & + & min( an(igs(mgs),jy,kgs(mgs),lr), 0.0 ) +! qx(mgs,lr) = an(igs(mgs),jy,kgs(mgs),lr) + end if + + + + IF ( ipconc .ge. 2 ) THEN + an(igs(mgs),jy,kgs(mgs),lnc) = Max(cx(mgs,lc) , 0.0) + IF ( lss > 1 ) an(igs(mgs),jy,kgs(mgs),lss) = Max( 0.0, ssmax(mgs) ) + IF ( lccn .gt. 1 ) THEN + an(igs(mgs),jy,kgs(mgs),lccn) = Max(0.0, ccnc(mgs) ) + ENDIF + IF ( lccnuf .gt. 1 ) THEN + an(igs(mgs),jy,kgs(mgs),lccnuf) = Max(0.0, ccncuf(mgs) ) + ENDIF + IF ( lccna .gt. 1 ) THEN + an(igs(mgs),jy,kgs(mgs),lccna) = Max(0.0, ccna(mgs) ) + ENDIF + ENDIF + IF ( ipconc .ge. 3 .and. rcond == 2 ) THEN + an(igs(mgs),jy,kgs(mgs),lnr) = Max(cx(mgs,lr) , 0.0) + ENDIF + end do + + +29998 continue + + + if ( kz .gt. nz-1 .and. ix .ge. nxi) then + if ( ix .ge. nxi ) then + go to 2200 ! exit gather scatter + else + nzmpb = kz + endif + else + nzmpb = kz + end if + + if ( ix .ge. nxi ) then + nxmpb = 1 + nzmpb = kz+1 + else + nxmpb = ix+1 + end if + + 2000 continue ! inumgs + 2200 continue +! +! end of gather scatter (for this jy slice) + + +!#ifdef COMMAS +! GOTO 9999 +!#endif + +! Redistribute inappreciable cloud particles and charge +! +! Redistribution everywhere in the domain... +! + IF ( .true. ) THEN + + frac = 1.0 ! 0.25 ! 1.0 ! 0.2 +! +! alternate test version for ipconc .ge. 3 +! just vaporize stuff to prevent noise in the number concentrations + + + do kz = 1,nz +! do jy = 1,1 + do ix = 1,nxi + + t0(ix,jy,kz) = an(ix,jy,kz,lt)*t77(ix,jy,kz) + + zerocx(:) = .false. + DO il = lc,lhab + IF ( iresetmoments == 1 .or. iresetmoments == il ) THEN + IF ( ln(il) > 1 ) zerocx(il) = ( an(ix,jy,kz,ln(il)) < cxmin ) + IF ( lz(il) > 1 ) zerocx(il) = ( zerocx(il) .or. an(ix,jy,kz,lz(il)) < zxmin ) + ELSE + IF ( il == lc ) THEN + IF ( ln(il) > 1 ) zerocx(il) = ( an(ix,jy,kz,ln(il)) <= 0 ) .and. .not. flag_qndrop ! do not reset if progn=1 (WRF-CHEM) + ELSE + IF ( ln(il) > 1 ) zerocx(il) = ( an(ix,jy,kz,ln(il)) <= 0 ) + ENDIF + ENDIF + ENDDO + + IF ( lhl .gt. 1 ) THEN + + + if ( an(ix,jy,kz,lhl) .lt. frac*qxmin(lhl) .or. zerocx(lhl) ) then + +! IF ( an(ix,jy,kz,lhl) .gt. 0 ) THEN + an(ix,jy,kz,lv) = an(ix,jy,kz,lv) + an(ix,jy,kz,lhl) + an(ix,jy,kz,lhl) = 0.0 +! ENDIF + + IF ( ipconc .ge. 5 ) THEN ! .and. an(ix,jy,kz,lnh) .gt. 0.0 ) THEN + an(ix,jy,kz,lnhl) = 0.0 + ENDIF + + IF ( lvhl .gt. 1 ) THEN + an(ix,jy,kz,lvhl) = 0.0 + ENDIF + + IF ( lhlw .gt. 1 ) THEN + an(ix,jy,kz,lhlw) = 0.0 + ENDIF + + IF ( lnhlf .gt. 1 ) THEN + an(ix,jy,kz,lnhlf) = 0.0 + ENDIF + + IF ( lzhl .gt. 1 ) THEN + an(ix,jy,kz,lzhl) = 0.0 + ENDIF + + ELSE + IF ( lvol(lhl) .gt. 1 ) THEN ! check density + IF ( an(ix,jy,kz,lvhl) .gt. 0.0 ) THEN + tmp = dn(ix,jy,kz)*an(ix,jy,kz,lhl)/an(ix,jy,kz,lvhl) + ELSE ! in case volume is zero but mass is above threshold (should not happen, of course) + tmp = rho_qhl + an(ix,jy,kz,lvhl) = dn(ix,jy,kz)*an(ix,jy,kz,lhl)/tmp + ENDIF + + IF ( tmp .lt. xdnmn(lhl) ) THEN + tmp = Max( xdnmn(lhl), tmp ) + an(ix,jy,kz,lvhl) = dn(ix,jy,kz)*an(ix,jy,kz,lhl)/tmp + ENDIF + + IF ( tmp .gt. xdnmx(lhl) .and. lhlw .le. 0 ) THEN ! no liquid allowed on hail + tmp = Min( xdnmx(lhl), tmp ) + an(ix,jy,kz,lvhl) = dn(ix,jy,kz)*an(ix,jy,kz,lhl)/tmp + ELSEIF ( tmp .gt. xdnmx(lhl) .and. lhlw .gt. 1 ) THEN ! allow for liquid on hail + fw = an(ix,jy,kz,lhlw)/an(ix,jy,kz,lhl) +! tmpmx = xdnmx(lhl) + fw*(xdnmx(lr) - xdnmx(lhl)) ! maximum possible average density + ! it is not exactly linear, but approx. is close enough for this +! tmpmx = 1./( (1. - fw)/900. + fw/1000. ) is exact max, where 900 is xdnmx + + tmpmx = xdnmx(lhl)/( 1. - fw*(1. - xdnmx(lhl)/xdnmx(lr) )) + + IF ( tmp .gt. tmpmx ) THEN + an(ix,jy,kz,lvhl) = dn(ix,jy,kz)*an(ix,jy,kz,lhl)/tmpmx + ENDIF + +! IF ( tmp .gt. xdnmx(lhl) .and. an(ix,jy,kz,lhlw) .lt. qxmin(lhl) ) THEN +! tmp = Min( xdnmx(lhl), tmp ) +! an(ix,jy,kz,lvhl) = dn(ix,jy,kz)*an(ix,jy,kz,lhl)/tmp +! ELSEIF ( tmp .gt. xdnmx(lr) ) THEN +! tmp = xdnmx(lr) +! an(ix,jy,kz,lvhl) = dn(ix,jy,kz)*an(ix,jy,kz,lhl)/tmp +! ENDIF + ENDIF + + IF ( lhlw .gt. 1 ) THEN ! check if basically pure water + IF ( an(ix,jy,kz,lhlw) .gt. 0.98*an(ix,jy,kz,lhl) ) THEN + tmp = xdnmx(lr) + an(ix,jy,kz,lvhl) = dn(ix,jy,kz)*an(ix,jy,kz,lhl)/tmp + ENDIF + ENDIF + + ENDIF + + +! CHECK INTERCEPT + IF ( ipconc == 5 .and. an(ix,jy,kz,lhl) .gt. qxmin(lhl) .and. alphahl .le. 0.1 .and. lnhl .gt. 1 .and. lzhl == 0 ) THEN + + IF ( lvhl .gt. 1 ) THEN + hwdn = dn(ix,jy,kz)*an(ix,jy,kz,lhl)/an(ix,jy,kz,lvhl) + ELSE + hwdn = xdn0(lhl) + ENDIF + tmp = (hwdn*an(ix,jy,kz,lnhl))/(dn(ix,jy,kz)*an(ix,jy,kz,lhl)) + tmpg = an(ix,jy,kz,lnhl)*(tmp*(3.14159))**(1./3.) + IF ( tmpg .lt. cnohlmn ) THEN + tmp = ( (hwdn)/(dn(ix,jy,kz)*an(ix,jy,kz,lhl))*(3.14159))**(1./3.) + an(ix,jy,kz,lnhl) = (cnohlmn/tmp)**(3./4.) + ENDIF + + ENDIF +! ELSE ! check mean size here? + + end if + + ENDIF !lhl + + + + + if ( an(ix,jy,kz,lh) .lt. frac*qxmin(lh) .or. zerocx(lh) ) then + +! IF ( an(ix,jy,kz,lh) .gt. 0 ) THEN + an(ix,jy,kz,lv) = an(ix,jy,kz,lv) + an(ix,jy,kz,lh) + an(ix,jy,kz,lh) = 0.0 +! ENDIF + + IF ( ipconc .ge. 5 ) THEN ! .and. an(ix,jy,kz,lnh) .gt. 0.0 ) THEN + an(ix,jy,kz,lnh) = 0.0 + ENDIF + + IF ( lvh .gt. 1 ) THEN + an(ix,jy,kz,lvh) = 0.0 + ENDIF + + IF ( lhw .gt. 1 ) THEN + an(ix,jy,kz,lhw) = 0.0 + ENDIF + + IF ( lnhf .gt. 1 ) THEN + an(ix,jy,kz,lnhf) = 0.0 + ENDIF + + IF ( lzh .gt. 1 ) THEN + an(ix,jy,kz,lzh) = 0.0 + ENDIF + + ELSE + IF ( lvol(lh) .gt. 1 ) THEN ! check density + IF ( an(ix,jy,kz,lvh) .gt. 0.0 ) THEN + tmp = dn(ix,jy,kz)*an(ix,jy,kz,lh)/an(ix,jy,kz,lvh) + ELSE + tmp = rho_qh + an(ix,jy,kz,lvh) = dn(ix,jy,kz)*an(ix,jy,kz,lh)/tmp + ENDIF + + IF ( tmp .lt. xdnmn(lh) ) THEN + tmp = Max( xdnmn(lh), tmp ) + an(ix,jy,kz,lvh) = dn(ix,jy,kz)*an(ix,jy,kz,lh)/tmp + ENDIF + + IF ( tmp .gt. xdnmx(lh) .and. lhw .le. 0 ) THEN ! no liquid allowed on graupel + tmp = Min( xdnmx(lh), tmp ) + an(ix,jy,kz,lvh) = dn(ix,jy,kz)*an(ix,jy,kz,lh)/tmp + ELSEIF ( tmp .gt. xdnmx(lh) .and. lhw .gt. 1 ) THEN ! allow for liquid on graupel + fw = an(ix,jy,kz,lhw)/an(ix,jy,kz,lh) +! tmpmx = xdnmx(lh) + fw*(xdnmx(lr) - xdnmx(lh)) ! maximum possible average density + ! it is not exactly linear, but approx. is close enough for this +! tmpmx = 1./( (1. - fw)/900. + fw/1000. ) is exact max, where 900 is xdnmx + tmpmx = xdnmx(lh)/( 1. - fw*(1. - xdnmx(lh)/xdnmx(lr) )) + + IF ( tmp .gt. tmpmx ) THEN + an(ix,jy,kz,lvh) = dn(ix,jy,kz)*an(ix,jy,kz,lh)/tmpmx + ENDIF + +! IF ( tmp .gt. xdnmx(lh) .and. an(ix,jy,kz,lhw) .lt. qxmin(lh) ) THEN +! tmp = Min( xdnmx(lh), tmp ) +! an(ix,jy,kz,lvh) = dn(ix,jy,kz)*an(ix,jy,kz,lh)/tmp +! ELSEIF ( tmp .gt. xdnmx(lr) ) THEN +! tmp = xdnmx(lr) +! an(ix,jy,kz,lvh) = dn(ix,jy,kz)*an(ix,jy,kz,lh)/tmp +! ENDIF + + ENDIF + + IF ( lhw .gt. 1 ) THEN ! check if basically pure water + IF ( an(ix,jy,kz,lhw) .gt. 0.98*an(ix,jy,kz,lh) ) THEN + tmp = xdnmx(lr) + an(ix,jy,kz,lvh) = dn(ix,jy,kz)*an(ix,jy,kz,lh)/tmp + ENDIF + ENDIF + + ENDIF + +! CHECK INTERCEPT + IF ( ipconc == 5 .and. an(ix,jy,kz,lh) .gt. qxmin(lh) .and. alphah .le. 0.1 .and. lnh .gt. 1 .and. lzh == 0 ) THEN + + IF ( lvh .gt. 1 ) THEN + IF ( an(ix,jy,kz,lvh) .gt. 0.0 ) THEN + hwdn = dn(ix,jy,kz)*an(ix,jy,kz,lh)/an(ix,jy,kz,lvh) + ELSE + hwdn = xdn0(lh) + ENDIF + hwdn = Max( xdnmn(lh), hwdn ) + ELSE + hwdn = xdn0(lh) + ENDIF + tmp = (hwdn*an(ix,jy,kz,lnh))/(dn(ix,jy,kz)*an(ix,jy,kz,lh)) + tmpg = an(ix,jy,kz,lnh)*(tmp*(3.14159))**(1./3.) + IF ( tmpg .lt. cnohmn ) THEN +! tmpg = an(ix,jy,kz,lnh)*( (hwdn*an(ix,jy,kz,lnh))/(dn(ix,jy,kz)*an(ix,jy,kz,lh))*(3.14159))**(1./3.) +! tmpg = an(ix,jy,kz,lnh)**(4./3.)*( (hwdn)/(dn(ix,jy,kz)*an(ix,jy,kz,lh))*(3.14159))**(1./3.) + tmp = ( (hwdn)/(dn(ix,jy,kz)*an(ix,jy,kz,lh))*(3.14159))**(1./3.) + an(ix,jy,kz,lnh) = (cnohmn/tmp)**(3./4.) + ENDIF + + ENDIF + + end if + + + if ( an(ix,jy,kz,ls) .lt. frac*qxmin(ls) .or. zerocx(ls) & ! .or. an(ix,jy,kz,lns) .lt. 0.1 ! .and. + & ) then + IF ( t0(ix,jy,kz) .lt. 273.15 ) THEN +! IF ( an(ix,jy,kz,ls) .gt. 0 ) THEN + an(ix,jy,kz,lv) = an(ix,jy,kz,lv) + an(ix,jy,kz,ls) + an(ix,jy,kz,ls) = 0.0 +! ENDIF + + IF ( ipconc .ge. 4 ) THEN ! .and. an(ix,jy,kz,lns) .gt. 0.0 ) THEN ! +! an(ix,jy,kz,lni) = an(ix,jy,kz,lni) + an(ix,jy,kz,lns) + an(ix,jy,kz,lns) = 0.0 + ENDIF + + IF ( lvs .gt. 1 ) THEN + an(ix,jy,kz,lvs) = 0.0 + ENDIF + + IF ( lsw .gt. 1 ) THEN + an(ix,jy,kz,lsw) = 0.0 + ENDIF + + ELSE +! IF ( an(ix,jy,kz,ls) .gt. 0 ) THEN + an(ix,jy,kz,lv) = an(ix,jy,kz,lv) + an(ix,jy,kz,ls) + an(ix,jy,kz,ls) = 0.0 +! ENDIF + + IF ( lvs .gt. 1 ) THEN + an(ix,jy,kz,lvs) = 0.0 + ENDIF + + IF ( lsw .gt. 1 ) THEN + an(ix,jy,kz,lsw) = 0.0 + ENDIF + + IF ( ipconc .ge. 4 ) THEN ! .and. an(ix,jy,kz,lns) .gt. 0.0 ) THEN ! +! an(ix,jy,kz,lnr) = an(ix,jy,kz,lnr) + an(ix,jy,kz,lns) + an(ix,jy,kz,lns) = 0.0 + ENDIF + + ENDIF + + + ELSEIF ( lvol(ls) .gt. 1 ) THEN ! check density + IF ( an(ix,jy,kz,lvs) .gt. 0.0 ) THEN + tmp = dn(ix,jy,kz)*an(ix,jy,kz,ls)/an(ix,jy,kz,lvs) + IF ( tmp .gt. xdnmx(ls) .or. tmp .lt. xdnmn(ls) ) THEN + tmp = Min( xdnmx(ls), Max( xdnmn(ls), tmp ) ) + an(ix,jy,kz,lvs) = dn(ix,jy,kz)*an(ix,jy,kz,ls)/tmp + ENDIF + ELSE + tmp = rho_qs + an(ix,jy,kz,lvs) = dn(ix,jy,kz)*an(ix,jy,kz,ls)/tmp + ENDIF + + + end if + + + if ( an(ix,jy,kz,lr) .lt. frac*qxmin(lr) .or. zerocx(lr) & + & ) then + an(ix,jy,kz,lv) = an(ix,jy,kz,lv) + an(ix,jy,kz,lr) + an(ix,jy,kz,lr) = 0.0 + IF ( ipconc .ge. 3 ) THEN +! an(ix,jy,kz,lnc) = an(ix,jy,kz,lnc) + an(ix,jy,kz,lnr) + an(ix,jy,kz,lnr) = 0.0 + ENDIF + + end if + +! +! for qci +! + IF ( an(ix,jy,kz,li) .le. frac*qxmin(li) .or. zerocx(li) & ! .or. an(ix,jy,kz,lni) .lt. 0.1 + & ) THEN + an(ix,jy,kz,lv) = an(ix,jy,kz,lv) + an(ix,jy,kz,li) + an(ix,jy,kz,li)= 0.0 + IF ( ipconc .ge. 1 ) THEN + an(ix,jy,kz,lni) = 0.0 + ENDIF + ENDIF + +! +! for qis +! + IF ( lis > 1 ) THEN ! { + IF ( an(ix,jy,kz,lis) .le. frac*qxmin(lis) .or. zerocx(lis) & ! .or. an(ix,jy,kz,lni) .lt. 0.1 + & ) THEN ! { { + an(ix,jy,kz,lv) = an(ix,jy,kz,lv) + an(ix,jy,kz,lis) + an(ix,jy,kz,lis)= 0.0 + IF ( ipconc .ge. 1 ) THEN + an(ix,jy,kz,lnis) = 0.0 + ENDIF + + ELSEIF ( icespheres >= 2 ) THEN ! } { + km1 = Max(1, kz-1) + IF ( 0.5*( w(ix,jy,kz) + w(ix,jy,kz+1)) < -1.0 .or. & + & (icespheres == 3 .and. ( t0(ix,jy,kz) < 232.15 .or. an(ix,jy,kz,lc) < qxmin(lc) ) ) .or. & + & (icespheres == 5 .and. ( t0(ix,jy,kz) < 232.15 .or. & + & ( an(ix,jy,kz,lc) < qxmin(lc) .and. an(ix,jy,km1,lc) < qxmin(lc) )) ) .or. & + & (icespheres == 4 .and. ( t0(ix,jy,kz) < 235.15 )) ) THEN ! transfer to regular ice crystals in downdraft or at low temp + an(ix,jy,kz,li) = an(ix,jy,kz,li) + an(ix,jy,kz,lis) + an(ix,jy,kz,lni) = an(ix,jy,kz,lni) + an(ix,jy,kz,lnis) + an(ix,jy,kz,lis)= 0.0 + an(ix,jy,kz,lnis)= 0.0 + + ENDIF + + ENDIF ! } } + ENDIF ! } + +! +! for qcw +! + + IF ( an(ix,jy,kz,lc) .le. frac*qxmin(lc) .or. zerocx(lc) & + & ) THEN + an(ix,jy,kz,lv) = an(ix,jy,kz,lv) + an(ix,jy,kz,lc) + an(ix,jy,kz,lc)= 0.0 + IF ( ipconc .ge. 2 ) THEN + IF ( lccn .gt. 1 ) THEN + an(ix,jy,kz,lccn) = & + & an(ix,jy,kz,lccn) + Max(0.0,an(ix,jy,kz,lnc)) + ENDIF + an(ix,jy,kz,lnc) = 0.0 + + IF ( lccna > 0 ) THEN ! apply exponential decay to activated CCN to restore to environmental value + tmp = an(ix,jy,kz,li) + an(ix,jy,kz,ls) + + IF ( an(ix,jy,kz,lccna) > 1. .and. tmp < qxmin(li) ) an(ix,jy,kz,lccna) = an(ix,jy,kz,lccna)*Exp(-dtp/ccntimeconst) + + ELSEIF ( lccn > 1 .and. restoreccn ) THEN + ! in this case, we are treating the ccn field as ccna + tmp = an(ix,jy,kz,li) + an(ix,jy,kz,ls) +! IF ( ny == 2 .and. ix == nx/2 ) THEN +! write(0,*) 'restore: k, qccn,exp = ',kz,qccn,dn(ix,jy,kz)*qccn,Exp(-dtp/ccntimeconst) +! write(0,*) 'ccn1,ccn2 = ',an(ix,jy,kz,lccn),dn(ix,jy,kz)*qccn - Max(0.0 , dn(ix,jy,kz)*qccn - an(ix,jy,kz,lccn))*Exp(-dtp/ccntimeconst) +! ENDIF + IF ( an(ix,jy,kz,lccn) > 1. .and. tmp < qxmin(li) .and. ( an(ix,jy,kz,lccn) < dn(ix,jy,kz)*qccn .or. .not. invertccn ) ) THEN + ! an(ix,jy,kz,lccn) = & + ! an(ix,jy,kz,lccn) + Max(0.0 , dn(ix,jy,kz)*qccn - an(ix,jy,kz,lccn))*(1.0 - Exp(-dtp/ccntimeconst)) + ! Equivalent form after expanding last term: + an(ix,jy,kz,lccn) = & + dn(ix,jy,kz)*qccn - Max(0.0 , dn(ix,jy,kz)*qccn - an(ix,jy,kz,lccn))*Exp(-dtp/ccntimeconst) + ENDIF + + ENDIF + + ENDIF + + ENDIF + + end do +! end do + end do + + ENDIF ! true/false + + IF ( ndebug .ge. 1 ) write(6,*) 'END OF ICEZVD_DR' +! +! + + + 9999 RETURN + + END SUBROUTINE NUCOND + + +! ##################################################################### +! ##################################################################### +!>\ingroup mod_nsslmp +!! Main microphysical processes routine + + + + +!c-------------------------------------------------------------------------- +! +! +!-------------------------------------------------------------------------- +! + + subroutine nssl_2mom_gs & + & (nx,ny,nz,na,jyslab & + & ,nor,norz & + & ,dtp,gz & + & ,t0,t1,t2,t3,t4,t5,t6,t7,t8,t9 & + & ,an,dn,p2 & + & ,pn,w,iunit & + & ,t00,t77, & + & ventr,ventc,c1sw,jgs,ido, & + & xdnmx,xdnmn, & +! & ln,ipc,lvol,lz,lliq, & + & cdx, & + & xdn0,tmp3d,tkediss & + & ,thproc,numproc,dx1,dy1 & + & ,timevtcalc,axtra,io_flag & + & , has_wetscav,rainprod2d, evapprod2d & + & ,errmsg,errflg & + & ,elec,its,ids,ide,jds,jde & + & ) + + +! +!-------------------------------------------------------------------------- +! +! Ziegler 1985 parameterized microphysics (also Zrnic et al. 1993) +! 1) cloud water +! 2) rain +! 3) column ice +! 6) snow +! 11) graupel/hail +! +!-------------------------------------------------------------------------- +! +! Notes: +! +! 4/27/2009: allows for liquid water to be advected on snow and graupel particles using flag "mixedphase" +! +! 3/14/2007: (APS) added qproc temp to make microphysic process timeseries +! +! 10/17/2006: added flag (iehw) to select how to calculate ehw +! +! 10/5/2006: switched chacr to integrated version rather than assuming that average rain +! drop mass does not change. This acts to reduce rain size somewhat via graupel +! collection. +! Use Mason data for ehw, with scaling toward ehw=1 as air density decreases. +! +! 10/3/2006: Turned off Meyers nucleation for T > -5 (can turn on with imeyers5 flag) +! Turned off contact nucleation in updrafts +! +! 7/24/2006: Turned on Meyers nucleation for -5 < T < 0 +! +! 5/12/2006: Converted qsacw/csacw and qsaci/csaci to Z93 +! +! 5/12/2006: Put a threshold on Bigg rain freezing. If the frozen drops +! have an average volume less than xvhmn, then the drops are put +! into snow instead of graupel/hail. +! +! Fixed bug when vapor deposition was limited. +! +! 5/13/2006: Note that qhacr has a large effect, but Z85 did not include it. +! Turned off qsacr (set to zero). +! +! 9/14/2007: erm: recalculate vx(lh) after setting xdn(lh) in case xdn was out of allowed range. +! added parameter rimc3 for minimum rime density. Default value set at 170. kg/m**3 +! instead of previous use of 100. (Farley, 1987) +! +!-------------------------------------------------------------------------- +! +! general declarations +! +!-------------------------------------------------------------------------- +! +! +! + + + implicit none +! +! integer icond +! parameter ( icond = 2 ) + + integer, parameter :: ng1 = 1 + + integer nx,ny,nz,na,nba,nv + integer nor,norz,istag,jstag,kstag ! ,nht,ngt,igsr + integer iwrite + real dtp,dx,dy,dz + + logical, intent(in) :: io_flag + + integer itile,jtile,ktile + integer ixbeg,jybeg + integer ixend,jyend,kzend,kzbeg + integer nxend,nyend,nzend,nzbeg + integer :: my_rank = 0 + integer, parameter :: myprock = 1, nprock = 1 + logical, intent(in) :: has_wetscav + integer, intent(in) :: numproc + real, intent(inout) :: thproc(nz,numproc) + real, intent(in) :: dx1,dy1 + real rainprod2d(-nor+1:nx+nor,-norz+ng1:nz+norz) + real evapprod2d(-nor+1:nx+nor,-norz+ng1:nz+norz) + + real tkediss(-nor+1:nx+nor,-norz+ng1:nz+norz) + real axtra(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-norz+ng1:nz+norz,nxtra) + + real :: galpharaut + real :: xvbarmax + + integer jyslab,its,ids,ide,jds,jde ! domain boundaries + integer, intent(in) :: iunit !,iunit0 + real qvex + integer iraincv, icgxconv + parameter ( iraincv = 1, icgxconv = 1) + real ffrz + real :: ffrzh = 1.0 + + real qcitmp,cirdiatmp ! ,qiptmp,qirtmp + real ccwtmp,ccitmp ! ,ciptmp,cirtmp + real cpqc,cpci ! ,cpip,cpir + real cpqc0,cpci0 ! ,cpip0,cpir0 + real scfac ! ,cpip1 + + double precision dp1 + + double precision frac, frach, xvfrz, xvbiggsnow + + double precision :: timevtcalc + double precision :: dpt1,dpt2 + + logical, parameter :: gammacheck = .false. + integer :: luindex + double precision :: tmpgam + logical, parameter :: usegamxinfcnu = .false. + logical, parameter :: usegamxinf = .false. + logical, parameter :: usegamxinf2 = .false. + logical, parameter :: usegamxinf3 = .false. +! real rar ! rime accretion rate as calculated from qxacw + + ! CCPP error handling + character(len=*), intent( out) :: errmsg + integer, intent( out) :: errflg +! a few vars for time-split fallout + real vtmax + integer n,ndfall + + double precision chgneg,chgpos,sctot + + real temgtmp + + real pb(-norz+ng1:nz+norz) + real pinit(-norz+ng1:nz+norz) + + real gz(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-norz+ng1:nz+norz) ! dz + + real qimax,xni0,roqi0 + + + real dv + + real dtptmp + integer itest,nidx,id1,jd1,kd1 + parameter (itest=1) + parameter (nidx=10) + parameter (id1=1,jd1=1,kd1=1) + integer ierr + integer iend + + integer ix,kz, il, ic, ir, icp1, irp1, ip1,jp1,kp1 + integer :: jy + integer i,j,k,i1 + integer kzb,kze + real slope1, slope2 + real x1, x2, x3 + real eps,eps2 + parameter (eps=1.e-20,eps2=1.e-5) +! +! Other elec. vars +! + real temele + real trev + + logical ldovol, ishail, ltest, wtest + logical , parameter :: alp0flag = .false. +! +! +! wind indicies +! + integer mu,mv,mw + parameter (mu=1,mv=2,mw=3) +! +! conversion parameters +! + integer mqcw,mqxw,mtem,mrho,mtim + parameter (mqcw=21,mqxw=21,mtem=21,mrho=5,mtim=6) + + real xftim,xftimi,yftim, xftem,yftem, xfqcw,yfqcw, xfqxw,yfqxw + parameter (xftim=0.05,xftimi = 1./xftim,yftim=1.) + parameter (xftem=0.5,yftem=1.) + parameter (xfqcw=2000.,yfqcw=1.) + parameter (xfqxw=2000.,yfqxw=1.) + real dtfac + parameter ( dtfac = 1.0 ) + integer ido(lc:lqmx) + +! integer iexy(lc:lqmx,lc:lqmx) +! integer ieswi, ieswir, ieswip, ieswc, ieswr +! integer ieglsw, iegli, ieglir, ieglip, ieglc, ieglr +! integer iegmsw, iegmi, iegmir, iegmip, iegmc, iegmr +! integer ieghsw, ieghi, ieghir, ieghip, ieghc, ieghr +! integer iefwsw, iefwi, iefwir, iefwip, iefwc, iefwr +! integer iehwsw, iehwi, iehwir, iehwip, iehwc, iehwr +! integer iehlsw, iehli, iehlir, iehlip, iehlc, iehlr +! real delqnsa, delqxsa, delqnsb, delqxsb, delqnia, delqxia +! real delqnra, delqxra + + real delqnxa(lc:lqmx) + real delqxxa(lc:lqmx) +! +! external temporary arrays +! + real t00(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-norz+ng1:nz+norz) + real t77(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-norz+ng1:nz+norz) + + real t0(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-norz+ng1:nz+norz) + real t1(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-norz+ng1:nz+norz) + real t2(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-norz+ng1:nz+norz) + real t3(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-norz+ng1:nz+norz) + real t4(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-norz+ng1:nz+norz) + real t5(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-norz+ng1:nz+norz) + real t6(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-norz+ng1:nz+norz) + real t7(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-norz+ng1:nz+norz) + real t8(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-norz+ng1:nz+norz) + real t9(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-norz+ng1:nz+norz) + + real p2(-nor+1:nx+nor,-nor+1:ny+nor,-norz+ng1:nz+norz) ! perturbation Pi + real pn(-nor+1:nx+nor,-nor+1:ny+nor,-norz+ng1:nz+norz) + real an(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-norz+ng1:nz+norz,na) + real dn(-nor+1:nx+nor,-nor+1:ny+nor,-norz+ng1:nz+norz) + real w(-nor+1:nx+nor,-nor+1:ny+nor,-norz+ng1:nz+norz) + + real tmp3d(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-norz+ng1:nz+norz) + +! +! declarations microphyscs and for gather/scatter +! + integer nxmpb,nzmpb,nxz + integer jgs,mgs,ngs,numgs + parameter (ngs=500) !500) + integer, parameter :: ngsz = 500 + integer ntt + parameter (ntt=300) + + real dvmgs(ngs) + + integer ngscnt,igs(ngs),kgs(ngs) + integer kgsp(ngs),kgsm(ngs),kgsm2(ngs) + integer ncuse + parameter (ncuse=0) + integer il0(ngs),il5(ngs),il2(ngs),il3(ngs) +! integer il1m(ngs),il2m(ngs),il3m(ngs),il4m(ngs),il5m(ngs) +! + real tdtol,temsav,tfrcbw,tfrcbi + real, parameter :: thnuc = 235.15 +! +! Ice Multiplication Arrays. +! + real fimt1(ngs),fimta(ngs),fimt2(ngs) !,qmul1(ngs),qmul2(ngs) + real xcwmas +! +! +! Variables for Ziegler warm rain microphysics +! + + + real ccnc(ngs),ccin(ngs),cina(ngs),ccna(ngs) + real cwnccn(ngs) + real sscb ! 'cloud base' SS threshold + parameter ( sscb = 2.0 ) + integer idecss ! flag to turn on (=1) decay of ssmax when no cloud or ice crystals + parameter ( idecss = 1 ) + integer iba ! flag to do condensation/nucleation in 1st or 2nd loop + ! =0 to use ad to calculate SS + ! =1 to use an at end of main jy loop to calculate SS + parameter (iba = 1) + integer ifilt ! =1 to filter ssat, =0 to set ssfilt=ssat + parameter ( ifilt = 0 ) + real temp1,temp2 ! ,ssold + real :: mwat, mice, dice, mwshed, fwmax, fw, mwcrit, massfactor, tmpdiam + real, parameter :: shedalp = 3. ! set 3 for maximum mass diameter (same as area-weighted diameter), 4 for mass-weighted diameter + real ssmax(ngs) ! maximum SS experienced by a parcel + real ssmx + real dnnet,dqnet +! real cnu,rnu,snu,cinu +! parameter ( cnu = 0.0, rnu = -0.8, snu = -0.8, cinu = 0.0 ) + real bfnu, bfnu0, bfnu1 + parameter ( bfnu0 = (rnu + 2.0)/(rnu + 1.0) ) + real ventr, ventc + real volb + double precision t2s, xdp + double precision xl2p(ngs),rb(ngs) + real, parameter :: aa1 = 9.44e15, aa2 = 5.78e3 ! a1 in Ziegler +! snow parameters: + real, parameter :: cexs = 0.1, cecs = 0.5 + real, parameter :: rvt = 0.104 ! ratio of collection kernels (Zrnic et al, 1993) + real, parameter :: kfrag = 1.0e-6 ! rate coefficent for collisional splintering (Schuur & Rutledge 00b) + real, parameter :: mfrag = 1.0e-10 ! assumed ice fragment mass for collisional splintering (Schuur & Rutledge 00b) + double precision cautn(ngs), rh(ngs), nh(ngs) + real ex1, ft, rhoinv(ngs) + double precision ec0(ngs) + + real ac1,bc, taus, c1,d1,e1,f1,p380,tmp,tmp1,tmp2,tmp3,tmp4,tmp5,temp3 ! , sstdy, super + real dw,dwr + double precision :: tmpz, tmpzmlt + real ratio, delx, dely + real dbigg,volt + real chgtmp,fac,mixedphasefac + real x,y,y2,del,r,rtmp,alpr + double precision :: vent1,vent2 + double precision :: g1palp,g4palp + double precision :: g1palpinf,g4palpinf + real fqt !charge separation as fn of temperature from Dong and Hallett 1992 + real bs + real v1, v2 + real d1r, d1i, d1s, e1i + real c1sw ! integration factor for snow melting with snu = -0.8 + real, parameter :: vr1mm = 5.23599e-10 ! volume of 1mm diameter sphere (m**3) + real, parameter :: vr3mm = 5.23599e-10*(3.0/1.)**3 ! volume of a 3 mm diameter sphere (m**3) (Rasmussen et al. 1984b, JAS) + real, parameter :: vr4p5mm = 5.23599e-10*(4.5/1.)**3 ! volume of 4.5mm diameter sphere (m**3) (Rasmussen et al. 1984b, JAS) + real vmlt,vshd, vshdgs(ngs,lh:lhab), maxmassfac(lc:lhab) + real rhosm + parameter ( rhosm = 500. ) + integer nc ! condensation step + real dtcon,dtcon1,dtcon2 ! condensation time step (dtcon*nc = dtp) + real delta + integer ltemq1,ltemq1m ! ,ltemq1m2 + real dqv,qv1,ss1,ss2,qvs1,dqvs,dtemp,dt1 ! temporaries for condensation + real ssi1, ssi2, dqvi, dqvis, dqvii,qis1 + real dqvr, dqc, dqr, dqi, dqs + real qv1m,qvs1m,ss1m,ssi1m,qis1m + real cwmastmp + real dcloud,dcloud2 ! ,as, bs + real cn(ngs) + double precision xvc, xvr + real mwfac +! real es(ngs) ! ss(ngs), +! real eis(ngs) + + real rwmasn,rwmasx + + real vgra,vfrz + parameter ( vgra = 0.523599*(1.0e-3)**3 ) + +! real, parameter :: epsi = 0.622 +! real, parameter :: d = 0.266 + real :: d, dold, denom,denominv,vth + double precision :: h1, h2, h3, h4,denomdp, denominvdp + real r1,qevap ! ,slv + + real vr,nrx,chw,g1,qr,z,z1,rdi,alp,xnutmp,xnuc,g1r,rd1,rdia,rmas + real :: snowmeltmass = 0 + +! real, parameter :: rhofrz = 900. ! density of graupel from newly-frozen rain + real, parameter :: rimedens = 500. ! default rime density + +! real svc(ngs) ! droplet volume +! +! contact freezing nucleation +! + real raero,kaero !assumd aerosol radius, thermal conductivity + parameter ( raero = 3.e-7, kaero = 5.39e-3 ) + real kb ! Boltzman constant J K-1 + parameter (kb = 1.3807e-23) + + real knud(ngs),knuda(ngs) !knudsen number and correction factor + real gtp(ngs) !G(T,p) = 1/(a' + b') Cotton 72b + real dfar(ngs) !aerosol diffusivity + real fn1(ngs),fn2(ngs),fnft(ngs) + + real ccia(ngs) + real ctfzbd(ngs),ctfzth(ngs),ctfzdi(ngs) +! +! misc +! + real ni,nis,nr,d0 + real dqvcnd(ngs),dqwv(ngs),dqcw(ngs),dqci(ngs),dqcitmp(ngs),dqwvtmp(ngs) + real tempc(ngs) + real temg(ngs),temcg(ngs),theta(ngs),qvap(ngs) + real temgkm1(ngs), temgkm2(ngs) + real temgx(ngs),temcgx(ngs) + real qvs(ngs),qis(ngs),qss(ngs),pqs(ngs) + real elv(ngs),elf(ngs),els(ngs) + real tsqr(ngs),ssi(ngs),ssw(ngs) + real qcwtmp(ngs),qtmp,qtot(ngs) + real qcond(ngs) + real ctmp, sctmp + real cimasn,cimasx,ccimx + real pid4 + real cs,ds,gf7,gf6,gf5,gf4,gf3,gf2,gf1 + real gcnup1,gcnup2 + real gf73rds, gf83rds + real gamice73fac, gamsnow73fac + real gf43rds, gf53rds + real aradcw,bradcw,cradcw,dradcw,cwrad,rwrad,rwradmn + parameter ( rwradmn = 50.e-6 ) + real dh0 + real dg0(ngs),df0(ngs) + + real clionpmx,clionnmx + parameter (clionpmx=1.e9,clionnmx=1.e9) ! Takahashi 84 +! +! other arrays + + real fwet1(ngs),fwet2(ngs) + real fmlt1(ngs),fmlt2(ngs) + real fvds(ngs),fvce(ngs),fiinit(ngs) + real fvent(ngs),fraci(ngs),fracl(ngs) +! + real fai(ngs),fav(ngs),fbi(ngs),fbv(ngs) + real felv(ngs),fels(ngs),felf(ngs) + real felvcp(ngs),felscp(ngs),felfcp(ngs) + real felvpi(ngs),felspi(ngs),felfpi(ngs) + real felvs(ngs),felss(ngs) ! ,felfs(ngs) + real fwvdf(ngs),ftka(ngs),fthdf(ngs) + real fadvisc(ngs),fakvisc(ngs) + real fci(ngs),fcw(ngs) ! heat capacities of ice and liquid + real fschm(ngs),fpndl(ngs) + real fgamw(ngs),fgams(ngs) + real fcqv1(ngs),fcqv2(ngs),fcc3(ngs) + + real cvm,cpm,rmm + + real, parameter :: cpv = 1885.0 ! specific heat of water vapor at constant pressure +! + real fcci(ngs), fcip(ngs) +! + real :: sfm1(ngs),sfm2(ngs) + real :: gfm1(ngs),gfm2(ngs) + real :: hfm1(ngs),hfm2(ngs) + + logical :: wetsfc(ngs),wetsfchl(ngs),wetsfcf(ngs) + logical :: wetgrowth(ngs), wetgrowthhl(ngs), wetgrowthf(ngs) + + real qitmp(ngs),qistmp(ngs) + + real rzxh(ngs), rzxhl(ngs), rzxhlh(ngs), rzxhlf(ngs) + real rzxs(ngs), rzxf(ngs) +! real axh(ngs),bxh(ngs),axhl(ngs),bxhl(ngs) + real cdh(ngs),cdhl(ngs) + real :: axx(ngs,lh:lhab),bxx(ngs,lh:lhab) + real vt2ave(ngs) + + real :: qcwresv(ngs), ccwresv(ngs) ! "reserved" droplet mass and number that are too small for accretion + + real :: lfsave(ngs,6) + real :: qx(ngs,lv:lhab) + real :: qxw(ngs,ls:lhab) + real :: qxwlg(ngs,lh:lhab) + real :: chxf(ngs,lh:lhab) + real :: cx(ngs,lc:lhab) + real :: cxmxd(ngs,lc:lhab) + real :: qxmxd(ngs,lv:lhab) + real :: scx(ngs,lc:lhab) + real :: xv(ngs,lc:lhab) + real :: vtxbar(ngs,lc:lhab,3) + real :: xmas(ngs,lc:lhab) + real :: xdn(ngs,lc:lhab) + real :: xdntmp(ngs,lc:lhab) + real :: cdxgs(ngs,lc:lhab) + real :: xdia(ngs,lc:lhab,3) + real :: vtwtdia(ngs,lr:lhab) ! sweep-out volume weighted diameter + real :: rarx(ngs,ls:lhab) + real :: vx(ngs,li:lhab) + real :: rimdn(ngs,li:lhab) + real :: raindn(ngs,li:lhab) + real :: alpha(ngs,lc:lhab) + real :: dab0lh(ngs,lc:lhab,lc:lhab) + real :: dab1lh(ngs,lc:lhab,lc:lhab) + + real :: qsimxdep(ngs) ! max sublimation of qi+qs+qis + real :: qsimxsub(ngs) ! max depositionof qi+qs+qis + logical,parameter :: DoSublimationFix = .true. + real :: qrtmp(ngs),qvtmp(ngs),qctmp(ngs) + real :: felvcptmp,felscptmp,qsstmp + real :: thetatmp, thetaptmp, temcgtmp,qvaptmp + real :: qvstmp, qisstmp, qvptmp, qitmp1, qctmp1 + + real :: galphrout + + real ventrx(ngs) + real ventrxn(ngs) + real g1shr, alphashr + real g1mlr, alphamlr + real massfacshr, massfacmlr + + real :: qhgt8mm ! ice mass greater than 8mm + real :: qhwgt8mm ! ice + max water mass greater than 8mm + real :: qhgt10mm ! mass greater than 10mm + real :: qhgt20mm ! mass greater than 20mm + real :: fwmhtmp + real, parameter :: fwmhtmptem = -15. ! temperature at which fwmhtmp fully switches to liquid water only being on large particles + real, parameter :: d1t = (6.0 * 0.268e-3/(917.* pi))**(1./3.) ! d1t is the diameter of the ice sphere with the mass (0.268e-3 kg) of an 8mm spherical drop + real, parameter :: srasheym = 0.1389 ! slope fraction from Rasmussen and Heymsfield +! + real swvent(ngs),hwvent(ngs),rwvent(ngs),hlvent(ngs),hwventy(ngs),hlventy(ngs),rwventz(ngs) + integer, parameter :: ndiam = 10 + integer :: numdiam + real hwvent0(ndiam+4),hlvent0 ! 0 to d1 + real hwvent1,hlvent1 ! d1 to infinity + real hwvent2,hlvent2 ! d2 to infinity + real gama0,gamb0 + real gama1,gamb1 + real gama2,gamb2 +! real, parameter :: mltdiam1 = 9.0e-3, mltdiam1p5 = 16.0e-3, mltdiam2 = 19.0e-3, mltdiam3 = 200.0e-3, mltdiam05 = 4.5e-3 + real :: mltdiam(ndiam+4) + real mltmass0inv,mltmass1inv,mltmass2inv, mltmass1cgs, mltmass2cgs,mltmass3inv, mltmass3cgs + real qhmlr0, qhmlr05, qhmlr1, qhmlr2,qhmlr3, qhmlr12, qhmlr23 + real qhlmlr0, qhlmlr05, qhlmlr1, qhlmlr2,qhlmlr3, qhlmlr12, qhlmlr23 + real qxd1, cxd1, zxd1 ! mass and number up to mltdiam1 + real qxd05, cxd05 ! mass and number up to mltdiam1/2 + + real :: qxd(ndiam+4), cxd(ndiam+4), qhml(ndiam+4), qhml0(ndiam+4) + real :: dqxd(ndiam+4), dcxd(ndiam+4), dqhml(ndiam+4) + + + real civent(ngs) + real isvent(ngs) +! + real xmascw(ngs) + real xdnmx(lc:lhab), xdnmn(lc:lhab) + real dnmx + real :: xdiamxmas(ngs,lc:lhab) +! + real cilen(ngs) ! ,ciplen(ngs) +! +! + real rwcap(ngs),swcap(ngs) + real hwcap(ngs) + real hlcap(ngs) + real cicap(ngs) + real iscap(ngs) + + real qvimxd(ngs) + real qimxd(ngs),qismxd(ngs),qcmxd(ngs),qrmxd(ngs),qsmxd(ngs),qhmxd(ngs),qhlmxd(ngs) + real cimxd(ngs),ccmxd(ngs),crmxd(ngs),csmxd(ngs),chmxd(ngs) + real cionpmxd(ngs),cionnmxd(ngs) + real clionpmxd(ngs),clionnmxd(ngs) + + + real elec(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-norz+ng1:nz+norz) ! Ez (elecsave) + +! +! + ! Hallett-Mossop arrays + real chmul1(ngs),chlmul1(ngs),csmul1(ngs),csmul(ngs) + real qhmul1(ngs),qhlmul1(ngs),qsmul1(ngs),qsmul(ngs) + + ! splinters from drop freezing + real csplinter(ngs),qsplinter(ngs) + real csplinter2(ngs),qsplinter2(ngs) +! +! +! concentration arrays... +! + real :: chlcnh(ngs), vhlcnh(ngs), vhlcnhl(ngs) + real :: chlcnhhl(ngs) ! number of new hail particles (may be different from number of lost graupel) + real cracif(ngs), ciacrf(ngs) + real cracr(ngs) + +! + real ciint(ngs), crfrz(ngs), crfrzf(ngs), crfrzs(ngs) + real cicint(ngs) + real cipint(ngs) + real ciacw(ngs), cwacii(ngs) + real ciacr(ngs), craci(ngs) + real csacw(ngs) + real csacr(ngs) + real csaci(ngs), csacs(ngs) + real cracw(ngs) + real chacw(ngs), chacr(ngs) + real :: chlacw(ngs) + real chaci(ngs), chacs(ngs) +! + real :: chlacr(ngs) + real :: chlaci(ngs), chlacs(ngs) + real crcnw(ngs) + real cidpv(ngs),cisbv(ngs) + real cisdpv(ngs),cissbv(ngs) + real cimlr(ngs),cismlr(ngs) + + real chlsbv(ngs), chldpv(ngs) + real chlmlr(ngs), chlmlrr(ngs) + real chlfmlr(ngs) +! real chlmlrsave(ngs),chlsave(ngs),qhlsave(ngs) + real chlshr(ngs), chlshrr(ngs) + + + real chdpv(ngs),chsbv(ngs) + real chmlr(ngs),chcev(ngs) + real chmlrr(ngs) + real chshr(ngs), chshrr(ngs) + + real csdpv(ngs),cssbv(ngs) + real csmlr(ngs),csmlrr(ngs),cscev(ngs) + real csshr(ngs), csshrr(ngs) + + real crcev(ngs) + real crshr(ngs) + real cwshw(ngs), qwshw(ngs) +! +! +! arrays for w-ac-x ; x-ac-w +! +! +! + real qrcnw(ngs), qwcnr(ngs) + real zrcnw(ngs),zracr(ngs),zracw(ngs),zrcev(ngs) + + + real qracw(ngs) ! qwacr(ngs), + real qiacw(ngs) !, qwaci(ngs) + + real qsacw(ngs) ! ,qwacs(ngs), + real qhacw(ngs) ! qwach(ngs), + real :: qhlacw(ngs) ! + real vhacw(ngs), vsacw(ngs), vhlacw(ngs), vhlacr(ngs) + + real qfmul1(ngs),cfmul1(ngs) +! + real qsacws(ngs) + +! +! arrays for x-ac-r and r-ac-x; +! + real qsacr(ngs),qracs(ngs) + real qhacr(ngs),qhacrmlr(ngs) ! ,qrach(ngs) + real vhacr(ngs), zhacr(ngs), zhacrf(ngs), zrach(ngs), zrachl(ngs) + real qiacr(ngs),qraci(ngs) + + real ziacr(ngs) + + real qracif(ngs),qiacrf(ngs),qiacrs(ngs),ciacrs(ngs) + + real :: qhlacr(ngs),qhlacrmlr(ngs) + real qsacrs(ngs) !,qracss(ngs) +! +! ice - ice interactions +! + real qsaci(ngs) + real qsacis(ngs) + real qhaci(ngs) + real qhacs(ngs) + + real :: qhacis(ngs) + real :: chacis(ngs) + real :: chacis0(ngs) + + real :: csaci0(ngs) ! collision rate only + real :: chaci0(ngs) ! collision rate only + real :: chacs0(ngs) ! collision rate only + real :: chlaci0(ngs) + real :: chlacis(ngs) + real :: chlacis0(ngs) + real :: chlacs0(ngs) + + real :: qsaci0(ngs) ! collision rate only + real :: qsacis0(ngs) ! collision rate only + real :: qhaci0(ngs) ! collision rate only + real :: qhacis0(ngs) ! collision rate only + real :: qhacs0(ngs) ! collision rate only + real :: qhlaci0(ngs) + real :: qhlacis0(ngs) + real :: qhlacs0(ngs) + + real :: qhlaci(ngs) + real :: qhlacis(ngs) + real :: qhlacs(ngs) +! +! conversions +! + real qrfrz(ngs) ! , qirirhr(ngs) + real zrfrz(ngs), zrfrzf(ngs), zrfrzs(ngs) + real ziacrf(ngs), zhcnsh(ngs), zhcnih(ngs) + real zhacw(ngs), zhacs(ngs), zhaci(ngs) + real zhmlr(ngs), zhdsv(ngs), zhsbv(ngs), zhlcnh(ngs), zhshr(ngs) + real zfacw(ngs), zfacs(ngs), zfaci(ngs) + real zfmlr(ngs), zfdsv(ngs), zfsbv(ngs), zhlcnf(ngs), zfshr(ngs), zfshrr(ngs) + real zhmlrtmp,zhmlr0inf,zhlmlr0inf + real zhmlrr(ngs),zhlmlrr(ngs),zhshrr(ngs),zhlshrr(ngs),zfmlrr(ngs) + real zsmlr(ngs), zsmlrr(ngs), zsshr(ngs) + real zhcns(ngs), zhcni(ngs) + real zhwdn(ngs), zfwdn(ngs) ! change in Z due to density changes + real zhldn(ngs) ! change in Z due to density changes + + real zhlacw(ngs), zhlacs(ngs), zhlacr(ngs) + real zhlmlr(ngs), zhldsv(ngs), zhlsbv(ngs), zhlshr(ngs) + + + real vrfrzf(ngs), viacrf(ngs) + real qrfrzs(ngs), qrfrzf(ngs) + real qwfrz(ngs), qwctfz(ngs) + real cwfrz(ngs), cwctfz(ngs) + real qwfrzis(ngs), qwctfzis(ngs) ! droplet freezing to ice spheres + real cwfrzis(ngs), cwctfzis(ngs) + real qwfrzc(ngs), qwctfzc(ngs) ! droplet freezing to columns + real cwfrzc(ngs), cwctfzc(ngs) + real qwfrzp(ngs), qwctfzp(ngs) ! droplet freezing to plates + real cwfrzp(ngs), cwctfzp(ngs) + real xcolmn(ngs), xplate(ngs) + real ciihr(ngs), qiihr(ngs) + real cicichr(ngs), qicichr(ngs) + real cipiphr(ngs), qipiphr(ngs) + real qscni(ngs), cscni(ngs), cscnis(ngs) + real qscnvi(ngs), cscnvi(ngs), cscnvis(ngs) + real qhcns(ngs), chcns(ngs), chcnsh(ngs), vhcns(ngs) + real qscnh(ngs), cscnh(ngs), vscnh(ngs) + real qhcni(ngs), chcni(ngs), chcnih(ngs), vhcni(ngs) + real qiint(ngs),qipipnt(ngs),qicicnt(ngs) + real cninm(ngs),cnina(ngs),cninp(ngs),wvel(ngs),wvelkm1(ngs) + real tke(ngs) + real uvel(ngs),vvel(ngs) +! + real qidpv(ngs),qisbv(ngs) ! qicnv(ngs),qievv(ngs), + real qimlr(ngs),qidsv(ngs),qisdsv(ngs),qidsvp(ngs) ! ,qicev(ngs) + real qismlr(ngs) + +! +! + real :: qhldpv(ngs), qhlsbv(ngs) ! qhlcnv(ngs),qhlevv(ngs), + real :: qhlmlr(ngs), qhldsv(ngs), qhlmlrsave(ngs) + real :: qhlwet(ngs), qhldry(ngs), qhlshr(ngs) +! + real :: qrfz(ngs),qsfz(ngs),qhfz(ngs),qhlfz(ngs) +! + real qhdpv(ngs),qhsbv(ngs) ! qhcnv(ngs),qhevv(ngs), + real qhmlr(ngs),qhdsv(ngs),qhcev(ngs),qhcndv(ngs),qhevv(ngs) + real qhlcev(ngs), chlcev(ngs) + real qhwet(ngs),qhdry(ngs),qhshr(ngs) + real qhshrp(ngs) + real qhshh(ngs) !accreted water that remains on graupel + real qhmlh(ngs) !melt water that remains on graupel + real qhfzh(ngs) !water that freezes on mixed-phase graupel + real qhlfzhl(ngs) !water that freezes on mixed-phase hail + + real qhmlrlg(ngs),qhlmlrlg(ngs) ! melting from the larger diameters + real qhfzhlg(ngs) !water that freezes on mixed-phase graupel (large sizes) + real qhlfzhllg(ngs) !water that freezes on mixed-phase hail (large sizes) + real qhlcevlg(ngs), chlcevlg(ngs) + real qhcevlg(ngs), chcevlg(ngs) + + real vhfzh(ngs), vffzf(ngs) ! change in volume from water that freezes on mixed-phase graupel, frozen drops + real vhlfzhl(ngs) ! change in volume from water that freezes on mixed-phase hail + + real vhshdr(ngs) !accreted water that leaves on graupel (mixedphase) + real vhlshdr(ngs) !accreted water that leaves on hail (mixedphase) + real vhmlr(ngs) !melt water that leaves graupel (single phase) + real vhlmlr(ngs) !melt water that leaves hail (single phase) + real vhsoak(ngs) ! aquired water that seeps into graupel. + real vhlsoak(ngs) ! aquired water that seeps into hail. + +! + real qsdpv(ngs),qssbv(ngs) ! qscnv(ngs),qsevv(ngs), + real qsmlr(ngs),qsdsv(ngs),qscev(ngs),qscndv(ngs),qsevv(ngs) + real qswet(ngs),qsdry(ngs),qsshr(ngs) + real qsshrp(ngs) + real qsfzs(ngs) +! +! + real qipdpv(ngs),qipsbv(ngs) + real qipmlr(ngs),qipdsv(ngs) +! + real qirdpv(ngs),qirsbv(ngs) + real qirmlr(ngs),qirdsv(ngs),qirmlw(ngs) +! + real qgldpv(ngs),qglsbv(ngs) + real qglmlr(ngs),qgldsv(ngs) + real qglwet(ngs),qgldry(ngs),qglshr(ngs) + real qglshrp(ngs) +! + real qgmdpv(ngs),qgmsbv(ngs) + real qgmmlr(ngs),qgmdsv(ngs) + real qgmwet(ngs),qgmdry(ngs),qgmshr(ngs) + real qgmshrp(ngs) + real qghdpv(ngs),qghsbv(ngs) + real qghmlr(ngs),qghdsv(ngs) + real qghwet(ngs),qghdry(ngs),qghshr(ngs) + real qghshrp(ngs) +! + real qrztot(ngs),qrzmax(ngs),qrzfac(ngs) + real qrcev(ngs) + real qrshr(ngs) + real fsw(ngs),fhw(ngs),fhlw(ngs),ffw(ngs) !liquid water fractions + real fswmax(ngs),fhwmax(ngs),fhlwmax(ngs) !liquid water fractions + real qhcnf(ngs) + real :: qhlcnh(ngs) + real qhcngh(ngs),qhcngm(ngs),qhcngl(ngs) + + real :: qhcnhl(ngs), chcnhl(ngs), zhcnhl(ngs), vhcnhl(ngs) ! conversion of low-density hail back to graupel + + real eiw(ngs),eii(ngs),eiri(ngs),eipir(ngs),eisw(ngs) + real erw(ngs),esw(ngs),eglw(ngs),eghw(ngs),efw(ngs) + real ehxw(ngs),ehlw(ngs),egmw(ngs),ehw(ngs) + real err(ngs),esr(ngs),eglr(ngs),eghr(ngs),efr(ngs) + real ehxr(ngs),ehlr(ngs),egmr(ngs) + real eri(ngs),esi(ngs),egli(ngs),eghi(ngs),efi(ngs),efis(ngs) + real ehxi(ngs),ehli(ngs),egmi(ngs),ehi(ngs),ehis(ngs),ehlis(ngs) + real ers(ngs),ess(ngs),egls(ngs),eghs(ngs),efs(ngs),ehs(ngs) + real ehscnv(ngs) + real ehxs(ngs),ehls(ngs),egms(ngs),egmip(ngs) + + real ehsclsn(ngs),ehiclsn(ngs),ehisclsn(ngs) + real efsclsn(ngs),eficlsn(ngs),efisclsn(ngs) + real ehlsclsn(ngs),ehliclsn(ngs),ehlisclsn(ngs) + real esiclsn(ngs) + + real :: ehs_collsn = 0.5, ehi_collsn = 1.0 + real :: efs_collsn = 0.5, efi_collsn = 1.0 + real :: ehls_collsn = 1.0, ehli_collsn = 1.0 + real :: esi_collsn = 1.0 + + real ew(8,6) + real cwr(8,2) ! radius and inverse of interval + data cwr / 2.0, 3.0, 4.0, 6.0, 8.0, 10.0, 15.0, 20.0 , & ! radius + & 1.0, 1.0, 0.5, 0.5, 0.5, 0.2, 0.2, 1. / ! inverse of interval + integer icwr(ngs), igwr(ngs), irwr(ngs), ihlr(ngs), ifwr(ngs) + real grad(6,2) ! graupel radius and inverse of interval + data grad / 100., 200., 300., 400., 600., 1000., & + & 1.e-2,1.e-2,1.e-2,5.e-3,2.5e-3, 1. / +!droplet radius: 2 3 4 6 8 10 15 20 + data ew /0.03, 0.07, 0.17, 0.41, 0.58, 0.69, 0.82, 0.88, & ! 100 +! : 0.07, 0.13, 0.27, 0.48, 0.65, 0.73, 0.84, 0.91, ! 150 + & 0.10, 0.20, 0.34, 0.58, 0.70, 0.78, 0.88, 0.92, & ! 200 + & 0.15, 0.31, 0.44, 0.65, 0.75, 0.83, 0.96, 0.91, & ! 300 + & 0.17, 0.37, 0.50, 0.70, 0.81, 0.87, 0.93, 0.96, & ! 400 + & 0.17, 0.40, 0.54, 0.71, 0.83, 0.88, 0.94, 0.98, & ! 600 + & 0.15, 0.37, 0.52, 0.74, 0.82, 0.88, 0.94, 0.98 / ! 1000 +! : 0.11, 0.34, 0.49, 0.71, 0.83, 0.88, 0.94, 0.95 / ! 1400 + + + real da0lr(ngs),da1lr(ngs) + real da0lc(ngs),da1lc(ngs) + real da0lh(ngs) + real da0lhl(ngs) + real da0lf(ngs) + real :: da0lx(ngs,lr:lhab) + + real va0 (lc:lqmx) ! collection coefficients from Seifert 2005 + real vab0(lc:lqmx,lc:lqmx) ! collection coefficients from Seifert 2005 + real vab1(lc:lqmx,lc:lqmx) ! collection coefficients from Seifert 2005 + real va1 (lc:lqmx) ! collection coefficients from Seifert 2005 + real ehip(ngs),ehlip(ngs),ehlir(ngs) + real erir(ngs),esir(ngs),eglir(ngs),egmir(ngs),eghir(ngs) + real efir(ngs),ehir(ngs),eirw(ngs),eirir(ngs),ehr(ngs) + real erip(ngs),esip(ngs),eglip(ngs),eghip(ngs) + real efip(ngs),eipi(ngs),eipw(ngs),eipip(ngs) +! +! arrays for production terms +! + real ptotal(ngs) ! , pqtot(ngs) +! + real pqcwi(ngs),pqcii(ngs),pqrwi(ngs),pqisi(ngs) + real pqswi(ngs),pqhwi(ngs),pqwvi(ngs) + real pqgli(ngs),pqghi(ngs),pqfwi(ngs) + real pqgmi(ngs),pqhli(ngs) ! ,pqhxi(ngs) + real pqiri(ngs),pqipi(ngs) ! pqwai(ngs), + real pqlwsi(ngs),pqlwhi(ngs),pqlwhli(ngs) + + real pqlwlghi(ngs),pqlwlghli(ngs) + real pqlwlghd(ngs),pqlwlghld(ngs) + + + + real pvhwi(ngs), pvhwd(ngs) + real pvfwi(ngs), pvfwd(ngs) + real pvhli(ngs), pvhld(ngs) + real pvswi(ngs), pvswd(ngs) +! + real pqcwd(ngs),pqcid(ngs),pqrwd(ngs),pqisd(ngs), pqcwdacc(ngs) + real pqswd(ngs),pqhwd(ngs),pqwvd(ngs) + real pqgld(ngs),pqghd(ngs),pqfwd(ngs) + real pqgmd(ngs),pqhld(ngs) ! ,pqhxd(ngs) + real pqird(ngs),pqipd(ngs) ! pqwad(ngs), + real pqlwsd(ngs),pqlwhd(ngs),pqlwhld(ngs) +! +! real pqxii(ngs,nhab),pqxid(ngs,nhab) +! + real pctot(ngs) + real pcipi(ngs), pcipd(ngs) + real pciri(ngs), pcird(ngs) + real pccwi(ngs), pccwd(ngs), pccwdacc(ngs) + real pccii(ngs), pccid(ngs) + real pcisi(ngs), pcisd(ngs) + real pccin(ngs) + real pcrwi(ngs), pcrwd(ngs) + real pcswi(ngs), pcswd(ngs) + real pchwi(ngs), pchwd(ngs) + real pchli(ngs), pchld(ngs) + real pcfwi(ngs), pcfwd(ngs) + real pcgli(ngs), pcgld(ngs) + real pcgmi(ngs), pcgmd(ngs) + real pcghi(ngs), pcghd(ngs) + + real pzrwi(ngs), pzrwd(ngs) + real pzhwi(ngs), pzhwd(ngs) + real pzfwi(ngs), pzfwd(ngs) + real pzhli(ngs), pzhld(ngs) + real pzswi(ngs), pzswd(ngs) + +! +! other arrays +! + real dqisdt(ngs) !,advisc(ngs) !dqwsdt(ngs), ,schm(ngs),pndl(ngs) + + real qss0(ngs) + + real qsacip(ngs) + real pres(ngs),pipert(ngs) + real pk(ngs) + real rho0(ngs),pi0(ngs) + real rhovt(ngs),sqrtrhovt + real thetap(ngs),theta0(ngs),qwvp(ngs),qv0(ngs) + real thsave(ngs) + real ptwfzi(ngs),ptimlw(ngs) + real psub(ngs),pvap(ngs),pfrz(ngs),ptem(ngs),pmlt(ngs),pevap(ngs),pdep(ngs),ptem2(ngs) + + real cnostmp(ngs) ! for diagnosed snow intercept +! +! iholef = 1 to do hole filling technique version 1 +! which uses all hydrometerors to do hole filling of all hydrometeors +! iholef = 2 to do hole filling technique version 2 +! which uses an individual hydrometeror species to do hole +! filling of a species of a hydrometeor +! +! iholen = interval that hole filling is done +! + integer iholef + integer iholen + parameter (iholef = 1) + parameter (iholen = 1) + real cqtotn,cqtotn1 + real cctotn + real citotn + real crtotn + real cstotn + real cvtotn + real cftotn + real cgltotn + real cghtotn + real chtotn + real cqtotp,cqtotp1 + real cctotp + real citotp + real ciptotp + real crtotp + real cstotp + real cvtotp + real cftotp + real chltotp + real cgltotp + real cgmtotp + real cghtotp + real chtotp + real cqfac + real ccfac + real cifac + real cipfac + real crfac + real csfac + real cvfac + real cffac + real cglfac + real cghfac + real chfac + + real ssifac, qvapor +! +! Miscellaneous variables +! + real, parameter :: cwmas30 = 1000.*0.523599*(2.*30.e-6)**3 ! mass of 30-micron radius droplet, for sat. adj. + real, parameter :: cwmas20 = 1000.*0.523599*(2.*20.e-6)**3 ! mass of 20-micron radius droplet, for sat. adj. + integer ireadqf,lrho,lqsw,lqgl,lqgm ,lqgh + integer lqrw + real vt + real arg ! gamma is a function + real erbnd1, fdgt1, costhe1 + real qeps + real dyi2,dzi2,bta1,cnit,dragh,dnz00,pii ! ,cp608 + real qccrit,gf4br,gf4ds,gf4p5, gf3ds, gf1ds + real gf1palp(ngs) ! for storing Gamma[1.0 + alphar] + + + real xdn0(lc:lhab) + real xdn_new,drhodt + + integer l ,ltemq,inumgs, idelq + + real brz,arz,temq + + real ssival,tqvcon + real cdx(lc:lhab) + real cnox + real cval,aval,eval,fval,gval ,qsign,ftelwc,qconkq,elecfac,altelecfac + real qconm,qconn,cfce15,gf8,gf4i,gf3p5,gf1a,gf1p5,qdiff,argrcnw + real c4,bradp,bl2,bt2,dthr,hrifac, hdia0,hdia1,civenta,civentb + real civentc,civentd,civente,civentf,civentg,cireyn,xcivent + real cipventa,cipventb,cipventc,cipventd,cipreyn,cirventa + real cirventb + integer igmrwa,igmrwb,igmswa, igmswb,igmfwa,igmfwb,igmhwa,igmhwb + real rwventa ,rwventb,swventa,swventb,fwventa,fwventb,fwventc + real hwventa,hwventb + real hwventc, hlventa, hlventb, hlventc + real glventa, glventb, glventc + real gmventa, gmventb, gmventc, ghventa, ghventb, ghventc + real dzfacp, dzfacm, cmassin, cwdiar + real rimmas, rhobar + real argtim, argqcw, argqxw, argtem + real frcswsw, frcswgl, frcswgm, frcswgh, frcswfw, frcswsw1 + real frcglgl, frcglgm, frcglgh, frcglfw, frcglgl1 + real frcgmgl, frcgmgm, frcgmgh, frcgmfw, frcgmgm1 + real frcghgl, frcghgm, frcghgh, frcghfw, frcghgh1 + real frcfwgl, frcfwgm, frcfwgh, frcfwfw, frcfwfw1 + real frcswrsw, frcswrgl, frcswrgm, frcswrgh, frcswrfw + real frcswrsw1 + real frcrswsw, frcrswgl, frcrswgm, frcrswgh, frcrswfw + real frcrswsw1 + real frcglrgl, frcglrgm, frcglrgh, frcglrfw, frcglrgl1 + real frcrglgl + real frcrglgm, frcrglgh, frcrglfw, frcrglgl1 + real frcgmrgl, frcgmrgm, frcgmrgh, frcgmrfw, frcgmrgm1 + real frcrgmgl, frcrgmgm, frcrgmgh, frcrgmfw, frcrgmgm1 + real sum, qweps, gf2a, gf4a, dqldt, dqidt, dqdt + real frcghrgl, frcghrgm, frcghrgh, frcghrfw, frcghrgh1, frcrghgl + real frcrghgm, frcrghgh, frcrghfw, frcrghgh1 + real a1,a2,a3,a4,a5,a6 + real gamss + real cdw, cdi, denom1, denom2, delqci1, delqip1 + real cirtotn, ciptotn, cgmtotn, chltotn, cirtotp + real cgmfac, chlfac, cirfac + integer igmhla, igmhlb, igmgla, igmglb, igmgma, igmgmb + integer igmgha, igmghb + integer idqis, item, itim0 + integer iqgl, iqgm, iqgh, iqrw, iqsw + integer itertd, ia + + integer :: infdo + + real tau, ewtmp + + integer cntnic_noliq + real q_noliqmn, q_noliqmx + real scsacimn, scsacimx + + real :: dtpinv + +! arrays for temporary bin space + + real :: xden,xmlt,cmlt,cmlttot,fventm,fventh,am,ah,felfinv,dmwdt + + real :: qhmlrtmp,qhmlrtmp2, chmlrtmp, chmlrtmpd1inf, chlmlrtmp, zhlmlrtmp, zhlmlrrtmp, qvs0,tmpcmlt + + real :: term1,term2,term3,term4 + real :: qaacw ! combined qsacw-qhacw for WSM6 variation + + + +! +! #################################################################### +! +! Start routine +! +! #################################################################### + + + +! + + pb(:) = 0.0 + pinit(:) = 0.0 + itile = nx + jtile = ny + ktile = nz + ixend = nx + jyend = ny + kzend = nz + nxend = nx + 1 + nyend = ny + 1 + nzend = nz + kzbeg = 1 + nzbeg = 1 + + istag = 0 + jstag = 0 + kstag = 1 + + + +! +! slope intercepts +! + + IF ( ngs .lt. nz ) THEN +! write(0,*) 'Error in ICEZVD: Must have ngs .ge. nz!' +! STOP + ENDIF + + cntnic_noliq = 0 + q_noliqmn = 0.0 + q_noliqmx = 0.0 + scsacimn = 0.0 + scsacimx = 0.0 + + ldovol = .false. + + DO il = lc,lhab + ldovol = ldovol .or. ( lvol(il) .gt. 1 ) + ENDDO + + + ffrzh = 1 +! DO il = lc,lhab +! write(iunit,*) 'delqnxa(',il,') = ',delqnxa(il) +! ENDDO + +! +! density maximums and minimums +! + +! +! Set terminal velocities... +! also set drag coefficients +! + + dtpinv = 1.d0/dtp + +! + +! +! electricity constants +! +! mixing ratio epsilon +! + qeps = 1.0e-20 + +! rebound efficiency (erbnd) +! +! +! +! constants +! + +! cp608 = 0.608 + aradcw = -0.27544 + bradcw = 0.26249e+06 + cradcw = -1.8896e+10 + dradcw = 4.4626e+14 + bta1 = 0.6 + cnit = 1.0e-02 + dragh = 0.60 + dnz00 = 1.225 +! cs = 4.83607122 +! ds = 0.25 +! new values for cs and ds + cs = 12.42 + ds = 0.42 + pii = piinv ! 1./pi + pid4 = pi/4.0 +! qscrit = 6.0e-04 + gf1 = 1.0 ! gamma(1.0) + gf1p5 = 0.8862269255 ! gamma(1.5) + gf2 = 1.0 ! gamma(2.0) + gf3 = 2.0 ! gamma(3.0) + gf3p5 = 3.32335097 ! gamma(3.5) + gf4 = 6.00 ! gamma(4.0) + gf5 = 24.0 ! gamma(5.0) + gf6 = 120.0 ! gamma(6.0) + gf7 = 720.0 ! gamma(7.0) + gf4br = 17.837861981813607 ! gamma(4.0+br) + gf4ds = 10.41688578110938 ! gamma(4.0+ds) + gf4p5 = 11.63172839656745 ! gamma(4.0+0.5) + gf3ds = 3.0458730354120997 ! gamma(3.0+ds) + gf1ds = 0.8863557896089221 ! gamma(1.0+ds) + + gf43rds = 0.8929795116 ! gamma(4./3.) + gf53rds = 0.9027452930 ! gamma(5./3.) + gf73rds = 1.190639349 ! gamma(7./3.) + gf83rds = 1.504575488 ! gamma(8./3.) + + gamice73fac = (Gamma_sp(7./3. + cinu))**3/ (Gamma_sp(1. + cinu)**3 * (1. + cinu)**4) + gamsnow73fac = (Gamma_sp(7./3. + snu))**3/ (Gamma_sp(1. + snu)**3 * (1. + snu)**4) + +! gcnup1 = Gamma_sp(cnu + 1.) +! gcnup2 = Gamma_sp(cnu + 2.) +! +! constants +! +! +! general constants for microphysics +! + brz = 100.0 + arz = 0.66 + + bfnu1 = (4. + alphar)*(5. + alphar)*(6. + alphar)/ & + & ((1. + alphar)*(2. + alphar)*(3. + alphar)) + + galpharaut = (6.+alpharaut)*(5.+alpharaut)*(4.+alpharaut)/ & + & ((3.+alpharaut)*(2.+alpharaut)*(1.+alpharaut)) + + vfrz = 0.523599*(dfrz)**3 + vmlt = Min(xvmx(lr), 0.523599*(dmlt)**3 ) + vshd = Min(xvmx(lr), 0.523599*(dshd)**3 ) + + snowmeltmass = pi/6.0 * 1000. * snowmeltdia**3 ! maximum rain particle mass from melting snow (if snowmeltdia > 0) + + tdtol = 1.0e-05 + tfrcbw = tfr - cbw + tfrcbi = tfr - cbi +! +! +! #ifdef COMMAS +! print*,'ventr,ventc = ',ventr,ventc + +! +! Set up look up tables for supersaturation w.r.t. liq and ice +! +!VD$L SKIP +! do l = 1,nqsat +! temq = 163.15 + (l-1)*fqsat +! tabqvs(l) = exp(caw*(temq-273.15)/(temq-cbw)) +! tabqis(l) = exp(cai*(temq-273.15)/(temq-cbi)) +! end do + + mltmass0inv = 1.0/( 1000.0* xvmx(lr) ) ! for drops melting from ice with diameter > 1.9cm + mltmass1inv = 1.0/( 1000.0*(4.0*pi/3.0)*((0.01*0.5*takshedsize1)**3) ) ! for drops melting from ice with diameter > 1.9cm; 0.01 converts cm to m, 0.5 conv. diam to radius + mltmass2inv = 1.0/( 1000.0*(4.0*pi/3.0)*((0.01*0.5*takshedsize2)**3) ) ! for drops melting from ice with 0.9cm < d < 1.9cm (or 1.6cm to 1.9cm) + mltmass3inv = 1.0/( 1000.0*(4.0*pi/3.0)*((0.01*0.5*takshedsize3)**3) ) ! for drops melting from ice with 0.9cm < d < 1.6cm + mltmass1cgs = 1.0*(4.0*pi/3.0)*((0.5*takshedsize1)**3) + mltmass2cgs = 1.0*(4.0*pi/3.0)*((0.5*takshedsize2)**3) + mltmass3cgs = 1.0*(4.0*pi/3.0)*((0.5*takshedsize3)**3) + +! real, parameter :: mltdiam1 = 9.0e-3, mltdiam2 = 19.0e-3, mltdiam05 = 4.5e-3 + + IF ( ibinnum == 1 ) THEN + numdiam = 1 ! must have numdiam < ndiam because numdiam+1 holds values for the interval of mltdiam(numdiam) to mltdiam(ndiam+1) + mltdiam(1) = 4.5e-3 + ELSEIF ( ibinnum == 2 ) THEN + numdiam = 2 ! must have numdiam < ndiam because numdiam+1 holds values for the interval of mltdiam(numdiam) to mltdiam(ndiam+1) + mltdiam(1) = mltdiam1/6. ! 1.5e-3 + mltdiam(2) = mltdiam1/2. ! 4.5e-3 + ELSEIF ( ibinnum > 2 ) THEN + numdiam = Min(ibinnum, ndiam) + DO k = 1,numdiam + mltdiam(k) = (k - 0.5)*mltdiam1/float(numdiam) + ENDDO + + ELSE + numdiam = 5 ! must have numdiam < ndiam because numdiam+1 holds values for the interval of mltdiam(numdiam) to mltdiam(ndiam+1) + mltdiam(1) = 0.5e-3 + mltdiam(2) = 1.0e-3 + mltdiam(3) = 2.0e-3 + mltdiam(4) = 4.0e-3 + mltdiam(5) = 6.0e-3 + ENDIF + + + IF ( numshedregimes == 2 ) THEN + mltdiam(ndiam+1) = mltdiam1 ! 9.0e-3 + mltdiam(ndiam+2) = mltdiam3 ! 19.0e-3 + mltdiam(ndiam+3) = mltdiam4 !100.0e-3 + ELSEIF ( numshedregimes == 3 ) THEN + mltdiam(ndiam+1) = mltdiam1 ! 9.0e-3 + mltdiam(ndiam+2) = mltdiam2 ! 16.0e-3 + mltdiam(ndiam+3) = mltdiam3 ! 19.0e-3 + mltdiam(ndiam+4) = mltdiam4 !200.0e-3 + ENDIF + + kzb = 1 + kze = ktile +! if (kzend .eq. nzend) kze = kzend-kzbeg+1-kstag + +! +! cw constants in mks units +! +! cwmasn = 4.25e-15 ! radius of 1.0e-6 + mwfac = 6.0**(1./3.) + IF ( ipconc .ge. 2 ) THEN +! cwmasn = xvmn(lc)*1000. +! cwradn = 1.0e-6 +! cwmasx = xvmx(lc)*1000. + ENDIF + rwmasn = xvmn(lr)*1000. + rwmasx = xvmx(lr)*1000. + + IF ( biggsnowdiam > 0.0 ) THEN + xvbiggsnow = (pi/6.0)*biggsnowdiam**3 + ELSE + xvbiggsnow = xvmn(lh) + ENDIF + +! +! ci constants in mks units +! + cimasn = Min(cimas0, cimas1) ! 12 microns for 0.1871*(xmas(mgs,li)**(0.3429)) + cimasx = 1.0e-8 ! 338 microns + ccimx = 5000.0e3 ! max of 5000 per liter + +! +! constants for paramerization +! +! +! set save counter (number of saves): nsvcnt +! +! nsvcnt = 0 + iend = 0 + + +! timetd1 = etime(tarray) +! timetd1 = tarray(1) + +! +!*********************************************************** +! start jy loop +!*********************************************************** +! + +! do 9999 jy = 1,ny-jstag +! +! VERY IMPORTANT: SET jy = jgs +! + jy = jgs + + +! t1(:,:,:) = 0 +! t2(:,:,:) = 0 +! t3(:,:,:) = 0 +! t4(:,:,:) = 0 +! t5(:,:,:) = 0 +! t6(:,:,:) = 0 +! t8(:,:,:) = 0 + + IF ( ipconc < 2 ) THEN ! Make a copy of cloud droplet mixing ratio to use for homogeneous freezing + DO kz = 1,kze + DO ix = 1,itile + t9(ix,jy,kz) = an(ix,jy,kz,lc) + ENDDO + ENDDO + ENDIF + +! +!..Gather microphysics +! + if ( ndebug .gt. 0 ) write(0,*) 'ICEZVD_GS: ENTER GATHER STAGE' + + + + nxmpb = 1 + nzmpb = 1 + nxz = itile*nz + numgs = nxz/ngs + 1 +! write(0,*) 'ICEZVD_GS: ENTER GATHER STAGE: nx,nz,nxz,numgs,ngs = ',nx,nz,nxz,numgs,ngs + + do 1000 inumgs = 1,numgs + ngscnt = 0 + + do kz = nzmpb,kze + do ix = nxmpb,itile + + pqs(1) = t00(ix,jy,kz) +! pqs(kz) = t00(ix,jy,kz) + + theta(1) = an(ix,jy,kz,lt) + temg(1) = t0(ix,jy,kz) + temcg(1) = temg(1) - tfr + tqvcon = temg(1)-cbw + ltemq = (temg(1)-163.15)/fqsat+1.5 + ltemq = Min( nqsat, Max(1,ltemq) ) + qvs(1) = pqs(1)*tabqvs(ltemq) + qis(1) = pqs(1)*tabqis(ltemq) + + qss(1) = qvs(1) + +! IF ( jy .eq. 1 .and. ix .eq. 24 ) THEN +! write(91,*) 'kz,qv,th: ',kz,an(ix,jy,kz,lv),an(ix,jy,kz,lt),pqs(kz),tabqvs(ltemq),qvs(kz) +! ENDIF + + if ( temg(1) .lt. tfr ) then +! if( qcw(kz) .le. qxmin(lc) .and. qci(kz) .gt. qxmin(li)) +! > qss(kz) = qis(kz) +! if( qcw(kz) .gt. qxmin(lc) .and. qci(kz) .gt. qxmin(li)) +! > qss(kz) = (qcw(kz)*qvs(kz) + qci(kz)*qis(kz)) / +! > (qcw(kz) + qci(kz)) + qss(1) = qis(1) + else +! IF ( an(ix,jy,kz,lv) .gt. qss(kz) ) THEN +! write(iunit,*) 'qss exceeded at ',ix,jy,kz,qss(kz),an(ix,jy,kz,lv),temg(kz) +! write(iunit,*) 'other temg = ',theta(kz)*(pinit(kz)+p2(ix,jy,kz)) +! ENDIF + end if +! + ishail = .false. + IF ( lhl > 1 ) THEN + IF ( an(ix,jy,kz,lhl) .gt. qxmin(lhl) ) ishail = .true. + ENDIF + + + + if ( an(ix,jy,kz,lv) .gt. qss(1) .or. & + & an(ix,jy,kz,lc) .gt. qxmin(lc) .or. & + & an(ix,jy,kz,li) .gt. qxmin(li) .or. & + & an(ix,jy,kz,lr) .gt. qxmin(lr) .or. & + & an(ix,jy,kz,ls) .gt. qxmin(ls) .or. & + & an(ix,jy,kz,lh) .gt. qxmin(lh) .or. ishail ) then + ngscnt = ngscnt + 1 + igs(ngscnt) = ix + kgs(ngscnt) = kz + if ( ngscnt .eq. ngs ) goto 1100 + end if + enddo !ix + nxmpb = 1 + enddo !kz + 1100 continue + + if ( ngscnt .eq. 0 ) go to 9998 + + if ( ndebug .gt. 0 ) write(0,*) 'ICEZVD_GS: dbg = 5, ngscnt = ',ngscnt + +! write(0,*) 'allocating qc' + + + xv(:,:) = 0.0 + xmas(:,:) = 0.0 + vtxbar(:,:,:) = 0.0 + xdia(:,:,:) = 0.0 + raindn(:,:) = 900. + cx(:,:) = 0.0 + IF ( lnhf > 1 .or. lnhlf > 1 ) chxf(:,:) = 0.0 + alpha(:,:) = 0.0 + DO il = li,lhab + DO mgs = 1,ngscnt + rimdn(mgs,il) = rimedens ! xdn0(il) + ENDDO + ENDDO +! +! define temporaries for state variables to be used in calculations +! + if ( ndebug .gt. 0 ) write(0,*) 'ICEZVD_GS: dbg = def temps' + do mgs = 1,ngscnt + kgsm(mgs) = max(kgs(mgs)-1,1) + kgsp(mgs) = min(kgs(mgs)+1,nz-1) + kgsm2(mgs) = Max(kgs(mgs)-2,1) + theta0(mgs) = an(igs(mgs),jy,kgs(mgs),lt) + thetap(mgs) = an(igs(mgs),jy,kgs(mgs),lt) - theta0(mgs) + theta(mgs) = an(igs(mgs),jy,kgs(mgs),lt) + qv0(mgs) = an(igs(mgs),jy,kgs(mgs),lv) + qwvp(mgs) = an(igs(mgs),jy,kgs(mgs),lv) - qv0(mgs) ! qv0(mgs) is full qv, so qwvp starts as zero! + + pres(mgs) = pn(igs(mgs),jy,kgs(mgs)) + pb(kgs(mgs)) + pipert(mgs) = p2(igs(mgs),jy,kgs(mgs)) + rho0(mgs) = dn(igs(mgs),jy,kgs(mgs)) + rhoinv(mgs) = 1.0/rho0(mgs) + rhovt(mgs) = Sqrt(rho00/Max(0.05,rho0(mgs))) ! prevent excessive rhovt + pi0(mgs) = p2(igs(mgs),jy,kgs(mgs)) + pinit(kgs(mgs)) + temg(mgs) = t0(igs(mgs),jy,kgs(mgs)) + temgkm1(mgs) = t0(igs(mgs),jy,kgsm(mgs)) + temgkm2(mgs) = t0(igs(mgs),jy,kgsm2(mgs)) + pk(mgs) = p2(igs(mgs),jy,kgs(mgs)) + pinit(kgs(mgs)) ! t77(igs(mgs),jy,kgs(mgs)) + temcg(mgs) = temg(mgs) - tfr + qss0(mgs) = (380.0)/(pres(mgs)) + pqs(mgs) = (380.0)/(pres(mgs)) + ltemq = (temg(mgs)-163.15)/fqsat+1.5 + ltemq = Min( nqsat, Max(1,ltemq) ) + qvs(mgs) = pqs(mgs)*tabqvs(ltemq) + qis(mgs) = pqs(mgs)*tabqis(ltemq) + qss(mgs) = qvs(mgs) +! es(mgs) = 6.1078e2*tabqvs(ltemq) +! eis(mgs) = 6.1078e2*tabqis(ltemq) + cnostmp(mgs) = cno(ls) +! + + il5(mgs) = 0 + if ( temg(mgs) .lt. tfr ) then + il5(mgs) = 1 + end if + enddo !mgs + + IF ( ipconc < 1 .and. lwsm6 ) THEN + DO mgs = 1,ngscnt + tmp = Min( 0.0, temcg(mgs) ) + cnostmp(mgs) = Min( 2.e8, 2.e6*exp(0.12*tmp) ) + ENDDO + ENDIF + + +! +! zero arrays that are used but not otherwise set (tm) +! + do mgs = 1,ngscnt + qhshr(mgs) = 0.0 + end do +! +! set temporaries for microphysics variables +! + DO il = lv,lhab + do mgs = 1,ngscnt + qx(mgs,il) = max(an(igs(mgs),jy,kgs(mgs),il), 0.0) + ENDDO + end do + + qxw(:,:) = 0.0 + qxwlg(:,:) = 0.0 + + + + scx(:,:) = 0.0 +! +! set shape parameters +! + IF ( imurain == 1 ) THEN + alpha(:,lr) = alphar + ELSEIF ( imurain == 3 ) THEN + alpha(:,lr) = xnu(lr) + ENDIF + + alpha(:,li) = xnu(li) + alpha(:,lc) = xnu(lc) + + IF ( imusnow == 1 ) THEN + alpha(:,ls) = alphas + ELSEIF ( imusnow == 3 ) THEN + alpha(:,ls) = xnu(ls) + ENDIF + + DO il = lr,lhab + do mgs = 1,ngscnt + IF ( il .ge. lg ) alpha(mgs,il) = dnu(il) + + + DO ic = lc,lhab + dab0lh(mgs,il,ic) = dab0(il,ic) ! dab0(ic,il) + dab1lh(mgs,il,ic) = dab1(il,ic) ! dab1(ic,il) + ENDDO + ENDDO + end do + + +! DO mgs = 1,ngscnt + DO il = lr,lhab + da0lx(:,il) = da0(il) + ENDDO + da0lh(:) = da0(lh) + da0lr(:) = da0(lr) + da1lr(:) = da1(lr) + da0lc(:) = da0(lc) + da1lc(:) = da1(lc) + + + IF ( lzh < 1 .or. lzhl < 1 ) THEN + rzxhlh(:) = rzhl/rz + ELSEIF ( lzh > 1 .and. lzhl > 1 ) THEN + rzxhlh(:) = 1. + ENDIF + IF ( lzr > 1 ) THEN + rzxh(:) = 1. + rzxhl(:) = 1. + ELSE + rzxh(:) = rz + rzxhl(:) = rzhl + ENDIF + + IF ( imurain == 1 .and. imusnow == 3 .and. lzr < 1 ) THEN + rzxs(:) = rzs + ELSEIF ( imurain == imusnow .or. lzr > 1 ) THEN + rzxs(:) = 1. + ENDIF + ! ENDDO + + IF ( lhl .gt. 1 ) THEN + DO mgs = 1,ngscnt + da0lhl(mgs) = da0(lhl) + ENDDO + ENDIF + + ventrx(:) = ventr + ventrxn(:) = ventrn + gf1palp(:) = gamma_sp(1.0 + alphar) + +! +! set concentrations +! +! ssmax = 0.0 + + + if ( ndebug .gt. 0 .and. my_rank>=0 ) write(0,*) 'ICEZVD_GS: dbg = 5b' + + if ( ipconc .ge. 1 ) then + do mgs = 1,ngscnt + cx(mgs,li) = Max(an(igs(mgs),jy,kgs(mgs),lni), 0.0) + IF ( qx(mgs,li) .le. qxmin(li) ) THEN + cx(mgs,li) = 0.0 + ENDIF + + IF ( lcina .gt. 1 ) THEN + cina(mgs) = an(igs(mgs),jy,kgs(mgs),lcina) + ELSE + cina(mgs) = cx(mgs,li) + ENDIF + IF ( lcin > 1 ) THEN + ccin(mgs) = an(igs(mgs),jy,kgs(mgs),lcin) + ENDIF + end do + end if + if ( ipconc .ge. 2 ) then + do mgs = 1,ngscnt + cx(mgs,lc) = Max(an(igs(mgs),jy,kgs(mgs),lnc), 0.0) +! cx(mgs,lc) = Min( ccwmx, cx(mgs,lc) ) + IF ( qx(mgs,lc) .le. qxmin(lc) ) THEN + cx(mgs,lc) = 0.0 + ENDIF + IF ( lss > 1 ) THEN + ssmax(mgs) = an(igs(mgs),jy,kgs(mgs),lss) + ENDIF + IF ( lccn .gt. 1 ) THEN + ccnc(mgs) = an(igs(mgs),jy,kgs(mgs),lccn) + ELSE + ccnc(mgs) = 0.0 + ENDIF + IF ( lccna .gt. 1 ) THEN + ccna(mgs) = an(igs(mgs),jy,kgs(mgs),lccna) + ELSE + ccna(mgs) = cx(mgs,lc) + ENDIF + end do +! ELSE +! cx(mgs,lc) = Abs(ccn) + end if + if ( ipconc .ge. 3 ) then + do mgs = 1,ngscnt + cx(mgs,lr) = Max(an(igs(mgs),jy,kgs(mgs),lnr), 0.0) + IF ( qx(mgs,lr) .le. qxmin(lr) ) THEN +! cx(mgs,lr) = 0.0 + ELSEIF ( cx(mgs,lr) .eq. 0.0 .and. qx(mgs,lr) .lt. 3.0*qxmin(lr) ) THEN + qx(mgs,lv) = qx(mgs,lv) + qx(mgs,lr) + qx(mgs,lr) = 0.0 + ELSE + cx(mgs,lr) = Max( 1.e-9, cx(mgs,lr) ) + ENDIF + end do + end if + if ( ipconc .ge. 4 ) then + do mgs = 1,ngscnt + cx(mgs,ls) = Max(an(igs(mgs),jy,kgs(mgs),lns), 0.0) + IF ( qx(mgs,ls) .le. qxmin(ls) ) THEN +! cx(mgs,ls) = 0.0 + ELSEIF ( cx(mgs,ls) .eq. 0.0 .and. qx(mgs,ls) .lt. 3.0*qxmin(ls) ) THEN + qx(mgs,lv) = qx(mgs,lv) + qx(mgs,ls) + qx(mgs,ls) = 0.0 + ELSE + cx(mgs,ls) = Max( 1.e-9, cx(mgs,ls) ) + + IF ( ilimit .ge. ipc(ls) ) THEN + tmp = (xdn0(ls)*cx(mgs,ls))/(rho0(mgs)*qx(mgs,ls)) + tmp2 = (tmp*(3.14159))**(1./3.) + cnox = cx(mgs,ls)*(tmp2) + IF ( cnox .gt. 3.0*cno(ls) ) THEN + cx(mgs,ls) = 3.0*cno(ls)/tmp2 + ENDIF + ENDIF + ENDIF + end do + end if + if ( ipconc .ge. 5 ) then + do mgs = 1,ngscnt + + cx(mgs,lh) = Max(an(igs(mgs),jy,kgs(mgs),lnh), 0.0) + IF ( qx(mgs,lh) .le. qxmin(lh) ) THEN +! cx(mgs,lh) = 0.0 + ELSEIF ( cx(mgs,lh) .eq. 0.0 .and. qx(mgs,lh) .lt. 3.0*qxmin(lh) ) THEN + qx(mgs,lv) = qx(mgs,lv) + qx(mgs,lh) + qx(mgs,lh) = 0.0 + ELSE + cx(mgs,lh) = Max( 1.e-9, cx(mgs,lh) ) + IF ( ilimit .ge. ipc(lh) ) THEN + tmp = (xdn0(lh)*cx(mgs,lh))/(rho0(mgs)*qx(mgs,lh)) + tmp2 = (tmp*(3.14159))**(1./3.) + cnox = cx(mgs,lh)*(tmp2) + IF ( cnox .gt. 3.0*cno(lh) ) THEN + cx(mgs,lh) = 3.0*cno(lh)/tmp2 + ENDIF + ENDIF + ENDIF + + + end do + + + end if + + if ( lhl .gt. 1 .and. ipconc .ge. 5 ) then + do mgs = 1,ngscnt + + cx(mgs,lhl) = Max(an(igs(mgs),jy,kgs(mgs),lnhl), 0.0) + IF ( qx(mgs,lhl) .le. qxmin(lhl) ) THEN + cx(mgs,lhl) = 0.0 + ELSEIF ( cx(mgs,lhl) .eq. 0.0 .and. qx(mgs,lhl) .lt. 3.0*qxmin(lhl) ) THEN + qx(mgs,lv) = qx(mgs,lv) + qx(mgs,lhl) + qx(mgs,lhl) = 0.0 + ELSE + cx(mgs,lhl) = Max( 1.e-9, cx(mgs,lhl) ) + IF ( ilimit .ge. ipc(lhl) ) THEN + tmp = (xdn0(lhl)*cx(mgs,lhl))/(rho0(mgs)*qx(mgs,lhl)) + tmp2 = (tmp*(3.14159))**(1./3.) + cnox = cx(mgs,lhl)*(tmp2) + IF ( cnox .gt. 3.0*cno(lhl) ) THEN + cx(mgs,lhl) = 3.0*cno(lhl)/tmp2 + ENDIF + ENDIF + ENDIF + + + end do + end if + +! +! Set mean particle volume +! + IF ( ldovol ) THEN + + vx(:,:) = 0.0 + + DO il = li,lhab + + IF ( lvol(il) .ge. 1 ) THEN + + DO mgs = 1,ngscnt + vx(mgs,il) = Max(an(igs(mgs),jy,kgs(mgs),lvol(il)), 0.0) + ENDDO + + ENDIF + + ENDDO + + ENDIF + + +! +! Set liquid water fraction +! + fhw(:) = 0.0 + fsw(:) = 0.0 + fhlw(:) = 0.0 + + + + +! +! set factors +! + do mgs = 1,ngscnt +! + ssi(mgs) = qx(mgs,lv)/qis(mgs) + ssw(mgs) = qx(mgs,lv)/qvs(mgs) +! + tsqr(mgs) = temg(mgs)**2 +! + temgx(mgs) = min(temg(mgs),313.15) + temgx(mgs) = max(temgx(mgs),233.15) + felv(mgs) = 2500837.367 * (273.15/temgx(mgs))**((0.167)+(3.67e-4)*temgx(mgs)) +! + temcgx(mgs) = min(temg(mgs),273.15) + temcgx(mgs) = max(temcgx(mgs),223.15) + temcgx(mgs) = temcgx(mgs)-273.15 + +! felf = latent heat of fusion, fels = LH of sublimation, felv = LH of vaporization + felf(mgs) = 333690.6098 + (2030.61425)*temcgx(mgs) - (10.46708312)*temcgx(mgs)**2 +! + fels(mgs) = felv(mgs) + felf(mgs) +! + felvs(mgs) = felv(mgs)*felv(mgs) + felss(mgs) = fels(mgs)*fels(mgs) + + IF ( eqtset <= 1 ) THEN + felvcp(mgs) = felv(mgs)*cpi + felscp(mgs) = fels(mgs)*cpi + felfcp(mgs) = felf(mgs)*cpi + ELSE + + ! equations from appendix in Bryan and Morrison (2012, MWR) + ! note that rw is Rv in the paper, and rd is R. + + tmp = qx(mgs,li)+qx(mgs,ls)+qx(mgs,lh) + IF ( lhl > 1 ) tmp = tmp + qx(mgs,lhl) + cvm = cv+cvv*qx(mgs,lv)+cpl*(qx(mgs,lc)+qx(mgs,lr)) & + +cpigb*(tmp) + + IF ( eqtset == 2 ) THEN ! compact form from treating dT/dt = theta*d(pi)/dt + pi*d(theta)dt and then applied to theta assuming constant pi + felvcp(mgs) = (felv(mgs)-rw*temg(mgs))/cvm + felscp(mgs) = (fels(mgs)-rw*temg(mgs))/cvm + felfcp(mgs) = felf(mgs)/cvm + + ELSE + ! equivalent version that applies separate updates of latent heating to theta and pi, when both are returned. + + cpm = cp+cpv*qx(mgs,lv)+cpl*(qx(mgs,lc)+qx(mgs,lr)) & + +cpigb*(tmp) + rmm=rd+rw*qx(mgs,lv) + + felvcp(mgs) = (felv(mgs)*cv/(cp) - rw*temg(mgs)*(1.0-rovcp*cpm/rmm))/cvm + felscp(mgs) = (fels(mgs)*cv/(cp) - rw*temg(mgs)*(1.0-rovcp*cpm/rmm))/cvm + felfcp(mgs) = felf(mgs)*cv/(cp*cvm) + + felvpi(mgs) = pi0(mgs)*rovcp*(felv(mgs)/(temg(mgs)) - rw*cpm/rmm)/cvm + felspi(mgs) = pi0(mgs)*rovcp*(fels(mgs)/(temg(mgs)) - rw*cpm/rmm)/cvm + felfpi(mgs) = pi0(mgs)*rovcp*(felf(mgs)/(cvm*temg(mgs))) + + ENDIF + + ENDIF +! + fgamw(mgs) = felvcp(mgs)/pi0(mgs) + fgams(mgs) = felscp(mgs)/pi0(mgs) +! + fcqv1(mgs) = 4098.0258*pi0(mgs)*fgamw(mgs) + fcqv2(mgs) = 5807.6953*pi0(mgs)*fgams(mgs) + fcc3(mgs) = felfcp(mgs)/pi0(mgs) +! +! fwvdf = water vapor diffusivity + fwvdf(mgs) = (2.11e-05)*((temg(mgs)/tfr)**1.94)*(101325.0/(pres(mgs))) +! +! fadvisc = 'd' for dynamic viscosity +! fakvisc = 'k' for kinematic viscosity + fadvisc(mgs) = advisc0*(416.16/(temg(mgs)+120.0))*(temg(mgs)/296.0)**(1.5) ! dynamic visc. +! + fakvisc(mgs) = fadvisc(mgs)*rhoinv(mgs) ! divide by rho_air to get kinematic visc. (note the 'k' vs. 'd') +! + temcgx(mgs) = min(temg(mgs),273.15) + temcgx(mgs) = max(temcgx(mgs),233.15) + temcgx(mgs) = temcgx(mgs)-273.15 + fci(mgs) = (2.118636 + 0.007371*(temcgx(mgs)))*(1.0e+03) +! + if ( temg(mgs) .lt. 273.15 ) then + temcgx(mgs) = min(temg(mgs),273.15) + temcgx(mgs) = max(temcgx(mgs),233.15) + temcgx(mgs) = temcgx(mgs)-273.15 + fcw(mgs) = 4203.1548 + (1.30572e-2)*((temcgx(mgs)-35.)**2) & + & + (1.60056e-5)*((temcgx(mgs)-35.)**4) + end if + if ( temg(mgs) .ge. 273.15 ) then + temcgx(mgs) = min(temg(mgs),308.15) + temcgx(mgs) = max(temcgx(mgs),273.15) + temcgx(mgs) = temcgx(mgs)-273.15 + fcw(mgs) = 4243.1688 + (3.47104e-1)*(temcgx(mgs)**2) + end if +! + ftka(mgs) = tka0*fadvisc(mgs)/advisc1 ! thermal conductivity: proportional to dynamic viscosity + fthdf(mgs) = ftka(mgs)*cpi*rhoinv(mgs) +! + fschm(mgs) = (fakvisc(mgs)/fwvdf(mgs)) ! Schmidt number + fpndl(mgs) = (fakvisc(mgs)/fthdf(mgs)) ! Prandl number (only used for bin melting) +! + fai(mgs) = (fels(mgs)**2)/(ftka(mgs)*rw*temg(mgs)**2) + fbi(mgs) = (1.0/(rho0(mgs)*fwvdf(mgs)*qis(mgs))) + fav(mgs) = (felv(mgs)**2)/(ftka(mgs)*rw*temg(mgs)**2) + fbv(mgs) = (1.0/(rho0(mgs)*fwvdf(mgs)*qvs(mgs))) + + kp1 = Min(nz, kgs(mgs)+1 ) + wvel(mgs) = (0.5)*(w(igs(mgs),jgs,kp1) & + & +w(igs(mgs),jgs,kgs(mgs))) + +! + end do +! +! +! ice habit fractions +! +! +! +! Set density +! + if (ndebug .gt. 0 ) write(0,*) 'ICEZVD_GS: Set density' +! + + do mgs = 1,ngscnt + xdn(mgs,li) = xdn0(li) + xdn(mgs,lc) = xdn0(lc) + xdn(mgs,lr) = xdn0(lr) + xdn(mgs,ls) = xdn0(ls) + xdn(mgs,lh) = xdn0(lh) + IF ( lvol(ls) .gt. 1 ) THEN + IF ( vx(mgs,ls) .gt. 0.0 .and. qx(mgs,ls) .gt. qxmin(ls) ) THEN + xdn(mgs,ls) = Min( xdnmx(ls), Max( xdnmn(ls), rho0(mgs)*qx(mgs,ls)/vx(mgs,ls) ) ) + ENDIF + ENDIF + + IF ( lvol(lh) .gt. 1 ) THEN + IF ( vx(mgs,lh) .gt. 0.0 .and. qx(mgs,lh) .gt. qxmin(lh) ) THEN + IF ( mixedphase ) THEN + ELSE + dnmx = xdnmx(lh) + ENDIF + xdn(mgs,lh) = Min( dnmx, Max( xdnmn(lh), rho0(mgs)*qx(mgs,lh)/vx(mgs,lh) ) ) + vx(mgs,lh) = rho0(mgs)*qx(mgs,lh)/xdn(mgs,lh) + + ELSEIF ( vx(mgs,lh) == 0.0 .and. qx(mgs,lh) .gt. qxmin(lh) ) THEN ! if volume is zero, need to initialize the default value + + vx(mgs,lh) = rho0(mgs)*qx(mgs,lh)/xdn(mgs,lh) + + ENDIF + ENDIF + + + IF ( lhl .gt. 1 ) THEN + + xdn(mgs,lhl) = xdn0(lhl) + xdntmp(mgs,lhl) = xdn0(lhl) + + IF ( lvol(lhl) .gt. 1 ) THEN + IF ( vx(mgs,lhl) .gt. 0.0 .and. qx(mgs,lhl) .gt. qxmin(lhl) ) THEN + + IF ( mixedphase .and. lhlw > 1 ) THEN + ELSE + dnmx = xdnmx(lhl) + ENDIF + + xdn(mgs,lhl) = Min( dnmx, Max( xdnmn(lhl), rho0(mgs)*qx(mgs,lhl)/vx(mgs,lhl) ) ) + vx(mgs,lhl) = rho0(mgs)*qx(mgs,lhl)/xdn(mgs,lhl) + xdntmp(mgs,lhl) = xdn(mgs,lhl) + + ELSEIF ( vx(mgs,lhl) == 0.0 .and. qx(mgs,lhl) .gt. qxmin(lhl) ) THEN ! if volume is zero, need to initialize the default value + + vx(mgs,lhl) = rho0(mgs)*qx(mgs,lhl)/xdn(mgs,lhl) + + ENDIF + ENDIF + + ENDIF + + + end do + + + IF ( imurain == 3 ) THEN + IF ( lzr > 1 ) THEN + alphashr = 0.0 + alphamlr = -2.0/3.0 + ELSE + alphashr = xnu(lr) + alphamlr = xnu(lr) + ENDIF +! massfacshr = ( (2. + 3.*(1. +alphashr) )/( 3.*(1. + alphashr) ) )**(1./3.) ! this is the diameter factor +! massfacmlr = ( (2. + 3.*(1. +alphamlr) )/( 3.*(1. + alphamlr) ) )**(1./3.) + massfacshr = ( (2. + 3.*(1. +alphashr) )**3/( 3.*(1. + alphashr) ) ) ! this is the mass or volume factor + massfacmlr = ( (2. + 3.*(1. +alphamlr) )**3/( 3.*(1. + alphamlr) ) ) + ELSEIF ( imurain == 1 ) THEN + IF ( lzr > 1 ) THEN + alphashr = 4.0 + alphamlr = 4.0 + ELSE + alphashr = alphar + alphamlr = alphar + ENDIF +! massfacshr = (3.0 + alphashr)*((3.+alphashr)*(2.+alphashr)*(1. + alphashr) )**(-1./3.) ! this is the diameter factor +! massfacmlr = (3.0 + alphamlr)*((3.+alphamlr)*(2.+alphamlr)*(1. + alphamlr) )**(-1./3.) + massfacshr = (3.0 + alphashr)**3/((3.+alphashr)*(2.+alphashr)*(1. + alphashr) ) ! this is the mass or volume factor + massfacmlr = (3.0 + alphamlr)**3/((3.+alphamlr)*(2.+alphamlr)*(1. + alphamlr) ) + ENDIF + + +! +! set some values for ice nucleation +! + do mgs = 1,ngscnt + kp1 = Min(nz, kgs(mgs)+1 ) +! wvel(mgs) = (0.5)*(w(igs(mgs),jgs,kp1) & +! & +w(igs(mgs),jgs,kgs(mgs))) + + + wvelkm1(mgs) = (0.5)*(w(igs(mgs),jgs,kgs(mgs)) & + & +w(igs(mgs),jgs,kgsm(mgs))) + cninm(mgs) = t7(igs(mgs),jgs,kgsm(mgs)) + cnina(mgs) = t7(igs(mgs),jgs,kgs(mgs)) + cninp(mgs) = t7(igs(mgs),jgs,kgsp(mgs)) + end do + +! +! Set a couple of cloud variables... +! + +! SUBROUTINE setvt(ngscnt,qx,qxmin,cx,rho0,rhovt,xdia,cno, +! : xmas,xdn,xvmn,xvmx,xv,cdx, +! : ipconc,ndebug) +! SUBROUTINE setvtz(ngscnt,qx,qxmin,qxw,cx,rho0,rhovt,xdia,cno, & +! & xmas,vtxbar,xdn,xvmn,xvmx,xv,cdx, & +! & ipconc1,ndebug1,ngs,nz,kgs,cwnccn,fadvisc, & +! & cwmasn,cwmasx,cwradn,cnina,cimna,cimxa, & +! & itype1a,itype2a,temcg,infdo,alpha) + + + infdo = 0 + IF ( rimdenvwgt > 0 ) infdo = 1 + + call setvtz(ngscnt,qx,qxmin,qxw,cx,rho0,rhovt,xdia,cno,cnostmp, & + & xmas,vtxbar,xdn,xvmn,xvmx,xv,cdx,cdxgs, & + & ipconc,ndebug,ngs,nz,kgs,fadvisc, & + & cwmasn,cwmasx,cwradn,cnina,cimn,cimx, & + & itype1,itype2,temcg,infdo,alpha,0,axx,bxx) ! ,cdh,cdhl) +! & itype1,itype2,temcg,infdo,alpha,0,axh,bxh,axhl,bxhl) ! ,cdh,cdhl) + + + IF ( lwsm6 .and. ipconc == 0 ) THEN + tmp = Max(qxmin(lh), qxmin(ls)) + DO mgs = 1,ngscnt + sum = qx(mgs,lh) + qx(mgs,ls) + IF ( sum > tmp ) THEN + vt2ave(mgs) = (qx(mgs,lh)*vtxbar(mgs,lh,1) + qx(mgs,ls)*vtxbar(mgs,ls,1))/sum + ELSE + vt2ave(mgs) = 0.0 + ENDIF + ENDDO + ENDIF + + +! +! Set number concentrations (need xdia from setvt) +! + if ( ndebug .gt. 0 ) write(0,*) 'ICEZVD_GS: Set concentration' + IF ( ipconc .lt. 1 ) THEN + cina(1:ngscnt) = cx(1:ngscnt,li) + ENDIF + if ( ipconc .lt. 5 ) then + do mgs = 1,ngscnt + + + IF ( ipconc .lt. 3 ) THEN +! cx(mgs,lr) = 0.0 + if ( qx(mgs,lr) .gt. qxmin(lh) ) then +! cx(mgs,lr) = cno(lr)*xdia(mgs,lr,1) +! xv(mgs,lr) = rho0(mgs)*qx(mgs,lr)/(xdn(mgs,lr)*cx(mgs,lr)) + end if + ENDIF + + IF ( ipconc .lt. 4 ) THEN +! tmp = cx(mgs,ls) +! cx(mgs,ls) = 0.0 + if ( qx(mgs,ls) .gt. qxmin(ls) ) then +! cx(mgs,ls) = cno(ls)*xdia(mgs,ls,1) +! xv(mgs,ls) = rho0(mgs)*qx(mgs,ls)/(xdn(mgs,ls)*cx(mgs,ls)) + end if + ENDIF ! ( ipconc .lt. 4 ) + + IF ( ipconc .lt. 5 ) THEN + + +! cx(mgs,lh) = 0.0 + if ( qx(mgs,lh) .gt. qxmin(lh) ) then +! cx(mgs,lh) = cno(lh)*xdia(mgs,lh,1) +! xv(mgs,lh) = Max(xvmn(lh), rho0(mgs)*qx(mgs,lh)/(xdn(mgs,lh)*cx(mgs,lh)) ) +! xdia(mgs,lh,3) = (xv(mgs,lh)*6./pi)**(1./3.) + end if + + ENDIF ! ( ipconc .lt. 5 ) + + end do + end if + + IF ( ipconc .ge. 2 ) THEN + DO mgs = 1,ngscnt + + rb(mgs) = 0.5*xdia(mgs,lc,1)*(1./(1.+alpha(mgs,lc)))**(1./6.) + xl2p(mgs) = Max(0.0d0, 2.7e-2*xdn(mgs,lc)*cx(mgs,lc)*xv(mgs,lc)* & + & ((0.5e20*rb(mgs)**3*xdia(mgs,lc,1))-0.4) ) + IF ( rb(mgs) .gt. 3.51e-6 ) THEN +! rh(mgs) = Max( 0.5d0*xdia(mgs,lc,1), 6.3d-4/(1.d6*(rb(mgs) - 3.5d-6)) ) + rh(mgs) = Max( 41.d-6, 6.3d-4/(1.d6*(rb(mgs) - 3.5d-6)) ) + ELSE + rh(mgs) = 41.d-6 + ENDIF + IF ( xl2p(mgs) .gt. 0.0 ) THEN + nh(mgs) = 4.2d9*xl2p(mgs) + ELSE + nh(mgs) = 1.e30 + ENDIF + ENDDO + ENDIF + +! +! +! +! +! maximum depletion tendency by any one source +! +! + if( ndebug .ge. 0 ) THEN +!mpi! write(0,*) 'Set depletion max/min1' + endif + do mgs = 1,ngscnt + qvimxd(mgs) = 0.70*(qx(mgs,lv)-qis(mgs))*dtpinv ! depletion by all vap. dep to ice. + + IF ( qx(mgs,lc) < qxmin(lc) ) qvimxd(mgs) = 0.99*(qx(mgs,lv)-qis(mgs))*dtpinv ! this makes virtually no difference whatsoever, but what the heck + + qvimxd(mgs) = max(qvimxd(mgs), 0.0) + + frac = 0.1d0 + qimxd(mgs) = frac*qx(mgs,li)*dtpinv + qcmxd(mgs) = frac*qx(mgs,lc)*dtpinv + qrmxd(mgs) = frac*qx(mgs,lr)*dtpinv + qsmxd(mgs) = frac*qx(mgs,ls)*dtpinv + qhmxd(mgs) = frac*qx(mgs,lh)*dtpinv + IF ( lhl > 1 ) qhlmxd(mgs) = frac*qx(mgs,lhl)*dtpinv + end do +! + if( ndebug .ge. 0 ) THEN +!mpi! write(0,*) 'Set depletion max/min2' + endif + + do mgs = 1,ngscnt +! + if ( qx(mgs,lc) .le. qxmin(lc) ) then + ccmxd(mgs) = 0.20*cx(mgs,lc)*dtpinv + else + IF ( ipconc .ge. 2 ) THEN + ccmxd(mgs) = frac*cx(mgs,lc)*dtpinv + ELSE + ccmxd(mgs) = frac*qx(mgs,lc)/(xmas(mgs,lc)*rho0(mgs)*dtp) + ENDIF + end if +! + if ( qx(mgs,li) .le. qxmin(li) ) then + cimxd(mgs) = frac*cx(mgs,li)*dtpinv + else + IF ( ipconc .ge. 1 ) THEN + cimxd(mgs) = frac*cx(mgs,li)*dtpinv + ELSE + cimxd(mgs) = frac*qx(mgs,li)/(xmas(mgs,li)*rho0(mgs)*dtp) + ENDIF + end if +! +! + crmxd(mgs) = 0.10*cx(mgs,lr)*dtpinv + csmxd(mgs) = frac*cx(mgs,ls)*dtpinv + chmxd(mgs) = frac*cx(mgs,lh)*dtpinv + + ccmxd(mgs) = frac*cx(mgs,lc)*dtpinv + cimxd(mgs) = frac*cx(mgs,li)*dtpinv + crmxd(mgs) = frac*cx(mgs,lr)*dtpinv + csmxd(mgs) = frac*cx(mgs,ls)*dtpinv + chmxd(mgs) = frac*cx(mgs,lh)*dtpinv + + qxmxd(mgs,lv) = Max(0.0, 0.1*(qx(mgs,lv) - qvs(mgs))*dtpinv) + + DO il = lc,lhab + qxmxd(mgs,il) = frac*qx(mgs,il)*dtpinv + cxmxd(mgs,il) = frac*cx(mgs,il)*dtpinv + ENDDO + + end do + + + + + + + + + ! default factors between mean volume and maximum mass volume + maxmassfac(lc) = ( (2. + 3.*(1. + xnu(lc)) )**3/( 3.*(1. + xnu(lc)) ) ) + maxmassfac(li) = ( (2. + 3.*(1. + xnu(li)) )**3/( 3.*(1. + xnu(li)) ) ) + + IF ( imurain == 3 ) THEN + maxmassfac(lr) = ( (2. + 3.*(1. + xnu(lr)) )**3/( 3.*(1. + xnu(lr)) ) ) + ELSE + maxmassfac(lr) = (3.0 + alphar)**3/ & + & ((3.+alphar)*(2.+alphar)*(1. + alphar) ) + ENDIF + + IF ( imusnow == 3 ) THEN + maxmassfac(ls) = ( (2. + 3.*(1. + alphas) )**3/( 3.*(1. + alphas) ) ) + ELSE + maxmassfac(ls) = (3.0 + alphas)**3/ & + & ((3.+alphas)*(2.+alphas)*(1. + alphas) ) + ENDIF + + maxmassfac(lh) = (3.0 + alphah)**3/ & + & ((3.+alphah)*(2.+alphah)*(1. + alphah) ) + + IF ( lhl > 1 ) THEN + maxmassfac(lhl) = (3.0 + alphahl)**3/ & + & ((3.+alphahl)*(2.+alphahl)*(1. + alphahl) ) + ENDIF + + + + DO mgs = 1,ngscnt + DO il = lh,lhab ! graupel and hail only (and frozen drops) + + vshdgs(mgs,il) = vshd ! base value + + IF ( qx(mgs,il) > qxmin(il) ) THEN + + ! tmpdiam is weighted diameter of d^(shedalp-1), so for shedalp=3, this is the area-weighted diameter or maximum mass diameter. + tmpdiam = (shedalp+alpha(mgs,il))*xdia(mgs,il,1)*( xdn(mgs,il)/917. )**(1./3.) ! erm added density factor for equiv. solid ice sphere 10.12.2015 + + IF ( tmpdiam > sheddiam0 ) THEN + vshdgs(mgs,il) = 0.523599*(1.5e-3)**3/massfacshr ! 1.5mm drops from very large ice + ELSEIF ( tmpdiam > sheddiam ) THEN ! intermediate size + vshdgs(mgs,il) = 0.523599*(3.0e-3)**3/massfacshr ! 3.0mm drops from medium-large ice + ELSE +! vshdgs(mgs,il) = Min( xvmx(lr), xv(mgs,il)*xdn(mgs,il)*0.001 ) ! size of drop from melted mean ice particle + vshdgs(mgs,il) = Min( xvmx(lr), 6./pi*xdn(mgs,il)*0.001*tmpdiam**3 )/massfacshr ! size of drop from melted mean ice particle; 0.001 is 1/rhow + ENDIF + ENDIF + ENDDO + ENDDO + +! +! +! microphysics source terms (1/s) for mixing ratios +! +! +! +! Collection efficiencies: +! + if (ndebug .gt. 0 ) write(0,*) 'ICEZVD_GS: Set collection efficiencies' +! + do mgs = 1,ngscnt +! +! +! + qcwresv(mgs) = 0.0 + ccwresv(mgs) = 0.0 + + erw(mgs) = 0.0 + esw(mgs) = 0.0 + ehw(mgs) = 0.0 + efw(mgs) = 0.0 + ehlw(mgs) = 0.0 +! ehxw(mgs) = 0.0 +! + err(mgs) = 0.0 + esr(mgs) = 0.0 + il2(mgs) = 0 + il3(mgs) = 0 + ehr(mgs) = 0.0 + ehlr(mgs) = 0.0 +! ehxr(mgs) = 0.0 +! + eri(mgs) = 0.0 + esi(mgs) = 0.0 + ehi(mgs) = 0.0 ! used as sticking efficiency, so collection efficiency is ehi*ehiclsn + ehis(mgs) = 0.0 ! used as sticking efficiency, so collection efficiency is ehi*ehiclsn + ehli(mgs) = 0.0 ! used as sticking efficiency, so collection efficiency is ehli*ehliclsn + ehlis(mgs) = 0.0 ! used as sticking efficiency, so collection efficiency is ehli*ehliclsn +! ehxi(mgs) = 0.0 +! + ers(mgs) = 0.0 + ess(mgs) = 0.0 + ehs(mgs) = 0.0 ! used as sticking efficiency, so collection efficiency is ehs*ehsclsn + ehls(mgs) = 0.0 ! used as sticking efficiency, so collection efficiency is ehls*ehlsclsn + ehscnv(mgs) = 0.0 +! ehxs(mgs) = 0.0 +! + eiw(mgs) = 0.0 + eii(mgs) = 0.0 + + ehsclsn(mgs) = 0.0 + ehiclsn(mgs) = 0.0 + ehlsclsn(mgs) = 0.0 + ehliclsn(mgs) = 0.0 + esiclsn(mgs) = 0.0 + + +! reserve droplets + IF ( exwmindiam > 0 .and. qx(mgs,lc) > qxmin(lc) ) THEN + tmp = cx(mgs,lc)*Exp(- (exwmindiam/xdia(mgs,lc,1))**3 ) + ccwresv(mgs) = Min( cx(mgs,lc), Max( 2.e6, cx(mgs,lc) - tmp ) ) + + tmp = cx(mgs,lc) - ccwresv(mgs) + + volt = pi/6.*(exwmindiam)**3 + qcwresv(mgs) = qx(mgs,lc) - tmp*xdn0(lc)*rhoinv(mgs)*(volt + xv(mgs,lc)) + + + IF ( .false. .and. qx(mgs,lc) > 0.1e-3 ) THEN + + write(0,*) 'cx,qx,crsv,qrsv = ',cx(mgs,lc),qx(mgs,lc),ccwresv(mgs),qcwresv(mgs) + + ENDIF + + ENDIF + + + icwr(mgs) = 1 + IF ( qx(mgs,lc) .gt. qxmin(lc) ) THEN + cwrad = 0.5*xdia(mgs,lc,1) + DO il = 1,8 + IF ( cwrad .ge. 1.e-6*cwr(il,1) ) icwr(mgs) = il + ENDDO + ENDIF + + + irwr(mgs) = 1 + IF ( qx(mgs,lr) .gt. qxmin(lr) ) THEN + rwrad = 0.5*xdia(mgs,lr,3) ! changed to mean volume diameter (10/6/06) + DO il = 1,6 + IF ( rwrad .ge. 1.e-6*grad(il,1) ) irwr(mgs) = il + ENDDO + ENDIF + + + igwr(mgs) = 1 +! IF ( qx(mgs,lr) .gt. qxmin(lr) ) THEN +! rwrad = 0.5*xdia(mgs,lr,1) +! setting erw = 1 always, so now use igwr for graupel + IF ( qx(mgs,lh) .gt. qxmin(lh) ) THEN + rwrad = 0.5*xdia(mgs,lh,3) ! changed to mean volume diameter (10/6/06) + DO il = 1,6 + IF ( rwrad .ge. 1.e-6*grad(il,1) ) igwr(mgs) = il + ENDDO + ENDIF + + + IF ( lhl .gt. 1 ) THEN ! hail is turned on + ihlr(mgs) = 1 + IF ( qx(mgs,lhl) .gt. qxmin(lhl) ) THEN + rwrad = 0.5*xdia(mgs,lhl,3) ! changed to mean volume diameter (10/6/06) + DO il = 1,6 + IF ( rwrad .ge. 1.e-6*grad(il,1) ) ihlr(mgs) = il + ENDDO + ENDIF + ENDIF + +! +! +! Ice-Ice: Collection (cxc) efficiencies +! +! + if ( qx(mgs,li) .gt. qxmin(li) ) then +! IF ( ipconc .ge. 14 ) THEN +! eii(mgs)=0.1*exp(0.1*temcg(mgs)) +! if ( temg(mgs) .lt. 243.15 .and. qx(mgs,lc) .gt. 1.e-6 ) then +! eii(mgs)=0.1 +! end if +! +! ELSE + eii(mgs) = exp(0.025*Min(temcg(mgs),0.0)) ! alpha1 from LFO83 (21) +! ENDIF + if ( temg(mgs) .gt. 273.15 ) eii(mgs) = 1.0 + end if +! +! +! +! Ice-cloud water: Collection (cxc) efficiencies +! +! + eiw(mgs) = 0.0 + if ( qx(mgs,li).gt.qxmin(li) .and. qx(mgs,lc).gt.qxmin(lc) ) then + + + if (xdia(mgs,lc,1).gt.15.0e-06 .and. xdia(mgs,li,1).gt.30.0e-06) then +! erm 5/10/2007 test following change: +! if (xdia(mgs,lc,1).gt.12.0e-06 .and. xdia(mgs,li,1).gt.50.0e-06) then + eiw(mgs) = 0.5 + end if + if ( temg(mgs) .ge. 273.15 ) eiw(mgs) = 0.0 + end if + +! +! +! +! Rain: Collection (cxc) efficiencies +! +! + if ( qx(mgs,lr).gt.qxmin(lr) .and. qx(mgs,lc).gt.qxmin(lc) ) then + + IF ( lnr .gt. 1 ) THEN + erw(mgs) = 1.0 + + ELSE + +! cwrad = 0.5*xdia(mgs,lc,1) +! erw(mgs) = +! > min((aradcw + cwrad*(bradcw + cwrad* +! < (cradcw + cwrad*(dradcw)))), 1.0) +! IF ( xdia(mgs,lc,1) .lt. 2.4e-06 .or. xdia(mgs,lr,1) .le. 50.0e-6 ) THEN +! erw(mgs)=0.0 +! ENDIF +! erw(mgs) = ew(icwr(mgs),igwr(mgs)) +! interpolate along droplet radius + ic = icwr(mgs) + icp1 = Min( 8, ic+1 ) + ir = irwr(mgs) + irp1 = Min( 6, ir+1 ) + cwrad = 0.5*xdia(mgs,lc,3) + rwrad = 0.5*xdia(mgs,lr,3) + + slope1 = (ew(icp1, ir ) - ew(ic,ir ))*cwr(ic,2) + slope2 = (ew(icp1, irp1) - ew(ic,irp1))*cwr(ic,2) + +! write(iunit,*) 'slop1: ',slope1,slope2,ew(ic,ir),cwr(ic,2) + + x1 = ew(ic, ir) + slope1*Max(0.0, (cwrad - cwr(ic,1)) ) + x2 = ew(icp1,ir) + slope2*Max(0.0, (cwrad - cwr(ic,1)) ) + + slope1 = (x2 - x1)*grad(ir,2) + + erw(mgs) = Max(0.0, x1 + slope1*Max(0.0, (rwrad - grad(ir,1)) )) + +! write(iunit,*) 'erw: ',erw(mgs),1.e6*cwrad,1.e6*rwrad,ic,ir,x1,x2 +! write(iunit,*) + + erw(mgs) = Max(0.0, erw(mgs) ) + IF ( rwrad .lt. 50.e-6 ) THEN + erw(mgs) = 0.0 + ELSEIF ( rwrad .lt. 100.e-6 ) THEN ! linear change from zero at 50 to erw at 100 microns + erw(mgs) = erw(mgs)*(rwrad - 50.e-6)/50.e-6 + ENDIF + + ENDIF + end if + IF ( cx(mgs,lc) .le. 0.0 ) erw(mgs) = 0.0 +! + if ( qx(mgs,lr).gt.qxmin(lr) .and. qx(mgs,lr).gt.qxmin(lr) ) then + err(mgs)=1.0 + end if +! + if ( qx(mgs,lr).gt.qxmin(lr) .and. qx(mgs,ls).gt.qxmin(ls) ) then + ers(mgs)=1.0 + end if +! + if ( qx(mgs,lr).gt.qxmin(lr) .and. qx(mgs,li).gt.qxmin(li) ) then +! IF ( vtxbar(mgs,lr,1) .gt. vtxbar(mgs,li,1) .and. +! : xdia(mgs,lr,3) .gt. 200.e-6 .and. xdia(mgs,li,3) .gt. 100.e-6 ) THEN + eri(mgs) = eri0 +! cwrad = 0.5*xdia(mgs,li,3) +! eri(mgs) = +! > 1.0*min((aradcw + cwrad*(bradcw + cwrad* +! < (cradcw + cwrad*(dradcw)))), 1.0) +! ENDIF +! if ( xdia(mgs,li,1) .lt. 10.e-6 ) eri(mgs)=0.0 + if ( xdia(mgs,li,3) .lt. eri_cimin ) eri(mgs)=0.0 + end if +! +! +! Snow aggregates: Collection (cxc) efficiencies +! +! Modified by ERM with a linear function for small droplets and large +! snow agg. based numerical data from Wang and Ji (1992) in P&K 1997 (Fig. 14-13), which +! allows collection of very small droplets, albeit at low efficiency. But slow +! fall speeds of snow make up for the efficiency. +! + esw(mgs) = 0.0 + if ( qx(mgs,ls).gt.qxmin(ls) .and. qx(mgs,lc).gt.qxmin(lc) ) then + esw(mgs) = 0.5 + if ( xdia(mgs,lc,1) .gt. 15.e-6 .and. xdia(mgs,ls,1) .gt. 100.e-6) then + esw(mgs) = 0.5 + ELSEIF ( xdia(mgs,ls,1) .ge. 500.e-6 ) THEN + esw(mgs) = Min(0.5, 0.05 + (0.8-0.05)/(40.e-6)*xdia(mgs,lc,1) ) + ENDIF + end if +! + if ( qx(mgs,ls).gt.qxmin(ls) .and. qx(mgs,lr).gt.qxmin(lr) & + & .and. temg(mgs) .lt. tfr - 1. & + & ) then + esr(mgs)=Exp(-(40.e-6)**3/xv(mgs,lr))*Exp(-40.e-6/xdia(mgs,ls,1)) + IF ( qx(mgs,ls) < 1.e-4 .and. qx(mgs,lr) < 1.e-4 ) il2(mgs) = 1 + end if + + IF ( ipconc < 3 .and. temg(mgs) < tfr .and. qx(mgs,lr).gt.qxmin(lr) .and. qx(mgs,lr) < 1.e-4 ) THEN + il3(mgs) = 1 + ENDIF +! +! if ( qx(mgs,ls).gt.qxmin(ls) ) then + if ( temcg(mgs) < 0.0 ) then + + IF ( ipconc .lt. 4 .or. temcg(mgs) < esstem1 ) THEN + ess(mgs) = 0.0 +! ess(mgs)=0.1*exp(0.1*min(temcg(mgs),0.0)) +! ess(mgs)=min(0.1,ess(mgs)) + + ELSE + + fac = Abs(ess0) + IF ( .true. .and. ess0 < 0.0 ) THEN +! IF ( wvel(mgs) > 2.0 .or. wvel(mgs) < -0.5 .or. ssi(mgs) < 1.0 ) THEN + IF ( wvel(mgs) > 2.0 ) THEN + ! assume convective cell or downdraft + fac = 0.0 + ELSEIF ( wvel(mgs) > 1.0 ) THEN ! transition to stratiform range of values + fac = Max(0.0, 2.0 - wvel(mgs))*fac + ENDIF + ENDIF + + IF ( temcg(mgs) > esstem1 .and. temcg(mgs) < esstem2 ) THEN ! only nonzero for T > -25 + ess(mgs) = fac*Exp(ess1*(esstem2) )*(temcg(mgs) - esstem1)/(esstem2 - esstem1) ! linear ramp up from zero at esstem1 to value at esstem2 + ELSEIF ( temcg(mgs) >= esstem2 ) THEN + ess(mgs) = fac*Exp(ess1*Min( temcg(mgs), 0.0 ) ) + ENDIF + + ENDIF + end if +! + if ( qx(mgs,ls).gt.qxmin(ls) .and. qx(mgs,li).gt.qxmin(li) ) then + esiclsn(mgs) = esi_collsn +! IF ( ipconc .lt. 4 ) THEN + IF ( ipconc < 1 .and. lwsm6 ) THEN + esi(mgs) = exp(0.7*min(temcg(mgs),0.0)) + ELSE + esi(mgs) = esi0*exp(0.1*min(temcg(mgs),0.0)) + esi(mgs) = Min(0.1,esi(mgs)) + ENDIF + IF ( ipconc .le. 3 ) THEN + esi(mgs) = exp(0.025*min(temcg(mgs),0.0)) ! LFO +! esi(mgs) = Min(0.5, exp(0.025*min(temcg(mgs),0.0)) ) ! LFO +! esi(mgs)=0.5*exp(0.1*min(temcg(mgs),0.0)) ! 10ice + ENDIF +! ELSE ! zrnic/ziegler 1993 +! esi(mgs)= 0.1 ! 0.5*exp(0.1*min(temcg(mgs),0.0)) +! ENDIF + if ( temg(mgs) .gt. 273.15 ) esi(mgs) = 0.0 + end if +! +! +! +! +! Graupel: Collection (cxc) efficiencies +! +! + xmascw(mgs) = xmas(mgs,lc) + if ( qx(mgs,lh).gt.qxmin(lh) .and. qx(mgs,lc).gt.qxmin(lc) ) then !{ + ehw(mgs) = 1.0 + IF ( iehw .eq. 0 ) THEN + ehw(mgs) = ehw0 ! default value is 1.0 + ELSEIF ( iehw .eq. 1 .or. iehw .eq. 10 ) THEN + cwrad = 0.5*xdia(mgs,lc,1) + ehw(mgs) = Min( ehw0, & + & ewfac*min((aradcw + cwrad*(bradcw + cwrad* & + & (cradcw + cwrad*(dradcw)))), 1.0) ) + + ELSEIF ( iehw .eq. 2 .or. iehw .eq. 10 ) THEN + ic = icwr(mgs) + icp1 = Min( 8, ic+1 ) + ir = igwr(mgs) + irp1 = Min( 6, ir+1 ) + cwrad = 0.5*xdia(mgs,lc,1) + rwrad = 0.5*xdia(mgs,lh,3) ! changed to mean volume diameter + + slope1 = (ew(icp1, ir ) - ew(ic,ir ))*cwr(ic,2) + slope2 = (ew(icp1, irp1) - ew(ic,irp1))*cwr(ic,2) + +! write(iunit,*) 'slop1: ',slope1,slope2,ew(ic,ir),cwr(ic,2) + + x1 = ew(ic, ir) + slope1*Max(0.0, (cwrad - cwr(ic,1)) ) + x2 = ew(icp1,ir) + slope2*Max(0.0, (cwrad - cwr(ic,1)) ) + + slope1 = (x2 - x1)*grad(ir,2) + + tmp = Max( 0.0, Min( 1.0, x1 + slope1*Max(0.0, (rwrad - grad(ir,1)) ) ) ) + ehw(mgs) = Min( ehw(mgs), tmp ) + +! write(iunit,*) 'ehw: ',ehw(mgs),1.e6*cwrad,1.e6*rwrad,ic,ir,x1,x2 +! write(iunit,*) + +! ehw(mgs) = Max( 0.2, ehw(mgs) ) +! assume that ehw = 1 for zero air resistance (rho0 = 0.0) and extrapolate toward that +! ehw(mgs) = ehw(mgs) + (ehw(mgs) - 1.0)*(rho0(mgs) - rho00)/rho00 +! ehw(mgs) = ehw(mgs) + (1.0 - ehw(mgs))*((Max(0.0,rho00 - rho0(mgs)))/rho00)**2 + + ELSEIF ( iehw .eq. 3 .or. iehw .eq. 10 ) THEN ! use fraction of droplets greater than dmincw diameter + tmp = Exp(- (dmincw/xdia(mgs,lc,1))**3) + xmascw(mgs) = xmas(mgs,lc) + xdn0(lc)*(pi*dmincw**3/6.0) ! this is the average mass of the droplets with d > dmincw + ehw(mgs) = Min( ehw(mgs), tmp ) + ELSEIF ( iehw .eq. 4 .or. iehw .eq. 10 ) THEN ! Cober and List 1993, eq. 19-20 + tmp = & + & 2.0*xdn(mgs,lc)*vtxbar(mgs,lh,1)*(0.5*xdia(mgs,lc,1))**2 & + & /(9.0*fadvisc(mgs)*0.5*xdia(mgs,lh,3)) + tmp = Max( 1.5, Min(10.0, tmp) ) + ehw(mgs) = Min( ehw(mgs), 0.55*Log10(2.51*tmp) ) + ENDIF + if ( xdia(mgs,lc,1) .lt. 2.4e-06 ) ehw(mgs)=0.0 + + ehw(mgs) = Min( ehw0, ehw(mgs) ) + + IF ( ibfc == -1 .and. temcg(mgs) < -41.0 ) THEN + ehw(mgs) = 0.0 + ENDIF + + end if !} +! + if ( qx(mgs,lh).gt.qxmin(lh) .and. qx(mgs,lr).gt.qxmin(lr) & +! & .and. temg(mgs) .lt. tfr & + & ) then +! ehr(mgs) = Exp(-(40.e-6)**3/xv(mgs,lr))*Exp(-40.e-6/xdia(mgs,lh,1)) +! ehr(mgs) = 1.0 + ehr(mgs) = Exp(-(40.e-6)/xdia(mgs,lr,3))*Exp(-40.e-6/xdia(mgs,lh,3)) + ehr(mgs) = Min( ehr0, ehr(mgs) ) + end if +! + IF ( qx(mgs,ls).gt.qxmin(ls) ) THEN + IF ( ipconc .ge. 4 ) THEN + ehscnv(mgs) = ehs0*exp(ehs1*min(temcg(mgs),0.0)) ! for 2-moment, used as default for ehs and ehls. Otherwise not used for snow->graupel conversion + ELSE + ehscnv(mgs) = exp(0.09*min(temcg(mgs),0.0)) + ENDIF + if ( qx(mgs,lh).gt.qxmin(lh) .and. qx(mgs,lc) > qxmin(lc) ) then + ehsclsn(mgs) = ehs_collsn + IF ( xdia(mgs,ls,3) < 40.e-6 ) THEN + ehsclsn(mgs) = 0.0 + ELSEIF ( xdia(mgs,ls,3) < 150.e-6 ) THEN + ehsclsn(mgs) = ehs_collsn*(xdia(mgs,ls,3) - 40.e-6)/(150.e-6 - 40.e-6) + ELSE + ehsclsn(mgs) = ehs_collsn + ENDIF +! ehs(mgs) = ehscnv(mgs)*Min(1.0, Max(0., xdn(mgs,lh) - xdnmn(lh)*1.2)/xdnmn(lh) ) ! shut off qhacs as graupel goes to lowest density + ehs(mgs) = ehscnv(mgs)*Min(1.0, Max(0.0,xdn(mgs,lh) - 300.)/300. ) ! shut off qhacs as graupel goes to low density +! ehs(mgs) = ehscnv(mgs) ! *Min(1.0, Max(0.0,xdn(mgs,lh) - 300.)/300. ) ! shut off qhacs as graupel goes to low density + ehs(mgs) = Min(ehs(mgs),ehsmax) + IF ( qx(mgs,lc) < qxmin(lc) ) ehs(mgs) = 0.0 + end if + ENDIF +! + if ( qx(mgs,lh).gt.qxmin(lh) .and. qx(mgs,li).gt.qxmin(li) ) then + ehiclsn(mgs) = ehi_collsn + ehi(mgs)=eii0*exp(eii1*min(temcg(mgs),0.0)) + ehi(mgs) = Min( ehimax, Max( ehi(mgs), ehimin ) ) + if ( temg(mgs) .gt. 273.15 .or. ( qx(mgs,lc) < qxmin(lc)) ) ehi(mgs) = 0.0 + end if + + IF ( lis > 1 ) THEN + if ( qx(mgs,lh).gt.qxmin(lh) .and. qx(mgs,lis).gt.qxmin(lis) ) then + ehisclsn(mgs) = ehi_collsn + ehis(mgs)=eii0*exp(eii1*min(temcg(mgs),0.0)) + ehis(mgs) = Min( ehimax, Max( ehis(mgs), ehimin ) ) + if ( temg(mgs) .gt. 273.15 .or. ( qx(mgs,lc) < qxmin(lc)) ) ehis(mgs) = 0.0 + end if + ENDIF + + +! +! +! Hail: Collection (cxc) efficiencies +! +! + IF ( lhl .gt. 1 ) THEN + + if ( qx(mgs,lhl).gt.qxmin(lhl) .and. qx(mgs,lc).gt.qxmin(lc) ) then + IF ( iehw == 3 ) iehlw = 3 + IF ( iehw == 4 ) iehlw = 4 + ehlw(mgs) = ehlw0 + IF ( iehlw .eq. 0 ) THEN + ehlw(mgs) = ehlw0 ! default value is 1.0 + ELSEIF ( iehlw .eq. 1 .or. iehlw .eq. 10 ) THEN + cwrad = 0.5*xdia(mgs,lc,1) + ehlw(mgs) = Min( ehlw0, & + & ewfac*min((aradcw + cwrad*(bradcw + cwrad* & + & (cradcw + cwrad*(dradcw)))), 1.0) ) + + ELSEIF ( iehlw .eq. 2 .or. iehlw .eq. 10 ) THEN + ic = icwr(mgs) + icp1 = Min( 8, ic+1 ) + ir = ihlr(mgs) + irp1 = Min( 6, ir+1 ) + cwrad = 0.5*xdia(mgs,lc,1) + rwrad = 0.5*xdia(mgs,lhl,3) ! changed to mean volume diameter + + slope1 = (ew(icp1, ir ) - ew(ic,ir ))*cwr(ic,2) + slope2 = (ew(icp1, irp1) - ew(ic,irp1))*cwr(ic,2) + + x1 = ew(ic, ir) + slope1*(cwrad - cwr(ic,1)) + x2 = ew(icp1,ir) + slope2*(cwrad - cwr(ic,1)) + + slope1 = (x2 - x1)*grad(ir,2) + + tmp = Max( 0.0, Min( 1.0, x1 + slope1*(rwrad - grad(ir,1)) ) ) + ehlw(mgs) = Min( ehlw(mgs), tmp ) + ehlw(mgs) = Min( ehlw0, ehlw(mgs) ) +! ehw(mgs) = Max( 0.2, ehw(mgs) ) +! assume that ehw = 1 for zero air resistance (rho0 = 0.0) and extrapolate toward that +! ehw(mgs) = ehw(mgs) + (ehw(mgs) - 1.0)*(rho0(mgs) - rho00)/rho00 +! ehlw(mgs) = ehlw(mgs) + (1.0 - ehlw(mgs))*((Max(0.0,rho00 - rho0(mgs)))/rho00)**2 + + ELSEIF ( iehlw .eq. 3 .or. iehlw .eq. 10 ) THEN ! use fraction of droplets greater than 15 micron diameter + tmp = Exp(- (dmincw/xdia(mgs,lc,1))**3) + ehlw(mgs) = Min( ehlw(mgs), tmp ) + ELSEIF ( iehlw .eq. 4 .or. iehlw .eq. 10 ) THEN ! Cober and List 1993 + tmp = & + & 2.0*xdn(mgs,lc)*vtxbar(mgs,lhl,1)*(0.5*xdia(mgs,lc,1))**2 & + & /(9.0*fadvisc(mgs)*0.5*xdia(mgs,lhl,3)) + tmp = Max( 1.5, Min(10.0, tmp) ) + ehlw(mgs) = Min( ehlw(mgs), 0.55*Log10(2.51*tmp) ) + ENDIF + if ( xdia(mgs,lc,1) .lt. 2.4e-06 ) ehlw(mgs)=0.0 + ehlw(mgs) = Min( ehlw0, ehlw(mgs) ) + + IF ( ibfc == -1 .and. temcg(mgs) < -41.0 ) THEN + ehlw(mgs) = 0.0 + ENDIF + + end if +! + if ( qx(mgs,lhl).gt.qxmin(lhl) .and. qx(mgs,lr).gt.qxmin(lr) & +! & .and. temg(mgs) .lt. tfr & + & ) then + ehlr(mgs) = 1.0 + ehlr(mgs) = Min( ehlr0, ehlr(mgs) ) + end if +! + IF ( qx(mgs,ls).gt.qxmin(ls) ) THEN + if ( qx(mgs,lhl).gt.qxmin(lhl) ) then + ehlsclsn(mgs) = ehls_collsn + ehls(mgs) = ehscnv(mgs) + ehls(mgs) = Min(ehls(mgs),ehsmax) + end if + ENDIF +! + if ( qx(mgs,lhl).gt.qxmin(lhl) .and. qx(mgs,li).gt.qxmin(li) ) then + ehliclsn(mgs) = ehli_collsn + ehli(mgs)=eii0hl*exp(eii1hl*min(temcg(mgs),0.0)) + ehli(mgs) = Min( ehimax, Max( ehli(mgs), ehimin ) ) + if ( temg(mgs) .gt. 273.15 .or. ( qx(mgs,lc) < qxmin(lc)) ) ehli(mgs) = 0.0 + end if + + IF ( lis > 1 ) THEN + if ( qx(mgs,lhl).gt.qxmin(lhl) .and. qx(mgs,lis).gt.qxmin(lis) ) then + ehlisclsn(mgs) = ehli_collsn + ehlis(mgs)=eii0*exp(eii1*min(temcg(mgs),0.0)) + ehlis(mgs) = Min( ehimax, Max( ehlis(mgs), ehimin ) ) + if ( temg(mgs) .gt. 273.15 .or. ( qx(mgs,lc) < qxmin(lc)) ) ehlis(mgs) = 0.0 + end if + ENDIF + + + ENDIF ! lhl .gt. 1 + + ENDDO ! mgs loop for collection efficiencies + +! +! +! +! Set flags for plates vs. columns +! +! + do mgs = 1,ngscnt +! + xplate(mgs) = 0.0 + xcolmn(mgs) = 1.0 +! +! if ( temcg(mgs) .lt. 0. .and. temcg(mgs) .ge. -4. ) then +! xplate(mgs) = 1.0 +! xcolmn(mgs) = 0.0 +! end if +!c +! if ( temcg(mgs) .lt. -4. .and. temcg(mgs) .ge. -9. ) then +! xplate(mgs) = 0.0 +! xcolmn(mgs) = 1.0 +! end if +!c +! if ( temcg(mgs) .lt. -9. .and. temcg(mgs) .ge. -22.5 ) then +! xplate(mgs) = 1.0 +! xcolmn(mgs) = 0.0 +! end if +!c +! if ( temcg(mgs) .lt. -22.5 .and. temcg(mgs) .ge. -90. ) then +! xplate(mgs) = 0.0 +! xcolmn(mgs) = 1.0 +! end if +! + end do + + +! +! +! +! Collection growth equations.... +! +! + if (ndebug .gt. 0 ) write(0,*) 'Collection: rain collects xxxxx' +! + do mgs = 1,ngscnt + qracw(mgs) = 0.0 + IF ( qx(mgs,lr) .gt. qxmin(lr) .and. erw(mgs) .gt. 0.0 ) THEN + IF ( ipconc .lt. 3 ) THEN + IF ( erw(mgs) .gt. 0.0 .and. qx(mgs,lr) .gt. 1.e-7 ) THEN + vt = (ar*(xdia(mgs,lc,1)**br))*rhovt(mgs) + qracw(mgs) = & + & (0.25)*pi*erw(mgs)*(qx(mgs,lc)-qcwresv(mgs))*cx(mgs,lr) & +! > *abs(vtxbar(mgs,lr,1)-vtxbar(mgs,lc,1)) & + & *Max(0.0, vtxbar(mgs,lr,1)-vt) & + & *( gf3*xdia(mgs,lr,2) & + & + 2.0*gf2*xdia(mgs,lr,1)*xdia(mgs,lc,1) & + & + gf1*xdia(mgs,lc,2) ) +! qracw(mgs) = 0.0 +! write(iunit,*) 'qracw,cx =',qracw(mgs),1.e6*xdia(mgs,lr,1),erw(mgs) +! write(iunit,*) 'qracw,cx =',qracw(mgs),cx(mgs,lc),kgs(mgs),cx(mgs,lr),1.e6*xdia(mgs,lr,1),vtxbar(mgs,lr,1),vt +! write(iunit,*) 'vtr: ',vtxbar(mgs,lr,1), ar*gf4br/6.0*xdia(mgs,lr,1)**br, rhovt(mgs), +! : ar*gf4br/6.0*xdia(mgs,lr,1)**br * rhovt(mgs) + ENDIF + ELSE + + IF ( dmrauto <= 0 .or. rho0(mgs)*qx(mgs,lr) > 1.2*xl2p(mgs) ) THEN + rwrad = 0.5*xdia(mgs,lr,3) + IF ( rwrad .gt. rh(mgs) ) THEN ! .or. cx(mgs,lr) .gt. nh(mgs) ) THEN + IF ( rwrad .gt. rwradmn ) THEN +! DM1CCC=A2*XNC*XNR*XVC*(((CNU+2.)/(CNU+1.))*XVC+XVR) ! (A12) +! NOTE: Result is independent of imurain, assumes mucloud = 3 + qracw(mgs) = erw(mgs)*aa2*cx(mgs,lr)*cx(mgs,lc)*xmas(mgs,lc)* & + & ((alpha(mgs,lc) + 2.)*xv(mgs,lc)/(alpha(mgs,lc) + 1.) + xv(mgs,lr))/rho0(mgs) !*rhoinv(mgs) + ELSE + + IF ( imurain == 3 ) THEN + +! DM1CCC=A1*XNC*XNR*(((CNU+3.)*(CNU+2.)/(CNU+1.)**2)*XVC**3+ ! (A14) +! 1 ((RNU+2.)/(RNU+1.))*XVC*XVR**2) + +! qracw(mgs) = aa1*cx(mgs,lr)*cx(mgs,lc)*xdn(mgs,lc)* & +! & ((cnu + 3.)*(cnu + 2.)*xv(mgs,lc)**3/(cnu + 1.)**2 + & +! & (alpha(mgs,lr) + 2.)*xv(mgs,lc)*xv(mgs,lr)**2/(alpha(mgs,lr) + 1.))/rho0(mgs) !*rhoinv(mgs) +! save multiplies by converting cx*xdn*xv/rho0 to qx + qracw(mgs) = aa1*cx(mgs,lr)*(qx(mgs,lc)-qcwresv(mgs))* & + & ((alpha(mgs,lc) + 3.)*(alpha(mgs,lc) + 2.)*xv(mgs,lc)**2/(alpha(mgs,lc) + 1.)**2 + & + & (alpha(mgs,lr) + 2.)*xv(mgs,lr)**2/(alpha(mgs,lr) + 1.)) + + ELSE ! imurain == 1 + + qracw(mgs) = aa1*cx(mgs,lr)*(qx(mgs,lc)-qcwresv(mgs))* & + & ((alpha(mgs,lc) + 3.)*(alpha(mgs,lc) + 2.)*xv(mgs,lc)**2/(alpha(mgs,lc) + 1.)**2 + & + & (alpha(mgs,lr) + 6.)*(alpha(mgs,lr) + 5.)*(alpha(mgs,lr) + 4.)*xv(mgs,lr)**2/ & + & ((alpha(mgs,lr) + 3.)*(alpha(mgs,lr) + 2.)*(alpha(mgs,lr) + 1.))) + + ENDIF + + ENDIF + ENDIF + ENDIF + ENDIF +! qracw(mgs) = Min(qracw(mgs), qx(mgs,lc)) + qracw(mgs) = Min(qracw(mgs), qcmxd(mgs)) + ENDIF + end do +! + do mgs = 1,ngscnt + qraci(mgs) = 0.0 + craci(mgs) = 0.0 + IF ( eri(mgs) .gt. 0.0 .and. iacr .ge. 1 .and. xdia(mgs,lr,3) .gt. 2.*rwradmn ) THEN + IF ( ipconc .ge. 3 ) THEN + + tmp = eri(mgs)*aa2*cx(mgs,lr)*cx(mgs,li)* & + & ((cinu + 2.)*xv(mgs,li)/(cinu + 1.) + xv(mgs,lr)) + + qraci(mgs) = Min( qxmxd(mgs,li), tmp*xmas(mgs,li)*rhoinv(mgs) ) + craci(mgs) = Min( cxmxd(mgs,li), tmp ) + +! vt = Sqrt((vtxbar(mgs,lr,1)-vtxbar(mgs,li,1))**2 + +! : 0.04*vtxbar(mgs,lr,1)*vtxbar(mgs,li,1) ) +! +! qraci(mgs) = 0.25*pi*eri(mgs)*cx(mgs,lr)*qx(mgs,li)*vt* +! : ( da0(lr)*xdia(mgs,lr,3)**2 + +! : dab1(lr,li)*xdia(mgs,lr,3)*xdia(mgs,li,3) + +! : da1(li)*xdia(mgs,li,3)**2 ) +! +! +! vt = Sqrt((vtxbar(mgs,lr,1)-vtxbar(mgs,li,1))**2 + +! : 0.04*vtxbar(mgs,lr,1)*vtxbar(mgs,li,1) ) +! +! craci(mgs) = 0.25*pi*eri(mgs)*cx(mgs,lr)*cx(mgs,li)*vt* +! : ( da0(lr)*xdia(mgs,lr,3)**2 + +! : dab0(lr,li)*xdia(mgs,lr,3)*xdia(mgs,li,3) + +! : da0(li)*xdia(mgs,li,3)**2 ) +! +! qraci(mgs) = Min( qraci(mgs), qxmxd(mgs,li) ) +! craci(mgs) = Min( craci(mgs), cxmxd(mgs,li) ) + + ELSE + qraci(mgs) = & + & min( & + & (0.25)*pi*eri(mgs)*qx(mgs,li)*cx(mgs,lr) & + & *abs(vtxbar(mgs,lr,1)-vtxbar(mgs,li,1)) & + & *( gf3*xdia(mgs,lr,2) & + & + 2.0*gf2*xdia(mgs,lr,1)*xdia(mgs,li,1) & + & + gf1*xdia(mgs,li,2) ) & + & , qimxd(mgs)) + ENDIF + if ( temg(mgs) .gt. 268.15 ) then + qraci(mgs) = 0.0 + end if + ENDIF + end do +! + do mgs = 1,ngscnt + qracs(mgs) = 0.0 + IF ( ers(mgs) .gt. 0.0 .and. ipconc < 3 ) THEN + IF ( lwsm6 .and. ipconc == 0 ) THEN + vt = vt2ave(mgs) + ELSE + vt = vtxbar(mgs,ls,1) + ENDIF + qracs(mgs) = & + & min( & + & ((0.25)*pi/gf4)*ers(mgs)*qx(mgs,ls)*cx(mgs,lr) & + & *abs(vtxbar(mgs,lr,1)-vt) & + & *( gf6*gf1*xdia(mgs,ls,2) & + & + 2.0*gf5*gf2*xdia(mgs,ls,1)*xdia(mgs,lr,1) & + & + gf4*gf3*xdia(mgs,lr,2) ) & + & , qsmxd(mgs)) + ENDIF + end do + +! +! + if (ndebug .gt. 0 ) write(0,*) 'Collection: snow collects xxxxx' +! + do mgs = 1,ngscnt + qsacw(mgs) = 0.0 + csacw(mgs) = 0.0 + vsacw(mgs) = 0.0 + IF ( esw(mgs) .gt. 0.0 ) THEN + + IF ( ipconc .ge. 4 ) THEN +! QSACC=CECS*RVT*A2*XNC*XNS*XVC*ROS* +! * (((CNU+2.)/(CNU+1.))*XVC+XVS)/RO + +! tmp = esw(mgs)*rvt*aa2*cx(mgs,ls)*cx(mgs,lc)* +! : ((cnu + 2.)*xv(mgs,lc)/(cnu + 1.) + xv(mgs,ls)) + tmp = 1.0*rvt*aa2*cx(mgs,ls)*cx(mgs,lc)* & + & ((alpha(mgs,lc) + 2.)*xv(mgs,lc)/(alpha(mgs,lc) + 1.) + xv(mgs,ls)) + + qsacw(mgs) = Min( qxmxd(mgs,lc), tmp*xmas(mgs,lc)*rhoinv(mgs) ) + csacw(mgs) = Min( cxmxd(mgs,lc), tmp ) + + IF ( lvol(ls) .gt. 1 ) THEN + IF ( temg(mgs) .lt. 273.15) THEN + rimdn(mgs,ls) = rimc1*(-((0.5)*(1.e+06)*xdia(mgs,lc,1)) & + & *((0.60)*vtxbar(mgs,ls,1)) & + & /(temg(mgs)-273.15))**(rimc2) + rimdn(mgs,ls) = Min( Max( rimc3, rimdn(mgs,ls) ), rimc4 ) + ELSE + rimdn(mgs,ls) = 1000. + ENDIF + + vsacw(mgs) = rho0(mgs)*qsacw(mgs)/rimdn(mgs,ls) + + ENDIF + + +! qsacw(mgs) = cecs*aa2*cx(mgs,ls)*cx(mgs,lc)*xmas(mgs,lc)* +! : ((alpha(mgs,lc) + 2.)*xv(mgs,lc)/(alpha(mgs,lc) + 1.) + xv(mgs,ls))*rhoinv(mgs) + ELSE +! qsacw(mgs) = +! > min( +! > ((0.25)*pi)*esw(mgs)*qx(mgs,lc)*cx(mgs,ls) +! > *abs(vtxbar(mgs,ls,1)-vtxbar(mgs,lc,1)) +! > *( gf3*xdia(mgs,ls,2) +! > + 2.0*gf2*xdia(mgs,ls,1)*xdia(mgs,lc,1) +! > + gf1*xdia(mgs,lc,2) ) +! < , qcmxd(mgs)) + + vt = abs(vtxbar(mgs,ls,1)-vtxbar(mgs,lc,1)) + + qsacw(mgs) = 0.25*pi*esw(mgs)*cx(mgs,ls)*qx(mgs,lc)*vt* & + & ( da0(ls)*xdia(mgs,ls,3)**2 + & + & dab1(ls,lc)*xdia(mgs,ls,3)*xdia(mgs,lc,3) + & + & da1lc(mgs)*xdia(mgs,lc,3)**2 ) + qsacw(mgs) = Min( qsacw(mgs), qxmxd(mgs,ls) ) + csacw(mgs) = rho0(mgs)*qsacw(mgs)/xmas(mgs,lc) + ENDIF + ENDIF + end do +! +! + do mgs = 1,ngscnt + qsaci(mgs) = 0.0 + csaci(mgs) = 0.0 + csaci0(mgs) = 0.0 + IF ( ipconc .ge. 4 ) THEN + IF ( esi(mgs) .gt. 0.0 .or. ( ipelec > 0 .and. esiclsn(mgs) > 0.0 )) THEN +! QSCOI=CEXS*RVT*A2*XNCI*XNS*XVCI*ROS* +! * (((CINU+2.)/(CINU+1.))*VCIP+XVS)/RO + + tmp = esiclsn(mgs)*rvt*aa2*cx(mgs,ls)*cx(mgs,li)* & + & ((cinu + 2.)*xv(mgs,li)/(cinu + 1.) + xv(mgs,ls)) + + qsaci(mgs) = Min( qxmxd(mgs,li), esi(mgs)*tmp*xmas(mgs,li)*rhoinv(mgs) ) + csaci0(mgs) = tmp + csaci(mgs) = Min(cxmxd(mgs,li), esi(mgs)*tmp ) + +! qsaci(mgs) = +! > min( +! > ((0.25)*pi)*esi(mgs)*qx(mgs,li)*cx(mgs,ls) +! > *abs(vtxbar(mgs,ls,1)-vtxbar(mgs,li,1)) +! > *( gf3*xdia(mgs,ls,2) +! > + 2.0*gf2*xdia(mgs,ls,1)*xdia(mgs,li,1) +! > + gf1*xdia(mgs,li,2) ) +! < , qimxd(mgs)) + ENDIF + ELSE ! + IF ( esi(mgs) .gt. 0.0 ) THEN + qsaci(mgs) = & + & min( & + & ((0.25)*pi)*esi(mgs)*qx(mgs,li)*cx(mgs,ls) & + & *abs(vtxbar(mgs,ls,1)-vtxbar(mgs,li,1)) & + & *( gf3*xdia(mgs,ls,2) & + & + 2.0*gf2*xdia(mgs,ls,1)*xdia(mgs,li,1) & + & + gf1*xdia(mgs,li,2) ) & + & , qimxd(mgs)) + ENDIF + ENDIF + end do +! +! +! + do mgs = 1,ngscnt + qsacr(mgs) = 0.0 + qsacrs(mgs) = 0.0 + csacr(mgs) = 0.0 + IF ( esr(mgs) .gt. 0.0 ) THEN + IF ( ipconc .ge. 3 ) THEN +! vt = Sqrt((vtxbar(mgs,ls,1)-vtxbar(mgs,lr,1))**2 + +! : 0.04*vtxbar(mgs,ls,1)*vtxbar(mgs,lr,1) ) +! qsacr(mgs) = esr(mgs)*cx(mgs,ls)*vt* +! : qx(mgs,lr)*0.25*pi* +! : (3.02787*xdia(mgs,lr,2) + +! : 3.30669*xdia(mgs,ls,1)*xdia(mgs,lr,1) + +! : 2.*xdia(mgs,ls,2)) +! qsacr(mgs) = Min( qsacr(mgs), qrmxd(mgs) ) +! csacr(mgs) = qsacr(mgs)*cx(mgs,lr)/qx(mgs,lr) +! csacr(mgs) = min(csacr(mgs),crmxd(mgs)) + ELSE + IF ( lwsm6 .and. ipconc == 0 ) THEN + vt = vt2ave(mgs) + ELSE + vt = vtxbar(mgs,ls,1) + ENDIF + + qsacr(mgs) = & + & min( & + & ((0.25)*pi/gf4)*esr(mgs)*qx(mgs,lr)*cx(mgs,ls) & + & *abs(vtxbar(mgs,lr,1)-vt) & + & *( gf6*gf1*xdia(mgs,lr,2) & + & + 2.0*gf5*gf2*xdia(mgs,lr,1)*xdia(mgs,ls,1) & + & + gf4*gf3*xdia(mgs,ls,2) ) & + & , qrmxd(mgs)) + ENDIF + ENDIF + end do +! +! +! + + if (ndebug .gt. 0 ) write(0,*) 'Collection: graupel collects xxxxx' +! + do mgs = 1,ngscnt + qhacw(mgs) = 0.0 + rarx(mgs,lh) = 0.0 + vhacw(mgs) = 0.0 + vhsoak(mgs) = 0.0 + zhacw(mgs) = 0.0 + + IF ( .false. ) THEN + vtmax = (gz(igs(mgs),jgs,kgs(mgs))*dtpinv) + vtxbar(mgs,lh,1) = Min( vtmax, vtxbar(mgs,lh,1)) + vtxbar(mgs,lh,2) = Min( vtmax, vtxbar(mgs,lh,2)) + vtxbar(mgs,lh,3) = Min( vtmax, vtxbar(mgs,lh,3)) + ENDIF + IF ( ehw(mgs) .gt. 0.0 ) THEN + + IF ( ipconc .ge. 2 ) THEN + + IF ( .false. ) THEN + qhacw(mgs) = (ehw(mgs)*(qx(mgs,lc)-qcwresv(mgs))*cx(mgs,lh)*pi* & + & abs(vtxbar(mgs,lh,1)-vtxbar(mgs,lc,1))* & + & (2.0*xdia(mgs,lh,1)*(xdia(mgs,lh,1) + & + & xdia(mgs,lc,1)*gf73rds) + & + & xdia(mgs,lc,2)*gf83rds))/4. + + ELSE ! using Seifert coefficients + vt = abs(vtxbar(mgs,lh,1)-vtxbar(mgs,lc,1)) + + qhacw(mgs) = 0.25*pi*ehw(mgs)*cx(mgs,lh)*(qx(mgs,lc)-qcwresv(mgs))*vt* & + & ( da0lh(mgs)*xdia(mgs,lh,3)**2 + & + & dab1lh(mgs,lh,lc)*xdia(mgs,lh,3)*xdia(mgs,lc,3) + & + & da1lc(mgs)*xdia(mgs,lc,3)**2 ) + + ENDIF + qhacw(mgs) = Min( qhacw(mgs), 0.5*qx(mgs,lc)*dtpinv ) + + IF ( lzh .gt. 1 ) THEN + tmp = qx(mgs,lh)/cx(mgs,lh) + +!! g1 = (6.0 + alpha(mgs,lh))*(5.0 + alpha(mgs,lh))*(4.0 + alpha(mgs,lh))/ +!! : ((3.0 + alpha(mgs,lh))*(2.0 + alpha(mgs,lh))*(1.0 + alpha(mgs,lh))) +! alp = Max( 1.0, alpha(mgs,lh)+1. ) +! g1 = (6.0 + alp)*(5.0 + alp)*(4.0 + alp)/ +! : ((3.0 + alp)*(2.0 + alp)*(1.0 + alp)) +! zhacw(mgs) = g1*(6.*rho0(mgs)/(pi*1000.))**2*( 2.*( qx(mgs,lh)/cx(mgs,lh)) * qhacw(mgs) ) + ENDIF + + ELSE + qhacw(mgs) = & + & min( & + & ((0.25)*pi)*ehw(mgs)*(qx(mgs,lc)-qcwresv(mgs))*cx(mgs,lh) & + & *abs(vtxbar(mgs,lh,1)-vtxbar(mgs,lc,1)) & + & *( gf3*xdia(mgs,lh,2) & + & + 2.0*gf2*xdia(mgs,lh,1)*xdia(mgs,lc,1) & + & + gf1*xdia(mgs,lc,2) ) & + & , 0.5*(qx(mgs,lc)-qcwresv(mgs))*dtpinv) +! < , qxmxd(mgs,lc)) +! < , qcmxd(mgs)) + + + IF ( lwsm6 .and. qsacw(mgs) > 0.0 .and. qhacw(mgs) > 0.0) THEN + qaacw = ( qx(mgs,ls)*qsacw(mgs) + qx(mgs,lh)*qhacw(mgs) )/(qx(mgs,ls) + qx(mgs,lh)) +! qaacw = Min( qaacw, 0.5*(qsacw(mgs) + qhacw(mgs) ) ) + qsacw(mgs) = qaacw + qhacw(mgs) = qaacw + ENDIF + + ENDIF + + IF ( lvol(lh) .gt. 1 .or. lhl .gt. 1 ) THEN ! calculate rime density for graupel volume and/or for graupel conversion to hail + + IF ( temg(mgs) .lt. 273.15) THEN + IF ( irimdenopt == 1 ) THEN ! Heymsfield and Pflaum (1985) + vt = ( (1.0-rimdenvwgt)*vtxbar(mgs,lh,1) + rimdenvwgt*vtxbar(mgs,lh,2) ) + + rimdn(mgs,lh) = rimc1*(-((0.5)*(1.e+06)*xdia(mgs,lc,1)) & + & *((0.60)*vt ) & + & /(temg(mgs)-273.15))**(rimc2) +! rimdn(mgs,lh) = Min( Max( hdnmn, rimc3, rimdn(mgs,lh) ), rimc4 ) + rimdn(mgs,lh) = Min( Max( rimc3, rimdn(mgs,lh) ), rimc4 ) + +! IF ( igs(mgs) == 30 ) THEN +! write(0,*) 'k,vt: ',kgs(mgs),vt, vtxbar(mgs,lh,1),vtxbar(mgs,lh,2), rhovt(mgs)*axx(mgs,lh)*( (alpha(mgs,lh)+3.)*xdia(mgs,lh,1) )**bxx(mgs,lh) +! write(0,*) 'diam: char, mean, maxmass = ',xdia(mgs,lh,1),xdia(mgs,lh,3),(alpha(mgs,lh)+3.)*xdia(mgs,lh,1) +! write(0,*) 'ax,bx,cd,xdn = ',axx(mgs,lh),bxx(mgs,lh),cdxgs(mgs,lh),xdn(mgs,lh) +! write(0,*) 'vt_char,vt_mean = ',rhovt(mgs)*axx(mgs,lh)*( xdia(mgs,lh,1) )**bxx(mgs,lh),rhovt(mgs)*axx(mgs,lh)*( xdia(mgs,lh,3) )**bxx(mgs,lh) +! write(0,*) 'rimdn,alpha = ',rimdn(mgs,lh),alpha(mgs,lh) +! ENDIF + + ELSEIF ( irimdenopt == 2 ) THEN ! Cober and List (1993) + + tmp = (-((0.5)*(1.e+06)*xdia(mgs,lc,1)) & + & *( (1.0-rimdenvwgt)*vtxbar(mgs,lh,1) + rimdenvwgt*vtxbar(mgs,lh,2) ) & + & /(temg(mgs)-273.15)) + tmp = Min( 5.5/0.6, Max( 0.3/0.6, tmp ) ) ! have to limit range of "R" because quadratic function starts to decrease (unphysically) at higher values + + rimdn(mgs,lh) = 1000.*(0.051 + 0.114*tmp - 0.0055*tmp**2) + + ELSEIF ( irimdenopt == 3 ) THEN ! Macklin + + tmp = (-((0.5)*(1.e+06)*xdia(mgs,lc,1)) & + & *( (1.0-rimdenvwgt)*vtxbar(mgs,lh,1) + rimdenvwgt*vtxbar(mgs,lh,2) ) & + & /(temg(mgs)-273.15)) + ! tmp = Min( 5.5/0.6, Max( 0.3/0.6, tmp ) ) + + rimdn(mgs,lh) = Min(900., Max( 170., 110.*tmp**0.76 ) ) + + ENDIF + ELSE + rimdn(mgs,lh) = 1000. + ENDIF + + IF ( lvol(lh) > 1 ) vhacw(mgs) = rho0(mgs)*qhacw(mgs)/rimdn(mgs,lh) + + ENDIF + + IF ( qx(mgs,lh) .gt. qxmin(lh) .and. ipelec .ge. 1 ) THEN + rarx(mgs,lh) = & + & qhacw(mgs)*1.0e3*rho0(mgs)/((pi/2.0)*xdia(mgs,lh,2)*cx(mgs,lh)) + ENDIF + + ENDIF + end do +! +! + do mgs = 1,ngscnt + qhaci(mgs) = 0.0 + qhaci0(mgs) = 0.0 + IF ( ehi(mgs) .gt. 0.0 ) THEN + IF ( ipconc .ge. 5 ) THEN + + vt = Sqrt((vtxbar(mgs,lh,1)-vtxbar(mgs,li,1))**2 + & + & 0.04*vtxbar(mgs,lh,1)*vtxbar(mgs,li,1) ) + + qhaci0(mgs) = 0.25*pi*ehiclsn(mgs)*cx(mgs,lh)*qx(mgs,li)*vt* & + & ( da0lh(mgs)*xdia(mgs,lh,3)**2 + & + & dab1lh(mgs,lh,li)*xdia(mgs,lh,3)*xdia(mgs,li,3) + & + & da1(li)*xdia(mgs,li,3)**2 ) + qhaci(mgs) = Min( ehi(mgs)*qhaci0(mgs), qimxd(mgs) ) + ELSE + qhaci(mgs) = & + & min( & + & ((0.25)*pi)*ehi(mgs)*ehiclsn(mgs)*qx(mgs,li)*cx(mgs,lh) & + & *abs(vtxbar(mgs,lh,1)-vtxbar(mgs,li,1)) & + & *( gf3*xdia(mgs,lh,2) & + & + 2.0*gf2*xdia(mgs,lh,1)*xdia(mgs,li,1) & + & + gf1*xdia(mgs,li,2) ) & + & , qimxd(mgs)) + ENDIF + ENDIF + end do + + + IF ( lis > 1 .and. ipconc >= 5 ) THEN + do mgs = 1,ngscnt + qhacis(mgs) = 0.0 + qhacis0(mgs) = 0.0 + IF ( ehis(mgs) .gt. 0.0 ) THEN + + vt = Sqrt((vtxbar(mgs,lh,1)-vtxbar(mgs,lis,1))**2 + & + & 0.04*vtxbar(mgs,lh,1)*vtxbar(mgs,lis,1) ) + + qhacis0(mgs) = 0.25*pi*ehisclsn(mgs)*cx(mgs,lh)*qx(mgs,lis)*vt* & + & ( da0lh(mgs)*xdia(mgs,lh,3)**2 + & + & dab1lh(mgs,lh,lis)*xdia(mgs,lh,3)*xdia(mgs,lis,3) + & + & da1(li)*xdia(mgs,lis,3)**2 ) + qhacis(mgs) = Min( ehis(mgs)*qhacis0(mgs), qxmxd(mgs,lis) ) + ENDIF + end do + ENDIF + +! +! + do mgs = 1,ngscnt + qhacs(mgs) = 0.0 + qhacs0(mgs) = 0.0 + IF ( ehs(mgs) .gt. 0.0 ) THEN + IF ( ipconc .ge. 5 ) THEN + + vt = Sqrt((vtxbar(mgs,lh,1)-vtxbar(mgs,ls,1))**2 + & + & 0.04*vtxbar(mgs,lh,1)*vtxbar(mgs,ls,1) ) + + qhacs0(mgs) = 0.25*pi*ehsclsn(mgs)*cx(mgs,lh)*qx(mgs,ls)*vt* & + & ( da0lh(mgs)*xdia(mgs,lh,3)**2 + & + & dab1lh(mgs,lh,ls)*xdia(mgs,lh,3)*xdia(mgs,ls,3) + & + & da1(ls)*xdia(mgs,ls,3)**2 ) + + qhacs(mgs) = Min( ehs(mgs)*qhacs0(mgs), qsmxd(mgs) ) + + ELSE + qhacs(mgs) = & + & min( & + & ((0.25)*pi/gf4)*ehs(mgs)*ehsclsn(mgs)*qx(mgs,ls)*cx(mgs,lh) & + & *abs(vtxbar(mgs,lh,1)-vtxbar(mgs,ls,1)) & + & *( gf6*gf1*xdia(mgs,ls,2) & + & + 2.0*gf5*gf2*xdia(mgs,ls,1)*xdia(mgs,lh,1) & + & + gf4*gf3*xdia(mgs,lh,2) ) & + & , qsmxd(mgs)) + ENDIF + ENDIF + end do +! + do mgs = 1,ngscnt + qhacr(mgs) = 0.0 + qhacrmlr(mgs) = 0.0 + vhacr(mgs) = 0.0 + chacr(mgs) = 0.0 + zhacr(mgs) = 0.0 + IF ( temg(mgs) .gt. tfr ) raindn(mgs,lh) = 1000.0 + + IF ( ehr(mgs) .gt. 0.0 ) THEN + IF ( ipconc .ge. 3 ) THEN + vt = Sqrt((vtxbar(mgs,lh,1)-vtxbar(mgs,lr,1))**2 + & + & 0.04*vtxbar(mgs,lh,1)*vtxbar(mgs,lr,1) ) +! qhacr(mgs) = ehr(mgs)*cx(mgs,lh)*vt* +! : qx(mgs,lr)*0.25*pi* +! : (3.02787*xdia(mgs,lr,2) + +! : 3.30669*xdia(mgs,lh,1)*xdia(mgs,lr,1) + +! : 2.*xdia(mgs,lh,2)) + + qhacr(mgs) = 0.25*pi*ehr(mgs)*cx(mgs,lh)*qx(mgs,lr)*vt* & + & ( da0lh(mgs)*xdia(mgs,lh,3)**2 + & + & dab1lh(mgs,lh,lr)*xdia(mgs,lh,3)*xdia(mgs,lr,3) + & + & da1lr(mgs)*xdia(mgs,lr,3)**2 ) +! & da1(lr)*xdia(mgs,lr,3)**2 ) +! IF ( qhacr(mgs) .gt. 0. .or. tmp .gt. 0.0 ) write(0,*) 'qhacr= ',qhacr(mgs),tmp +!! qhacr(mgs) = Min( qhacr(mgs), qrmxd(mgs) ) +!! chacr(mgs) = qhacr(mgs)*cx(mgs,lr)/qx(mgs,lr) +!! chacr(mgs) = min(chacr(mgs),crmxd(mgs)) + + qhacr(mgs) = Min( qhacr(mgs), qxmxd(mgs,lr) ) + + qhacrmlr(mgs) = qhacr(mgs) + + IF ( temg(mgs) > tfr .and. iehr0c == 0 ) THEN + qhacr(mgs) = 0.0 + + IF ( iqhacrmlr == 0 ) THEN + qhacrmlr(mgs) = -qhacw(mgs) + ENDIF + + ELSE +! chacr(mgs) = Min( qhacr(mgs)*rho0(mgs)/xmas(mgs,lr), cxmxd(mgs,lr) ) + +! chacr(mgs) = ehr(mgs)*cx(mgs,lh)*vt* +! : cx(mgs,lr)*0.25*pi* +! : (0.69874*xdia(mgs,lr,2) + +! : 1.24001*xdia(mgs,lh,1)*xdia(mgs,lr,1) + +! : 2.*xdia(mgs,lh,2)) + + chacr(mgs) = 0.25*pi*ehr(mgs)*cx(mgs,lh)*cx(mgs,lr)*vt* & + & ( da0lh(mgs)*xdia(mgs,lh,3)**2 + & + & dab0lh(mgs,lh,lr)*xdia(mgs,lh,3)*xdia(mgs,lr,3) + & + & da0lr(mgs)*xdia(mgs,lr,3)**2 ) + +! IF ( qhacr(mgs) .gt. 0. .or. tmp .gt. 0.0 ) write(0,*) 'chacr= ',chacr(mgs),tmp + +! chacr(mgs) = qhacr(mgs)*cx(mgs,lr)/qx(mgs,lr) + chacr(mgs) = min(chacr(mgs),crmxd(mgs)) + + IF ( lzh .gt. 1 ) THEN + tmp = qx(mgs,lh)/cx(mgs,lh) + +! g1 = (6.0 + alpha(mgs,lh))*(5.0 + alpha(mgs,lh))*(4.0 + alpha(mgs,lh))/ +! : ((3.0 + alpha(mgs,lh))*(2.0 + alpha(mgs,lh))*(1.0 + alpha(mgs,lh))) +! alp = Max( 1.0, alpha(mgs,lh)+1. ) +! g1 = (6.0 + alp)*(5.0 + alp)*(4.0 + alp)/ +! : ((3.0 + alp)*(2.0 + alp)*(1.0 + alp)) +! zhacr(mgs) = g1*(6.*rho0(mgs)/(pi*1000.))**2*( 2.*( tmp ) * qhacr(mgs) - tmp**2 * chacr(mgs) ) +! zhacr(mgs) = g1*(6.*rho0(mgs)/(pi*xdn(mgs,lh)))**2*( 2.*( tmp ) * qhacr(mgs) ) + ENDIF + ENDIF ! temg > tfr + + ELSE + IF ( lwsm6 .and. ipconc == 0 ) THEN + vt = vt2ave(mgs) + ELSE + vt = vtxbar(mgs,lh,1) + ENDIF + + qhacr(mgs) = & + & min( & + & ((0.25)*pi/gf4)*ehr(mgs)*qx(mgs,lr)*cx(mgs,lh) & + & *abs(vt-vtxbar(mgs,lr,1)) & + & *( gf6*gf1*xdia(mgs,lr,2) & + & + 2.0*gf5*gf2*xdia(mgs,lr,1)*xdia(mgs,lh,1) & + & + gf4*gf3*xdia(mgs,lh,2) ) & + & , qrmxd(mgs)) + + IF ( temg(mgs) > tfr ) THEN + IF ( iqhacrmlr >= 1 ) qhacrmlr(mgs) = qhacr(mgs) + qhacr(mgs) = 0.0 + ENDIF + + ENDIF + IF ( lvol(lh) .gt. 1 .or. lhl .gt. 1 ) THEN ! calculate rime density for graupel volume and/or for graupel conversion to hail + + IF ( temg(mgs) .lt. 273.15) THEN + raindn(mgs,lh) = rimc1*(-((0.5)*(1.e+06)*xdia(mgs,lr,3)) & + & *((0.60)*vt) & + & /(temg(mgs)-273.15))**(rimc2) + + raindn(mgs,lh) = Min( Max( rimc3, rimdn(mgs,lh) ), rimc4 ) + ELSE + raindn(mgs,lh) = 1000. + ENDIF + + IF ( lvol(lh) > 1 ) vhacr(mgs) = rho0(mgs)*qhacr(mgs)/raindn(mgs,lh) + ENDIF + ENDIF + end do + +! +! + if (ndebug .gt. 0 ) write(0,*) 'Collection: hail collects xxxxx' +! + + do mgs = 1,ngscnt + qhlacw(mgs) = 0.0 + vhlacw(mgs) = 0.0 + vhlsoak(mgs) = 0.0 + IF ( lhl > 1 .and. .true.) THEN + vtmax = (gz(igs(mgs),jgs,kgs(mgs))*dtpinv) + vtxbar(mgs,lhl,1) = Min( vtmax, vtxbar(mgs,lhl,1)) + vtxbar(mgs,lhl,2) = Min( vtmax, vtxbar(mgs,lhl,2)) + vtxbar(mgs,lhl,3) = Min( vtmax, vtxbar(mgs,lhl,3)) + ENDIF + + IF ( lhl > 0 ) THEN + rarx(mgs,lhl) = 0.0 + ENDIF + + IF ( lhl .gt. 1 .and. ehlw(mgs) .gt. 0.0 ) THEN + + +! IF ( ipconc .ge. 2 ) THEN + + vt = abs(vtxbar(mgs,lhl,1)-vtxbar(mgs,lc,1)) + + qhlacw(mgs) = 0.25*pi*ehlw(mgs)*cx(mgs,lhl)*(qx(mgs,lc)-qcwresv(mgs))*vt* & + & ( da0lhl(mgs)*xdia(mgs,lhl,3)**2 + & + & dab1lh(mgs,lhl,lc)*xdia(mgs,lhl,3)*xdia(mgs,lc,3) + & + & da1lc(mgs)*xdia(mgs,lc,3)**2 ) + + + qhlacw(mgs) = Min( qhlacw(mgs), 0.5*qx(mgs,lc)*dtpinv ) + + IF ( lvol(lhl) .gt. 1 ) THEN + + IF ( temg(mgs) .lt. 273.15) THEN + IF ( irimdenopt == 1 ) THEN ! Rasmussen and Heymsfeld (1985) + rimdn(mgs,lhl) = rimc1*(-((0.5)*(1.e+06)*xdia(mgs,lc,1)) & + & *((0.60)*( (1.0-rimdenvwgt)*vtxbar(mgs,lhl,1) + rimdenvwgt*vtxbar(mgs,lhl,2) )) & + & /(temg(mgs)-273.15))**(rimc2) + rimdn(mgs,lhl) = Min( Max( hldnmn, rimc3, rimdn(mgs,lhl) ), rimc4 ) + + ELSEIF ( irimdenopt == 2 ) THEN ! Cober and List (1993) + tmp = -0.5*(1.e+06)*xdia(mgs,lc,1) & + & *( (1.0-rimdenvwgt)*vtxbar(mgs,lhl,1) + rimdenvwgt*vtxbar(mgs,lhl,2) ) & + & /(temg(mgs)-273.15) + tmp = Min( 5.5/0.6, Max( 0.3/0.6, tmp ) ) + + rimdn(mgs,lhl) = 1000.*(0.051 + 0.114*tmp - 0.005*tmp**2) + + ELSEIF ( irimdenopt == 3 ) THEN ! Macklin + tmp = -0.5*(1.e+06)*xdia(mgs,lc,1) & + & *( (1.0-rimdenvwgt)*vtxbar(mgs,lhl,1) + rimdenvwgt*vtxbar(mgs,lhl,2) ) & + & /(temg(mgs)-273.15) + ! tmp = Min( 5.5/0.6, Max( 0.3/0.6, tmp ) ) + + rimdn(mgs,lhl) = Min(900., Max( 170., 110.*tmp**0.76 ) ) + + ENDIF + ELSE + rimdn(mgs,lhl) = 1000. + ENDIF + + vhlacw(mgs) = rho0(mgs)*qhlacw(mgs)/rimdn(mgs,lhl) + + ENDIF + + + IF ( qx(mgs,lhl) .gt. qxmin(lhl) .and. ipelec .ge. 1 ) THEN + rarx(mgs,lhl) = & + & qhlacw(mgs)*1.0e3*rho0(mgs)/((pi/2.0)*xdia(mgs,lhl,2)*cx(mgs,lhl)) + ENDIF + + ENDIF + end do + + qhlaci(:) = 0.0 + qhlaci0(:) = 0.0 + IF ( lhl .gt. 1 ) THEN + do mgs = 1,ngscnt + IF ( ehli(mgs) .gt. 0.0 ) THEN + IF ( ipconc .ge. 5 ) THEN + + vt = Sqrt((vtxbar(mgs,lhl,1)-vtxbar(mgs,li,1))**2 + & + & 0.04*vtxbar(mgs,lhl,1)*vtxbar(mgs,li,1) ) + + qhlaci0(mgs) = 0.25*pi*ehliclsn(mgs)*cx(mgs,lhl)*qx(mgs,li)*vt* & + & ( da0lhl(mgs)*xdia(mgs,lhl,3)**2 + & + & dab1lh(mgs,lhl,li)*xdia(mgs,lhl,3)*xdia(mgs,li,3) + & + & da1(li)*xdia(mgs,li,3)**2 ) + ! qhlaci(mgs) = Min( qhlaci(mgs), qimxd(mgs) ) + qhlaci(mgs) = Min( ehli(mgs)*qhlaci0(mgs), qimxd(mgs) ) + ENDIF + ENDIF + end do + ENDIF +! + qhlacs(:) = 0.0 + qhlacs0(:) = 0.0 + IF ( lhl .gt. 1 ) THEN + do mgs = 1,ngscnt + IF ( ehls(mgs) .gt. 0.0) THEN + IF ( ipconc .ge. 5 ) THEN + + vt = Sqrt((vtxbar(mgs,lhl,1)-vtxbar(mgs,ls,1))**2 + & + & 0.04*vtxbar(mgs,lhl,1)*vtxbar(mgs,ls,1) ) + + qhlacs0(mgs) = 0.25*pi*ehlsclsn(mgs)*cx(mgs,lhl)*qx(mgs,ls)*vt* & + & ( da0lhl(mgs)*xdia(mgs,lhl,3)**2 + & + & dab1lh(mgs,lhl,ls)*xdia(mgs,lhl,3)*xdia(mgs,ls,3) + & + & da1(ls)*xdia(mgs,ls,3)**2 ) + + qhlacs(mgs) = Min( ehls(mgs)*qhlacs0(mgs), qsmxd(mgs) ) + ENDIF + ENDIF + end do + ENDIF + + + do mgs = 1,ngscnt + qhlacr(mgs) = 0.0 + qhlacrmlr(mgs) = 0.0 + chlacr(mgs) = 0.0 + vhlacr(mgs) = 0.0 + IF ( lhl .gt. 1 .and. temg(mgs) .gt. tfr ) raindn(mgs,lhl) = 1000.0 + + IF ( lhl .gt. 1 .and. ehlr(mgs) .gt. 0.0 ) THEN + IF ( ipconc .ge. 3 ) THEN + vt = Sqrt((vtxbar(mgs,lhl,1)-vtxbar(mgs,lr,1))**2 + & + & 0.04*vtxbar(mgs,lhl,1)*vtxbar(mgs,lr,1) ) + + qhlacr(mgs) = 0.25*pi*ehlr(mgs)*cx(mgs,lhl)*qx(mgs,lr)*vt* & + & ( da0lhl(mgs)*xdia(mgs,lhl,3)**2 + & + & dab1lh(mgs,lhl,lr)*xdia(mgs,lhl,3)*xdia(mgs,lr,3) + & + & da1lr(mgs)*xdia(mgs,lr,3)**2 ) +! & da1(lr)*xdia(mgs,lr,3)**2 ) +! IF ( qhacr(mgs) .gt. 0. .or. tmp .gt. 0.0 ) write(0,*) 'qhacr= ',qhacr(mgs),tmp +!! qhacr(mgs) = Min( qhacr(mgs), qrmxd(mgs) ) +!! chacr(mgs) = qhacr(mgs)*cx(mgs,lr)/qx(mgs,lr) +!! chacr(mgs) = min(chacr(mgs),crmxd(mgs)) + + qhlacr(mgs) = Min( qhlacr(mgs), qxmxd(mgs,lr) ) + + + IF ( iqhlacrmlr >= 1 ) qhlacrmlr(mgs) = qhlacr(mgs) + + IF ( temg(mgs) > tfr .and. iehlr0c == 0) THEN + qhlacr(mgs) = 0.0 + IF ( iqhlacrmlr == 0 ) THEN + qhlacrmlr(mgs) = -qhlacw(mgs) + ENDIF + ELSE + chlacr(mgs) = 0.25*pi*ehlr(mgs)*cx(mgs,lhl)*cx(mgs,lr)*vt* & + & ( da0lhl(mgs)*xdia(mgs,lhl,3)**2 + & + & dab0lh(mgs,lhl,lr)*xdia(mgs,lhl,3)*xdia(mgs,lr,3) + & + & da0lr(mgs)*xdia(mgs,lr,3)**2 ) + + chlacr(mgs) = min(chlacr(mgs),crmxd(mgs)) + + IF ( lvol(lhl) .gt. 1 ) THEN + vhlacr(mgs) = rho0(mgs)*qhlacr(mgs)/raindn(mgs,lhl) + ENDIF + ENDIF + ENDIF + ENDIF + end do + + + +! +! +! +! +! if (ndebug .gt. 0 ) write(0,*) 'Collection: Cloud collects xxxxx' + + if (ndebug .gt. 0 ) write(0,*) 'Collection: cloud ice collects xxxx2' +! + do mgs = 1,ngscnt + qiacw(mgs) = 0.0 + IF ( eiw(mgs) .gt. 0.0 ) THEN + + vt = Sqrt((vtxbar(mgs,li,1)-vtxbar(mgs,lc,1))**2 + & + & 0.04*vtxbar(mgs,li,1)*vtxbar(mgs,lc,1) ) + + qiacw(mgs) = 0.25*pi*eiw(mgs)*cx(mgs,li)*qx(mgs,lc)*vt* & + & ( da0(li)*xdia(mgs,li,3)**2 + & + & dab1(li,lc)*xdia(mgs,li,3)*xdia(mgs,lc,3) + & + & da1lc(mgs)*xdia(mgs,lc,3)**2 ) + + qiacw(mgs) = Min( qiacw(mgs), qxmxd(mgs,lc) ) + ENDIF + end do + + +! +! + if (ndebug .gt. 0 ) write(0,*) 'Collection: cloud ice collects xxxx8' +! + do mgs = 1,ngscnt + qiacr(mgs) = 0.0 + qiacrf(mgs) = 0.0 + qiacrs(mgs) = 0.0 + ciacrs(mgs) = 0.0 + ciacr(mgs) = 0.0 + ciacrf(mgs) = 0.0 + viacrf(mgs) = 0.0 + csplinter(mgs) = 0.0 + qsplinter(mgs) = 0.0 + csplinter2(mgs) = 0.0 + qsplinter2(mgs) = 0.0 + IF ( iacr .ge. 1 .and. eri(mgs) .gt. 0.0 & + & .and. temg(mgs) .le. 270.15 ) THEN + IF ( ipconc .ge. 3 ) THEN + ni = 0.0 + IF ( xdia(mgs,li,1) .ge. 10.e-6 ) THEN + ni = ni + cx(mgs,li)*Exp(- (40.e-6/xdia(mgs,li,1))**3 ) + ENDIF + IF ( imurain == 1 ) THEN ! gamma of diameter + IF ( iacrsize /= 4 ) THEN + IF ( iacrsize .eq. 1 ) THEN + ratio = 500.e-6/xdia(mgs,lr,1) + ELSEIF ( iacrsize .eq. 2 ) THEN + ratio = 300.e-6/xdia(mgs,lr,1) + ELSEIF ( iacrsize .eq. 3 ) THEN + ratio = 40.e-6/xdia(mgs,lr,1) + ELSEIF ( iacrsize .eq. 5 ) THEN + ratio = 150.e-6/xdia(mgs,lr,1) + ENDIF + i = Min(nqiacrratio,Int(ratio*dqiacrratioinv)) + j = Int(Max(0.0,Min(15.,alpha(mgs,lr)))*dqiacralphainv) +! j = Int(Max(minalphalu,Min(maxalphalu,alpha(mgs,lr)))*dqiacralphainv) + delx = ratio - float(i)*dqiacrratio + dely = alpha(mgs,lr) - float(j)*dqiacralpha + ip1 = Min( i+1, nqiacrratio ) + jp1 = Min( j+1, nqiacralpha ) + + ! interpolate along x, i.e., ratio + tmp1 = ciacrratio(i,j) + delx*dqiacrratioinv*(ciacrratio(ip1,j) - ciacrratio(i,j)) + tmp2 = ciacrratio(i,jp1) + delx*dqiacrratioinv*(ciacrratio(ip1,jp1) - ciacrratio(i,jp1)) + + ! interpolate along alpha + + nr = (tmp1 + dely*dqiacralphainv*(tmp2 - tmp1))*cx(mgs,lr) + + ! interpolate along x, i.e., ratio; + tmp1 = qiacrratio(i,j) + delx*dqiacrratioinv*(qiacrratio(ip1,j) - qiacrratio(i,j)) + tmp2 = qiacrratio(i,jp1) + delx*dqiacrratioinv*(qiacrratio(ip1,jp1) - qiacrratio(i,jp1)) + + ! interpolate along alpha; + + qr = (tmp1 + dely*dqiacralphainv*(tmp2 - tmp1))*qx(mgs,lr) + + ELSE ! iacrsize == 4 : use all + nr = cx(mgs,lr) + qr = qx(mgs,lr) + ENDIF + + vt = Sqrt((vtxbar(mgs,lr,1)-vtxbar(mgs,li,1))**2 + & + & 0.04*vtxbar(mgs,lr,1)*vtxbar(mgs,li,1) ) + + qiacr(mgs) = 0.25*pi*eri(mgs)*ni*qr*vt* & + & ( da0(li)*xdia(mgs,li,3)**2 + & + & dab1lh(mgs,li,lr)*xdia(mgs,lh,3)*xdia(mgs,li,3) + & + & da1(lr)*xdia(mgs,lr,3)**2 ) + + qiacr(mgs) = Min( qrmxd(mgs), qiacr(mgs) ) + + + ciacr(mgs) = 0.25*pi*eri(mgs)*ni*nr*vt* & + & ( da0(li)*xdia(mgs,li,3)**2 + & + & dab0lh(mgs,li,lr)*xdia(mgs,lr,3)*xdia(mgs,li,3) + & + & da0(lr)*xdia(mgs,lr,3)**2 ) + + ciacr(mgs) = Min( crmxd(mgs), ciacr(mgs) ) + +! write(iunit,*) 'qiacr: ',cx(mgs,lr),nr,qx(mgs,lr),qr,qiacr(mgs),ciacr(mgs) +! write(iunit,*) 'xdia r li = ',xdia(mgs,lr,3),xdia(mgs,li,3),xdia(mgs,lr,1),xdia(mgs,li,1) +! write(iunit,*) 'i,j,ratio = ',i,j,ciacrratio(i,j),qiacrratio(i,j) +! write(iunit,*) 'ni,ci = ',ni,cx(mgs,li),qx(mgs,li) + + ELSEIF ( imurain == 3 ) THEN ! gamma of volume +! Set nr to the number of drops greater than 40 microns. + arg = 1000.*xdia(mgs,lr,3) +! nr = cx(mgs,lr)*gaml02( arg ) +! IF ( iacr .eq. 1 ) THEN + IF ( ipconc .ge. 3 ) THEN + IF ( iacrsize .eq. 1 ) THEN + nr = cx(mgs,lr)*gaml02d500( arg ) ! number greater than 500 microns in diameter + ELSEIF ( iacrsize .eq. 2 .or. iacrsize .eq. 5 ) THEN + nr = cx(mgs,lr)*gaml02d300( arg ) ! number greater than 300 microns in diameter + ELSEIF ( iacrsize .eq. 3 ) THEN + nr = cx(mgs,lr)*gaml02( arg ) ! number greater than 40 microns in diameter + ELSEIF ( iacrsize .eq. 4 ) THEN + nr = cx(mgs,lr) ! all raindrops + ENDIF + ELSE + nr = cx(mgs,lr)*gaml02( arg ) + ENDIF +! ELSEIF ( iacr .eq. 2 ) THEN +! nr = cx(mgs,lr)*gaml02d300( arg ) ! number greater than 300 microns in diameter +! ENDIF + IF ( ni .gt. 0.0 .and. nr .gt. 0.0 ) THEN + d0 = xdia(mgs,lr,3) + qiacr(mgs) = xdn(mgs,lr)*rhoinv(mgs)* & + & (0.217239*(0.522295*(d0**5) + & + & 49711.81*(d0**6) - & + & 1.673016e7*(d0**7)+ & + & 2.404471e9*(d0**8) - & + & 1.22872e11*(d0**9))*ni*nr) + qiacr(mgs) = Min( qrmxd(mgs), qiacr(mgs) ) + ciacr(mgs) = & + & (0.217239*(0.2301947*(d0**2) + & + & 15823.76*(d0**3) - & + & 4.167685e6*(d0**4) + & + & 4.920215e8*(d0**5) - & + & 2.133344e10*(d0**6))*ni*nr) + ciacr(mgs) = Min( crmxd(mgs), ciacr(mgs) ) +! ciacr(mgs) = qiacr(mgs)*cx(mgs,lr)/qx(mgs,lr) + ENDIF + ENDIF + IF ( iacr .eq. 1 .or. iacr .eq. 3 ) THEN + ciacrf(mgs) = Min(ciacr(mgs), qiacr(mgs)/(1.0*vr1mm*1000.0)*rho0(mgs) ) ! *rzxh(mgs) + ELSEIF ( iacr .eq. 2 ) THEN + ciacrf(mgs) = ciacr(mgs) ! *rzxh(mgs) + ELSEIF ( iacr .eq. 4 ) THEN + ciacrf(mgs) = Min(ciacr(mgs), qiacr(mgs)/(1.0*vfrz*1000.0)*rho0(mgs) ) ! *rzxh(mgs) + ELSEIF ( iacr .eq. 5 ) THEN + ciacrf(mgs) = ciacr(mgs)*rzxh(mgs) + ENDIF +! crfrzf(mgs) = Min(crfrz(mgs), qrfrz(mgs)/(bfnu*27.0*vr1mm*1000.0)*rho0(mgs) ) ! rzxh(mgs)*crfrz(mgs) + ENDIF + + + ELSE ! single-moment rain + qiacr(mgs) = & + & min( & + & ((0.25/gf4)*pi)*eri(mgs)*cx(mgs,li)*qx(mgs,lr) & + & *abs(vtxbar(mgs,lr,1)-vtxbar(mgs,li,1)) & + & *( gf6*gf1*xdia(mgs,lr,2) & + & + 2.0*gf5*gf2*xdia(mgs,lr,1)*xdia(mgs,li,1) & + & + gf4*gf3*xdia(mgs,li,2) ) & + & , qrmxd(mgs)) + ENDIF +! if ( temg(mgs) .gt. 268.15 ) then +! qiacr(mgs) = 0.0 +! ciacr(mgs) = 0.0 +! end if + + IF ( ipconc .ge. 1 ) THEN + IF ( nsplinter .ge. 1000 ) THEN + ! Lawson et al. 2015 JAS + ! ave. diam of freezing drops in microns + IF ( qiacr(mgs)*dtp > qxmin(lh) .and. ciacr(mgs) > 1.e-3 ) THEN + tmpdiam = 1.e6*( 6.*qiacr(mgs)/(1000.*pi*ciacr(mgs) ) )**(1./3.) ! avg. diameter of newly frozen drops in microns + csplinter(mgs) = lawson_splinter_fac*tmpdiam**4*ciacr(mgs) + ENDIF + ELSEIF ( nsplinter .ge. 0 ) THEN + csplinter(mgs) = nsplinter*ciacr(mgs) + ELSE + csplinter(mgs) = -nsplinter*ciacrf(mgs) + ENDIF + qsplinter(mgs) = Min(0.1*qiacr(mgs), csplinter(mgs)*splintermass/rho0(mgs) ) ! makes splinters smaller if too much mass is taken from graupel + ENDIF + + frach = 1.0 + IF ( ibiggsnow == 2 .or. ibiggsnow == 3 ) THEN + IF ( ciacr(mgs) > qxmin(lh) ) THEN + xvfrz = rho0(mgs)*qiacr(mgs)/(ciacr(mgs)*900.) ! mean volume of frozen drops; 900. for frozen drop density + frach = 0.5 *(1. + Tanh(0.2e12 *( xvfrz - 1.15*xvbiggsnow))) + + qiacrs(mgs) = (1.-frach)*qiacr(mgs) + ciacrs(mgs) = (1.-frach)*ciacr(mgs) ! *rzxh(mgs) + + ENDIF + ENDIF + + qiacrf(mgs) = frach*qiacr(mgs) + ciacrf(mgs) = frach*ciacrf(mgs) + + IF ( lvol(lh) > 1 ) THEN + viacrf(mgs) = rho0(mgs)*qiacrf(mgs)/rhofrz + ENDIF + + end do +! +! +! +! + +! snow aggregation here + if ( ipconc .ge. 4 ) then ! + do mgs = 1,ngscnt + csacs(mgs) = 0.0 + IF ( qx(mgs,ls) > qxmin(ls) .and. ess(mgs) .gt. 0.0 ) THEN ! .and. xv(mgs,ls) < 0.25*xvmx(ls)*Max(1.,100./Min(100.,xdn(mgs,ls))) ) THEN + + IF ( iessec0flag == 0 ) THEN + ec0(mgs) = 1.0 + ELSE + tmp = xv(mgs,ls)/(xvmx(ls)*Max(1.,100./Min(100.,xdn(mgs,ls)))) ! fraction of max snow mass + IF ( tmp .lt. essfrac1 ) THEN + ec0(mgs) = 1.0 + ELSEIF ( tmp .gt. essfrac2 ) THEN + ec0(mgs) = 0.0 + ELSE + ec0(mgs) = (essfrac2 - tmp)/(essfrac2 - essfrac1) + ENDIF + ENDIF + + csacs(mgs) = ec0(mgs)*rvt*aa2*ess(mgs)*cx(mgs,ls)**2*Min( xv(mgs,ls), 4.*pii/3.*essrmax**3 ) ! *Min(1.,xdn(mgs,ls)/100. ) ! Min func tries to recalibrate for low diagnosed density +! csacs(mgs) = rvt*aa2*ess(mgs)*cx(mgs,ls)**2*Min( xv(mgs,ls), 4.*pii/3.*0.02**3 ) ! *Min(1.,xdn(mgs,ls)/100. ) ! Min func tries to recalibrate for low diagnosed density + csacs(mgs) = Min(csacs(mgs),csmxd(mgs)) + ENDIF + end do + end if +! +! + if (ndebug .gt. 0 ) write(0,*) 'ICEZVD_GS: conc 11' + if ( ipconc .ge. 2 .or. ipelec .ge. 9 ) then + do mgs = 1,ngscnt + ciacw(mgs) = 0.0 + IF ( eiw(mgs) .gt. 0.0 ) THEN + ciacw(mgs) = qiacw(mgs)*rho0(mgs)/xmas(mgs,lc) + ciacw(mgs) = min(ciacw(mgs),ccmxd(mgs)) + ENDIF + end do + + end if + + if (ndebug .gt. 0 ) write(0,*) 'ICEZVD_GS: conc 18' + if ( ipconc .ge. 2 .or. ipelec .ge. 1 ) then + do mgs = 1,ngscnt + cracw(mgs) = 0.0 + cracr(mgs) = 0.0 + ec0(mgs) = 1.e9 + IF ( qx(mgs,lc) .gt. qxmin(lc) .and. qx(mgs,lr) .gt. qxmin(lr) & + & .and. qracw(mgs) .gt. 0.0 ) THEN + + IF ( ipconc .lt. 3 ) THEN + IF ( erw(mgs) .gt. 0.0 ) THEN + cracw(mgs) = & + & ((0.25)*pi)*erw(mgs)*(cx(mgs,lc) - ccwresv(mgs))*cx(mgs,lr) & + & *abs(vtxbar(mgs,lr,1)-vtxbar(mgs,lc,1)) & + & *( gf1*xdia(mgs,lc,2) & + & + 2.0*gf2*xdia(mgs,lc,1)*xdia(mgs,lr,1) & + & + gf3*xdia(mgs,lr,2) ) + ENDIF + ELSE ! IF ( ipconc .ge. 3 .and. + IF ( dmrauto <= 0 .or. rho0(mgs)*qx(mgs,lr) > 1.2*xl2p(mgs) ) THEN !{ + IF ( 0.5*xdia(mgs,lr,3) .gt. rh(mgs) ) THEN ! { .or. cx(mgs,lr) .gt. nh(mgs) +! IF ( qx(mgs,lc) .gt. qxmin(lc) .and. qx(mgs,lr) .gt. qxmin(lr) ) THEN + IF ( 0.5*xdia(mgs,lr,3) .gt. rwradmn ) THEN ! r > 50.e-6 +! DM0CCC=A2*XNC*XNR*(XVC+XVR) ! (A11) +! NOTE: murain drops out, so same result for imurain = 1 and 3 + cracw(mgs) = aa2*cx(mgs,lr)*(cx(mgs,lc) - ccwresv(mgs))*(xv(mgs,lc) + xv(mgs,lr)) + ELSE + IF ( imurain == 3 ) THEN +! DM0CCC=A1*XNC*XNR*(((CNU+2.)/(CNU+1.))*XVC**2+((RNU+2.)/(RNU+1.))*XVR**2) ! (A13) + cracw(mgs) = aa1*cx(mgs,lr)*(cx(mgs,lc) - ccwresv(mgs))* & + & ((alpha(mgs,lc) + 2.)*xv(mgs,lc)**2/(alpha(mgs,lc) + 1.) + & + & (alpha(mgs,lr) + 2.)*xv(mgs,lr)**2/(alpha(mgs,lr) + 1.)) + ELSE ! imurain == 1 USE CP00 for rain DSD in diameter + cracw(mgs) = aa1*cx(mgs,lr)*(cx(mgs,lc) - ccwresv(mgs))* & + & ((alpha(mgs,lc) + 2.)*xv(mgs,lc)**2/(alpha(mgs,lc) + 1.) + & + & (alpha(mgs,lr) + 6.)*(alpha(mgs,lr) + 5.)*(alpha(mgs,lr) + 4.)*xv(mgs,lr)**2/ & + & ((alpha(mgs,lr) + 3.)*(alpha(mgs,lr) + 2.)*(alpha(mgs,lr) + 1.)) ) + ENDIF ! imurain + ENDIF + ENDIF ! } rh + ENDIF ! } dmrauto + ENDIF ! ipconc + ENDIF ! qc > qcmin & qr > qrmin + +! Rain self collection (cracr) and break-up (factor of ec0) +! +! + ec0(mgs) = 2.e9 + IF ( qx(mgs,lr) .gt. qxmin(lr) ) THEN + rwrad = 0.5*xdia(mgs,lr,3) + IF ( xdia(mgs,lr,3) .gt. 2.0e-3 .or. icracr <= 0 ) THEN + ec0(mgs) = 0.0 + cracr(mgs) = 0.0 + ELSE + IF ( dmrauto <= 0 .or. rho0(mgs)*qx(mgs,lr) > 1.2*xl2p(mgs) ) THEN + IF ( xdia(mgs,lr,3) .lt. 6.1e-4 ) THEN + ec0(mgs) = 1.0 + ELSE + ec0(mgs) = Exp(-50.0*(50.0*(xdia(mgs,lr,3) - 6.0e-4))) + ENDIF + + + IF ( rwrad .ge. 50.e-6 ) THEN + cracr(mgs) = ec0(mgs)*aa2*cx(mgs,lr)**2*xv(mgs,lr) + ELSE + IF ( imurain == 3 ) THEN + cracr(mgs) = ec0(mgs)*aa1*(cx(mgs,lr)*xv(mgs,lr))**2* & + & (alpha(mgs,lr) + 2.)/(alpha(mgs,lr) + 1.) + ELSE ! imurain == 1 + cracr(mgs) = ec0(mgs)*aa1*(cx(mgs,lr)*xv(mgs,lr))**2* & + & (alpha(mgs,lr) + 6.)*(alpha(mgs,lr) + 5.)*(alpha(mgs,lr) + 4.)/ & + & ((alpha(mgs,lr) + 3.)*(alpha(mgs,lr) + 2.)*(alpha(mgs,lr) + 1.)) + + ENDIF + ENDIF +! cracr(mgs) = Min(cracr(mgs),crmxd(mgs)) + ENDIF + ENDIF + ENDIF + +! cracw(mgs) = min(cracw(mgs),cxmxd(mgs,lc)) + end do + end if + +! +! +! +! Graupel +! + if (ndebug .gt. 0 ) write(0,*) 'ICEZVD_GS: conc 22ii' + chacw(:) = 0.0 + if ( ipconc .ge. 1 .or. ipelec .ge. 1 ) then + do mgs = 1,ngscnt + + IF ( ipconc .ge. 5 ) THEN + IF ( qhacw(mgs) .gt. 0.0 .and. xmas(mgs,lc) .gt. 0.0 ) THEN + +! This is the explict version of chacw, which turns out to be very close to the +! approximation that the droplet size does not change, to within a few percent. +! This may _not_ be the case for cnu other than zero! +! chacw(mgs) = (ehw(mgs)*cx(mgs,lc)*cx(mgs,lh)*(pi/4.)* +! : abs(vtxbar(mgs,lh,1)-vtxbar(mgs,lc,1))* +! : (2.0*xdia(mgs,lh,1)*(xdia(mgs,lh,1) + +! : xdia(mgs,lc,1)*gf43rds) + +! : xdia(mgs,lc,2)*gf53rds)) + +! chacw(mgs) = Min( chacw(mgs), 0.6*cx(mgs,lc)*dtpinv ) + +! chacw(mgs) = qhacw(mgs)*rho0(mgs)/xmas(mgs,lc) + chacw(mgs) = qhacw(mgs)*rho0(mgs)/xmascw(mgs) +! chacw(mgs) = min(chacw(mgs),cxmxd(mgs,lc)) + chacw(mgs) = Min( chacw(mgs), 0.5*(cx(mgs,lc) - ccwresv(mgs))*dtpinv ) + ELSE + qhacw(mgs) = 0.0 + ENDIF + ELSE + ! single-moment + chacw(mgs) = & + & ((0.25)*pi)*ehw(mgs)*cx(mgs,lc)*cx(mgs,lh) & + & *abs(vtxbar(mgs,lh,1)-vtxbar(mgs,lc,1)) & + & *( gf1*xdia(mgs,lc,2) & + & + 2.0*gf2*xdia(mgs,lc,1)*xdia(mgs,lh,1) & + & + gf3*xdia(mgs,lh,2) ) + chacw(mgs) = min(chacw(mgs),0.5*cx(mgs,lc)*dtpinv) +! chacw(mgs) = min(chacw(mgs),cxmxd(mgs,lc)) +! chacw(mgs) = min(chacw(mgs),ccmxd(mgs)) + ENDIF + end do + end if +! + if (ndebug .gt. 0 ) write(0,*) 'ICEZVD_GS: conc 22kk' + chaci(:) = 0.0 + if ( ipconc .ge. 1 .or. ipelec .ge. 1 ) then + do mgs = 1,ngscnt + IF ( ehi(mgs) .gt. 0.0 .or. ( ehiclsn(mgs) > 0.0 .and. ipelec > 0 )) THEN + IF ( ipconc .ge. 5 ) THEN + + vt = Sqrt((vtxbar(mgs,lh,1)-vtxbar(mgs,li,1))**2 + & + & 0.04*vtxbar(mgs,lh,1)*vtxbar(mgs,li,1) ) + + chaci0(mgs) = 0.25*pi*ehiclsn(mgs)*cx(mgs,lh)*cx(mgs,li)*vt* & + & ( da0lh(mgs)*xdia(mgs,lh,3)**2 + & + & dab0lh(mgs,lh,li)*xdia(mgs,lh,3)*xdia(mgs,li,3) + & + & da0(li)*xdia(mgs,li,3)**2 ) + + ELSE + chaci0(mgs) = & + & ((0.25)*pi)*ehiclsn(mgs)*cx(mgs,li)*cx(mgs,lh) & + & *abs(vtxbar(mgs,lh,1)-vtxbar(mgs,li,1)) & + & *( gf1*xdia(mgs,li,2) & + & + 2.0*gf2*xdia(mgs,li,1)*xdia(mgs,lh,1) & + & + gf3*xdia(mgs,lh,2) ) + ENDIF + + chaci(mgs) = min(ehi(mgs)*chaci0(mgs),cimxd(mgs)) + ENDIF + end do + end if + + + chacis(:) = 0.0 + if ( lis > 1 .and. ipconc .ge. 5 .or. ipelec .ge. 1 ) then + do mgs = 1,ngscnt + IF ( ehis(mgs) .gt. 0.0 .or. ( ehisclsn(mgs) > 0.0 .and. ipelec > 0 )) THEN + + vt = Sqrt((vtxbar(mgs,lh,1)-vtxbar(mgs,lis,1))**2 + & + & 0.04*vtxbar(mgs,lh,1)*vtxbar(mgs,lis,1) ) + + chacis0(mgs) = 0.25*pi*ehisclsn(mgs)*cx(mgs,lh)*cx(mgs,lis)*vt* & + & ( da0lh(mgs)*xdia(mgs,lh,3)**2 + & + & dab0lh(mgs,lh,lis)*xdia(mgs,lh,3)*xdia(mgs,lis,3) + & + & da0(lis)*xdia(mgs,lis,3)**2 ) + + + chacis(mgs) = min(ehis(mgs)*chacis0(mgs),cxmxd(mgs,lis)) + ENDIF + end do + end if +! +! + if (ndebug .gt. 0 ) write(0,*) 'ICEZVD_GS: conc 22nn' + chacs(:) = 0.0 + if ( ipconc .ge. 1 .or. ipelec .ge. 1 ) then + do mgs = 1,ngscnt + IF ( ehs(mgs) .gt. 0 ) THEN + IF ( ipconc .ge. 5 .or. ( ehsclsn(mgs) > 0.0 .and. ipelec > 0 ) ) THEN + + vt = Sqrt((vtxbar(mgs,lh,1)-vtxbar(mgs,ls,1))**2 + & + & 0.04*vtxbar(mgs,lh,1)*vtxbar(mgs,ls,1) ) + + chacs0(mgs) = 0.25*pi*ehsclsn(mgs)*cx(mgs,lh)*cx(mgs,ls)*vt* & + & ( da0lh(mgs)*xdia(mgs,lh,3)**2 + & + & dab0lh(mgs,lh,ls)*xdia(mgs,lh,3)*xdia(mgs,ls,3) + & + & da0(ls)*xdia(mgs,ls,3)**2 ) + + ELSE + chacs0(mgs) = & + & ((0.25)*pi)*ehsclsn(mgs)*cx(mgs,ls)*cx(mgs,lh) & + & *abs(vtxbar(mgs,lh,1)-vtxbar(mgs,ls,1)) & + & *( gf3*gf1*xdia(mgs,ls,2) & + & + 2.0*gf2*gf2*xdia(mgs,ls,1)*xdia(mgs,lh,1) & + & + gf1*gf3*xdia(mgs,lh,2) ) + ENDIF + chacs(mgs) = min(ehs(mgs)*chacs0(mgs),csmxd(mgs)) + ENDIF + end do + end if + + +! +! +! Hail +! + if (ndebug .gt. 0 ) write(0,*) 'ICEZVD_GS: conc 22ii' + chlacw(:) = 0.0 + if ( ipconc .ge. 1 .or. ipelec .ge. 1 ) then + do mgs = 1,ngscnt + + IF ( lhl .gt. 1 .and. ipconc .ge. 5 ) THEN + IF ( qhlacw(mgs) .gt. 0.0 .and. xmas(mgs,lc) .gt. 0.0 ) THEN + +! This is the explict version of chacw, which turns out to be very close to the +! approximation that the droplet size does not change, to within a few percent. +! This may _not_ be the case for cnu other than zero! +! chlacw(mgs) = (ehlw(mgs)*cx(mgs,lc)*cx(mgs,lhl)*(pi/4.)* +! : abs(vtxbar(mgs,lhl,1)-vtxbar(mgs,lc,1))* +! : (2.0*xdia(mgs,lhl,1)*(xdia(mgs,lhl,1) + +! : xdia(mgs,lc,1)*gf43rds) + +! : xdia(mgs,lc,2)*gf53rds)) + +! chlacw(mgs) = Min( chlacw(mgs), 0.6*cx(mgs,lc)*dtpinv ) + +! chlacw(mgs) = qhlacw(mgs)*rho0(mgs)/xmas(mgs,lc) + chlacw(mgs) = qhlacw(mgs)*rho0(mgs)/xmascw(mgs) +! chlacw(mgs) = min(chlacw(mgs),cxmxd(mgs,lc)) + chlacw(mgs) = Min( chlacw(mgs), 0.5*cx(mgs,lc)*dtpinv ) + ELSE + qhlacw(mgs) = 0.0 + ENDIF +! ELSE +! chlacw(mgs) = +! > ((0.25)*pi)*ehlw(mgs)*cx(mgs,lc)*cx(mgs,lhl) +! > *abs(vtxbar(mgs,lhl,1)-vtxbar(mgs,lc,1)) +! > *( gf1*xdia(mgs,lc,2) +! > + 2.0*gf2*xdia(mgs,lc,1)*xdia(mgs,lhl,1) +! > + gf3*xdia(mgs,lhl,2) ) +! chlacw(mgs) = min(chlacw(mgs),0.5*cx(mgs,lc)*dtpinv) +! chlacw(mgs) = min(chlacw(mgs),cxmxd(mgs,lc)) +! chlacw(mgs) = min(chlacw(mgs),ccmxd(mgs)) + ENDIF + end do + end if +! + if (ndebug .gt. 0 ) write(0,*) 'ICEZVD_GS: conc 22kk' + chlaci(:) = 0.0 + chlaci0(:) = 0.0 + if ( ipconc .ge. 1 .or. ipelec .ge. 1 ) then + do mgs = 1,ngscnt + IF ( lhl .gt. 1 .and. ( ehli(mgs) .gt. 0.0 .or. (ipelec > 0 .and. ehliclsn(mgs) > 0.0) ) ) THEN + IF ( ipconc .ge. 5 ) THEN + + vt = Sqrt((vtxbar(mgs,lhl,1)-vtxbar(mgs,li,1))**2 + & + & 0.04*vtxbar(mgs,lhl,1)*vtxbar(mgs,li,1) ) + + chlaci0(mgs) = 0.25*pi*ehliclsn(mgs)*cx(mgs,lhl)*cx(mgs,li)*vt* & + & ( da0lhl(mgs)*xdia(mgs,lhl,3)**2 + & + & dab0(lhl,li)*xdia(mgs,lhl,3)*xdia(mgs,li,3) + & + & da0(li)*xdia(mgs,li,3)**2 ) + +! ELSE +! chlaci(mgs) = +! > ((0.25)*pi)*ehli(mgs)*cx(mgs,li)*cx(mgs,lhl) +! > *abs(vtxbar(mgs,lhl,1)-vtxbar(mgs,li,1)) +! > *( gf1*xdia(mgs,li,2) +! > + 2.0*gf2*xdia(mgs,li,1)*xdia(mgs,lhl,1) +! > + gf3*xdia(mgs,lhl,2) ) + ENDIF + + chlaci(mgs) = min(ehli(mgs)*chlaci0(mgs),cimxd(mgs)) + ENDIF + end do + end if + + + IF ( lis > 1 .and. ipconc .ge. 5) THEN + + if (ndebug .gt. 0 ) write(0,*) 'ICEZVD_GS: conc 22kk' + chlacis(:) = 0.0 + chlacis0(:) = 0.0 + do mgs = 1,ngscnt + IF ( lhl .gt. 1 .and. ( ehlis(mgs) .gt. 0.0 .or. (ipelec > 0 .and. ehlisclsn(mgs) > 0.0) ) ) THEN + + vt = Sqrt((vtxbar(mgs,lhl,1)-vtxbar(mgs,lis,1))**2 + & + & 0.04*vtxbar(mgs,lhl,1)*vtxbar(mgs,lis,1) ) + + chlacis0(mgs) = 0.25*pi*ehlisclsn(mgs)*cx(mgs,lhl)*cx(mgs,lis)*vt* & + & ( da0lhl(mgs)*xdia(mgs,lhl,3)**2 + & + & dab0(lhl,lis)*xdia(mgs,lhl,3)*xdia(mgs,lis,3) + & + & da0(lis)*xdia(mgs,lis,3)**2 ) + + + chlacis(mgs) = min(ehlis(mgs)*chlacis0(mgs),cxmxd(mgs,lis)) + ENDIF + end do + ENDIF + +! +! + if (ndebug .gt. 0 ) write(0,*) 'ICEZVD_GS: conc 22jj' + chlacs(:) = 0.0 + chlacs0(:) = 0.0 + if ( ipconc .ge. 1 .or. ipelec .ge. 1 ) then + do mgs = 1,ngscnt + IF ( lhl .gt. 1 .and. ( ehls(mgs) .gt. 0.0 .or. (ipelec > 0 .and. ehlsclsn(mgs) > 0.0) ) ) THEN + IF ( ipconc .ge. 5 ) THEN + + vt = Sqrt((vtxbar(mgs,lhl,1)-vtxbar(mgs,ls,1))**2 + & + & 0.04*vtxbar(mgs,lhl,1)*vtxbar(mgs,ls,1) ) + + chlacs0(mgs) = 0.25*pi*ehlsclsn(mgs)*cx(mgs,lhl)*cx(mgs,ls)*vt* & + & ( da0lhl(mgs)*xdia(mgs,lhl,3)**2 + & + & dab0(lhl,ls)*xdia(mgs,lhl,3)*xdia(mgs,ls,3) + & + & da0(ls)*xdia(mgs,ls,3)**2 ) + +! ELSE +! chlacs(mgs) = +! > ((0.25)*pi)*ehls(mgs)*cx(mgs,ls)*cx(mgs,lhl) +! > *abs(vtxbar(mgs,lhl,1)-vtxbar(mgs,ls,1)) +! > *( gf3*gf1*xdia(mgs,ls,2) +! > + 2.0*gf2*gf2*xdia(mgs,ls,1)*xdia(mgs,lhl,1) +! > + gf1*gf3*xdia(mgs,lhl,2) ) + ENDIF + chlacs(mgs) = min(ehls(mgs)*chlacs0(mgs),csmxd(mgs)) + ENDIF + end do + end if + +! +! Ziegler (1985) autoconversion +! +! + IF ( ipconc .ge. 2 .and. ircnw /= -1) THEN ! DTD: added flag for autoconversion. If -1, turns off autoconversion + if (ndebug .gt. 0 ) write(0,*) 'conc 26a' + + DO mgs = 1,ngscnt + zrcnw(mgs) = 0.0 + qrcnw(mgs) = 0.0 + crcnw(mgs) = 0.0 + cautn(mgs) = 0.0 + ENDDO + + IF ( dmrauto >= -1 ) THEN !{ + DO mgs = 1,ngscnt +! qracw(mgs) = 0.0 +! cracw(mgs) = 0.0 + IF ( qx(mgs,lc) .gt. qxmin(lc) .and. cx(mgs,lc) .gt. 1000. .and. temg(mgs) .gt. tfrh+4.) THEN + !( .and. w(igs(mgs),jgs,kgs(mgs)) > 5.0) THEN ! DTD: added w threshold for testing + volb = xv(mgs,lc)*(1./(1.+alpha(mgs,lc)))**(1./2.) + cautn(mgs) = Min(ccmxd(mgs), & + & ((alpha(mgs,lc)+2.)/(alpha(mgs,lc)+1.))*aa1*cx(mgs,lc)**2*xv(mgs,lc)**2) + cautn(mgs) = Max( 0.0d0, cautn(mgs) ) + IF ( rb(mgs) .le. 7.51d-6 .or. dmrauto == -1) THEN + t2s = 1.d30 +! cautn(mgs) = 0.0 + ELSE +! XL2P=2.7E-2*XNC*XVC*((1.E12*RB**3*RC)-0.4) + +! T2S=3.72E-3/(((1.E4*RB)-7.5)*XNC*XVC) +! t2s = 3.72E-3/(((1.e6*rb)-7.5)*cx(mgs,lc)*xv(mgs,lc)) +! t2s = 3.72/(((1.e6*rb(mgs))-7.5)*rho0(mgs)*qx(mgs,lc)) + t2s = 3.72/(1.e6*(rb(mgs)-7.500d-6)*rho0(mgs)*qx(mgs,lc)) + + qrcnw(mgs) = Max( 0.0d0, xl2p(mgs)/(t2s*rho0(mgs)) ) + crcnw(mgs) = Max( 0.0d0, Min(3.5e9*xl2p(mgs)/t2s,0.5*cautn(mgs)) ) + + IF ( dmrauto == 0 ) THEN + IF ( qx(mgs,lr)*rho0(mgs) > 1.2*xl2p(mgs) .and. cx(mgs,lr) > cxmin ) THEN ! Cohard and Pinty (2000a) switch over from (18) to (19) + crcnw(mgs) = cx(mgs,lr)/qx(mgs,lr)*qrcnw(mgs) + ELSEIF ( ( dmropt == 1 .or. dmropt == 3 ) .and. qx(mgs,lr) > qxmin(lr) ) THEN + tmp = qrcnw(mgs)*cx(mgs,lr)/qx(mgs,lr) + crcnw(mgs) = Min(tmp,crcnw(mgs) ) + ELSEIF ( ( dmropt == 4 ) .and. qx(mgs,lr) > qxmin(lr) ) THEN + tmp = crcnw(mgs) + tmp2 = qrcnw(mgs)*cx(mgs,lr)/qx(mgs,lr) + ! try mass-weighted average of old and new Dmr using converted qc mass + crcnw(mgs) = (tmp*qrcnw(mgs)+tmp2*qx(mgs,lr))/(qrcnw(mgs)+qx(mgs,lr)) + ELSEIF ( ( dmropt == 5 ) .and. qx(mgs,lr) > qxmin(lr) ) THEN + tmp = crcnw(mgs) + tmp2 = qrcnw(mgs)*cx(mgs,lr)/qx(mgs,lr) + ! try mass-weighted average of old and new Dmr using full qc mass + crcnw(mgs) = (tmp*qx(mgs,lc)+tmp2*qx(mgs,lr))/(qx(mgs,lc)+qx(mgs,lr)) + ELSEIF ( ( dmropt == 6 ) .and. qx(mgs,lr) > qxmin(lr) ) THEN + tmp = crcnw(mgs) + tmp2 = qrcnw(mgs)*cx(mgs,lr)/qx(mgs,lr) + ! try mass*diameter-weighted average of old and new Dmr (using full qc mass) + crcnw(mgs) = (tmp*xdia(mgs,lc,3)*qx(mgs,lc)+tmp2*xdia(mgs,lr,3)*qx(mgs,lr))/(xdia(mgs,lc,3)*qx(mgs,lc)+xdia(mgs,lr,3)*qx(mgs,lr)) + ELSEIF ( ( dmropt == 7 ) .and. qx(mgs,lr) > qxmin(lr) ) THEN + tmp = crcnw(mgs) + tmp2 = qrcnw(mgs)*cx(mgs,lr)/qx(mgs,lr) + ! try diameter-weighted average of old and new Dmr + crcnw(mgs) = (tmp*xdia(mgs,lc,3)+tmp2*xdia(mgs,lr,3))/(xdia(mgs,lc,3)+xdia(mgs,lr,3)) + ELSEIF ( ( dmropt == 8 ) .and. qx(mgs,lr) > qxmin(lr) ) THEN + tmp = crcnw(mgs) + tmp2 = qrcnw(mgs)*cx(mgs,lr)/qx(mgs,lr) + ! try sqrt(diameter)-weighted average of old and new Dmr + crcnw(mgs) = (tmp*sqrt(xdia(mgs,lc,3))+tmp2*sqrt(xdia(mgs,lr,3)))/(sqrt(xdia(mgs,lc,3))+sqrt(xdia(mgs,lr,3))) + ENDIF + ELSEIF ( dmrauto == 1 .and. cx(mgs,lr) > cxmin) THEN + IF ( qx(mgs,lr) > qxmin(lr) ) THEN + tmp = qrcnw(mgs)*cx(mgs,lr)/qx(mgs,lr) + crcnw(mgs) = Min(tmp,crcnw(mgs) ) + ENDIF + ELSEIF ( dmrauto == 2 .and. cx(mgs,lr) > cxmin) THEN + tmp = crcnw(mgs) + tmp2 = qrcnw(mgs)*cx(mgs,lr)/qx(mgs,lr) + ! try mass-weighted average of old and new Dmr + crcnw(mgs) = (tmp*qrcnw(mgs)+tmp2*qx(mgs,lr))/(qrcnw(mgs)+qx(mgs,lr)) + ELSEIF ( dmrauto == 3 .and. cx(mgs,lr) > cxmin) THEN ! adapted from MY/CP code + tmp = Max( 2.d0*rh(mgs), dble( xdia(mgs,lr,3) ) ) + crcnw(mgs) = rho0(mgs)*qrcnw(mgs)/(pi/6.*1000.*tmp**3) + ENDIF + + IF ( crcnw(mgs) < 1.e-30 ) qrcnw(mgs) = 0.0 + +! IF ( crcnw(mgs) .gt. cautn(mgs) .and. crcnw(mgs) .gt. 1.0 ) +! : THEN +! write(0,*) 'crcnw,cautn ',crcnw(mgs)/cautn(mgs), +! : crcnw(mgs),cautn(mgs),igs(mgs),kgs(mgs),t2s,qx(mgs,lr) +! write(0,*) ' ',qx(mgs,lc),cx(mgs,lc),0.5e6*xdia(mgs,lc,1) +! write(0,*) ' ',rho0(mgs)*qrcnw(mgs)/crcnw(mgs), +! : 1.e6*(( 3/(4.*pi))*rho0(mgs)*qrcnw(mgs)/ +! : (crcnw(mgs)*xdn(mgs,lr)))**(1./3.),rh(mgs)*1.e6,rwrad(mgs) +! ELSEIF ( crcnw(mgs) .gt. 1.0 .and. cautn(mgs) .gt. 0.) THEN +! write(0,*) 'crcnw,cautn ',crcnw(mgs)/cautn(mgs), +! : crcnw(mgs),cautn(mgs),igs(mgs),kgs(mgs),t2s +! write(0,*) ' ',rho0(mgs)*qrcnw(mgs)/crcnw(mgs), +! : 1.e6*(( 3*pi/4.)*rho0(mgs)*qrcnw(mgs)/ +! : (crcnw(mgs)*xdn(mgs,lr)))**(1./3.) +! ENDIF +! crcnw(mgs) = Min(cautn(mgs),3.5e9*xl2p(mgs)/t2s) + +! IF ( qrcnw(mgs) .gt. 0.3e-2 ) THEN +! write(0,*) 'QRCNW' +! write(0,*) qrcnw(mgs),crcnw(mgs),cautn(mgs) +! write(0,*) xl2p,t2s,rho0(mgs),xv(mgs,lc),cx(mgs,lc),qx(mgs,lc) +! write(0,*) rb,0.5*xdia(mgs,lc,1),mgs,igs(mgs),kgs(mgs) +! ENDIF +! qrcnw(mgs) = Min(qrcnw(mgs),qcmxd(mgs)) + ENDIF + + + ENDIF + ENDDO + + ENDIF !} dmrauto >= 0 + + + + ELSE + +! +! Berry 1968 auto conversion for rain (Orville & Kopp 1977) +! +! + if ( ircnw .eq. 4 ) then + do mgs = 1,ngscnt +! sconvmix(lcw,mgs) = 0.0 + qrcnw(mgs) = 0.0 + qdiff = max((qx(mgs,lc)-qminrncw),0.0) + if ( qdiff .gt. 0.0 .and. xdia(mgs,lc,1) .gt. 20.0e-6 ) then + argrcnw = & + & ((1.2e-4)+(1.596e-12)*(cx(mgs,lc)*1.0e-6) & + & /(cwdisp*qdiff*1.0e-3*rho0(mgs))) + qrcnw(mgs) = (rho0(mgs)*1e-3)*(qdiff**2)/argrcnw +! sconvmix(lcw,mgs) = max(sconvmix(lcw,mgs),0.0) + qrcnw(mgs) = (max(qrcnw(mgs),0.0)) + end if + end do + + ENDIF +! +! +! +! Berry 1968 auto conversion for rain (Ferrier 1994) +! +! + if ( ircnw .eq. 5 ) then + do mgs = 1,ngscnt + qrcnw(mgs) = 0.0 + qrcnw(mgs) = 0.0 + qccrit = (pi/6.)*(cx(mgs,lc)*cwdiap**3)*xdn(mgs,lc)/rho0(mgs) + qdiff = max((qx(mgs,lc)-qccrit),0.) + if ( qdiff .gt. 0.0 .and. cx(mgs,lc) .gt. 1.0 ) then + argrcnw = & +! > ((1.2e-4)+(1.596e-12)*cx(mgs,lc)/(cwdisp*rho0(mgs)*qdiff)) & + & ((1.2e-4)+(1.596e-12)*cx(mgs,lc)*1.0e-3/(cwdisp*rho0(mgs)*qdiff)) + qrcnw(mgs) = & +! > timflg(mgs)*rho0(mgs)*(qdiff**2)/argrcnw & + & 1.0e-3*rho0(mgs)*(qdiff**2)/argrcnw + qrcnw(mgs) = Min(qxmxd(mgs,lc), (max(qrcnw(mgs),0.0)) ) + +! write(iunit,*) 'qrcnw,cx =',qrcnw(mgs),cx(mgs,lc),mgs,1.e3*qx(mgs,lc),cno(lr) + end if + end do + end if + +! +! +! kessler auto conversion for rain. +! + if ( ircnw .eq. 2 ) then + do mgs = 1,ngscnt + qrcnw(mgs) = 0.0 + qrcnw(mgs) = (0.001)*max((qx(mgs,lc)-qminrncw),0.0) + end do + end if +! +! c4 = pi/6 +! c1 = 0.12-0.32 for colorado storms...typically 0.3-0.4 +! berry reinhart type conversion (proctor 1988) +! + if ( ircnw .eq. 1 ) then + do mgs = 1,ngscnt + qrcnw(mgs) = 0.0 + c1 = 0.2 + c4 = pi/(6.0) + bradp = & + & (1.e+06) * ((c1/(0.38))**(1./3.)) * (xdia(mgs,lc,1)*(0.5)) + bl2 = & + & (0.027) * ((100.0)*(bradp**3)*(xdia(mgs,lc,1)*(0.5)) - (0.4)) + bt2 = (bradp -7.5) / (3.72) + qrcnw(mgs) = 0.0 + if ( bl2 .gt. 0.0 .and. bt2 .gt. 0.0 ) then + qrcnw(mgs) = bl2 * bt2 * rho0(mgs) & + & * qx(mgs,lc) * qx(mgs,lc) + end if + end do + end if + + + + ENDIF ! ( ipconc .ge. 2 ) + +! +! +! +! Bigg Freezing of Rain +! + if (ndebug .gt. 0 ) write(0,*) 'conc 27a' + qrfrz(:) = 0.0 + qrfrzs(:) = 0.0 + qrfrzf(:) = 0.0 + vrfrzf(:) = 0.0 + crfrz(:) = 0.0 + crfrzs(:) = 0.0 + crfrzf(:) = 0.0 + zrfrz(:) = 0.0 + zrfrzs(:) = 0.0 + zrfrzf(:) = 0.0 + qwcnr(:) = 0.0 + + IF ( .not. ( ipconc == 0 .and. lwsm6 ) ) THEN + + do mgs = 1,ngscnt + if ( qx(mgs,lr) .gt. qxmin(lr) .and. temcg(mgs) .lt. -5. .and. ibiggopt > 0 ) then +! brz = 100.0 +! arz = 0.66 + IF ( ipconc .lt. 3 ) THEN + qrfrz(mgs) = & + & min( & + & (20.0)*(pi**2)*brz*(xdn(mgs,lr)/rho0(mgs)) & + & *cx(mgs,lr)*(xdia(mgs,lr,1)**6) & + & *(exp(max(-arz*temcg(mgs), 0.0))-1.0) & + & , qrmxd(mgs)) + qrfrzf(mgs) = qrfrz(mgs) + +! ELSEIF ( ipconc .ge. 3 .and. xv(mgs,lr) .gt. 1.1*xvmn(lr) ) THEN + ELSEIF ( ipconc .ge. 3 ) THEN +! tmp = brz*cx(mgs,lr)*(Exp(Max( -arz*temcg(mgs), 0.0 )) - 1.0) +! crfrz(mgs) = xv(mgs,lr)*tmp + + frach = 1.0d0 + +! IF ( ibiggopt == 2 .and. imurain == 1 .and. lzr < 1 ) THEN ! lzr check because results are weird for 3-moment + IF ( ibiggopt == 2 .and. imurain == 1 ) THEN ! + ! integrate from Bigg diameter (for given supercooling Ts) to infinity + + volt = exp( 16.2 + 1.0*temcg(mgs) )* 1.0e-6 ! Ts == -temcg ; volt comes from the fit in Fig. 1 in Bigg 1953 (Proc. Phys. Soc. London) + ! for mean temperature for freezing: -ln (V) = a*Ts - b, where a = 6.9/6.8, or approx a = 1.0, and b = 16.2 + ! volt is given in cm**3, so convert to m**3 + dbigg = (6./pi* volt )**(1./3.) + + ! perhaps should also test that W > V_t_dbigg, i.e., that drops the size of dbigg are being lifted and cooled. + IF ( dbigg < 8.e-3 ) THEN !{ only bother if freezing diameter is reasonable + + ratio = Min(maxratiolu, dbigg/xdia(mgs,lr,1) ) + + i = Min(nqiacrratio,Int(ratio*dqiacrratioinv)) + IF ( alp0flag ) THEN + j = Int(Max(0.0,Min(15.,alpha(mgs,lr)))*dqiacralphainv) + ELSE + j = Int(Max(minalphalu,Min(maxalphalu,alpha(mgs,lr)))*dqiacralphainv) + ENDIF + delx = ratio - float(i)*dqiacrratio + dely = alpha(mgs,lr) - float(j)*dqiacralpha + ip1 = Min( i+1, nqiacrratio ) + jp1 = Min( j+1, nqiacralpha ) + + ! interpolate along x, i.e., ratio; + tmp1 = ciacrratio(i,j) + delx*dqiacrratioinv*(ciacrratio(ip1,j) - ciacrratio(i,j)) + tmp2 = ciacrratio(i,jp1) + delx*dqiacrratioinv*(ciacrratio(ip1,jp1) - ciacrratio(i,jp1)) + + ! interpolate along alpha; + + crfrz(mgs) = (tmp1 + dely*dqiacralphainv*(tmp2 - tmp1))*cx(mgs,lr)*dtpinv + crfrzf(mgs) = crfrz(mgs) + ! interpolate along x, i.e., ratio; + tmp1 = qiacrratio(i,j) + delx*dqiacrratioinv*(qiacrratio(ip1,j) - qiacrratio(i,j)) + tmp2 = qiacrratio(i,jp1) + delx*dqiacrratioinv*(qiacrratio(ip1,jp1) - qiacrratio(i,jp1)) + + ! interpolate along alpha; + + qrfrz(mgs) = (tmp1 + dely*dqiacralphainv*(tmp2 - tmp1))*qx(mgs,lr)*dtpinv + qrfrzf(mgs) = qrfrz(mgs) + + IF ( qrfrz(mgs)*dtp < qxmin(lh) .or. crfrz(mgs)*dtp < cxmin ) THEN + + crfrz(mgs) = 0.0 + qrfrz(mgs) = 0.0 + qrfrzf(mgs) = 0.0 + + ELSE !{ + + + + IF ( ibiggsmallrain > 0 .and. xv(mgs,lr) < 2.*xvmn(lr) .and. ( ibiggsnow == 1 .or. ibiggsnow == 3 ) ) THEN +! IF ( ibiggsmallrain > 0 .and. xv(mgs,lr) < xvbiggsnow .and. ( ibiggsnow == 1 .or. ibiggsnow == 3 ) ) THEN + ! rain drops are so small that they cannot be pushed smaller, so put into snow (or cloud ice, depending on ifrzs) + crfrzf(mgs) = 0.0 + qrfrzf(mgs) = 0.0 + crfrzs(mgs) = crfrz(mgs) + qrfrzs(mgs) = qrfrz(mgs) + + ELSEIF ( dbigg < Max( biggsnowdiam, Max(dfrz,dhmn)) .and. ( ibiggsnow == 1 .or. ibiggsnow == 3 ) ) THEN ! { convert some to snow or ice crystals + ! temporarily store qrfrz and crfrz in snow terms and caclulate new crfrzf, qrfrzf, and zrfrzf. Leave crfrz etc. alone! + + crfrzs(mgs) = crfrz(mgs) + qrfrzs(mgs) = qrfrz(mgs) + + IF ( ibiggsmallrain > 0 .and. xv(mgs,lr) < 1.2*xvmn(lr) ) THEN + ! rain drops are so small that they cannot be pushed smaller, so put into snow (or cloud ice, depending on ifrzs) + crfrzf(mgs) = 0.0 + qrfrzf(mgs) = 0.0 + + ELSE !{ + + ! recalculate using dhmn for ratio + ratio = Min( maxratiolu, Max(dfrz,dhmn)/xdia(mgs,lr,1) ) + + i = Min(nqiacrratio,Int(ratio*dqiacrratioinv)) +! j = Int(Max(0.0,Min(15.,alpha(mgs,lr)))*dqiacralphainv) +! j = Int(Max(alphamin,Min(alphamax,alpha(mgs,lr)))*dqiacralphainv) + IF ( alp0flag ) THEN + j = Int(Max(0.0,Min(15.,alpha(mgs,lr)))*dqiacralphainv) + ELSE + j = Int(Max(minalphalu,Min(maxalphalu,alpha(mgs,lr)))*dqiacralphainv) + ENDIF + delx = ratio - float(i)*dqiacrratio + dely = alpha(mgs,lr) - float(j)*dqiacralpha + ip1 = Min( i+1, nqiacrratio ) + jp1 = Min( j+1, nqiacralpha ) + + ! interpolate along x, i.e., ratio; + tmp1 = ciacrratio(i,j) + delx*dqiacrratioinv*(ciacrratio(ip1,j) - ciacrratio(i,j)) + tmp2 = ciacrratio(i,jp1) + delx*dqiacrratioinv*(ciacrratio(ip1,jp1) - ciacrratio(i,jp1)) + + + ! interpolate along alpha; + + crfrzf(mgs) = (tmp1 + dely*dqiacralphainv*(tmp2 - tmp1))*cx(mgs,lr)*dtpinv + + ! interpolate along x, i.e., ratio; + tmp1 = qiacrratio(i,j) + delx*dqiacrratioinv*(qiacrratio(ip1,j) - qiacrratio(i,j)) + tmp2 = qiacrratio(i,jp1) + delx*dqiacrratioinv*(qiacrratio(ip1,jp1) - qiacrratio(i,jp1)) + + ! interpolate along alpha; + + qrfrzf(mgs) = (tmp1 + dely*dqiacralphainv*(tmp2 - tmp1))*qx(mgs,lr)*dtpinv + + ! now subtract off the difference + crfrzs(mgs) = crfrzs(mgs) - crfrzf(mgs) + qrfrzs(mgs) = qrfrzs(mgs) - qrfrzf(mgs) + + ENDIF ! } + ELSE + crfrzs(mgs) = 0.0 + qrfrzs(mgs) = 0.0 + ENDIF ! } + + ENDIF !} + + IF ( (qrfrz(mgs))*dtp > qx(mgs,lr) ) THEN + fac = ( qrfrz(mgs) )*dtp/qx(mgs,lr) + qrfrz(mgs) = fac*qrfrz(mgs) + qrfrzs(mgs) = fac*qrfrzs(mgs) + qrfrzf(mgs) = fac*qrfrzf(mgs) + crfrz(mgs) = fac*crfrz(mgs) + crfrzs(mgs) = fac*crfrzs(mgs) + crfrzf(mgs) = fac*crfrzf(mgs) + ENDIF + + ENDIF !} + +! IF ( (crfrzs(mgs) + crfrz(mgs))*dtp > cx(mgs,lr) ) THEN +! fac = ( crfrzs(mgs) + crfrz(mgs) )*dtp/cx(mgs,lr) +! crfrz(mgs) = fac*crfrz(mgs) +! crfrzs(mgs) = fac*crfrzs(mgs) +! ENDIF + +! qrfrzf(mgs) = qrfrz(mgs) +! crfrzf(mgs) = crfrz(mgs) + + ! qrfrz(mgs) = qrfrzf(mgs) + qrfrzs(mgs) + ! crfrz(mgs) = crfrzf(mgs) + crfrzs(mgs) + + + ELSEIF ( ibiggopt == 1 ) THEN + ! Z85, eq. A34 + tmp = xv(mgs,lr)*brz*cx(mgs,lr)*(Exp(Max( -arz*temcg(mgs), 0.0 )) - 1.0) + IF ( .false. .and. tmp .gt. cxmxd(mgs,lr) ) THEN ! { +! write(iunit,*) 'Bigg Freezing problem!',mgs,igs(mgs),kgs(mgs) +! write(iunit,*) 'tmp, cx(lr), xv = ',tmp, cx(mgs,lr), xv(mgs,lr), (Exp(Max( -arz*temcg(mgs), 0.0 )) - 1.0) +! write(iunit,*) 'qr,temcg = ',qx(mgs,lr)*1000.,temcg(mgs) + crfrz(mgs) = cxmxd(mgs,lr) ! cx(mgs,lr)*dtpinv + qrfrz(mgs) = qxmxd(mgs,lr) ! qx(mgs,lr)*dtpinv +! STOP + ELSE ! } { + crfrz(mgs) = tmp + ! crfrzfmx = cx(mgs,lr)*Exp(-4./3.*pi*(40.e-6)**3/xv(mgs,lr)) + ! IF ( crfrz(mgs) .gt. crfrzmx ) THEN + ! crfrz(mgs) = crfrzmx + ! qrfrz(mgs) = bfnu*xmas(mgs,lr)*rhoinv(mgs)*crfrzmx + ! qwcnr(mgs) = cx(mgs,lr) - crfrzmx + ! ELSE + IF ( lzr < 1 ) THEN + IF ( imurain == 3 ) THEN + bfnu = bfnu0 + ELSE !imurain == 1 + bfnu = bfnu1 + ENDIF + ELSE + ! bfnu = 1.0 ! (alpha(mgs,lr)+2.0)/(alpha(mgs,lr)+1.) + IF ( imurain == 3 ) THEN + bfnu = (alpha(mgs,lr)+2.0)/(alpha(mgs,lr)+1.) + ELSE !imurain == 1 +! bfnu = bfnu1 + bfnu = (4. + alpha(mgs,lr))*(5. + alpha(mgs,lr))*(6. + alpha(mgs,lr))/ & + & ((1. + alpha(mgs,lr))*(2. + alpha(mgs,lr))*(3. + alpha(mgs,lr))) +! bfnu = 1. + ENDIF + ENDIF + qrfrz(mgs) = bfnu*xmas(mgs,lr)*rhoinv(mgs)*crfrz(mgs) + + qrfrz(mgs) = Min( qrfrz(mgs), 1.*qx(mgs,lr)*dtpinv ) ! qxmxd(mgs,lr) + crfrz(mgs) = Min( crfrz(mgs), 1.*cx(mgs,lr)*dtpinv ) !cxmxd(mgs,lr) + qrfrz(mgs) = Min( qrfrz(mgs), qx(mgs,lr) ) + qrfrzf(mgs) = qrfrz(mgs) + ENDIF !} + + + + + IF ( crfrz(mgs) .gt. qxmin(lh) ) THEN !{ Yes, it compares cx and qxmin, but this is just to be sure that + ! crfrz is greater than zero in the division +! IF ( xdia(mgs,lr,1) .lt. 200.e-6 ) THEN +! IF ( xv(mgs,lr) .lt. xvmn(lh) ) THEN + + IF ( (ibiggsnow == 1 .or. ibiggsnow == 3 ) .and. ibiggopt /= 2 ) THEN + xvfrz = rho0(mgs)*qrfrz(mgs)/(crfrz(mgs)*900.) ! mean volume of frozen drops; 900. for frozen drop density + frach = 0.5 *(1. + Tanh(0.2e12 *( xvfrz - 1.15*xvmn(lh)))) + + qrfrzs(mgs) = (1.-frach)*qrfrz(mgs) + crfrzs(mgs) = (1.-frach)*crfrz(mgs) ! *rzxh(mgs) +! qrfrzf(mgs) = frach*qrfrz(mgs) + + ENDIF + + IF ( ipconc .ge. 14 .and. 1.e-3*rho0(mgs)*qrfrz(mgs)/crfrz(mgs) .lt. xvmn(lh) ) THEN + qrfrzs(mgs) = qrfrz(mgs) + crfrzs(mgs) = crfrz(mgs) ! *rzxh(mgs) + ELSE +! crfrz(mgs) = Min( crfrz(mgs), 0.1*cx(mgs,lr)*dtpinv ) ! cxmxd(mgs,lr) +! qrfrz(mgs) = Min( qrfrz(mgs), 0.1*qx(mgs,lr)*dtpinv ) ! qxmxd(mgs,lr) + qrfrzf(mgs) = frach*qrfrz(mgs) +! crfrzf(mgs) = Min( qrfrz(mgs)*rho0(mgs)/(xdn(mgs,lh)*vgra), crfrz(mgs) ) + IF ( ibfr .le. 1 ) THEN + crfrzf(mgs) = frach*Min(crfrz(mgs), qrfrz(mgs)/(bfnu*1.0*vr1mm*1000.0)*rho0(mgs) ) ! rzxh(mgs)*crfrz(mgs) + ELSEIF ( ibfr .eq. 5 ) THEN + crfrzf(mgs) = frach*Min(crfrz(mgs), qrfrz(mgs)/(bfnu*vfrz*1000.0)*rho0(mgs) )*rzxh(mgs) !*crfrz(mgs) + ELSEIF ( ibfr .eq. 2 ) THEN + crfrzf(mgs) = frach*Min(crfrz(mgs), qrfrz(mgs)/(bfnu*vfrz*1000.0)*rho0(mgs) ) ! rzxh(mgs)*crfrz(mgs) + ELSEIF ( ibfr .eq. 6 ) THEN + crfrzf(mgs) = frach*Max(crfrz(mgs), qrfrz(mgs)/(bfnu*9.*xv(mgs,lr)*1000.0)*rho0(mgs) ) ! rzxh(mgs)*crfrz(mgs) + ELSE + crfrzf(mgs) = frach*crfrz(mgs) + ENDIF +! crfrzf(mgs) = Min(crfrz(mgs), qrfrz(mgs)/(bfnu*xvmn(lh)*1000.0)*rho0(mgs) ) ! rzxh(mgs)*crfrz(mgs) +! IF ( lz(lr) > 1 .and. lz(lh) > 1 ) THEN +! crfrzf(mgs) = crfrz(mgs) +! ENDIF + + ENDIF +! crfrz(mgs) = Min( cxmxd(mgs,lr), rho0(mgs)*qrfrz(mgs)/xmas(mgs,lr) ) + ELSE + crfrz(mgs) = 0.0 + qrfrz(mgs) = 0.0 + ENDIF !} + + ENDIF ! ibiggopt + + IF ( lvol(lh) .gt. 1 ) THEN + vrfrzf(mgs) = rho0(mgs)*qrfrzf(mgs)/rhofrz + ENDIF + + + IF ( nsplinter .ne. 0 ) THEN + IF ( nsplinter .ge. 1000 ) THEN + ! Lawson et al. 2015 JAS + ! ave. diam of freezing drops in microns + tmp = 0 + IF ( qrfrz(mgs)*dtp > qxmin(lh) .and. crfrz(mgs) > 1.e-3 ) THEN + tmpdiam = 1.e6*( 6.*qrfrz(mgs)/(1000.*pi*crfrz(mgs) ))**(1./3.) ! avg. diameter of newly frozen drops in microns + tmp = lawson_splinter_fac*tmpdiam**4*crfrz(mgs) + ENDIF + ELSEIF ( nsplinter .gt. 0 ) THEN + tmp = nsplinter*crfrz(mgs) + ELSE + tmp = -nsplinter*crfrzf(mgs) + ENDIF + csplinter2(mgs) = tmp + qsplinter2(mgs) = Min(0.1*qrfrz(mgs), tmp*splintermass/rho0(mgs) ) ! makes splinters smaller if too much mass is taken from graupel + +! csplinter(mgs) = csplinter(mgs) + tmp +! qsplinter(mgs) = qsplinter(mgs) + Min(0.1*qrfrz(mgs), tmp*splintermass/rho0(mgs) ) ! makes splinters smaller if too much mass is taken from graupel + ENDIF +! IF ( temcg(mgs) .lt. -31.0 ) THEN +! qrfrz(mgs) = qx(mgs,lr)*dtpinv + qrcnw(mgs) +! qrfrzf(mgs) = qrfrz(mgs) +! crfrz(mgs) = cx(mgs,lr)*dtpinv + crcnw(mgs) +! crfrzf(mgs) = Min(crfrz(mgs), qrfrz(mgs)/(bfnu*1.0*vr1mm*1000.0)*rho0(mgs) ) ! rzxh(mgs)*crfrz(mgs) +! ENDIF +! qrfrz(mgs) = 6.0*xdn(mgs,lr)*xv(mgs,lr)**2*tmp*rhoinv(mgs) +! qrfrz(mgs) = Min( qrfrz(mgs), ffrz*qrmxd(mgs) ) +! crfrz(mgs) = Min( crmxd(mgs), ffrz*crfrz(mgs)) +! crfrz(mgs) = Min(crmxd(mgs),qrfrz(mgs)*rho0(mgs)/xmas(mgs,lr)) + ENDIF +! if ( temg(mgs) .gt. 268.15 ) then + else +! end if + end if + end do + + ENDIF +! +! Homogeneous freezing of cloud drops to ice crystals +! following Bigg (1953) and Ferrier (1994). +! + if (ndebug .gt. 0 ) write(0,*) 'conc 25b' + do mgs = 1,ngscnt + qwfrz(mgs) = 0.0 + cwfrz(mgs) = 0.0 + qwfrzc(mgs) = 0.0 + cwfrzc(mgs) = 0.0 + qwfrzp(mgs) = 0.0 + cwfrzp(mgs) = 0.0 + IF ( ibfc .ge. 1 .and. ibfc /= 3 .and. temg(mgs) < 268.15 ) THEN +! if ( qx(mgs,lc) .gt. qxmin(lc) .and. cx(mgs,lc) .gt. 1. .and. & +! & .not. (ipconc .ge. 2 .and. xdia(mgs,lc,1) .lt. 10.e-6) ) then + if ( qx(mgs,lc) .gt. qxmin(lc) .and. cx(mgs,lc) .gt. cxmin ) THEN + IF ( ipconc < 2 ) THEN + qwfrz(mgs) = ((2.0)*(brz)/(xdn(mgs,lc)*cx(mgs,lc))) & + & *(exp(max(-arz*temcg(mgs), 0.0))-1.0) & + & *rho0(mgs)*(qx(mgs,lc)**2) + qwfrz(mgs) = max(qwfrz(mgs), 0.0) + qwfrz(mgs) = min(qwfrz(mgs),qcmxd(mgs)) + cwfrz(mgs) = qwfrz(mgs)*rho0(mgs)/xmas(mgs,li) + ELSEIF ( ipconc .ge. 2 ) THEN + IF ( xdia(mgs,lc,3) > 0.e-6 ) THEN + volt = exp( 16.2 + 1.0*temcg(mgs) )* 1.0e-6 ! Ts == -temcg ; volt comes from the fit in Fig. 1 in Bigg 1953 + ! for mean temperature for freezing: -ln (V) = a*Ts - b + ! volt is given in cm**3, so factor of 1.e-6 to convert to m**3 +! dbigg = (6./pi* volt )**(1./3.) + + IF ( alpha(mgs,lc) == 0.0 ) THEN + cwfrz(mgs) = cx(mgs,lc)*Exp(-volt/xv(mgs,lc))*dtpinv ! number of droplets with volume greater than volt +!turn off limit so that all can freeze at low temp +!!! cwfrz(mgs) = Min(cwfrz(mgs),ccmxd(mgs)) + + qwfrz(mgs) = cwfrz(mgs)*xdn0(lc)*rhoinv(mgs)*(volt + xv(mgs,lc)) + ELSE + ratio = (1. + alpha(mgs,lc))*volt/xv(mgs,lc) + + IF ( .false. .and. usegamxinfcnu ) THEN + i = Nint(dgami*(1. + alpha(mgs,lc))) + gcnup1 = gmoi(i) + i = Nint(dgami*(2. + alpha(mgs,lc))) + gcnup2 = gmoi(i) + + cwfrz(mgs) = cx(mgs,lc)*Gamxinf(1.+alpha(mgs,lc), ratio)/(dtp*gcnup1) ! gamxinflu(i,j,1,1) + + qwfrz(mgs) = cx(mgs,lc)*xdn0(lc)*xv(mgs,lc)*rhoinv(mgs)*Gamxinf(2.+alpha(mgs,lc), ratio)/(dtp*gcnup2) ! gamxinflu(i,j,12,1) + + ELSE + + ratio = Min( maxratiolu, ratio ) +! write(0,*) 'cwfrz: temp,ratio = ',temcg(mgs),ratio +! write(0,*) 'cwfrz: xv,volt,qx = ',xv(mgs,lc),volt,qx(mgs,lc) +! write(0,*) 'cwfrz: i,j,k = ',igs(mgs),jgs,kgs(mgs) + tmp = gaminterp(ratio,alpha(mgs,lc),1,1) +! write(0,*) 'cwfrz: tmp1 = ',tmp + cwfrz(mgs) = cx(mgs,lc)*tmp*dtpinv ! Gamxinf(1.+alpha(mgs,lc), ratio)/(dtp*gcnup1) ! gamxinflu(i,j,1,1) + + tmp = gaminterp(ratio,alpha(mgs,lc),12,1) +! write(0,*) 'cwfrz: tmp2 = ',tmp + qwfrz(mgs) = cx(mgs,lc)*xdn0(lc)*xv(mgs,lc)*rhoinv(mgs)*dtpinv*tmp ! Gamxinf(2.+alpha(mgs,lc), ratio)/(dtp*gcnup2) ! gamxinflu(i,j,12,1) + + ENDIF + + ENDIF + + ENDIF + ENDIF + if ( temg(mgs) .gt. 268.15 ) then + qwfrz(mgs) = 0.0 + cwfrz(mgs) = 0.0 + end if + end if + ENDIF +! + if ( xplate(mgs) .eq. 1 ) then + qwfrzp(mgs) = qwfrz(mgs) + cwfrzp(mgs) = cwfrz(mgs) + end if +! + if ( xcolmn(mgs) .eq. 1 ) then + qwfrzc(mgs) = qwfrz(mgs) + cwfrzc(mgs) = cwfrz(mgs) + end if + +! +! qwfrzp(mgs) = 0.0 +! qwfrzc(mgs) = qwfrz(mgs) +! + end do +! +! +! Contact freezing nucleation: factor is to convert from L-1 +! T < -2C: via Meyers et al. JAM July, 1992 (31, 708-721) +! + if (ndebug .gt. 0 ) write(0,*) 'conc 25a' + do mgs = 1,ngscnt + + ccia(mgs) = 0.0 + + cwctfz(mgs) = 0.0 + qwctfz(mgs) = 0.0 + ctfzbd(mgs) = 0.0 + ctfzth(mgs) = 0.0 + ctfzdi(mgs) = 0.0 + + cwctfzc(mgs) = 0.0 + qwctfzc(mgs) = 0.0 + cwctfzp(mgs) = 0.0 + qwctfzp(mgs) = 0.0 + IF ( icfn .ge. 1 ) THEN + + IF ( temg(mgs) .lt. 271.15 .and. qx(mgs,lc) .gt. qxmin(lc)) THEN + +! find available # of ice nuclei & limit value to max depletion of cloud water + + IF ( icfn .ge. 2 ) THEN + ccia(mgs) = exp( 4.11 - (0.262)*temcg(mgs) ) ! in m-3, see Walko et al. 1995; 1000*exp(-2.8 -b*t) = exp(6.91)*exp(-2.8 - b*t) = exp(4.11 -b*t) + !ccia(mgs) = Min(cwctfz(mgs), ccmxd(mgs) ) + +! now find how many of these collect cloud water to form IN +! Cotton et al 1986 + + knud(mgs) = 2.28e-5 * temg(mgs) / ( pres(mgs)*raero ) !Walko et al. 1995 + knuda(mgs) = 1.257 + 0.4*exp(-1.1/knud(mgs)) !Pruppacher & Klett 1997 eqn 11-16 + gtp(mgs) = 1. / ( fai(mgs) + fbi(mgs) ) !Byers 65 / Cotton 72b + dfar(mgs) = kb*temg(mgs)*(1.+knuda(mgs)*knud(mgs))/(6.*pi*fadvisc(mgs)*raero) !P&K 1997 eqn 11-15 + fn1(mgs) = 2.*pi*xdia(mgs,lc,1)*cx(mgs,lc)*ccia(mgs) + fn2(mgs) = -gtp(mgs)*(ssw(mgs)-1.)*felv(mgs)/pres(mgs) + fnft(mgs) = 0.4*(1.+1.45*knud(mgs)+0.4*knud(mgs)*exp(-1./knud(mgs)))*(ftka(mgs)+2.5*knud(mgs)*kaero) & + & / ( (1.+3.*knud(mgs))*(2*ftka(mgs)+5.*knud(mgs)*kaero+kaero) ) + + +! Brownian diffusion + ctfzbd(mgs) = fn1(mgs)*dfar(mgs) + +! Thermophoretic contact nucleation + ctfzth(mgs) = fn1(mgs)*fn2(mgs)*fnft(mgs)/rho0(mgs) + +! Diffusiophoretic contact nucleation + ctfzdi(mgs) = fn1(mgs)*fn2(mgs)*rw*temg(mgs)/(felv(mgs)*rho0(mgs)) + + cwctfz(mgs) = max( ctfzbd(mgs) + ctfzth(mgs) + ctfzdi(mgs) , 0.) + +! Sum of the contact nucleation processes +! IF ( cx(mgs,lc) .gt. 1.e6) write(0,*) 'ctfzbd,etc = ',cwctfz(mgs),ctfzbd(mgs),ctfzth(mgs),ctfzdi(mgs) +! IF ( wvel(mgs) .lt. -0.05 ) write(6,*) 'ctfzbd,etc = ',ctfzbd(mgs),ctfzth(mgs),ctfzdi(mgs),cx(mgs,lc)*1e-6,wvel(mgs) +! IF ( ssw(mgs) .lt. 1.0 .and. cx(mgs,lc) .gt. 1.e6 .and. cwctfz(mgs) .gt. 1. ) THEN +! write(6,*) 'ctfzbd,etc = ',ctfzbd(mgs),ctfzth(mgs),ctfzdi(mgs),cx(mgs,lc)*1e-6,wvel(mgs),fn1(mgs),fn2(mgs) +! write(6,*) 'more = ',nstep,ssw(mgs),dfar(mgs),gtp(mgs),felv(mgs),pres(mgs) +! ENDIF + + ELSEIF ( icfn .eq. 1 ) THEN + IF ( wvel(mgs) .lt. -0.05 ) THEN ! older kludgy version + cwctfz(mgs) = cfnfac*exp( (-2.80) - (0.262)*temcg(mgs) ) + cwctfz(mgs) = Min((1.0e3)*cwctfz(mgs), ccmxd(mgs) ) !convert to m-3 + ENDIF + ENDIF ! icfn + + IF ( ipconc .ge. 2 ) THEN + cwctfz(mgs) = Min( cwctfz(mgs)*dtpinv, ccmxd(mgs) ) + qwctfz(mgs) = xmas(mgs,lc)*cwctfz(mgs)/rho0(mgs) + ELSE + qwctfz(mgs) = (cimasn)*cwctfz(mgs)/(dtp*rho0(mgs)) + qwctfz(mgs) = max(qwctfz(mgs), 0.0) + qwctfz(mgs) = min(qwctfz(mgs),qcmxd(mgs)) + ENDIF + +! + if ( xplate(mgs) .eq. 1 ) then + qwctfzp(mgs) = qwctfz(mgs) + cwctfzp(mgs) = cwctfz(mgs) + end if +! + if ( xcolmn(mgs) .eq. 1 ) then + qwctfzc(mgs) = qwctfz(mgs) + cwctfzc(mgs) = cwctfz(mgs) + end if + +! IF ( cwctfz(mgs)*dtp > 0.5 .and. dtp*qwctfz(mgs) > qxmin(li) ) THEN +! write(91,*) 'cwctfz: ',cwctfz(mgs),qwctfz(mgs) ! ,cwctfzc(mgs),qwctfzc(mgs) +! ENDIF + +! +! qwctfzc(mgs) = qwctfz(mgs) +! qwctfzp(mgs) = 0.0 +! + end if + + ENDIF ! icfn + + end do +! +! +! +! Hobbs-Rangno ice enhancement (Ferrier, 1994) +! + if (ndebug .gt. 0 ) write(0,*) 'conc 23a' + dthr = 300.0 + hrifac = (1.e-3)*((0.044)*(0.01**3)) + do mgs = 1,ngscnt + ciihr(mgs) = 0.0 + qiihr(mgs) = 0.0 + cicichr(mgs) = 0.0 + qicichr(mgs) = 0.0 + cipiphr(mgs) = 0.0 + qipiphr(mgs) = 0.0 + IF ( ihrn .ge. 1 ) THEN + if ( qx(mgs,lc) .gt. qxmin(lc) ) then + if ( temg(mgs) .lt. 273.15 ) then +! write(iunit,'(3(1x,i3),3(1x,1pe12.5))') +! : igs(mgs),jgs,kgs(mgs),cx(mgs,lc),rho0(mgs),qx(mgs,lc) +! write(iunit,'(1pe15.6)') +! : log(cx(mgs,lc)*(1.e-6)/(3.0)), +! : ((1.e-3)*rho0(mgs)*qx(mgs,lc)), +! : (cx(mgs,lc)*(1.e-6)), +! : ((1.e-3)*rho0(mgs)*qx(mgs,lc))/(cx(mgs,lc)*(1.e-6)), +! : (alog(cx(mgs,lc)*(1.e-6)/(3.0)) * +! > ((1.e-3)*rho0(mgs)*qx(mgs,lc))/(cx(mgs,lc)*(1.e-6))) + + IF ( Log(cx(mgs,lc)*(1.e-6)/(3.0)) .gt. 0.0 ) THEN + ciihr(mgs) = ((1.69e17)/dthr) & + & *(log(cx(mgs,lc)*(1.e-6)/(3.0)) * & + & ((1.e-3)*rho0(mgs)*qx(mgs,lc))/(cx(mgs,lc)*(1.e-6)))**(7./3.) + ciihr(mgs) = ciihr(mgs)*(1.0e6) + qiihr(mgs) = hrifac*ciihr(mgs)/rho0(mgs) + qiihr(mgs) = max(qiihr(mgs), 0.0) + qiihr(mgs) = min(qiihr(mgs),qcmxd(mgs)) + ENDIF +! + if ( xplate(mgs) .eq. 1 ) then + qipiphr(mgs) = qiihr(mgs) + cipiphr(mgs) = ciihr(mgs) + end if +! + if ( xcolmn(mgs) .eq. 1 ) then + qicichr(mgs) = qiihr(mgs) + cicichr(mgs) = ciihr(mgs) + end if +! +! qipiphr(mgs) = 0.0 +! qicichr(mgs) = qiihr(mgs) +! + end if + end if + ENDIF ! ihrn + end do +! +! +! +! simple frozen rain to hail conversion. All of the +! frozen rain larger than 5.0e-3 m in diameter are converted +! to hail. This is done by considering the equation for +! frozen rain mixing ratio: +! +! +! qfw = [ cno(lf) * pi * fwdn / (6 rhoair) ] +! +! /inf +! * | fwdia*3 exp(-dia/fwdia) d(dia) +! /Do +! +! The amount to be reclassified as hail is the integral above from +! Do to inf where Do is 5.0e-3 m. +! +! +! qfauh = [ cno(lf) * pi * fwdn / (6 rhoair) ] +! +! + + + hdia0 = 300.0e-6 + do mgs = 1,ngscnt + qscnvi(mgs) = 0.0 + cscnvi(mgs) = 0.0 + cscnvis(mgs) = 0.0 +! IF ( .false. ) THEN +! IF ( temg(mgs) .lt. tfr .and. ssi(mgs) .gt. 1.01 .and. qx(mgs,li) .gt. qxmin(li) ) THEN + IF ( temg(mgs) .lt. tfr .and. qx(mgs,li) .gt. qxmin(li) ) THEN + IF ( ipconc .ge. 4 .and. .false. ) THEN + if ( cx(mgs,li) .gt. 10. .and. xdia(mgs,li,1) .gt. 50.e-6 ) then !{ + cirdiatmp = & + & (qx(mgs,li)*rho0(mgs) & + & /(pi*xdn(mgs,li)*cx(mgs,li)))**(1./3.) + IF ( cirdiatmp .gt. 100.e-6 ) THEN !{ + qscnvi(mgs) = & + & ((pi*xdn(mgs,li)*cx(mgs,li)) / (6.0*rho0(mgs)*dtp)) & + & *exp(-hdia0/cirdiatmp) & + & *( (hdia0**3) + 3.0*(hdia0**2)*cirdiatmp & + & + 6.0*(hdia0)*(cirdiatmp**2) + 6.0*(cirdiatmp**3) ) + qscnvi(mgs) = & + & min(qscnvi(mgs),qimxd(mgs)) + IF ( ipconc .ge. 4 ) THEN + cscnvi(mgs) = Min( cimxd(mgs), cx(mgs,li)*Exp(-hdia0/cirdiatmp)) + ENDIF + ENDIF ! } + end if ! } + + ELSEIF ( ipconc .lt. 4 ) THEN + + qscnvi(mgs) = 0.001*eii(mgs)*max((qx(mgs,li)-1.e-3),0.0) + qscnvi(mgs) = min(qscnvi(mgs),qxmxd(mgs,li)) + cscnvi(mgs) = qscnvi(mgs)*rho0(mgs)/xmas(mgs,li) + cscnvis(mgs) = 0.5*cscnvi(mgs) + + ENDIF + ENDIF +! ENDIF + end do + + + +! +! Ventilation coeficients +! + do mgs = 1,ngscnt + fvent(mgs) = (fschm(mgs)**(1./3.)) * (fakvisc(mgs)**(-0.5)) + end do +! +! + if ( ndebug .gt. 0 ) write(0,*) 'civent' +! + civenta = 1.258e4 + civentb = 2.331 + civentc = 5.662e4 + civentd = 2.373 + civente = 0.8241 + civentf = -0.042 + civentg = 1.70 + + do mgs = 1,ngscnt + IF ( icond .eq. 1 .or. temg(mgs) .le. tfrh & + & .or. (qx(mgs,lr) .le. qxmin(lr) .and. qx(mgs,lc) .le. qxmin(lc)) ) THEN + IF ( qx(mgs,li) .gt. qxmin(li) ) THEN + cireyn = & + & (civenta*xdia(mgs,li,1)**civentb & + & +civentc*xdia(mgs,li,1)**civentd) & + & / & + & (civente*xdia(mgs,li,1)**civentf+civentg) + xcivent = (fschm(mgs)**(1./3.))*((cireyn/fakvisc(mgs))**0.5) + if ( xcivent .lt. 1.0 ) then + civent(mgs) = 1.0 + 0.14*xcivent**2 + end if + if ( xcivent .ge. 1.0 ) then + civent(mgs) = 0.86 + 0.28*xcivent + end if + ELSE + civent(mgs) = 0.0 + ENDIF + + + ENDIF ! icond .eq. 1 + end do + +! +! + igmrwa = 100.0*2.0 + igmrwb = 100.*((5.0+br)/2.0) + rwventa = (0.78)*gmoi(igmrwa) ! 0.78 + rwventb = (0.308)*gmoi(igmrwb) ! 0.562825 + do mgs = 1,ngscnt + IF ( qx(mgs,lr) .gt. qxmin(lr) ) THEN + IF ( ipconc .ge. 3 ) THEN + IF ( imurain == 3 ) THEN + IF ( izwisventr == 1 ) THEN + rwvent(mgs) = ventrx(mgs)*(1.6 + 124.9*(1.e-3*rho0(mgs)*qx(mgs,lr))**.2046) + ELSE ! izwisventr = 2 +! Following Wisner et al. (1972) but using gamma of volume. Note that Ferrier rain fall speed does not integrate with gamma of volume, so using Vr = ar*d^br + rwvent(mgs) = & + & (0.78*ventrx(mgs) + 0.308*ventrxn(mgs)*fvent(mgs) & + & *Sqrt((ar*rhovt(mgs))) & + & *(xdia(mgs,lr,1)**((1.0+br)/2.0)) ) + ENDIF + + ELSE ! imurain == 1 + ! linear interpolation of complete gamma function +! tmp = 2. + alpha(mgs,lr) +! i = Int(dgami*(tmp)) +! del = tmp - dgam*i +! x = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami + + IF ( iferwisventr == 1 ) THEN + + ! Ferrier fall speed in the ventillation term [uses fx(lr) ] + + alpr = Min(alpharmax,alpha(mgs,lr) ) + + x = 1. + alpha(mgs,lr) + + IF ( lzr > 1 ) THEN ! 3 moment +! + ELSE + y = ventrxn(mgs) + ENDIF + +! vent1 = dble(xdia(mgs,lr,1))**(-2. - alpr) ! Actually OK +! vent2 = dble(1./xdia(mgs,lr,1) + 0.5*fx(lr))**dble(2.5+alpr+0.5*bx(lr)) ! Actually OK + vent1 = dble(xdia(mgs,lr,1))**(0.5 + 0.5*bx(lr)) ! 2016.2.26 Changed for consistency with derivation (recast formula -- should be equivalent) + vent2 = dble(1. + 0.5*fx(lr)*xdia(mgs,lr,1))**dble(2.5+alpr+0.5*bx(lr)) + + + rwvent(mgs) = & + & 0.78*x + & + & 0.308*fvent(mgs)*y* & + & Sqrt(ax(lr)*rhovt(mgs))*(vent1/vent2) + + + ELSEIF ( iferwisventr == 2 ) THEN + +! Following Wisner et al. (1972) but using gamma of volume. Note that Ferrier rain fall speed does not integrate with gamma of volume, so using Vr = ar*d^br + x = 1. + alpha(mgs,lr) + + rwvent(mgs) = & + & (0.78*x + 0.308*ventrxn(mgs)*fvent(mgs) & + & *Sqrt((ar*rhovt(mgs))) & + & *(xdia(mgs,lr,1)**((1.0+br)/2.0)) ) + + + + ENDIF ! iferwisventr + + ENDIF ! imurain + ELSE + rwvent(mgs) = & + & (rwventa + rwventb*fvent(mgs) & + & *Sqrt((ar*rhovt(mgs))) & + & *(xdia(mgs,lr,1)**((1.0+br)/2.0)) ) + ENDIF + ELSE + rwvent(mgs) = 0.0 + ENDIF + end do +! + igmswa = 100.0*2.0 + igmswb = 100.*((5.0+ds)/2.0) + swventa = (0.78)*gmoi(igmswa) + swventb = (0.308)*gmoi(igmswb) + do mgs = 1,ngscnt + IF ( qx(mgs,ls) .gt. qxmin(ls) ) THEN + IF ( ipconc .ge. 4 ) THEN + swvent(mgs) = 0.65 + 0.44*fvent(mgs)*Sqrt(vtxbar(mgs,ls,1)*xdia(mgs,ls,1)) + ELSE +! 10-ice version: + swvent(mgs) = & + & (swventa + swventb*fvent(mgs) & + & *Sqrt((cs*rhovt(mgs))) & + & *(xdia(mgs,ls,1)**((1.0+ds)/2.0)) ) + ENDIF + ELSE + swvent(mgs) = 0.0 + ENDIF + end do +! +! + + igmhwa = 100.0*2.0 + igmhwb = 100.0*2.75 + hwventa = (0.78)*gmoi(igmhwa) + hwventb = (0.308)*gmoi(igmhwb) +! hwventc = (4.0*gr/(3.0*cdx(lh)))**(0.25) + do mgs = 1,ngscnt + IF ( qx(mgs,lh) .gt. qxmin(lh) ) THEN + hwventc = (4.0*gr/(3.0*cdxgs(mgs,lh)))**(0.25) + IF ( .false. .or. alpha(mgs,lh) .eq. 0.0 ) THEN + hwvent(mgs) = & + & ( hwventa + hwventb*hwventc*fvent(mgs) & + & *((xdn(mgs,lh)/rho0(mgs))**(0.25)) & + & *(xdia(mgs,lh,1)**(0.75))) + ELSE ! Ferrier 1994, eq. B.36 + ! linear interpolation of complete gamma function +! tmp = 2. + alpha(mgs,lh) +! i = Int(dgami*(tmp)) +! del = tmp - dgam*i +! x = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami + +! note that hwvent includes a division by Gamma(1+alpha), so Gamma(2+alpha)/Gamma(1+alpha) = 1 + alpha +! and g1palp = Gamma(1+alpha) divides into y + x = 1. + alpha(mgs,lh) + + tmp = 1 + alpha(mgs,lh) + i = Int(dgami*(tmp)) + del = tmp - dgam*i + g1palp = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami + + tmp = 2.5 + alpha(mgs,lh) + 0.5*bxx(mgs,lh) + i = Int(dgami*(tmp)) + del = tmp - dgam*i + y = (gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami)/g1palp + + + hwventy(mgs) = 0.308*fvent(mgs)*(xdia(mgs,lh,1)**(0.5 + 0.5*bxx(mgs,lh)))*Sqrt(axx(mgs,lh)*rhovt(mgs)) + hwvent(mgs) = & + & ( 0.78*x + y*hwventy(mgs) ) ! & +! & 0.308*fvent(mgs)*y*(xdia(mgs,lh,1)**(0.5 + 0.5*bxx(mgs,lh)))* & +! & Sqrt(axx(mgs,lh)*rhovt(mgs)) ) + + ENDIF + ELSE + hwvent(mgs) = 0.0 + hwventy(mgs) = 0.0 + ENDIF + end do + + + hlvent(:) = 0.0 + hlventy(:) = 0.0 + + IF ( lhl .gt. 1 ) THEN + igmhwa = 100.0*2.0 + igmhwb = 100.0*2.75 + hwventa = (0.78)*gmoi(igmhwa) + hwventb = (0.308)*gmoi(igmhwb) +! hwventc = (4.0*gr/(3.0*cdx(lhl)))**(0.25) + do mgs = 1,ngscnt + IF ( qx(mgs,lhl) .gt. qxmin(lhl) ) THEN + hwventc = (4.0*gr/(3.0*cdxgs(mgs,lhl)))**(0.25) + + IF ( .false. .or. alpha(mgs,lhl) .eq. 0.0 ) THEN + hlvent(mgs) = & + & ( hwventa + hwventb*hwventc*fvent(mgs) & + & *((xdn(mgs,lhl)/rho0(mgs))**(0.25)) & + & *(xdia(mgs,lhl,1)**(0.75))) + ELSE ! Ferrier 1994, eq. B.36 + ! linear interpolation of complete gamma function +! tmp = 2. + alpha(mgs,lhl) +! i = Int(dgami*(tmp)) +! del = tmp - dgam*i +! x = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami + +! note that hlvent includes a division by Gamma(1+alpha), so x = Gamma(2+alpha)/Gamma(1+alpha) = 1 + alpha +! and g1palp = Gamma(1+alpha) divides into y + + x = 1. + alpha(mgs,lhl) + + tmp = 1 + alpha(mgs,lhl) + i = Int(dgami*(tmp)) + del = tmp - dgam*i + g1palp = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami + + tmp = 2.5 + alpha(mgs,lhl) + 0.5*bxx(mgs,lhl) + i = Int(dgami*(tmp)) + del = tmp - dgam*i + y = (gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami)/g1palp ! ratio of gamma functions + + hlventy(mgs) = 0.308*fvent(mgs)*(xdia(mgs,lhl,1)**(0.5 + 0.5*bxx(mgs,lhl)))*Sqrt(axx(mgs,lhl)*rhovt(mgs)) + + hlvent(mgs) = 0.78*x + y*hlventy(mgs) ! & +! & 0.308*fvent(mgs)*y*(xdia(mgs,lhl,1)**(0.5 + 0.5*bxx(mgs,lhl)))* & +! & Sqrt(axx(mgs,lhl)*rhovt(mgs))) +! : Sqrt(xdn(mgs,lhl)*ax(lhl)*rhovt(mgs)/rg0))/tmp + + ENDIF + ENDIF + end do + ENDIF + +! +! +! +! Wet growth constants +! + do mgs = 1,ngscnt + fwet1(mgs) = & + & (2.0*pi)* & + & ( felv(mgs)*fwvdf(mgs)*rho0(mgs)*(qss0(mgs)-qx(mgs,lv)) & + & -ftka(mgs)*temcg(mgs) ) & + & / ( rho0(mgs)*(felf(mgs)+fcw(mgs)*temcg(mgs)) ) + fwet2(mgs) = & + & (1.0)-fci(mgs)*temcg(mgs) & + & / ( felf(mgs)+fcw(mgs)*temcg(mgs) ) + end do +! +! Melting constants +! + do mgs = 1,ngscnt + fmlt1(mgs) = (2.0*pi)* & + & ( felv(mgs)*fwvdf(mgs)*(qss0(mgs)-qx(mgs,lv)) & + & -ftka(mgs)*temcg(mgs)/rho0(mgs) ) & + & / (felf(mgs)) + fmlt2(mgs) = -fcw(mgs)*temcg(mgs)/felf(mgs) + end do +! +! Vapor Deposition constants +! + do mgs = 1,ngscnt + fvds(mgs) = & + & (4.0*pi/rho0(mgs))*(ssi(mgs)-1.0)* & + & (1.0/(fai(mgs)+fbi(mgs))) + end do + do mgs = 1,ngscnt + fvce(mgs) = & + & (4.0*pi/rho0(mgs))*(ssw(mgs)-1.0)* & + & (1.0/(fav(mgs)+fbv(mgs))) + end do + +! +! deposition, sublimation, and melting of snow, graupel and hail +! + qsmlr(:) = 0.0 + qimlr(:) = 0.0 ! this is not used. qi melts to qc way down in the code. + qhmlr(:) = 0.0 + qhlmlr(:) = 0.0 + IF ( lhwlg > 1 ) THEN + qhmlrlg(:) = 0.0 + qhlmlrlg(:) = 0.0 + ENDIF + qhfzh(:) = 0.0 + qhlfzhl(:) = 0.0 + qhfzhlg(:) = 0.0 + qhlfzhllg(:) = 0.0 + vhfzh(:) = 0.0 + vffzf(:) = 0.0 + vhlfzhl(:) = 0.0 + qsfzs(:) = 0.0 + zsmlr(:) = 0.0 + zhmlr(:) = 0.0 + zhmlrr(:) = 0.0 + zhshr(:) = 0.0 + zhlmlr(:) = 0.0 + zhlshr(:) = 0.0 + + zhshrr(:) = 0.0 + zhlmlrr(:) = 0.0 + zhlshrr(:) = 0.0 + + csmlr(:) = 0.0 + csmlrr(:) = 0.0 + chmlr(:) = 0.0 + chmlrr(:) = 0.0 + chlmlr(:) = 0.0 + chlfmlr(:) = 0.0 +! chlmlrsave(:) = 0.0 +! qhlmlrsave(:) = 0.0 +! chlsave(:) = 0.0 +! qhlsave(:) = 0.0 + chlmlrr(:) = 0.0 + + + if ( .not. mixedphase ) then !{ + do mgs = 1,ngscnt +! + IF ( temg(mgs) .gt. tfr ) THEN + + IF ( qx(mgs,ls) .gt. qxmin(ls) ) THEN + qsmlr(mgs) = & + & min( & + & (c1sw*fmlt1(mgs)*cx(mgs,ls)*swvent(mgs)*xdia(mgs,ls,1) ) & ! /rhosm & + & , 0.0 ) + ENDIF + + +! IF ( qx(mgs,ls) .gt. 0.1e-4 ) write(0,*) 'qsmlr: ',qsmlr(mgs),qx(mgs,ls),cx(mgs,ls),fmlt1(mgs), +! : temcg(mgs),swvent(mgs),xdia(mgs,ls,1),qss0(mgs)-qx(mgs,lv) +! ELSE +! qsmlr(mgs) = 0.0 +! ENDIF +! 10ice version: +! > min( +! > (fmlt1(mgs)*cx(mgs,ls)*swvent(mgs)*xdia(mgs,ls,1) + +! > fmlt2(mgs)*(qsacr(mgs)+qsacw(mgs)) ) +! < , 0.0 ) + + IF ( qx(mgs,lh) .gt. qxmin(lh) ) THEN + + IF ( ibinhmlr == 0 .or. lzh < 1 ) THEN + qhmlr(mgs) = & + & meltfac*min( & + & fmlt1(mgs)*cx(mgs,lh)*hwvent(mgs)*xdia(mgs,lh,1) & + & + fmlt2(mgs)*(qhacrmlr(mgs)+qhacw(mgs)) & + & , 0.0 ) + ELSEIF ( ibinhmlr == 1 ) THEN ! use incomplete gamma functions to approximate the bin results + + errmsg = 'ibinhmlr = 1 not available for 2-moment' + errflg = 1 + RETURN + + ELSEIF ( ibinhmlr == 2 .or. ibinhmlr == 3 ) THEN + + ENDIF + + + IF ( ivhmltsoak > 0 .and. qhmlr(mgs) < 0.0 .and. lvol(lh) > 1 .and. xdn(mgs,lh) .lt. xdnmx(lh) ) THEN + ! act as if 100% of the meltwater were soaked into the graupel + v1 = (1. - xdn(mgs,lh)/xdnmx(lh))*(vx(mgs,lh) + rho0(mgs)*qhmlr(mgs)/xdn(mgs,lh) )/(dtp) ! volume available for filling + v2 = -1.0*rho0(mgs)*qhmlr(mgs)/xdnmx(lh) ! volume of melted ice if it were refrozen in the matrix + + vhsoak(mgs) = Min(v1,v2) + + ENDIF + + ENDIF ! qx(mgs,lh) .gt. qxmin(lh) + + + IF ( lhl .gt. 1 .and. lhlw < 1 ) THEN + + IF ( qx(mgs,lhl) .gt. qxmin(lhl) ) THEN + IF ( ibinhlmlr == 0 .or. lzhl < 1) THEN + qhlmlr(mgs) = & + & meltfac*min( & + & fmlt1(mgs)*cx(mgs,lhl)*hlvent(mgs)*xdia(mgs,lhl,1) & + & + fmlt2(mgs)*(qhlacrmlr(mgs)+qhlacw(mgs)) & + & , 0.0 ) + + ELSEIF ( ibinhlmlr == 1 ) THEN ! use incomplete gamma functions to approximate the bin results + +! #ifdef Z3MOM +! #if (defined Z3MOM) && defined( COMMAS ) || defined( COMMASTMP ) + + ELSEIF ( ibinhlmlr == -1 ) THEN ! OLD VERSION use incomplete gamma functions to approximate the bin results + + ENDIF ! ibinhlmlr + + + IF ( ivhmltsoak > 0 .and. qhlmlr(mgs) < 0.0 .and. lvol(lhl) > 1 .and. xdn(mgs,lhl) .lt. xdnmx(lhl) ) THEN + ! act as if 50% of the meltwater were soaked into the graupel + v1 = (1. - xdn(mgs,lhl)/xdnmx(lhl))*(vx(mgs,lhl) + rho0(mgs)*qhlmlr(mgs)/xdn(mgs,lhl) )/(dtp) ! volume available for filling + v2 = -1.0*rho0(mgs)*qhlmlr(mgs)/xdnmx(lhl) ! volume of melted ice if it were refrozen in the matrix + + vhlsoak(mgs) = Min(v1,v2) + + ENDIF + + ENDIF + ENDIF + + ENDIF + +! +! qimlr(mgs) = max( qimlr(mgs), -qimxd(mgs) ) +! qsmlr(mgs) = max( qsmlr(mgs), -qsmxd(mgs) ) +! erm 5/10/2007 changed to next line: + if ( .not. mixedphase ) qsmlr(mgs) = max( qsmlr(mgs), Min( -qsmxd(mgs), -0.7*qx(mgs,ls)*dtpinv ) ) + IF ( .not. mixedphase ) THEN + qhmlr(mgs) = max( qhmlr(mgs), Min( -qhmxd(mgs), -0.95*qx(mgs,lh)*dtpinv ) ) + chmlr(mgs) = max( chmlr(mgs), Min( -chmxd(mgs), -0.95*cx(mgs,lh)*dtpinv ) ) + ENDIF +! qhmlr(mgs) = max( max( qhmlr(mgs), -qhmxd(mgs) ) , -0.5*qx(mgs,lh)*dtpinv ) !limits to 1/2 qh or max depletion + qhmlh(mgs) = 0. + + + ! Rasmussen and Heymsfield say melt water remains on graupel up to 9 mm before shedding + + + IF ( lhl .gt. 1 .and. lhlw < 1 ) THEN + qhlmlr(mgs) = max( qhlmlr(mgs), Min( -qxmxd(mgs,lhl), -0.95*qx(mgs,lhl)*dtpinv ) ) + chlmlr(mgs) = max( chlmlr(mgs), Min( -cxmxd(mgs,lhl), -0.95*cx(mgs,lhl)*dtpinv ) ) + ENDIF + +! + end do + + endif ! } not mixedphase +! + if ( ipconc .ge. 1 ) then + do mgs = 1,ngscnt + cimlr(mgs) = (cx(mgs,li)/(qx(mgs,li)+1.e-20))*qimlr(mgs) + IF ( .not. mixedphase ) THEN !{ + IF ( xdia(mgs,ls,1) .gt. 1.e-6 .and. -qsmlr(mgs) .ge. 0.5*qxmin(ls) .and. ipconc .ge. 4 ) THEN +! csmlr(mgs) = rho0(mgs)*qsmlr(mgs)/(xv(mgs,ls)*rhosm) + csmlr(mgs) = (cx(mgs,ls)/(qx(mgs,ls)))*qsmlr(mgs) + ELSEIF ( qx(mgs,ls) > qxmin(ls) ) THEN + csmlr(mgs) = (cx(mgs,ls)/(qx(mgs,ls)))*qsmlr(mgs) + ENDIF + + csmlrr(mgs) = csmlr(mgs)/rzxs(mgs) + IF ( -csmlrr(mgs)*dtp > cxmin .and. -qsmlr(mgs)*dtp > qxmin(lr) .and. snowmeltdia > 0.0 ) THEN + rmas = rho0(mgs)*qsmlr(mgs)/csmlrr(mgs) + IF ( rmas > snowmeltmass ) THEN + csmlrr(mgs) = rho0(mgs)*qsmlr(mgs)/snowmeltmass + ENDIF + ENDIF + + + +! IF ( xdia(mgs,lh,1) .gt. 1.e-6 .and. Abs(qhmlr(mgs)) .ge. qxmin(lh) ) THEN +! chmlr(mgs) = rho0(mgs)*qhmlr(mgs)/(pi*xdn(mgs,lh)*xdia(mgs,lh,1)**3) ! out of hail +! chmlr(mgs) = Max( chmlr(mgs), -chmxd(mgs) ) +! ELSE + IF ( ibinhmlr == 0 .or. lzh < 1 ) THEN + chmlr(mgs) = (cx(mgs,lh)/(qx(mgs,lh)+1.e-20))*qhmlr(mgs) + IF ( imltshddmr == 3 .and. qhmlr(mgs) < -qxmin(lh) ) THEN + ! tmpdiam = (shedalp+alpha(mgs,lh))*xdia(mgs,lh,1) + ! + ! IF ( tmpdiam > sheddiam ) THEN ! let size get smaller until it reaches sheddiam + ! chmlr(mgs) = 0.0 + ! ENDIF + + ! test to remove the part of the melting associated with large ice particles so they get smaller + + tmp = 1. + alpha(mgs,lh) + i = Int(dgami*(tmp)) + del = tmp - dgam*i + g1palp = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami + + ratio = Min( maxratiolu, mltdiam1/xdia(mgs,lh,1) ) + + x = gamxinfdp(2. + alpha(mgs,lh), ratio)/g1palp + y = gamxinfdp(2.5 + alpha(mgs,lh) + 0.5*bxx(mgs,lh), ratio)/g1palp + + hwvent1 = 0.78*x + y*hwventy(mgs) + + qhlmlr1 = min( fmlt1(mgs)*cx(mgs,lh)*hwvent1*xdia(mgs,lh,1), 0.0 ) + + chmlr(mgs) = (cx(mgs,lh)/(qx(mgs,lh)+1.e-20))*(qhmlr(mgs) - qhlmlr1) + + + ENDIF +! IF ( igs(mgs) == 40 ) THEN +! write(0,*) 'is this running? chmlr = ',kgs(mgs), chmlr(mgs) +! ENDIF + ENDIF +! ENDIF + + + + IF ( chmlr(mgs) < 0.0 .and. (ibinhmlr < 1 .or. lzh < 1) ) THEN ! { already done if ibinhmlr > 0 + + IF ( ibinhmlr == 0 .or. lzh < 1 ) THEN + IF ( ihmlt .eq. 1 ) THEN + chmlrr(mgs) = Min( chmlr(mgs), rho0(mgs)*qhmlr(mgs)/(xdn(mgs,lr)*vmlt) ) ! into rain + ELSEIF ( ihmlt .eq. 2 ) THEN + IF ( xv(mgs,lh) .gt. 0.0 .and. chmlr(mgs) .lt. 0.0 ) THEN +! chmlrr(mgs) = Min( chmlr(mgs), rho0(mgs)*qhmlr(mgs)/(xdn(mgs,lh)*xv(mgs,lh)) ) ! into rain +! guess what, this is the same as chmlr: rho0*qhmlr/xmas(lh) --> cx/qx = rho0/xmas + IF(imltshddmr == 1) THEN + ! DTD: If Dmg < sheddiam, then assume complete melting into + ! maximal raindrop. Between sheddiam and sheddiam0 mm, linearly ramp down to a 3 mm shed drop + tmp = -rho0(mgs)*qhmlr(mgs)/(Min(xdn(mgs,lr)*xvmx(lr), xdn(mgs,lh)*xv(mgs,lh))) ! Min of Maximum raindrop size/mean hail size + tmp2 = -rho0(mgs)*qhmlr(mgs)/(xdn(mgs,lr)*vr3mm) ! conc. change for a 3 mm mean drop diameter + + chmlrr(mgs) = tmp*(sheddiam0-xdia(mgs,lh,3))/(sheddiam0-sheddiam)+tmp2*(xdia(mgs,lh,3)-sheddiam)/(sheddiam0-sheddiam) ! old version + chmlrr(mgs) = -Max(tmp,Min(tmp2,chmlrr(mgs))) + ELSEIF ( imltshddmr == 2 .or. imltshddmr == 3 ) THEN + ! 8/26/2015 ERM updated to use shedalp and tmpdiam + ! tmpdiam = (shedalp+alpha(mgs,lh))*xdia(mgs,lh,1) + chmlrr(mgs) = rho0(mgs)*qhmlr(mgs)/(xdn(mgs,lr)*vshdgs(mgs,lh)) ! into rain + ELSE ! Old method + chmlrr(mgs) = rho0(mgs)*qhmlr(mgs)/(Min(xdn(mgs,lr)*xvmx(lr), xdn(mgs,lh)*xv(mgs,lh))) ! into rain + ENDIF + ELSE + chmlrr(mgs) = chmlr(mgs) + ENDIF + ELSEIF ( ihmlt .eq. 0 ) THEN + chmlrr(mgs) = chmlr(mgs) + ENDIF + + ELSE ! ibinhmlr < 0? Already have an outer IF test for ibinhmlr < 1 + chmlrr(mgs) = Min( chmlrr(mgs), rho0(mgs)*qhmlr(mgs)/(xdn(mgs,lr)*xvmx(lr)) ) ! into rain + ENDIF + + ENDIF ! } ( chmlr(mgs) < 0.0 .and. ibinhmlr < 1) + + IF ( lhl .gt. 1 .and. lhlw < 1 .and. .not. mixedphase .and. qhlmlr(mgs) < 0.0 ) THEN ! { + + IF ( ibinhlmlr == 0 .or. lzhl < 1 ) THEN +! IF ( xdia(mgs,lhl,1) .gt. 1.e-6 .and. Abs(qhlmlr(mgs)) .ge. qxmin(lhl) ) THEN +! chlmlr(mgs) = rho0(mgs)*qhlmlr(mgs)/(pi*xdn(mgs,lhl)*xdia(mgs,lhl,1)**3) ! out of hail +! chlmlr(mgs) = Max( chlmlr(mgs), -cxmxd(mgs,lhl) ) +! ELSE + chlmlr(mgs) = (cx(mgs,lhl)/(qx(mgs,lhl)+1.e-20))*qhlmlr(mgs) + IF ( imltshddmr == 3 .and. qhlmlr(mgs) < -qxmin(lhl) ) THEN +! IF ( .false. .and. imltshddmr == 3 ) THEN +! tmpdiam = (shedalp+alpha(mgs,lhl))*xdia(mgs,lhl,1) +! +! IF ( tmpdiam > sheddiam ) THEN ! let size get smaller until it reaches sheddiam +! chlmlr(mgs) = 0.0 +! ENDIF + + ! test to remove the part of the melting associated with large ice particles so they get smaller +! + tmp = 1. + alpha(mgs,lhl) + i = Int(dgami*(tmp)) + del = tmp - dgam*i + g1palp = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami + + ratio = Min( maxratiolu, mltdiam1/xdia(mgs,lhl,1) ) + + x = gamxinfdp(2. + alpha(mgs,lhl), ratio)/g1palp + y = gamxinfdp(2.5 + alpha(mgs,lhl) + 0.5*bxx(mgs,lhl), ratio)/g1palp + + hwvent1 = 0.78*x + y*hlventy(mgs) + + qhlmlr1 = min( fmlt1(mgs)*cx(mgs,lhl)*hwvent1*xdia(mgs,lhl,1), 0.0 ) + + chlmlr(mgs) = (cx(mgs,lhl)/(qx(mgs,lhl)+1.e-20))*Min(0.0, qhlmlr(mgs) - qhlmlr1) + + ENDIF +! ENDIF + ENDIF + + IF ( ibinhlmlr == 0 .or. lzhl < 1 ) THEN !{ + IF ( ihmlt .eq. 1 ) THEN + chlmlrr(mgs) = Min( chlmlr(mgs), rho0(mgs)*qhlmlr(mgs)/(xdn(mgs,lr)*vmlt) ) ! into rain + ELSEIF ( ihmlt .eq. 2 ) THEN + IF ( xv(mgs,lhl) .gt. 0.0 .and. chlmlr(mgs) .lt. 0.0 ) THEN +! chlmlrr(mgs) = rho0(mgs)*qhlmlr(mgs)/(Min(xdn(mgs,lr)*xvmx(lr), xdn(mgs,lhl)*xv(mgs,lhl))) ! into rain +! chlmlrr(mgs) = Min( chlmlr(mgs), rho0(mgs)*qhlmlr(mgs)/(xdn(mgs,lhl)*xv(mgs,lhl)) ) ! into rain + IF(imltshddmr == 1 ) THEN + tmp = -rho0(mgs)*qhlmlr(mgs)/(Min(xdn(mgs,lr)*xvmx(lr), xdn(mgs,lhl)*xv(mgs,lhl))) ! Min of Maximum raindrop size/mean hail size + tmp2 = -rho0(mgs)*qhlmlr(mgs)/(xdn(mgs,lr)*vr3mm) ! conc. change for a 3 mm mean drop diameter + chlmlrr(mgs) = tmp*(20.e-3-xdia(mgs,lhl,3))/(20.e-3-sheddiam)+tmp2*(xdia(mgs,lhl,3)-sheddiam)/(20.e-3-sheddiam) + chlmlrr(mgs) = -Max(tmp,Min(tmp2,chlmlrr(mgs))) + ELSEIF ( imltshddmr == 2 .or. imltshddmr == 3 ) THEN + ! 8/26/2015 ERM updated to use shedalp and tmpdiam + ! tmpdiam = (shedalp+alpha(mgs,lh))*xdia(mgs,lh,1) + chlmlrr(mgs) = rho0(mgs)*qhlmlr(mgs)/(xdn(mgs,lr)*vshdgs(mgs,lhl)) ! into rain + ELSE ! old method + chlmlrr(mgs) = rho0(mgs)*qhlmlr(mgs)/(Min(xdn(mgs,lr)*xvmx(lr), xdn(mgs,lhl)*xv(mgs,lhl))) ! into rain + ENDIF + ELSE + chlmlrr(mgs) = chlmlr(mgs) + ENDIF + ELSEIF ( ihmlt .eq. 0 ) THEN + chlmlrr(mgs) = chlmlr(mgs) + ENDIF + + ELSE ! } { ibinhlmlr > 0 + chlmlrr(mgs) = Min( chlmlrr(mgs), rho0(mgs)*qhlmlr(mgs)/(xdn(mgs,lr)*xvmx(lr)) ) ! into rain + ENDIF !} + + + ENDIF ! } + + ENDIF ! }.not. mixedphase + +! 10ice versions: +! chmlr(mgs) = (cx(mgs,lh)/(qx(mgs,lh)+1.e-20))*qhmlr(mgs) +! chmlrr(mgs) = chmlr(mgs) + end do + end if + +! +! deposition/sublimation of ice +! + DO mgs = 1,ngscnt + + rwcap(mgs) = (0.5)*xdia(mgs,lr,1) + swcap(mgs) = (0.5)*xdia(mgs,ls,1) + hwcap(mgs) = (0.5)*xdia(mgs,lh,1) + IF ( lhl .gt. 1 ) hlcap(mgs) = (0.5)*xdia(mgs,lhl,1) + + if ( qx(mgs,li).gt.qxmin(li) .and. xdia(mgs,li,1) .gt. 0.0 ) then +! +! from Cotton, 1972 (Part II) +! + cilen(mgs) = 0.4764*(xdia(mgs,li,1))**(0.958) + cval = xdia(mgs,li,1) + aval = cilen(mgs) + eval = Sqrt(1.0-(aval**2)/(cval**2)) + fval = min(0.99,eval) + gval = alog( abs( (1.+fval)/(1.-fval) ) ) + cicap(mgs) = cval*fval / gval + ELSE + cicap(mgs) = 0.0 + end if + ENDDO +! +! + qhldsv(:) = 0.0 + + do mgs = 1,ngscnt + IF ( icond .eq. 1 .or. temg(mgs) .le. tfrh & + & .or. (qx(mgs,lr) .le. qxmin(lr) .and. qx(mgs,lc) .le. qxmin(lc)) ) THEN + qidsv(mgs) = & + & fvds(mgs)*cx(mgs,li)*civent(mgs)*cicap(mgs)*depfac + qsdsv(mgs) = & + & fvds(mgs)*cx(mgs,ls)*swvent(mgs)*swcap(mgs)*depfac +! IF ( ny .eq. 2 .and. igs(mgs) .eq. 302 .and. temg(mgs) .le. tfrh+10 .and. qx(mgs,lv) .gt. qis(mgs) +! : .and. qx(mgs,li) .gt. qxmin(li) ) THEN +! write(0,*) 'qidsv = ',nstep,kgs(mgs),qidsv(mgs),temg(mgs)-tfrh,100.*(qx(mgs,lv)/qis(mgs) - 1.),1.e6*xdia(mgs,li,1), +! : fvds(mgs),civent(mgs),cicap(mgs) +! ENDIF + ELSE + qidsv(mgs) = 0.0 + qsdsv(mgs) = 0.0 + ENDIF + qhdsv(mgs) = & + & fvds(mgs)*cx(mgs,lh)*hwvent(mgs)*hwcap(mgs)*depfac + + IF ( lhl .gt. 1 ) qhldsv(mgs) = fvds(mgs)*cx(mgs,lhl)*hlvent(mgs)*hlcap(mgs)*depfac +! +! + end do +! + + +! #include "nssl.qlimit.F" + +! +! Use a test saturation adjustment to set limits on ice deposition/sublimation +! and rain evaporation +! +! + IF ( DoSublimationFix ) THEN + + do mgs = 1,ngscnt + + qitmp(mgs) = qx(mgs,li) + qx(mgs,ls) + qx(mgs,lh) + IF ( lis > 1 ) qitmp(mgs) = qitmp(mgs) + qx(mgs,lis) + IF ( lhl > 1 ) qitmp(mgs) = qitmp(mgs) + qx(mgs,lhl) + qrtmp(mgs) = qx(mgs,lr) + qctmp(mgs) = qx(mgs,lc) + qsimxdep(mgs) = 0.0 + qsimxsub(mgs) = 0.0 + dqcitmp(mgs) = 0.0 + + +! IF ( ( qitmp(mgs) > qxmin(li) .or. qrtmp(mgs) > qxmin(lr) ) ) THEN + IF ( qitmp(mgs) > qxmin(li) ) THEN + + qitmp1 = qitmp(mgs) + qctmp1 = qctmp(mgs) + felvcptmp = felvcp(mgs) + felscptmp = felscp(mgs) + qvtmp(mgs) = qx(mgs,lv) + qss(mgs) = qvs(mgs) + qsstmp = qvs(mgs) + qvstmp = qvs(mgs) + qisstmp = qis(mgs) + thetatmp = theta(mgs) + thetaptmp = thetap(mgs) + temgtmp = temg(mgs) + temcgtmp = temcg(mgs) + qvaptmp = qx(mgs,lv) ! qwvp(mgs) + qv0(mgs) + qvptmp = 0.0 ! qwvp(mgs) ! qv pertubation + + qsstmp = qisstmp + + + dqwvtmp(mgs) = ( qvtmp(mgs) - qsstmp ) + + do itertd = 1,2 + +! +! calculate super-saturation +! + IF ( itertd == 1 ) THEN + + ELSE + dqcitmp(mgs) = dqci(mgs) + ! dqwvtmp(mgs) = dqwv(mgs) + ENDIF + + dqcw(mgs) = 0.0 + dqci(mgs) = 0.0 + dqwv(mgs) = ( qvtmp(mgs) - qsstmp ) +! +! evaporation and sublimation adjustment +! + if( dqwv(mgs) .lt. 0. ) then ! { subsaturated + if( qitmp(mgs) .gt. -dqwv(mgs) ) then ! check if qi can make up all the deficit + dqci(mgs) = dqwv(mgs) + dqwv(mgs) = 0. + else ! otherwise make all ice available for sublimation + dqci(mgs) = -qitmp(mgs) + dqwv(mgs) = dqwv(mgs) + qitmp(mgs) + end if +! + qvptmp = qvptmp - ( dqcw(mgs) + dqci(mgs) ) ! add to perturbation vapor + + IF ( itertd == 2 .and. eqtset > 1 ) THEN + ! if eqtset == 2, then need to update the latent heats for change in hydrometeor content + tmp = qitmp(mgs) !+ qx(mgs,lh) +! IF ( lhl > 1 ) tmp = tmp + qx(mgs,lhl) + cvm = cv+cvv*qvtmp(mgs)+cpl*(qx(mgs,lc)+qrtmp(mgs)) & + +cpigb*(tmp) + + felvcptmp = (felv(mgs)-rw*temg(mgs))/cvm + felscptmp = (fels(mgs)-rw*temg(mgs))/cvm + ENDIF + + +! qitmp(mgs) = qx(mgs,li) + qctmp(mgs) = qctmp(mgs) + dqcw(mgs) ! dqcw is zero + qitmp(mgs) = qitmp(mgs) + dqci(mgs) + thetaptmp = thetaptmp + & + & 1./pi0(mgs)* & + & (felvcp(mgs)*dqcw(mgs) +felscp(mgs)*dqci(mgs)) + + + end if ! } dqwv(mgs) .lt. 0. (end of evap/sublim) +! +! condensation/deposition +! + IF ( dqwv(mgs) .ge. 0. ) THEN ! { + +! write(iunit,*) 'satadj: mgs,iter = ',mgs,itertd,dqwv(mgs),qss(mgs),qx(mgs,lv),qx(mgs,lc) +! +! qitmp(mgs) = qx(mgs,li) + fracl(mgs) = 0.0 + fraci(mgs) = 1.0 + if ( temg(mgs) .lt. tfr .and. temg(mgs) .gt. thnuc ) then +! fracl(mgs) = max(min(1.,(temg(mgs)-233.15)/(20.)),0.0) +! fraci(mgs) = 1.0-fracl(mgs) + end if + if ( temg(mgs) .le. thnuc ) then + fraci(mgs) = 1.0 + fracl(mgs) = 0.0 + end if +! fraci(mgs) = 1.0-fracl(mgs) + + gamss = (felvcp(mgs)*fracl(mgs) + felscp(mgs)*fraci(mgs)) & + & / (pi0(mgs)) + + dqvcnd(mgs) = dqwv(mgs)/(1. + fcqv2(mgs)*qsstmp/ & + & ((temg(mgs)-cbi)**2)) + + if ( temg(mgs) .ge. tfr ) then + dqvcnd(mgs) = dqwv(mgs)/(1. + fcqv1(mgs)*qsstmp/ & + & ((temg(mgs)-cbw)**2)) + end if + + delqci1=qx(mgs,li) + + + dqcw(mgs) = dqvcnd(mgs)*fracl(mgs) ! is zero + dqci(mgs) = dqvcnd(mgs)*fraci(mgs) + + thetaptmp = thetaptmp + & + & (felvcp(mgs)*dqcw(mgs) + felscp(mgs)*dqci(mgs)) & + & / (pi0(mgs)) + + qvptmp = qvptmp - ( dqvcnd(mgs) ) + qctmp(mgs) = qctmp(mgs) + dqcw(mgs) + qitmp(mgs) = qitmp(mgs) + dqci(mgs) + + IF ( itertd == 2 .and. eqtset > 1 ) THEN + ! if eqtset == 2, then need to update the latent heats for change in hydrometeor content + tmp = qitmp(mgs) ! + qx(mgs,lh) +! IF ( lhl > 1 ) tmp = tmp + qx(mgs,lhl) + cvm = cv+cvv*qvtmp(mgs)+cpl*(qctmp(mgs) +qrtmp(mgs)) & + +cpigb*(tmp) + + felvcptmp = (felv(mgs)-rw*temg(mgs))/cvm + felscptmp = (fels(mgs)-rw*temg(mgs))/cvm + ENDIF + + IF ( eqtset > 2 ) THEN + pipert(mgs) = pipert(mgs) + (0 & + & +felspi(mgs)*dqci(mgs) & + & +felvpi(mgs)*dqcw(mgs))*dtp + ENDIF + +! +! + END IF ! } dqwv(mgs) .ge. 0. + + +! + IF ( itertd == 1 ) THEN + ! update temporary saturation values + + thetatmp = thetaptmp + theta0(mgs) + temgtmp = thetatmp*pk(mgs) ! ( pres(mgs) / poo ) ** cap + qvaptmp = Max((qvptmp + qv0(mgs)), 0.0) + temcgtmp = temgtmp - tfr + tqvcon = temgtmp-cbw + ltemq = (temgtmp-163.15)/fqsat+1.5 + ltemq = Min( nqsat, Max(1,ltemq) ) + qvstmp = pqs(mgs)*tabqvs(ltemq) + qisstmp = pqs(mgs)*tabqis(ltemq) + qctmp(mgs) = max( 0.0, qctmp(mgs) ) + qitmp(mgs) = max( 0.0, qitmp(mgs) ) + qvtmp(mgs) = max( 0.0, qvaptmp ) + +! qsstmp = qvstmp + qsstmp = qisstmp + + ELSE + ! set max depletion + qctmp(mgs) = max( 0.0, qctmp(mgs) ) + qitmp(mgs) = max( 0.0, qitmp(mgs) ) + + IF ( qitmp(mgs) < qitmp1 ) THEN + qsimxsub(mgs) = (qitmp1 - qitmp(mgs))*dtpinv + ELSEIF ( qitmp(mgs) > qitmp1 ) THEN + qsimxdep(mgs) = (qitmp(mgs) - qitmp1)*dtpinv + ENDIF + + + ENDIF +! pceds(mgs) = (thetap(mgs) - thsave(mgs))*dtpinv +! write(iunit,*) 'satadj2: mgs,iter = ',mgs,itertd,dqwv(mgs),qss(mgs),qxtmp,qctmp(mgs) +! +! end the saturation adjustment iteration loop +! + end do ! itertd + + ENDIF + + end do ! mgs + + ELSE + + DO mgs = 1,ngscnt + qsimxdep(mgs) = qvimxd(mgs) + qsimxsub(mgs) = 1.e20 + ENDDO + + ENDIF + +! end of qlimit + + do mgs = 1,ngscnt + qisbv(mgs) = 0.0 + qssbv(mgs) = 0.0 + qidpv(mgs) = 0.0 + qsdpv(mgs) = 0.0 + IF ( icond .eq. 1 .or. temg(mgs) .le. tfrh & + & .or. (qx(mgs,lr) .le. qxmin(lr) .and. qx(mgs,lc) .le. qxmin(lc)) ) THEN +! qisbv(mgs) = max( min(qidsv(mgs), 0.0), -qimxd(mgs) ) +! qssbv(mgs) = max( min(qsdsv(mgs), 0.0), -qsmxd(mgs) ) +! erm 5/10/2007: + qisbv(mgs) = max( min(qidsv(mgs), 0.0), Min( -qimxd(mgs), -0.5*qx(mgs,li)*dtpinv ) ) + qssbv(mgs) = max( min(qsdsv(mgs), 0.0), Min( -qsmxd(mgs), -0.5*qx(mgs,ls)*dtpinv ) ) + qidpv(mgs) = Max(qidsv(mgs), 0.0) + qsdpv(mgs) = Max(qsdsv(mgs), 0.0) + + + ELSE + qisbv(mgs) = 0.0 + qssbv(mgs) = 0.0 + qidpv(mgs) = 0.0 + qsdpv(mgs) = 0.0 + ENDIF + + qhsbv(mgs) = max( min(qhdsv(mgs), 0.0), -qhmxd(mgs) ) + + qhdpv(mgs) = Max(qhdsv(mgs), 0.0) + + + qhlsbv(mgs) = 0.0 + qhldpv(mgs) = 0.0 + IF ( lhl .gt. 1 ) THEN + qhlsbv(mgs) = max( min(qhldsv(mgs), 0.0), -qxmxd(mgs,lhl) ) + qhldpv(mgs) = Max(qhldsv(mgs), 0.0) + ENDIF + + temp1 = qidpv(mgs) + qsdpv(mgs) + qhdpv(mgs) + qhldpv(mgs) + +! IF ( temp1 .gt. qvimxd(mgs) ) THEN + +! frac = qvimxd(mgs)/temp1 + + IF ( temp1 .gt. qsimxdep(mgs) ) THEN + frac = qsimxdep(mgs)/temp1 + + qidpv(mgs) = frac*qidpv(mgs) + qsdpv(mgs) = frac*qsdpv(mgs) + qhdpv(mgs) = frac*qhdpv(mgs) + qhldpv(mgs) = frac*qhldpv(mgs) + +! IF ( ny .eq. 2 .and. igs(mgs) .eq. 302 .and. temg(mgs) .le. tfrh+10 .and. qx(mgs,lv) .gt. qis(mgs) +! : .and. qx(mgs,li) .gt. qxmin(li) ) THEN +! write(0,*) 'qidpv,frac = ',kgs(mgs),qidpv(mgs),frac +! ENDIF + + ENDIF + + temp1 = qisbv(mgs) + qssbv(mgs) + qhsbv(mgs) + qhlsbv(mgs) + + + IF ( temp1 < -qsimxsub(mgs) ) THEN + frac = -qsimxsub(mgs)/temp1 + + qisbv(mgs) = frac*qisbv(mgs) + qssbv(mgs) = frac*qssbv(mgs) + qhsbv(mgs) = frac*qhsbv(mgs) + qhlsbv(mgs) = frac*qhlsbv(mgs) + +! IF ( ny .eq. 2 .and. igs(mgs) .eq. 302 .and. temg(mgs) .le. tfrh+10 .and. qx(mgs,lv) .gt. qis(mgs) +! : .and. qx(mgs,li) .gt. qxmin(li) ) THEN +! write(0,*) 'qidpv,frac = ',kgs(mgs),qidpv(mgs),frac +! ENDIF + + ENDIF + + + end do +! +! + if ( ipconc .ge. 1 ) then + do mgs = 1,ngscnt + cssbv(mgs) = (cx(mgs,ls)/(qx(mgs,ls)+1.e-20))*qssbv(mgs) + cisbv(mgs) = (cx(mgs,li)/(qx(mgs,li)+1.e-20))*qisbv(mgs) + chsbv(mgs) = (cx(mgs,lh)/(qx(mgs,lh)+1.e-20))*qhsbv(mgs) + IF ( lhl .gt. 1 ) chlsbv(mgs) = (cx(mgs,lhl)/(qx(mgs,lhl)+1.e-20))*qhlsbv(mgs) + csdpv(mgs) = 0.0 ! (cx(mgs,ls)/(qx(mgs,ls)+1.e-20))*qsdpv(mgs) + cidpv(mgs) = 0.0 ! (cx(mgs,li)/(qx(mgs,li)+1.e-20))*qidpv(mgs) + cisdpv(mgs) = 0.0 + chdpv(mgs) = 0.0 ! (cx(mgs,lh)/(qx(mgs,lh)+1.e-20))*qhdpv(mgs) + chldpv(mgs) = 0.0 + end do + end if + +! +! Aggregation or size conversion of small crystals to snow +! + if (ndebug .gt. 0 ) write(0,*) 'conc 29a' + do mgs = 1,ngscnt + qscni(mgs) = 0.0 + cscni(mgs) = 0.0 + cscnis(mgs) = 0.0 + if ( ipconc .ge. 4 .and. iscni .ge. 1 .and. qx(mgs,li) .gt. qxmin(li) ) then + IF ( iscni .eq. 1 ) THEN + qscni(mgs) = & + & pi*rho0(mgs)*((0.25)/(6.0)) & + & *eii(mgs)*(qx(mgs,li)**2)*(xdia(mgs,li,2)) & + & *vtxbar(mgs,li,1)/xmas(mgs,li) + cscni(mgs) = Min(cimxd(mgs),qscni(mgs)*rho0(mgs)/xmas(mgs,li)) + cscnis(mgs) = 0.5*cscni(mgs) + ELSEIF ( iscni .eq. 2 .or. iscni .eq. 4 .or. iscni .eq. 5 ) THEN ! Zeigler 1985/Zrnic 1993, sort of + IF ( iscni .ne. 5 .and. qidpv(mgs) .gt. 0.0 .and. xdia(mgs,li,3) .ge. 100.e-6 ) THEN + ! convert larger crystals to snow +! IF ( xdia(mgs,ls,3) .gt. xdia(mgs,li,3) ) THEN +! qscni(mgs) = Max(0.1,xdia(mgs,li,3)/xdia(mgs,ls,3))*qidpv(mgs) +! erm 9/5/08 changed max to min + qscni(mgs) = Min(0.5, xdia(mgs,li,3)/200.e-6)*qidpv(mgs) +! ELSE +! qscni(mgs) = 0.1*qidpv(mgs) +! ENDIF + cscni(mgs) = fscni*qscni(mgs)*rho0(mgs)/Max(rho_qs*xvmn(ls),xmas(mgs,li)) +! cscni(mgs) = fscni*Min(cimxd(mgs),qscni(mgs)*rho0(mgs)/Max(xdn(mgs,ls)*xvmn(ls),xmas(mgs,li))) +! cscni(mgs) = Min(cimxd(mgs),qscni(mgs)*rho0(mgs)/xmas(mgs,li) ) +! IF ( xdia(mgs,ls,3) .le. 200.e-6 ) THEN + cscnis(mgs) = cscni(mgs) +! ELSE +! cscnis(mgs) = 0.0 +! ENDIF + ENDIF + + IF ( iscni .ne. 4 ) THEN + ! crystal aggregation to become snow +! erm 9/5/08 commented second line and added xv to 1st line (zrnic et al 1993) + tmp = ess(mgs)*rvt*aa2*cx(mgs,li)*cx(mgs,li)*xv(mgs,li) +! : ((cinu + 2.)*xv(mgs,li)/(cinu + 1.) + xv(mgs,li)) + +! csacs(mgs) = rvt*aa2*ess(mgs)*cx(mgs,ls)**2*xv(mgs,ls) + + qscni(mgs) = qscni(mgs) + Min( qxmxd(mgs,li), 2.0*tmp*xmas(mgs,li)*rhoinv(mgs) ) + cscni(mgs) = cscni(mgs) + Min( cxmxd(mgs,li), 2.0*tmp ) + cscnis(mgs) = cscnis(mgs) + Min( cxmxd(mgs,li), tmp ) + ENDIF + ELSEIF ( iscni .eq. 3 ) THEN ! LFO + qscni(mgs) = 0.001*eii(mgs)*max((qx(mgs,li)-1.e-3),0.0) + qscni(mgs) = min(qscni(mgs),qxmxd(mgs,li)) + cscni(mgs) = qscni(mgs)*rho0(mgs)/xmas(mgs,li) + cscnis(mgs) = 0.5*cscni(mgs) +! write(iunit,*) 'qscni, qi = ',qscni(mgs),qx(mgs,li),igs(mgs),kgs(mgs) + ENDIF + + ELSEIF ( ipconc < 4 ) THEN ! LFO + IF ( lwsm6 ) THEN + qimax = rhoinv(mgs)*roqimax + qscni(mgs) = Min(0.90*qx(mgs,li), Max( 0.0, (qx(mgs,li) - qimax)*dtpinv ) ) + ELSE + qscni(mgs) = 0.001*eii(mgs)*max((qx(mgs,li)-1.e-3),0.0) + qscni(mgs) = min(qscni(mgs),qxmxd(mgs,li)) + ENDIF + else ! 10-ice version + if ( iscni > 0 .and. qx(mgs,li) .gt. qxmin(li) ) then + qscni(mgs) = & + & pi*rho0(mgs)*((0.25)/(6.0)) & + & *eii(mgs)*(qx(mgs,li)**2)*(xdia(mgs,li,2)) & + & *vtxbar(mgs,li,1)/xmas(mgs,li) + cscni(mgs) = Min(cimxd(mgs),qscni(mgs)*rho0(mgs)/xmas(mgs,li)) + end if + + end if + end do + +! +! +! compute dry growth rate of snow, graupel, and hail +! + do mgs = 1,ngscnt +! + qsdry(mgs) = qsacr(mgs) + qsacw(mgs) & + & + qsaci(mgs) +! + qhdry(mgs) = qhaci(mgs) + qhacs(mgs) & + & + qhacr(mgs) & + & + qhacw(mgs) +! + + qhldry(mgs) = 0.0 + IF ( lhl .gt. 1 ) THEN + qhldry(mgs) = qhlaci(mgs) + qhlacs(mgs) & + & + qhlacr(mgs) & + & + qhlacw(mgs) + ENDIF + end do +! +! set wet growth and shedding +! + do mgs = 1,ngscnt + + IF ( temg(mgs) < tfr ) THEN +! +! qswet(mgs) = +! > ( xdia(mgs,ls,1)*swvent(mgs)*cx(mgs,ls)*fwet1(mgs) +! > + fwet2(mgs)*(qsaci(mgs)+qsacir(mgs) +! > +qsacip(mgs)) ) +! qswet(mgs) = max( 0.0, qswet(mgs)) +! +! IF ( dnu(lh) .ne. 0. ) THEN +! qhwet(mgs) = qhdry(mgs) +! ELSE + qhwet(mgs) = & + & ( xdia(mgs,lh,1)*hwvent(mgs)*cx(mgs,lh)*fwet1(mgs) & + & + fwet2(mgs)*(qhaci(mgs) + qhacs(mgs)) ) + qhwet(mgs) = max( 0.0, qhwet(mgs)) +! ENDIF + + + qhlwet(mgs) = 0.0 + IF ( lhl .gt. 1 ) THEN + qhlwet(mgs) = & + & ( xdia(mgs,lhl,1)*hlvent(mgs)*cx(mgs,lhl)*fwet1(mgs) & + & + fwet2(mgs)*(qhlaci(mgs) + qhlacs(mgs)) ) + qhlwet(mgs) = max( 0.0, qhlwet(mgs)) + ENDIF + + ELSE + + qhwet(mgs) = qhdry(mgs) + qhlwet(mgs) = qhldry(mgs) + + ENDIF +! +! qhlwet(mgs) = qhldry(mgs) + + end do +! +! shedding rate +! + qsshr(:) = 0.0 + qhshr(:) = 0.0 + qhlshr(:) = 0.0 + qhshh(:) = 0.0 + csshr(:) = 0.0 + csshrr(:) = 0.0 + chshr(:) = 0.0 + chlshr(:) = 0.0 + chshrr(:) = 0.0 + chlshrr(:) = 0.0 + vhshdr(:) = 0.0 + vhlshdr(:) = 0.0 + wetsfc(:) = .false. + wetgrowth(:) = .false. + wetsfchl(:) = .false. + wetgrowthhl(:) = .false. + + do mgs = 1,ngscnt +! +! +! + qhshr(mgs) = Min( 0.0, qhwet(mgs) - qhdry(mgs) ) ! water that freezes should never be more than what sheds + + + + qhlshr(mgs) = Min( 0.0, qhlwet(mgs) - qhldry(mgs) ) + +! +! limit wet growth to only higher density particles +! + qsshr(mgs) = 0.0 +! +! +! no shedding for temperatures < 243.15 +! + if ( temg(mgs) .lt. 243.15 ) then + qsshr(mgs) = 0.0 + qhshr(mgs) = 0.0 + qhlshr(mgs) = 0.0 + vhshdr(mgs) = 0.0 + vhlshdr(mgs) = 0.0 + wetsfc(mgs) = .false. + wetgrowth(mgs) = .false. + wetsfchl(mgs) = .false. + wetgrowthhl(mgs) = .false. + end if +! +! shed all at temperatures > 273.15 +! + if ( temg(mgs) .gt. tfr ) then + + IF ( .false. ) THEN ! old and incorrect -- Thanks to Shaofeng Hua for noticing this error (9/17/2017) + qsshr(mgs) = -qsdry(mgs) + qhshr(mgs) = -qhdry(mgs) + qhlshr(mgs) = -qhldry(mgs) + ELSE ! new and correct + + qsshr(mgs) = - qsacr(mgs) - qsacw(mgs) ! -qsdry(mgs) + qhlshr(mgs) = - qhlacw(mgs) - qhlacr(mgs) ! -qhldry(mgs) + qhshr(mgs) = - qhacw(mgs) - qhacr(mgs) ! -qhdry(mgs) + + ENDIF + + vhshdr(mgs) = -vhacw(mgs) - vhacr(mgs) + vhlshdr(mgs) = -vhlacw(mgs) - vhlacr(mgs) + qhwet(mgs) = 0.0 + qhlwet(mgs) = 0.0 + end if +! +! if (qhshr(mgs) .lt. 0.0 .and. temg(mgs) < tfr ) THEN + wetsfc(mgs) = (qhshr(mgs) .lt. 0.0 .and. temg(mgs) < tfr ) .or. ( qhmlr(mgs) < -qxmin(lh) .and. temg(mgs) > tfr ) + wetgrowth(mgs) = (qhshr(mgs) .lt. 0.0 .and. temg(mgs) < tfr ) +! ENDIF + if (qhlshr(mgs) .lt. 0.0 .and. temg(mgs) < tfr ) THEN + wetsfchl(mgs) = (qhlshr(mgs) .lt. 0.0 .and. temg(mgs) < tfr ) .or. ( qhlmlr(mgs) < -qxmin(lhl) .and. temg(mgs) > tfr ) + wetgrowthhl(mgs) = (qhlshr(mgs) .lt. 0.0 .and. temg(mgs) < tfr ) + ENDIF + + end do +! + if ( ipconc .ge. 1 ) then + do mgs = 1,ngscnt + csshr(mgs) = 0.0 ! (cx(mgs,ls)/(qx(mgs,ls)+1.e-20))*Min(0.0,qsshr(mgs)) + + chshr(mgs) = 0.0 ! no change to graupel number concentration for wet-growth shedding + + ! tmpdiam = (shedalp+alpha(mgs,lh))*xdia(mgs,lh,1) + ! Base the drop size on the shedding regime + ! 8/26/2015 ERM updated to use shedalp and tmpdiam + ! tmpdiam = (shedalp+alpha(mgs,lh))*xdia(mgs,lh,1) + chshrr(mgs) = rho0(mgs)*qhshr(mgs)/(xdn(mgs,lr)*vshdgs(mgs,lh)) ! into rain + + + + chlshr(mgs) = 0.0 + chlshrr(mgs) = 0.0 + IF ( lhl .gt. 1 ) THEN +! chlshr(mgs) = (cx(mgs,lhl)/(qx(mgs,lhl)+1.e-20))*qhlshr(mgs) + + + chlshr(mgs) = 0.0 ! no change to hail number concentration for wet-growth shedding + + ! tmpdiam = (shedalp+alpha(mgs,lh))*xdia(mgs,lh,1) + ! Base the drop size on the shedding regime + ! 8/26/2015 ERM updated to use shedalp and tmpdiam + ! tmpdiam = (shedalp+alpha(mgs,lh))*xdia(mgs,lh,1) + chlshrr(mgs) = rho0(mgs)*qhlshr(mgs)/(xdn(mgs,lr)*vshdgs(mgs,lhl)) ! into rain + + ENDIF ! ( lhl > 1 ) + + + end do + end if + + + +! +! final decisions +! + do mgs = 1,ngscnt +! +! Snow +! + if ( qsshr(mgs) .lt. 0.0 ) then + qsdpv(mgs) = 0.0 + qssbv(mgs) = 0.0 + else + qsshr(mgs) = 0.0 + end if +! +! if ( qsdry(mgs) .lt. qswet(mgs) ) then +! qswet(mgs) = 0.0 +! else +! qsdry(mgs) = 0.0 +! end if +! + +! graupel +! +! + if ( wetgrowth(mgs) .or. (mixedphase .and. fhw(mgs) .gt. 0.05 .and. temg(mgs) .gt. 243.15) ) then + + +! soaking (when not advected liquid water film with graupel) + + IF ( lvol(lh) .gt. 1 .and. .not. mixedphase) THEN + ! rescale volumes to maximum density + IF ( iwetsoak ) THEN + + rimdn(mgs,lh) = xdnmx(lh) + raindn(mgs,lh) = xdnmx(lh) + vhacw(mgs) = qhacw(mgs)*rho0(mgs)/rimdn(mgs,lh) + vhacr(mgs) = qhacr(mgs)*rho0(mgs)/raindn(mgs,lh) +! IF ( lvol(lh) .gt. 1 .and. wetgrowth(mgs) ) THEN + IF ( xdn(mgs,lh) .lt. xdnmx(lh) ) THEN + ! soak some liquid into the graupel +! v1 = xdnmx(lh)*vx(mgs,lh)/(xdn(mgs,lh)*dtp) ! volume available for filling + v1 = (1. - xdn(mgs,lh)/xdnmx(lh))*vx(mgs,lh)/(dtp) ! volume available for filling +! tmp = (vx(mgs,lh)/rho0(mgs))*(xdnmx(lh) - xdn(mgs,lh)) ! max mixing ratio of liquid water that can be added + v2 = rho0(mgs)*qhwet(mgs)/xdnmx(lh) ! volume of frozen accretion + + vhsoak(mgs) = Min(v1,v2) + + + ENDIF + + ENDIF + + vhshdr(mgs) = Min(0.0, rho0(mgs)*qhwet(mgs)/xdnmx(lh) - vhacw(mgs) - vhacr(mgs) ) + + ELSEIF ( lvol(lh) .gt. 1 .and. mixedphase ) THEN +! vhacw(mgs) = rho0(mgs)*qhacw(mgs)/xdn0(lr) +! vhacr(mgs) = rho0(mgs)*qhacr(mgs)/xdn0(lr) + ENDIF + + + qhdpv(mgs) = 0.0 +! qhsbv(mgs) = 0.0 + chdpv(mgs) = 0.0 +! chsbv(mgs) = 0.0 + +! collection efficiency modification + + IF ( ehi(mgs) .gt. 0.0 ) THEN + qhaci(mgs) = Min(qimxd(mgs),qhaci0(mgs)) ! effectively sets collection eff to 1 + chaci(mgs) = Min(cimxd(mgs),chaci0(mgs)) ! effectively sets collection eff to 1 + ENDIF + IF ( ehs(mgs) .gt. 0.0 ) THEN +! qhacs(mgs) = Min(qsmxd(mgs),qhacs(mgs)/ehs(mgs)) ! effectively sets collection eff to 1 + qhacs(mgs) = Min(qsmxd(mgs),qhacs0(mgs)) !/ehs(mgs) ! divide out the collection efficiency + chacs(mgs) = Min(csmxd(mgs),chacs0(mgs)) !/ehs(mgs) ! divide out the collection efficiency + ehs(mgs) = ehsmax ! 1.0 ! min(ehsfrac*ehs(mgs),ehsmax) ! modify it + qhacs(mgs) = Min(qsmxd(mgs),qhacs(mgs)) ! plug it back in + ENDIF + +! be sure to catch particles with wet surfaces but not in wet growth to turn off Hallett-Mossop + wetsfc(mgs) = .true. + + else +! qhshr(mgs) = 0.0 + end if +! +! +! hail +! +! if ( lhl .gt. 1 .and. qhlshr(mgs) .lt. 0.0 ) then + if ( lhl > 1 .and. ( wetgrowthhl(mgs) .or. (mixedphase .and. fhlw(mgs) .gt. 0.05 .and. temg(mgs) .gt. 243.15) ) ) then +! if ( wetgrowthhl(mgs) ) then + + + qhldpv(mgs) = 0.0 +! qhlsbv(mgs) = 0.0 + chldpv(mgs) = 0.0 +! chlsbv(mgs) = 0.0 + + + + + IF ( lvol(lhl) .gt. 1 .and. .not. mixedphase ) THEN +! IF ( lvol(lhl) .gt. 1 .and. wetgrowthhl(mgs) ) THEN + + IF ( iwetsoak ) THEN + + rimdn(mgs,lhl) = xdnmx(lhl) + raindn(mgs,lhl) = xdnmx(lhl) + vhlacw(mgs) = qhlacw(mgs)*rho0(mgs)/rimdn(mgs,lhl) + vhlacr(mgs) = qhlacr(mgs)*rho0(mgs)/raindn(mgs,lhl) + + IF ( xdn(mgs,lhl) .lt. xdnmx(lhl) ) THEN + ! soak some liquid into the hail +! v1 = xdnmx(lhl)*vx(mgs,lhl)/(xdn(mgs,lhl)*dtp) ! volume available for filling + v1 = (1. - xdn(mgs,lhl)/xdnmx(lhl))*vx(mgs,lhl)/(dtp) ! volume available for filling +! tmp = (vx(mgs,lhl)/rho0(mgs))*(xdnmx(lhl) - xdn(mgs,lhl)) ! max mixing ratio of liquid water that can be added + v2 = rho0(mgs)*qhlwet(mgs)/xdnmx(lhl) ! volume of frozen accretion + IF ( v1 > v2 ) THEN ! all the frozen stuff fits in + vhlsoak(mgs) = v2 + ELSE ! fill up the available space + vhlsoak(mgs) = v1 + ENDIF +! vhlacw(mgs) = 0.0 +! vhlacr(mgs) = Max( 0.0, v2 - v1 ) + ELSE + vhlsoak(mgs) = 0.0 +! vhlacw(mgs) = 0.0 +! vhlacr(mgs) = rho0(mgs)*qhlwet(mgs)/raindn(mgs,lhl) + + ENDIF + + ENDIF + + vhlshdr(mgs) = Min(0.0, rho0(mgs)*qhlwet(mgs)/xdnmx(lhl) - vhlacw(mgs) - vhlacr(mgs) ) + + + ELSEIF ( lvol(lhl) .gt. 1 .and. mixedphase ) THEN +! vhlacw(mgs) = rho0(mgs)*qhlacw(mgs)/xdn0(lr) +! vhlacr(mgs) = rho0(mgs)*qhlacr(mgs)/xdn0(lr) + ENDIF + + IF ( ehli(mgs) .gt. 0.0 ) THEN + qhlaci(mgs) = Min(qimxd(mgs),qhlaci0(mgs)) ! effectively sets collection eff to 1 + chlaci(mgs) = Min(cimxd(mgs),chlaci0(mgs)) ! effectively sets collection eff to 1 + ENDIF + +! IF ( ehls(mgs) .gt. 0.0 ) THEN +! qhlacs(mgs) = Min(qsmxd(mgs),qhlacs(mgs)/ehls(mgs)) +! ENDIF + IF ( ehls(mgs) .gt. 0.0 ) THEN + qhlacs(mgs) = Min(qsmxd(mgs),qhlacs0(mgs)) !/ehls(mgs) ! divide out the collection efficiency + chlacs(mgs) = Min(csmxd(mgs),chlacs0(mgs)) !/ehls(mgs) ! divide out the collection efficiency + ehls(mgs) = ehsmax ! 1.0 ! min(ehsfrac*ehs(mgs),ehsmax) ! modify it +! qhlacs(mgs) = Min(qsmxd(mgs),qhlacs(mgs)) ! plug it back in + ENDIF + + +! qhlwet(mgs) = 1.0 + +! be sure to catch particles with wet surfaces but not in wet growth to turn off Hallett-Mossop + wetsfchl(mgs) = .true. + + + else +! qhlshr(mgs) = 0.0 +! qhlwet(mgs) = 0.0 + end if + + end do +! +! Ice -> graupel conversion +! + DO mgs = 1,ngscnt + + qhcni(mgs) = 0.0 + chcni(mgs) = 0.0 + chcnih(mgs) = 0.0 + vhcni(mgs) = 0.0 + + IF ( iglcnvi .ge. 1 ) THEN + IF ( temg(mgs) .lt. 273.0 .and. qiacw(mgs) - qidpv(mgs) .gt. 0.0 ) THEN + + + tmp = rimc1*(-((0.5)*(1.e+06)*xdia(mgs,lc,1)) & + & *((0.60)*vtxbar(mgs,li,1)) & + & /(temg(mgs)-273.15))**(rimc2) + tmp = Min( Max( rimc3, tmp ), 900.0 ) + + ! Assume that half the volume of the embryo is rime with density 'tmp' + ! m = rhoi*(V/2) + rhorime*(V/2) = (rhoi + rhorime)*V/2 + ! V = 2*m/(rhoi + rhorime) + +! write(0,*) 'rime dens = ',tmp + + IF ( tmp .ge. 200.0 .or. iglcnvi >= 2 ) THEN + r = Max( 0.5*(xdn(mgs,li) + tmp), xdnmn(lh) ) +! r = Max( r, 400. ) + qhcni(mgs) = (qiacw(mgs) - qidpv(mgs)) ! *float(iglcnvi) + chcni(mgs) = cx(mgs,li)*qhcni(mgs)/qx(mgs,li) +! chcnih(mgs) = rho0(mgs)*qhcni(mgs)/(1.6e-10) + chcnih(mgs) = Min(chcni(mgs), rho0(mgs)*qhcni(mgs)/(r*xvmn(lh)) ) +! vhcni(mgs) = rho0(mgs)*2.0*qhcni(mgs)/(xdn(mgs,li) + tmp) + vhcni(mgs) = rho0(mgs)*qhcni(mgs)/r + ENDIF + + ELSEIF ( iglcnvi == 3 ) THEN + + IF ( temg(mgs) .lt. 273.0 .and. qiacw(mgs)*dtp > 2.*qxmin(lh) .and. gamice73fac*xmas(mgs,li) > xdnmn(lh)*xvmn(lh) ) THEN + + + tmp = rimc1*(-((0.5)*(1.e+06)*xdia(mgs,lc,1)) & + & *((0.60)*vtxbar(mgs,li,1)) & + & /(temg(mgs)-273.15))**(rimc2) + tmp = Min( Max( rimc3, tmp ), 900.0 ) + + ! Assume that half the volume of the embryo is rime with density 'tmp' + ! m = rhoi*(V/2) + rhorime*(V/2) = (rhoi + rhorime)*V/2 + ! V = 2*m/(rhoi + rhorime) + +! write(0,*) 'rime dens = ',tmp + ! convert to particles with the mass of the mass-weighted diameter + ! massofmwr = gamice73fac*xmas(mgs,li) + + IF ( tmp .ge. xdnmn(lh) ) THEN + r = Max( 0.5*(xdn(mgs,li) + tmp), xdnmn(lh) ) +! r = Max( r, 400. ) + qhcni(mgs) = 0.5*qiacw(mgs) + chcni(mgs) = qhcni(mgs)/(gamice73fac*xmas(mgs,li)) + chcnih(mgs) = Min(chcni(mgs), rho0(mgs)*qhcni(mgs)/(r*xvmn(lh)) ) +! vhcni(mgs) = rho0(mgs)*2.0*qhcni(mgs)/(xdn(mgs,li) + tmp) + vhcni(mgs) = rho0(mgs)*qhcni(mgs)/r + ENDIF + + ENDIF + + + ENDIF + ENDIF + + + ENDDO + + + qhlcnh(:) = 0.0 + chlcnh(:) = 0.0 + chlcnhhl(:) = 0.0 + vhlcnh(:) = 0.0 + vhlcnhl(:) = 0.0 + zhlcnh(:) = 0.0 + + qhcnhl(:) = 0.0 + chcnhl(:) = 0.0 + vhcnhl(:) = 0.0 + zhcnhl(:) = 0.0 + + + IF ( lhl .gt. 1 ) THEN + + IF ( ihlcnh == 1 .or. ihlcnh == 3 ) THEN + +! +! Graupel (h) conversion to hail (hl) based on Milbrandt and Yau 2005b +! + DO mgs = 1,ngscnt + +! IF ( lhl .gt. 1 .and. ipconc .ge. 5 .and. qx(mgs,lh) .gt. 1.0e-3 .and. +! : xdn(mgs,lh) .gt. 750. .and. qhshr(mgs) .lt. 0.0 .and. +! : xdia(mgs,lh,3) .gt. 1.e-3 ) THEN + IF ( hlcnhdia > 0 ) THEN + ltest = xdia(mgs,lh,3) .gt. hlcnhdia ! test on mean volume diameter + ELSE +! ltest = xdia(mgs,lh,1)*(3. + alpha(mgs,lh)) > Abs( hlcnhdia ) ! test on maximum mass diameter + ltest = xdia(mgs,lh,1)*(4. + alpha(mgs,lh)) > Abs( hlcnhdia ) ! test on mass-weighted diameter + ENDIF + + dg0(mgs) = -1. + + wtest = (dg0(mgs) > 0.0 .and. dg0(mgs) < dg0thresh ) + + IF ( ihlcnh == 1 ) THEN ! .or. iusedw == 0 THEN + + IF ( ( wetgrowth(mgs) .and. (xdn(mgs,lh) .gt. hldnmn .or. lvh < 1 ) .and. & ! correct this when hail gets turned on + & rimdn(mgs,lh) .gt. 800. .and. & + & ltest .and. qx(mgs,lh) .gt. hlcnhqmin ) .or. wtest ) THEN ! { +! : xdia(mgs,lh,3) .gt. 2.e-3 .and. qx(mgs,lh) .gt. 1.0e-3 THEN ! 0823.2008 erm test +! IF ( xdia(mgs,lh,3) .gt. 1.e-3 ) THEN + IF ( qhacw(mgs) .gt. 0.0 .and. qhacw(mgs) .gt. qhaci(mgs) .and. temg(mgs) .le. tfr-2.0 ) THEN ! { + ! dh0 is the diameter dividing wet growth from dry growth (Ziegler 1985), modified by MY05 +! dh0 = 0.01*(exp(temcg(mgs)/(1.1e4*(qx(mgs,lc)+qx(mgs,lr)) - +! : 1.3e3*qx(mgs,li) + 1.0e-3 ) ) - 1.0) + IF ( wtest ) THEN + dh0 = dg0(mgs) + ELSE + x = (1.1e4*(rho0(mgs)*qx(mgs,lc)) - 1.3e3*rho0(mgs)*qx(mgs,li) + 1.0e-3 ) + IF ( x > 1.e-20 ) THEN + arg = Min(70.0, (-temcg(mgs)/x )) ! prevent overflow of the exp function in 32 bit + dh0 = 0.01*(exp(arg) - 1.0) + ELSE + dh0 = 1.e30 + ENDIF + ENDIF ! wtest +! dh0 = Max( dh0, 5.e-3 ) + +! IF ( dh0 .gt. 0.0 ) write(0,*) 'dh0 = ',dh0 +! IF ( dh0 .gt. 1.0e-4 ) THEN + IF ( xdia(mgs,lh,3)/dh0 .gt. 0.1 ) THEN !{ +! IF ( xdia(mgs,lh,3) .lt. 20.*dh0 .and. dh0 .lt. 2.0*xdia(mgs,lh,3) ) THEN + tmp = qhacw(mgs) + qhacr(mgs) + qhaci(mgs) + qhacs(mgs) +! qtmp = Min( 1.0, xdia(mgs,lh,3)/(2.0*dh0) )*(tmp) + qtmp = Min( 100.0, xdia(mgs,lh,3)/(2.0*dh0) )*(tmp) +! IF ( .false. .and. qx(mgs,lhl) + qtmp*dtp .lt. 0.5e-3 ) THEN +! hdia1 = Max(dh0, xdia(mgs,lh,3) ) +! qtmp = qtmp + Min(qxmxd(mgs,lh), Max( 0.0, & +! & ((pi*xdn(mgs,lh)*cx(mgs,lh)) / (6.0*rho0(mgs)*dtp)) & +! & *exp(-hdia1/xdia(mgs,lh,1)) & +! & *( (hdia1**3) + 3.0*(hdia1**2)*xdia(mgs,lh,1) & +! & + 6.0*(hdia1)*(xdia(mgs,lh,1)**2) + 6.0*(xdia(mgs,lh,1)**3) ) ) ) + +! ENDIF + +! qhlcnh(mgs) = Min( 0.5*(qx(mgs,lh))+tmp, xdia(mgs,lh,3)/(2.0*dh0)*(tmp) ) +! qhlcnh(mgs) = Min( qxmxd(mgs,lh), xdia(mgs,lh,3)/(2.0*dh0)*(tmp) ) + qhlcnh(mgs) = Min( qxmxd(mgs,lh), qtmp ) + + IF ( ipconc .ge. 5 ) THEN !{ +! dh0 = Max( xdia(mgs,lh,3), Min( dh0, 5.e-3 ) ) ! do not create hail greater than 5mm diam. unless the graupel is larger + IF ( .not. wtest ) dh0 = Min( dh0, 10.e-3 ) ! do not create hail greater than 10mm diam., which is the max graupel size + IF ( qx(mgs,lhl) > 0.1e-3 ) dh0 = Max( dh0, xdia(mgs,lhl,3) ) ! when enough hail is established, do not dilute the size + chlcnhhl(mgs) = Min( cxmxd(mgs,lh), rho0(mgs)*qhlcnh(mgs)/(pi*xdn(mgs,lh)*dh0**3/6.0) ) + + r = rho0(mgs)*qhlcnh(mgs)/(xdn(mgs,lh)*xv(mgs,lh)) ! number of graupel particles at mean volume diameter +! chlcnh(mgs) = Min( Max( 1./8.*r , chlcnh(mgs)), r ) +! chlcnh(mgs) = Min( chlcnh(mgs), r ) + chlcnh(mgs) = Max( chlcnhhl(mgs), r ) + ENDIF !} + + vhlcnh(mgs) = rho0(mgs)*qhlcnh(mgs)/xdn(mgs,lh) + vhlcnhl(mgs) = rho0(mgs)*qhlcnh(mgs)/Max(xdnmn(lhl), xdn(mgs,lh)) + + ENDIF !} + + ENDIF ! } + ENDIF ! } + + ELSEIF ( ihlcnh == 3 ) THEN !{ + + + ENDIF !} + + ENDDO + + ELSEIF ( ihlcnh == 2 ) THEN ! 10-ice type conversion + + ELSEIF ( ihlcnh == 0 ) THEN + + do mgs = 1,ngscnt +! qhlcnh(mgs) = 0.0 +! chlcnh(mgs) = 0.0 + if ( wetgrowth(mgs) .and. temg(mgs) .lt. tfr-5. .and. qx(mgs,lh) > qxmin(lh) ) then + if ( qhacw(mgs).gt.1.e-6 .and. xdn(mgs,lh) > 700. ) then + qhlcnh(mgs) = & + ((pi*xdn(mgs,lh)*cx(mgs,lh)) / (6.0*rho0(mgs)*dtp)) & + *exp(-hldia1/xdia(mgs,lh,1)) & + *( (hldia1**3) + 3.0*(hldia1**2)*xdia(mgs,lh,1) & + + 6.0*(hldia1)*(xdia(mgs,lh,1)**2) + 6.0*(xdia(mgs,lh,1)**3) ) + qhlcnh(mgs) = min(qhlcnh(mgs),qhmxd(mgs)) + IF ( ipconc .ge. 5 ) THEN + chlcnh(mgs) = Min( cxmxd(mgs,lh), cx(mgs,lh)*Exp(-hldia1/xdia(mgs,lh,1))) + chlcnhhl(mgs) = chlcnh(mgs) +! chlcnh(mgs) = Min( cxmxd(mgs,lh), rho0(mgs)*qhlcnh(mgs)/(2.0*xmas(mgs,lh) )) + ENDIF + vhlcnh(mgs) = rho0(mgs)*qhlcnh(mgs)/xdn(mgs,lh) + vhlcnhl(mgs) = rho0(mgs)*qhlcnh(mgs)/Max(xdnmn(lhl), xdn(mgs,lh)) + end if + end if + end do + +! ENDIF ! true + + ENDIF ! ihlcnh options + + ! convert low-density hail to graupel + IF ( icvhl2h >= 1 ) THEN + DO mgs = 1,ngscnt + IF ( qx(mgs,lhl) > qxmin(lhl) .and. xdn(mgs,lhl) < 0.5*(xdnmn(lhl) + xdnmx(lhl)) ) THEN + tmp = Min(0.95, 1. - 0.5*(1. + tanh(0.125*(xdn(mgs,lhl) - 1.01*xdnmn(lhl) )) )) + qhcnhl(mgs) = tmp*qx(mgs,lhl)*dtpinv + chcnhl(mgs) = cx(mgs,lhl)*qhcnhl(mgs)/qx(mgs,lhl) + vhcnhl(mgs) = vx(mgs,lhl)*qhcnhl(mgs)/qx(mgs,lhl) + + ENDIF + ENDDO + + ENDIF + + ENDIF ! lhl > 1 + + + + +! +! Ziegler snow conversion to graupel +! + DO mgs = 1,ngscnt + + qhcns(mgs) = 0.0 + chcns(mgs) = 0.0 + chcnsh(mgs) = 0.0 + vhcns(mgs) = 0.0 + + qscnh(mgs) = 0.0 + cscnh(mgs) = 0.0 + vscnh(mgs) = 0.0 + + IF ( ipconc .ge. 5 ) THEN + + ! test attempt at converting graupel to snow when not riming but growing by deposition + IF ( temg(mgs) < tfr .and. qx(mgs,lh) .gt. qxmin(lh) .and. qhdpv(mgs) > qxmin(lh)*dtpinv & + & .and. qhacw(mgs) < qxmin(lh)*dtpinv ) THEN + IF ( xdn(mgs,lh) < 290. ) THEN +! qscnh(mgs) = 2.*qhdpv(mgs) +! cscnh(mgs) = cx(mgs,lh)*qscnh(mgs)/qx(mgs,lh) +! vscnh(mgs) = rho0(mgs)*qscnh(mgs)/xdn(mgs,lh) + ENDIF + ENDIF + + + IF ( qx(mgs,ls) .gt. qxmin(ls) .and. qsacw(mgs) .gt. 0.0 ) THEN + +! DATA VGRA/1.413E-2/ ! this is the volume (cm**3) of a 3mm diam. sphere +! vgra = 1.4137e-8 m**3 + +! DNNET=DNCNV-DNAGG +! DQNET=QXCON+QSACC+SDEP +! +! DNSCNV=EXP(-(ROS*XNS*VGRA/(RO*QI)))*((1.-(XNS*VGRA*ROS/ +! / (RO*QI)))*DNNET + (XNS**2*VGRA*ROS/(RO*QI**2))*DQNET) +! IF(DNSCNV.LT.0.) DNSCNV=0. +! +! QIHC=(ROS*VGRA/RO)*DNSCNV +! +! QH=QH+DT*QIHC +! QI=QI-DT*QIHC +! XNH=XNH+DT*DNSCNV +! XNS=XNS-DT*DNSCNV + + IF ( iglcnvs .eq. 1 ) THEN ! Zrnic, Ziegler et al (1993) + + dnnet = cscnvis(mgs) + cscnis(mgs) - csacs(mgs) + dqnet = qscnvi(mgs) + qscni(mgs) + qsacw(mgs) + qsdpv(mgs) + qssbv(mgs) + + a3 = 1./(rho0(mgs)*qx(mgs,ls)) + a1 = Exp( - xdn(mgs,ls)*cx(mgs,ls)*vgra*a3 ) !! EXP(-(ROS*XNS*VGRA/(RO*QI))) +! (1.-(XNS*VGRA*ROS/(RO*QI)))*DNNET + a2 = (1.-(cx(mgs,ls)*vgra*xdn(mgs,ls)*a3))*dnnet +! (XNS**2*VGRA*ROS/(RO*QI**2))*DQNET + a4 = cx(mgs,ls)**2*vgra*xdn(mgs,ls)*a3/qx(mgs,ls)*dqnet + + chcns(mgs) = Max( 0.0, a1*(a2 + a4) ) + chcns(mgs) = Min( chcns(mgs), cxmxd(mgs,ls) ) + chcnsh(mgs) = chcns(mgs) + + qhcns(mgs) = Min( xdn(mgs,ls)*vgra*rhoinv(mgs)*chcns(mgs), qxmxd(mgs,ls) ) + vhcns(mgs) = rho0(mgs)*qhcns(mgs)/Max(xdn(mgs,ls),xdnmn(lh)) +! vhcns(mgs) = rho0(mgs)*qhcns(mgs)/Max(xdn(mgs,ls),400.) + + ELSEIF ( iglcnvs .ge. 2 ) THEN ! treat like ice crystals, i.e., check for rime density (ERM) + + IF ( temg(mgs) .lt. 273.0 .and. ( qsacw(mgs) - qsdpv(mgs) .gt. 0.0 .or. & + ( iglcnvs >= 3 .and. qsacw(mgs)*dtp > 2.*qxmin(lh) .and. gamsnow73fac*xmas(mgs,ls) > xdnmn(lh)*xvmn(lh) ) ) ) THEN !{ + + + tmp = rimc1*(-((0.5)*(1.e+06)*xdia(mgs,lc,1)) & + & *((0.60)*vtxbar(mgs,ls,1)) & + & /(temg(mgs)-273.15))**(rimc2) +! tmp = Min( Max( rimc3, tmp ), 900.0 ) + tmp = Min( tmp , 900.0 ) + + ! Assume that half the volume of the embryo is rime with density 'tmp' + ! m = rhoi*(V/2) + rhorime*(V/2) = (rhoi + rhorime)*V/2 + ! V = 2*m/(rhoi + rhorime) + +! write(0,*) 'rime dens = ',tmp + + IF ( iglcnvs == 2 ) THEN !{ + IF ( tmp .ge. 200.0 ) THEN + r = Max( 0.5*(xdn(mgs,ls) + tmp), xdnmn(lh) ) +! r = Max( r, 400. ) + qhcns(mgs) = (qsacw(mgs) - qsdpv(mgs)) + chcns(mgs) = cx(mgs,ls)*qhcns(mgs)/qx(mgs,ls) +! chcnih(mgs) = rho0(mgs)*qhcni(mgs)/(1.6e-10) + chcnsh(mgs) = Min(chcns(mgs), rho0(mgs)*qhcns(mgs)/(r*xvmn(lh)) ) +! vhcni(mgs) = rho0(mgs)*2.0*qhcni(mgs)/(xdn(mgs,li) + tmp) + vhcns(mgs) = rho0(mgs)*qhcns(mgs)/r + ENDIF + + ELSEIF ( iglcnvs == 3 ) THEN + + ! convert to particles with the mass of the mass-weighted diameter + ! massofmwr = gamice73fac*xmas(mgs,li) + + IF ( tmp > xdnmn(lh) ) THEN + r = Max( 0.5*(xdn(mgs,ls) + tmp), xdnmn(lh) ) +! r = Max( r, 400. ) + qhcns(mgs) = 0.5*qsacw(mgs) + chcns(mgs) = qhcns(mgs)/(gamsnow73fac*xmas(mgs,ls)) + chcns(mgs) = Min( chcns(mgs), cx(mgs,ls)*qhcns(mgs)/qx(mgs,ls)) + chcnsh(mgs) = Min(chcns(mgs), rho0(mgs)*qhcns(mgs)/(r*xvmn(lh)) ) + vhcns(mgs) = rho0(mgs)*qhcns(mgs)/r + ENDIF + + ENDIF !} + + ENDIF !} + + ENDIF + + + ENDIF + + ELSE ! single moment lfo + + qhcns(mgs) = 0.001*ehscnv(mgs)*max((qx(mgs,ls)-6.e-4),0.0) + qhcns(mgs) = min(qhcns(mgs),qxmxd(mgs,ls)) + IF ( lvol(lh) .ge. 1 ) vhcns(mgs) = rho0(mgs)*qhcns(mgs)/Max(xdn(mgs,ls),400.) + + ENDIF + ENDDO +! +! +! heat budget for rain---not all rain that collects ice can freeze +! +! +! + if ( irwfrz .gt. 0 .and. .not. mixedphase) then +! + do mgs = 1,ngscnt +! +! compute total rain that freeze when it interacts with cloud ice +! + qrztot(mgs) = qrfrz(mgs) + qiacr(mgs) + qsacr(mgs) +! +! compute the maximum amount of rain that can freeze +! Used to limit freezing to 4*qrmxd, but now allow all rain to freeze if possible +! + qrzmax(mgs) = & + & ( xdia(mgs,lr,1)*rwvent(mgs)*cx(mgs,lr)*fwet1(mgs) ) + qrzmax(mgs) = max(qrzmax(mgs), 0.0) + qrzmax(mgs) = min(qrztot(mgs), qrzmax(mgs)) + qrzmax(mgs) = min(qx(mgs,lr)*dtpinv, qrzmax(mgs)) + + IF ( temcg(mgs) < -30. ) THEN ! allow all to freeze if T < -30 because fwet becomes invalid (negative) + qrzmax(mgs) = qx(mgs,lr)*dtpinv + ENDIF +! qrzmax(mgs) = min(4.*qrmxd(mgs), qrzmax(mgs)) +! +! compute the correction factor +! +! IF ( qrztot(mgs) .gt. qxmin(lr) ) THEN + IF ( qrztot(mgs) .gt. qrzmax(mgs) .and. qrztot(mgs) .gt. qxmin(lr) ) THEN + qrzfac(mgs) = qrzmax(mgs)/(qrztot(mgs)) + ELSE + qrzfac(mgs) = 1.0 + ENDIF + qrzfac(mgs) = min(1.0, qrzfac(mgs)) +! + end do +! +! +! now correct the above sources +! +! + do mgs = 1,ngscnt + if ( temg(mgs) .le. 273.15 .and. qrzfac(mgs) .lt. 1.0 ) then + qrfrz(mgs) = qrzfac(mgs)*qrfrz(mgs) + qrfrzs(mgs) = qrzfac(mgs)*qrfrzs(mgs) + qrfrzf(mgs) = qrzfac(mgs)*qrfrzf(mgs) + qiacr(mgs) = qrzfac(mgs)*qiacr(mgs) + qsacr(mgs) = qrzfac(mgs)*qsacr(mgs) + qiacrf(mgs) = qrzfac(mgs)*qiacrf(mgs) + qiacrs(mgs) = qrzfac(mgs)*qiacrs(mgs) + crfrz(mgs) = qrzfac(mgs)*crfrz(mgs) + crfrzf(mgs) = qrzfac(mgs)*crfrzf(mgs) + crfrzs(mgs) = qrzfac(mgs)*crfrzs(mgs) + ciacr(mgs) = qrzfac(mgs)*ciacr(mgs) + ciacrf(mgs) = qrzfac(mgs)*ciacrf(mgs) + ciacrs(mgs) = qrzfac(mgs)*ciacrs(mgs) + + + vrfrzf(mgs) = qrzfac(mgs)*vrfrzf(mgs) + viacrf(mgs) = qrzfac(mgs)*viacrf(mgs) + end if + end do +! +! +! + end if +! +! +! +! evaporation of rain +! +! +! + qrcev(:) = 0.0 + crcev(:) = 0.0 + + + do mgs = 1,ngscnt +! + IF ( qx(mgs,lr) .gt. qxmin(lr) ) THEN + + qrcev(mgs) = & + & fvce(mgs)*cx(mgs,lr)*rwvent(mgs)*rwcap(mgs)*evapfac +! this line to allow condensation on rain: + IF ( rcond .eq. 1 ) THEN + qrcev(mgs) = min(qrcev(mgs), qxmxd(mgs,lv)) +! this line to have evaporation only: + ELSE + qrcev(mgs) = min(qrcev(mgs), 0.0) + ENDIF + + qrcev(mgs) = max(qrcev(mgs), -qrmxd(mgs)) +! if ( temg(mgs) .lt. 273.15 ) qrcev(mgs) = 0.0 + IF ( qrcev(mgs) .lt. 0. .and. lnr > 1 ) THEN +! qrcev(mgs) = -qrmxd(mgs) +! crcev(mgs) = (rho0(mgs)/(xmas(mgs,lr)+1.e-20))*qrcev(mgs) + crcev(mgs) = (cx(mgs,lr)/(qx(mgs,lr)))*qrcev(mgs) + ELSE + crcev(mgs) = 0.0 + ENDIF +! if ( temg(mgs) .lt. 273.15 ) crcev(mgs) = 0.0 +! + ENDIF + + end do +! +! evaporation/condensation of wet graupel and snow +! + qscev(:) = 0.0 + cscev(:) = 0.0 + qhcev(:) = 0.0 + chcev(:) = 0.0 + qhlcev(:) = 0.0 + chlcev(:) = 0.0 + IF ( lhwlg > 1 ) THEN + qhcevlg(:) = 0.0 + chcevlg(:) = 0.0 + ENDIF + IF ( lhlwlg > 1 ) THEN + qhlcevlg(:) = 0.0 + chlcevlg(:) = 0.0 + ENDIF + +! +! +! +! ICE MULTIPLICATION: Two modes (rimpa, and rimpb) +! (following Cotton et al. 1986) +! + + chmul1(:) = 0.0 + chlmul1(:) = 0.0 + csmul1(:) = 0.0 +! + qhmul1(:) = 0.0 + qhlmul1(:) = 0.0 + qsmul1(:) = 0.0 + do mgs = 1,ngscnt + + ltest = qx(mgs,lh) .gt. qxmin(lh) + IF ( lhl > 1 ) ltest = ltest .or. qx(mgs,lhl) .gt. qxmin(lhl) + + IF ( (itype1 .ge. 1 .or. itype2 .ge. 1 ) & + & .and. qx(mgs,lc) .gt. qxmin(lc)) THEN + if ( temg(mgs) .ge. 265.15 .and. temg(mgs) .le. 271.15 ) then + IF ( ipconc .ge. 2 ) THEN + IF ( xv(mgs,lc) .gt. 0.0 & + & .and. ltest & +! .and. itype2 .ge. 2 & + & ) THEN +! +! Ziegler et al. 1986 Hallett-Mossop process. VSTAR = 7.23e-15 (vol of 12micron radius) +! + IF ( alpha(mgs,lc) == 0.0 ) THEN + ex1 = (1./250.)*Exp(-7.23e-15/xv(mgs,lc)) + ELSE + + ratio = (1. + alpha(mgs,lc))*(7.23e-15)/xv(mgs,lc) + + IF ( usegamxinfcnu ) THEN + i = Nint(dgami*(1. + alpha(mgs,lc))) + gcnup1 = gmoi(i) + ex1 = (1./250.)*Gamxinf(1.+alpha(mgs,lc), ratio)/(gcnup1) + ELSE + ratio = Min( maxratiolu, ratio ) + tmp = gaminterp(ratio,alpha(mgs,lc),1,1) + ex1 = (1./250.)*tmp + ENDIF + ENDIF + IF ( itype2 .le. 2 ) THEN + ft = Max(0.0,Min(1.0,-0.11*temcg(mgs)**2 - 1.1*temcg(mgs)-1.7)) + ELSE + IF ( temg(mgs) .ge. 265.15 .and. temg(mgs) .le. 267.15 ) THEN + ft = 0.5 + ELSEIF (temg(mgs) .ge. 267.15 .and. temg(mgs) .le. 269.15 ) THEN + ft = 1.0 + ELSEIF (temg(mgs) .ge. 269.15 .and. temg(mgs) .le. 271.15 ) THEN + ft = 0.5 + ELSE + ft = 0.0 + ENDIF + ENDIF +! rhoinv = 1./rho0(mgs) +! DNSTAR = ex1*cglacw(mgs) + + IF ( ft > 0.0 ) THEN + + IF ( itype2 > 0 ) THEN + IF ( qx(mgs,lh) .gt. qxmin(lh) .and. (.not. wetsfc(mgs)) ) THEN + chmul1(mgs) = ft*ex1*chacw(mgs) +! chmul1(mgs) = Min( ft*ex1*chacw(mgs), ft*(30.*1.e+06)*rho0(mgs)*qhacw(mgs) ) ! 1.e+6 converts kg to mg; Saunders & Hosseini (2001) average of about 30 crystals per mg + qhmul1(mgs) = cimas0*chmul1(mgs)*rhoinv(mgs) + ENDIF + IF ( lhl .gt. 1 ) THEN + IF ( qx(mgs,lhl) .gt. qxmin(lhl) .and. (.not. wetsfchl(mgs)) ) THEN + chlmul1(mgs) = (ft*ex1*chlacw(mgs)) + qhlmul1(mgs) = cimas0*chlmul1(mgs)*rhoinv(mgs) + ENDIF + ENDIF + ENDIF ! itype2 + + IF ( itype1 > 0 ) THEN + IF ( qx(mgs,lh) .gt. qxmin(lh) .and. (.not. wetsfc(mgs)) ) THEN + tmp = ft*(3.5e+08)*rho0(mgs)*qhacw(mgs) + chmul1(mgs) = chmul1(mgs) + tmp + qhmul1(mgs) = qhmul1(mgs) + cimas0*tmp*rhoinv(mgs) + ENDIF + IF ( lhl .gt. 1 ) THEN + IF ( qx(mgs,lhl) .gt. qxmin(lhl) .and. (.not. wetsfchl(mgs)) ) THEN + tmp = ft*(3.5e+08)*rho0(mgs)*qhlacw(mgs) + chlmul1(mgs) = chlmul1(mgs) + tmp + qhlmul1(mgs) = qhlmul1(mgs) + cimas0*tmp*rhoinv(mgs) + ENDIF + ENDIF + ENDIF ! itype1 + + + ENDIF ! ft + + ENDIF ! xv(mgs,lc) .gt. 0.0 .and. + + ELSE ! ipconc .lt. 2 +! +! define the temperature function +! + fimt1(mgs) = 0.0 +! +! Cotton et al. (1986) version +! + if ( temg(mgs) .ge. 268.15 .and. temg(mgs) .le. 270.15 ) then + fimt1(mgs) = 1.0 -(temg(mgs)-268.15)/2.0 + elseif (temg(mgs) .le. 268.15 .and. temg(mgs) .ge. 265.15 ) then + fimt1(mgs) = 1.0 +(temg(mgs)-268.15)/3.0 + ELSE + fimt1(mgs) = 0.0 + end if +! +! Ferrier (1994) version +! + if ( temg(mgs) .ge. 265.15 .and. temg(mgs) .le. 267.15 ) then + fimt1(mgs) = 0.5 + elseif (temg(mgs) .ge. 267.15 .and. temg(mgs) .le. 269.15 ) then + fimt1(mgs) = 1.0 + elseif (temg(mgs) .ge. 269.15 .and. temg(mgs) .le. 271.15 ) then + fimt1(mgs) = 0.5 + ELSE + fimt1(mgs) = 0.0 + end if +! +! +! type I: 350 splinters are formed for every 1e-3 grams of cloud +! water accreted by graupel/hail (note converted to MKS units) +! 3.5e+8 has units of 1/kg +! + IF ( itype1 .ge. 1 ) THEN + fimta(mgs) = (3.5e+08)*rho0(mgs) + ELSE + fimta(mgs) = 0.0 + ENDIF + +! +! +! type II: 1 splinter formed for every 250 cloud droplets larger than +! 24 micons in diameter (12 microns in radius) accreted by +! graupel/hail +! +! + fimt2(mgs) = 0.0 + xcwmas = xmas(mgs,lc) * 1000. +! + IF ( itype2 .ge. 1 ) THEN + if ( xcwmas.lt.1.26e-9 ) then + fimt2(mgs) = 0.0 + end if + if ( xcwmas .le. 3.55e-9 .and. xcwmas .ge. 1.26e-9 ) then + fimt2(mgs) = (2.27)*alog(xcwmas) + 13.39 + end if + if ( xcwmas .gt. 3.55e-9 ) then + fimt2(mgs) = 1.0 + end if + + fimt2(mgs) = min(fimt2(mgs),1.0) + fimt2(mgs) = max(fimt2(mgs),0.0) + + ENDIF +! +! qhmul2 = 0.0 +! qsmul2 = 0.0 +! +! qhmul2 = +! > (4.0e-03)*fimt1(mgs)*fimt2(mgs)*qhacw(mgs) +! qsmul2 = +! > (4.0e-03)*fimt1(mgs)*fimt2(mgs)*qsacw(mgs) +! +! cimas0 = (1.0e-12) +! cimas0 = 2.5e-10 + IF ( .not. wetsfc(mgs) ) THEN + chmul1(mgs) = fimt1(mgs)*(fimta(mgs) + & + & (4.0e-03)*fimt2(mgs))*qhacw(mgs) + ENDIF +! + qhmul1(mgs) = chmul1(mgs)*(cimas0/rho0(mgs)) + + IF ( lhl .gt. 1 ) THEN + IF ( qx(mgs,lhl) .gt. qxmin(lhl) .and. (.not. wetsfchl(mgs)) ) THEN + tmp = fimt1(mgs)*(fimta(mgs) + & + & (4.0e-03)*fimt2(mgs))*qhlacw(mgs) + chlmul1(mgs) = tmp + qhlmul1(mgs) = cimas0*tmp*rhoinv(mgs) + ENDIF + ENDIF + +! qsmul1(mgs) = csmul1(mgs)*(cimas0/rho0(mgs)) +! + ENDIF ! ( ipconc .ge. 2 ) + + end if ! (in temperature range) + + ENDIF ! ( itype1 .eq. 1 .or. itype2 .eq. 1) +! + end do +! +! +! +! end if +! +! end do +! +! +! ICE MULTIPLICATION FROM SNOW +! Lo and Passarelli 82 / Willis and Heymsfield 89 / Schuur and Rutledge 00b +! using kfrag as fragmentation rate (s-1) / 500 microns as char mean diam for max snow mix ratio +! + csmul(:) = 0.0 + qsmul(:) = 0.0 + + IF ( isnwfrac /= 0 ) THEN + do mgs = 1,ngscnt + IF (temg(mgs) .gt. 265.0) THEN !{ + if (xdia(mgs,ls,1) .gt. 100.e-6 .and. xdia(mgs,ls,1) .lt. 2.0e-3) then ! equiv diameter 100microns to 2mm + + tmp = rhoinv(mgs)*pi*xdn(mgs,ls)*cx(mgs,ls)*(500.e-6)**3 + qsmul(mgs) = Max( kfrag*( qx(mgs,ls) - tmp ) , 0.0 ) + + qsmul(mgs) = Min( qxmxd(mgs,li), qsmul(mgs) ) + csmul(mgs) = Min( cxmxd(mgs,li), rho0(mgs)*qsmul(mgs)/mfrag ) + + endif + ENDIF !} + enddo + ENDIF + +! +! frozen rain-rain interaction.... +! +! +! +! +! rain-ice interaction +! +! + do mgs = 1,ngscnt + qracif(mgs) = qraci(mgs) + cracif(mgs) = craci(mgs) +! ciacrf(mgs) = ciacr(mgs) + end do +! +! +! vapor to pristine ice crystals UP +! +! +! +! compute the nucleation rate +! +! do mgs = 1,ngscnt +! idqis = 0 +! if ( ssi(mgs) .gt. 1.0 ) idqis = 1 +! fiinit(mgs) = (felv(mgs)**2)/(cp*rw) +! dqisdt(mgs) = (qx(mgs,lv)-qis(mgs))/ +! > (1.0 + fiinit(mgs)*qis(mgs)/tsqr(mgs)) +! qidsvp(mgs) = dqisdt(mgs) +! cnnt = min(cnit*exp(-temcg(mgs)*bta1),1.0e+09) +! qiint(mgs) = +! > il5(mgs)*idqis*(1.0*dtpinv) +! < *min((6.88e-13)*cnnt/rho0(mgs), 0.25*dqisdt(mgs)) +! end do +! +! Meyers et al. (1992; JAS) and Ferrier (1994) primary ice nucleation +! + cmassin = cimasn ! 6.88e-13 + do mgs = 1,ngscnt + qiint(mgs) = 0.0 + ciint(mgs) = 0.0 + qicicnt(mgs) = 0.0 + cicint(mgs) = 0.0 + qipipnt(mgs) = 0.0 + cipint(mgs) = 0.0 + ccitmp = 0.0 + IF ( icenucopt == 1 .or. icenucopt == -10 .or. icenucopt == -11 ) THEN + if ( ( temg(mgs) .lt. 268.15 .or. & +! : ( imeyers5 .and. temg(mgs) .lt. 273.0) ) .and. & + & ( imeyers5 .and. temg(mgs) .lt. 272.0 .and. temgkm2(mgs) .lt. tfr) ) .and. & + & ciintmx .gt. (cx(mgs,li)+ccitmp) & +! : .and. cninm(mgs) .gt. 0. & + & ) then + fiinit(mgs) = (felv(mgs)**2)/(cp*rw) + dqisdt(mgs) = (qx(mgs,lv)-qis(mgs))/ & + & (1.0 + fiinit(mgs)*qis(mgs)/tsqr(mgs)) +! qidsvp(mgs) = dqisdt(mgs) + idqis = 0 + if ( ssi(mgs) .gt. 1.0 ) THEN + idqis = 1 + dzfacp = max( float(kgsp(mgs)-kgs(mgs)), 0.0 ) + dzfacm = max( float(kgs(mgs)-kgsm(mgs)), 0.0 ) + qiint(mgs) = & + & idqis*il5(mgs) & + & *(cmassin/rho0(mgs)) & + & *max(0.0,wvel(mgs)) & + & *max((cninp(mgs)-cninm(mgs)),0.0)/gz(igs(mgs),jgs,kgs(mgs)) & + & /((dzfacp+dzfacm)) + + qiint(mgs) = min(qiint(mgs), max(0.25*dqisdt(mgs),0.0)) + ciint(mgs) = qiint(mgs)*rho0(mgs)/cmassin + +! +! limit new crystals so it does not increase the current concentration +! above ciintmx 20,000 per liter (2.e7 per m**3) +! +! ciintmx = 1.e9 +! ciintmx = 1.e9 + IF ( icenucopt /= -10 ) THEN + + IF ( lcin > 1 ) THEN + ciint(mgs) = Min(ciint(mgs), ccin(mgs)*dtpinv) ! because ciint is a *rate* + ccin(mgs) = ccin(mgs) - ciint(mgs)*dtp + qiint(mgs) = ciint(mgs)*cmassin/rho0(mgs) + ELSEIF ( lcina > 1 ) THEN + ciint(mgs) = Max(0.0, Min( ciint(mgs), Min( cnina(mgs), ciintmx ) - cina(mgs) )) + qiint(mgs) = ciint(mgs)*cmassin/rho0(mgs) + + ELSEIF ( icenucopt == 1 .and. ciint(mgs) .gt. Max(0.0, ciintmx - cx(mgs,li) - ccitmp )*dtpinv ) THEN + ciint(mgs) = Max(0.0, ciintmx - (cx(mgs,li)) )*dtpinv + qiint(mgs) = ciint(mgs)*cmassin/rho0(mgs) + + ELSEIF ( icenucopt == -11 .and. dtp*ciint(mgs) .gt. ( cnina(mgs) - (cx(mgs,li) - ccitmp))) THEN + ciint(mgs) = Max(0.0, cnina(mgs) - (cx(mgs,li)+ccitmp)*dtpinv ) + qiint(mgs) = ciint(mgs)*cmassin/rho0(mgs) + + ENDIF + ENDIF + + end if + endif + + ELSEIF ( icenucopt == 2 .or. icenucopt == -1 .or. icenucopt == -2 ) THEN + + IF ( ( temg(mgs) .lt. 268.15 .and. ssw(mgs) > 1.0 ) .or. ssi(mgs) > 1.25 ) THEN + IF ( lcin > 1 ) THEN + ciint(mgs) = Min(cnina(mgs), ccin(mgs)) + ciint(mgs) = Min( ciint(mgs), Max(0.0, ciintmx - (cx(mgs,li) - ccitmp) ) ) ! do not initiate ice beyond concentration of ciintmx + ccin(mgs) = ccin(mgs) - ciint(mgs) + ciint(mgs) = ciint(mgs)*dtpinv ! convert total initiation to a rate + ELSE + ciint(mgs) = Max( 0.0, cnina(mgs) - cina(mgs) )*dtpinv + ENDIF + qiint(mgs) = ciint(mgs)*cmassin/rho0(mgs) + + fiinit(mgs) = (felv(mgs)**2)/(cp*rw) + dqisdt(mgs) = (qx(mgs,lv)-qis(mgs))/(1.0 + fiinit(mgs)*qis(mgs)/tsqr(mgs)) + qiint(mgs) = min(qiint(mgs), max(0.25*dqisdt(mgs),0.0)) + ciint(mgs) = qiint(mgs)*rho0(mgs)/cmassin + ENDIF + + + + ELSEIF ( icenucopt == 3 .or. icenucopt == 4 .or. icenucopt == 10 ) THEN + IF ( temg(mgs) .lt. 268.15 ) THEN + IF ( lcin > 1 ) THEN + ciint(mgs) = Min(cnina(mgs), ccin(mgs)) + ciint(mgs) = Min( ciint(mgs), Max(0.0, ciintmx - (cx(mgs,li) + ccitmp) ) ) ! do not initiate ice beyond concentration of ciintmx + ccin(mgs) = ccin(mgs) - ciint(mgs) + ciint(mgs) = ciint(mgs)*dtpinv ! convert total initiation to a rate + ELSE + ciint(mgs) = Max( 0.0, cnina(mgs) - cina(mgs) )*dtpinv + ENDIF + qiint(mgs) = ciint(mgs)*cmassin/rho0(mgs) + ENDIF + + ENDIF +! + if ( xplate(mgs) .eq. 1 ) then + qipipnt(mgs) = qiint(mgs) + cipint(mgs) = ciint(mgs) + end if +! + if ( xcolmn(mgs) .eq. 1 ) then + qicicnt(mgs) = qiint(mgs) + cicint(mgs) = ciint(mgs) + end if +! +! qipipnt(mgs) = 0.0 +! qicicnt(mgs) = qiint(mgs) +! + end do +! +! + +! +! vapor to cloud droplets UP +! + if (ndebug .gt. 0 ) write(0,*) 'dbg = 8' +! +! + if (ndebug .gt. 0 ) write(0,*) 'Collection: set 3-component' +! +! time for riming.... +! +! rimtim = 240.0 +! dtrim = rimtim +! xacrtim = 120.0 +! tranfr = 0.50 +! tranfw = 0.50 +! +! coefficients for riming +! +! rimc1 = 300.00 +! rimc2 = 0.44 +! +! +! zero some arrays +! +! + do mgs = 1,ngscnt + qrshr(mgs) = 0.0 + qwshw(mgs) = 0.0 + cwshw(mgs) = 0.0 + qsshrp(mgs) = 0.0 + qhshrp(mgs) = 0.0 + end do +! +! +! first sum all of the shed rain +! +! + do mgs = 1,ngscnt + qrshr(mgs) = qsshr(mgs) + qhshr(mgs) + qhlshr(mgs) + crshr(mgs) = chshrr(mgs)/rzxh(mgs) + chlshrr(mgs)/rzxhl(mgs) + + + IF ( ipconc .ge. 3 ) THEN +! crshr(mgs) = Max(crshr(mgs), rho0(mgs)*qrshr(mgs)/(xdn(mgs,lr)*vr1mm) ) + ENDIF + end do +! +! +! + +! +! +! +! + IF ( ipconc .ge. 1 ) THEN +! +! +! concentration production terms +! +! YYY +! +! +! DO mgs = 1,ngscnt + pccwi(:) = 0.0 + pccwd(:) = 0.0 + pccwdacc(:) = 0.0 + pccii(:) = 0.0 + pccin(:) = 0.0 + pccid(:) = 0.0 + pcisi(:) = 0.0 + pcisd(:) = 0.0 + pcrwi(:) = 0.0 + pcrwd(:) = 0.0 + pcswi(:) = 0.0 + pcswd(:) = 0.0 + pchwi(:) = 0.0 + pchwd(:) = 0.0 + pchli(:) = 0.0 + pchld(:) = 0.0 +! ENDDO +! +! Cloud ice +! +! IF ( ipconc .ge. 1 ) THEN + + IF ( warmonly < 0.5 ) THEN + IF ( ffrzs < 1.0 ) THEN + do mgs = 1,ngscnt + pccii(mgs) = & + & il5(mgs)*cicint(mgs) & + & +il5(mgs)*((1.0-cwfrz2snowfrac)*cwfrzc(mgs)+cwctfzc(mgs) & + & +cicichr(mgs)) & + & +chmul1(mgs) & + & +chlmul1(mgs) & + & + csplinter(mgs) + csplinter2(mgs) & + & +csmul(mgs) + + pccii(mgs) = pccii(mgs)*(1.0 - ffrzs) + +! > + nsplinter*(crfrzf(mgs) + crfrz(mgs)) + pccid(mgs) = & + & il5(mgs)*(-cscni(mgs) - cscnvi(mgs) & ! - cwaci(mgs) & + & -craci(mgs) & + & -csaci(mgs) & + & -chaci(mgs) - chlaci(mgs) & + & -chcni(mgs)) & + & +il5(mgs)*cisbv(mgs) & + & -(1.-il5(mgs))*cimlr(mgs) + + pccin(mgs) = ciint(mgs) + + + end do + ENDIF ! ffrzs + ELSEIF ( warmonly < 0.8 ) THEN + do mgs = 1,ngscnt + +! qiint(mgs) = 0.0 +! cicint(mgs) = 0.0 +! qicicnt(mgs) = 0.0 + + pccii(mgs) = & + & il5(mgs)*cicint(mgs) & + & +il5(mgs)*((1.0-cwfrz2snowfrac)*cwfrzc(mgs)+cwctfzc(mgs) & + & +cicichr(mgs)) & + & +chmul1(mgs) & + & +chlmul1(mgs) & + & + csplinter(mgs) + csplinter2(mgs) & + & +csmul(mgs) + + pccii(mgs) = pccii(mgs)*(1. - ffrzs) + pccid(mgs) = & +! & il5(mgs)*(-cscni(mgs) - cscnvi(mgs) & ! - cwaci(mgs) & +! & -craci(mgs) & +! & -csaci(mgs) & +! & -chaci(mgs) - chlaci(mgs) & +! & -chcni(mgs)) & + & +il5(mgs)*cisbv(mgs) & + & -(1.-il5(mgs))*cimlr(mgs) + + pccin(mgs) = ciint(mgs) + + end do + ENDIF ! warmonly + + +! ENDIF ! ( ipconc .ge. 1 ) +! +! Cloud water +! + IF ( ipconc .ge. 2 ) THEN + + do mgs = 1,ngscnt + pccwi(mgs) = (0.0) - cwshw(mgs) ! + (1-il5(mgs))*(-cirmlw(mgs)) + + IF ( warmonly < 0.5 ) THEN + pccwd(mgs) = & + & - cautn(mgs) + & + & il5(mgs)*(-ciacw(mgs)-cwfrz(mgs)-cwctfzp(mgs) & + & -cwctfzc(mgs) & + & ) & + & -cracw(mgs) -csacw(mgs) -chacw(mgs) - chlacw(mgs) + + + ELSEIF ( warmonly < 0.8 ) THEN + pccwd(mgs) = & + & - cautn(mgs) + & + & il5(mgs)*( & + & -ciacw(mgs)-cwfrz(mgs)-cwctfzp(mgs) & + & -cwctfzc(mgs) & + & ) & + & -cracw(mgs) -chacw(mgs) -chlacw(mgs) + ELSE + +! tmp3d(igs(mgs),jy,kgs(mgs)) = crcnw(mgs) + +! cracw(mgs) = 0.0 ! turn off accretion +! qracw(mgs) = 0.0 +! crcev(mgs) = 0.0 ! turn off evap +! qrcev(mgs) = 0.0 ! turn off evap +! cracr(mgs) = 0.0 ! turn off self collection + + +! cautn(mgs) = 0.0 +! crcnw(mgs) = 0.0 +! qrcnw(mgs) = 0.0 + + pccwd(mgs) = & + & - cautn(mgs) -cracw(mgs) + ENDIF + + + IF ( .false. .and. exwmindiam > 0.0 .and. ccwresv(mgs) > 0.0 ) THEN + pccwdacc(mgs) = & + & il5(mgs)*(-ciacw(mgs) & + & ) & + & -cracw(mgs) -csacw(mgs) -chacw(mgs) - chlacw(mgs) + + IF ( -pccwdacc(mgs)*dtp .gt. cx(mgs,lc) - ccwresv(mgs) ) THEN + + frac = -(cx(mgs,lc) - ccwresv(mgs) )/(pccwdacc(mgs)*dtp) + pccwdacc(mgs) = -(cx(mgs,lc) - ccwresv(mgs) )*dtpinv + + ciacw(mgs) = frac*ciacw(mgs) + cracw(mgs) = frac*cracw(mgs) + csacw(mgs) = frac*csacw(mgs) + chacw(mgs) = frac*chacw(mgs) + cautn(mgs) = frac*cautn(mgs) + + IF ( lhl .gt. 1 ) chlacw(mgs) = frac*chlacw(mgs) + +! resum + pccwd(mgs) = & + & - cautn(mgs) + & + & il5(mgs)*(-ciacw(mgs)-cwfrzp(mgs)-cwctfzp(mgs) & + & -cwfrzc(mgs)-cwctfzc(mgs) & + & -il5(mgs)*(ciihr(mgs)) & + & ) & + & -cracw(mgs) -csacw(mgs) -chacw(mgs) - chlacw(mgs) + + ENDIF + + ENDIF + + + IF ( -pccwd(mgs)*dtp .gt. cx(mgs,lc) ) THEN +! write(0,*) 'OUCH! pccwd(mgs)*dtp .gt. ccw(mgs) ',pccwd(mgs),cx(mgs,lc) +! write(0,*) 'qc = ',qx(mgs,lc) +! write(0,*) -ciacw(mgs)-cwfrzp(mgs)-cwctfzp(mgs)-cwfrzc(mgs)-cwctfzc(mgs) +! write(0,*) -cracw(mgs) -csacw(mgs) -chacw(mgs) +! write(0,*) - cautn(mgs) + + frac = -cx(mgs,lc)/(pccwd(mgs)*dtp) + pccwd(mgs) = -cx(mgs,lc)*dtpinv + + ciacw(mgs) = frac*ciacw(mgs) + cwfrz(mgs) = frac*cwfrz(mgs) + cwfrzp(mgs) = frac*cwfrzp(mgs) + cwctfzp(mgs) = frac*cwctfzp(mgs) + cwfrzc(mgs) = frac*cwfrzc(mgs) + cwctfzc(mgs) = frac*cwctfzc(mgs) + cwctfz(mgs) = frac*cwctfz(mgs) + cracw(mgs) = frac*cracw(mgs) + csacw(mgs) = frac*csacw(mgs) + chacw(mgs) = frac*chacw(mgs) + cautn(mgs) = frac*cautn(mgs) + + pccii(mgs) = pccii(mgs) - (1.-frac)*il5(mgs)*(cwfrzc(mgs)+cwctfzc(mgs))*(1. - ffrzs) + IF ( lhl .gt. 1 ) chlacw(mgs) = frac*chlacw(mgs) + +! STOP + ENDIF + + end do + + ENDIF ! ipconc + +! +! Rain +! + IF ( ipconc .ge. 3 ) THEN + + do mgs = 1,ngscnt + + IF ( warmonly < 0.5 ) THEN + pcrwi(mgs) = & +! > cracw(mgs) + & + & crcnw(mgs) & + & +(1-il5(mgs))*( & + & -chmlrr(mgs)/rzxh(mgs) & + & -chlmlrr(mgs)/rzxhl(mgs) & +! & -csmlr(mgs)/rzxs(mgs) & + & -csmlrr(mgs) & + & - cimlr(mgs) ) & + & -crshr(mgs) !null at this point when wet snow/graupel included + pcrwd(mgs) = & + & il5(mgs)*(-ciacr(mgs) - crfrz(mgs) ) & ! - cipacr(mgs)) +! > -csacr(mgs) & + & - chacr(mgs) - chlacr(mgs) & + & +crcev(mgs) & + & - cracr(mgs) +! > -il5(mgs)*ciracr(mgs) + + + ELSEIF ( warmonly < 0.8 ) THEN + pcrwi(mgs) = & + & crcnw(mgs) & + & +(1-il5(mgs))*( & + & -chmlrr(mgs)/rzxh(mgs) & + & -chlmlrr(mgs)/rzxhl(mgs) & +! & -csmlr(mgs) & + & -csmlrr(mgs) & + & - cimlr(mgs) ) & + & -crshr(mgs) !null at this point when wet snow/graupel included + pcrwd(mgs) = & + & il5(mgs)*( - crfrz(mgs) ) & ! - cipacr(mgs)) + & - chacr(mgs) & + & - chlacr(mgs) & + & +crcev(mgs) & + & - cracr(mgs) + ELSE + pcrwi(mgs) = & + & crcnw(mgs) + pcrwd(mgs) = & + & +crcev(mgs) & + & - cracr(mgs) + +! tmp3d(igs(mgs),jy,kgs(mgs)) = vtxbar(mgs,lr,1) ! crcnw(mgs) ! (pcrwi(mgs) + pcrwd(mgs)) +! pcrwi(mgs) = 0.0 +! pcrwd(mgs) = 0.0 +! qrcnw(mgs) = 0.0 + + ENDIF + + + frac = 0.0 + IF ( -pcrwd(mgs)*dtp .gt. cx(mgs,lr) ) THEN +! write(0,*) 'OUCH! pcrwd(mgs)*dtp .gt. crw(mgs) ',pcrwd(mgs)*dtp,cx(mgs,lr),mgs,igs(mgs),kgs(mgs) +! write(0,*) -ciacr(mgs) +! write(0,*) -crfrz(mgs) +! write(0,*) -chacr(mgs) +! write(0,*) crcev(mgs) +! write(0,*) -cracr(mgs) + + frac = -cx(mgs,lr)/(pcrwd(mgs)*dtp) + pcrwd(mgs) = -cx(mgs,lr)*dtpinv + + ciacr(mgs) = frac*ciacr(mgs) + ciacrf(mgs) = frac*ciacrf(mgs) + ciacrs(mgs) = frac*ciacrs(mgs) + crfrz(mgs) = frac*crfrz(mgs) + crfrzf(mgs) = frac*crfrzf(mgs) + crfrzs(mgs) = frac*crfrzs(mgs) + chacr(mgs) = frac*chacr(mgs) + chlacr(mgs) = frac*chlacr(mgs) + crcev(mgs) = frac*crcev(mgs) + cracr(mgs) = frac*cracr(mgs) + +! STOP + ENDIF + + end do + + ENDIF + + + IF ( warmonly < 0.5 ) THEN + +! +! Snow +! + IF ( ipconc .ge. 4 ) THEN ! + + do mgs = 1,ngscnt + pcswi(mgs) = & + & il5(mgs)*(cscnis(mgs) + cscnvis(mgs) ) & + & + cwfrz2snowfrac*cwfrz(mgs)/cwfrz2snowratio & + & + cscnh(mgs) + + IF ( ffrzs > 0.0 ) THEN + pcswi(mgs) = pcswi(mgs) + ffrzs* ( & + & il5(mgs)*cicint(mgs) & + & +il5(mgs)*(cwfrzc(mgs)+cwctfzc(mgs) & + & +cicichr(mgs)) & + & +chmul1(mgs) & + & +chlmul1(mgs) & + & + csplinter(mgs) + csplinter2(mgs) & + & +csmul(mgs) ) + ENDIF + + + IF ( ess0 < 0.0 ) THEN + csacs(mgs) = Max(0.0, csacs(mgs) - (ifrzs)*(crfrzs(mgs) + ciacrs(mgs))) + ENDIF + + pcswd(mgs) = & +! : cracs(mgs) & + & -chacs(mgs) - chlacs(mgs) & + & -chcns(mgs) & + & +(1-il5(mgs))*csmlr(mgs) + csshr(mgs) & ! + csshrp(mgs) +! > +il5(mgs)*(cssbv(mgs)) & + & + cssbv(mgs) & + & - csacs(mgs) + + frac = 0.0 + IF ( imixedphase == 0 ) THEN + IF ( cx(mgs,ls) + dtp*(pcswi(mgs) + pcswd(mgs)) < 0.0 ) THEN + frac = (-cx(mgs,ls) + pcswi(mgs)*dtp)/(pcswd(mgs)*dtp) + + pcswd(mgs) = frac*pcswd(mgs) + + chacs(mgs) = frac*chacs(mgs) + chlacs(mgs) = frac*chlacs(mgs) + chcns(mgs) = frac*chcns(mgs) + csmlr(mgs) = frac*csmlr(mgs) + csshr(mgs) = frac*csshr(mgs) + cssbv(mgs) = frac*cssbv(mgs) + csacs(mgs) = frac*csacs(mgs) + + ENDIF + ENDIF + + + + pccii(mgs) = pccii(mgs) & + & + (1. - ifrzs)*crfrzs(mgs) & + & + (1. - ifrzs)*ciacrs(mgs) + + pcswi(mgs) = pcswi(mgs) & + & + (ifrzs)*crfrzs(mgs) & + & + (ifrzs)*ciacrs(mgs) + + end do + + ENDIF + +! +! Graupel +! + IF ( ipconc .ge. 5 ) THEN ! + do mgs = 1,ngscnt + pchwi(mgs) = & + & +(ffrzh*ifrzg*crfrzf(mgs) & + & +il5(mgs)*ffrzh*ifiacrg*(ciacrf(mgs) )) & + & + f2h*chcnsh(mgs) + f2h*chcnih(mgs) + chcnhl(mgs) + + pchwd(mgs) = & + & (1-il5(mgs))*chmlr(mgs) & +! > + il5(mgs)*chsbv(mgs) & + & + chsbv(mgs) & + & - il5(mgs)*chlcnh(mgs) & + & - cscnh(mgs) + + end do + + + +! + +! +! Hail +! + IF ( lhl .gt. 1 .and. lnhl > 1 ) THEN ! + do mgs = 1,ngscnt + pchli(mgs) = (ffrzh*(1.0-ifrzg)*crfrzf(mgs) +il5(mgs)*ffrzh*(1.0-ifiacrg)*(ciacrf(mgs) )) & + & + chlcnhhl(mgs) *rzxhlh(mgs) + + pchld(mgs) = & + & (1-il5(mgs))*chlmlr(mgs) & +! > + il5(mgs)*chlsbv(mgs) & + & + chlsbv(mgs) - chcnhl(mgs) + + IF ( imixedphase == 0 ) THEN + frac = 0.0 + IF ( cx(mgs,lhl) + dtp*(pchli(mgs) + pchld(mgs)) < 0.0 ) THEN + ! rescale depletion + + frac = (-cx(mgs,lhl) + pchli(mgs)*dtp)/(pchld(mgs)*dtp) + + chlmlr(mgs) = frac*chlmlr(mgs) + chlsbv(mgs) = frac*chlsbv(mgs) + chcnhl(mgs) = frac*chcnhl(mgs) + + pchld(mgs) = frac*pchld(mgs) + + ENDIF + ENDIF + + end do + + ENDIF +! + + ENDIF ! (ipconc .ge. 5 ) + + ELSEIF ( warmonly < 0.8 ) THEN + +! +! Graupel +! + IF ( ipconc .ge. 5 ) THEN ! + do mgs = 1,ngscnt + pchwi(mgs) = & + & +ifrzg*(crfrzf(mgs) ) ! +il5(mgs)*(ciacrf(mgs) )) + + pchwd(mgs) = & + & (1-il5(mgs))*chmlr(mgs) & + & - il5(mgs)*chlcnh(mgs) + end do +! +! Hail +! + IF ( lhl .gt. 1 ) THEN ! + do mgs = 1,ngscnt + pchli(mgs) = (1.0-ifrzg)*(crfrzf(mgs)) & ! +il5(mgs)*(ciacrf(mgs) )) & + & + chlcnhhl(mgs) *rzxhl(mgs)/rzxh(mgs) + + pchld(mgs) = & + & (1-il5(mgs))*chlmlr(mgs) ! & +! > + il5(mgs)*chlsbv(mgs) & +! & + chlsbv(mgs) + +! IF ( pchli(mgs) .ne. 0. .or. pchld(mgs) .ne. 0 ) THEN +! write(0,*) 'dr: pchli,pchld = ', pchli(mgs),pchld(mgs), igs(mgs),kgs(mgs) +! ENDIF + end do + + ENDIF + + ENDIF ! ipconc >= 5 + + ENDIF ! warmonly + +! + +! +! Balance and checks for continuity.....within machine precision... +! + do mgs = 1,ngscnt + pctot(mgs) = pccwi(mgs) +pccwd(mgs) + & + & pccii(mgs) +pccid(mgs) + & + & pcrwi(mgs) +pcrwd(mgs) + & + & pcswi(mgs) +pcswd(mgs) + & + & pchwi(mgs) +pchwd(mgs) + & + & pchli(mgs) +pchld(mgs) + end do +! +! + ENDIF ! ( ipconc .ge. 1 ) +! +! +! +! +! +! GOGO +! production terms for mass +! +! + pqwvi(:) = 0.0 + pqwvd(:) = 0.0 + pqcwi(:) = 0.0 + pqcwd(:) = 0.0 + pqcwdacc(:) = 0.0 + pqcii(:) = 0.0 + pqcid(:) = 0.0 + pqrwi(:) = 0.0 + pqrwd(:) = 0.0 + pqswi(:) = 0.0 + pqswd(:) = 0.0 + pqhwi(:) = 0.0 + pqhwd(:) = 0.0 + pqhli(:) = 0.0 + pqhld(:) = 0.0 + pqlwsi(:) = 0.0 + pqlwsd(:) = 0.0 + pqlwhi(:) = 0.0 + pqlwhd(:) = 0.0 + pqlwlghi(:) = 0.0 + pqlwlghd(:) = 0.0 + pqlwlghli(:) = 0.0 + pqlwlghld(:) = 0.0 + pqlwhli(:) = 0.0 + pqlwhld(:) = 0.0 + + +! +! Vapor +! + IF ( warmonly < 0.5 ) THEN + do mgs = 1,ngscnt + +! NOTE: ANY CHANGES HERE ALSO NEED TO GO INTO THE RESUM FARTHER DOWN! + pqwvi(mgs) = & + & -Min(0.0, qrcev(mgs)) & + & -Min(0.0, qhcev(mgs)) & + & -Min(0.0, qhlcev(mgs)) & + & -Min(0.0, qscev(mgs)) & +! > +il5(mgs)*(-qhsbv(mgs) - qhlsbv(mgs) ) & + & -qhsbv(mgs) - qhlsbv(mgs) & + & -qssbv(mgs) & + & -il5(mgs)*qisbv(mgs) + + pqwvd(mgs) = & + & -Max(0.0, qrcev(mgs)) & + & -Max(0.0, qhcev(mgs)) & + & -Max(0.0, qhlcev(mgs)) & + & -Max(0.0, qscev(mgs)) & + & +il5(mgs)*(-qiint(mgs) & + & -qhdpv(mgs) -qsdpv(mgs) - qhldpv(mgs)) & + & -il5(mgs)*qidpv(mgs) + + end do + + ELSEIF ( warmonly < 0.8 ) THEN + do mgs = 1,ngscnt + pqwvi(mgs) = & + & -Min(0.0, qrcev(mgs)) & + & -il5(mgs)*qisbv(mgs) + pqwvd(mgs) = & + & +il5(mgs)*(-qiint(mgs) & +! & -qhdpv(mgs) ) & !- qhldpv(mgs)) & + & -qhdpv(mgs) - qhldpv(mgs)) & +! & -qhdpv(mgs) -qsdpv(mgs) - qhldpv(mgs)) & + & -Max(0.0, qrcev(mgs)) & + & -il5(mgs)*qidpv(mgs) + end do + + ELSE + do mgs = 1,ngscnt + pqwvi(mgs) = & + & -Min(0.0, qrcev(mgs)) + pqwvd(mgs) = & + & -Max(0.0, qrcev(mgs)) + end do + + ENDIF ! warmonly +! +! Cloud water +! + do mgs = 1,ngscnt + + pqcwi(mgs) = (0.0) + qwcnr(mgs) - qwshw(mgs) + + IF ( warmonly < 0.5 ) THEN + pqcwd(mgs) = & + & il5(mgs)*(-qiacw(mgs)-qwfrz(mgs)-qwctfz(mgs)) & + & -il5(mgs)*(qiihr(mgs)) & + & -qracw(mgs) -qsacw(mgs) -qrcnw(mgs) -qhacw(mgs) - qhlacw(mgs) !& +! & -il5(mgs)*(qwfrzp(mgs)) + ELSEIF ( warmonly < 0.8 ) THEN + pqcwd(mgs) = & + & il5(mgs)*(-qiacw(mgs)-qwfrz(mgs)-qwctfz(mgs)) & + & -il5(mgs)*(qiihr(mgs)) & + & -qracw(mgs) -qrcnw(mgs) -qhacw(mgs) -qhlacw(mgs) + ELSE + pqcwd(mgs) = & + & -qracw(mgs) - qrcnw(mgs) + ENDIF + + + IF ( pqcwd(mgs) .lt. 0.0 .and. -pqcwd(mgs)*dtp .gt. qx(mgs,lc) ) THEN + + frac = -Max(0.0,qx(mgs,lc))/(pqcwd(mgs)*dtp) + pqcwd(mgs) = -qx(mgs,lc)*dtpinv + + qiacw(mgs) = frac*qiacw(mgs) +! qwfrzp(mgs) = frac*qwfrzp(mgs) +! qwctfzp(mgs) = frac*qwctfzp(mgs) + qwfrzc(mgs) = frac*qwfrzc(mgs) + qwfrz(mgs) = frac*qwfrz(mgs) + qwctfzc(mgs) = frac*qwctfzc(mgs) + qwctfz(mgs) = frac*qwctfz(mgs) + qracw(mgs) = frac*qracw(mgs) + qsacw(mgs) = frac*qsacw(mgs) + qhacw(mgs) = frac*qhacw(mgs) + vhacw(mgs) = frac*vhacw(mgs) + qrcnw(mgs) = frac*qrcnw(mgs) + qwfrzp(mgs) = frac*qwfrzp(mgs) + IF ( lhl .gt. 1 ) THEN + qhlacw(mgs) = frac*qhlacw(mgs) + vhlacw(mgs) = frac*vhlacw(mgs) + ENDIF +! IF ( lzh .gt. 1 ) zhacw(mgs) = frac*zhacw(mgs) + +! STOP + ENDIF + + + end do +! +! Cloud ice +! + IF ( warmonly < 0.5 ) THEN + + do mgs = 1,ngscnt + IF ( ffrzs < 1.0 ) THEN + pqcii(mgs) = & + & il5(mgs)*qicicnt(mgs) & + & +il5(mgs)*((1.0-cwfrz2snowfrac)*qwfrzc(mgs)+qwctfzc(mgs)) & + & +il5(mgs)*(qicichr(mgs)) & + & +qsmul(mgs) & + & +qhmul1(mgs) + qhlmul1(mgs) & + & + qsplinter(mgs) + qsplinter2(mgs) +! > + cimas0*nsplinter*(crfrzf(mgs) + crfrz(mgs))/rho0(mgs) + ENDIF + + pqcii(mgs) = pqcii(mgs)*(1.0 - ffrzs) & + & +il5(mgs)*qidpv(mgs) & + & +il5(mgs)*qiacw(mgs) + + pqcid(mgs) = & + & il5(mgs)*(-qscni(mgs) - qscnvi(mgs) & ! -qwaci(mgs) & + & -qraci(mgs) & + & -qsaci(mgs) ) & + & -qhaci(mgs) & + & -qhlaci(mgs) & + & +il5(mgs)*qisbv(mgs) & + & +(1.-il5(mgs))*qimlr(mgs) & + & - qhcni(mgs) + end do + + + ELSEIF ( warmonly < 0.8 ) THEN + + do mgs = 1,ngscnt + pqcii(mgs) = & + & il5(mgs)*qicicnt(mgs)*(1. - ffrzs) & + & +il5(mgs)*((1.0-cwfrz2snowfrac)*qwfrzc(mgs)+qwctfzc(mgs))*(1. - ffrzs) & + & +il5(mgs)*(qicichr(mgs))*(1. - ffrzs) & +! & +il5(mgs)*(qicichr(mgs)) & +! & +qsmul(mgs) & + & +qhmul1(mgs) + qhlmul1(mgs) & + & + qsplinter(mgs) + qsplinter2(mgs) & + & +il5(mgs)*qidpv(mgs) & + & +il5(mgs)*qiacw(mgs) ! & ! (qiacwi(mgs)+qwacii(mgs)) & +! & +il5(mgs)*(qwfrzc(mgs)+qwctfzc(mgs)) & +! & +il5(mgs)*(qicichr(mgs)) & +! & +qsmul(mgs) & +! & +qhmul1(mgs) + qhlmul1(mgs) & +! & + qsplinter(mgs) + qsplinter2(mgs) + + pqcid(mgs) = & +! & il5(mgs)*(-qscni(mgs) - qscnvi(mgs) & ! -qwaci(mgs) & +! & -qraci(mgs) & +! & -qsaci(mgs) ) & +! & -qhaci(mgs) & +! & -qhlaci(mgs) & + & +il5(mgs)*qisbv(mgs) & + & +(1.-il5(mgs))*qimlr(mgs) ! & +! & - qhcni(mgs) + end do + + ENDIF +! +! Rain +! + + do mgs = 1,ngscnt + IF ( warmonly < 0.5 ) THEN + pqrwi(mgs) = & + & qracw(mgs) + qrcnw(mgs) + Max(0.0, qrcev(mgs)) & + & +(1-il5(mgs))*( & + & -qhmlr(mgs) & !null at this point when wet snow/graupel included + & -qsmlr(mgs) - qhlmlr(mgs) & + & -qimlr(mgs)) & +! & -qsshr(mgs) & !null at this point when wet snow/graupel included +! & -qhshr(mgs) & !null at this point when wet snow/graupel included +! & -qhlshr(mgs) & + & - qrshr(mgs) + + pqrwd(mgs) = & + & il5(mgs)*(-qiacr(mgs)-qrfrz(mgs)) & + & - qsacr(mgs) - qhacr(mgs) - qhlacr(mgs) - qwcnr(mgs) & + & + Min(0.0,qrcev(mgs)) + ELSEIF ( warmonly < 0.8 ) THEN + pqrwi(mgs) = & + & qracw(mgs) + qrcnw(mgs) + Max(0.0, qrcev(mgs)) & + & +(1-il5(mgs))*( & + & -qhlmlr(mgs) & !null at this point when wet snow/graupel included + & -qhmlr(mgs) ) & !null at this point when wet snow/graupel included + & -qhshr(mgs) & !null at this point when wet snow/graupel included + & -qhlshr(mgs) !null at this point when wet snow/graupel included + pqrwd(mgs) = & + & il5(mgs)*(-qrfrz(mgs)) & + & - qhacr(mgs) & + & - qhlacr(mgs) & + & + Min(0.0,qrcev(mgs)) + ELSE + pqrwi(mgs) = & + & qracw(mgs) + qrcnw(mgs) + Max(0.0, qrcev(mgs)) + pqrwd(mgs) = Min(0.0,qrcev(mgs)) + ENDIF ! warmonly + + + ! IF ( pqrwd(mgs) .lt. 0.0 .and. -(pqrwd(mgs) + pqrwi(mgs))*dtp .gt. qx(mgs,lr) ) THEN + IF ( pqrwd(mgs) .lt. 0.0 .and. -(pqrwd(mgs) + pqrwi(mgs))*dtp .gt. qx(mgs,lr) ) THEN + + frac = (-qx(mgs,lr) + pqrwi(mgs)*dtp)/(pqrwd(mgs)*dtp) +! pqrwd(mgs) = -qx(mgs,lr)*dtpinv + pqrwi(mgs) + + pqwvi(mgs) = pqwvi(mgs) & + & + Min(0.0, qrcev(mgs)) & + & - frac*Min(0.0, qrcev(mgs)) + pqwvd(mgs) = pqwvd(mgs) & + & + Max(0.0, qrcev(mgs)) & + & - frac*Max(0.0, qrcev(mgs)) + + qiacr(mgs) = frac*qiacr(mgs) + qiacrf(mgs) = frac*qiacrf(mgs) + qiacrs(mgs) = frac*qiacrs(mgs) + viacrf(mgs) = frac*viacrf(mgs) + qrfrz(mgs) = frac*qrfrz(mgs) + qrfrzs(mgs) = frac*qrfrzs(mgs) + qrfrzf(mgs) = frac*qrfrzf(mgs) + vrfrzf(mgs) = frac*vrfrzf(mgs) + qsacr(mgs) = frac*qsacr(mgs) + qhacr(mgs) = frac*qhacr(mgs) + vhacr(mgs) = frac*vhacr(mgs) + qrcev(mgs) = frac*qrcev(mgs) + qhlacr(mgs) = frac*qhlacr(mgs) + vhlacr(mgs) = frac*vhlacr(mgs) +! qhcev(mgs) = frac*qhcev(mgs) + + + IF ( warmonly < 0.5 ) THEN + pqrwd(mgs) = & + & il5(mgs)*(-qiacr(mgs)-qrfrz(mgs) - qsacr(mgs)) & + & - qhacr(mgs) - qhlacr(mgs) - qwcnr(mgs) & + & + Min(0.0,qrcev(mgs)) + ELSEIF ( warmonly < 0.8 ) THEN + pqrwd(mgs) = & + & il5(mgs)*(-qrfrz(mgs)) & + & - qhacr(mgs) & + & - qhlacr(mgs) & + & + Min(0.0,qrcev(mgs)) + ELSE + pqrwd(mgs) = Min(0.0,qrcev(mgs)) + ENDIF ! warmonly + +! +! Resum for vapor since qrcev has changed +! + IF ( qrcev(mgs) .ne. 0.0 ) THEN + pqwvi(mgs) = & + & -Min(0.0, qrcev(mgs)) & + & -Min(0.0, qhcev(mgs)) & + & -Min(0.0, qhlcev(mgs)) & + & -Min(0.0, qscev(mgs)) & +! > +il5(mgs)*(-qhsbv(mgs) - qhlsbv(mgs) ) & + & -qhsbv(mgs) - qhlsbv(mgs) & + & -qssbv(mgs) & + & -il5(mgs)*qisbv(mgs) + + pqwvd(mgs) = & + & -Max(0.0, qrcev(mgs)) & + & -Max(0.0, qhcev(mgs)) & + & -Max(0.0, qhlcev(mgs)) & + & -Max(0.0, qscev(mgs)) & + & +il5(mgs)*(-qiint(mgs) & + & -qhdpv(mgs) -qsdpv(mgs) - qhldpv(mgs)) & + & -il5(mgs)*qidpv(mgs) + + ENDIF + + +! STOP + ENDIF + end do + + IF ( warmonly < 0.5 ) THEN + +! +! Snow +! + do mgs = 1,ngscnt + pqswi(mgs) = & + & il5(mgs)*(qscni(mgs)+qsaci(mgs)+qsdpv(mgs) & + & + qscnvi(mgs) & + & + ifrzs*(qiacrs(mgs) + qrfrzs(mgs)) & + & + il5(mgs)*(( qwfrzc(mgs) + qwctfzc(mgs) + qicichr(mgs) )*ffrzs & + & + (1.0 - ffrzs)*cwfrz2snowfrac*qwfrz(mgs) ) & + & + il2(mgs)*qsacr(mgs)) & + & + il5(mgs)*qicicnt(mgs)*ffrzs & + & + il3(mgs)*(qiacrf(mgs)+qracif(mgs)) & ! only applies for ipconc <= 3 + & + Max(0.0, qscev(mgs)) & + & + qsacw(mgs) + qscnh(mgs) & + & + ffrzs*(qsmul(mgs) & + & +qhmul1(mgs) + qhlmul1(mgs) & + & + qsplinter(mgs) + qsplinter2(mgs)) + pqswd(mgs) = & +! > -qfacs(mgs) ! -qwacs(mgs) & + & -qracs(mgs)*(1-il2(mgs)) -qhacs(mgs) - qhlacs(mgs) & + & -qhcns(mgs) & + & +(1-il5(mgs))*qsmlr(mgs) + qsshr(mgs) & !null at this point when wet snow included +! > +il5(mgs)*(qssbv(mgs)) & + & + (qssbv(mgs)) & + & + Min(0.0, qscev(mgs)) & + & -qsmul(mgs) + + + IF ( imixedphase == 0 .and. pqswd(mgs) .lt. 0.0 ) THEN + IF ( qx(mgs,ls) + dtp*(pqswi(mgs) + pqswd(mgs)) < 0.0 ) THEN + frac = (-qx(mgs,ls) + pqswi(mgs)*dtp)/(pqswd(mgs)*dtp) + + pqswd(mgs) = frac*pqswd(mgs) + + qracs(mgs) = frac*qracs(mgs) ! only used for single moment at this time + qhacs(mgs) = frac*qhacs(mgs) + qhlacs(mgs) = frac*qhlacs(mgs) + qhcns(mgs) = frac*qhcns(mgs) + qsmlr(mgs) = frac*qsmlr(mgs) + qsshr(mgs) = frac*qsshr(mgs) + qssbv(mgs) = frac*qssbv(mgs) + qsmul(mgs) = frac*qsmul(mgs) + IF ( qscev(mgs) < 0.0 ) qscev(mgs) = frac*qscev(mgs) + + ENDIF + ENDIF + + pqcii(mgs) = pqcii(mgs) & + & + (1. - ifrzs)*qrfrzs(mgs) & + & + (1. - ifrzs)*qiacrs(mgs) + + end do + +! +! Graupel +! + do mgs = 1,ngscnt + pqhwi(mgs) = & + & +il5(mgs)*(ffrzh*ifrzg*qrfrzf(mgs) + (1-il3(mgs))*ffrzh*ifiacrg*(qiacrf(mgs)+qracif(mgs))) & + & + (1-il2(mgs))*(qracs(mgs) + qsacr(mgs)) & ! only used for ipconc < 3 + & +il5(mgs)*(qhdpv(mgs)) & + & +Max(0.0, qhcev(mgs)) & + & +qhacr(mgs)+qhacw(mgs) & + & +qhacs(mgs)+qhaci(mgs) & + & + f2h*qhcns(mgs) + f2h*qhcni(mgs) + qhcnhl(mgs) + pqhwd(mgs) = & + & qhshr(mgs) & !null at this point when wet graupel included + & +(1-il5(mgs))*qhmlr(mgs) & !null at this point when wet graupel included +! > +il5(mgs)*qhsbv(mgs) & + & + qhsbv(mgs) & + & + Min(0.0, qhcev(mgs)) & + & -qhmul1(mgs) - qhlcnh(mgs) - qscnh(mgs) & + & - ffrzh*(qsplinter(mgs) + qsplinter2(mgs)) +! > - cimas0*nsplinter*(crfrzf(mgs) + crfrz(mgs))/rho0(mgs) + + end do + + +! +! Hail +! + IF ( lhl .gt. 1 ) THEN + + do mgs = 1,ngscnt + pqhli(mgs) = & + & +il5(mgs)*(qhldpv(mgs) + ((1.0-ifrzg)*qrfrzf(mgs) + (1.0-ifiacrg)*(qiacrf(mgs)+ qracif(mgs)))) & + & +Max(0.0, qhlcev(mgs)) & + & +qhlacr(mgs)+qhlacw(mgs) & + & +qhlacs(mgs)+qhlaci(mgs) & + & + qhlcnh(mgs) + pqhld(mgs) = & + & qhlshr(mgs) & + & +(1-il5(mgs))*qhlmlr(mgs) & +! > +il5(mgs)*qhlsbv(mgs) & + & + qhlsbv(mgs) & + & + Min(0.0, qhlcev(mgs)) & + & -qhlmul1(mgs) - qhcnhl(mgs) + + IF ( imixedphase == 0 ) THEN + frac = 0.0 + IF ( qx(mgs,lhl) + dtp*(pqhli(mgs) + pqhld(mgs)) < 0.0 ) THEN + ! rescale depletion + + frac = (-qx(mgs,lhl) + pqhli(mgs)*dtp)/(pqhld(mgs)*dtp) + + qhlmlr(mgs) = frac*qhlmlr(mgs) + qhlsbv(mgs) = frac*qhlsbv(mgs) + qhcnhl(mgs) = frac*qhcnhl(mgs) + qhlmul1(mgs) = frac*qhlmul1(mgs) + IF ( qhlcev(mgs) < 0.0 ) qhlcev(mgs) = frac*qhlcev(mgs) + + pqhld(mgs) = frac*pqhld(mgs) + + ENDIF + ENDIF + + + end do + + ENDIF ! lhl + + ELSEIF ( warmonly < 0.8 ) THEN +! +! Graupel +! + do mgs = 1,ngscnt + pqhwi(mgs) = & + & +il5(mgs)*ifrzg*(qrfrzf(mgs) ) & + & +il5(mgs)*(qhdpv(mgs)) & + & +qhacr(mgs)+qhacw(mgs) + pqhwd(mgs) = & + & qhshr(mgs) & !null at this point when wet graupel included + & - qhlcnh(mgs) & + & - qhmul1(mgs) & + & - qsplinter(mgs) - qsplinter2(mgs) & + & +(1-il5(mgs))*qhmlr(mgs) !null at this point when wet graupel included + end do + +! +! Hail +! + IF ( lhl .gt. 1 ) THEN + + do mgs = 1,ngscnt + pqhli(mgs) = & + & +il5(mgs)*(qhldpv(mgs) ) & ! + (1.0-ifrzg)*(qiacrf(mgs)+qrfrzf(mgs) + qracif(mgs))) & + & +il5(mgs)*(1.0-ifrzg)*(qrfrzf(mgs) ) & + & +qhlacr(mgs)+qhlacw(mgs) & +! & +qhlacs(mgs)+qhlaci(mgs) & + & + qhlcnh(mgs) + pqhld(mgs) = & + & qhlshr(mgs) & + & +(1-il5(mgs))*qhlmlr(mgs) & +! > +il5(mgs)*qhlsbv(mgs) & + & + qhlsbv(mgs) & + & -qhlmul1(mgs) - qhcnhl(mgs) + + end do + + ENDIF ! lhl + + ENDIF ! warmonly + +! +! Liquid water on snow and graupel +! + + vhmlr(:) = 0.0 + vhlmlr(:) = 0.0 + vhfzh(:) = 0.0 + vhlfzhl(:) = 0.0 + + IF ( mixedphase ) THEN + ELSE ! set arrays for non-mixedphase graupel + +! vhshdr(:) = 0.0 + vhmlr(:) = qhmlr(:) ! not actually volume, but treated as q in rate equation +! vhsoak(:) = 0.0 + +! vhlshdr(:) = 0.0 + vhlmlr(:) = qhlmlr(:) ! not actually volume, but treated as q in rate equation +! vhlmlr(:) = rho0(:)*qhlmlr(:)/xdn(:,lhl) +! vhlsoak(:) = 0.0 + + ENDIF ! mixedphase + + + +! +! Snow volume +! + IF ( lvol(ls) .gt. 1 ) THEN + do mgs = 1,ngscnt +! pvswi(mgs) = rho0(mgs)*( pqswi(mgs) )/xdn0(ls) + + pvswi(mgs) = rho0(mgs)*( & +!aps > il5*qsfzs(mgs)/xdn(mgs,ls) & +!aps > -il5*qsfzs(mgs)/xdn(mgs,lr) & + & +il5(mgs)*(qscni(mgs)+qsaci(mgs)+qsdpv(mgs) & + & + qscnvi(mgs) + (1. - ifrzs)*qiacrs(mgs) & + & + (1. - ifrzs)*qrfrzs(mgs) & + & )/xdn0(ls) & + & + (qsacr(mgs))/rimdn(mgs,ls) ) + vsacw(mgs) +! > + (qsacw(mgs) + qsacr(mgs))/rimdn(mgs,ls) ) + pvswd(mgs) = rho0(mgs)*( pqswd(mgs) )/xdn0(ls) & +! > -qhacs(mgs) +! > -qhcns(mgs) +! > +(1-il5(mgs))*qsmlr(mgs) + qsshr(mgs) +! > +il5(mgs)*(qssbv(mgs)) + & -rho0(mgs)*qsmul(mgs)/xdn0(ls) +!aps > +rho0(mgs)*(1-il5(mgs))*( +!aps > qsmlr(mgs)/xdn(mgs,ls) +!aps > +(qscev-qsmlr(mgs))/xdn(mgs,lr) ) + end do + +!aps IF (mixedphase) THEN +!aps pvswd(mgs) = pvswd(mgs) +!aps > + rho0(mgs)*qsshr(mgs)/xdn(mgs,lr) +!aps ENDIF + + ENDIF +! +! Graupel volume +! + IF ( lvol(lh) .gt. 1 ) THEN + DO mgs = 1,ngscnt +! pvhwi(mgs) = rho0(mgs)*( (pqhwi(mgs) )/xdn0(lh) ) + +! pvhwi(mgs) = rho0(mgs)*( (pqhwi(mgs) - il5(mgs)*qrfrzf(mgs) )/xdn0(lh) ! +! : + il5(mgs)*qrfrzf(mgs)/rhofrz ) + + pvhwi(mgs) = rho0(mgs)*( & + & +il5(mgs)*( ifiacrg*ffrzh*qracif(mgs))/rhofrz & +!erm > + il5(mgs)*qhfzh(mgs)/rhofrz !aps: or use xdnmx(lh)? & + & + ( il5(mgs)*qhdpv(mgs)/qhdpvdn & + & + (qhacs(mgs) + qhaci(mgs))/qhacidn ) ) & + & + rho0(mgs)*Max(0.0, qhcev(mgs))/1000. & ! only used in mixed phase: evaporation/condensation of liquid water coating +! > + qhacs(mgs) + qhaci(mgs) )/xdn0(ls) ) & + & + f2h*vhcns(mgs) & + & + vhacr(mgs) + vhacw(mgs) + vhfzh(mgs) & ! qhacw(mgs)/rimdn(mgs,lh) +! > + vhfrh(mgs) & + & + f2h*vhcni(mgs) + (ifiacrg*viacrf(mgs) + ifrzg*vrfrzf(mgs))*ffrzh +! > +qhacr(mgs)/raindn(mgs,lh) + qhacw(mgs)/rimdn(mgs,lh) + +! pvhwd(mgs) = rho0(mgs)*(pqhwd(mgs) )/xdn0(lh) + + pvhwd(mgs) = rho0(mgs)*( & +! > qhshr(mgs)/xdn0(lr) & +! > - il5(mgs)*qhfzh(mgs)/xdn(mgs,lr) & + & +( (1-il5(mgs))*vhmlr(mgs) & +! > +il5(mgs)*qhsbv(mgs) & + & + qhsbv(mgs) & + & + Min(0.0, qhcev(mgs)) & + & -qhmul1(mgs) )/xdn(mgs,lh) ) & + & - vhlcnh(mgs) + vhshdr(mgs) - vhsoak(mgs) - vscnh(mgs) + +! IF (mixedphase) THEN +! pvhwd(mgs) = pvhwd(mgs) +! > + rho0(mgs)*qhshr(mgs)/xdn(mgs,lh) !xdn(mgs,lr) +! ENDIF + + IF ( .false. .and. ny .eq. 2 .and. kgs(mgs) .eq. 9 .and. igs(mgs) .eq. 19 ) THEN + + write(iunit,*) + write(iunit,*) 'Graupel at ',igs(mgs),kgs(mgs) +! + write(iunit,*) il5(mgs)*qrfrzf(mgs), qrfrzf(mgs) - qrfrz(mgs) + write(iunit,*) il5(mgs)*qiacrf(mgs) + write(iunit,*) il5(mgs)*qracif(mgs) + write(iunit,*) 'qhcns',qhcns(mgs) + write(iunit,*) 'qhcni',qhcni(mgs) + write(iunit,*) il5(mgs)*(qhdpv(mgs)) + write(iunit,*) 'qhacr ',qhacr(mgs) + write(iunit,*) 'qhacw', qhacw(mgs) + write(iunit,*) 'qhacs', qhacs(mgs) + write(iunit,*) 'qhaci', qhaci(mgs) + write(iunit,*) 'pqhwi = ',pqhwi(mgs) + write(iunit,*) + write(iunit,*) 'qhcev',qhcev(mgs) + write(iunit,*) + write(iunit,*) 'qhshr',qhshr(mgs) + write(iunit,*) 'qhmlr', (1-il5(mgs))*qhmlr(mgs) + write(iunit,*) 'qhsbv', qhsbv(mgs) + write(iunit,*) 'qhlcnh',-qhlcnh(mgs) + write(iunit,*) 'qhmul1',-qhmul1(mgs) + write(iunit,*) 'pqhwd = ', pqhwd(mgs) + write(iunit,*) + write(iunit,*) 'Volume' + write(iunit,*) + write(iunit,*) 'pvhwi',pvhwi(mgs) + write(iunit,*) 'vhcns', vhcns(mgs) + write(iunit,*) 'vhacr,vhacw',vhacr(mgs), vhacw(mgs) ! qhacw(mgs)/rimdn(mgs,lh) + write(iunit,*) 'vhcni',vhcni(mgs) + write(iunit,*) + write(iunit,*) 'pvhwd',pvhwd(mgs) + write(iunit,*) 'vhlcnh,vhshdr,vhsoak ', vhlcnh(mgs), vhshdr(mgs), vhsoak(mgs) + write(iunit,*) 'vhmlr', vhmlr(mgs) + write(iunit,*) +! write(iunit,*) +! write(iunit,*) +! write(iunit,*) + write(iunit,*) 'Concentration' + write(iunit,*) pchwi(mgs),pchwd(mgs) + write(iunit,*) crfrzf(mgs) + write(iunit,*) chcns(mgs) + write(iunit,*) ciacrf(mgs) + + + ENDIF + + + ENDDO + + ENDIF +! +! +! + +! +! Hail volume +! + IF ( lhl .gt. 1 ) THEN + IF ( lvol(lhl) .gt. 1 ) THEN + DO mgs = 1,ngscnt + + pvhli(mgs) = rho0(mgs)*( & + & + ( il5(mgs)*(((1.0-ifiacrg)*ffrzh*qracif(mgs))/rhofrz + qhldpv(mgs) ) & +! & + Max(0.0, qhlcev(mgs)) & +! & + qhlacs(mgs) + qhlaci(mgs) )/xdnmn(lhl) ) & ! xdn0(ls) ) & +! & + qhlacs(mgs) + qhlaci(mgs) )/xdnmn(lh) ) & ! yes, this is 'lh' on purpose + & + qhlacs(mgs) + qhlaci(mgs) )/500. ) & ! changed to 500 instead of min graupel density to keep hail density from dropping too much + & + rho0(mgs)*Max(0.0, qhlcev(mgs))/1000. & + & + vhlcnhl(mgs) + ((1.0-ifiacrg)*ffrzh*viacrf(mgs) + (1.0-ifrzg)*ffrzh*vrfrzf(mgs)) & + & + vhlacr(mgs) + vhlacw(mgs) + vhlfzhl(mgs) ! qhlacw(mgs)/rimdn(mgs,lhl) + + pvhld(mgs) = rho0(mgs)*( & + & +( qhlsbv(mgs) & + & + Min(0.0, qhlcev(mgs)) & + & -qhlmul1(mgs) )/xdn(mgs,lhl) ) & +! & + vhlmlr(mgs) & + & + rho0(mgs)*(1-il5(mgs))*vhlmlr(mgs)/xdn(mgs,lhl) & + & + vhlshdr(mgs) - vhlsoak(mgs) + + + ENDDO + + ENDIF + ENDIF + + + if ( ndebug .ge. 1 ) then + do mgs = 1,ngscnt +! + ptotal(mgs) = 0. + ptotal(mgs) = ptotal(mgs) & + & + pqwvi(mgs) + pqwvd(mgs) & + & + pqcwi(mgs) + pqcwd(mgs) & + & + pqcii(mgs) + pqcid(mgs) & + & + pqrwi(mgs) + pqrwd(mgs) & + & + pqswi(mgs) + pqswd(mgs) & + & + pqhwi(mgs) + pqhwd(mgs) & + & + pqhli(mgs) + pqhld(mgs) +! + + + + ENDDO + + do mgs = 1,ngscnt + + if ( ( (ndebug .ge. 0 ) .and. abs(ptotal(mgs)) .gt. eqtot ) & +! if ( ( abs(ptotal(mgs)) .gt. eqtot ) +! : .or. pqswi(mgs)*dtp .gt. 1.e-3 +! : .or. pqhwi(mgs)*dtp .gt. 1.e-3 +! : .or. dtp*(pqrwi(mgs)+pqrwd(mgs)) .gt. 10.0e-3 +! : .or. dtp*(pccii(mgs)+pccid(mgs)) .gt. 1.e7 +! : .or. dtp*(pcipi(mgs)+pcipd(mgs)) .gt. 1.e7 & + & .or. .not. (ptotal(mgs) .lt. 1.0 .and. ptotal(mgs) .gt. -1.0) & ! this line is basically checking for NaNs + & ) then + write(iunit,*) 'YIKES! ','ptotal1',mgs,igs(mgs),jgs, & + & kgs(mgs),ptotal(mgs) + + write(iunit,*) 't7: ', t7(igs(mgs),jgs,kgs(mgs)) + write(iunit,*) 'cci,ccw,crw,rdia: ',cx(mgs,li),cx(mgs,lc),cx(mgs,lr),0.5*xdia(mgs,lr,1) + write(iunit,*) 'qc,qi,qr : ',qx(mgs,lc),qx(mgs,li),qx(mgs,lr) + write(iunit,*) 'rmas, qrcalc : ',xmas(mgs,lr),xmas(mgs,lr)*cx(mgs,lr)/rho0(mgs) + write(iunit,*) 'vti,vtc,eiw,vtr: ',vtxbar(mgs,li,1),vtxbar(mgs,lc,1),eiw(mgs),vtxbar(mgs,lr,1) + write(iunit,*) 'cidia,cwdia,qcmxd: ', xdia(mgs,li,1),xdia(mgs,lc,1),qcmxd(mgs) + write(iunit,*) 'snow: ',qx(mgs,ls),cx(mgs,ls),swvent(mgs),vtxbar(mgs,ls,1),xdia(mgs,ls,1) + write(iunit,*) 'graupel: ',qx(mgs,lh),cx(mgs,lh),hwvent(mgs),vtxbar(mgs,lh,1),xdia(mgs,lh,1) + IF ( lhl .gt. 1 ) write(iunit,*) 'hail: ',qx(mgs,lhl),cx(mgs,lhl),hlvent(mgs),vtxbar(mgs,lhl,1),xdia(mgs,lhl,1) + + + write(iunit,*) 'li: ',xdia(mgs,li,1),xdia(mgs,li,2),xmas(mgs,li),qx(mgs,li), & + & vtxbar(mgs,li,1) + + + write(iunit,*) 'rain cx,xv : ',cx(mgs,lr),xv(mgs,lr) + write(iunit,*) 'temcg = ', temcg(mgs) + + write(iunit,*) 'v ', pqwvi(mgs) ,pqwvd(mgs) + write(iunit,*) 'c ', pqcwi(mgs) ,pqcwd(mgs) + write(iunit,*) 'ci', pqcii(mgs) ,pqcid(mgs) + write(iunit,*) 'r ', pqrwi(mgs) ,pqrwd(mgs) + write(iunit,*) 's ', pqswi(mgs) ,pqswd(mgs) + write(iunit,*) 'h ', pqhwi(mgs) ,pqhwd(mgs) + write(iunit,*) 'hl', pqhli(mgs) ,pqhld(mgs) + tmp = pqwvi(mgs) + pqwvd(mgs) & + & + pqcwi(mgs) + pqcwd(mgs) & + & + pqcii(mgs) + pqcid(mgs) & + & + pqrwi(mgs) + pqrwd(mgs) & + & + pqswi(mgs) + pqswd(mgs) & + & + pqhwi(mgs) + pqhwd(mgs) & + & + pqhli(mgs) + pqhld(mgs) + + write(iunit,*) 'total = ',tmp + write(iunit,*) 'END OF OUTPUT OF SOURCE AND SINK' + +! +! print production terms +! + write(iunit,*) + write(iunit,*) 'Vapor' +! + write(iunit,*) -Min(0.0,qrcev(mgs)) + write(iunit,*) -il5(mgs)*qhsbv(mgs) + write(iunit,*) -il5(mgs)*qhlsbv(mgs) + write(iunit,*) -il5(mgs)*qssbv(mgs) + write(iunit,*) -il5(mgs)*qisbv(mgs) + write(iunit,*) 'pqwvi= ', pqwvi(mgs) + write(iunit,*) -Max(0.0,qrcev(mgs)) + write(iunit,*) -Max(0.0,qhcev(mgs)) + write(iunit,*) -Max(0.0,qhlcev(mgs)) + write(iunit,*) -Max(0.0,qscev(mgs)) + write(iunit,*) -il5(mgs)*qiint(mgs) + write(iunit,*) -il5(mgs)*qhdpv(mgs) + write(iunit,*) -il5(mgs)*qhldpv(mgs) + write(iunit,*) -il5(mgs)*qsdpv(mgs) + write(iunit,*) -il5(mgs)*qidpv(mgs) + write(iunit,*) 'pqwvd = ', pqwvd(mgs) +! + write(iunit,*) + write(iunit,*) 'Cloud ice' +! + write(iunit,*) il5(mgs)*qicicnt(mgs) + write(iunit,*) il5(mgs)*qidpv(mgs) + write(iunit,*) il5(mgs)*qiacw(mgs) + write(iunit,*) il5(mgs)*qwfrzc(mgs) + write(iunit,*) il5(mgs)*qwctfzc(mgs) + write(iunit,*) il5(mgs)*qicichr(mgs) + write(iunit,*) qhmul1(mgs) + write(iunit,*) qhlmul1(mgs) + write(iunit,*) 'pqcii = ', pqcii(mgs) + write(iunit,*) -il5(mgs)*qscni(mgs) + write(iunit,*) -il5(mgs)*qscnvi(mgs) + write(iunit,*) -il5(mgs)*qraci(mgs) + write(iunit,*) -il5(mgs)*qsaci(mgs) + write(iunit,*) -il5(mgs)*qhaci(mgs) + write(iunit,*) -il5(mgs)*qhlaci(mgs) + write(iunit,*) il5(mgs)*qisbv(mgs) + write(iunit,*) (1.-il5(mgs))*qimlr(mgs) + write(iunit,*) -il5(mgs)*qhcni(mgs) + write(iunit,*) 'pqcid = ', pqcid(mgs) + write(iunit,*) ' Conc:' + write(iunit,*) pccii(mgs),pccid(mgs) + write(iunit,*) il5(mgs),cicint(mgs) + write(iunit,*) cwfrzc(mgs),cwctfzc(mgs) + write(iunit,*) cicichr(mgs) + write(iunit,*) chmul1(mgs) + write(iunit,*) chlmul1(mgs) + write(iunit,*) csmul(mgs) +! +! +! +! + write(iunit,*) + write(iunit,*) 'Cloud water' +! + write(iunit,*) 'pqcwi =', pqcwi(mgs) + write(iunit,*) -il5(mgs)*qiacw(mgs) + write(iunit,*) -il5(mgs)*qwfrzc(mgs) + write(iunit,*) -il5(mgs)*qwctfzc(mgs) +! write(iunit,*) -il5(mgs)*qwfrzp(mgs) +! write(iunit,*) -il5(mgs)*qwctfzp(mgs) + write(iunit,*) -il5(mgs)*qiihr(mgs) + write(iunit,*) -il5(mgs)*qicichr(mgs) + write(iunit,*) -il5(mgs)*qipiphr(mgs) + write(iunit,*) -qracw(mgs) + write(iunit,*) -qsacw(mgs) + write(iunit,*) -qrcnw(mgs) + write(iunit,*) -qhacw(mgs) + write(iunit,*) -qhlacw(mgs) + write(iunit,*) 'pqcwd = ', pqcwd(mgs) + + + write(iunit,*) + write(iunit,*) 'Concentration:' + write(iunit,*) -cautn(mgs) + write(iunit,*) -cracw(mgs) + write(iunit,*) -csacw(mgs) + write(iunit,*) -chacw(mgs) + write(iunit,*) -ciacw(mgs) + write(iunit,*) -cwfrzp(mgs) + write(iunit,*) -cwctfzp(mgs) + write(iunit,*) -cwfrzc(mgs) + write(iunit,*) -cwctfzc(mgs) + write(iunit,*) pccwd(mgs) +! + write(iunit,*) + write(iunit,*) 'Rain ' +! + write(iunit,*) qracw(mgs) + write(iunit,*) qrcnw(mgs) + write(iunit,*) Max(0.0, qrcev(mgs)) + write(iunit,*) -(1-il5(mgs))*qhmlr(mgs) + write(iunit,*) -(1-il5(mgs))*qhlmlr(mgs) + write(iunit,*) -(1-il5(mgs))*qsmlr(mgs) + write(iunit,*) -(1-il5(mgs))*qimlr(mgs) + write(iunit,*) -qrshr(mgs) + write(iunit,*) 'pqrwi = ', pqrwi(mgs) + write(iunit,*) -qsshr(mgs) + write(iunit,*) -qhshr(mgs) + write(iunit,*) -qhlshr(mgs) + write(iunit,*) -il5(mgs)*qiacr(mgs),qiacr(mgs), qiacrf(mgs) + write(iunit,*) -il5(mgs)*qrfrz(mgs) + write(iunit,*) -qsacr(mgs) + write(iunit,*) -qhacr(mgs) + write(iunit,*) -qhlacr(mgs) + write(iunit,*) qrcev(mgs) + write(iunit,*) 'pqrwd = ', pqrwd(mgs) + write(iunit,*) 'qrzfac = ', qrzfac(mgs) +! + + write(iunit,*) + write(iunit,*) 'Rain concentration' + write(iunit,*) pcrwi(mgs) + write(iunit,*) crcnw(mgs) + write(iunit,*) 1-il5(mgs) + write(iunit,*) -chmlr(mgs),-csmlr(mgs) + write(iunit,*) -crshr(mgs) + write(iunit,*) pcrwd(mgs) + write(iunit,*) il5(mgs) + write(iunit,*) -ciacr(mgs),-crfrz(mgs) + write(iunit,*) -csacr(mgs),-chacr(mgs) + write(iunit,*) +crcev(mgs) + write(iunit,*) cracr(mgs) +! write(iunit,*) -il5(mgs)*ciracr(mgs) + + + write(iunit,*) + write(iunit,*) 'Snow' +! + write(iunit,*) il5(mgs)*qscni(mgs), qscnvi(mgs) + write(iunit,*) il5(mgs)*qsaci(mgs) + write(iunit,*) il5(mgs)*qrfrzs(mgs) + write(iunit,*) il5(mgs)*qiacrs(mgs),il3(mgs)*(qiacrf(mgs)+qracif(mgs)),il3(mgs),qiacrf(mgs),qracif(mgs) + write(iunit,*) il5(mgs)*qsdpv(mgs), qscev(mgs) + write(iunit,*) qsacw(mgs) + write(iunit,*) qsacr(mgs), qscnh(mgs) + write(iunit,*) 'pqswi = ',pqswi(mgs) + write(iunit,*) -qhcns(mgs) + write(iunit,*) -qracs(mgs) + write(iunit,*) -qhacs(mgs) + write(iunit,*) -qhlacs(mgs) + write(iunit,*) (1-il5(mgs))*qsmlr(mgs) + write(iunit,*) qsshr(mgs) +! write(iunit,*) qsshrp(mgs) + write(iunit,*) il5(mgs)*(qssbv(mgs)) + write(iunit,*) 'pqswd = ', pqswd(mgs) + write(iunit,*) -qracs(mgs)*(1-il2(mgs)) , qhacs(mgs) , qhlacs(mgs) + write(iunit,*) -qhcns(mgs) + write(iunit,*) +(1-il5(mgs))*qsmlr(mgs) , qsshr(mgs) + write(iunit,*) (qssbv(mgs)) + write(iunit,*) Min(0.0, qscev(mgs)) + write(iunit,*) -qsmul(mgs) +! +! + write(iunit,*) + write(iunit,*) 'Graupel' +! + write(iunit,*) il5(mgs)*qrfrzf(mgs), qrfrzf(mgs) - qrfrz(mgs) + write(iunit,*) il5(mgs)*qiacrf(mgs) + write(iunit,*) il5(mgs)*qracif(mgs) + write(iunit,*) qhcns(mgs) + write(iunit,*) qhcni(mgs) + write(iunit,*) il5(mgs)*(qhdpv(mgs)) + write(iunit,*) qhacr(mgs) + write(iunit,*) qhacw(mgs) + write(iunit,*) qhacs(mgs) + write(iunit,*) qhaci(mgs) + write(iunit,*) 'pqhwi = ',pqhwi(mgs) + write(iunit,*) + write(iunit,*) qhshr(mgs) + write(iunit,*) (1-il5(mgs))*qhmlr(mgs) + write(iunit,*) il5(mgs),qhsbv(mgs) + write(iunit,*) -qhlcnh(mgs) + write(iunit,*) -qhmul1(mgs) + write(iunit,*) 'pqhwd = ', pqhwd(mgs) + write(iunit,*) 'Concentration' + write(iunit,*) pchwi(mgs),pchwd(mgs) + write(iunit,*) crfrzf(mgs) + write(iunit,*) chcns(mgs) + write(iunit,*) ciacrf(mgs) + +! + write(iunit,*) + write(iunit,*) 'Hail' +! + write(iunit,*) qhlcnh(mgs) + write(iunit,*) il5(mgs)*(qhldpv(mgs)) + write(iunit,*) qhlacr(mgs) + write(iunit,*) qhlacw(mgs) + write(iunit,*) qhlacs(mgs) + write(iunit,*) qhlaci(mgs) + write(iunit,*) pqhli(mgs) + write(iunit,*) + write(iunit,*) qhlshr(mgs) + write(iunit,*) (1-il5(mgs))*qhlmlr(mgs) + write(iunit,*) il5(mgs)*qhlsbv(mgs) + write(iunit,*) pqhld(mgs) + write(iunit,*) 'Concentration' + write(iunit,*) pchli(mgs),pchld(mgs) + write(iunit,*) chlcnh(mgs) +! +! Balance and checks for continuity.....within machine precision... +! +! + write(iunit,*) 'END OF OUTPUT OF SOURCE AND SINK' + write(iunit,*) 'PTOTAL',ptotal(mgs) +! + end if ! ptotal out of bounds or NaN +! + end do +! + + end if ! ( nstep/12*12 .eq. nstep ) + +! +! latent heating from phase changes (except qcw, qci cond, and evap) +! + do mgs = 1,ngscnt + IF ( warmonly < 0.5 ) THEN + pfrz(mgs) = & + & (1-il5(mgs))* & + & (qhmlr(mgs)+qsmlr(mgs)+qhlmlr(mgs)) & !+qhmlh(mgs)) & + & +il5(mgs)*(qhfzh(mgs)+qsfzs(mgs)+qhlfzhl(mgs)) & + & +il5(mgs)*(1-imixedphase)*( & + & qsacw(mgs)+qhacw(mgs) + qhlacw(mgs) & + & +qsacr(mgs)+qhacr(mgs) + qhlacr(mgs) & + & +qsshr(mgs) & + & +qhshr(mgs) & + & +qhlshr(mgs) +qrfrz(mgs)+qiacr(mgs) & + & ) & + & +il5(mgs)*(qwfrz(mgs) & + & +qwctfz(mgs)+qiihr(mgs) & + & +qiacw(mgs)) + pmlt(mgs) = & + & (1-il5(mgs))* & + & (qhmlr(mgs)+qsmlr(mgs)+qhlmlr(mgs)) !+qhmlh(mgs)) + ! NOTE: psub is sum of sublimation and deposition + psub(mgs) = & + & il5(mgs)*( & + & + qsdpv(mgs) + qhdpv(mgs) & + & + qhldpv(mgs) & + & + qidpv(mgs) + qisbv(mgs) ) & + & + qssbv(mgs) + qhsbv(mgs) + qhlsbv(mgs) & + & +il5(mgs)*(qiint(mgs)) + pvap(mgs) = & + & qrcev(mgs) + qhcev(mgs) + qscev(mgs) + qhlcev(mgs) + pevap(mgs) = & + & Min(0.0,qrcev(mgs)) + Min(0.0,qhcev(mgs)) + Min(0.0,qscev(mgs)) + Min(0.0,qhlcev(mgs)) + ! NOTE: pdep is the deposition part only + pdep(mgs) = & + & il5(mgs)*( & + & + qsdpv(mgs) + qhdpv(mgs) & + & + qhldpv(mgs) & + & + qidpv(mgs) ) & + & +il5(mgs)*(qiint(mgs)) + ELSEIF ( warmonly < 0.8 ) THEN + pfrz(mgs) = & + & (1-il5(mgs))* & + & (qhmlr(mgs)+qhlmlr(mgs)) & !+qhmlh(mgs)) & + & +il5(mgs)*(qhfzh(mgs)+qhlfzhl(mgs)) & + & +il5(mgs)*( & + & +qhshr(mgs) & + & +qhlshr(mgs) & + & +qrfrz(mgs)+qwfrz(mgs) & + & +qwctfz(mgs)+qiihr(mgs) & + & +qiacw(mgs) & + & +qhacw(mgs) + qhlacw(mgs) & + & +qhacr(mgs) + qhlacr(mgs) ) + psub(mgs) = 0.0 + & + & il5(mgs)*( & + & + qhdpv(mgs) & + & + qhldpv(mgs) & + & + qidpv(mgs) + qisbv(mgs) ) & + & +il5(mgs)*(qiint(mgs)) + pvap(mgs) = & + & qrcev(mgs) + qhcev(mgs) + qhlcev(mgs) ! + qscev(mgs) + ELSE + pfrz(mgs) = 0.0 + psub(mgs) = 0.0 + pvap(mgs) = qrcev(mgs) + ENDIF ! warmonly + ptem(mgs) = & + & (1./pi0(mgs))* & + & (felfcp(mgs)*pfrz(mgs) & + & +felscp(mgs)*psub(mgs) & + & +felvcp(mgs)*pvap(mgs)) + thetap(mgs) = thetap(mgs) + dtp*ptem(mgs) + ptem2(mgs) = ptem(mgs) + IF ( eqtset > 2 ) THEN + pipert(mgs) = pipert(mgs) + (felfpi(mgs)*pfrz(mgs) & + & +felspi(mgs)*psub(mgs) & + & +felvpi(mgs)*pvap(mgs))*dtp + ENDIF + end do + + + + +! +! sum the sources and sinks for qwvp, qcw, qci, qrw, qsw +! +! + do mgs = 1,ngscnt + qwvp(mgs) = qwvp(mgs) + & + & dtp*(pqwvi(mgs)+pqwvd(mgs)) + qx(mgs,lc) = qx(mgs,lc) + & + & dtp*(pqcwi(mgs)+pqcwd(mgs)) + qx(mgs,lr) = qx(mgs,lr) + & + & dtp*(pqrwi(mgs)+pqrwd(mgs)) + qx(mgs,li) = qx(mgs,li) + & + & dtp*(pqcii(mgs)+pqcid(mgs)) + qx(mgs,ls) = qx(mgs,ls) + & + & dtp*(pqswi(mgs)+pqswd(mgs)) + qx(mgs,lh) = qx(mgs,lh) + & + & dtp*(pqhwi(mgs)+pqhwd(mgs)) + IF ( lhl .gt. 1 ) THEN + qx(mgs,lhl) = qx(mgs,lhl) + & + & dtp*(pqhli(mgs)+pqhld(mgs)) + ENDIF + + + end do + +! sum sources for particle volume + + IF ( ldovol ) THEN + + do mgs = 1,ngscnt + + IF ( lvol(ls) .gt. 1 ) THEN + vx(mgs,ls) = vx(mgs,ls) + & + & dtp*(pvswi(mgs)+pvswd(mgs)) + ENDIF + + IF ( lvol(lh) .gt. 1 ) THEN + vx(mgs,lh) = vx(mgs,lh) + & + & dtp*(pvhwi(mgs)+pvhwd(mgs)) +! > rho0(mgs)*dtp*(pqhwi(mgs)+pqhwd(mgs))/xdn0(lh) + ENDIF + + IF ( lhl .gt. 1 ) THEN + IF ( lvol(lhl) .gt. 1 ) THEN + vx(mgs,lhl) = vx(mgs,lhl) + & + & dtp*(pvhli(mgs)+pvhld(mgs)) +! > rho0(mgs)*dtp*(pqhwi(mgs)+pqhwd(mgs))/xdn0(lh) + ENDIF + ENDIF + + ENDDO + + ENDIF ! ldovol + +! +! +! +! concentrations +! + if ( ipconc .ge. 1 ) then + do mgs = 1,ngscnt + cx(mgs,li) = cx(mgs,li) + & + & dtp*(pccii(mgs)+pccid(mgs)) + cina(mgs) = cina(mgs) + pccin(mgs)*dtp + IF ( ipconc .ge. 2 ) THEN + cx(mgs,lc) = cx(mgs,lc) + & + & dtp*(pccwi(mgs)+pccwd(mgs)) + ENDIF + IF ( ipconc .ge. 3 ) THEN + cx(mgs,lr) = cx(mgs,lr) + & + & dtp*(pcrwi(mgs)+pcrwd(mgs)) + ENDIF + IF ( ipconc .ge. 4 ) THEN + cx(mgs,ls) = cx(mgs,ls) + & + & dtp*(pcswi(mgs)+pcswd(mgs)) + ENDIF + IF ( ipconc .ge. 5 ) THEN + cx(mgs,lh) = cx(mgs,lh) + & + & dtp*(pchwi(mgs)+pchwd(mgs)) + IF ( lhl .gt. 1 ) THEN + cx(mgs,lhl) = cx(mgs,lhl) + & + & dtp*(pchli(mgs)+pchld(mgs)) + + + + + ENDIF + ENDIF + end do + end if + + + IF ( has_wetscav ) THEN + DO mgs = 1,ngscnt + evapprod2d(igs(mgs),kgs(mgs)) = -(qrcev(mgs) + qssbv(mgs) + qhsbv(mgs) + qhlsbv(mgs)) + rainprod2d(igs(mgs),kgs(mgs)) = qrcnw(mgs) + qracw(mgs) + qsacw(mgs) + qhacw(mgs) + qhlacw(mgs) + & + qraci(mgs) + qsaci(mgs) + qhaci(mgs) + qhlaci(mgs) + qscni(mgs) + ENDDO + ENDIF +! +! +! +! start saturation adjustment +! + if (ndebug .gt. 0 ) write(0,*) 'conc 30a' +! include 'sam.jms.satadj.sgi' +! +! +! +! Modified Straka adjustment (nearly identical to Tao et al. 1989 MWR) +! +! +! +! set up temperature and vapor arrays +! + do mgs = 1,ngscnt + pqs(mgs) = (380.0)/(pres(mgs)) + theta(mgs) = thetap(mgs) + theta0(mgs) + qvap(mgs) = max( (qwvp(mgs) + qv0(mgs)), 0.0 ) + temg(mgs) = theta(mgs)*pk(mgs) ! ( pres(mgs) / poo ) ** cap + end do +! +! melting of cloud ice +! + do mgs = 1,ngscnt + qcwtmp(mgs) = qx(mgs,lc) + ptimlw(mgs) = 0.0 + end do +! + do mgs = 1,ngscnt + qitmp(mgs) = qx(mgs,li) + if( temg(mgs) .gt. tfr .and. & + & qitmp(mgs) .gt. 0.0 ) then + qx(mgs,lc) = qx(mgs,lc) + qitmp(mgs) +! pfrz(mgs) = pfrz(mgs) - qitmp(mgs)*dtpinv + ptem(mgs) = ptem(mgs) + & + & (1./pi0(mgs))* & + & felfcp(mgs)*(- qitmp(mgs)*dtpinv) + IF ( eqtset > 2 ) THEN + pipert(mgs) = pipert(mgs) - (felfpi(mgs)*qitmp(mgs)) + ENDIF + pmlt(mgs) = pmlt(mgs) - qitmp(mgs)*dtpinv + scx(mgs,lc) = scx(mgs,lc) + scx(mgs,li) + thetap(mgs) = thetap(mgs) - & + & fcc3(mgs)*qitmp(mgs) + ptimlw(mgs) = -fcc3(mgs)*qitmp(mgs)*dtpinv + cx(mgs,lc) = cx(mgs,lc) + cx(mgs,li) + qx(mgs,li) = 0.0 + cx(mgs,li) = 0.0 + scx(mgs,li) = 0.0 + vx(mgs,li) = 0.0 + qitmp(mgs) = 0.0 + end if + end do + +! +! + + +! do mgs = 1,ngscnt +! qimlw(mgs) = (qcwtmp(mgs)-qx(mgs,lc))*dtpinv +! end do +! +! homogeneous freezing of cloud water +! + IF ( warmonly < 0.8 ) THEN + + do mgs = 1,ngscnt + qcwtmp(mgs) = qx(mgs,lc) + ptwfzi(mgs) = 0.0 + end do +! + do mgs = 1,ngscnt + +! if( temg(mgs) .lt. tfrh ) THEN +! write(0,*) 'GS: mgs,temp,qc,qi = ',mgs,temg(mgs),temcg(mgs),qx(mgs,lc),qx(mgs,li) +! ENDIF + + ctmp = 0.0 + frac = 0.0 + qtmp = 0.0 + +! if( ( temg(mgs) .lt. thnuc + 2. .or. (ibfc == 2 .and. temg(mgs) < thnuc + 10. ) ) .and. & +! & qx(mgs,lc) .gt. qxmin(lc) .and. (ipconc < 2 .or. ibfc == 0 .or. ibfc == 2 )) then +! commented for test (12/01/2015): +! if( temg(mgs) .lt. thnuc + 0. .and. & +! & qx(mgs,lc) .gt. 0.0 .and. (ipconc < 2 .or. ibfc == 0 )) then + if( ( ( temg(mgs) .lt. thnuc + 0.) .or. (temg(mgs) .lt. thnuc + 2. .and. ibfc >= 3) ) .and. & + & qx(mgs,lc) .gt. 0.0 .and. (ipconc < 2 .or. ibfc == 0 .or. ibfc == 2)) then + + IF ( ibfc >= 3 ) THEN + frac = Max( 0.25, Min( 1., ((thnuc + 2.) - temg(mgs) )/4.0 ) ) + ELSEIF ( ibfc /= 2 .or. ipconc < 2 ) THEN + frac = Max( 0.25, Min( 1., ((thnuc + 1.) - temg(mgs) )/4.0 ) ) + ELSE + volt = exp( 16.2 + 1.0*temcg(mgs) )* 1.0e-6 ! Ts == -temcg ; volt comes from the fit in Fig. 1 in Bigg 1953 + ! for mean temperature for freezing: -ln (V) = a*Ts - b + ! volt is given in cm**3, so factor of 1.e-6 to convert to m**3 + + cwfrz(mgs) = cx(mgs,lc)*Exp(-volt/xv(mgs,lc)) ! number of droplets with volume greater than volt + + qtmp = cwfrz(mgs)*xdn0(lc)*rhoinv(mgs)*(volt + xv(mgs,lc)) + frac = qtmp/qx(mgs,lc) ! reset number frozen to same fraction as mass. This makes + ! sure that cwfrz and qwfrz are consistent and prevents + ! spurious creation of ice crystals. + + ENDIF + qtmp = frac*qx(mgs,lc) + + IF ( ibfc == 4 .and. lis >= 1 ) THEN + qx(mgs,lis) = qx(mgs,lis) + qtmp + ELSE + qx(mgs,li) = qx(mgs,li) + qtmp ! qx(mgs,lc) + ENDIF + pfrz(mgs) = pfrz(mgs) + qtmp*dtpinv + ptem(mgs) = ptem(mgs) + & + & (1./pi0(mgs))* & + & felfcp(mgs)*(qtmp*dtpinv) + + IF ( eqtset > 2 ) THEN + pipert(mgs) = pipert(mgs) + felfpi(mgs)*qtmp + ENDIF + +! IF ( lvol(li) .gt. 1 ) vx(mgs,li) = vx(mgs,li) + rho0(mgs)*qx(mgs,lc)/xdn0(li) + IF ( lvol(li) .gt. 1 ) vx(mgs,li) = vx(mgs,li) + rho0(mgs)*qtmp/xdn0(li) + + IF ( ipconc .ge. 2 ) THEN + ctmp = frac*cx(mgs,lc) +! cx(mgs,li) = cx(mgs,li) + cx(mgs,lc) + IF ( ibfc == 4 .and. lis >= 1 ) THEN + cx(mgs,lis) = cx(mgs,lis) + ctmp + ELSE + cx(mgs,li) = cx(mgs,li) + ctmp + ENDIF + ELSE ! (ipconc .lt. 2 ) + ctmp = 0.0 + IF ( t9(igs(mgs),jgs,kgs(mgs)-1) .gt. qx(mgs,lc) ) THEN + qtmp = frac*t9(igs(mgs),jgs,kgs(mgs)-1) + +! cx(mgs,lc) = cx(mgs,lc)*qx(mgs,lc)*rho0(mgs)/qtmp + ctmp = cx(mgs,lc)*qx(mgs,lc)*rho0(mgs)/qtmp + ELSE + cx(mgs,lc) = Max(0.0,wvel(mgs))*dtp*cwccn & + & /gz(igs(mgs),jgs,kgs(mgs)) + cx(mgs,lc) = cwccn + ENDIF + + IF ( ipconc .ge. 1 ) cx(mgs,li) = Min(ccimx, cx(mgs,li) + cx(mgs,lc)) + ENDIF + + sctmp = frac*scx(mgs,lc) +! scx(mgs,li) = scx(mgs,li) + scx(mgs,lc) + scx(mgs,li) = scx(mgs,li) + sctmp +! thetap(mgs) = thetap(mgs) + fcc3(mgs)*qx(mgs,lc) +! ptwfzi(mgs) = fcc3(mgs)*qx(mgs,lc)*dtpinv +! qx(mgs,lc) = 0.0 +! cx(mgs,lc) = 0.0 +! scx(mgs,lc) = 0.0 + thetap(mgs) = thetap(mgs) + fcc3(mgs)*qtmp + ptwfzi(mgs) = fcc3(mgs)*qtmp*dtpinv + qx(mgs,lc) = qx(mgs,lc) - qtmp + cx(mgs,lc) = cx(mgs,lc) - ctmp + scx(mgs,lc) = scx(mgs,lc) - sctmp + end if + end do + + ENDIF ! warmonly +! +! do mgs = 1,ngscnt +! qwfzi(mgs) = (qcwtmp(mgs)-qx(mgs,lc))*dtpinv ! Not used?? (ERM) +! end do +! +! reset temporaries for cloud particles and vapor +! + qcond(:) = 0.0 + + IF ( ipconc .le. 1 .and. lwsm6 ) THEN ! Explicit cloud condensation/evaporation (Rutledge and Hobbs 1983) + DO mgs = 1,ngscnt + + qcwtmp(mgs) = qx(mgs,lc) + theta(mgs) = thetap(mgs) + theta0(mgs) + temgtmp = temg(mgs) +! temg(mgs) = theta(mgs)*(p2(igs(mgs),jgs,kgs(mgs)) ) ! *pk(mgs) ! ( pres(mgs) / poo ) ** cap +! temsav = temg(mgs) +! thsave(mgs) = thetap(mgs) + temg(mgs) = theta(mgs)*pk(mgs) ! ( pres(mgs) / poo ) ** cap + temcg(mgs) = temg(mgs) - tfr + ltemq = (temg(mgs)-163.15)/fqsat+1.5 + ltemq = Min( nqsat, Max(1,ltemq) ) + + qvs(mgs) = pqs(mgs)*tabqvs(ltemq) + + IF ( ( qvap(mgs) > qvs(mgs) .or. qx(mgs,lc) > qxmin(lc) ) .and. temg(mgs) > tfrh ) THEN + tmp = (qvap(mgs) - qvs(mgs))/(1. + qvs(mgs)*felv(mgs)**2/(cp*rw*temg(mgs)**2) ) + qcond(mgs) = Min( Max( 0.0, tmp ), (qvap(mgs)-qvs(mgs)) ) + IF ( qx(mgs,lc) > qxmin(lc) .and. tmp < 0.0 ) THEN ! evaporation + qcond(mgs) = Max( tmp, -qx(mgs,lc) ) + ENDIF + qwvp(mgs) = qwvp(mgs) - qcond(mgs) + qvap(mgs) = qvap(mgs) - qcond(mgs) + qx(mgs,lc) = Max( 0.0, qx(mgs,lc) + qcond(mgs) ) + thetap(mgs) = thetap(mgs) + felvcp(mgs)*qcond(mgs)/(pi0(mgs)) + + ENDIF + + ENDDO + + ENDIF + + + IF ( ipconc .le. 1 .and. .not. lwsm6 ) THEN +! IF ( ipconc .le. 1 ) THEN + + do mgs = 1,ngscnt + qx(mgs,lv) = max( 0.0, qvap(mgs) ) + qx(mgs,lc) = max( 0.0, qx(mgs,lc) ) + qx(mgs,li) = max( 0.0, qx(mgs,li) ) + qitmp(mgs) = qx(mgs,li) + end do +! +! + do mgs = 1,ngscnt + qcwtmp(mgs) = qx(mgs,lc) + qitmp(mgs) = qx(mgs,li) + theta(mgs) = thetap(mgs) + theta0(mgs) + temgtmp = temg(mgs) + temg(mgs) = theta(mgs)*(pinit(kgs(mgs)) + p2(igs(mgs),jgs,kgs(mgs)) ) ! *pk(mgs) ! ( pres(mgs) / poo ) ** cap + temsav = temg(mgs) + thsave(mgs) = thetap(mgs) + temcg(mgs) = temg(mgs) - tfr + tqvcon = temg(mgs)-cbw + ltemq = (temg(mgs)-163.15)/fqsat+1.5 + ltemq = Min( nqsat, Max(1,ltemq) ) +! IF ( ltemq .lt. 1 .or. ltemq .gt. nqsat ) THEN +! C$PAR CRITICAL SECTION +! write(iunit,*) 'out of range ltemq!',temgtmp,temg(mgs), +! : thetap(mgs),theta0(mgs),pres(mgs),theta(mgs), +! : ltemq,igs(mgs),jy,kgs(mgs) +! write(iunit,*) an(igs(mgs),jy,kgs(mgs),lt), +! : ab(igs(mgs),jy,kgs(mgs),lt), +! : t0(igs(mgs),jy,kgs(mgs)) +! write(iunit,*) fcc3(mgs),qx(mgs,lc),qitmp(mgs),dtp,ptem(mgs) +! STOP +! C$PAR END CRITICAL SECTION +! END IF + qvs(mgs) = pqs(mgs)*tabqvs(ltemq) + qis(mgs) = pqs(mgs)*tabqis(ltemq) +! qss(kz) = qvs(kz) +! if ( temg(kz) .lt. tfr ) then +! if( qcw(kz) .le. qxmin(lc) .and. qci(kz) .gt. qxmin(li)) +! > qss(kz) = qis(kz) +! if( qcw(kz) .gt. qxmin(lc) .and. qci(kz) .gt. qxmin(li)) +! > qss(kz) = (qcw(kz)*qvs(kz) + qci(kz)*qis(kz)) / +! > (qcw(kz) + qci(kz)) +! qss(kz) = qis(kz) +! end if +! dont get enough condensation with qcw .le./.gt. qxmin(lc) +! if ( temg(mgs) .lt. tfr ) then +! if( qx(mgs,lc) .ge. 0.0 .and. qitmp(mgs) .le. qxmin(li) ) +! > qss(mgs) = qvs(mgs) +! if( qx(mgs,lc) .eq. 0.0 .and. qitmp(mgs) .gt. qxmin(li)) +! > qss(mgs) = qis(mgs) +! if( qx(mgs,lc) .gt. 0.0 .and. qitmp(mgs) .gt. qxmin(li)) +! > qss(mgs) = (qx(mgs,lc)*qvs(mgs) + qitmp(mgs)*qis(mgs)) / +! > (qx(mgs,lc) + qitmp(mgs)) +! else +! qss(mgs) = qvs(mgs) +! end if + qss(mgs) = qvs(mgs) + if ( temg(mgs) .lt. tfr ) then + if( qx(mgs,lc) .ge. 0.0 .and. qitmp(mgs) .le. qxmin(li) ) & + & qss(mgs) = qvs(mgs) + if( qx(mgs,lc) .le. qxmin(lc) .and. qitmp(mgs) .gt. qxmin(li)) & + & qss(mgs) = qis(mgs) + if( qx(mgs,lc) .gt. qxmin(lc) .and. qitmp(mgs) .gt. qxmin(li)) & + & qss(mgs) = (qx(mgs,lc)*qvs(mgs) + qitmp(mgs)*qis(mgs)) / & + & (qx(mgs,lc) + qitmp(mgs)) + end if + end do +! +! iterate adjustment +! + do itertd = 1,2 +! + do mgs = 1,ngscnt +! +! calculate super-saturation +! + qitmp(mgs) = qx(mgs,li) + fcci(mgs) = 0.0 + fcip(mgs) = 0.0 + dqcw(mgs) = 0.0 + dqci(mgs) = 0.0 + dqwv(mgs) = ( qx(mgs,lv) - qss(mgs) ) +! +! evaporation and sublimation adjustment +! + if( dqwv(mgs) .lt. 0. ) then ! subsaturated + if( qx(mgs,lc) .gt. -dqwv(mgs) ) then ! check if qc can make up all of the deficit + dqcw(mgs) = dqwv(mgs) + dqwv(mgs) = 0. + else ! otherwise make all qc available for evap + dqcw(mgs) = -qx(mgs,lc) + dqwv(mgs) = dqwv(mgs) + qx(mgs,lc) + end if +! + if( qitmp(mgs) .gt. -dqwv(mgs) ) then ! check if qi can make up all the deficit + dqci(mgs) = dqwv(mgs) + dqwv(mgs) = 0. + else ! otherwise make all ice available for sublimation + dqci(mgs) = -qitmp(mgs) + dqwv(mgs) = dqwv(mgs) + qitmp(mgs) + end if +! + qwvp(mgs) = qwvp(mgs) - ( dqcw(mgs) + dqci(mgs) ) ! add to perturbation vapor +! +! This next line removed 3/19/2003 thanks to Adam Houston, +! who found the bug in the 3-ICE code +! qwvp(mgs) = max(qwvp(mgs), 0.0) + qitmp(mgs) = qx(mgs,li) + IF ( qitmp(mgs) .ge. qxmin(li) ) THEN + fcci(mgs) = qx(mgs,li)/(qitmp(mgs)) + ELSE + fcci(mgs) = 1.0 + ENDIF + qx(mgs,lc) = qx(mgs,lc) + dqcw(mgs) + qx(mgs,li) = qx(mgs,li) + dqci(mgs) * fcci(mgs) + thetap(mgs) = thetap(mgs) + & + & 1./pi0(mgs)* & + & (felvcp(mgs)*dqcw(mgs) +felscp(mgs)*dqci(mgs)) + + IF ( eqtset > 2 ) THEN + pipert(mgs) = pipert(mgs) & + & +(felspi(mgs)*dqci(mgs) & + & +felvpi(mgs)*dqcw(mgs))*dtp + ENDIF + + end if ! dqwv(mgs) .lt. 0. (end of evap/sublim) +! +! condensation/deposition +! + IF ( dqwv(mgs) .ge. 0. ) THEN + +! write(iunit,*) 'satadj: mgs,iter = ',mgs,itertd,dqwv(mgs),qss(mgs),qx(mgs,lv),qx(mgs,lc) +! + qitmp(mgs) = qx(mgs,li) + fracl(mgs) = 1.0 + fraci(mgs) = 0.0 + if ( temg(mgs) .lt. tfr .and. temg(mgs) .gt. thnuc ) then + fracl(mgs) = max(min(1.,(temg(mgs)-233.15)/(20.)),0.0) + fraci(mgs) = 1.0-fracl(mgs) + end if + if ( temg(mgs) .le. thnuc ) then + fraci(mgs) = 1.0 + fracl(mgs) = 0.0 + end if + fraci(mgs) = 1.0-fracl(mgs) +! + gamss = (felvcp(mgs)*fracl(mgs) + felscp(mgs)*fraci(mgs)) & + & / (pi0(mgs)) +! + IF ( temg(mgs) .lt. tfr ) then + IF (qx(mgs,lc) .ge. 0.0 .and. qitmp(mgs) .le. qxmin(li) ) then + dqvcnd(mgs) = dqwv(mgs)/(1. + fcqv1(mgs)*qss(mgs)/ & + & ((temg(mgs)-cbw)**2)) + END IF + IF ( qx(mgs,lc) .eq. 0.0 .and. qitmp(mgs) .gt. qxmin(li) ) then + dqvcnd(mgs) = dqwv(mgs)/(1. + fcqv2(mgs)*qss(mgs)/ & + & ((temg(mgs)-cbi)**2)) + END IF + IF ( qx(mgs,lc) .gt. 0.0 .and. qitmp(mgs) .gt. qxmin(li) ) then + cdw = caw*pi0(mgs)*tfrcbw/((temg(mgs)-cbw)**2) + cdi = cai*pi0(mgs)*tfrcbi/((temg(mgs)-cbi)**2) + denom1 = qx(mgs,lc) + qitmp(mgs) + denom2 = 1.0 + gamss* & + & (qx(mgs,lc)*qvs(mgs)*cdw + qitmp(mgs)*qis(mgs)*cdi) / denom1 + dqvcnd(mgs) = dqwv(mgs) / denom2 + END IF + + ENDIF ! temg(mgs) .lt. tfr +! + if ( temg(mgs) .ge. tfr ) then + dqvcnd(mgs) = dqwv(mgs)/(1. + fcqv1(mgs)*qss(mgs)/ & + & ((temg(mgs)-cbw)**2)) + end if +! + delqci1=qx(mgs,li) +! + IF ( qitmp(mgs) .gt. qxmin(li) ) THEN + fcci(mgs) = qx(mgs,li)/(qitmp(mgs)) + ELSE + fcci(mgs) = 1.0 + ENDIF +! + dqcw(mgs) = dqvcnd(mgs)*fracl(mgs) + dqci(mgs) = dqvcnd(mgs)*fraci(mgs) +! + thetap(mgs) = thetap(mgs) + & + & (felvcp(mgs)*dqcw(mgs) + felscp(mgs)*dqci(mgs)) & + & / (pi0(mgs)) + + IF ( eqtset > 2 ) THEN + pipert(mgs) = pipert(mgs) + (0 & + & +felspi(mgs)*dqci(mgs) & + & +felvpi(mgs)*dqcw(mgs))*dtp + ENDIF + + qwvp(mgs) = qwvp(mgs) - ( dqvcnd(mgs) ) + qx(mgs,lc) = qx(mgs,lc) + dqcw(mgs) +! IF ( qitmp(mgs) .gt. qxmin(li) ) THEN + qx(mgs,li) = qx(mgs,li) + dqci(mgs)*fcci(mgs) + qitmp(mgs) = qx(mgs,li) +! ENDIF +! +! delqci(mgs) = dqci(mgs)*fcci(mgs) +! + END IF ! dqwv(mgs) .ge. 0. + end do +! + do mgs = 1,ngscnt + qitmp(mgs) = qx(mgs,li) + theta(mgs) = thetap(mgs) + theta0(mgs) + temg(mgs) = theta(mgs)*pk(mgs) ! ( pres(mgs) / poo ) ** cap + qvap(mgs) = Max((qwvp(mgs) + qv0(mgs)), 0.0) + temcg(mgs) = temg(mgs) - tfr + tqvcon = temg(mgs)-cbw + ltemq = (temg(mgs)-163.15)/fqsat+1.5 + ltemq = Min( nqsat, Max(1,ltemq) ) + qvs(mgs) = pqs(mgs)*tabqvs(ltemq) + qis(mgs) = pqs(mgs)*tabqis(ltemq) + qx(mgs,lc) = max( 0.0, qx(mgs,lc) ) + qitmp(mgs) = max( 0.0, qitmp(mgs) ) + qx(mgs,lv) = max( 0.0, qvap(mgs)) +! if ( temg(mgs) .lt. tfr ) then +! if( qx(mgs,lc) .ge. 0.0 .and. qitmp(mgs) .le. qxmin(li) ) +! > qss(mgs) = qvs(mgs) +!c if( qx(mgs,lc) .le. qxmin(lc) .and. qitmp(mgs) .gt. qxmin(li)) +! if( qx(mgs,lc) .eq. 0.0 .and. qitmp(mgs) .gt. qxmin(li)) +! > qss(mgs) = qis(mgs) +!c if( qx(mgs,lc) .gt. qxmin(lc) .and. qitmp(mgs) .gt. qxmin(li)) +! if( qx(mgs,lc) .gt. 0.0 .and. qitmp(mgs) .gt. qxmin(li)) +! > qss(mgs) = (qx(mgs,lc)*qvs(mgs) + qitmp(mgs)*qis(mgs)) / +! > (qx(mgs,lc) + qitmp(mgs)) +! else +! qss(mgs) = qvs(mgs) +! end if + qss(mgs) = qvs(mgs) + if ( temg(mgs) .lt. tfr ) then + if( qx(mgs,lc) .ge. 0.0 .and. qitmp(mgs) .le. qxmin(li) ) & + & qss(mgs) = qvs(mgs) + if( qx(mgs,lc) .le. qxmin(lc) .and. qitmp(mgs) .gt. qxmin(li)) & + & qss(mgs) = qis(mgs) + if( qx(mgs,lc) .gt. qxmin(lc) .and. qitmp(mgs) .gt. qxmin(li)) & + & qss(mgs) = (qx(mgs,lc)*qvs(mgs) + qitmp(mgs)*qis(mgs)) / & + & (qx(mgs,lc) + qitmp(mgs)) + end if +! pceds(mgs) = (thetap(mgs) - thsave(mgs))*dtpinv +! write(iunit,*) 'satadj2: mgs,iter = ',mgs,itertd,dqwv(mgs),qss(mgs),qx(mgs,lv),qx(mgs,lc) + end do +! +! end the saturation adjustment iteration loop +! + end do + + ENDIF ! ( ipconc .le. 1 ) + +! +! spread the growth owing to vapor diffusion onto the +! ice crystal categories using the +! +! END OF SATURATION ADJUSTMENT +! + + if (ndebug .gt. 0 ) write(0,*) 'conc 30b' +! +! +! end of saturation adjustment + +! +! +! !DIR$ IVDEP + do mgs = 1,ngscnt + t0(igs(mgs),jy,kgs(mgs)) = temg(mgs) + end do +! +! Load the save arrays +! + + +! Sample code for using the axtra array to load microphysical rates or quantities for output +! +! Note that indices 1 and 2 are used in the nucond subroutine for condensation/evap of droplets (1) and +! condensation of rain (2) +! +! IF ( io_flag .and. nxtra > 1 ) THEN +! DO mgs = 1,ngscnt +! axtra(igs(mgs),jy,kgs(mgs),3) = pfrz(mgs) ! +! axtra(igs(mgs),jy,kgs(mgs),4) = qrcev(mgs) ! pre2 +! axtra(igs(mgs),jy,kgs(mgs),5) = psub(mgs) ! depsubr +! axtra(igs(mgs),jy,kgs(mgs),6) = qrfrz(mgs) ! rain freezing (Bigg) +! axtra(igs(mgs),jy,kgs(mgs),7) = pmlt(mgs) ! melr2 +! ENDDO +! ENDIF + + + + + if (ndebug .gt. 0 ) write(0,*) 'gs 11' + + do mgs = 1,ngscnt +! + an(igs(mgs),jy,kgs(mgs),lt) = & + & theta0(mgs) + thetap(mgs) + an(igs(mgs),jy,kgs(mgs),lv) = qwvp(mgs) + qv0(mgs) ! + + IF ( eqtset > 2 ) THEN + p2(igs(mgs),jy,kgs(mgs)) = pipert(mgs) + ENDIF +! + + DO il = lc,lhab + IF ( ido(il) .eq. 1 ) THEN + IF ( lf > 1 .and. il == lf ) THEN + lfsave(mgs,1) = an(igs(mgs),jy,kgs(mgs),il) + lfsave(mgs,2) = qx(mgs,il) + ENDIF + an(igs(mgs),jy,kgs(mgs),il) = qx(mgs,il) + & + & min( an(igs(mgs),jy,kgs(mgs),il), 0.0 ) + qx(mgs,il) = an(igs(mgs),jy,kgs(mgs),il) + ENDIF + ENDDO + + IF ( lcina > 1 ) THEN + an(igs(mgs),jy,kgs(mgs),lcina) = cina(mgs) + ENDIF + + +! + end do +! + + if ( ipconc .ge. 1 ) then + DO il = lc,lhab !{ + +! write(0,*) 'limiter loop: il,ipc,lz: ',il,ipc(il),lz(il),ipconc + + IF ( ipconc .ge. ipc(il) .and. ido(il) > 0 ) THEN ! { + + IF ( ipconc .ge. 4 .and. ipc(il) .ge. 1 ) THEN ! { + +! write(0,*) 'MY limiter: il,ipc,lz: ',il,ipc(il),lz(il),lr,lzr +! STOP + + IF ( lz(il) <= 1 .or. ioldlimiter == 1 ) THEN ! { { is a two-moment category so dont worry about reflectivity + + + DO mgs = 1,ngscnt + IF ( qx(mgs,il) .le. 0.0 ) THEN + cx(mgs,il) = 0.0 + ELSE !{ + IF ( cx(mgs,il) .gt. cxmin ) THEN !{ +! xv(mgs,il) = rho0(mgs)*qx(mgs,il)/(xdn(mgs,il)*Max(1.0e-9,cx(mgs,il))) +! xv(mgs,il) = rho0(mgs)*qx(mgs,il)/(xdn(mgs,il)*Max(cxmin,cx(mgs,il))) + xv(mgs,il) = rho0(mgs)*qx(mgs,il)/(xdn(mgs,il)*cx(mgs,il)) + +! IF ( lhl .gt. 1 .and. il .eq. lhl ) THEN +! write(0,*) 'dr: xv,cx,qx,xdn,ln = ',xv(mgs,il),cx(mgs,il),qx(mgs,il),xdn(mgs,il),ln(il) +! ENDIF + + ! 8/26/2015 erm: apply imaxdiaopt for 2-moment also + IF ( imaxdiaopt == 1 .or. il == lc .or. il == li .or. (il == lr .and. imurain == 3) .or. & + & (il == ls .and. imusnow == 3 ) ) THEN + xvbarmax = xvmx(il) + ELSEIF ( imaxdiaopt == 2 ) THEN ! test against maximum mass diameter + xvbarmax = xvmx(il) /((3. + alpha(mgs,il))**3/((3. + alpha(mgs,il))*(2. + alpha(mgs,il))*(1. + alpha(mgs,il)))) + ELSEIF ( imaxdiaopt == 3 ) THEN ! test against mass-weighted diameter + xvbarmax = xvmx(il) /((4. + alpha(mgs,il))**3/((3. + alpha(mgs,il))*(2. + alpha(mgs,il))*(1. + alpha(mgs,il)))) + ELSE + xvbarmax = xvmx(il) + ENDIF + + tmp = 1.0 + IF ( il == ls ) THEN + xvbarmax = xvbarmax*Max(1.,100./Min(100.,xdn(mgs,ls))) + ENDIF + + IF ( xv(mgs,il) .lt. xvmn(il) .or. xv(mgs,il) .gt. xvbarmax ) THEN + xv(mgs,il) = Min( xvbarmax, xv(mgs,il) ) + xv(mgs,il) = Max( xvmn(il), xv(mgs,il) ) + cx(mgs,il) = rho0(mgs)*qx(mgs,il)/(xv(mgs,il)*xdn(mgs,il)) + ENDIF + + ENDIF !} + +! IF ( lhl .gt. 1 .and. il .eq. lhl ) THEN +! write(0,*) 'dr: xv,cx,= ',xv(mgs,il),cx(mgs,il) +! ENDIF + + ENDIF !} + ENDDO ! mgs + + + ENDIF ! }} + ENDIF ! } + + DO mgs = 1,ngscnt + + IF ( il == lh ) THEN + IF ( lnhf > 1 ) THEN ! number of graupel from frozen drops + an(igs(mgs),jy,kgs(mgs),lnhf) = Max( chxf(mgs,lh), 0.0) + ENDIF + ENDIF + + IF ( il == lhl ) THEN + + IF ( lnhlf > 1 ) THEN ! number of hail from frozen drops +! an(igs(mgs),jy,kgs(mgs),lnhlf) = Min( cx(mgs,lhl), Max( chxf(mgs,lhl), 0.0) ) + an(igs(mgs),jy,kgs(mgs),lnhlf) = Max( chxf(mgs,lhl), 0.0) + ENDIF + ENDIF + an(igs(mgs),jy,kgs(mgs),ln(il)) = Max(cx(mgs,il), 0.0) + ENDDO + ENDIF ! } + ENDDO ! il } + + IF ( lcin > 1 ) THEN + do mgs = 1,ngscnt + an(igs(mgs),jy,kgs(mgs),lcin) = Max(0.0, ccin(mgs)) + end do + ENDIF + + IF ( ipconc .ge. 2 ) THEN + do mgs = 1,ngscnt + IF ( lss > 1 ) THEN + an(igs(mgs),jy,kgs(mgs),lss) = Max(0.0, ssmax(mgs) ) + ENDIF + + IF ( lccn > 1 ) THEN + an(igs(mgs),jy,kgs(mgs),lccn) = Max(0.0, ccnc(mgs) ) + ENDIF + end do + ENDIF + + ELSEIF ( ipconc .eq. 0 .and. lni .gt. 1 ) THEN + + DO mgs = 1,ngscnt + an(igs(mgs),jy,kgs(mgs),lni) = Max(cx(mgs,li), 0.0) + ENDDO + + + end if + + IF ( ldovol ) THEN + + DO il = li,lhab + + IF ( lvol(il) .ge. 1 ) THEN + + DO mgs = 1,ngscnt + + an(igs(mgs),jy,kgs(mgs),lvol(il)) = Max( 0.0, vx(mgs,il) ) + ENDDO + + ENDIF + + ENDDO + + ENDIF +! +! +! +! +! + if (ndebug .gt. 0 ) write(0,*) 'gs 12' + + + + if (ndebug .gt. 0 ) write(0,*) 'gs 13' + + 9998 continue + + if ( kz .gt. nz-1 .and. ix .ge. itile) then + if ( ix .ge. itile ) then + go to 1200 ! exit gather scatter + else + nzmpb = kz + endif + else + nzmpb = kz + end if + + if ( ix .ge. itile ) then + nxmpb = 1 + nzmpb = kz+1 + else + nxmpb = ix+1 + end if + + 1000 continue + 1200 continue +! +! end of gather scatter (for this jy slice) +! +! + + return + end subroutine nssl_2mom_gs +! +!-------------------------------------------------------------------------- +! + + + +! +!-------------------------------------------------------------------------- +! + + +END MODULE module_mp_nssl_2mom diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/module_mp_thompson.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/module_mp_thompson.F90 index 28367d77e..2c5f9a96b 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/module_mp_thompson.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/module_mp_thompson.F90 @@ -67,7 +67,7 @@ MODULE module_mp_thompson private - public thompson_init, mp_gt_driver + public thompson_init, mp_gt_driver, calc_refl10cm LOGICAL, PARAMETER, PRIVATE:: iiwarm = .false. LOGICAL, PRIVATE:: is_aerosol_aware = .false. @@ -1649,12 +1649,12 @@ SUBROUTINE mp_gt_driver(qv, qc, qr, qi, qs, qg, ni, nr, nc, & endif ! if (present(vt_dbz_wt)) then - call calc_refl10cm (qv1d, qc1d, qr1d, nr1d, qs1d, qg1d, & + call calc_refl10cm (qv1d, qr1d, nr1d, qs1d, qg1d, & t1d, p1d, dBZ, rand1, kts, kte, i, j, & melti, vt_dbz_wt(i,:,j), & first_time_step) else - call calc_refl10cm (qv1d, qc1d, qr1d, nr1d, qs1d, qg1d, & + call calc_refl10cm (qv1d, qr1d, nr1d, qs1d, qg1d, & t1d, p1d, dBZ, rand1, kts, kte, i, j, & melti) end if @@ -1955,7 +1955,7 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & REAL:: dtsave, odts, odt, odzq, hgt_agl, SR REAL:: xslw1, ygra1, zans1, eva_factor REAL:: av_i - INTEGER:: i, k, k2, n, nn, nstep, k_0, kbot, IT, iexfrq + INTEGER:: i, k, k2, n, nn, nstep, k_0, IT, iexfrq INTEGER, DIMENSION(5):: ksed1 INTEGER:: nir, nis, nig, nii, nic, niin INTEGER:: idx_tc, idx_t, idx_s, idx_g1, idx_g, idx_r1, idx_r, & @@ -5859,9 +5859,9 @@ end subroutine calc_effectRad !! of frozen species remaining from what initially existed at the !! melting level interface. - subroutine calc_refl10cm (qv1d, qc1d, qr1d, nr1d, qs1d, qg1d, & + subroutine calc_refl10cm (qv1d, qr1d, nr1d, qs1d, qg1d, & t1d, p1d, dBZ, rand1, kts, kte, ii, jj, melti, & - vt_dBZ, first_time_step) + vt_dBZ, first_time_step, ktopin, kbotin) IMPLICIT NONE @@ -5869,17 +5869,18 @@ subroutine calc_refl10cm (qv1d, qc1d, qr1d, nr1d, qs1d, qg1d, & INTEGER, INTENT(IN):: kts, kte, ii, jj REAL, INTENT(IN):: rand1 REAL, DIMENSION(kts:kte), INTENT(IN):: & - qv1d, qc1d, qr1d, nr1d, qs1d, qg1d, t1d, p1d + qv1d, qr1d, nr1d, qs1d, qg1d, t1d, p1d REAL, DIMENSION(kts:kte), INTENT(INOUT):: dBZ REAL, DIMENSION(kts:kte), OPTIONAL, INTENT(INOUT):: vt_dBZ LOGICAL, OPTIONAL, INTENT(IN) :: first_time_step + INTEGER, OPTIONAL, INTENT(IN) :: ktopin, kbotin !..Local variables LOGICAL :: do_vt_dBZ LOGICAL :: allow_wet_graupel LOGICAL :: allow_wet_snow REAL, DIMENSION(kts:kte):: temp, pres, qv, rho, rhof - REAL, DIMENSION(kts:kte):: rc, rr, nr, rs, rg + REAL, DIMENSION(kts:kte):: rr, nr, rs, rg DOUBLE PRECISION, DIMENSION(kts:kte):: ilamr, ilamg, N0_r, N0_g REAL, DIMENSION(kts:kte):: mvd_r @@ -5894,7 +5895,7 @@ subroutine calc_refl10cm (qv1d, qc1d, qr1d, nr1d, qs1d, qg1d, & REAL:: a_, b_, loga_, tc0, SR DOUBLE PRECISION:: fmelt_s, fmelt_g - INTEGER:: i, k, k_0, kbot, n + INTEGER:: i, k, k_0, ktop, kbot, kdwn, n LOGICAL, INTENT(IN):: melti LOGICAL, DIMENSION(kts:kte):: L_qr, L_qs, L_qg @@ -5902,6 +5903,20 @@ subroutine calc_refl10cm (qv1d, qc1d, qr1d, nr1d, qs1d, qg1d, & REAL:: xslw1, ygra1, zans1 !+---+ + if (present(ktopin) .and. present(kbotin)) then + ktop=ktopin + kbot=kbotin + if (ktop < kbot) then + kdwn= 1 + else + kdwn=-1 + endif + else + ktop=kte + kbot=kts + kdwn=-1 + endif + if (present(vt_dBZ) .and. present(first_time_step)) then do_vt_dBZ = .true. if (first_time_step) then @@ -5930,7 +5945,6 @@ subroutine calc_refl10cm (qv1d, qc1d, qr1d, nr1d, qs1d, qg1d, & pres(k) = p1d(k) rho(k) = 0.622*pres(k)/(R*temp(k)*(qv(k)+0.622)) rhof(k) = SQRT(RHO_NOT/rho(k)) - rc(k) = MAX(R1, qc1d(k)*rho(k)) if (qr1d(k) .gt. R1) then rr(k) = qr1d(k)*rho(k) nr(k) = MAX(R2, nr1d(k)*rho(k)) @@ -6028,7 +6042,7 @@ subroutine calc_refl10cm (qv1d, qc1d, qr1d, nr1d, qs1d, qg1d, & !+---+-----------------------------------------------------------------+ if (ANY(L_qg .eqv. .true.)) then - do k = kte, kts, -1 + do k = ktop, kbot, kdwn ygra1 = alog10(max(1.E-9, rg(k))) zans1 = 3.4 + 2./7.*(ygra1+8.) + rand1 N0_exp = 10.**(zans1) @@ -6043,12 +6057,16 @@ subroutine calc_refl10cm (qv1d, qc1d, qr1d, nr1d, qs1d, qg1d, & !+---+-----------------------------------------------------------------+ !..Locate K-level of start of melting (k_0 is level above). !+---+-----------------------------------------------------------------+ - k_0 = kts + k_0 = kbot if ( melti ) then - K_LOOP:do k = kte-1, kts, -1 + K_LOOP:do k = ktop+kdwn, kbot, kdwn if ((temp(k).gt.273.15) .and. L_qr(k) & - & .and. (L_qs(k+1).or.L_qg(k+1)) ) then - k_0 = MAX(k+1, k_0) + & .and. (L_qs(k-kdwn).or.L_qg(k-kdwn)) ) then + if (kdwn < 0) then + k_0 = MAX(k-kdwn, k_0) + else + k_0 = MIN(k-kdwn, k_0) + endif EXIT K_LOOP endif enddo K_LOOP @@ -6080,7 +6098,7 @@ subroutine calc_refl10cm (qv1d, qc1d, qr1d, nr1d, qs1d, qg1d, & !+---+-----------------------------------------------------------------+ if (.not. iiwarm .and. melti .and. k_0.ge.2) then - do k = k_0-1, kts, -1 + do k = k_0+kdwn, kbot, kdwn !..Reflectivity contributed by melting snow if (allow_wet_snow .and. L_qs(k) .and. L_qs(k_0) ) then @@ -6128,13 +6146,13 @@ subroutine calc_refl10cm (qv1d, qc1d, qr1d, nr1d, qs1d, qg1d, & enddo endif - do k = kte, kts, -1 + do k = ktop, kbot, kdwn dBZ(k) = 10.*log10((ze_rain(k)+ze_snow(k)+ze_graupel(k))*1.d18) enddo !..Reflectivity-weighted terminal velocity (snow, rain, graupel, mix). if (do_vt_dBZ) then - do k = kte, kts, -1 + do k = ktop, kbot, kdwn vt_dBZ(k) = 1.E-3 if (rs(k).gt.R2) then Mrat = smob(k) / smoc(k) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/mp_nssl.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/mp_nssl.F90 new file mode 100644 index 000000000..91406bcf4 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/mp_nssl.F90 @@ -0,0 +1,807 @@ +!>\file mp_nssl.F90 +!! This file contains NSSL 2-moment MP scheme. + + +!>\defgroup nsslmp NSSL MP Module +!! This module contains the front end to NSSL microphysics scheme. +module mp_nssl + + use module_mp_nssl_2mom, only : nssl_2mom_init, nssl_2mom_driver + + implicit none + + public :: mp_nssl_init, mp_nssl_run + + private + logical :: is_initialized = .False. + real :: nssl_qccn + integer, parameter :: kind_phys=4 + + contains + +!>\ingroup nsslmp +!> This subroutine is a wrapper around the nssl_2mom_init(). +!>@{ +!> \section arg_table_mp_nssl_init Argument Table +!! \htmlinclude mp_nssl_init.html +!! + subroutine mp_nssl_init(ncol, nlev, errflg, errmsg, threads, restart, & + mpirank, mpiroot, & + con_g, con_rd, con_cp, con_rv, & + con_t0c, con_cliq, con_csol, con_eps, & + imp_physics, imp_physics_nssl, & + nssl_cccn, nssl_alphah, nssl_alphahl, & + nssl_alphar, nssl_ehw0, nssl_ehlw0, & + nssl_ccn_on, nssl_hail_on, nssl_invertccn ) + + + use module_mp_nssl_2mom, only: nssl_2mom_init, nssl_2mom_init_const + + implicit none + + integer, intent(in) :: ncol + integer, intent(in) :: nlev + character(len=*), intent( out) :: errmsg + integer, intent( out) :: errflg + integer, intent(in) :: threads + logical, intent(in) :: restart + real(kind_phys), intent(in) :: con_g, con_rd, con_cp, con_rv, & + con_t0c, con_cliq, con_csol, con_eps + + integer, intent(in) :: mpirank + integer, intent(in) :: mpiroot + integer, intent(in) :: imp_physics + integer, intent(in) :: imp_physics_nssl + real(kind_phys), intent(in) :: nssl_cccn, nssl_alphah, nssl_alphahl + real(kind_phys), intent(in) :: nssl_alphar, nssl_ehw0, nssl_ehlw0 + logical, intent(in) :: nssl_ccn_on, nssl_hail_on, nssl_invertccn + + ! Local variables: dimensions used in nssl_init + integer :: ims,ime, jms,jme, kms,kme, nx, nz, i,k + real :: nssl_params(20) + integer :: ihailv + + + ! Initialize the CCPP error handling variables + errflg = 0 + errmsg = '' + +! write(0,*) 'nssl_init: nlev,ncol,rank = ',nlev,ncol,mpirank + + if ( is_initialized ) return + + IF ( .not. is_initialized ) THEN ! only do this on first call + if (mpirank==mpiroot) then + write(0,*) ' ----------------------------------------------------------------------------------------------------------------' + write(0,*) ' --- CCPP NSSL MP scheme init ---' + write(0,*) ' ----------------------------------------------------------------------------------------------------------------' + write(6,*) ' ----------------------------------------------------------------------------------------------------------------' + write(6,*) ' --- CCPP NSSL MP scheme init ---' + write(6,*) ' ----------------------------------------------------------------------------------------------------------------' + end if + +! update this when ccn_flag is active? + if ( imp_physics /= imp_physics_nssl ) then + write(errmsg,'(*(a))') "Logic error: namelist choice of microphysics is different from NSSL" + errflg = 1 + return + end if + + ! set some physical constants in NSSL microphysics to be consistent with parent model + call nssl_2mom_init_const( & + con_g, con_rd, con_cp, con_rv, con_t0c, con_cliq, con_csol, con_eps ) + + + ! Set internal dimensions + ims = 1 + ime = ncol + nx = ncol + jms = 1 + jme = 1 + kms = 1 + kme = nlev + nz = nlev + + + nssl_params(:) = 0.0 + nssl_params(1) = nssl_cccn + nssl_params(2) = nssl_alphah + nssl_params(3) = nssl_alphahl + nssl_params(4) = 4.e5 ! nssl_cnoh -- not used for 2-moment + nssl_params(5) = 4.e4 ! nssl_cnohl-- not used for 2-moment + nssl_params(6) = 4.e5 ! nssl_cnor-- not used for 2-moment + nssl_params(7) = 4.e6 ! nssl_cnos-- not used for 2-moment + nssl_params(8) = 500. ! nssl_rho_qh + nssl_params(9) = 800. ! nssl_rho_qhl + nssl_params(10) = 100. ! nssl_rho_qs + nssl_params(11) = 0 ! nssl_ipelec_tmp + nssl_params(12) = 11 ! nssl_isaund + nssl_params(13) = 0 ! 1= turn on cccna; 0 = turn off + nssl_params(15) = nssl_alphar + + nssl_qccn = nssl_cccn/1.225 + ! if (mpirank==mpiroot) then + ! write(*,*) 'nssl_init: nssl_qccn = ',nssl_qccn + ! endif + + IF ( nssl_hail_on ) THEN + ihailv = 1 + ELSE + ihailv = -1 + ENDIF + +! write(0,*) 'call nssl_2mom_init' + CALL nssl_2mom_init(ims,ime, jms,jme, kms,kme,nssl_params,ipctmp=5,mixphase=0, & + ihvol=ihailv,nssl_ehw0=nssl_ehw0,nssl_ehlw0=nssl_ehlw0,errmsg=errmsg,errflg=errflg,myrank=mpirank,mpiroot=mpiroot) + + ! For restart runs, the init is done here + if (restart) then + is_initialized = .true. + return + end if + +! Other initialization operation here.... + + is_initialized = .true. + + ENDIF ! .not. is_initialized + + return + + end subroutine mp_nssl_init +!>@} + +!>\ingroup nsslmp +!>\section gen_nssl NSSL MP General Algorithm: interface to driver +!>@{ +!> \section arg_table_mp_nssl_run Argument Table +!! \htmlinclude mp_nssl_run.html +!! + subroutine mp_nssl_run(ncol, nlev, con_g, con_rd, mpirank, & +! spechum, cccn, qc, qr, qi, qs, qh, qhl, & + spechum, cccn, cccna, qc, qr, qi, qs, qh, qhl, & + ccw, crw, cci, csw, chw, chl, vh, vhl, & + tgrs, prslk, prsl, phii, omega, dtp, & + prcp, rain, graupel, ice, snow, sr, & + refl_10cm, do_radar_ref, first_time_step, restart, & + re_cloud, re_ice, re_snow, re_rain, & + nleffr, nieffr, nseffr, nreffr, & + imp_physics, convert_dry_rho, & + imp_physics_nssl, nssl_ccn_on, & + nssl_hail_on, nssl_invertccn, ntccn, ntccna, & + errflg, errmsg) + + use module_mp_nssl_2mom, only: calcnfromq, na + + implicit none + integer, intent(in) :: ncol, nlev + real(kind_phys), intent(in ) :: con_g + real(kind_phys), intent(in ) :: con_rd + integer, intent(in) :: mpirank + ! Hydrometeors + logical, intent(in ) :: convert_dry_rho + real(kind_phys), intent(inout) :: spechum(:,:) !(1:ncol,1:nlev) + real(kind_phys), intent(inout) :: cccn(:,:) !(1:ncol,1:nlev) + real(kind_phys), intent(inout) :: cccna(:,:) !(1:ncol,1:nlev) + real(kind_phys), intent(inout) :: qc (:,:) !(1:ncol,1:nlev) + real(kind_phys), intent(inout) :: qr (:,:) !(1:ncol,1:nlev) + real(kind_phys), intent(inout) :: qi (:,:) !(1:ncol,1:nlev) + real(kind_phys), intent(inout) :: qs (:,:) !(1:ncol,1:nlev) + real(kind_phys), intent(inout) :: qh (:,:) !(1:ncol,1:nlev) graupel + real(kind_phys), intent(inout) :: qhl(:,:) !(1:ncol,1:nlev) hail + real(kind_phys), intent(inout) :: ccw(:,:) !(1:ncol,1:nlev) + real(kind_phys), intent(inout) :: crw(:,:) !(1:ncol,1:nlev) + real(kind_phys), intent(inout) :: cci(:,:) !(1:ncol,1:nlev) + real(kind_phys), intent(inout) :: csw(:,:) !(1:ncol,1:nlev) + real(kind_phys), intent(inout) :: chw(:,:) !(1:ncol,1:nlev) graupel number + real(kind_phys), intent(inout) :: chl(:,:) !(1:ncol,1:nlev) hail number + real(kind_phys), intent(inout) :: vh (:,:) !(1:ncol,1:nlev) graupel volume + real(kind_phys), intent(inout) :: vhl(:,:) !(1:ncol,1:nlev) hail volume + ! State variables and timestep information + real(kind_phys), intent(inout) :: tgrs (:,:) !(1:ncol,1:nlev) + real(kind_phys), intent(in ) :: prsl (:,:) !(1:ncol,1:nlev) + real(kind_phys), intent(in ) :: prslk(:,:) !(1:ncol,1:nlev) + real(kind_phys), intent(in ) :: phii (:,:) !(1:ncol,1:nlev+1) + real(kind_phys), intent(in ) :: omega(:,:) !(1:ncol,1:nlev) + real(kind_phys), intent(in ) :: dtp + ! Precip/rain/snow/graupel fall amounts and fraction of frozen precip + real(kind_phys), intent( out) :: prcp (:) !(1:ncol) + real(kind_phys), intent( out) :: rain (:) !(1:ncol) + real(kind_phys), intent( out) :: graupel(:) !(1:ncol) + real(kind_phys), intent( out) :: ice (:) !(1:ncol) + real(kind_phys), intent( out) :: snow (:) !(1:ncol) + real(kind_phys), intent( out) :: sr (:) !(1:ncol) + ! Radar reflectivity + real(kind_phys), intent(inout) :: refl_10cm(:,:) !(1:ncol,1:nlev) + logical, intent(in ) :: do_radar_ref, first_time_step + logical, intent(in) :: restart + ! Cloud effective radii + real(kind_phys), intent(inout) :: re_cloud(:,:) ! (1:ncol,1:nlev) + real(kind_phys), intent(inout) :: re_ice(:,:) ! (1:ncol,1:nlev) + real(kind_phys), intent(inout) :: re_snow(:,:) ! (1:ncol,1:nlev) + real(kind_phys), intent(inout) :: re_rain(:,:) ! (1:ncol,1:nlev) + integer, intent(in) :: nleffr, nieffr, nseffr, nreffr + integer, intent(in) :: imp_physics + integer, intent(in) :: imp_physics_nssl + logical, intent(in) :: nssl_ccn_on, nssl_hail_on, nssl_invertccn + integer, intent(in) :: ntccn, ntccna + + integer, intent(out) :: errflg + character(len=*), intent(out) :: errmsg + + + ! Local variables + + ! Air density + real(kind_phys) :: rho(1:ncol,1:nlev) !< kg m-3 + ! Hydrometeors + real(kind_phys) :: qv_mp(1:ncol,1:nlev) !< kg kg-1 (dry mixing ratio) + real(kind_phys) :: qc_mp(1:ncol,1:nlev) !< kg kg-1 (dry mixing ratio) + real(kind_phys) :: qr_mp(1:ncol,1:nlev) !< kg kg-1 (dry mixing ratio) + real(kind_phys) :: qi_mp(1:ncol,1:nlev) !< kg kg-1 (dry mixing ratio) + real(kind_phys) :: qs_mp(1:ncol,1:nlev) !< kg kg-1 (dry mixing ratio) + real(kind_phys) :: qh_mp(1:ncol,1:nlev) !< kg kg-1 (graupel dry mixing ratio) + real(kind_phys) :: qhl_mp(1:ncol,1:nlev) !< kg kg-1 (hail dry mixing ratio) + real(kind_phys) :: nc_mp(1:ncol,1:nlev) !< droplet num. conc. + real(kind_phys) :: nr_mp(1:ncol,1:nlev) !< rain num. conc. + real(kind_phys) :: ni_mp(1:ncol,1:nlev) !< ice crystal num. conc. + real(kind_phys) :: ns_mp(1:ncol,1:nlev) !< snow num. conc. + real(kind_phys) :: nh_mp(1:ncol,1:nlev) !< graupel num. conc. + real(kind_phys) :: nhl_mp(1:ncol,1:nlev) !< hail num. conc. + real(kind_phys) :: cn_mp(1:ncol,1:nlev) + real(kind_phys) :: cna_mp(1:ncol,1:nlev) + real(kind_phys) :: cccn_mp(1:ncol,1:nlev) + real(kind_phys) :: cccna_mp(1:ncol,1:nlev) + real(kind_phys) :: vh_mp(1:ncol,1:nlev) !< m3 kg-1 (volume mixing ratio) + ! create temporaries for hail in case it does not exist + !real(kind_phys) :: chl_mp(1:ncol,1:nlev) !< kg-1 (number mixing ratio) + real(kind_phys) :: vhl_mp(1:ncol,1:nlev) !< m3 kg-1 (volume mixing ratio) + ! Vertical velocity and level width + real(kind_phys) :: w(1:ncol,1:nlev) !< m s-1 + real(kind_phys) :: dz(1:ncol,1:nlev) !< m + + ! Rain/snow/graupel fall amounts + real(kind_phys) :: rain_mp(1:ncol) ! mm, dummy, not used + real(kind_phys) :: graupel_mp(1:ncol) ! mm, dummy, not used + real(kind_phys) :: ice_mp(1:ncol) ! mm, dummy, not used + real(kind_phys) :: snow_mp(1:ncol) ! mm, dummy, not used + real(kind_phys) :: delta_rain_mp(1:ncol) ! mm + real(kind_phys) :: delta_graupel_mp(1:ncol) ! mm + real(kind_phys) :: delta_ice_mp(1:ncol) ! mm + real(kind_phys) :: delta_snow_mp(1:ncol) ! mm + + real(kind_phys) :: xrain_mp(1:ncol) ! mm, dummy, not used + real(kind_phys) :: xgraupel_mp(1:ncol) ! mm, dummy, not used + real(kind_phys) :: xice_mp(1:ncol) ! mm, dummy, not used + real(kind_phys) :: xsnow_mp(1:ncol) ! mm, dummy, not used + real(kind_phys) :: xdelta_rain_mp(1:ncol) ! mm + real(kind_phys) :: xdelta_graupel_mp(1:ncol) ! mm + real(kind_phys) :: xdelta_ice_mp(1:ncol) ! mm + real(kind_phys) :: xdelta_snow_mp(1:ncol) ! mm + + ! Radar reflectivity + logical :: diagflag ! must be true if do_radar_ref is true, not used otherwise + integer :: do_radar_ref_mp ! integer instead of logical do_radar_ref + ! Effective cloud radii + logical :: do_effective_radii + real(kind_phys) :: re_cloud_mp(1:ncol,1:nlev) ! m + real(kind_phys) :: re_ice_mp(1:ncol,1:nlev) ! m + real(kind_phys) :: re_snow_mp(1:ncol,1:nlev) ! m + real(kind_phys) :: re_rain_mp(1:ncol,1:nlev) ! m + integer :: has_reqc + integer :: has_reqi + integer :: has_reqs + integer :: has_reqr + ! Dimensions used in driver + integer :: ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte, i,j,k + integer :: itimestep ! timestep counter + integer :: ntmul, n + real, parameter :: dtpmax = 60. ! allow up to dt=75 (1.25*60) + real(kind_phys) :: dtptmp + integer, parameter :: ndebug = 0 + logical :: invertccn + real :: cwmas + + real(kind_phys), allocatable :: an(:,:,:,:) ! temporary scalar array + + + errflg = 0 + errmsg = '' + +! write(0,*) 'nssl_run: nlev,ncol,rank = ',nlev,ncol,mpirank + + IF ( ndebug >= 1 ) write(0,*) 'In physics nssl_run' + + + ! Check initialization state + if (.not.is_initialized) then + write(errmsg, fmt='((a))') 'mp_nssl_run called before mp_nssl_init' + errflg = 1 + return + end if + + invertccn = nssl_invertccn + + !> - Convert specific humidity/moist mixing ratios to dry mixing ratios + ! NOTE: Implied loops! + qv_mp = spechum/(1.0_kind_phys-spechum) + IF ( convert_dry_rho ) THEN + qc_mp = qc/(1.0_kind_phys-spechum) + qr_mp = qr/(1.0_kind_phys-spechum) + qi_mp = qi/(1.0_kind_phys-spechum) + qs_mp = qs/(1.0_kind_phys-spechum) + qh_mp = qh/(1.0_kind_phys-spechum) + + IF ( nssl_ccn_on ) cccn_mp = cccn/(1.0_kind_phys-spechum) +! cccna_mp = cccna/(1.0_kind_phys-spechum) + nc_mp = ccw/(1.0_kind_phys-spechum) + nr_mp = crw/(1.0_kind_phys-spechum) + ni_mp = cci/(1.0_kind_phys-spechum) + ns_mp = csw/(1.0_kind_phys-spechum) + nh_mp = chw/(1.0_kind_phys-spechum) + vh_mp = vh/(1.0_kind_phys-spechum) + IF ( nssl_hail_on ) THEN + qhl_mp = qhl/(1.0_kind_phys-spechum) + nhl_mp = chl/(1.0_kind_phys-spechum) + vhl_mp = vhl/(1.0_kind_phys-spechum) + ENDIF + ELSE +! qv_mp = spechum ! /(1.0_kind_phys-spechum) + qc_mp = qc ! /(1.0_kind_phys-spechum) + qr_mp = qr ! /(1.0_kind_phys-spechum) + qi_mp = qi ! /(1.0_kind_phys-spechum) + qs_mp = qs ! /(1.0_kind_phys-spechum) + qh_mp = qh ! /(1.0_kind_phys-spechum) + IF ( nssl_ccn_on ) cccn_mp = cccn +! cccna_mp = cccna + nc_mp = ccw + nr_mp = crw + ni_mp = cci + ns_mp = csw + nh_mp = chw + IF ( nssl_hail_on ) THEN + qhl_mp = qhl ! /(1.0_kind_phys-spechum) + nhl_mp = chl + vhl_mp = vhl + ENDIF + + ENDIF + + IF ( nssl_hail_on ) THEN +! nhl_mp = chl +! vhl_mp = vhl + ELSE + qhl_mp = 0 + nhl_mp = 0 + vhl_mp = 0 + ENDIF + + IF ( .false. ) THEN + write(6,*) 'nsslrun: qc,max ccw = ',mpirank,maxval(qc_mp),maxval(nc_mp),sum(nc_mp) + IF ( mpirank == 1 ) THEN + DO k=1,nlev + DO i=1,ncol + IF ( qc_mp(i,k) > 1.e-6 .and. nc_mp(i,k) <= 1.e-9 ) THEN + write(6,*) 'i,k,qc,nc,ccn = ',i,k,qc_mp(i,k),nc_mp(i,k),cccn_mp(i,k) + ENDIF + ENDDO + ENDDO + ENDIF + ENDIF + + ! IF ( first_time_step ) THEN + ! write(0,*) 'mp_nssl_run: qi,qs,qh maxval: ',maxval(qi),maxval(qs),maxval(qh) + ! write(0,*) 'mp_nssl_run: ni,ns,nh maxval: ',maxval(ni_mp),maxval(ns_mp),maxval(nh_mp) + ! ENDIF + + + !> - Density of air in kg m-3 + rho = prsl/(con_rd*tgrs) + + !> - Convert omega in Pa s-1 to vertical velocity w in m s-1 + w = -omega/(rho*con_g) + + !> - Layer thickness in m from geopotential in m2 s-2 + dz = (phii(:,2:nlev+1) - phii(:,1:nlev)) / con_g + + ! Accumulated values inside scheme, not used; + ! only use delta and add to inout variables (different units) + rain_mp = 0 + graupel_mp = 0 + ice_mp = 0 + snow_mp = 0 + delta_rain_mp = 0 + delta_graupel_mp = 0 + delta_ice_mp = 0 + delta_snow_mp = 0 + xrain_mp = 0 + xgraupel_mp = 0 + xice_mp = 0 + xsnow_mp = 0 + xdelta_rain_mp = 0 + xdelta_graupel_mp = 0 + xdelta_ice_mp = 0 + xdelta_snow_mp = 0 + IF ( ndebug > 1 ) THEN + write(*,*) 'Max q before micro' + write(*,*) 'qc = ',1000.*maxval(qc_mp) + write(*,*) 'qr = ',1000.*maxval(qr_mp) + write(*,*) 'qi = ',1000.*maxval(qi_mp) + write(*,*) 'qs = ',1000.*maxval(qs_mp) + write(*,*) 'qh = ',1000.*maxval(qh_mp) + IF ( nssl_hail_on ) write(*,*) 'qhl = ',1000.*maxval(qhl_mp) + write(*,*) 'ccw = ',1.e-6*maxval(ccw*rho) + ENDIF + + ! Flags for calculating radar reflectivity; diagflag is redundant + if (do_radar_ref) then + diagflag = .true. + do_radar_ref_mp = 1 + else + diagflag = .false. + do_radar_ref_mp = 0 + end if + + do_effective_radii = .false. + IF ( nleffr > 0 .and. nieffr > 0 .and. nseffr > 0 .and. nreffr > 0 ) THEN + ! if (present(re_cloud) .and. present(re_ice) .and. present(re_snow)) then + do_effective_radii = .true. + has_reqc = 1 + has_reqi = 1 + has_reqs = 1 + has_reqr = 1 + else if (nleffr < 1 .and. nieffr < 1 .and. nseffr < 1 .and. nreffr < 1 ) then + do_effective_radii = .false. + has_reqc = 0 + has_reqi = 0 + has_reqs = 0 + has_reqr = 0 + else + write(errmsg,fmt='(*(a))') 'Logic error in mp_nssl_run:', & + ' hydrometeor radius calculation logic problem' + errflg = 1 + return + end if + ! Initialize to zero, intent(out) variables + re_cloud_mp = 0 + re_ice_mp = 0 + re_snow_mp = 0 + re_rain_mp = 0 + + ! Set internal dimensions + ids = 1 + ims = 1 + its = 1 + ide = ncol + ime = ncol + ite = ncol + jds = 1 + jms = 1 + jts = 1 + jde = 1 + jme = 1 + jte = 1 + kds = 1 + kms = 1 + kts = 1 + kde = nlev + kme = nlev + kte = nlev + + + IF ( ndebug >= 1 ) write(0,*) 'call nssl_2mom_driver' + + IF ( dtp > 1.25001*dtpmax ) THEN + ntmul = Max(2, Nint( dtp/dtpmax ) ) + dtptmp = dtp/ntmul + ELSE + dtptmp = dtp + ntmul = 1 + ENDIF + + IF ( first_time_step .and. .not. restart ) THEN + itimestep = 0 ! gets incremented to 1 in call loop + IF ( nssl_ccn_on ) THEN + IF ( invertccn ) THEN + cccn_mp = 0 + !cccn = nssl_qccn + ELSE + cccn_mp = nssl_qccn + ENDIF + ENDIF + ELSE + itimestep = 2 + ENDIF + + IF ( .false. ) THEN ! disable for now, as logic in the NSSL driver does this, but may switch back to here + ! incoming droplet field may have some inconsistent number concentrations (e.g., from PBL) + ! so check for that, otherwise mass may be zapped into vapor + allocate( an(ncol,1,nlev,na) ) + an(:,:,:,:) = 0.0 ! needed for workspace in routine + + cwmas = 1000.*0.523599*(2.*9.e-6)**3 + + call calcnfromq(nx=ncol,ny=1,nz=nlev,an=an,na=na,nor=0,norz=0,dn=rho, & + & qcw=qc_mp,qci=qi_mp, & + & ccw=nc_mp,cci=ni_mp, & + & cccn=cccn_mp,qv=qv_mp, invertccn_flag=nssl_invertccn, cwmasin=cwmas ) + + IF ( .false. ) THEN + write(6,*) 'nsslrun2: qc,max ccw = ',mpirank,maxval(qc_mp),maxval(nc_mp),sum(nc_mp) + IF ( mpirank == 1 ) THEN + DO k=1,nlev + DO i=1,ncol + IF ( qc_mp(i,k) > 1.e-6 .and. nc_mp(i,k) <= 1.e-9 ) THEN + write(6,*) 'i2,k,qc,nc,ccn = ',i,k,qc_mp(i,k),nc_mp(i,k),cccn_mp(i,k) + ENDIF + ENDDO + ENDDO + ENDIF + ENDIF + + + deallocate( an ) + ENDIF + + IF ( nssl_ccn_on ) THEN + IF ( invertccn ) THEN + ! cn_mp = Max(0.0, nssl_qccn - Max(0.0,cccn_mp)) + ! Flip CCN concentrations from 'activated' to 'unactivated' (allows BC condition to be zero) + cn_mp = nssl_qccn - cccn_mp + cn_mp = Max(0.0_kind_phys, cn_mp) + + ELSE + cn_mp = cccn_mp + ENDIF + IF ( ntccna > 0 ) THEN + ! not in use yet +! cna_mp = cccna + ELSE + cna_mp = 0 + ENDIF + ENDIF + + IF ( .true. ) THEN + DO n = 1,ntmul + + itimestep = itimestep + 1 + + + + IF ( nssl_ccn_on ) THEN + + + CALL nssl_2mom_driver( & + ITIMESTEP=itimestep, & + ! TH=th, & + tt=tgrs, & + QV=qv_mp, & + QC=qc_mp, & + QR=qr_mp, & + QI=qi_mp, & + QS=qs_mp, & + QH=qh_mp, & + QHL=qhl_mp, & + CCW=nc_mp, & + CRW=nr_mp, & + CCI=ni_mp, & + CSW=ns_mp, & + CHW=nh_mp, & + CHL=nhl_mp, & + VHW=vh_mp, & + VHL=vhl_mp, & + cn=cn_mp, & +! cna=cna_mp, f_cna=( ntccna > 0 ), & ! for future use + cna=cna_mp, f_cna=.false. , & + PII=prslk, & + P=prsl, & + W=w, & + DZ=dz, & + DTP=dtptmp, & + DN=rho, & + rainnc=xrain_mp, rainncv=xdelta_rain_mp, & + snownc=xsnow_mp, snowncv=xdelta_snow_mp, & +! icenc=ice_mp, icencv=delta_ice_mp, & + GRPLNC=xgraupel_mp, GRPLNCV=xdelta_graupel_mp, sr=sr, & + dbz = refl_10cm, & +! nssl_progn=.false., & + diagflag = diagflag, & + errmsg=errmsg,errflg=errflg, & + re_cloud=re_cloud_mp, & + re_ice=re_ice_mp, & + re_snow=re_snow_mp, & + re_rain=re_rain_mp, & + has_reqc=has_reqc, & ! ala G. Thompson + has_reqi=has_reqi, & ! ala G. Thompson + has_reqs=has_reqs, & ! ala G. Thompson + has_reqr=has_reqr, & + IDS=ids,IDE=ide, JDS=jds,JDE=jde, KDS=kds,KDE=kde, & + IMS=ims,IME=ime, JMS=jms,JME=jme, KMS=kms,KME=kme, & + ITS=its,ITE=ite, JTS=jts,JTE=jte, KTS=kts,KTE=kte & + ) + + + ELSE + + CALL nssl_2mom_driver( & + ITIMESTEP=itimestep, & + ! TH=th, & + tt=tgrs, & + QV=qv_mp, & + QC=qc_mp, & + QR=qr_mp, & + QI=qi_mp, & + QS=qs_mp, & + QH=qh_mp, & + QHL=qhl_mp, & +! CCW=qnc_mp, & + CCW=nc_mp, & + CRW=nr_mp, & + CCI=ni_mp, & + CSW=ns_mp, & + CHW=nh_mp, & + CHL=nhl_mp, & + VHW=vh_mp, & + VHL=vhl_mp, & + ! cn=cccn, & + PII=prslk, & + P=prsl, & + W=w, & + DZ=dz, & + DTP=dtptmp, & + DN=rho, & + rainnc=xrain_mp, rainncv=xdelta_rain_mp, & + snownc=xsnow_mp, snowncv=xdelta_snow_mp, & +! icenc=ice_mp, icencv=delta_ice_mp, & + GRPLNC=xgraupel_mp, GRPLNCV=xdelta_graupel_mp, sr=sr, & + dbz = refl_10cm, & +! nssl_progn=.false., & + diagflag = diagflag, & + errmsg=errmsg,errflg=errflg, & + re_cloud=re_cloud_mp, & + re_ice=re_ice_mp, & + re_snow=re_snow_mp, & + re_rain=re_rain_mp, & + has_reqc=has_reqc, & ! ala G. Thompson + has_reqi=has_reqi, & ! ala G. Thompson + has_reqs=has_reqs, & ! ala G. Thompson + has_reqr=has_reqr, & + IDS=ids,IDE=ide, JDS=jds,JDE=jde, KDS=kds,KDE=kde, & + IMS=ims,IME=ime, JMS=jms,JME=jme, KMS=kms,KME=kme, & + ITS=its,ITE=ite, JTS=jts,JTE=jte, KTS=kts,KTE=kte & + ) + + ENDIF + + + DO i = 1,ncol + delta_rain_mp(i) = delta_rain_mp(i) + xdelta_rain_mp(i) ! this is liquid equivalent of all precip + delta_graupel_mp(i) = delta_graupel_mp(i) + xdelta_graupel_mp(i) ! this is liquid equivalent of graupel + delta_ice_mp(i) = delta_ice_mp(i) + xdelta_ice_mp(i) + delta_snow_mp(i) = delta_snow_mp(i) + xdelta_snow_mp(i) + ENDDO + + ENDDO + + ENDIF + + + IF ( nssl_ccn_on ) THEN + IF ( invertccn ) THEN + cccn_mp = Max(0.0_kind_phys, nssl_qccn - cn_mp ) +! cccn_mp = nssl_qccn - cn_mp + ELSE + cccn_mp = cn_mp + ENDIF +! cccna = cna_mp ! cna not in use yet for ccpp + ENDIF + +! test code +! IF ( ntccna > 1 .and. do_effective_radii ) THEN +! cccna = re_ice_mp*1.0E6_kind_phys +! ENDIF + + IF ( ndebug > 1 ) write(0,*) 'done nssl_2mom_driver' + + if (errflg/=0) return + + IF ( ndebug > 1 ) THEN + write(*,*) 'Max q after micro' + write(*,*) 'qc = ',1000.*maxval(qc_mp) + write(*,*) 'qr = ',1000.*maxval(qr_mp) + write(*,*) 'qi = ',1000.*maxval(qi_mp) + write(*,*) 'qs = ',1000.*maxval(qs_mp) + write(*,*) 'qh = ',1000.*maxval(qh_mp) + IF ( nssl_hail_on ) THEN + write(*,*) 'qhl = ',1000.*maxval(qhl_mp) + ENDIF + write(*,*) 'ccw = ',1.e-6*maxval(ccw*rho) + IF ( 1000.*maxval(qc_mp) > 0.5 .or. 1000.*maxval(qi_mp) > 0.09 .or. 1000.*maxval(qs_mp) > 0.1 ) THEN + IF ( nssl_ccn_on ) THEN + write(*,*) 'qc, ccn, ccw, tt, qi+qs by height' + DO k = 1,nlev + write(*,*) qc_mp(1,k)*1000., cccn(1,k)*rho(1,k)*1.e-6, ccw(1,k)*rho(1,k)*1.e-6, tgrs(1,k), (qs_mp(1,k)+qi_mp(1,k))*1000. ! cccn(1,k)*1.e-6 + ENDDO + ELSE + write(*,*) 'qc, ccn, ccw, tt, qi+qs by height' + DO k = 1,nlev + write(*,*) qc_mp(1,k)*1000., cccn(1,k)*rho(1,k)*1.e-6, 0.0, tgrs(1,k), (qs_mp(1,k)+qi_mp(1,k))*1000. ! cccn(1,k)*1.e-6 + ENDDO + ENDIF + ENDIF + ENDIF + + + !> - Convert dry mixing ratios to specific humidity/moist mixing ratios + spechum = qv_mp/(1.0_kind_phys+qv_mp) + IF ( convert_dry_rho ) THEN + qc = qc_mp/(1.0_kind_phys+qv_mp) + qr = qr_mp/(1.0_kind_phys+qv_mp) + qi = qi_mp/(1.0_kind_phys+qv_mp) + qs = qs_mp/(1.0_kind_phys+qv_mp) + qh = qh_mp/(1.0_kind_phys+qv_mp) + IF ( nssl_ccn_on ) cccn = cccn_mp/(1.0_kind_phys+qv_mp) +! cccna = cccna_mp/(1.0_kind_phys+qv_mp) + ccw = nc_mp/(1.0_kind_phys+qv_mp) + crw = nr_mp/(1.0_kind_phys+qv_mp) + cci = ni_mp/(1.0_kind_phys+qv_mp) + csw = ns_mp/(1.0_kind_phys+qv_mp) + chw = nh_mp/(1.0_kind_phys+qv_mp) + vh = vh_mp/(1.0_kind_phys+qv_mp) + IF ( nssl_hail_on ) THEN + qhl = qhl_mp/(1.0_kind_phys+qv_mp) + chl = nhl_mp/(1.0_kind_phys+qv_mp) + vhl = vhl_mp/(1.0_kind_phys+qv_mp) + ENDIF + ELSE +! spechum = qv_mp ! /(1.0_kind_phys+qv_mp) + qc = qc_mp ! /(1.0_kind_phys+qv_mp) + qr = qr_mp ! /(1.0_kind_phys+qv_mp) + qi = qi_mp ! /(1.0_kind_phys+qv_mp) + qs = qs_mp ! /(1.0_kind_phys+qv_mp) + qh = qh_mp ! /(1.0_kind_phys+qv_mp) + IF ( nssl_ccn_on ) cccn = cccn_mp +! cccna = cccna_mp + ccw = nc_mp + crw = nr_mp + cci = ni_mp + csw = ns_mp + chw = nh_mp + vh = vh_mp + IF ( nssl_hail_on ) THEN + qhl = qhl_mp ! /(1.0_kind_phys+qv_mp) + chl = nhl_mp + vhl = vhl_mp + ENDIF + + ENDIF + +! write(0,*) 'mp_nssl: done q' + + !> - Convert rainfall deltas from mm to m (on physics timestep); add to inout variables + ! "rain" in NSSL MP refers to precipitation (total of liquid rainfall+snow+graupel+ice) + + prcp = max(0.0, delta_rain_mp/1000.0_kind_phys) + graupel = max(0.0, delta_graupel_mp/1000.0_kind_phys) + ice = max(0.0, delta_ice_mp/1000.0_kind_phys) + snow = max(0.0, delta_snow_mp/1000.0_kind_phys) + rain = max(0.0, (delta_rain_mp - (delta_graupel_mp + delta_ice_mp + delta_snow_mp))/1000.0_kind_phys) + +! write(0,*) 'mp_nssl: done precip' + + if (do_effective_radii) then + ! Convert m to micron + re_cloud = re_cloud_mp*1.0E6_kind_phys + re_ice = re_ice_mp*1.0E6_kind_phys + re_snow = re_snow_mp*1.0E6_kind_phys + re_rain = re_rain_mp*1.0E6_kind_phys + end if + + IF ( ndebug >= 1 ) write(0,*) 'mp_nssl: end' + + end subroutine mp_nssl_run +!>@} + +end module mp_nssl diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/uwshcu.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/uwshcu.F90 index 6aec3513b..f88146ee3 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/uwshcu.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/uwshcu.F90 @@ -27,6 +27,7 @@ module uwshcu integer :: windsrcavg ! Source air uses PBL mean momentum real :: rpen ! Penentrative entrainment factor real :: rle + real :: rkfre ! fraction_of_tke_associated_with_vertical_velocity real :: rkm ! Factor controlling lateral mixing rate real :: mixscale ! Controls vertical structure of mixing real :: detrhgt ! Mixing rate increases above this height @@ -61,7 +62,11 @@ module uwshcu real, parameter :: p00 = 1e5 ! Reference pressure real, parameter :: rovcp = MAPL_RGAS/MAPL_CP ! Gas constant over specific heat - real, parameter :: mintracer = tiny(1.) + real, parameter :: qpmin = 1.e-8 !< min value for suspended rain/snow/liquid/ice precip + real, parameter :: qvmin = 1.e-20 !< min value for water vapor (treated as zero) + real, parameter :: qcmin = 1.e-12 !< min value for cloud condensates + + real, parameter :: mintracer = 0.0 contains real function exnerfn(pressure) @@ -73,7 +78,7 @@ end function exnerfn subroutine compute_uwshcu_inv(idim, k0, dt,pmid0_inv, & ! INPUT zmid0_inv, exnmid0_inv, pifc0_inv, zifc0_inv, exnifc0_inv, & dp0_inv, u0_inv, v0_inv, qv0_inv, ql0_inv, qi0_inv, & - t0_inv, tke_inv, rkfre, kpbl_inv, shfx,evap, cnvtr, frland,& + t0_inv, tke_inv, rkfre, kpbl_inv, shfx,evap, cnvtr, frland, rkm2d, mix2d, & cush, & ! INOUT umf_inv, dcm_inv, qvten_inv, qlten_inv, qiten_inv, tten_inv, & ! OUTPUT uten_inv, vten_inv, qrten_inv, qsten_inv, cufrc_inv, & @@ -117,6 +122,8 @@ subroutine compute_uwshcu_inv(idim, k0, dt,pmid0_inv, & ! INPUT real, intent(in) :: evap(idim) ! Surface evaporation real, intent(in) :: cnvtr(idim) ! convective tracer real, intent(in) :: frland(idim) ! land fraction + real, intent(in) :: rkm2d(idim) ! Resolution dependent lateral mixing parameter + real, intent(in) :: mix2d(idim) ! Resolution dependent lateral mixing depth real, intent(inout) :: cush(idim) ! Convective scale height [m] real, intent(out) :: umf_inv(idim,k0+1) ! Updraft mass flux at interfaces [kg/m2/s] @@ -297,7 +304,7 @@ subroutine compute_uwshcu_inv(idim, k0, dt,pmid0_inv, & ! INPUT call compute_uwshcu( idim,k0, dt, ncnst,pifc0, zifc0, & exnifc0, pmid0, zmid0, exnmid0, dp0, u0, v0, & - qv0, ql0, qi0, th0, tr0, kpbl, frland, tke, rkfre, cush, umf, & + qv0, ql0, qi0, th0, tr0, kpbl, frland, tke, rkfre, rkm2d, mix2d, cush, umf, & dcm, qvten, qlten, qiten, sten, uten, vten, & qrten, qsten, cufrc, fer, fdr, qldet, qidet, & qlsub, qisub, ndrop, nice, & @@ -394,7 +401,7 @@ end subroutine compute_uwshcu_inv subroutine compute_uwshcu(idim, k0, dt,ncnst, pifc0_in,zifc0_in,& ! IN exnifc0_in, pmid0_in, zmid0_in, exnmid0_in, dp0_in, & u0_in, v0_in, qv0_in, ql0_in, qi0_in, th0_in, & - tr0_inout, kpbl_in, frland_in, tke_in, rkfre, cush_inout, & ! OUT + tr0_inout, kpbl_in, frland_in, tke_in, rkfre, rkm2d, mix2d, cush_inout, & ! OUT umf_out, dcm_out, qvten_out, qlten_out, qiten_out, & sten_out, uten_out, vten_out, qrten_out, & qsten_out, cufrc_out, fer_out, fdr_out, qldet_out, & @@ -453,7 +460,9 @@ subroutine compute_uwshcu(idim, k0, dt,ncnst, pifc0_in,zifc0_in,& ! IN real, intent(in) :: qi0_in( idim,k0 ) ! Environmental ice specific humidity real, intent(in) :: th0_in( idim,k0 ) ! Environmental potential temperature [K] real, intent(in) :: tke_in( idim,0:k0 ) ! Turbulent kinetic energy at interfaces - real, intent(in) :: rkfre(idim) ! Resolution dependent Vertical velocity variance as fraction of tke. + real, intent(in) :: rkfre(idim) ! Resolution dependent Vertical velocity variance as fraction of tke. + real, intent(in) :: rkm2d(idim) ! Resolution dependent lateral mixing parameter + real, intent(in) :: mix2d(idim) ! Resolution dependent lateral mixing depth real, intent(in) :: shfx(idim) ! Surface sensible heat real, intent(in) :: evap(idim) ! Surface evaporation real, intent(in) :: cnvtr(idim) ! Convective tracer @@ -629,7 +638,6 @@ subroutine compute_uwshcu(idim, k0, dt,ncnst, pifc0_in,zifc0_in,& ! IN real trflx(0:k0,ncnst) ! Flux of real trflx_d(0:k0) ! Adjustive real trflx_u(0:k0) ! Adjustive - real trmin real pdelx, dum ! Variables for temperature/moisture excess in source parcel @@ -954,7 +962,7 @@ subroutine compute_uwshcu(idim, k0, dt,ncnst, pifc0_in,zifc0_in,& ! IN real :: frc_rasn !!! TEMPORARY: should be ncnst array of minimum values for all constituents - real, parameter,dimension(4) :: qmin = [0.,0.,0.,0.] +!!! real, parameter,dimension(4) :: qmin = [0.,0.,0.,0.] ! ---------------------------------------- ! @@ -1443,6 +1451,7 @@ subroutine compute_uwshcu(idim, k0, dt,ncnst, pifc0_in,zifc0_in,& ! IN dpsum = 0. thvlmin = 1000. thvlavg = 0. + qtavg = 0. do k = 1,kinv ! max(kinv-1,1) ! Here, 'k' is an interfacial layer index. dpi = pifc0(k-1) - pifc0(k) dpsum = dpsum + dpi @@ -1450,12 +1459,14 @@ subroutine compute_uwshcu(idim, k0, dt,ncnst, pifc0_in,zifc0_in,& ! IN uavg = uavg + dpi*u0(k) vavg = vavg + dpi*v0(k) thvlavg = thvlavg + dpi*thvl0(k) + qtavg = qtavg + dpi*qt0(k) if( k .ne. kinv ) thvlmin = min(thvlmin,min(thvl0bot(k),thvl0top(k))) end do tkeavg = tkeavg/dpsum uavg = uavg/dpsum vavg = vavg/dpsum thvlavg = thvlavg/dpsum + qtavg = qtavg/dpsum ! weighted average over lowest 20mb ! dpsum = 0. @@ -1467,16 +1478,17 @@ subroutine compute_uwshcu(idim, k0, dt,ncnst, pifc0_in,zifc0_in,& ! IN ! qtavg = qtavg/dpsum ! Interpolate qt to specified height - k = 1 - do while (zmid0(k).lt.qtsrchgt) - k = k+1 - end do - if (k.gt.1) then - qtavg = qt0(k-1)*(zmid0(k)-qtsrchgt) + qt0(k)*(qtsrchgt-zmid0(k-1)) - qtavg = qtavg / (zmid0(k)-zmid0(k-1)) - else - qtavg = qt0(1) - end if +! k = 1 +! do while (zmid0(k).lt.qtsrchgt) +! do while (zmid0(k).lt.0.5*zmid0(kinv)) ! use qt from half of inv height +! k = k+1 +! end do +! if (k.gt.1) then +! qtavg = qt0(k-1)*(zmid0(k)-qtsrchgt) + qt0(k)*(qtsrchgt-zmid0(k-1)) +! qtavg = qtavg / (zmid0(k)-zmid0(k-1)) +! else +! qtavg = qt0(1) +! end if ! ------------------------------------------------------------------ ! ! Find characteristics of cumulus source air: qtsrc,thlsrc,usrc,vsrc ! @@ -2154,11 +2166,11 @@ subroutine compute_uwshcu(idim, k0, dt,ncnst, pifc0_in,zifc0_in,& ! IN ! --------------------------------------------------------------------------- if( use_CINcin ) then - wcrit = sqrt( 2. * cin * rbuoy ) + wcrit = sqrt(max(0.0, 2. * cin * rbuoy) ) else - wcrit = sqrt( 2. * cinlcl * rbuoy ) + wcrit = sqrt(max(0.0, 2. * cinlcl * rbuoy) ) endif - sigmaw = sqrt( rkfre(i) * tkeavg + epsvarw ) + sigmaw = sqrt(max(0.0, rkfre(i) * tkeavg + epsvarw) ) mu = wcrit/sigmaw/1.4142 if( mu .ge. 3. ) then if (scverbose) then @@ -2173,11 +2185,12 @@ subroutine compute_uwshcu(idim, k0, dt,ncnst, pifc0_in,zifc0_in,& ! IN ! 1. 'cbmf' constraint cbmflimit = 0.9*dp0(kinv-1)/g/dt mumin0 = 0. - if( cbmf .gt. cbmflimit ) mumin0 = sqrt(-log(2.5066*cbmflimit/rho0inv/sigmaw)) + if( cbmf .gt. cbmflimit ) mumin0 = sqrt(max(0.0,-log(max(tiny(0.0),2.5066*cbmflimit/rho0inv/sigmaw)))) +! ALT ?? if( cbmf .gt. cbmflimit ) mumin0 = sqrt(mu**2-log(cbmflimit/cbmf)) ! 2. 'ufrcinv' constraint mu = max(max(mu,mumin0),mumin1) ! 3. 'ufrclcl' constraint - mulcl = sqrt(2.*cinlcl*rbuoy)/1.4142/sigmaw + mulcl = sqrt(max(0.0,2.*cinlcl*rbuoy))/1.4142/sigmaw mulclstar = sqrt(max(0.,2.*(exp(-mu**2)/2.5066)**2*(1./erfc(mu)**2-0.25/rmaxfrac**2))) if( mulcl .gt. 1.e-8 .and. mulcl .gt. mulclstar ) then mumin2 = compute_mumin2(mulcl,rmaxfrac,mu) @@ -2222,7 +2235,7 @@ subroutine compute_uwshcu(idim, k0, dt,ncnst, pifc0_in,zifc0_in,& ! IN id_exit = .true. go to 333 endif - wlcl = sqrt(wtw) + wlcl = sqrt(wtw) ! protected from NaN above ufrclcl = cbmf/wlcl/rho0inv wrel = wlcl if( ufrclcl .le. 0.0001 ) then @@ -2657,15 +2670,15 @@ subroutine compute_uwshcu(idim, k0, dt,ncnst, pifc0_in,zifc0_in,& ! IN ! ------------------------------------------------------------------------ ! ee2 = xc**2 ud2 = 1. - 2.*xc + xc**2 ! (1-xc)**2 - if (min(scaleh,mixscale).ne.0.0) then - rei(k) = ( (rkm+max(0.,(zmid0(k)-detrhgt)/200.) ) / min(scaleh,mixscale) / g / rhomid0j ) ! alternative + if (min(scaleh,mix2d(i)).gt.0.0) then + rei(k) = ( (rkm2d(i)+max(0.,(zmid0(k)-detrhgt)/200.) ) / min(scaleh,mix2d(i)) / g / rhomid0j ) ! alternative ! regression bug due to cnvtr -! WMP rei(k) = ( (rkm+max(0.,(zmid0(k)-detrhgt)/200.)-max(0.,min(2.,(cnvtr(i))/2.5e-6))) / min(scaleh,mixscale) / g / rhomid0j ) ! alternative +! WMP rei(k) = ( (rkm2d(i)+max(0.,(zmid0(k)-detrhgt)/200.)-max(0.,min(2.,(cnvtr(i))/2.5e-6))) / min(scaleh,mix2d(i)) / g / rhomid0j ) ! alternative else - rei(k) = ( 0.5 * rkm / zmid0(k) / g /rhomid0j ) ! Jason-2_0 version + rei(k) = ( 0.5 * rkm2d(i) / zmid0(k) / g /rhomid0j ) ! Jason-2_0 version end if - if( xc .gt. 0.5 ) rei(k) = min(rei(k),0.9*log(dp0(k)/g/dt/umf(km1) + 1.)/dpe/(2.*xc-1.)) + if( xc .gt. 0.5 ) rei(k) = min(rei(k),0.9*log(max(tiny(0.0),dp0(k)/g/dt/umf(km1) + 1.))/dpe/(2.*xc-1.)) fer(k) = rei(k) * ee2 fdr(k) = rei(k) * ud2 xco(k) = xc @@ -2904,7 +2917,7 @@ subroutine compute_uwshcu(idim, k0, dt,ncnst, pifc0_in,zifc0_in,& ! IN go to 45 end if - wu(k) = sqrt(wtw) + wu(k) = sqrt(wtw) ! Protected from NaN above if( wu(k) .gt. 100. ) then exit_wu(i) = 1. id_exit = .true. @@ -2940,7 +2953,7 @@ subroutine compute_uwshcu(idim, k0, dt,ncnst, pifc0_in,zifc0_in,& ! IN limit_ufrc(i) = 1. ufrc(k) = rmaxfrac umf(k) = rmaxfrac * rhoifc0j * wu(k) - fdr(k) = fer(k) - log( umf(k) / umf(km1) ) / dpe + fdr(k) = fer(k) - log(max(tiny(0.0), umf(k) / umf(km1)) ) / dpe endif ! ------------------------------------------------------------ ! @@ -4002,7 +4015,7 @@ subroutine compute_uwshcu(idim, k0, dt,ncnst, pifc0_in,zifc0_in,& ! IN ql0_star(:k0) = ql0(:k0) + qlten(:k0) * dt qi0_star(:k0) = qi0(:k0) + qiten(:k0) * dt s0_star(:k0) = s0(:k0) + sten(:k0) * dt - call positive_moisture_single( xlv, xls, k0, dt, qmin(1), qmin(ixcldliq), qmin(ixcldice), & + call positive_moisture_single( xlv, xls, k0, dt, & dp0, qv0_star, ql0_star, qi0_star, s0_star, qvten, qlten, qiten, sten ) qtten(:k0) = qvten(:k0) + qlten(:k0) + qiten(:k0) slten(:k0) = sten(:k0) - xlv * qlten(:k0) - xls * qiten(:k0) @@ -4016,16 +4029,6 @@ subroutine compute_uwshcu(idim, k0, dt,ncnst, pifc0_in,zifc0_in,& ! IN ! if( m .ne. ixnumliq .and. m .ne. ixnumice ) then - trmin = 0. !qmin(m) -!#ifdef MODAL_AERO -! do mm = 1, ntot_amode -! if( m .eq. numptr_amode(mm) ) then -! trmin = 1.e-5 -! goto 55 -! endif -! enddo -! 55 continue -!#endif trflx_d(0:k0) = 0. trflx_u(0:k0) = 0. do k = 1, k0-1 @@ -4035,7 +4038,7 @@ subroutine compute_uwshcu(idim, k0, dt,ncnst, pifc0_in,zifc0_in,& ! IN ! pdelx = dpdry0(k) ! endif km1 = k - 1 - dum = ( tr0(k,m) - trmin ) * pdelx / g / dt + trflx(km1,m) - trflx(k,m) + trflx_d(km1) + dum = tr0(k,m) * pdelx / g / dt + trflx(km1,m) - trflx(k,m) + trflx_d(km1) trflx_d(k) = min( 0., dum ) enddo do k = k0, 2, -1 @@ -4045,7 +4048,7 @@ subroutine compute_uwshcu(idim, k0, dt,ncnst, pifc0_in,zifc0_in,& ! IN ! pdelx = dpdry0(k) ! endif km1 = k - 1 - dum = ( tr0(k,m) - trmin ) * pdelx / g / dt + trflx(km1,m) - trflx(k,m) + & + dum = tr0(k,m) * pdelx / g / dt + trflx(km1,m) - trflx(k,m) + & trflx_d(km1) - trflx_d(k) - trflx_u(k) trflx_u(km1) = max( 0., -dum ) enddo @@ -4642,7 +4645,7 @@ function qsinvert(qt,thl,ps_in) return end if -! print *,'Ti,Rhi,thl=',Ti,rhi,thl +! print *,'Ti,Rhi,thl=',Ti,rhi,thl ! WMP log(rhi) protected from NaN above TLCL = 55._r8 + 1._r8/(1._r8/(Ti-55._r8)-log(rhi)/2840._r8) ! Bolton's formula. MWR.1980.Eq.(22) PiLCL = TLCL/thl ps = p00*(PiLCL)**(1._r8/rovcp) @@ -4867,7 +4870,7 @@ subroutine fluxbelowinv(cbmf,ps0,mkx,kinv,dt,xsrc,xmean,xtopin,xbotin,xflx) end subroutine fluxbelowinv - subroutine positive_moisture_single( xlv, xls, mkx, dt, qvmin, qlmin, qimin, dp, qv, ql, qi, s, qvten, qlten, qiten, sten ) + subroutine positive_moisture_single( xlv, xls, mkx, dt, dp, qv, ql, qi, s, qvten, qlten, qiten, sten ) ! ------------------------------------------------------------------------------- ! ! If any 'ql < qlmin, qi < qimin, qv < qvmin' are developed in any layer, ! ! force them to be larger than minimum value by (1) condensating water vapor ! @@ -4881,48 +4884,47 @@ subroutine positive_moisture_single( xlv, xls, mkx, dt, qvmin, qlmin, qimin, dp, implicit none integer, intent(in) :: mkx real, intent(in) :: xlv, xls - real, intent(in) :: qvmin, qlmin, qimin real, intent(in) :: dp(mkx) real, intent(in) :: dt real, intent(inout) :: qv(mkx), ql(mkx), qi(mkx), s(mkx) real, intent(inout) :: qvten(mkx), qlten(mkx), qiten(mkx), sten(mkx) integer k - real*8 dql, dqi, dqv, sum, aa, dum + real dql, dqi, dqv, sum, aa, dum do k = mkx, 1, -1 ! From the top to the 1st (lowest) layer from the surface - dql = max(0._r8,1._r8*qlmin-ql(k)) - dqi = max(0._r8,1._r8*qimin-qi(k)) + dql = max(0.0, (qcmin-ql(k))) + dqi = max(0.0, (qcmin-qi(k))) qlten(k) = qlten(k) + dql/dt qiten(k) = qiten(k) + dqi/dt - qvten(k) = qvten(k) - (dql+dqi)/dt sten(k) = sten(k) + xlv * (dql/dt) + xls * (dqi/dt) ql(k) = ql(k) + dql qi(k) = qi(k) + dqi - qv(k) = qv(k) - dql - dqi s(k) = s(k) + xlv * dql + xls * dqi - dqv = max(0.,1.*qvmin-qv(k)) + + qv(k) = qv(k) - dql - dqi + dqv = max(0.0, (qvmin-qv(k))) qvten(k) = qvten(k) + dqv/dt - qv(k) = qv(k) + dqv + qv(k) = qv(k) + dqv if( k .ne. 1 ) then qv(k-1) = qv(k-1) - dqv*dp(k)/dp(k-1) qvten(k-1) = qvten(k-1) - dqv*dp(k)/dp(k-1)/dt endif qv(k) = max(qv(k),qvmin) - ql(k) = max(ql(k),qlmin) - qi(k) = max(qi(k),qimin) + ql(k) = max(ql(k),qcmin) + qi(k) = max(qi(k),qcmin) end do ! Extra moisture used to satisfy 'qv(i,1)=qvmin' is proportionally ! extracted from all the layers that has 'qv > 2*qvmin'. This fully ! preserves column moisture. - if( dqv .gt. 1.e-20_r8 ) then + if( dqv .gt. qvmin ) then sum = 0. do k = 1, mkx - if( qv(k) .gt. 2._r8*qvmin ) sum = sum + qv(k)*dp(k) + if( qv(k) .gt. 2.0*qvmin ) sum = sum + qv(k)*dp(k) enddo - aa = dqv*dp(1)/max(1.e-20_r8,sum) - if( aa .lt. 0.5_r8 ) then + aa = dqv*dp(1)/max(qvmin,sum) + if( aa .lt. 0.5 ) then do k = 1, mkx - if( qv(k) .gt. 2._r8*qvmin ) then + if( qv(k) .gt. 2.0*qvmin ) then dum = aa*qv(k) qv(k) = qv(k) - dum qvten(k) = qvten(k) - dum/dt @@ -5024,14 +5026,14 @@ subroutine roots(a,b,c,r1,r2,status) if( a*c .gt. 0. ) then ! Failure: x**2 = -c/a < 0 status = 2 else ! x**2 = -c/a - r1 = sqrt(-c/a) + r1 = sqrt(-c/a) ! protected from NaN above endif r2 = -r1 else ! Form a*x**2 + b*x + c = 0 if( (b**2 - 4.*a*c) .lt. 0. ) then ! Failure, no real roots status = 3 else - q = -0.5*(b + sign(1.0,b)*sqrt(b**2 - 4.*a*c)) + q = -0.5*(b + sign(1.0,b)*sqrt(b**2 - 4.*a*c)) ! protected from NaN above r1 = q/a r2 = c/q ! r1 = -0.5*(b + sign(1.0,b)*sqrt(b**2 - 4.*a*c))/a diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOS_SurfaceGridComp.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOS_SurfaceGridComp.F90 index 0718f700a..583db543a 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOS_SurfaceGridComp.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOS_SurfaceGridComp.F90 @@ -7670,6 +7670,7 @@ subroutine RUN2 ( GC, IMPORT, EXPORT, CLOCK, RC ) else CN_PRCP = PRECCU endif + CN_PRCP = MAX(CN_PRCP, 0.0) ! Total Precipitation ! ------------------- @@ -7683,6 +7684,7 @@ subroutine RUN2 ( GC, IMPORT, EXPORT, CLOCK, RC ) else PRECTOT = TPREC endif + PRECTOT = MAX(PRECTOT, 0.0) ! New effective temperature and humidity !--------------------------------------- diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatch_GridComp/GEOS_CatchGridComp.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatch_GridComp/GEOS_CatchGridComp.F90 index 17da8116a..5ba1873b4 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatch_GridComp/GEOS_CatchGridComp.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatch_GridComp/GEOS_CatchGridComp.F90 @@ -3313,6 +3313,11 @@ subroutine RUN1 ( GC, IMPORT, EXPORT, CLOCK, RC ) call MAPL_GetResource ( MAPL, CHOOSEZ0, Label="CHOOSEZ0:", DEFAULT=3, RC=STATUS) VERIFY_(STATUS) + + niter = 6 ! number of internal iterations in the helfand MO surface layer routine + call MAPL_GetResource ( MAPL, niter, Label="NITER_HELFSURFACE:", DEFAULT=niter, RC=STATUS) + VERIFY_(STATUS) + call ESMF_VMGetCurrent(VM, rc=STATUS) VERIFY_(STATUS) @@ -3741,7 +3746,6 @@ subroutine RUN1 ( GC, IMPORT, EXPORT, CLOCK, RC ) RE = 0. UUU = UU UCN = 0. - ! Aggregate to tiles for MO only diagnostics !-------------------------------------------- if(associated(MOU50M))MOU50M = MOU50M + U50M(:)*FR(:,N) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/Shared/catch_wrap_state.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/Shared/catch_wrap_state.F90 index 4c50fedcd..045fc93ea 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/Shared/catch_wrap_state.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/Shared/catch_wrap_state.F90 @@ -135,10 +135,9 @@ subroutine surface_params_to_wrap_state(statePtr, scf, rc) FWETC_default = 0.005 ! NOT ready for science! FWETL_default = 0.025 ! NOT ready for science! endif - call MAPL_GetResource( SCF, statePtr%FWETC, label='FWETC:', DEFAULT=FWETC_default, __RC__ ) call MAPL_GetResource( SCF, statePtr%FWETL, label='FWETL:', DEFAULT=FWETL_default, __RC__ ) - call MAPL_GetResource( SCF, statePtr%SNOW_ALBEDO_INFO, label='SNOW_ALBEDO_INFO:', DEFAULT=0, __RC__ ) + call MAPL_GetResource( SCF, statePtr%SNOW_ALBEDO_INFO, label='SNOW_ALBEDO_INFO:', DEFAULT=1, __RC__ ) call MAPL_GetResource( SCF, statePtr%N_CONST_LAND4SNWALB, label='N_CONST_LAND4SNWALB:', DEFAULT=0, __RC__ ) call MAPL_GetResource( SCF, statePtr%AEROSOL_DEPOSITION, label='AEROSOL_DEPOSITION:', DEFAULT=0, __RC__ ) call MAPL_GetResource( SCF, statePtr%RUN_IRRIG, label='RUN_IRRIG:', DEFAULT=0, __RC__ ) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Shared/GEOS_SurfaceGridComp.rc b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Shared/GEOS_SurfaceGridComp.rc index 1ba28b70b..03f7e6e95 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Shared/GEOS_SurfaceGridComp.rc +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Shared/GEOS_SurfaceGridComp.rc @@ -125,8 +125,8 @@ # - NOTE: bcs v06, v08, and v09 used approximate averaging of MODIS-based snow albedo to tile space; # bcs v11, v12 and v13 employ more accurate, raster-based averaging. # -# GEOSagcm=>SNOW_ALBEDO_INFO: 0 -# GEOSldas=>SNOW_ALBEDO_INFO: 0 +# GEOSagcm=>SNOW_ALBEDO_INFO: 1 +# GEOSldas=>SNOW_ALBEDO_INFO: 1 #--------------------------------------------------------# # GOSWIM aerosol deposition on surface snow # diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Shared/StieglitzSnow.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Shared/StieglitzSnow.F90 index c0aa05caf..44073985f 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Shared/StieglitzSnow.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Shared/StieglitzSnow.F90 @@ -1773,7 +1773,7 @@ SUBROUTINE StieglitzSnow_snow_albedo( & if(SLOPE < 0.0) then GK_B = SLOPE else - GK_B = (0.85808-0.6)/(RHOFRESH-StieglitzSnow_RHOMA) + GK_B = (0.86-0.76)/(RHOFRESH-StieglitzSnow_RHOMA) endif DO I=1,NCH diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/CMakeLists.txt b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/CMakeLists.txt index c52656386..1d990849f 100755 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/CMakeLists.txt +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/CMakeLists.txt @@ -11,18 +11,10 @@ zip.c util.c ) -if(NOT FORTRAN_COMPILER_SUPPORTS_FINDLOC) - list(APPEND srcs findloc.F90) -endif () - set_source_files_properties(mkMITAquaRaster.F90 PROPERTIES COMPILE_FLAGS "${BYTERECLEN}") esma_add_library(${this} SRCS ${srcs} DEPENDENCIES MAPL GEOS_SurfaceShared GEOS_LandShared ESMF::ESMF NetCDF::NetCDF_Fortran OpenMP::OpenMP_Fortran) -if(NOT FORTRAN_COMPILER_SUPPORTS_FINDLOC) - target_compile_definitions(${this} PRIVATE USE_EXTERNAL_FINDLOC) -endif () - # MAT NOTE This should use find_package(ZLIB) but Baselibs currently # confuses find_package(). This is a hack until Baselibs is # reorganized. diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/findloc.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/findloc.F90 deleted file mode 100644 index ef22a99fd..000000000 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/findloc.F90 +++ /dev/null @@ -1,30 +0,0 @@ -module findloc_mod - - implicit none - - private - public :: findloc - - contains - - function findloc(array, value) - - integer, intent(in) :: array(:) - integer, intent(in) :: value - integer :: findloc(1) - - integer :: num_elements, i - - num_elements = size(array) - - findloc(1) = 0 - do i = 1, num_elements - if (array(i) == value) then - findloc(1) = i - exit - endif - end do - - end function findloc - -end module findloc_mod diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/mod_process_hres_data.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/mod_process_hres_data.F90 index 6300fdebd..c9c5c3604 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/mod_process_hres_data.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/mod_process_hres_data.F90 @@ -31,10 +31,6 @@ MODULE process_hres_data use lsm_routines, ONLY: sibalb use LogRectRasterizeMod, ONLY: SRTM_maxcat -#if defined USE_EXTERNAL_FINDLOC - use findloc_mod, only: findloc -#endif - implicit none include 'netcdf.inc' diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/CMakeLists.txt b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/CMakeLists.txt index 6c63bfa05..4af3b5863 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/CMakeLists.txt +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/CMakeLists.txt @@ -7,17 +7,12 @@ set(srcs ) set (exe_srcs - Scale_Catch.F90 - Scale_CatchCN.F90 cv_SaltRestart.F90 SaltIntSplitter.F90 SaltImpConverter.F90 mk_CICERestart.F90 - mk_CatchCNRestarts.F90 - mk_CatchRestarts.F90 mk_LakeLandiceSaltRestarts.F90 mk_RouteRestarts.F90 - mk_GEOSldasRestarts.F90 mk_catchANDcnRestarts.F90 ) @@ -33,7 +28,6 @@ foreach (src ${exe_srcs}) LIBS MAPL GFTL_SHARED::gftl-shared GEOS_SurfaceShared GEOSroute_GridComp GEOS_LandShared GEOS_CatchCNShared ${this}) endforeach () -install(PROGRAMS mk_Restarts DESTINATION bin) foreach (src ${exe_srcs}) string (REGEX REPLACE ".F90" ".x" exe ${src}) string (REGEX REPLACE ".F90" "" lname ${src}) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/Scale_Catch.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/Scale_Catch.F90 deleted file mode 100644 index f79225031..000000000 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/Scale_Catch.F90 +++ /dev/null @@ -1,728 +0,0 @@ -#define I_AM_MAIN -#include "MAPL_Generic.h" - -program Scale_Catch - - use MAPL - - use LSM_ROUTINES, ONLY: & - catch_calc_soil_moist, & - catch_calc_tp, & - catch_calc_ght - - USE CATCH_CONSTANTS, ONLY: & - N_GT => CATCH_N_GT, & - DZGT => CATCH_DZGT, & - PEATCLSM_POROS_THRESHOLD - - implicit none - - character(256) :: fname1, fname2, fname3 -#ifndef __GFORTRAN__ - integer :: ftell - external :: ftell -#endif - integer :: bpos, epos, ntiles, n, nargs - integer :: old, new, sca - integer :: iargc - real :: SURFLAY ! (Ganymed-3 and earlier) SURFLAY=20.0 for Old Soil Params - ! (Ganymed-4 and later ) SURFLAY=50.0 for New Soil Params - real :: WEMIN_IN, WEMIN_OUT - character*256 :: arg(6) - - type catch_rst - real, pointer :: bf1(:) - real, pointer :: bf2(:) - real, pointer :: bf3(:) - real, pointer :: vgwmax(:) - real, pointer :: cdcr1(:) - real, pointer :: cdcr2(:) - real, pointer :: psis(:) - real, pointer :: bee(:) - real, pointer :: poros(:) - real, pointer :: wpwet(:) - real, pointer :: cond(:) - real, pointer :: gnu(:) - real, pointer :: ars1(:) - real, pointer :: ars2(:) - real, pointer :: ars3(:) - real, pointer :: ara1(:) - real, pointer :: ara2(:) - real, pointer :: ara3(:) - real, pointer :: ara4(:) - real, pointer :: arw1(:) - real, pointer :: arw2(:) - real, pointer :: arw3(:) - real, pointer :: arw4(:) - real, pointer :: tsa1(:) - real, pointer :: tsa2(:) - real, pointer :: tsb1(:) - real, pointer :: tsb2(:) - real, pointer :: atau(:) - real, pointer :: btau(:) - real, pointer :: ity(:) - real, pointer :: tc(:,:) - real, pointer :: qc(:,:) - real, pointer :: capac(:) - real, pointer :: catdef(:) - real, pointer :: rzexc(:) - real, pointer :: srfexc(:) - real, pointer :: ghtcnt1(:) - real, pointer :: ghtcnt2(:) - real, pointer :: ghtcnt3(:) - real, pointer :: ghtcnt4(:) - real, pointer :: ghtcnt5(:) - real, pointer :: ghtcnt6(:) - real, pointer :: tsurf(:) - real, pointer :: wesnn1(:) - real, pointer :: wesnn2(:) - real, pointer :: wesnn3(:) - real, pointer :: htsnnn1(:) - real, pointer :: htsnnn2(:) - real, pointer :: htsnnn3(:) - real, pointer :: sndzn1(:) - real, pointer :: sndzn2(:) - real, pointer :: sndzn3(:) - real, pointer :: ch(:,:) - real, pointer :: cm(:,:) - real, pointer :: cq(:,:) - real, pointer :: fr(:,:) - real, pointer :: ww(:,:) - endtype catch_rst - - type(catch_rst) catch(3) - - real, allocatable, dimension(:) :: dzsf, ar1, ar2, ar4 - real, allocatable, dimension(:,:) :: TP_IN, GHT_IN, FICE, GHT_OUT, TP_OUT - real, allocatable, dimension(:) :: swe_in, depth_in, areasc_in, areasc_out, depth_out - - type(Netcdf4_fileformatter) :: formatter(3) - type(Filemetadata) :: cfg(3) - integer :: i, rc, filetype - integer :: status - character(256) :: Iam = "Scale_Catch" - -! Usage -! ----- - if (iargc() /= 6) then - write(*,*) "Usage: Scale_Catch " - call exit(2) - end if - - do n=1,6 - call getarg(n,arg(n)) - enddo - -! Open INPUT and Regridded Catch Files -! ------------------------------------ - read(arg(1),'(a)') fname1 - - read(arg(2),'(a)') fname2 - -! Open OUTPUT (Scaled) Catch File -! ------------------------------- - read(arg(3),'(a)') fname3 - - call MAPL_NCIOGetFileType(fname1, filetype, __RC__) - - if (filetype == 0) then - call formatter(1)%open(trim(fname1),pFIO_READ, __RC__) - call formatter(2)%open(trim(fname2),pFIO_READ, __RC__) - cfg(1)=formatter(1)%read(__RC__) - cfg(2)=formatter(2)%read(__RC__) - else - open(unit=10, file=trim(fname1), form='unformatted') - open(unit=20, file=trim(fname2), form='unformatted') - open(unit=30, file=trim(fname3), form='unformatted') - end if - -! Get SURFLAY Value -! ----------------- - read(arg(4),*) SURFLAY - read(arg(5),*) WEMIN_IN - read(arg(6),*) WEMIN_OUT - - if (SURFLAY.ne.20 .and. SURFLAY.ne.50) then - print *, "You must supply a valid SURFLAY value:" - print *, "(Ganymed-3 and earlier) SURFLAY=20.0 for Old Soil Params" - print *, "(Ganymed-4 and later ) SURFLAY=50.0 for New Soil Params" - call exit(2) - end if - print *, 'SURFLAY: ',SURFLAY - - if (filetype ==0) then - - ntiles = cfg(1)%get_dimension('tile', __RC__) - - else - -! Determine NTILES -! ---------------- - bpos=0 - read(10) - epos = ftell(10) ! ending position of file pointer - ntiles = (epos-bpos)/4-2 ! record size (in 4 byte words; - rewind 10 - - end if - - write(6,100) ntiles - -! Allocate Catches -! ---------------- - do n=1,3 - call allocatch ( ntiles,catch(n) ) - enddo - -! Read INPUT Catches -! ------------------ - old = 1 - new = 2 - - if (filetype ==0) then - call readcatch_nc4 ( catch(old), formatter(old), __RC__ ) - call readcatch_nc4 ( catch(new), formatter(new), __RC__ ) - else - call readcatch ( 10,catch(old) ) - call readcatch ( 20,catch(new) ) - end if - -! Create Scaled Catch -! ------------------- - sca = 3 - - catch(sca) = catch(new) - -! 1) soil moisture prognostics -! ---------------------------- -! n = count( (catch(old)%catdef .gt. catch(old)%cdcr1) .and. & -! (catch(new)%cdcr2 .gt. catch(old)%cdcr2) ) -! -! write(6,200) n,100*n/ntiles -! -! where( (catch(old)%catdef .gt. catch(old)%cdcr1) .and. & -! (catch(new)%cdcr2 .gt. catch(old)%cdcr2) ) -! -! catch(sca)%rzexc = catch(old)%rzexc * ( catch(new)%vgwmax / & -! catch(old)%vgwmax ) -! -! catch(sca)%catdef = catch(new)%cdcr1 + & -! ( catch(old)%catdef-catch(old)%cdcr1 ) / & -! ( catch(old)%cdcr2 -catch(old)%cdcr1 ) * & -! ( catch(new)%cdcr2 -catch(new)%cdcr1 ) -! end where - - n =count((catch(old)%catdef .gt. catch(old)%cdcr1)) - - write(6,200) n,100*n/ntiles - -! Scale rxexc regardless of CDCR1, CDCR2 differences -! -------------------------------------------------- - catch(sca)%rzexc = catch(old)%rzexc * ( catch(new)%vgwmax / & - catch(old)%vgwmax ) - -! Scale catdef regardless of whether CDCR2 is larger or smaller in the new situation -! ---------------------------------------------------------------------------------- - where (catch(old)%catdef .gt. catch(old)%cdcr1) - - catch(sca)%catdef = catch(new)%cdcr1 + & - ( catch(old)%catdef-catch(old)%cdcr1 ) / & - ( catch(old)%cdcr2 -catch(old)%cdcr1 ) * & - ( catch(new)%cdcr2 -catch(new)%cdcr1 ) - end where - -! Scale catdef also for the case where catdef le cdcr1. -! ----------------------------------------------------- - where( (catch(old)%catdef .le. catch(old)%cdcr1)) - catch(sca)%catdef = catch(old)%catdef * (catch(new)%cdcr1 / catch(old)%cdcr1) - end where - -! Sanity Check (catch_calc_soil_moist() forces consistency betw. srfexc, rzexc, catdef) -! ------------ - print *, 'Performing Sanity Check ...' - allocate ( dzsf(ntiles) ) - allocate ( ar1( ntiles) ) - allocate ( ar2( ntiles) ) - allocate ( ar4( ntiles) ) - - dzsf = SURFLAY - - call catch_calc_soil_moist( ntiles, dzsf, & - catch(sca)%vgwmax, catch(sca)%cdcr1, catch(sca)%cdcr2, & - catch(sca)%psis, catch(sca)%bee, catch(sca)%poros, catch(sca)%wpwet, & - catch(sca)%ars1, catch(sca)%ars2, catch(sca)%ars3, & - catch(sca)%ara1, catch(sca)%ara2, catch(sca)%ara3, catch(sca)%ara4, & - catch(sca)%arw1, catch(sca)%arw2, catch(sca)%arw3, catch(sca)%arw4, & - catch(sca)%bf1, catch(sca)%bf2, & - catch(sca)%srfexc, catch(sca)%rzexc, catch(sca)%catdef, & - ar1, ar2, ar4 ) - - n = count( catch(sca)%catdef .ne. catch(new)%catdef ) - write(6,300) n,100*n/ntiles - n = count( catch(sca)%srfexc .ne. catch(new)%srfexc ) - write(6,400) n,100*n/ntiles - n = count( catch(sca)%rzexc .ne. catch(new)%rzexc ) - write(6,400) n,100*n/ntiles - -! (2) Ground heat -! --------------- - - allocate (TP_IN (N_GT, Ntiles)) - allocate (GHT_IN (N_GT, Ntiles)) - allocate (GHT_OUT(N_GT, Ntiles)) - allocate (FICE (N_GT, NTILES)) - allocate (TP_OUT (N_GT, Ntiles)) - - GHT_IN (1,:) = catch(old)%ghtcnt1 - GHT_IN (2,:) = catch(old)%ghtcnt2 - GHT_IN (3,:) = catch(old)%ghtcnt3 - GHT_IN (4,:) = catch(old)%ghtcnt4 - GHT_IN (5,:) = catch(old)%ghtcnt5 - GHT_IN (6,:) = catch(old)%ghtcnt6 - - call catch_calc_tp ( NTILES, catch(old)%poros, GHT_IN, tp_in, FICE) - GHT_OUT = GHT_IN - -! open (99,file='ght.diff', form = 'formatted') - - do n = 1, ntiles - do i = 1, N_GT - call catch_calc_ght(dzgt(i), catch(new)%poros(n), tp_in(i,n), fice(i,n), GHT_IN(i,n)) -! if (i == N_GT) then -! if (GHT_IN(i,n) /= GHT_OUT(i,n)) write (99,*)n,catch(old)%poros(n),catch(new)%poros(n),ABS(GHT_IN(i,n)-GHT_OUT(i,n)) -! endif - end do - end do - - catch(sca)%ghtcnt1 = GHT_IN (1,:) - catch(sca)%ghtcnt2 = GHT_IN (2,:) - catch(sca)%ghtcnt3 = GHT_IN (3,:) - catch(sca)%ghtcnt4 = GHT_IN (4,:) - catch(sca)%ghtcnt5 = GHT_IN (5,:) - catch(sca)%ghtcnt6 = GHT_IN (6,:) - -! Deep soil temp sanity check -! --------------------------- - - call catch_calc_tp ( NTILES, catch(new)%poros, GHT_IN, tp_out, FICE) - - print *, 'Percent tiles TP Layer 1 differ : ', 100.* count(ABS(tp_out(1,:) - tp_in(1,:)) > 1.e-5) /float (Ntiles) - print *, 'Percent tiles TP Layer 2 differ : ', 100.* count(ABS(tp_out(2,:) - tp_in(2,:)) > 1.e-5) /float (Ntiles) - print *, 'Percent tiles TP Layer 3 differ : ', 100.* count(ABS(tp_out(3,:) - tp_in(3,:)) > 1.e-5) /float (Ntiles) - print *, 'Percent tiles TP Layer 4 differ : ', 100.* count(ABS(tp_out(4,:) - tp_in(4,:)) > 1.e-5) /float (Ntiles) - print *, 'Percent tiles TP Layer 5 differ : ', 100.* count(ABS(tp_out(5,:) - tp_in(5,:)) > 1.e-5) /float (Ntiles) - print *, 'Percent tiles TP Layer 6 differ : ', 100.* count(ABS(tp_out(6,:) - tp_in(6,:)) > 1.e-5) /float (Ntiles) - - -! SNOW scaling -! ------------ - - if(wemin_out /= wemin_in) then - - allocate (swe_in (Ntiles)) - allocate (depth_in (Ntiles)) - allocate (depth_out (Ntiles)) - allocate (areasc_in (Ntiles)) - allocate (areasc_out (Ntiles)) - - swe_in = catch(new)%wesnn1 + catch(new)%wesnn2 + catch(new)%wesnn3 - depth_in = catch(new)%sndzn1 + catch(new)%sndzn2 + catch(new)%sndzn3 - areasc_in = min(swe_in/wemin_in, 1.) - areasc_out= min(swe_in/wemin_out,1.) - - ! catch(sca)%sndzn1=catch(old)%sndzn1 - ! catch(sca)%sndzn2=catch(old)%sndzn2 - ! catch(sca)%sndzn3=catch(old)%sndzn3 - ! do i = 1, ntiles - ! if((swe_in(i) > 0.).and. ((areasc_in(i) < 1.).OR.(areasc_out(i) < 1.))) then - ! print *, i, areasc_in(i), depth_in(i) - ! density_in(i)= swe_in(i)/(areasc_in(i) * depth_in(i)) - ! depth_out(i) = swe_in(i)/(areasc_out(i)*density_in(i)) - ! depth_out(i) = areasc_in(i) * depth_in(i)/(areasc_out(i) + 1.e-20) - ! print *, catch(sca)%sndzn1(i), catch(old)%sndzn1(i),wemin_out/wemin_in - ! catch(sca)%sndzn1(i) = catch(new)%sndzn1(i)*wemin_out/wemin_in ! depth_out(i)/3. - ! catch(sca)%sndzn2(i) = catch(new)%sndzn2(i)*wemin_out/wemin_in ! depth_out(i)/3. - ! catch(sca)%sndzn3(i) = catch(new)%sndzn3(i)*wemin_out/wemin_in ! depth_out(i)/3. - ! endif - ! end do - - where (swe_in .gt. 0.) - where (areasc_in .lt. 1. .or. areasc_out .lt. 1.) - ! density_in= swe_in/(areasc_in * depth_in + 1.e-20) - ! depth_out = swe_in/(areasc_out*density_in) - depth_out = areasc_in * depth_in/(areasc_out + 1.e-20) - catch(sca)%sndzn1 = depth_out/3. - catch(sca)%sndzn2 = depth_out/3. - catch(sca)%sndzn3 = depth_out/3. - endwhere - endwhere - - print *, 'Snow scaling summary' - print *, '....................' - print *, 'Percent tiles SNDZ scaled : ', 100.* count (catch(sca)%sndzn3 .ne. catch(old)%sndzn3) /float (count (catch(sca)%sndzn3 > 0.)) - - endif - - ! PEATCLSM - ensure low CATDEF on peat tiles where "old" restart is not also peat - ! ------------------------------------------------------------------------------- - - where ( (catch(old)%poros < PEATCLSM_POROS_THRESHOLD) .and. (catch(sca)%poros >= PEATCLSM_POROS_THRESHOLD) ) - catch(sca)%catdef = 25. - catch(sca)%rzexc = 0. - catch(sca)%srfexc = 0. - end where - -! Write Scaled Catch -! ------------------ - if (filetype ==0) then - cfg(3)=cfg(2) - call formatter(3)%create(fname3, __RC__) - call formatter(3)%write(cfg(3), __RC__) - call writecatch_nc4 ( catch(sca), formatter(3) ) - else - call writecatch ( 30,catch(sca) ) - end if - -100 format(1x,'Total Tiles: ',i10) -200 format(1x,'Scaled Tiles: ',i10,2x,'(',i2.2,'%)') -300 format(1x,'CatDef Tiles: ',i10,2x,'(',i2.2,'%)') -400 format(1x,'SrfExc Tiles: ',i10,2x,'(',i2.2,'%)') -500 format(1x,' Rzexc Tiles: ',i10,2x,'(',i2.2,'%)') - - stop - - contains - - subroutine allocatch (ntiles,catch) - - integer ntiles - - type(catch_rst) catch - - allocate( catch% bf1(ntiles) ) - allocate( catch% bf2(ntiles) ) - allocate( catch% bf3(ntiles) ) - allocate( catch% vgwmax(ntiles) ) - allocate( catch% cdcr1(ntiles) ) - allocate( catch% cdcr2(ntiles) ) - allocate( catch% psis(ntiles) ) - allocate( catch% bee(ntiles) ) - allocate( catch% poros(ntiles) ) - allocate( catch% wpwet(ntiles) ) - allocate( catch% cond(ntiles) ) - allocate( catch% gnu(ntiles) ) - allocate( catch% ars1(ntiles) ) - allocate( catch% ars2(ntiles) ) - allocate( catch% ars3(ntiles) ) - allocate( catch% ara1(ntiles) ) - allocate( catch% ara2(ntiles) ) - allocate( catch% ara3(ntiles) ) - allocate( catch% ara4(ntiles) ) - allocate( catch% arw1(ntiles) ) - allocate( catch% arw2(ntiles) ) - allocate( catch% arw3(ntiles) ) - allocate( catch% arw4(ntiles) ) - allocate( catch% tsa1(ntiles) ) - allocate( catch% tsa2(ntiles) ) - allocate( catch% tsb1(ntiles) ) - allocate( catch% tsb2(ntiles) ) - allocate( catch% atau(ntiles) ) - allocate( catch% btau(ntiles) ) - allocate( catch% ity(ntiles) ) - allocate( catch% tc(ntiles,4) ) - allocate( catch% qc(ntiles,4) ) - allocate( catch% capac(ntiles) ) - allocate( catch% catdef(ntiles) ) - allocate( catch% rzexc(ntiles) ) - allocate( catch% srfexc(ntiles) ) - allocate( catch% ghtcnt1(ntiles) ) - allocate( catch% ghtcnt2(ntiles) ) - allocate( catch% ghtcnt3(ntiles) ) - allocate( catch% ghtcnt4(ntiles) ) - allocate( catch% ghtcnt5(ntiles) ) - allocate( catch% ghtcnt6(ntiles) ) - allocate( catch% tsurf(ntiles) ) - allocate( catch% wesnn1(ntiles) ) - allocate( catch% wesnn2(ntiles) ) - allocate( catch% wesnn3(ntiles) ) - allocate( catch% htsnnn1(ntiles) ) - allocate( catch% htsnnn2(ntiles) ) - allocate( catch% htsnnn3(ntiles) ) - allocate( catch% sndzn1(ntiles) ) - allocate( catch% sndzn2(ntiles) ) - allocate( catch% sndzn3(ntiles) ) - allocate( catch% ch(ntiles,4) ) - allocate( catch% cm(ntiles,4) ) - allocate( catch% cq(ntiles,4) ) - allocate( catch% fr(ntiles,4) ) - allocate( catch% ww(ntiles,4) ) - - return - end subroutine allocatch - - subroutine readcatch_nc4 (catch,formatter, rc) - type(catch_rst) catch - type(Netcdf4_fileformatter) :: formatter - integer, optional, intent(out) :: rc - integer :: status - character(256) :: Iam = "readcatch_nc4" - - call MAPL_VarRead(formatter,"BF1",catch%bf1, __RC__) - call MAPL_VarRead(formatter,"BF2",catch%bf2, __RC__) - call MAPL_VarRead(formatter,"BF3",catch%bf3, __RC__) - call MAPL_VarRead(formatter,"VGWMAX",catch%vgwmax, __RC__) - call MAPL_VarRead(formatter,"CDCR1",catch%cdcr1, __RC__) - call MAPL_VarRead(formatter,"CDCR2",catch%cdcr2, __RC__) - call MAPL_VarRead(formatter,"PSIS",catch%psis, __RC__) - call MAPL_VarRead(formatter,"BEE",catch%bee, __RC__) - call MAPL_VarRead(formatter,"POROS",catch%poros, __RC__) - call MAPL_VarRead(formatter,"WPWET",catch%wpwet, __RC__) - call MAPL_VarRead(formatter,"COND",catch%cond, __RC__) - call MAPL_VarRead(formatter,"GNU",catch%gnu, __RC__) - call MAPL_VarRead(formatter,"ARS1",catch%ars1, __RC__) - call MAPL_VarRead(formatter,"ARS2",catch%ars2, __RC__) - call MAPL_VarRead(formatter,"ARS3",catch%ars3, __RC__) - call MAPL_VarRead(formatter,"ARA1",catch%ara1, __RC__) - call MAPL_VarRead(formatter,"ARA2",catch%ara2, __RC__) - call MAPL_VarRead(formatter,"ARA3",catch%ara3, __RC__) - call MAPL_VarRead(formatter,"ARA4",catch%ara4, __RC__) - call MAPL_VarRead(formatter,"ARW1",catch%arw1, __RC__) - call MAPL_VarRead(formatter,"ARW2",catch%arw2, __RC__) - call MAPL_VarRead(formatter,"ARW3",catch%arw3, __RC__) - call MAPL_VarRead(formatter,"ARW4",catch%arw4, __RC__) - call MAPL_VarRead(formatter,"TSA1",catch%tsa1, __RC__) - call MAPL_VarRead(formatter,"TSA2",catch%tsa2, __RC__) - call MAPL_VarRead(formatter,"TSB1",catch%tsb1, __RC__) - call MAPL_VarRead(formatter,"TSB2",catch%tsb2, __RC__) - call MAPL_VarRead(formatter,"ATAU",catch%atau, __RC__) - call MAPL_VarRead(formatter,"BTAU",catch%btau, __RC__) - call MAPL_VarRead(formatter,"OLD_ITY",catch%ity, __RC__) - call MAPL_VarRead(formatter,"TC",catch%tc, __RC__) - call MAPL_VarRead(formatter,"QC",catch%qc, __RC__) - call MAPL_VarRead(formatter,"OLD_ITY",catch%ity, __RC__) - call MAPL_VarRead(formatter,"CAPAC",catch%capac, __RC__) - call MAPL_VarRead(formatter,"CATDEF",catch%catdef, __RC__) - call MAPL_VarRead(formatter,"RZEXC",catch%rzexc, __RC__) - call MAPL_VarRead(formatter,"SRFEXC",catch%srfexc, __RC__) - call MAPL_VarRead(formatter,"GHTCNT1",catch%ghtcnt1, __RC__) - call MAPL_VarRead(formatter,"GHTCNT2",catch%ghtcnt2, __RC__) - call MAPL_VarRead(formatter,"GHTCNT3",catch%ghtcnt3, __RC__) - call MAPL_VarRead(formatter,"GHTCNT4",catch%ghtcnt4, __RC__) - call MAPL_VarRead(formatter,"GHTCNT5",catch%ghtcnt5, __RC__) - call MAPL_VarRead(formatter,"GHTCNT6",catch%ghtcnt6, __RC__) - call MAPL_VarRead(formatter,"TSURF",catch%tsurf, __RC__) - call MAPL_VarRead(formatter,"WESNN1",catch%wesnn1, __RC__) - call MAPL_VarRead(formatter,"WESNN2",catch%wesnn2, __RC__) - call MAPL_VarRead(formatter,"WESNN3",catch%wesnn3, __RC__) - call MAPL_VarRead(formatter,"HTSNNN1",catch%htsnnn1, __RC__) - call MAPL_VarRead(formatter,"HTSNNN2",catch%htsnnn2, __RC__) - call MAPL_VarRead(formatter,"HTSNNN3",catch%htsnnn3, __RC__) - call MAPL_VarRead(formatter,"SNDZN1",catch%sndzn1, __RC__) - call MAPL_VarRead(formatter,"SNDZN2",catch%sndzn2, __RC__) - call MAPL_VarRead(formatter,"SNDZN3",catch%sndzn3, __RC__) - call MAPL_VarRead(formatter,"CH",catch%ch, __RC__) - call MAPL_VarRead(formatter,"CM",catch%cm, __RC__) - call MAPL_VarRead(formatter,"CQ",catch%cq, __RC__) - call MAPL_VarRead(formatter,"FR",catch%fr, __RC__) - call MAPL_VarRead(formatter,"WW",catch%ww, __RC__) - if (present(rc)) rc =0 - !_RETURN(_SUCCESS) - end subroutine readcatch_nc4 - - subroutine readcatch (unit,catch) - integer unit - type(catch_rst) catch - - read(unit) catch% bf1 - read(unit) catch% bf2 - read(unit) catch% bf3 - read(unit) catch% vgwmax - read(unit) catch% cdcr1 - read(unit) catch% cdcr2 - read(unit) catch% psis - read(unit) catch% bee - read(unit) catch% poros - read(unit) catch% wpwet - read(unit) catch% cond - read(unit) catch% gnu - read(unit) catch% ars1 - read(unit) catch% ars2 - read(unit) catch% ars3 - read(unit) catch% ara1 - read(unit) catch% ara2 - read(unit) catch% ara3 - read(unit) catch% ara4 - read(unit) catch% arw1 - read(unit) catch% arw2 - read(unit) catch% arw3 - read(unit) catch% arw4 - read(unit) catch% tsa1 - read(unit) catch% tsa2 - read(unit) catch% tsb1 - read(unit) catch% tsb2 - read(unit) catch% atau - read(unit) catch% btau - read(unit) catch% ity - read(unit) catch% tc - read(unit) catch% qc - read(unit) catch% capac - read(unit) catch% catdef - read(unit) catch% rzexc - read(unit) catch% srfexc - read(unit) catch% ghtcnt1 - read(unit) catch% ghtcnt2 - read(unit) catch% ghtcnt3 - read(unit) catch% ghtcnt4 - read(unit) catch% ghtcnt5 - read(unit) catch% ghtcnt6 - read(unit) catch% tsurf - read(unit) catch% wesnn1 - read(unit) catch% wesnn2 - read(unit) catch% wesnn3 - read(unit) catch% htsnnn1 - read(unit) catch% htsnnn2 - read(unit) catch% htsnnn3 - read(unit) catch% sndzn1 - read(unit) catch% sndzn2 - read(unit) catch% sndzn3 - read(unit) catch% ch - read(unit) catch% cm - read(unit) catch% cq - read(unit) catch% fr - read(unit) catch% ww - - return - end subroutine readcatch - - subroutine writecatch_nc4 (catch,formatter) - type(catch_rst) catch - type(Netcdf4_fileformatter) :: formatter - - call MAPL_VarWrite(formatter,"BF1",catch%bf1) - call MAPL_VarWrite(formatter,"BF2",catch%bf2) - call MAPL_VarWrite(formatter,"BF3",catch%bf3) - call MAPL_VarWrite(formatter,"VGWMAX",catch%vgwmax) - call MAPL_VarWrite(formatter,"CDCR1",catch%cdcr1) - call MAPL_VarWrite(formatter,"CDCR2",catch%cdcr2) - call MAPL_VarWrite(formatter,"PSIS",catch%psis) - call MAPL_VarWrite(formatter,"BEE",catch%bee) - call MAPL_VarWrite(formatter,"POROS",catch%poros) - call MAPL_VarWrite(formatter,"WPWET",catch%wpwet) - call MAPL_VarWrite(formatter,"COND",catch%cond) - call MAPL_VarWrite(formatter,"GNU",catch%gnu) - call MAPL_VarWrite(formatter,"ARS1",catch%ars1) - call MAPL_VarWrite(formatter,"ARS2",catch%ars2) - call MAPL_VarWrite(formatter,"ARS3",catch%ars3) - call MAPL_VarWrite(formatter,"ARA1",catch%ara1) - call MAPL_VarWrite(formatter,"ARA2",catch%ara2) - call MAPL_VarWrite(formatter,"ARA3",catch%ara3) - call MAPL_VarWrite(formatter,"ARA4",catch%ara4) - call MAPL_VarWrite(formatter,"ARW1",catch%arw1) - call MAPL_VarWrite(formatter,"ARW2",catch%arw2) - call MAPL_VarWrite(formatter,"ARW3",catch%arw3) - call MAPL_VarWrite(formatter,"ARW4",catch%arw4) - call MAPL_VarWrite(formatter,"TSA1",catch%tsa1) - call MAPL_VarWrite(formatter,"TSA2",catch%tsa2) - call MAPL_VarWrite(formatter,"TSB1",catch%tsb1) - call MAPL_VarWrite(formatter,"TSB2",catch%tsb2) - call MAPL_VarWrite(formatter,"ATAU",catch%atau) - call MAPL_VarWrite(formatter,"BTAU",catch%btau) - call MAPL_VarWrite(formatter,"OLD_ITY",catch%ity) - call MAPL_VarWrite(formatter,"TC",catch%tc) - call MAPL_VarWrite(formatter,"QC",catch%qc) - call MAPL_VarWrite(formatter,"OLD_ITY",catch%ity) - call MAPL_VarWrite(formatter,"CAPAC",catch%capac) - call MAPL_VarWrite(formatter,"CATDEF",catch%catdef) - call MAPL_VarWrite(formatter,"RZEXC",catch%rzexc) - call MAPL_VarWrite(formatter,"SRFEXC",catch%srfexc) - call MAPL_VarWrite(formatter,"GHTCNT1",catch%ghtcnt1) - call MAPL_VarWrite(formatter,"GHTCNT2",catch%ghtcnt2) - call MAPL_VarWrite(formatter,"GHTCNT3",catch%ghtcnt3) - call MAPL_VarWrite(formatter,"GHTCNT4",catch%ghtcnt4) - call MAPL_VarWrite(formatter,"GHTCNT5",catch%ghtcnt5) - call MAPL_VarWrite(formatter,"GHTCNT6",catch%ghtcnt6) - call MAPL_VarWrite(formatter,"TSURF",catch%tsurf) - call MAPL_VarWrite(formatter,"WESNN1",catch%wesnn1) - call MAPL_VarWrite(formatter,"WESNN2",catch%wesnn2) - call MAPL_VarWrite(formatter,"WESNN3",catch%wesnn3) - call MAPL_VarWrite(formatter,"HTSNNN1",catch%htsnnn1) - call MAPL_VarWrite(formatter,"HTSNNN2",catch%htsnnn2) - call MAPL_VarWrite(formatter,"HTSNNN3",catch%htsnnn3) - call MAPL_VarWrite(formatter,"SNDZN1",catch%sndzn1) - call MAPL_VarWrite(formatter,"SNDZN2",catch%sndzn2) - call MAPL_VarWrite(formatter,"SNDZN3",catch%sndzn3) - call MAPL_VarWrite(formatter,"CH",catch%ch) - call MAPL_VarWrite(formatter,"CM",catch%cm) - call MAPL_VarWrite(formatter,"CQ",catch%cq) - call MAPL_VarWrite(formatter,"FR",catch%fr) - call MAPL_VarWrite(formatter,"WW",catch%ww) - - return - end subroutine writecatch_nc4 - - subroutine writecatch (unit,catch) - integer unit - type(catch_rst) catch - - write(unit) catch% bf1 - write(unit) catch% bf2 - write(unit) catch% bf3 - write(unit) catch% vgwmax - write(unit) catch% cdcr1 - write(unit) catch% cdcr2 - write(unit) catch% psis - write(unit) catch% bee - write(unit) catch% poros - write(unit) catch% wpwet - write(unit) catch% cond - write(unit) catch% gnu - write(unit) catch% ars1 - write(unit) catch% ars2 - write(unit) catch% ars3 - write(unit) catch% ara1 - write(unit) catch% ara2 - write(unit) catch% ara3 - write(unit) catch% ara4 - write(unit) catch% arw1 - write(unit) catch% arw2 - write(unit) catch% arw3 - write(unit) catch% arw4 - write(unit) catch% tsa1 - write(unit) catch% tsa2 - write(unit) catch% tsb1 - write(unit) catch% tsb2 - write(unit) catch% atau - write(unit) catch% btau - write(unit) catch% ity - write(unit) catch% tc - write(unit) catch% qc - write(unit) catch% capac - write(unit) catch% catdef - write(unit) catch% rzexc - write(unit) catch% srfexc - write(unit) catch% ghtcnt1 - write(unit) catch% ghtcnt2 - write(unit) catch% ghtcnt3 - write(unit) catch% ghtcnt4 - write(unit) catch% ghtcnt5 - write(unit) catch% ghtcnt6 - write(unit) catch% tsurf - write(unit) catch% wesnn1 - write(unit) catch% wesnn2 - write(unit) catch% wesnn3 - write(unit) catch% htsnnn1 - write(unit) catch% htsnnn2 - write(unit) catch% htsnnn3 - write(unit) catch% sndzn1 - write(unit) catch% sndzn2 - write(unit) catch% sndzn3 - write(unit) catch% ch - write(unit) catch% cm - write(unit) catch% cq - write(unit) catch% fr - write(unit) catch% ww - - return - end subroutine writecatch - - end program diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/Scale_CatchCN.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/Scale_CatchCN.F90 deleted file mode 100755 index cd2bce354..000000000 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/Scale_CatchCN.F90 +++ /dev/null @@ -1,962 +0,0 @@ -#define I_AM_MAIN -#include "MAPL_Generic.h" - -program Scale_CatchCN - - use MAPL - - use LSM_ROUTINES, ONLY: & - catch_calc_soil_moist, & - catch_calc_tp, & - catch_calc_ght - - USE CATCH_CONSTANTS, ONLY: & - N_GT => CATCH_N_GT, & - DZGT => CATCH_DZGT, & - PEATCLSM_POROS_THRESHOLD - - implicit none - - character(256) :: fname1, fname2, fname3 -#ifndef __GFORTRAN__ - integer :: ftell - external :: ftell -#endif - integer :: bpos, epos, ntiles, n, nargs - integer :: old, new, sca - integer :: iargc - real :: SURFLAY ! (Ganymed-3 and earlier) SURFLAY=20.0 for Old Soil Params - ! (Ganymed-4 and later ) SURFLAY=50.0 for New Soil Params - real :: WEMIN_IN, WEMIN_OUT - character*256 :: arg(6) - - integer, parameter :: nveg = 4 - integer, parameter :: nzone = 3 - integer :: VAR_COL, VAR_PFT - integer, parameter :: VAR_COL_CLM40 = 40 ! number of CN column restart variables - integer, parameter :: VAR_PFT_CLM40 = 74 ! number of CN PFT variables per column - integer, parameter :: npft = 19 - integer, parameter :: VAR_COL_CLM45 = 35 ! number of CN column restart variables - integer, parameter :: VAR_PFT_CLM45 = 75 ! number of CN PFT variables per column - - logical :: clm45 = .false. - integer :: un_dim3 - - type catch_rst - real, pointer :: bf1(:) - real, pointer :: bf2(:) - real, pointer :: bf3(:) - real, pointer :: vgwmax(:) - real, pointer :: cdcr1(:) - real, pointer :: cdcr2(:) - real, pointer :: psis(:) - real, pointer :: bee(:) - real, pointer :: poros(:) - real, pointer :: wpwet(:) - real, pointer :: cond(:) - real, pointer :: gnu(:) - real, pointer :: ars1(:) - real, pointer :: ars2(:) - real, pointer :: ars3(:) - real, pointer :: ara1(:) - real, pointer :: ara2(:) - real, pointer :: ara3(:) - real, pointer :: ara4(:) - real, pointer :: arw1(:) - real, pointer :: arw2(:) - real, pointer :: arw3(:) - real, pointer :: arw4(:) - real, pointer :: tsa1(:) - real, pointer :: tsa2(:) - real, pointer :: tsb1(:) - real, pointer :: tsb2(:) - real, pointer :: atau(:) - real, pointer :: btau(:) - real, pointer :: ity(:,:) - real, pointer :: fvg(:,:) - real, pointer :: tc(:,:) - real, pointer :: qc(:,:) - real, pointer :: tg(:,:) - real, pointer :: capac(:) - real, pointer :: catdef(:) - real, pointer :: rzexc(:) - real, pointer :: srfexc(:) - real, pointer :: ghtcnt1(:) - real, pointer :: ghtcnt2(:) - real, pointer :: ghtcnt3(:) - real, pointer :: ghtcnt4(:) - real, pointer :: ghtcnt5(:) - real, pointer :: ghtcnt6(:) - real, pointer :: tsurf(:) - real, pointer :: wesnn1(:) - real, pointer :: wesnn2(:) - real, pointer :: wesnn3(:) - real, pointer :: htsnnn1(:) - real, pointer :: htsnnn2(:) - real, pointer :: htsnnn3(:) - real, pointer :: sndzn1(:) - real, pointer :: sndzn2(:) - real, pointer :: sndzn3(:) - real, pointer :: ch(:,:) - real, pointer :: cm(:,:) - real, pointer :: cq(:,:) - real, pointer :: fr(:,:) - real, pointer :: ww(:,:) - real, pointer :: TILE_ID(:) - real, pointer :: ndep(:) - real, pointer :: t2(:) - real, pointer :: BGALBVR(:) - real, pointer :: BGALBVF(:) - real, pointer :: BGALBNR(:) - real, pointer :: BGALBNF(:) - real, pointer :: CNCOL(:,:) - real, pointer :: CNPFT(:,:) - real, pointer :: ABM (:) - real, pointer :: FIELDCAP(:) - real, pointer :: HDM (:) - real, pointer :: GDP (:) - real, pointer :: PEATF (:) - endtype catch_rst - - type(catch_rst) catch(3) - - real, allocatable, dimension(:) :: dzsf, ar1, ar2, ar4 - real, allocatable, dimension(:,:) :: TP_IN, GHT_IN, FICE, GHT_OUT, TP_OUT - real, allocatable, dimension(:) :: swe_in, depth_in, areasc_in, areasc_out, depth_out - - type(Netcdf4_fileformatter) :: formatter(3) - type(Filemetadata) :: cfg(3) - integer :: i, rc, filetype - integer :: status - character(256) :: Iam = "Scale_CatchCN" - -! Usage -! ----- - if (iargc() /= 6) then - write(*,*) "Usage: Scale_CatchCN " - call exit(2) - end if - - do n=1,6 - call getarg(n,arg(n)) - enddo - -! Open INPUT and Regridded Catch Files -! ------------------------------------ - read(arg(1),'(a)') fname1 - - read(arg(2),'(a)') fname2 - -! Open OUTPUT (Scaled) Catch File -! ------------------------------- - read(arg(3),'(a)') fname3 - - call MAPL_NCIOGetFileType(fname1, filetype, __RC__) - - if (filetype == 0) then - call formatter(1)%open(trim(fname1),pFIO_READ, __RC__) - call formatter(2)%open(trim(fname2),pFIO_READ, __RC__) - cfg(1)=formatter(1)%read(__RC__) - cfg(2)=formatter(2)%read(__RC__) - ! else - ! open(unit=10, file=trim(fname1), form='unformatted') - ! open(unit=20, file=trim(fname2), form='unformatted') - ! open(unit=30, file=trim(fname3), form='unformatted') - end if - -! Get SURFLAY Value -! ----------------- - read(arg(4),*) SURFLAY - read(arg(5),*) WEMIN_IN - read(arg(6),*) WEMIN_OUT - - if (SURFLAY.ne.20 .and. SURFLAY.ne.50) then - print *, "You must supply a valid SURFLAY value:" - print *, "(Ganymed-3 and earlier) SURFLAY=20.0 for Old Soil Params" - print *, "(Ganymed-4 and later ) SURFLAY=50.0 for New Soil Params" - call exit(2) - end if - print *, 'SURFLAY: ',SURFLAY - - VAR_COL = VAR_COL_CLM40 - VAR_PFT = VAR_PFT_CLM40 - - if (filetype ==0) then - - ntiles = cfg(1)%get_dimension('tile', __RC__) - un_dim3 = cfg(1)%get_dimension('unknown_dim3', __RC__) - if(un_dim3 == 105) then - clm45 = .true. - VAR_COL = VAR_COL_CLM45 - VAR_PFT = VAR_PFT_CLM45 - print *, 'Processing CLM45 restarts : ', VAR_COL, VAR_PFT, clm45 - else - print *, 'Processing CLM40 restarts : ', VAR_COL, VAR_PFT, clm45 - endif -! else -! -!! Determine NTILES -!! ---------------- -! bpos=0 -! read(10) -! epos = ftell(10) ! ending position of file pointer -! ntiles = (epos-bpos)/4-2 ! record size (in 4 byte words; -! rewind 10 - - end if - - write(6,100) ntiles - -! Allocate Catches -! ---------------- - do n=1,3 - call allocatch ( ntiles,catch(n) ) - enddo - -! Read INPUT Catches -! ------------------ - old = 1 - new = 2 - - if (filetype ==0) then - call readcatchcn_nc4 ( catch(old), formatter(old), cfg(old), __RC__ ) - call readcatchcn_nc4 ( catch(new), formatter(new), cfg(new), __RC__ ) -! else -! call readcatchcn ( 10,catch(old) ) -! call readcatchcn ( 20,catch(new) ) - end if - -! Create Scaled Catch -! ------------------- - sca = 3 - - catch(sca) = catch(new) - -! 1) soil moisture prognostics -! ---------------------------- -! n = count( (catch(old)%catdef .gt. catch(old)%cdcr1) .and. & -! (catch(new)%cdcr2 .gt. catch(old)%cdcr2) ) -! -! write(6,200) n,100*n/ntiles -! -! where( (catch(old)%catdef .gt. catch(old)%cdcr1) .and. & -! (catch(new)%cdcr2 .gt. catch(old)%cdcr2) ) -! -! catch(sca)%rzexc = catch(old)%rzexc * ( catch(new)%vgwmax / & -! catch(old)%vgwmax ) -! -! catch(sca)%catdef = catch(new)%cdcr1 + & -! ( catch(old)%catdef-catch(old)%cdcr1 ) / & -! ( catch(old)%cdcr2 -catch(old)%cdcr1 ) * & -! ( catch(new)%cdcr2 -catch(new)%cdcr1 ) -! end where - - n =count((catch(old)%catdef .gt. catch(old)%cdcr1)) - - write(6,200) n,100*n/ntiles - -! Scale rxexc regardless of CDCR1, CDCR2 differences -! -------------------------------------------------- - catch(sca)%rzexc = catch(old)%rzexc * ( catch(new)%vgwmax / & - catch(old)%vgwmax ) - -! Scale catdef regardless of whether CDCR2 is larger or smaller in the new situation -! ---------------------------------------------------------------------------------- - where (catch(old)%catdef .gt. catch(old)%cdcr1) - - catch(sca)%catdef = catch(new)%cdcr1 + & - ( catch(old)%catdef-catch(old)%cdcr1 ) / & - ( catch(old)%cdcr2 -catch(old)%cdcr1 ) * & - ( catch(new)%cdcr2 -catch(new)%cdcr1 ) - end where - -! Scale catdef also for the case where catdef le cdcr1. -! ----------------------------------------------------- - where( (catch(old)%catdef .le. catch(old)%cdcr1)) - catch(sca)%catdef = catch(old)%catdef * (catch(new)%cdcr1 / catch(old)%cdcr1) - end where - -! Sanity Check (catch_calc_soil_moist() forces consistency betw. srfexc, rzexc, catdef) -! ------------ - print *, 'Performing Sanity Check ...' - allocate ( dzsf(ntiles) ) - allocate ( ar1( ntiles) ) - allocate ( ar2( ntiles) ) - allocate ( ar4( ntiles) ) - - dzsf = SURFLAY - - call catch_calc_soil_moist( ntiles, dzsf, & - catch(sca)%vgwmax, catch(sca)%cdcr1, catch(sca)%cdcr2, & - catch(sca)%psis, catch(sca)%bee, catch(sca)%poros, catch(sca)%wpwet, & - catch(sca)%ars1, catch(sca)%ars2, catch(sca)%ars3, & - catch(sca)%ara1, catch(sca)%ara2, catch(sca)%ara3, catch(sca)%ara4, & - catch(sca)%arw1, catch(sca)%arw2, catch(sca)%arw3, catch(sca)%arw4, & - catch(sca)%bf1, catch(sca)%bf2, & - catch(sca)%srfexc, catch(sca)%rzexc, catch(sca)%catdef, & - ar1, ar2, ar4 ) - - n = count( catch(sca)%catdef .ne. catch(new)%catdef ) - write(6,300) n,100*n/ntiles - n = count( catch(sca)%srfexc .ne. catch(new)%srfexc ) - write(6,400) n,100*n/ntiles - n = count( catch(sca)%rzexc .ne. catch(new)%rzexc ) - write(6,400) n,100*n/ntiles - -! (2) Ground heat -! --------------- - - allocate (TP_IN (N_GT, Ntiles)) - allocate (GHT_IN (N_GT, Ntiles)) - allocate (GHT_OUT(N_GT, Ntiles)) - allocate (FICE (N_GT, NTILES)) - allocate (TP_OUT (N_GT, Ntiles)) - - GHT_IN (1,:) = catch(old)%ghtcnt1 - GHT_IN (2,:) = catch(old)%ghtcnt2 - GHT_IN (3,:) = catch(old)%ghtcnt3 - GHT_IN (4,:) = catch(old)%ghtcnt4 - GHT_IN (5,:) = catch(old)%ghtcnt5 - GHT_IN (6,:) = catch(old)%ghtcnt6 - - call catch_calc_tp ( NTILES, catch(old)%poros, GHT_IN, tp_in, FICE) - GHT_OUT = GHT_IN - -! open (99,file='ght.diff', form = 'formatted') - - do n = 1, ntiles - do i = 1, N_GT - call catch_calc_ght(dzgt(i), catch(new)%poros(n), tp_in(i,n), fice(i,n), GHT_IN(i,n)) -! if (i == N_GT) then -! if (GHT_IN(i,n) /= GHT_OUT(i,n)) write (99,*)n,catch(old)%poros(n),catch(new)%poros(n),ABS(GHT_IN(i,n)-GHT_OUT(i,n)) -! endif - end do - end do - - catch(sca)%ghtcnt1 = GHT_IN (1,:) - catch(sca)%ghtcnt2 = GHT_IN (2,:) - catch(sca)%ghtcnt3 = GHT_IN (3,:) - catch(sca)%ghtcnt4 = GHT_IN (4,:) - catch(sca)%ghtcnt5 = GHT_IN (5,:) - catch(sca)%ghtcnt6 = GHT_IN (6,:) - -! Deep soil temp sanity check -! --------------------------- - - call catch_calc_tp ( NTILES, catch(new)%poros, GHT_IN, tp_out, FICE) - - print *, 'Percent tiles TP Layer 1 differ : ', 100.* count(ABS(tp_out(1,:) - tp_in(1,:)) > 1.e-5) /float (Ntiles) - print *, 'Percent tiles TP Layer 2 differ : ', 100.* count(ABS(tp_out(2,:) - tp_in(2,:)) > 1.e-5) /float (Ntiles) - print *, 'Percent tiles TP Layer 3 differ : ', 100.* count(ABS(tp_out(3,:) - tp_in(3,:)) > 1.e-5) /float (Ntiles) - print *, 'Percent tiles TP Layer 4 differ : ', 100.* count(ABS(tp_out(4,:) - tp_in(4,:)) > 1.e-5) /float (Ntiles) - print *, 'Percent tiles TP Layer 5 differ : ', 100.* count(ABS(tp_out(5,:) - tp_in(5,:)) > 1.e-5) /float (Ntiles) - print *, 'Percent tiles TP Layer 6 differ : ', 100.* count(ABS(tp_out(6,:) - tp_in(6,:)) > 1.e-5) /float (Ntiles) - - -! SNOW scaling -! ------------ - - if(wemin_out /= wemin_in) then - - allocate (swe_in (Ntiles)) - allocate (depth_in (Ntiles)) - allocate (depth_out (Ntiles)) - allocate (areasc_in (Ntiles)) - allocate (areasc_out (Ntiles)) - - swe_in = catch(new)%wesnn1 + catch(new)%wesnn2 + catch(new)%wesnn3 - depth_in = catch(new)%sndzn1 + catch(new)%sndzn2 + catch(new)%sndzn3 - areasc_in = min(swe_in/wemin_in, 1.) - areasc_out= min(swe_in/wemin_out,1.) - - ! catch(sca)%sndzn1=catch(old)%sndzn1 - ! catch(sca)%sndzn2=catch(old)%sndzn2 - ! catch(sca)%sndzn3=catch(old)%sndzn3 - ! do i = 1, ntiles - ! if((swe_in(i) > 0.).and. ((areasc_in(i) < 1.).OR.(areasc_out(i) < 1.))) then - ! print *, i, areasc_in(i), depth_in(i) - ! density_in(i)= swe_in(i)/(areasc_in(i) * depth_in(i)) - ! depth_out(i) = swe_in(i)/(areasc_out(i)*density_in(i)) - ! depth_out(i) = areasc_in(i) * depth_in(i)/(areasc_out(i) + 1.e-20) - ! print *, catch(sca)%sndzn1(i), catch(old)%sndzn1(i),wemin_out/wemin_in - ! catch(sca)%sndzn1(i) = catch(new)%sndzn1(i)*wemin_out/wemin_in ! depth_out(i)/3. - ! catch(sca)%sndzn2(i) = catch(new)%sndzn2(i)*wemin_out/wemin_in ! depth_out(i)/3. - ! catch(sca)%sndzn3(i) = catch(new)%sndzn3(i)*wemin_out/wemin_in ! depth_out(i)/3. - ! endif - ! end do - - where (swe_in .gt. 0.) - where (areasc_in .lt. 1. .or. areasc_out .lt. 1.) - ! density_in= swe_in/(areasc_in * depth_in + 1.e-20) - ! depth_out = swe_in/(areasc_out*density_in) - depth_out = areasc_in * depth_in/(areasc_out + 1.e-20) - catch(sca)%sndzn1 = depth_out/3. - catch(sca)%sndzn2 = depth_out/3. - catch(sca)%sndzn3 = depth_out/3. - endwhere - endwhere - - print *, 'Snow scaling summary' - print *, '....................' - print *, 'Percent tiles SNDZ scaled : ', 100.* count (catch(sca)%sndzn3 .ne. catch(old)%sndzn3) /float (count (catch(sca)%sndzn3 > 0.)) - - endif - - ! PEATCLSM - ensure low CATDEF on peat tiles where "old" restart is not also peat - ! ------------------------------------------------------------------------------- - - where ( (catch(old)%poros < PEATCLSM_POROS_THRESHOLD) .and. (catch(sca)%poros >= PEATCLSM_POROS_THRESHOLD) ) - catch(sca)%catdef = 25. - catch(sca)%rzexc = 0. - catch(sca)%srfexc = 0. - end where - -! Write Scaled Catch -! ------------------ - if (filetype ==0) then - cfg(3)=cfg(2) - call formatter(3)%create(fname3, __RC__) - call formatter(3)%write(cfg(3), __RC__) - call writecatchcn_nc4 ( catch(sca), formatter(3) ,cfg(3) ) -! else -! call writecatchcn ( 30,catch(sca) ) - end if - -100 format(1x,'Total Tiles: ',i10) -200 format(1x,'Scaled Tiles: ',i10,2x,'(',i2.2,'%)') -300 format(1x,'CatDef Tiles: ',i10,2x,'(',i2.2,'%)') -400 format(1x,'SrfExc Tiles: ',i10,2x,'(',i2.2,'%)') -500 format(1x,' Rzexc Tiles: ',i10,2x,'(',i2.2,'%)') - - stop - - contains - - subroutine allocatch (ntiles,catch) - - integer ntiles - - type(catch_rst) catch - - allocate( catch% bf1(ntiles) ) - allocate( catch% bf2(ntiles) ) - allocate( catch% bf3(ntiles) ) - allocate( catch% vgwmax(ntiles) ) - allocate( catch% cdcr1(ntiles) ) - allocate( catch% cdcr2(ntiles) ) - allocate( catch% psis(ntiles) ) - allocate( catch% bee(ntiles) ) - allocate( catch% poros(ntiles) ) - allocate( catch% wpwet(ntiles) ) - allocate( catch% cond(ntiles) ) - allocate( catch% gnu(ntiles) ) - allocate( catch% ars1(ntiles) ) - allocate( catch% ars2(ntiles) ) - allocate( catch% ars3(ntiles) ) - allocate( catch% ara1(ntiles) ) - allocate( catch% ara2(ntiles) ) - allocate( catch% ara3(ntiles) ) - allocate( catch% ara4(ntiles) ) - allocate( catch% arw1(ntiles) ) - allocate( catch% arw2(ntiles) ) - allocate( catch% arw3(ntiles) ) - allocate( catch% arw4(ntiles) ) - allocate( catch% tsa1(ntiles) ) - allocate( catch% tsa2(ntiles) ) - allocate( catch% tsb1(ntiles) ) - allocate( catch% tsb2(ntiles) ) - allocate( catch% atau(ntiles) ) - allocate( catch% btau(ntiles) ) - allocate( catch% ity(ntiles,4) ) - allocate( catch% fvg(ntiles,4) ) - allocate( catch% tc(ntiles,4) ) - allocate( catch% qc(ntiles,4) ) - allocate( catch% tg(ntiles,4) ) - allocate( catch% capac(ntiles) ) - allocate( catch% catdef(ntiles) ) - allocate( catch% rzexc(ntiles) ) - allocate( catch% srfexc(ntiles) ) - allocate( catch% ghtcnt1(ntiles) ) - allocate( catch% ghtcnt2(ntiles) ) - allocate( catch% ghtcnt3(ntiles) ) - allocate( catch% ghtcnt4(ntiles) ) - allocate( catch% ghtcnt5(ntiles) ) - allocate( catch% ghtcnt6(ntiles) ) - allocate( catch% tsurf(ntiles) ) - allocate( catch% wesnn1(ntiles) ) - allocate( catch% wesnn2(ntiles) ) - allocate( catch% wesnn3(ntiles) ) - allocate( catch% htsnnn1(ntiles) ) - allocate( catch% htsnnn2(ntiles) ) - allocate( catch% htsnnn3(ntiles) ) - allocate( catch% sndzn1(ntiles) ) - allocate( catch% sndzn2(ntiles) ) - allocate( catch% sndzn3(ntiles) ) - allocate( catch% ch(ntiles,4) ) - allocate( catch% cm(ntiles,4) ) - allocate( catch% cq(ntiles,4) ) - allocate( catch% fr(ntiles,4) ) - allocate( catch% ww(ntiles,4) ) - allocate( catch% TILE_ID(ntiles) ) - allocate( catch% ndep(ntiles) ) - allocate( catch% t2(ntiles) ) - allocate( catch% BGALBVR(ntiles) ) - allocate( catch% BGALBVF(ntiles) ) - allocate( catch% BGALBNR(ntiles) ) - allocate( catch% BGALBNF(ntiles) ) - allocate( catch% CNCOL(ntiles,nzone*VAR_COL)) - allocate( catch% CNPFT(ntiles,nzone*nveg*VAR_PFT)) - allocate( catch% ABM(ntiles) ) - allocate( catch% FIELDCAP(ntiles) ) - allocate( catch% HDM(ntiles) ) - allocate( catch% GDP(ntiles) ) - allocate( catch% PEATF(ntiles) ) - - return - end subroutine allocatch - - subroutine readcatchcn_nc4 (catch,formatter,cfg, rc) - type(catch_rst) catch - type(Filemetadata) :: cfg - type(Netcdf4_fileformatter) :: formatter - integer, optional, intent(out) :: rc - integer :: j, dim1,dim2 - type(Variable), pointer :: myVariable - character(len=:), pointer :: dname - integer :: status - character(256) :: Iam = "readcatchcn_nc4" - - call MAPL_VarRead(formatter,"BF1",catch%bf1, __RC__) - call MAPL_VarRead(formatter,"BF2",catch%bf2, __RC__) - call MAPL_VarRead(formatter,"BF3",catch%bf3, __RC__) - call MAPL_VarRead(formatter,"VGWMAX",catch%vgwmax, __RC__) - call MAPL_VarRead(formatter,"CDCR1",catch%cdcr1, __RC__) - call MAPL_VarRead(formatter,"CDCR2",catch%cdcr2, __RC__) - call MAPL_VarRead(formatter,"PSIS",catch%psis, __RC__) - call MAPL_VarRead(formatter,"BEE",catch%bee, __RC__) - call MAPL_VarRead(formatter,"POROS",catch%poros, __RC__) - call MAPL_VarRead(formatter,"WPWET",catch%wpwet, __RC__) - call MAPL_VarRead(formatter,"COND",catch%cond, __RC__) - call MAPL_VarRead(formatter,"GNU",catch%gnu, __RC__) - call MAPL_VarRead(formatter,"ARS1",catch%ars1, __RC__) - call MAPL_VarRead(formatter,"ARS2",catch%ars2, __RC__) - call MAPL_VarRead(formatter,"ARS3",catch%ars3, __RC__) - call MAPL_VarRead(formatter,"ARA1",catch%ara1, __RC__) - call MAPL_VarRead(formatter,"ARA2",catch%ara2, __RC__) - call MAPL_VarRead(formatter,"ARA3",catch%ara3, __RC__) - call MAPL_VarRead(formatter,"ARA4",catch%ara4, __RC__) - call MAPL_VarRead(formatter,"ARW1",catch%arw1, __RC__) - call MAPL_VarRead(formatter,"ARW2",catch%arw2, __RC__) - call MAPL_VarRead(formatter,"ARW3",catch%arw3, __RC__) - call MAPL_VarRead(formatter,"ARW4",catch%arw4, __RC__) - call MAPL_VarRead(formatter,"TSA1",catch%tsa1, __RC__) - call MAPL_VarRead(formatter,"TSA2",catch%tsa2, __RC__) - call MAPL_VarRead(formatter,"TSB1",catch%tsb1, __RC__) - call MAPL_VarRead(formatter,"TSB2",catch%tsb2, __RC__) - call MAPL_VarRead(formatter,"ATAU",catch%atau, __RC__) - call MAPL_VarRead(formatter,"BTAU",catch%btau, __RC__) - - myVariable => cfg%get_variable("ITY") - dname => myVariable%get_ith_dimension(2) - dim1 = cfg%get_dimension(dname) - do j=1,dim1 - call MAPL_VarRead(formatter,"ITY",catch%ity(:,j),offset1=j, __RC__) - call MAPL_VarRead(formatter,"FVG",catch%fvg(:,j),offset1=j, __RC__) - enddo - - call MAPL_VarRead(formatter,"TC",catch%tc, __RC__) - call MAPL_VarRead(formatter,"QC",catch%qc, __RC__) - call MAPL_VarRead(formatter,"TG",catch%tg, __RC__) - call MAPL_VarRead(formatter,"CAPAC",catch%capac, __RC__) - call MAPL_VarRead(formatter,"CATDEF",catch%catdef, __RC__) - call MAPL_VarRead(formatter,"RZEXC",catch%rzexc, __RC__) - call MAPL_VarRead(formatter,"SRFEXC",catch%srfexc, __RC__) - call MAPL_VarRead(formatter,"GHTCNT1",catch%ghtcnt1, __RC__) - call MAPL_VarRead(formatter,"GHTCNT2",catch%ghtcnt2, __RC__) - call MAPL_VarRead(formatter,"GHTCNT3",catch%ghtcnt3, __RC__) - call MAPL_VarRead(formatter,"GHTCNT4",catch%ghtcnt4, __RC__) - call MAPL_VarRead(formatter,"GHTCNT5",catch%ghtcnt5, __RC__) - call MAPL_VarRead(formatter,"GHTCNT6",catch%ghtcnt6, __RC__) - call MAPL_VarRead(formatter,"TSURF",catch%tsurf, __RC__) - call MAPL_VarRead(formatter,"WESNN1",catch%wesnn1, __RC__) - call MAPL_VarRead(formatter,"WESNN2",catch%wesnn2, __RC__) - call MAPL_VarRead(formatter,"WESNN3",catch%wesnn3, __RC__) - call MAPL_VarRead(formatter,"HTSNNN1",catch%htsnnn1, __RC__) - call MAPL_VarRead(formatter,"HTSNNN2",catch%htsnnn2, __RC__) - call MAPL_VarRead(formatter,"HTSNNN3",catch%htsnnn3, __RC__) - call MAPL_VarRead(formatter,"SNDZN1",catch%sndzn1, __RC__) - call MAPL_VarRead(formatter,"SNDZN2",catch%sndzn2, __RC__) - call MAPL_VarRead(formatter,"SNDZN3",catch%sndzn3, __RC__) - call MAPL_VarRead(formatter,"CH",catch%ch, __RC__) - call MAPL_VarRead(formatter,"CM",catch%cm, __RC__) - call MAPL_VarRead(formatter,"CQ",catch%cq, __RC__) - call MAPL_VarRead(formatter,"FR",catch%fr, __RC__) - call MAPL_VarRead(formatter,"WW",catch%ww, __RC__) - call MAPL_VarRead(formatter,"TILE_ID",catch%TILE_ID, __RC__) - call MAPL_VarRead(formatter,"NDEP",catch%ndep, __RC__) - call MAPL_VarRead(formatter,"CLI_T2M",catch%t2, __RC__) - call MAPL_VarRead(formatter,"BGALBVR",catch%BGALBVR, __RC__) - call MAPL_VarRead(formatter,"BGALBVF",catch%BGALBVF, __RC__) - call MAPL_VarRead(formatter,"BGALBNR",catch%BGALBNR, __RC__) - call MAPL_VarRead(formatter,"BGALBNF",catch%BGALBNF, __RC__) - myVariable => cfg%get_variable("CNCOL") - dname => myVariable%get_ith_dimension(2) - dim1 = cfg%get_dimension(dname) - if(clm45) then - call MAPL_VarRead(formatter,"ABM", catch%ABM, __RC__) - call MAPL_VarRead(formatter,"FIELDCAP",catch%FIELDCAP, __RC__) - call MAPL_VarRead(formatter,"HDM", catch%HDM , __RC__) - call MAPL_VarRead(formatter,"GDP", catch%GDP , __RC__) - call MAPL_VarRead(formatter,"PEATF", catch%PEATF , __RC__) - endif - do j=1,dim1 - call MAPL_VarRead(formatter,"CNCOL",catch%CNCOL(:,j),offset1=j, __RC__) - enddo - ! The following three lines were added as a bug fix by smahanam on 5 Oct 2020 - ! (to be merged into the "develop" branch in late 2020): - ! The length of the 2nd dim of CNPFT differs from that of CNCOL. Prior to this fix, - ! CNPFT was not read in its entirety and some elements remained uninitialized (or zero), - ! resulting in bad values in the "regridded" (re-tiled) restart file. - ! This impacted re-tiled restarts for both CNCLM40 and CLCLM45. - ! - reichle, 23 Nov 2020 - myVariable => cfg%get_variable("CNPFT") - dname => myVariable%get_ith_dimension(2) - dim1 = cfg%get_dimension(dname) - do j=1,dim1 - call MAPL_VarRead(formatter,"CNPFT",catch%CNPFT(:,j),offset1=j, __RC__) - enddo - if (present(rc)) rc =0 - !_RETURN(_SUCCESS) - end subroutine readcatchcn_nc4 - - subroutine readcatchcn (unit,catch) - integer unit, i,j,n - type(catch_rst) catch - - read(unit) catch% bf1 - read(unit) catch% bf2 - read(unit) catch% bf3 - read(unit) catch% vgwmax - read(unit) catch% cdcr1 - read(unit) catch% cdcr2 - read(unit) catch% psis - read(unit) catch% bee - read(unit) catch% poros - read(unit) catch% wpwet - read(unit) catch% cond - read(unit) catch% gnu - read(unit) catch% ars1 - read(unit) catch% ars2 - read(unit) catch% ars3 - read(unit) catch% ara1 - read(unit) catch% ara2 - read(unit) catch% ara3 - read(unit) catch% ara4 - read(unit) catch% arw1 - read(unit) catch% arw2 - read(unit) catch% arw3 - read(unit) catch% arw4 - read(unit) catch% tsa1 - read(unit) catch% tsa2 - read(unit) catch% tsb1 - read(unit) catch% tsb2 - read(unit) catch% atau - read(unit) catch% btau - read(unit) catch% ity(:,1) - read(unit) catch% ity(:,2) - read(unit) catch% ity(:,3) - read(unit) catch% ity(:,4) - read(unit) catch% fvg(:,1) - read(unit) catch% fvg(:,2) - read(unit) catch% fvg(:,3) - read(unit) catch% fvg(:,4) - read(unit) catch% tc - read(unit) catch% qc - read(unit) catch% tg - read(unit) catch% capac - read(unit) catch% catdef - read(unit) catch% rzexc - read(unit) catch% srfexc - read(unit) catch% ghtcnt1 - read(unit) catch% ghtcnt2 - read(unit) catch% ghtcnt3 - read(unit) catch% ghtcnt4 - read(unit) catch% ghtcnt5 - read(unit) catch% ghtcnt6 - read(unit) catch% tsurf - read(unit) catch% wesnn1 - read(unit) catch% wesnn2 - read(unit) catch% wesnn3 - read(unit) catch% htsnnn1 - read(unit) catch% htsnnn2 - read(unit) catch% htsnnn3 - read(unit) catch% sndzn1 - read(unit) catch% sndzn2 - read(unit) catch% sndzn3 - read(unit) catch% ch - read(unit) catch% cm - read(unit) catch% cq - read(unit) catch% fr - read(unit) catch% ww - read(unit) catch% TILE_ID - read(unit) catch% ndep - read(unit) catch% t2 - read(unit) catch% BGALBVR - read(unit) catch% BGALBVF - read(unit) catch% BGALBNR - read(unit) catch% BGALBNF - - do j = 1,nzone * VAR_COL - read(unit) catch% CNCOL (:,j) - end do - - do i = 1,nzone * nveg * VAR_PFT - read(unit) catch% CNPFT (:,i) - end do - return - end subroutine readcatchcn - - subroutine writecatchcn_nc4 (catch,formatter,cfg) - type(catch_rst) catch - type(Netcdf4_fileformatter) :: formatter - type(filemetadata) :: cfg - integer :: i,j, dim1,dim2 - real, dimension (:), allocatable :: var - type(Variable), pointer :: myVariable - character(len=:), pointer :: dname - - call MAPL_VarWrite(formatter,"BF1",catch%bf1) - call MAPL_VarWrite(formatter,"BF2",catch%bf2) - call MAPL_VarWrite(formatter,"BF3",catch%bf3) - call MAPL_VarWrite(formatter,"VGWMAX",catch%vgwmax) - call MAPL_VarWrite(formatter,"CDCR1",catch%cdcr1) - call MAPL_VarWrite(formatter,"CDCR2",catch%cdcr2) - call MAPL_VarWrite(formatter,"PSIS",catch%psis) - call MAPL_VarWrite(formatter,"BEE",catch%bee) - call MAPL_VarWrite(formatter,"POROS",catch%poros) - call MAPL_VarWrite(formatter,"WPWET",catch%wpwet) - call MAPL_VarWrite(formatter,"COND",catch%cond) - call MAPL_VarWrite(formatter,"GNU",catch%gnu) - call MAPL_VarWrite(formatter,"ARS1",catch%ars1) - call MAPL_VarWrite(formatter,"ARS2",catch%ars2) - call MAPL_VarWrite(formatter,"ARS3",catch%ars3) - call MAPL_VarWrite(formatter,"ARA1",catch%ara1) - call MAPL_VarWrite(formatter,"ARA2",catch%ara2) - call MAPL_VarWrite(formatter,"ARA3",catch%ara3) - call MAPL_VarWrite(formatter,"ARA4",catch%ara4) - call MAPL_VarWrite(formatter,"ARW1",catch%arw1) - call MAPL_VarWrite(formatter,"ARW2",catch%arw2) - call MAPL_VarWrite(formatter,"ARW3",catch%arw3) - call MAPL_VarWrite(formatter,"ARW4",catch%arw4) - call MAPL_VarWrite(formatter,"TSA1",catch%tsa1) - call MAPL_VarWrite(formatter,"TSA2",catch%tsa2) - call MAPL_VarWrite(formatter,"TSB1",catch%tsb1) - call MAPL_VarWrite(formatter,"TSB2",catch%tsb2) - call MAPL_VarWrite(formatter,"ATAU",catch%atau) - call MAPL_VarWrite(formatter,"BTAU",catch%btau) - - myVariable => cfg%get_variable("ITY") - dname => myVariable%get_ith_dimension(2) - dim1 = cfg%get_dimension(dname) - do j=1,dim1 - call MAPL_VarWrite(formatter,"ITY",catch%ity(:,j),offset1=j) - call MAPL_VarWrite(formatter,"FVG",catch%fvg(:,j),offset1=j) - enddo - - call MAPL_VarWrite(formatter,"TC",catch%tc) - call MAPL_VarWrite(formatter,"QC",catch%qc) - call MAPL_VarWrite(formatter,"TG",catch%TG) - call MAPL_VarWrite(formatter,"CAPAC",catch%capac) - call MAPL_VarWrite(formatter,"CATDEF",catch%catdef) - call MAPL_VarWrite(formatter,"RZEXC",catch%rzexc) - call MAPL_VarWrite(formatter,"SRFEXC",catch%srfexc) - call MAPL_VarWrite(formatter,"GHTCNT1",catch%ghtcnt1) - call MAPL_VarWrite(formatter,"GHTCNT2",catch%ghtcnt2) - call MAPL_VarWrite(formatter,"GHTCNT3",catch%ghtcnt3) - call MAPL_VarWrite(formatter,"GHTCNT4",catch%ghtcnt4) - call MAPL_VarWrite(formatter,"GHTCNT5",catch%ghtcnt5) - call MAPL_VarWrite(formatter,"GHTCNT6",catch%ghtcnt6) - call MAPL_VarWrite(formatter,"TSURF",catch%tsurf) - call MAPL_VarWrite(formatter,"WESNN1",catch%wesnn1) - call MAPL_VarWrite(formatter,"WESNN2",catch%wesnn2) - call MAPL_VarWrite(formatter,"WESNN3",catch%wesnn3) - call MAPL_VarWrite(formatter,"HTSNNN1",catch%htsnnn1) - call MAPL_VarWrite(formatter,"HTSNNN2",catch%htsnnn2) - call MAPL_VarWrite(formatter,"HTSNNN3",catch%htsnnn3) - call MAPL_VarWrite(formatter,"SNDZN1",catch%sndzn1) - call MAPL_VarWrite(formatter,"SNDZN2",catch%sndzn2) - call MAPL_VarWrite(formatter,"SNDZN3",catch%sndzn3) - call MAPL_VarWrite(formatter,"CH",catch%ch) - call MAPL_VarWrite(formatter,"CM",catch%cm) - call MAPL_VarWrite(formatter,"CQ",catch%cq) - call MAPL_VarWrite(formatter,"FR",catch%fr) - call MAPL_VarWrite(formatter,"WW",catch%ww) - call MAPL_VarWrite(formatter,"TILE_ID",catch%TILE_ID) - call MAPL_VarWrite(formatter,"NDEP",catch%NDEP) - call MAPL_VarWrite(formatter,"CLI_T2M",catch%t2) - call MAPL_VarWrite(formatter,"BGALBVR",catch%BGALBVR) - call MAPL_VarWrite(formatter,"BGALBVF",catch%BGALBVF) - call MAPL_VarWrite(formatter,"BGALBNR",catch%BGALBNR) - call MAPL_VarWrite(formatter,"BGALBNF",catch%BGALBNF) - myVariable => cfg%get_variable("CNCOL") - dname => myVariable%get_ith_dimension(2) - dim1 = cfg%get_dimension(dname) - - do j=1,dim1 - call MAPL_VarWrite(formatter,"CNCOL",catch%CNCOL(:,j),offset1=j) - enddo - myVariable => cfg%get_variable("CNPFT") - dname => myVariable%get_ith_dimension(2) - dim1 = cfg%get_dimension(dname) - do j=1,dim1 - call MAPL_VarWrite(formatter,"CNPFT",catch%CNPFT(:,j),offset1=j) - enddo - - dim1 = cfg%get_dimension('tile') - allocate (var (dim1)) - var = 0. - - call MAPL_VarWrite(formatter,"BFLOWM", var) - call MAPL_VarWrite(formatter,"TOTWATM",var) - call MAPL_VarWrite(formatter,"TAIRM", var) - call MAPL_VarWrite(formatter,"TPM", var) - call MAPL_VarWrite(formatter,"CNSUM", var) - call MAPL_VarWrite(formatter,"SNDZM", var) - call MAPL_VarWrite(formatter,"ASNOWM", var) - - myVariable => cfg%get_variable("TGWM") - dname => myVariable%get_ith_dimension(2) - dim1 = cfg%get_dimension(dname) - do j=1,dim1 - call MAPL_VarWrite(formatter,"TGWM",var,offset1=j) - call MAPL_VarWrite(formatter,"RZMM",var,offset1=j) - end do - - if (clm45) then - do j=1,dim1 - call MAPL_VarWrite(formatter,"SFMM", var,offset1=j) - enddo - - call MAPL_VarWrite(formatter,"ABM", catch%ABM, rc =rc ) - call MAPL_VarWrite(formatter,"FIELDCAP",catch%FIELDCAP) - call MAPL_VarWrite(formatter,"HDM", catch%HDM ) - call MAPL_VarWrite(formatter,"GDP", catch%GDP ) - call MAPL_VarWrite(formatter,"PEATF", catch%PEATF ) - call MAPL_VarWrite(formatter,"RHM", var) - call MAPL_VarWrite(formatter,"WINDM", var) - call MAPL_VarWrite(formatter,"RAINFM", var) - call MAPL_VarWrite(formatter,"SNOWFM", var) - call MAPL_VarWrite(formatter,"RUNSRFM", var) - call MAPL_VarWrite(formatter,"AR1M", var) - call MAPL_VarWrite(formatter,"T2M10D", var) - call MAPL_VarWrite(formatter,"TPREC10D",var) - call MAPL_VarWrite(formatter,"TPREC60D",var) - else - call MAPL_VarWrite(formatter,"SFMCM", var) - endif - - myVariable => cfg%get_variable("PSNSUNM") - dname => myVariable%get_ith_dimension(2) - dim1 = cfg%get_dimension(dname) - dname => myVariable%get_ith_dimension(3) - dim2 = cfg%get_dimension(dname) - do i=1,dim2 - do j=1,dim1 - call MAPL_VarWrite(formatter,"PSNSUNM",var,offset1=j,offset2=i) - call MAPL_VarWrite(formatter,"PSNSHAM",var,offset1=j,offset2=i) - end do - end do - call formatter%close() - return - end subroutine writecatchcn_nc4 - - subroutine writecatchcn (unit,catch) - integer unit, i,j,n - type(catch_rst) catch - - write(unit) catch% bf1 - write(unit) catch% bf2 - write(unit) catch% bf3 - write(unit) catch% vgwmax - write(unit) catch% cdcr1 - write(unit) catch% cdcr2 - write(unit) catch% psis - write(unit) catch% bee - write(unit) catch% poros - write(unit) catch% wpwet - write(unit) catch% cond - write(unit) catch% gnu - write(unit) catch% ars1 - write(unit) catch% ars2 - write(unit) catch% ars3 - write(unit) catch% ara1 - write(unit) catch% ara2 - write(unit) catch% ara3 - write(unit) catch% ara4 - write(unit) catch% arw1 - write(unit) catch% arw2 - write(unit) catch% arw3 - write(unit) catch% arw4 - write(unit) catch% tsa1 - write(unit) catch% tsa2 - write(unit) catch% tsb1 - write(unit) catch% tsb2 - write(unit) catch% atau - write(unit) catch% btau - write(unit) catch% ity(:,1) - write(unit) catch% ity(:,2) - write(unit) catch% ity(:,3) - write(unit) catch% ity(:,4) - write(unit) catch% fvg(:,1) - write(unit) catch% fvg(:,2) - write(unit) catch% fvg(:,3) - write(unit) catch% fvg(:,4) - write(unit) catch% tc - write(unit) catch% qc - write(unit) catch% tg - write(unit) catch% capac - write(unit) catch% catdef - write(unit) catch% rzexc - write(unit) catch% srfexc - write(unit) catch% ghtcnt1 - write(unit) catch% ghtcnt2 - write(unit) catch% ghtcnt3 - write(unit) catch% ghtcnt4 - write(unit) catch% ghtcnt5 - write(unit) catch% ghtcnt6 - write(unit) catch% tsurf - write(unit) catch% wesnn1 - write(unit) catch% wesnn2 - write(unit) catch% wesnn3 - write(unit) catch% htsnnn1 - write(unit) catch% htsnnn2 - write(unit) catch% htsnnn3 - write(unit) catch% sndzn1 - write(unit) catch% sndzn2 - write(unit) catch% sndzn3 - write(unit) catch% ch - write(unit) catch% cm - write(unit) catch% cq - write(unit) catch% fr - write(unit) catch% ww - write(unit) catch% TILE_ID - write(unit) catch% ndep - write(unit) catch% t2 - write(unit) catch% BGALBVR - write(unit) catch% BGALBVF - write(unit) catch% BGALBNR - write(unit) catch% BGALBNF - - do j = 1,nzone * VAR_COL - write(unit) catch% CNCOL (:,j) - end do - - do i = 1,nzone * nveg * VAR_PFT - write(unit) catch% CNPFT (:,i) - end do - - return - end subroutine writecatchcn - - end program - diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/mk_CatchCNRestarts.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/mk_CatchCNRestarts.F90 deleted file mode 100755 index e4ab880c8..000000000 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/mk_CatchCNRestarts.F90 +++ /dev/null @@ -1,2453 +0,0 @@ -#define I_AM_MAIN -#include "MAPL_Generic.h" - -program mk_CatchCNRestarts - -! Usage : mk_CatchCNRestarts OutTileFile InTileFile InRestart SURFLAY RestartTime -! Version 1 : Sarith Mahanama -! sarith.p.mahanama@nasa.gov (Feb 19, 2016) -! The program follows the same nearest neighbor based procedure, as in mk_CatchRestarts.F90, -! to regrid hydrological variables and BCs-based parameters. The algorithm developed -! by Greg Walker (~gkwalker/geos5/convert_offline_cn_restart.f90) to regrid carbon -! variables that looks for a neighbor with a similar vegetation type was modified -! to improve efficiency (in subroutine regrid_carbon_vars). The two main -! modifications in this implementation include: (1) instead looping over the globe, -! it starts from a 10 x 10 window and zoom out until a similar type appears, -! (2) uses MPI enabling parrellel computation. -! Version 2 : Sarith Mahanama (Oct 12, 2016) -! (1) updated to read both carbon and hydrological variables more recent SMAP M09 simulation from Fanwei. -! (2) added subroutine reorder_LDASsa_rst -! The program produces catchcn_internal_rst in nc4 format for any user specified AGCM grid resolution. - -! regrid.pl visits this program twice during the regridding process. During the first visit, the program does not use BCs data. -! It just regrids hydrological variables and BCs-based land parameters in InRestart from InTile space to OutTile -! space (InRestart could be either a catchcn_internal_rst or a catch_internal_rst). If InRestart is a -! catchcn_internal_rst, carbon variables will be regridded using the same simple nearest neighbor algorithm (getids.H) that -! was employed for regridding all other variables. If InRestart is a catch_internal_rst, carbon variables will be -! filled with zeros. - -! During the second visit, the program uses the catchcn_internal_rst produced from the first visit as InRestart (herein -! referred to as InRestart2 which is in OutTile space already). The program reads BCs data from BCSDIR, carbon variables -! from an offline simulation on the SMAP_EASEv2_M09 grid which has been initialized by another 3000-year offline simulation, and -! hydrological from -! InRestart2 in Version 1, -! the same offline simulation on the SMAP_EASEv2_M09 in Version 2. -! Then, they will be regridded to OutTile space. The regridding carbon variables utilizes a more complicated algorithm which looks -! for a M09 grid cell in the neighborhood with a similar vegetation type seperately for each fractional vegetation type within the -! catchment-tile. Note, the model can have upto 4 different types per catchment-tile: primary and secondary types -! and 2 split types for each primary and secondary type. - -! regrid.pl will then execute Scale_CatchCN.F90 which reads catchcn_internal_rst files created in the above 2 steps, -! and scale soil moisture variables to be consistent with the new BCs-based land parameters to produce the final -! catchcn_internal_rst file. - -! Output file format: Output catchcn_internal_rst is always a nc4 file. - -! Here are available options: -! (1) OPT1 (for above first step) -! Input : (1) catchcn_internal_rst from an existing AGCM run (will always be nc4) -! (2) InTile and OutTile are DIFFERENT -! (3) NO land BCs -! OutPut: Every variable (BCs-based land parameters, hydrological variables, and carbon parameters) will be regridded -! from InTile to OutTile space using the simple nearest neighbor algorithm (getids.H) - -! (2) OPT2 (for above first step) -! Input : (1) catch_internal_rst from an existing AGCM run (either nc4 or binary) -! (2) InTile and OutTile are DIFFERENT -! (3) NO land BCs -! OutPut: BCs-based land parameters, and hydrological variables will regridded from InTile to OutTile space -! using the simple nearest neighbor algorithm (getids.H). All carbon variables are filled with zeros. - -! (3) OPT3 (above second step) : -! Input : (1) catchcn_internal_rst (file format is always nc4) -! (2) InTile and OutTile are the same user defined OutTile -! (3) land BCs, -! Output: BCs-based land parameters will be replaced and carbon variables will be filled with regridded (from the -! nearest offline cell with the same vegetation type) data to produce catchcn_internal_rst - -! ---------------------------------------------------------------------------------------------------------------------------------------------- - - ! ====================== ! - ! Process ! - ! ====================== ! - -! HAVEDATA -! | -! _______________________________________________________________________ -! | | -! -! NO (OPT1/OPT2) YES (OPT3) -! -------------- ---------- -!OutTile : /= InTile == InTile -!regridding: ID (InTile to OutTile using getids.H) ID (one-to-one i.e. 1:NTILES, no regridding) -! | | -! clsmcn_file | -! _____________________________________ | -! | | | -! YES (OPT1) NO (OPT2) | -!InRestart : catchcn_internal_rst catch_internal_rst catchcn_internal_rst -! | | | -! | filetype | -! | | | -! | _________________________________ | -! | | | | -! V 0 /= 0 V -!call : read_catchcn_nc4 read_catch_nc4 read_catch_bin read_bcs_data -! | | -! ----------------------------------- -! | -! V -!1) reads InRestart nVars records (1) reads InCNRestart/regrids/writes (1:65) (1) reads BCs -!2) regrids (takes hydrological initial conditions (2) writes 1:37; 66:72 -!3) writes from offline SMAP M09) (3) reads InRestart2/writes 38, 39,40=38,41:65 -!4) close files (2) close files (4) call regrid_carbon_vars (from offline SMAP M09) -! (a) reads from InCNRestart -! (b) regrids each veg type from the nearest InRestart cell -! (c) writes (73-192,193-1080) -! (d) close files -! -! -! -! OUTPUT catchcn_internal_rst will always be nc4 -! ---------------------------------------------------------------------------------------------------------------------------------------------- - - -! The order of the INTERNAL STATE variables in GEOS_CatchCNGridComp -! ----------------------------------------------------------------- -! 1: BF1 -! 2: BF2 -! 3: BF3 -! 4: VGWMAX -! 5: CDCR1 -! 6: CDCR2 -! 7: PSIS -! 8: BEE -! 9: POROS -! 10: WPWET -! 11: COND -! 12: GNU -! 13: ARS1 -! 14: ARS2 -! 15: ARS3 -! 16: ARA1 -! 17: ARA2 -! 18: ARA3 -! 19: ARA4 -! 20: ARW1 -! 21: ARW2 -! 22: ARW3 -! 23: ARW4 -! 24: TSA1 -! 25: TSA2 -! 26: TSB1 -! 27: TSB2 -! 28: ATAU -! 29: BTAU -! 30-33: ITY * NUM_VEG -! 34-37: FVEG * NUM_VEG -! 38: ((TC (n,i),n=1,n_catd),i=1,4) -! 39: ((QC (n,i),n=1,n_catd),i=1,4) -! 40: ((TG (n,i),n=1,n_catd),i=1,4) -! 41: CAPAC -! 42: CATDEF -! 43: RZEXC -! 44: SRFEXC -! 45: GHTCNT1 -! 46: GHTCNT2 -! 47: GHTCNT3 -! 48: GHTCNT4 -! 49: GHTCNT5 -! 50: GHTCNT6 -! 51: TSURF -! 52: WESNN1 -! 53: WESNN2 -! 54: WESNN3 -! 55: HTSNNN1 -! 56: HTSNNN2 -! 57: HTSNNN3 -! 58: SNDZN1 -! 59: SNDZN2 -! 60: SNDZN3 -! 61: ((CH (n,i),n=1,n_catd),i=1,4) -! 62: ((CM (n,i),n=1,n_catd),i=1,4) -! 63: ((CQ (n,i),n=1,n_catd),i=1,4) -! 64: ((FR (n,i),n=1,n_catd),i=1,4) -! 65: ((WW (n,i),n=1,n_catd),i=1,4) -! 66: cat_id -! 67: ndep -! 68: cli_t2m -! 69: BGALBVR -! 70: BGALBVF -! 71: BGALBNR -! 72: BGALBNF -! 73-192: CNCOL (n,nz*VAR_COL) -! 193-1080: CNPFT (n,nz*nv*VAR_PFT) -! 1081-1083: TGWM (n,nz) -! 1084: SFMCM -! 1085: BFLOWM -! 1086: TOTWATM -! 1087: TAIRM -! 1088: TPM -! 1089: CNSUM -! 1090: SNDZM -! 1091: ASNOWM -! 1092-1103: PSNSUNM (n,nz*nv) -! 1104-1115: PSNSHAM (n,nz*nv) - - use MAPL - use ESMF - use gFTL_StringVector - use ieee_arithmetic, only: isnan => ieee_is_nan - use mk_restarts_getidsMod, only: GetIDs, ReadTileFile_RealLatLon - use clm_varpar_shared , only : nzone => NUM_ZON_CN, nveg => NUM_VEG_CN, & - VAR_COL => VAR_COL_40, VAR_PFT => VAR_PFT_40, & - npft => numpft_CN - - implicit none - include 'mpif.h' - INCLUDE 'netcdf.inc' - - ! initialize to non-MPI values - - integer :: myid=0, numprocs=1, mpierr, mpistatus(MPI_STATUS_SIZE) - logical :: root_proc=.true. - - real, parameter :: nan = O'17760000000' - real, parameter :: fmin= 1.e-4 ! ignore vegetation fractions at or below this value - integer, parameter :: OutUnit = 40, InUnit = 50 - - ! =============================================================================================== - ! Below hard-wired ldas restart file is from a global offline simulation on the SMAP M09 grid - ! after 1000s of years of simulations - - integer, parameter :: ntiles_cn = 1684725 - character(len=300), parameter :: & - InCNRestart = '/discover/nobackup/projects/gmao/ssd/land/l_data/LandRestarts_for_Regridding/CatchCN/M09/20151231/catchcn_internal_rst', & - InCNTilFile = '/discover/nobackup/projects/gmao/bcs_shared/legacy_bcs/Icarus-NLv3/Icarus-NLv3_EASE/SMAP_EASEv2_M09/SMAP_EASEv2_M09_3856x1624.til' - - character(len=256), parameter :: CatNames (57) = & - (/'BF1 ','BF2 ','BF3 ','VGWMAX ','CDCR1 ', & - 'CDCR2 ','PSIS ','BEE ','POROS ','WPWET ', & - 'COND ','GNU ','ARS1 ','ARS2 ','ARS3 ', & - 'ARA1 ','ARA2 ','ARA3 ','ARA4 ','ARW1 ', & - 'ARW2 ','ARW3 ','ARW4 ','TSA1 ','TSA2 ', & - 'TSB1 ','TSB2 ','ATAU ','BTAU ','OLD_ITY', & - 'TC ','QC ','CAPAC ','CATDEF ','RZEXC ', & - 'SRFEXC ','GHTCNT1','GHTCNT2','GHTCNT3','GHTCNT4', & - 'GHTCNT5','GHTCNT6','TSURF ','WESNN1 ','WESNN2 ', & - 'WESNN3 ','HTSNNN1','HTSNNN2','HTSNNN3','SNDZN1 ', & - 'SNDZN2 ','SNDZN3 ','CH ','CM ','CQ ', & - 'FR ','WW '/) - - character(len=256), parameter :: CarbNames (68) = & - (/'BF1 ','BF2 ','BF3 ','VGWMAX ','CDCR1 ', & - 'CDCR2 ','PSIS ','BEE ','POROS ','WPWET ', & - 'COND ','GNU ','ARS1 ','ARS2 ','ARS3 ', & - 'ARA1 ','ARA2 ','ARA3 ','ARA4 ','ARW1 ', & - 'ARW2 ','ARW3 ','ARW4 ','TSA1 ','TSA2 ', & - 'TSB1 ','TSB2 ','ATAU ','BTAU ','ITY ', & - 'FVG ','TC ','QC ','TG ','CAPAC ', & - 'CATDEF ','RZEXC ','SRFEXC ','GHTCNT1','GHTCNT2', & - 'GHTCNT3','GHTCNT4','GHTCNT5','GHTCNT6','TSURF ', & - 'WESNN1 ','WESNN2 ','WESNN3 ','HTSNNN1','HTSNNN2', & - 'HTSNNN3','SNDZN1 ','SNDZN2 ','SNDZN3 ','CH ', & - 'CM ','CQ ','FR ','WW ','TILE_ID', & - 'NDEP ','CLI_T2M','BGALBVR','BGALBVF','BGALBNR', & - 'BGALBNF','CNCOL ','CNPFT ' /) - - integer :: AGCM_YY, AGCM_MM, AGCM_DD, AGCM_HR - - character*256 :: DataDir="OutData/clsm/" - character*256 :: Usage="mk_CatchCNRestarts OutTileFile InTileFile InRestart SURFLAY RestartTime" - character*256 :: OutTileFile, InTileFile, InRestart, arg(6), OutFileName - character*10 :: RestartTime - - logical :: clsmcn_file = .true., RegridSMAP = .false. - logical :: havedata - integer :: i, i1, iargc, n, k, ncatch,ntiles,ntiles_in, filetype, rc, nVars, req, infos, STATUS - integer, pointer :: Id(:), id_loc(:), tid_in(:) - real, pointer :: loni(:),lono(:), lati(:), lato(:) , lonn(:), latt(:) - real :: SURFLAY - type(Netcdf4_Fileformatter) :: InFmt,OutFmt - type(FileMetadata) :: InCfg,OutCfg - integer, allocatable :: low_ind(:), upp_ind(:), nt_local (:) - character(256) :: Iam = "mk_CatchCNRestarts" - - call init_MPI() - call MPI_Info_create(infos, STATUS) ; VERIFY_(STATUS) - call MPI_Info_set(infos, "romio_cb_read", "automatic", STATUS) ; VERIFY_(STATUS) - call MPI_Barrier(MPI_COMM_WORLD, STATUS) - - !----------------------------------------------------- - ! Read command-line arguments, file names (inRestart, - ! inTile, outTile), determine file format, and BCs - ! availability. - !----------------------------------------------------- - - call ESMF_Initialize(LogKindFlag=ESMF_LOGKIND_NONE) - - I = iargc() - - if( I /=5 ) then - print *, "Wrong Number of arguments: ", i - print *, trim(Usage) - stop - end if - - do n=1,I - call getarg(n,arg(n)) - enddo - - read(arg(1),'(a)') OutTileFile - read(arg(2),'(a)') InTileFile - read(arg(3),'(a)') InRestart - read(arg(4),*) SURFLAY - read(arg(5),'(a)') RestartTime - - if (SURFLAY.ne.20 .and. SURFLAY.ne.50) then - print *, "You must supply a valid SURFLAY value:" - print *, "(Ganymed-3 and earlier) SURFLAY=20.0 for Old Soil Params" - print *, "(Ganymed-4 and later ) SURFLAY=50.0 for New Soil Params" - call exit(2) - end if - - ! Are BCs data available? - ! ----------------------- - - inquire(file=trim(DataDir)//"CLM_veg_typs_fracs",exist=havedata) - - ! Reading restart time stamp and constructing daylength array - ! ----------------------------------------------------------- - read (RestartTime (1: 4), '(i4)', IOSTAT = K) AGCM_YY ; VERIFY_(K) - read (RestartTime (5: 6), '(i2)', IOSTAT = K) AGCM_MM ; VERIFY_(K) - read (RestartTime (7: 8), '(i2)', IOSTAT = K) AGCM_DD ; VERIFY_(K) - read (RestartTime (9:10), '(i2)', IOSTAT = K) AGCM_HR ; VERIFY_(K) - - MPI_PROC0 : if (root_proc) then - - ! Read Output/Input .til files - call ReadTileFile_RealLatLon(OutTileFile, ntiles, xlon=lono, xlat=lato) - call ReadTileFile_RealLatLon(InTileFile,ntiles_in,xlon=loni, xlat=lati) - allocate(Id (ntiles)) - - ! ------------------------------------------------ - ! create output catchcn_internal_rst in nc4 format - ! ------------------------------------------------ - - call InFmt%open('/discover/nobackup/projects/gmao/ssd/land/l_data/LandRestarts_for_Regridding/CatchCN/catchcn_internal_dummy',pFIO_READ, __RC__) - InCfg=InFmt%read( __RC__) - call MAPL_IOCountNonDimVars(InCfg,nvars, __RC__) - call MAPL_IOChangeRes(InCfg,OutCfg,(/'tile'/),(/ntiles/),__RC__) - i = index(InRestart,'/',back=.true.) - OutFileName = "OutData/"//trim(InRestart(i+1:)) - call OutFmt%create(OutFileName, __RC__) - call OutFmt%write(OutCfg, __RC__) - i1= index(InRestart,'/',back=.true.) - i = index(InRestart,'catchcn',back=.true.) - - endif MPI_PROC0 - - call MPI_Barrier(MPI_COMM_WORLD, mpierr) - call MPI_BCAST(NTILES , 1, MPI_INTEGER , 0,MPI_COMM_WORLD,mpierr) ; VERIFY_(mpierr) - call MPI_BCAST(NTILES_IN, 1, MPI_INTEGER , 0,MPI_COMM_WORLD,mpierr) ; VERIFY_(mpierr) - - HAVE_DATA :if(havedata) then - - ! OPT3 - ! ---- - ! Get number of catchments - ! ------------------------ - - open(unit=22, & - file=trim(DataDir)//"catchment.def",status='old',form='formatted') - - read(22,*) ncatch - - close(22) - - if(ncatch /= ntiles) then - print *, "Number of tiles in BCs data, ",Ncatch," does not match number in OutTile file ", NTILES - print *, trim(OutTileFile) - stop - endif - - if(ntiles_in /= ntiles) then - print *, "HAVEDATA : Number of tiles in InTileFile, ",NTILES_IN," does not match number in OutTileFile ", NTILES - print *, trim ( InTileFile) - print *, trim (OutTileFile) - stop - endif - - allocate (Id(ntiles)) - - do i = 1,ntiles - id (i) = i ! Just one-to-one mapping - end do - RegridSMAP = .true. - - !OPT3 (Reading/writing BCs/hydrological variables) - - if (root_proc) call read_bcs_data (ntiles, SURFLAY, OutFmt, InRestart, __RC__) - - else - - ! What is the format of the InRestart file? - ! ----------------------------------------- - - call MAPL_NCIOGetFileType(InRestart, filetype, __RC__) - - if (filetype /= 0) then - - ! OPT2 (filetype =/ 0: a binary file must be a catch_internal_rst) - ! ---- - clsmcn_file = .false. - - open(unit=InUnit,FILE=InRestart,form='unformatted', & - status='old',convert='little_endian') - - else - - ! filetype = 0 : nc4, could be catch_internal_rst or catchcn_internal_rst - ! check nVars: if nVars > 57 OPT1 (catchcn_internal_rst) ; else OPT2 (catch_internal_rst) - ! --------------------------------------------------------------------------------------- - - call InFmt%open(InRestart,pFIO_READ, __RC__) - InCfg = InFmt%read(__RC__) - call InFmt%close() - - call MAPL_IOCountNonDimVars(InCfg,nvars) - - if(nVars == 57) clsmcn_file = .false. - - endif - - CATCHCN: if (clsmcn_file) then - - ! OPT1 - ! ---- - - ! ---------------------------------------------------- - ! INPUT/OUTPUT Mapping since InTileFile =/ OutTileFile - ! ---------------------------------------------------- - - if(myid > 0) allocate (loni (1:ntiles_in)) - if(myid > 0) allocate (lati (1:ntiles_in)) - - allocate (tid_in (1:ntiles_in)) - do n = 1, NTILES_IN - tid_in (n) = n - end do - - call MPI_BCAST(loni,ntiles_in,MPI_REAL,0,MPI_COMM_WORLD,mpierr) - call MPI_BCAST(lati,ntiles_in,MPI_REAL,0,MPI_COMM_WORLD,mpierr) - call MPI_Barrier(MPI_COMM_WORLD, mpierr) - - ! Now mapping (Id) - ! ---------------- - - allocate (Id(ntiles)) ! Id contains corresponding InTileID after mapping InTiles on to OutTile - ! call GetIds(loni,lati,lono,lato,zoom,Id) - allocate(low_ind ( numprocs)) - allocate(upp_ind ( numprocs)) - allocate(nt_local( numprocs)) - low_ind (:) = 1 - upp_ind (:) = NTILES - nt_local(:) = NTILES - - ! Domain decomposition - ! -------------------- - - if (numprocs > 1) then - do i = 1, numprocs - 1 - upp_ind(i) = low_ind(i) + (ntiles/numprocs) - 1 - low_ind(i+1) = upp_ind(i) + 1 - nt_local(i) = upp_ind(i) - low_ind(i) + 1 - end do - nt_local(numprocs) = upp_ind(numprocs) - low_ind(numprocs) + 1 - endif - - ! Get out tile lat/lots from root - - allocate (id_loc (nt_local (myid + 1))) - allocate (lonn (nt_local (myid + 1))) - allocate (latt (nt_local (myid + 1))) - - do i = 1, numprocs - if((I == 1).and.(myid == 0)) then - lonn(:) = lono(low_ind(i) : upp_ind(i)) - latt(:) = lato(low_ind(i) : upp_ind(i)) - else if (I > 1) then - if(I-1 == myid) then - ! receiving from root - - call MPI_RECV(lonn,nt_local(i) , MPI_REAL, 0,995,MPI_COMM_WORLD,MPI_STATUS_IGNORE,mpierr) - call MPI_RECV(latt,nt_local(i) , MPI_REAL, 0,994,MPI_COMM_WORLD,MPI_STATUS_IGNORE,mpierr) - else if (myid == 0) then - ! root sends - - call MPI_ISend(lono(low_ind(i) : upp_ind(i)),nt_local(i),MPI_REAL,i-1,995,MPI_COMM_WORLD,req,mpierr) - call MPI_WAIT (req,MPI_STATUS_IGNORE,mpierr) - call MPI_ISend(lato(low_ind(i) : upp_ind(i)),nt_local(i),MPI_REAL,i-1,994,MPI_COMM_WORLD,req,mpierr) - call MPI_WAIT (req,MPI_STATUS_IGNORE,mpierr) - endif - endif - end do - - call GetIds(loni,lati,lonn,latt,id_loc, tid_in) - call MPI_Barrier(MPI_COMM_WORLD, mpierr) - - do i = 1, numprocs - if((I == 1).and.(myid == 0)) then - id(low_ind(i) : upp_ind(i)) = Id_loc(:) - else if (I > 1) then - if(I-1 == myid) then - ! send to root - call MPI_ISend(id_loc,nt_local(i),MPI_INTEGER,0,993,MPI_COMM_WORLD,req,mpierr) - call MPI_WAIT (req,MPI_STATUS_IGNORE,mpierr) - else if (myid == 0) then - ! root receives - call MPI_RECV(id(low_ind(i) : upp_ind(i)),nt_local(i) , MPI_INTEGER, i-1,993,MPI_COMM_WORLD,MPI_STATUS_IGNORE,mpierr) - endif - endif - end do - - if(root_proc) deallocate (lono, lato,lonn,latt, tid_in) - - deallocate (loni,lati) - - - if (root_proc) call read_catchcn_nc4 (NTILES_IN, NTILES, OutFmt, ID, InRestart, __RC__) - - else - - call regrid_hyd_vars (NTILES, OutFmt) - - ! OPT2 - ! ---- - ! NC4ORBIN: if(filetype ==0) then - ! - ! call read_catch_nc4 (NTILES_IN, NTILES, OutFmt, ID, InRestart) - ! - ! else - ! - ! call read_catch_bin (NTILES_IN, NTILES, OutFmt, ID) - ! - ! endif NC4ORBIN - - endif CATCHCN - - endif HAVE_DATA - - if (root_proc) then - - ! ----------------- - ! BEGIN THE PROCESS - ! ----------------- - - print *, " " - print *, "**********************************************************************" - print *, " " - print *, "mk_CatchCNRestarts Configuration" - print *, "--------------------------------" - print *, " " - print '(A22, i4.4,i2.2,i2.2,i2.2)', " Restart Time :",AGCM_YY,AGCM_MM,AGCM_DD,AGCM_HR - print *, 'SURFLAY : ',SURFLAY - print *, 'Have BCs data : ',havedata - print *, "# of tiles in InTile : ",ntiles_in - print *, "# of tiles in OutTile: ",ntiles - - if(clsmcn_file) then - print *,"InRestart is from : Catchment-carbon AGCM simulation" - else - InRestart = trim(InCNRestart) - print *,"InRestart is from : offline SMAP_EASEv2_M09" - endif - - print *, "InRestart filename : ",trim(InRestart) - print *, "OutRestart filename : ",trim(OutFileName) - print *, "OutRestart file fmt : nc4" - print *, " " - print *, "**********************************************************************" - print *, " " - - endif - - call MPI_BCAST(OutFileName , 256, MPI_CHARACTER, 0,MPI_COMM_WORLD,mpierr) - call MPI_Barrier(MPI_COMM_WORLD, mpierr) - - if (RegridSMAP) then - ntiles_in = ntiles_cn - !OPT3 (carbon variables from offline SMAP M09) - call regrid_carbon_vars (NTILES,AGCM_YY,AGCM_MM,AGCM_DD,AGCM_HR, OutFileName, OutTileFile) - ! call regrid_carbon_vars_omp (NTILES,AGCM_YY,AGCM_MM,AGCM_DD,AGCM_HR, OutFileName, OutTileFile) - - endif -call MPI_BARRIER( MPI_COMM_WORLD, mpierr) -call ESMF_Finalize(endflag=ESMF_END_KEEPMPI) -call MPI_FINALIZE(mpierr) - -contains - - ! ***************************************************************************** - - SUBROUTINE read_bcs_data (ntiles, SURFLAY, OutFmt, InRestart, rc) - - ! This subroutine : - ! 1) reads BCs from BCSDIR and hydrological varables from InRestart. - ! InRestart is a catchcn_internal_rst nc4 file. - ! - ! 2) writes out BCs and hydrological variables in catchcn_internal_rst (1:72). - ! output catchcn_internal_rst is nc4. - - implicit none - real, intent (in) :: SURFLAY - integer, intent (in) :: ntiles - character (*), intent (in) :: InRestart - type(Netcdf4_Fileformatter), intent (inout) :: OutFmt - integer, optional, intent(out) :: rc - - real, allocatable :: CLMC_pf1(:), CLMC_pf2(:), CLMC_sf1(:), CLMC_sf2(:) - real, allocatable :: CLMC_pt1(:), CLMC_pt2(:), CLMC_st1(:), CLMC_st2(:) - real, allocatable :: BF1(:), BF2(:), BF3(:), VGWMAX(:) - real, allocatable :: CDCR1(:), CDCR2(:), PSIS(:), BEE(:) - real, allocatable :: POROS(:), WPWET(:), COND(:), GNU(:) - real, allocatable :: ARS1(:), ARS2(:), ARS3(:) - real, allocatable :: ARA1(:), ARA2(:), ARA3(:), ARA4(:) - real, allocatable :: ARW1(:), ARW2(:), ARW3(:), ARW4(:) - real, allocatable :: TSA1(:), TSA2(:), TSB1(:), TSB2(:) - real, allocatable :: ATAU2(:), BTAU2(:), DP2BR(:), rity(:), CanopH(:) - real, allocatable :: NDEP(:), BVISDR(:), BVISDF(:), BNIRDR(:), BNIRDF(:) - real, allocatable :: T2(:), var1(:) - integer, allocatable :: ity(:) - character*256 :: vname - character*256 :: DataDir="OutData/clsm/" - integer :: idum, i,j,n, ib, nv - real :: rdum, zdep1, zdep2, zdep3, zmet, term1, term2, bare,fvg(4) - logical :: file_exists - type(Netcdf4_Fileformatter) :: InFmt,CatchCNFmt, CatchFmt - integer :: status - - allocate ( BF1(ntiles), BF2 (ntiles), BF3(ntiles) ) - allocate (VGWMAX(ntiles), CDCR1(ntiles), CDCR2(ntiles) ) - allocate ( PSIS(ntiles), BEE(ntiles), POROS(ntiles) ) - allocate ( WPWET(ntiles), COND(ntiles), GNU(ntiles) ) - allocate ( ARS1(ntiles), ARS2(ntiles), ARS3(ntiles) ) - allocate ( ARA1(ntiles), ARA2(ntiles), ARA3(ntiles) ) - allocate ( ARA4(ntiles), ARW1(ntiles), ARW2(ntiles) ) - allocate ( ARW3(ntiles), ARW4(ntiles), TSA1(ntiles) ) - allocate ( TSA2(ntiles), TSB1(ntiles), TSB2(ntiles) ) - allocate ( ATAU2(ntiles), BTAU2(ntiles), DP2BR(ntiles) ) - allocate (BVISDR(ntiles), BVISDF(ntiles), BNIRDR(ntiles) ) - allocate (BNIRDF(ntiles), T2(ntiles), NDEP(ntiles) ) - allocate ( ity(ntiles), rity(ntiles), CanopH(ntiles)) - allocate (CLMC_pf1(ntiles), CLMC_pf2(ntiles), CLMC_sf1(ntiles)) - allocate (CLMC_sf2(ntiles), CLMC_pt1(ntiles), CLMC_pt2(ntiles)) - allocate (CLMC_st1(ntiles), CLMC_st2(ntiles)) - - inquire(file = trim(DataDir)//'/catchcn_params.nc4', exist=file_exists) - - if(file_exists) then - - print *,'FILE FORMAT FOR LAND BCS IS NC4' - call CatchFmt%open(trim(DataDir)//'/catch_params.nc4',pFIO_READ, __RC__) - call CatchCNFmt%open(trim(DataDir)//'/catchcn_params.nc4',pFIO_READ, __RC__) - call MAPL_VarRead ( CatchFmt ,'OLD_ITY', rity, __RC__) - call MAPL_VarRead ( CatchFmt ,'ARA1', ARA1, __RC__) - call MAPL_VarRead ( CatchFmt ,'ARA2', ARA2, __RC__) - call MAPL_VarRead ( CatchFmt ,'ARA3', ARA3, __RC__) - call MAPL_VarRead ( CatchFmt ,'ARA4', ARA4, __RC__) - call MAPL_VarRead ( CatchFmt ,'ARS1', ARS1, __RC__) - call MAPL_VarRead ( CatchFmt ,'ARS2', ARS2, __RC__) - call MAPL_VarRead ( CatchFmt ,'ARS3', ARS3, __RC__) - call MAPL_VarRead ( CatchFmt ,'ARW1', ARW1, __RC__) - call MAPL_VarRead ( CatchFmt ,'ARW2', ARW2, __RC__) - call MAPL_VarRead ( CatchFmt ,'ARW3', ARW3, __RC__) - call MAPL_VarRead ( CatchFmt ,'ARW4', ARW4, __RC__) - - if( SURFLAY.eq.20.0 ) then - call MAPL_VarRead ( CatchFmt ,'ATAU2', ATAU2, __RC__) - call MAPL_VarRead ( CatchFmt ,'BTAU2', BTAU2, __RC__) - endif - - if( SURFLAY.eq.50.0 ) then - call MAPL_VarRead ( CatchFmt ,'ATAU5', ATAU2, __RC__) - call MAPL_VarRead ( CatchFmt ,'BTAU5', BTAU2, __RC__) - endif - - call MAPL_VarRead ( CatchFmt ,'PSIS', PSIS, __RC__) - call MAPL_VarRead ( CatchFmt ,'BEE', BEE, __RC__) - call MAPL_VarRead ( CatchFmt ,'BF1', BF1, __RC__) - call MAPL_VarRead ( CatchFmt ,'BF2', BF2, __RC__) - call MAPL_VarRead ( CatchFmt ,'BF3', BF3, __RC__) - call MAPL_VarRead ( CatchFmt ,'TSA1', TSA1, __RC__) - call MAPL_VarRead ( CatchFmt ,'TSA2', TSA2, __RC__) - call MAPL_VarRead ( CatchFmt ,'TSB1', TSB1, __RC__) - call MAPL_VarRead ( CatchFmt ,'TSB2', TSB2, __RC__) - call MAPL_VarRead ( CatchFmt ,'COND', COND, __RC__) - call MAPL_VarRead ( CatchFmt ,'GNU', GNU, __RC__) - call MAPL_VarRead ( CatchFmt ,'WPWET', WPWET, __RC__) - call MAPL_VarRead ( CatchFmt ,'DP2BR', DP2BR, __RC__) - call MAPL_VarRead ( CatchFmt ,'POROS', POROS, __RC__) - call MAPL_VarRead ( CatchCNFmt ,'BGALBNF', BNIRDF, __RC__) - call MAPL_VarRead ( CatchCNFmt ,'BGALBNR', BNIRDR, __RC__) - call MAPL_VarRead ( CatchCNFmt ,'BGALBVF', BVISDF, __RC__) - call MAPL_VarRead ( CatchCNFmt ,'BGALBVR', BVISDR, __RC__) - call MAPL_VarRead ( CatchCNFmt ,'NDEP', NDEP, __RC__) - call MAPL_VarRead ( CatchCNFmt ,'T2_M', T2, __RC__) - call MAPL_VarRead(CatchCNFmt,'ITY',CLMC_pt1,offset1=1, __RC__) ! 30 - call MAPL_VarRead(CatchCNFmt,'ITY',CLMC_pt2,offset1=2, __RC__) ! 31 - call MAPL_VarRead(CatchCNFmt,'ITY',CLMC_st1,offset1=3, __RC__) ! 32 - call MAPL_VarRead(CatchCNFmt,'ITY',CLMC_st2,offset1=4, __RC__) ! 33 - call MAPL_VarRead(CatchCNFmt,'FVG',CLMC_pf1,offset1=1, __RC__) ! 34 - call MAPL_VarRead(CatchCNFmt,'FVG',CLMC_pf2,offset1=2, __RC__) ! 35 - call MAPL_VarRead(CatchCNFmt,'FVG',CLMC_sf1,offset1=3, __RC__) ! 36 - call MAPL_VarRead(CatchCNFmt,'FVG',CLMC_sf2,offset1=4, __RC__) ! 37 - call CatchFmt%close() - call CatchCNFmt%close() - - else - - open(unit=22, & - file=trim(DataDir)//"mosaic_veg_typs_fracs",status='old',form='formatted') - - do N=1,ntiles - read(22,*) I, j, ITY(N),idum, rdum, rdum, CanopH(N) - enddo - - rity(:) = float(ity) - - close(22) - - open(unit=22, file=trim(DataDir)//'bf.dat' ,form='formatted') - open(unit=23, file=trim(DataDir)//'soil_param.dat' ,form='formatted') - open(unit=24, file=trim(DataDir)//'ar.new' ,form='formatted') - open(unit=25, file=trim(DataDir)//'ts.dat' ,form='formatted') - open(unit=26, file=trim(DataDir)//'tau_param.dat' ,form='formatted') - open(unit=27, file=trim(DataDir)//'CLM_veg_typs_fracs' ,form='formatted') - open(unit=28, file=trim(DataDir)//'CLM_NDep_SoilAlb_T2m' ,form='formatted') - - do n=1,ntiles - read (22, *) i,j, GNU(n), BF1(n), BF2(n), BF3(n) - - read (23, *) i,j, idum, idum, BEE(n), PSIS(n),& - POROS(n), COND(n), WPWET(n), DP2BR(n) - - read (24, *) i,j, rdum, ARS1(n), ARS2(n), ARS3(n), & - ARA1(n), ARA2(n), ARA3(n), ARA4(n), & - ARW1(n), ARW2(n), ARW3(n), ARW4(n) - - read (25, *) i,j, rdum, TSA1(n), TSA2(n), TSB1(n), TSB2(n) - - if( SURFLAY.eq.20.0 ) read (26, *) i,j, ATAU2(n), BTAU2(n), rdum, rdum ! for old soil params - if( SURFLAY.eq.50.0 ) read (26, *) i,j, rdum , rdum, ATAU2(n), BTAU2(n) ! for new soil params - - read (27, *) i,j, CLMC_pt1(n), CLMC_pt2(n), CLMC_st1(n), CLMC_st2(n), & - CLMC_pf1(n), CLMC_pf2(n), CLMC_sf1(n), CLMC_sf2(n) - - read (28, *) NDEP(n), BVISDR(n), BVISDF(n), BNIRDR(n), BNIRDF(n), T2(n) ! MERRA-2 Annual Mean Temp is default. - - end do - - CLOSE (22, STATUS = 'KEEP') - CLOSE (23, STATUS = 'KEEP') - CLOSE (24, STATUS = 'KEEP') - CLOSE (25, STATUS = 'KEEP') - CLOSE (26, STATUS = 'KEEP') - CLOSE (27, STATUS = 'KEEP') - CLOSE (28, STATUS = 'KEEP') - - endif - - do n=1,ntiles - - BVISDR(n) = amax1(1.e-6, BVISDR(n)) - BVISDF(n) = amax1(1.e-6, BVISDF(n)) - BNIRDR(n) = amax1(1.e-6, BNIRDR(n)) - BNIRDF(n) = amax1(1.e-6, BNIRDF(n)) - - zdep2=1000. - zdep3=amax1(1000.,DP2BR(n)) - - if (zdep2 .gt.0.75*zdep3) then - zdep2 = 0.75*zdep3 - end if - - zdep1=20. - zmet=zdep3/1000. - - term1=-1.+((PSIS(n)-zmet)/PSIS(n))**((BEE(n)-1.)/BEE(n)) - term2=PSIS(n)*BEE(n)/(BEE(n)-1) - - VGWMAX(n) = POROS(n)*zdep2 - CDCR1(n) = 1000.*POROS(n)*(zmet-(-term2*term1)) - CDCR2(n) = (1.-WPWET(n))*POROS(n)*zdep3 - - ! convert % to fractions - - CLMC_pf1(n) = CLMC_pf1(n) / 100. - CLMC_pf2(n) = CLMC_pf2(n) / 100. - CLMC_sf1(n) = CLMC_sf1(n) / 100. - CLMC_sf2(n) = CLMC_sf2(n) / 100. - - fvg(1) = CLMC_pf1(n) - fvg(2) = CLMC_pf2(n) - fvg(3) = CLMC_sf1(n) - fvg(4) = CLMC_sf2(n) - - BARE = 1. - - DO NV = 1, NVEG - BARE = BARE - FVG(NV)! subtract vegetated fractions - END DO - - if (BARE /= 0.) THEN - IB = MAXLOC(FVG(:),1) - FVG (IB) = FVG(IB) + BARE ! This also corrects all cases sum ne 0. - ENDIF - - CLMC_pf1(n) = fvg(1) - CLMC_pf2(n) = fvg(2) - CLMC_sf1(n) = fvg(3) - CLMC_sf2(n) = fvg(4) - - enddo - - NDEP = NDEP * 1.e-9 - -! prevent trivial fractions -! ------------------------- - do n = 1,ntiles - if(CLMC_pf1(n) <= 1.e-4) then - CLMC_pf2(n) = CLMC_pf2(n) + CLMC_pf1(n) - CLMC_pf1(n) = 0. - endif - - if(CLMC_pf2(n) <= 1.e-4) then - CLMC_pf1(n) = CLMC_pf1(n) + CLMC_pf2(n) - CLMC_pf2(n) = 0. - endif - - if(CLMC_sf1(n) <= 1.e-4) then - if(CLMC_sf2(n) > 1.e-4) then - CLMC_sf2(n) = CLMC_sf2(n) + CLMC_sf1(n) - else if(CLMC_pf2(n) > 1.e-4) then - CLMC_pf2(n) = CLMC_pf2(n) + CLMC_sf1(n) - else if(CLMC_pf1(n) > 1.e-4) then - CLMC_pf1(n) = CLMC_pf1(n) + CLMC_sf1(n) - else - stop 'fveg3' - endif - CLMC_sf1(n) = 0. - endif - - if(CLMC_sf2(n) <= 1.e-4) then - if(CLMC_sf1(n) > 1.e-4) then - CLMC_sf1(n) = CLMC_sf1(n) + CLMC_sf2(n) - else if(CLMC_pf2(n) > 1.e-4) then - CLMC_pf2(n) = CLMC_pf2(n) + CLMC_sf2(n) - else if(CLMC_pf1(n) > 1.e-4) then - CLMC_pf1(n) = CLMC_pf1(n) + CLMC_sf2(n) - else - stop 'fveg4' - endif - CLMC_sf2(n) = 0. - endif - end do - - - - ! Now writing BCs (from BCSDIR) and regridded hydrological variables 1-72 - ! ----------------------------------------------------------------------- - - call InFmt%open(InRestart,pFIO_READ, __RC__) - - call MAPL_VarWrite(OutFmt,trim(CarbNames(1)),BF1) ! 1 - call MAPL_VarWrite(OutFmt,trim(CarbNames(2)),BF2) ! 2 - call MAPL_VarWrite(OutFmt,trim(CarbNames(3)),BF3) ! 3 - call MAPL_VarWrite(OutFmt,trim(CarbNames(4)),VGWMAX) ! 4 - call MAPL_VarWrite(OutFmt,trim(CarbNames(5)),CDCR1) ! 5 - call MAPL_VarWrite(OutFmt,trim(CarbNames(6)),CDCR2) ! 6 - call MAPL_VarWrite(OutFmt,trim(CarbNames(7)),PSIS) ! 7 - call MAPL_VarWrite(OutFmt,trim(CarbNames(8)),BEE) ! 8 - call MAPL_VarWrite(OutFmt,trim(CarbNames(9)),POROS) ! 9 - call MAPL_VarWrite(OutFmt,trim(CarbNames(10)),WPWET) ! 10 - call MAPL_VarWrite(OutFmt,trim(CarbNames(11)),COND) ! 11 - call MAPL_VarWrite(OutFmt,trim(CarbNames(12)),GNU) ! 12 - call MAPL_VarWrite(OutFmt,trim(CarbNames(13)),ARS1) ! 13 - call MAPL_VarWrite(OutFmt,trim(CarbNames(14)),ARS2) ! 14 - call MAPL_VarWrite(OutFmt,trim(CarbNames(15)),ARS3) ! 15 - call MAPL_VarWrite(OutFmt,trim(CarbNames(16)),ARA1) ! 16 - call MAPL_VarWrite(OutFmt,trim(CarbNames(17)),ARA2) ! 17 - call MAPL_VarWrite(OutFmt,trim(CarbNames(18)),ARA3) ! 18 - call MAPL_VarWrite(OutFmt,trim(CarbNames(19)),ARA4) ! 19 - call MAPL_VarWrite(OutFmt,trim(CarbNames(20)),ARW1) ! 20 - call MAPL_VarWrite(OutFmt,trim(CarbNames(21)),ARW2) ! 21 - call MAPL_VarWrite(OutFmt,trim(CarbNames(22)),ARW3) ! 22 - call MAPL_VarWrite(OutFmt,trim(CarbNames(23)),ARW4) ! 23 - call MAPL_VarWrite(OutFmt,trim(CarbNames(24)),TSA1) ! 24 - call MAPL_VarWrite(OutFmt,trim(CarbNames(25)),TSA2) ! 25 - call MAPL_VarWrite(OutFmt,trim(CarbNames(26)),TSB1) ! 26 - call MAPL_VarWrite(OutFmt,trim(CarbNames(27)),TSB2) ! 27 - call MAPL_VarWrite(OutFmt,trim(CarbNames(28)),ATAU2) ! 28 - call MAPL_VarWrite(OutFmt,trim(CarbNames(29)),BTAU2) ! 29 - call MAPL_VarWrite(OutFmt,'ITY',CLMC_pt1,offset1=1) ! 30 - call MAPL_VarWrite(OutFmt,'ITY',CLMC_pt2,offset1=2) ! 31 - call MAPL_VarWrite(OutFmt,'ITY',CLMC_st1,offset1=3) ! 32 - call MAPL_VarWrite(OutFmt,'ITY',CLMC_st2,offset1=4) ! 33 - call MAPL_VarWrite(OutFmt,'FVG',CLMC_pf1,offset1=1) ! 34 - call MAPL_VarWrite(OutFmt,'FVG',CLMC_pf2,offset1=2) ! 35 - call MAPL_VarWrite(OutFmt,'FVG',CLMC_sf1,offset1=3) ! 36 - call MAPL_VarWrite(OutFmt,'FVG',CLMC_sf2,offset1=4) ! 37 - - allocate(var1(ntiles)) - - ! TC QC TG - - do n = 38,40 - if(n == 38) vname = 'TC' - if(n == 39) vname = 'QC' - if(n == 40) vname = 'TG' - do j = 1,4 - call MAPL_VarRead ( InFmt,vname,var1 ,offset1=j, __RC__) - call MAPL_VarWrite(OutFmt,vname,var1 ,offset1=j) ! 38-40 - end do - end do - - ! CAPAC CATDEF RZEXC SRFEXC ... SNDZN3 - - do n=41,60 - call MAPL_VarRead ( InFmt,trim(CarbNames(n-6)),var1, __RC__) - call MAPL_VarWrite(OutFmt,trim(CarbNames(n-6)),var1) ! 41-60 - enddo - - ! CH CM CQ FR WW - var1 = 0. - - do n=61,65 - if((n >= 61).AND.(n <= 63)) var1 = 1.e-3 - if(n == 64) var1 = 0.25 - if(n == 65) var1 = 0.1 - do j = 1,4 - - call MAPL_VarRead ( InFmt,trim(CarbNames(n-6)),var1 ,offset1=j, __RC__) - call MAPL_VarWrite(OutFmt,trim(CarbNames(n-6)),var1 ,offset1=j) ! 61-65 - end do - end do - - do i=1,ntiles - var1(i) = real(i) - end do - - call MAPL_VarWrite(OutFmt,'TILE_ID',var1 ) ! 66 : cat_id - call MAPL_VarWrite(OutFmt,'NDEP' ,NDEP ) ! 67 : ndep - call MAPL_VarWrite(OutFmt,'CLI_T2M',T2 ) ! 68 : cli_t2m - call MAPL_VarWrite(OutFmt,'BGALBVR',BVISDR) ! 69 : BGALBVR - call MAPL_VarWrite(OutFmt,'BGALBVF',BVISDF) ! 70 : BGALBVF - call MAPL_VarWrite(OutFmt,'BGALBNR',BNIRDR) ! 71 : BGALBNR - call MAPL_VarWrite(OutFmt,'BGALBNF',BNIRDF) ! 72 : BGALBNF - - deallocate (var1) - call InFmt%close() - call OutFmt%close() - -! Vegdyn Boundary Condition -! ------------------------- -! -! open(20,file=trim("OutData/vegdyn_internal_rst"), & -! status="unknown", & -! form="unformatted",convert="little_endian") -! write(20) rity -! write(20) CanopH -! close(20) -! print *, "Wrote vegdyn_internal_restart" - - deallocate ( BF1, BF2, BF3 ) - deallocate (VGWMAX, CDCR1, CDCR2 ) - deallocate ( PSIS, BEE, POROS ) - deallocate ( WPWET, COND, GNU ) - deallocate ( ARS1, ARS2, ARS3 ) - deallocate ( ARA1, ARA2, ARA3 ) - deallocate ( ARA4, ARW1, ARW2 ) - deallocate ( ARW3, ARW4, TSA1 ) - deallocate ( TSA2, TSB1, TSB2 ) - deallocate ( ATAU2, BTAU2, DP2BR ) - deallocate (BVISDR, BVISDF, BNIRDR ) - deallocate (BNIRDF, T2, NDEP ) - deallocate ( ity, rity, CanopH) - deallocate (CLMC_pf1, CLMC_pf2, CLMC_sf1) - deallocate (CLMC_sf2, CLMC_pt1, CLMC_pt2) - deallocate (CLMC_st1,CLMC_st2) - if (present(rc)) rc = 0 - !_RETURN(_SUCCESS) - END SUBROUTINE read_bcs_data - - ! ***************************************************************************** - - SUBROUTINE read_catchcn_nc4 (NTILES_IN, NTILES, OutFmt, IDX, InRestart, rc) - - implicit none - - ! Reads catchcn_internal_rst nc4 file, regrids every single variable and writes - ! out catchcn_internal_rst in nc4 format. - ! This subroutine is called when BCs data are not available. - - integer, intent (in) :: NTILES_IN, NTILES - character(*), intent (in) :: InRestart - type(Netcdf4_Fileformatter), intent (inout) :: OutFmt - integer, dimension (NTILES), intent (in) :: IDX - integer, optional, intent(out) :: rc - type(Netcdf4_Fileformatter) :: InFmt - type(FileMetadata) :: InCfg - integer :: n,i,j, ndims, nVars,dim1,dim2 - character(len=:), pointer :: vname - real, allocatable :: var1 (:), var2 (:) - integer, allocatable :: TILE_ID (:) - type(StringVariableMap), pointer :: variables - type(Variable), pointer :: var - type(StringVariableMapIterator) :: var_iter - type(StringVector), pointer :: var_dimensions - character(len=:), pointer :: dname - integer :: status - - call InFmt%open(InRestart,pFIO_READ, __RC__) - InCfg = InFmt%read(__RC__) - - allocate (var1 (1:NTILES_IN)) - allocate (var2 (1:NTILES_IN)) - allocate (TILE_ID (1:NTILES_IN)) - - call MAPL_VarRead ( InFmt,'TILE_ID',var1, __RC__) - do n = 1, NTILES_IN - tile_id (NINT (var1(n))) = n - end do - - variables => InCfg%get_variables() - var_iter = variables%begin() - do while (var_iter /= variables%end()) - - vname => var_iter%key() - var => var_iter%value() - var_dimensions => var%get_dimensions() - - ndims = var_dimensions%size() - - if (ndims == 1) then - call MAPL_VarRead ( InFmt,vname,var1, __RC__) - var2 = var1 (tile_id) - call MAPL_VarWrite(OutFmt,vname,var2(idx)) - - else if (ndims == 2) then - - dname => var%get_ith_dimension(2) - dim1=InCfg%get_dimension(dname) - do j=1,dim1 - call MAPL_VarRead ( InFmt,vname,var1 ,offset1=j, __RC__) - var2 = var1 (tile_id) - call MAPL_VarWrite(OutFmt,vname,var2(idx),offset1=j) - enddo - - else if (ndims == 3) then - - dname => var%get_ith_dimension(2) - dim1=InCfg%get_dimension(dname) - dname => var%get_ith_dimension(3) - dim2=InCfg%get_dimension(dname) - do i=1,dim2 - do j=1,dim1 - call MAPL_VarRead ( InFmt,vname,var1 ,offset1=j,offset2=i, __RC__) - var2 = var1 (tile_id) - call MAPL_VarWrite(OutFmt,vname,var2(idx),offset1=j,offset2=i) - enddo - enddo - - end if - - call var_iter%next() - enddo - - deallocate (var1, var2, tile_id) - call InFmt%close() - call OutFmt%close() - if (present(rc)) rc = 0 - !_RETURN(_SUCCESS) - END SUBROUTINE read_catchcn_nc4 - - ! ***************************************************************************** - - SUBROUTINE regrid_carbon_vars ( & - NTILES,AGCM_YY,AGCM_MM,AGCM_DD,AGCM_HR, OutFileName, OutTileFile) - - implicit none - character (*), intent (in) :: OutTileFile, OutFileName - integer, intent (in) :: NTILES,AGCM_YY,AGCM_MM,AGCM_DD,AGCM_HR - real, allocatable, dimension (:) :: CLMC_pf1, CLMC_pf2, CLMC_sf1, CLMC_sf2, & - CLMC_pt1, CLMC_pt2,CLMC_st1,CLMC_st2 - - ! =============================================================================================== - - integer :: iclass(npft) = (/1,1,2,3,3,4,5,5,6,7,8,9,10,11,12,11,12,11,12/) - integer, allocatable, dimension(:,:) :: Id_glb, Id_loc - integer, allocatable, dimension(:) :: tid_offl, id_vec - real, allocatable, dimension(:,:) :: fveg_offl, ityp_offl - real :: fveg_new, sub_dist - integer :: n,i,j, k, nv, nx, nz, iv, offl_cell, ityp_new, STATUS,NCFID, req - integer :: outid, local_id - integer, allocatable, dimension (:) :: sub_tid, sub_ityp1, sub_ityp2,icl_ityp1 - real , pointer, dimension (:) :: sub_lon, sub_lat, rev_dist, sub_fevg1, sub_fevg2,& - lonc, latc, LATT, LONN, DAYX, long, latg, var_dum, TILE_ID, var_dum2 - real, allocatable :: var_off_col (:,:,:), var_off_pft (:,:,:,:) - real, allocatable :: var_col_out (:,:,:), var_pft_out (:,:,:,:) - integer, allocatable :: low_ind(:), upp_ind(:), nt_local (:) - integer :: AGCM_YYY, AGCM_MMM, AGCM_DDD, AGCM_HRR, AGCM_MI, AGCM_S, dofyr - type(MAPL_SunOrbit) :: ORBIT - type(ESMF_Time) :: CURRENT_TIME - type(ESMF_TimeInterval) :: timeStep - type(ESMF_Clock) :: CLOCK - type(ESMF_Config) :: CF - - - allocate (tid_offl (ntiles_cn)) - allocate (ityp_offl (ntiles_cn,nveg)) - allocate (fveg_offl (ntiles_cn,nveg)) - - allocate(low_ind ( numprocs)) - allocate(upp_ind ( numprocs)) - allocate(nt_local( numprocs)) - - low_ind (:) = 1 - upp_ind (:) = NTILES - nt_local(:) = NTILES - - ! Domain decomposition - ! -------------------- - - if (numprocs > 1) then - do i = 1, numprocs - 1 - upp_ind(i) = low_ind(i) + (ntiles/numprocs) - 1 - low_ind(i+1) = upp_ind(i) + 1 - nt_local(i) = upp_ind(i) - low_ind(i) + 1 - end do - nt_local(numprocs) = upp_ind(numprocs) - low_ind(numprocs) + 1 - endif - - allocate (id_loc (nt_local (myid + 1),4)) - allocate (lonn (nt_local (myid + 1))) - allocate (latt (nt_local (myid + 1))) - allocate (CLMC_pf1(nt_local (myid + 1))) - allocate (CLMC_pf2(nt_local (myid + 1))) - allocate (CLMC_sf1(nt_local (myid + 1))) - allocate (CLMC_sf2(nt_local (myid + 1))) - allocate (CLMC_pt1(nt_local (myid + 1))) - allocate (CLMC_pt2(nt_local (myid + 1))) - allocate (CLMC_st1(nt_local (myid + 1))) - allocate (CLMC_st2(nt_local (myid + 1))) - allocate (lonc (1:ntiles_cn)) - allocate (latc (1:ntiles_cn)) - - if (root_proc) then - - ! -------------------------------------------- - ! Read exact lonn, latt from output .til file - ! -------------------------------------------- - - allocate (long (ntiles)) - allocate (latg (ntiles)) - allocate (DAYX (NTILES)) - - call ReadTileFile_RealLatLon (OutTileFile, i, xlon=long, xlat=latg) - - !----------------------- - ! COMPUTE DAYX - !----------------------- - - AGCM_YYY = AGCM_YY - AGCM_MMM = AGCM_MM - AGCM_DDD = AGCM_DD - AGCM_HRR = AGCM_HR - AGCM_MI = 0 - AGCM_S = 0 - - - call ESMF_CalendarSetDefault ( ESMF_CALKIND_GREGORIAN, rc=status ) - - ! get current date & time - ! ----------------------- - call ESMF_TimeSet ( CURRENT_TIME, YY = AGCM_YYY, & - MM = AGCM_MMM, & - DD = AGCM_DDD, & - H = AGCM_HRR, & - M = AGCM_MI, & - S = AGCM_S , & - rc=status ) - VERIFY_(STATUS) - - call ESMF_TimeIntervalSet(TimeStep, S=450, RC=status) - clock = ESMF_ClockCreate(TimeStep, startTime = CURRENT_TIME, RC=status) - VERIFY_(STATUS) - call ESMF_ClockSet ( clock, CurrTime=CURRENT_TIME, rc=status ) - - CF = ESMF_ConfigCreate(RC=STATUS) - VERIFY_(status) - - ORBIT = MAPL_SunOrbitCreateFromConfig(CF, CLOCK, .false., RC=status) - VERIFY_(status) - - ! compute current daylight duration - !---------------------------------- - call MAPL_SunGetDaylightDuration(ORBIT,latg,dayx,currTime=CURRENT_TIME,RC=STATUS) - VERIFY_(STATUS) - - ! --------------------------------------------- - ! Read exact lonc, latc from offline .til File - ! --------------------------------------------- - - call ReadTileFile_RealLatLon(InCNTilFile,i,xlon=lonc,xlat=latc) - - endif - -! call MPI_SCATTERV ( & -! long,nt_local,low_ind-1,MPI_real, & -! lonn,size(lonn),MPI_real , & -! 0,MPI_COMM_WORLD, mpierr ) -! -! call MPI_SCATTERV ( & -! latg,nt_local,low_ind-1,MPI_real, & -! latt,nt_local(myid+1),MPI_real , & -! 0,MPI_COMM_WORLD, mpierr ) - - do i = 1, numprocs - if((I == 1).and.(myid == 0)) then - lonn(:) = long(low_ind(i) : upp_ind(i)) - latt(:) = latg(low_ind(i) : upp_ind(i)) - else if (I > 1) then - if(I-1 == myid) then - ! receiving from root - call MPI_RECV(lonn,nt_local(i) , MPI_REAL, 0,995,MPI_COMM_WORLD,MPI_STATUS_IGNORE,mpierr) - call MPI_RECV(latt,nt_local(i) , MPI_REAL, 0,994,MPI_COMM_WORLD,MPI_STATUS_IGNORE,mpierr) - else if (myid == 0) then - ! root sends - call MPI_ISend(long(low_ind(i) : upp_ind(i)),nt_local(i),MPI_REAL,i-1,995,MPI_COMM_WORLD,req,mpierr) - call MPI_WAIT (req,MPI_STATUS_IGNORE,mpierr) - call MPI_ISend(latg(low_ind(i) : upp_ind(i)),nt_local(i),MPI_REAL,i-1,994,MPI_COMM_WORLD,req,mpierr) - call MPI_WAIT (req,MPI_STATUS_IGNORE,mpierr) - endif - endif - end do - - if(root_proc) deallocate (long, latg) - - call MPI_BCAST(lonc,ntiles_cn,MPI_REAL,0,MPI_COMM_WORLD,mpierr) - call MPI_BCAST(latc,ntiles_cn,MPI_REAL,0,MPI_COMM_WORLD,mpierr) - - ! Open GKW/Fzeng SMAP M09 catchcn_internal_rst and output catchcn_internal_rst - ! ---------------------------------------------------------------------------- - ! call MPI_Info_create(info, STATUS) - ! call MPI_Info_set(info, "romio_cb_read", "automatic", STATUS) - ! STATUS = NF_OPEN_PAR (trim(InCNRestart),IOR(NF_NOWRITE,NF_MPIIO),MPI_COMM_WORLD, info,NCFID) - ! STATUS = NF_OPEN_PAR (trim(OutFileName),IOR(NF_WRITE ,NF_MPIIO),MPI_COMM_WORLD, info,OUTID) - - STATUS = NF_OPEN_PAR (trim(OutFileName),IOR(NF_NOWRITE,NF_MPIIO),MPI_COMM_WORLD, infos,OUTID) ; VERIFY_(STATUS) - ! if(root_proc) then - ! STATUS = NF_OPEN (trim(OutFileName),NF_WRITE,OUTID) - ! - ! else - ! STATUS = NF_OPEN (trim(OutFileName),NF_NOWRITE,OUTID) - ! endif - ! - IF (STATUS .NE. NF_NOERR) CALL HANDLE_ERR(STATUS, 'OUTPUT RESTART FAILED') - - STATUS = NF_GET_VARA_REAL(OUTID,VarID(OUTID,'ITY'), (/low_ind(myid+1),1/), (/nt_local(myid+1),1/),CLMC_pt1) - STATUS = NF_GET_VARA_REAL(OUTID,VarID(OUTID,'ITY'), (/low_ind(myid+1),2/), (/nt_local(myid+1),1/),CLMC_pt2) - STATUS = NF_GET_VARA_REAL(OUTID,VarID(OUTID,'ITY'), (/low_ind(myid+1),3/), (/nt_local(myid+1),1/),CLMC_st1) - STATUS = NF_GET_VARA_REAL(OUTID,VarID(OUTID,'ITY'), (/low_ind(myid+1),4/), (/nt_local(myid+1),1/),CLMC_st2) - STATUS = NF_GET_VARA_REAL(OUTID,VarID(OUTID,'FVG'), (/low_ind(myid+1),1/), (/nt_local(myid+1),1/),CLMC_pf1) - STATUS = NF_GET_VARA_REAL(OUTID,VarID(OUTID,'FVG'), (/low_ind(myid+1),2/), (/nt_local(myid+1),1/),CLMC_pf2) - STATUS = NF_GET_VARA_REAL(OUTID,VarID(OUTID,'FVG'), (/low_ind(myid+1),3/), (/nt_local(myid+1),1/),CLMC_sf1) - STATUS = NF_GET_VARA_REAL(OUTID,VarID(OUTID,'FVG'), (/low_ind(myid+1),4/), (/nt_local(myid+1),1/),CLMC_sf2) - - if (root_proc) then - - STATUS = NF_OPEN (trim(InCNRestart),NF_NOWRITE,NCFID) - IF (STATUS .NE. NF_NOERR) CALL HANDLE_ERR(STATUS, 'OFFLINE RESTART FAILED') - allocate (TILE_ID (1:ntiles_cn)) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'TILE_ID' ), (/1/), (/NTILES_cn/),TILE_ID) - - do n = 1,ntiles_cn - - K = NINT (TILE_ID (n)) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'ITY'), (/n,1/), (/1,4/),ityp_offl(k,:)) - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'FVG'), (/n,1/), (/1,4/),fveg_offl(k,:)) - - tid_offl (n) = n - - do nv = 1,nveg - if(ityp_offl(k,nv)<0 .or. ityp_offl(k,nv)>npft) stop 'ityp' - if(fveg_offl(k,nv)<0..or. fveg_offl(k,nv)>1.00001) stop 'fveg' - end do - - if((ityp_offl(k,3) == 0).and.(ityp_offl(k,4) == 0)) then - if(ityp_offl(k,1) /= 0) then - ityp_offl(k,3) = ityp_offl(k,1) - else - ityp_offl(k,3) = ityp_offl(k,2) - endif - endif - - if((ityp_offl(k,1) == 0).and.(ityp_offl(k,2) /= 0)) ityp_offl(k,1) = ityp_offl(k,2) - if((ityp_offl(k,2) == 0).and.(ityp_offl(k,1) /= 0)) ityp_offl(k,2) = ityp_offl(k,1) - if((ityp_offl(k,3) == 0).and.(ityp_offl(k,4) /= 0)) ityp_offl(k,3) = ityp_offl(k,4) - if((ityp_offl(k,4) == 0).and.(ityp_offl(k,3) /= 0)) ityp_offl(k,4) = ityp_offl(k,3) - - end do - - endif - - call MPI_BCAST(tid_offl ,size(tid_offl ),MPI_INTEGER,0,MPI_COMM_WORLD,mpierr) - call MPI_BCAST(ityp_offl,size(ityp_offl),MPI_REAL ,0,MPI_COMM_WORLD,mpierr) - call MPI_BCAST(fveg_offl,size(fveg_offl),MPI_REAL ,0,MPI_COMM_WORLD,mpierr) - - ! -------------------------------------------------------------------------------- - ! Here we create transfer index array to map offline restarts to output tile space - ! -------------------------------------------------------------------------------- - - call GetIds(lonc,latc,lonn,latt,id_loc, tid_offl, & - CLMC_pf1, CLMC_pf2, CLMC_sf1, CLMC_sf2, CLMC_pt1, CLMC_pt2,CLMC_st1,CLMC_st2, & - fveg_offl, ityp_offl) - deallocate (CLMC_pf1, CLMC_pf2, CLMC_sf1, CLMC_sf2, CLMC_pt1, CLMC_pt2,CLMC_st1,CLMC_st2,lonc,latc,lonn,latt) - - ! update id_glb in root - - if(root_proc) then - allocate (id_glb (ntiles,4)) - allocate (id_vec (ntiles)) - endif - - do nv = 1, nveg - call MPI_Barrier(MPI_COMM_WORLD, STATUS) -! call MPI_GATHERV( & -! id_loc (:,nv), nt_local(myid+1) , MPI_real, & -! id_vec, nt_local,low_ind-1, MPI_real, & -! 0, MPI_COMM_WORLD, mpierr ) - - do i = 1, numprocs - if((I == 1).and.(myid == 0)) then - id_vec(low_ind(i) : upp_ind(i)) = Id_loc(:,nv) - else if (I > 1) then - if(I-1 == myid) then - ! send to root - call MPI_ISend(id_loc(:,nv),nt_local(i),MPI_INTEGER,0,993,MPI_COMM_WORLD,req,mpierr) - call MPI_WAIT (req,MPI_STATUS_IGNORE,mpierr) - else if (myid == 0) then - ! root receives - call MPI_RECV(id_vec(low_ind(i) : upp_ind(i)),nt_local(i) , MPI_INTEGER, i-1,993,MPI_COMM_WORLD,MPI_STATUS_IGNORE,mpierr) - endif - endif - end do - - if(root_proc) id_glb (:,nv) = id_vec - - end do - - call MPI_Barrier(MPI_COMM_WORLD, STATUS) - STATUS = NF_CLOSE (OutID) -! write out regridded carbon variables - - if(root_proc) then - - STATUS = NF_OPEN (trim(OutFileName),NF_WRITE,OUTID) ; VERIFY_(STATUS) - allocate (CLMC_pf1(NTILES)) - allocate (CLMC_pf2(NTILES)) - allocate (CLMC_sf1(NTILES)) - allocate (CLMC_sf2(NTILES)) - allocate (CLMC_pt1(NTILES)) - allocate (CLMC_pt2(NTILES)) - allocate (CLMC_st1(NTILES)) - allocate (CLMC_st2(NTILES)) - allocate (VAR_DUM (NTILES)) - allocate (var_dum2 (1:ntiles_cn)) - - STATUS = NF_GET_VARA_REAL(OUTID,VarID(OUTID,'ITY'), (/1,1/), (/NTILES,1/),CLMC_pt1) - STATUS = NF_GET_VARA_REAL(OUTID,VarID(OUTID,'ITY'), (/1,2/), (/NTILES,1/),CLMC_pt2) - STATUS = NF_GET_VARA_REAL(OUTID,VarID(OUTID,'ITY'), (/1,3/), (/NTILES,1/),CLMC_st1) - STATUS = NF_GET_VARA_REAL(OUTID,VarID(OUTID,'ITY'), (/1,4/), (/NTILES,1/),CLMC_st2) - STATUS = NF_GET_VARA_REAL(OUTID,VarID(OUTID,'FVG'), (/1,1/), (/NTILES,1/),CLMC_pf1) - STATUS = NF_GET_VARA_REAL(OUTID,VarID(OUTID,'FVG'), (/1,2/), (/NTILES,1/),CLMC_pf2) - STATUS = NF_GET_VARA_REAL(OUTID,VarID(OUTID,'FVG'), (/1,3/), (/NTILES,1/),CLMC_sf1) - STATUS = NF_GET_VARA_REAL(OUTID,VarID(OUTID,'FVG'), (/1,4/), (/NTILES,1/),CLMC_sf2) - - allocate (var_off_col (1: NTILES_CN, 1 : nzone,1 : var_col)) - allocate (var_off_pft (1: NTILES_CN, 1 : nzone,1 : nveg, 1 : var_pft)) - - allocate (var_col_out (1: NTILES, 1 : nzone,1 : var_col)) - allocate (var_pft_out (1: NTILES, 1 : nzone,1 : nveg, 1 : var_pft)) - - i = 1 - do nv = 1,VAR_COL - do nz = 1,nzone - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'CNCOL'), (/1,i/), (/NTILES_CN,1 /),VAR_DUM2) - do k = 1, NTILES_CN - var_off_col(TILE_ID(K), nz,nv) = VAR_DUM2(K) - end do - i = i + 1 - end do - end do - - i = 1 - do iv = 1,VAR_PFT - do nv = 1,nveg - do nz = 1,nzone - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'CNPFT'), (/1,i/), (/NTILES_CN,1 /),VAR_DUM2) - do k = 1, NTILES_CN - var_off_pft(TILE_ID(K), nz,nv,iv) = VAR_DUM2(K) - end do - i = i + 1 - end do - end do - end do - - var_col_out = 0. - var_pft_out = NaN - - where(isnan(var_off_pft)) var_off_pft = 0. - where(var_off_pft /= var_off_pft) var_off_pft = 0. - - OUT_TILE : DO N = 1, NTILES - - !if(mod (n,1000) == 0) print *, myid +1, n, Id_glb(n,:) - - NVLOOP2 : do nv = 1, nveg - - if(nv <= 2) then ! index for secondary PFT index if primary or primary if secondary - nx = nv + 2 - else - nx = nv - 2 - endif - - if (nv == 1) ityp_new = CLMC_pt1(n) - if (nv == 1) fveg_new = CLMC_pf1(n) - if (nv == 2) ityp_new = CLMC_pt2(n) - if (nv == 2) fveg_new = CLMC_pf2(n) - if (nv == 3) ityp_new = CLMC_st1(n) - if (nv == 3) fveg_new = CLMC_sf1(n) - if (nv == 4) ityp_new = CLMC_st2(n) - if (nv == 4) fveg_new = CLMC_sf2(n) - - if (fveg_new > fmin) then - - offl_cell = Id_glb(n,nv) - - if(ityp_new == ityp_offl (offl_cell,nv) .and. fveg_offl (offl_cell,nv)> fmin) then - iv = nv ! same type fraction (primary of secondary) - else if(ityp_new == ityp_offl (offl_cell,nx) .and. fveg_offl (offl_cell,nx)> fmin) then - iv = nx ! not same fraction - else if(iclass(ityp_new)==iclass(ityp_offl(offl_cell,nv)) .and. fveg_offl (offl_cell,nv)> fmin) then - iv = nv ! primary, other type (same class) - else if(fveg_offl (offl_cell,nx)> fmin) then - iv = nx ! secondary, other type (same class) - endif - - ! Get col and pft variables for the Id_glb(nv) grid cell from offline catchcn_internal_rst - ! ---------------------------------------------------------------------------------------- - - ! call NCDF_reshape_getOput (NCFID,Id_glb(n,nv),var_off_col,var_off_pft,.true.) - - var_pft_out (n,:,nv,:) = var_off_pft(Id_glb(n,nv), :,iv,:) - var_col_out (n,:,:) = var_col_out(n,:,:) + fveg_new * var_off_col(Id_glb(n,nv), :,:) ! gkw: column state simple weighted mean; ! could use "woody" fraction? - - ! Check whether var_pft_out is realistic - do nz = 1, nzone - do j = 1, VAR_PFT - if (isnan(var_pft_out (n, nz,nv,j))) print *,j,nv,nz,n,var_pft_out (n, nz,nv,j),fveg_new - !if(isnan(var_pft_out (n, nz,nv,69))) var_pft_out (n, nz,nv,69) = 1.e-6 - !if(isnan(var_pft_out (n, nz,nv,70))) var_pft_out (n, nz,nv,70) = 1.e-6 - !if(isnan(var_pft_out (n, nz,nv,73))) var_pft_out (n, nz,nv,73) = 1.e-6 - !if(isnan(var_pft_out (n, nz,nv,74))) var_pft_out (n, nz,nv,74) = 1.e-6 - end do - end do - endif - - end do NVLOOP2 - - ! reset carbon if negative < 10g - ! ------------------------ - - NZLOOP : do nz = 1, nzone - - if(var_col_out (n, nz,14) < 10.) then - - var_col_out(n, nz, 1) = max(var_col_out(n, nz, 1), 0.) - var_col_out(n, nz, 2) = max(var_col_out(n, nz, 2), 0.) - var_col_out(n, nz, 3) = max(var_col_out(n, nz, 3), 0.) - var_col_out(n, nz, 4) = max(var_col_out(n, nz, 4), 0.) - var_col_out(n, nz, 5) = max(var_col_out(n, nz, 5), 0.) - var_col_out(n, nz,10) = max(var_col_out(n, nz,10), 0.) - var_col_out(n, nz,11) = max(var_col_out(n, nz,11), 0.) - var_col_out(n, nz,12) = max(var_col_out(n, nz,12), 0.) - var_col_out(n, nz,13) = max(var_col_out(n, nz,13),10.) ! soil4c - var_col_out(n, nz,14) = max(var_col_out(n, nz,14), 0.) - var_col_out(n, nz,15) = max(var_col_out(n, nz,15), 0.) - var_col_out(n, nz,16) = max(var_col_out(n, nz,16), 0.) - var_col_out(n, nz,17) = max(var_col_out(n, nz,17), 0.) - var_col_out(n, nz,18) = max(var_col_out(n, nz,18), 0.) - var_col_out(n, nz,19) = max(var_col_out(n, nz,19), 0.) - var_col_out(n, nz,20) = max(var_col_out(n, nz,20), 0.) - var_col_out(n, nz,24) = max(var_col_out(n, nz,24), 0.) - var_col_out(n, nz,25) = max(var_col_out(n, nz,25), 0.) - var_col_out(n, nz,26) = max(var_col_out(n, nz,26), 0.) - var_col_out(n, nz,27) = max(var_col_out(n, nz,27), 0.) - var_col_out(n, nz,28) = max(var_col_out(n, nz,28), 1.) - var_col_out(n, nz,29) = max(var_col_out(n, nz,29), 0.) - - NVLOOP3 : do nv = 1,nveg - - if (nv == 1) ityp_new = CLMC_pt1(n) - if (nv == 1) fveg_new = CLMC_pf1(n) - if (nv == 2) ityp_new = CLMC_pt2(n) - if (nv == 2) fveg_new = CLMC_pf2(n) - if (nv == 3) ityp_new = CLMC_st1(n) - if (nv == 3) fveg_new = CLMC_sf1(n) - if (nv == 4) ityp_new = CLMC_st2(n) - if (nv == 4) fveg_new = CLMC_sf2(n) - - if(fveg_new > fmin) then - var_pft_out(n, nz,nv, 1) = max(var_pft_out(n, nz,nv, 1),0.) - var_pft_out(n, nz,nv, 2) = max(var_pft_out(n, nz,nv, 2),0.) - var_pft_out(n, nz,nv, 3) = max(var_pft_out(n, nz,nv, 3),0.) - var_pft_out(n, nz,nv, 4) = max(var_pft_out(n, nz,nv, 4),0.) - - if(ityp_new <= 12) then ! tree or shrub deadstemc - var_pft_out(n, nz,nv, 5) = max(var_pft_out(n, nz,nv, 5),0.1) - else - var_pft_out(n, nz,nv, 5) = max(var_pft_out(n, nz,nv, 5),0.0) - endif - - var_pft_out(n, nz,nv, 6) = max(var_pft_out(n, nz,nv, 6),0.) - var_pft_out(n, nz,nv, 7) = max(var_pft_out(n, nz,nv, 7),0.) - var_pft_out(n, nz,nv, 8) = max(var_pft_out(n, nz,nv, 8),0.) - var_pft_out(n, nz,nv, 9) = max(var_pft_out(n, nz,nv, 9),0.) - var_pft_out(n, nz,nv,10) = max(var_pft_out(n, nz,nv,10),0.) - var_pft_out(n, nz,nv,11) = max(var_pft_out(n, nz,nv,11),0.) - var_pft_out(n, nz,nv,12) = max(var_pft_out(n, nz,nv,12),0.) - - if(ityp_new <=2 .or. ityp_new ==4 .or. ityp_new ==5 .or. ityp_new == 9) then - var_pft_out(n, nz,nv,13) = max(var_pft_out(n, nz,nv,13),1.) ! leaf carbon display for evergreen - var_pft_out(n, nz,nv,14) = max(var_pft_out(n, nz,nv,14),0.) - else - var_pft_out(n, nz,nv,13) = max(var_pft_out(n, nz,nv,13),0.) - var_pft_out(n, nz,nv,14) = max(var_pft_out(n, nz,nv,14),1.) ! leaf carbon storage for deciduous - endif - - var_pft_out(n, nz,nv,15) = max(var_pft_out(n, nz,nv,15),0.) - var_pft_out(n, nz,nv,16) = max(var_pft_out(n, nz,nv,16),0.) - var_pft_out(n, nz,nv,17) = max(var_pft_out(n, nz,nv,17),0.) - var_pft_out(n, nz,nv,18) = max(var_pft_out(n, nz,nv,18),0.) - var_pft_out(n, nz,nv,19) = max(var_pft_out(n, nz,nv,19),0.) - var_pft_out(n, nz,nv,20) = max(var_pft_out(n, nz,nv,20),0.) - var_pft_out(n, nz,nv,21) = max(var_pft_out(n, nz,nv,21),0.) - var_pft_out(n, nz,nv,22) = max(var_pft_out(n, nz,nv,22),0.) - var_pft_out(n, nz,nv,23) = max(var_pft_out(n, nz,nv,23),0.) - var_pft_out(n, nz,nv,25) = max(var_pft_out(n, nz,nv,25),0.) - var_pft_out(n, nz,nv,26) = max(var_pft_out(n, nz,nv,26),0.) - var_pft_out(n, nz,nv,27) = max(var_pft_out(n, nz,nv,27),0.) - var_pft_out(n, nz,nv,41) = max(var_pft_out(n, nz,nv,41),0.) - var_pft_out(n, nz,nv,42) = max(var_pft_out(n, nz,nv,42),0.) - var_pft_out(n, nz,nv,44) = max(var_pft_out(n, nz,nv,44),0.) - var_pft_out(n, nz,nv,45) = max(var_pft_out(n, nz,nv,45),0.) - var_pft_out(n, nz,nv,46) = max(var_pft_out(n, nz,nv,46),0.) - var_pft_out(n, nz,nv,47) = max(var_pft_out(n, nz,nv,47),0.) - var_pft_out(n, nz,nv,48) = max(var_pft_out(n, nz,nv,48),0.) - var_pft_out(n, nz,nv,49) = max(var_pft_out(n, nz,nv,49),0.) - var_pft_out(n, nz,nv,50) = max(var_pft_out(n, nz,nv,50),0.) - var_pft_out(n, nz,nv,51) = max(var_pft_out(n, nz,nv, 5)/500.,0.) - var_pft_out(n, nz,nv,52) = max(var_pft_out(n, nz,nv,52),0.) - var_pft_out(n, nz,nv,53) = max(var_pft_out(n, nz,nv,53),0.) - var_pft_out(n, nz,nv,54) = max(var_pft_out(n, nz,nv,54),0.) - var_pft_out(n, nz,nv,55) = max(var_pft_out(n, nz,nv,55),0.) - var_pft_out(n, nz,nv,56) = max(var_pft_out(n, nz,nv,56),0.) - var_pft_out(n, nz,nv,57) = max(var_pft_out(n, nz,nv,13)/25.,0.) - var_pft_out(n, nz,nv,58) = max(var_pft_out(n, nz,nv,14)/25.,0.) - var_pft_out(n, nz,nv,59) = max(var_pft_out(n, nz,nv,59),0.) - var_pft_out(n, nz,nv,60) = max(var_pft_out(n, nz,nv,60),0.) - var_pft_out(n, nz,nv,61) = max(var_pft_out(n, nz,nv,61),0.) - var_pft_out(n, nz,nv,62) = max(var_pft_out(n, nz,nv,62),0.) - var_pft_out(n, nz,nv,63) = max(var_pft_out(n, nz,nv,63),0.) - var_pft_out(n, nz,nv,64) = max(var_pft_out(n, nz,nv,64),0.) - var_pft_out(n, nz,nv,65) = max(var_pft_out(n, nz,nv,65),0.) - var_pft_out(n, nz,nv,66) = max(var_pft_out(n, nz,nv,66),0.) - var_pft_out(n, nz,nv,67) = max(var_pft_out(n, nz,nv,67),0.) - var_pft_out(n, nz,nv,68) = max(var_pft_out(n, nz,nv,68),0.) - var_pft_out(n, nz,nv,69) = max(var_pft_out(n, nz,nv,69),0.) - var_pft_out(n, nz,nv,70) = max(var_pft_out(n, nz,nv,70),0.) - var_pft_out(n, nz,nv,73) = max(var_pft_out(n, nz,nv,73),0.) - var_pft_out(n, nz,nv,74) = max(var_pft_out(n, nz,nv,74),0.) - endif - end do NVLOOP3 ! end veg loop - endif ! end carbon check - end do NZLOOP ! end zone loop - - ! Update dayx variable var_pft_out (:,:,28) - - do j = 28, 28 ! 1,VAR_PFT var_pft_out (:,:,:,28) - do nv = 1,nveg - do nz = 1,nzone - var_pft_out (n, nz,nv,j) = dayx(n) - end do - end do - end do - - ! call NCDF_reshape_getOput (OutID,N,var_col_out,var_pft_out,.false.) - - ! column vars - ! ----------- - ! 1 clm3%g%l%c%ccs%col_ctrunc - ! 2 clm3%g%l%c%ccs%cwdc - ! 3 clm3%g%l%c%ccs%litr1c - ! 4 clm3%g%l%c%ccs%litr2c - ! 5 clm3%g%l%c%ccs%litr3c - ! 6 clm3%g%l%c%ccs%pcs_a%totvegc - ! 7 clm3%g%l%c%ccs%prod100c - ! 8 clm3%g%l%c%ccs%prod10c - ! 9 clm3%g%l%c%ccs%seedc - ! 10 clm3%g%l%c%ccs%soil1c - ! 11 clm3%g%l%c%ccs%soil2c - ! 12 clm3%g%l%c%ccs%soil3c - ! 13 clm3%g%l%c%ccs%soil4c - ! 14 clm3%g%l%c%ccs%totcolc - ! 15 clm3%g%l%c%ccs%totlitc - ! 16 clm3%g%l%c%cns%col_ntrunc - ! 17 clm3%g%l%c%cns%cwdn - ! 18 clm3%g%l%c%cns%litr1n - ! 19 clm3%g%l%c%cns%litr2n - ! 20 clm3%g%l%c%cns%litr3n - ! 21 clm3%g%l%c%cns%prod100n - ! 22 clm3%g%l%c%cns%prod10n - ! 23 clm3%g%l%c%cns%seedn - ! 24 clm3%g%l%c%cns%sminn - ! 25 clm3%g%l%c%cns%soil1n - ! 26 clm3%g%l%c%cns%soil2n - ! 27 clm3%g%l%c%cns%soil3n - ! 28 clm3%g%l%c%cns%soil4n - ! 29 clm3%g%l%c%cns%totcoln - ! 30 clm3%g%l%c%cps%ann_farea_burned - ! 31 clm3%g%l%c%cps%annsum_counter - ! 32 clm3%g%l%c%cps%cannavg_t2m - ! 33 clm3%g%l%c%cps%cannsum_npp - ! 34 clm3%g%l%c%cps%farea_burned - ! 35 clm3%g%l%c%cps%fire_prob - ! 36 clm3%g%l%c%cps%fireseasonl - ! 37 clm3%g%l%c%cps%fpg - ! 38 clm3%g%l%c%cps%fpi - ! 39 clm3%g%l%c%cps%me - ! 40 clm3%g%l%c%cps%mean_fire_prob - - ! PFT vars - ! -------- - ! 1 clm3%g%l%c%p%pcs%cpool - ! 2 clm3%g%l%c%p%pcs%deadcrootc - ! 3 clm3%g%l%c%p%pcs%deadcrootc_storage - ! 4 clm3%g%l%c%p%pcs%deadcrootc_xfer - ! 5 clm3%g%l%c%p%pcs%deadstemc - ! 6 clm3%g%l%c%p%pcs%deadstemc_storage - ! 7 clm3%g%l%c%p%pcs%deadstemc_xfer - ! 8 clm3%g%l%c%p%pcs%frootc - ! 9 clm3%g%l%c%p%pcs%frootc_storage - ! 10 clm3%g%l%c%p%pcs%frootc_xfer - ! 11 clm3%g%l%c%p%pcs%gresp_storage - ! 12 clm3%g%l%c%p%pcs%gresp_xfer - ! 13 clm3%g%l%c%p%pcs%leafc - ! 14 clm3%g%l%c%p%pcs%leafc_storage - ! 15 clm3%g%l%c%p%pcs%leafc_xfer - ! 16 clm3%g%l%c%p%pcs%livecrootc - ! 17 clm3%g%l%c%p%pcs%livecrootc_storage - ! 18 clm3%g%l%c%p%pcs%livecrootc_xfer - ! 19 clm3%g%l%c%p%pcs%livestemc - ! 20 clm3%g%l%c%p%pcs%livestemc_storage - ! 21 clm3%g%l%c%p%pcs%livestemc_xfer - ! 22 clm3%g%l%c%p%pcs%pft_ctrunc - ! 23 clm3%g%l%c%p%pcs%xsmrpool - ! 24 clm3%g%l%c%p%pepv%annavg_t2m - ! 25 clm3%g%l%c%p%pepv%annmax_retransn - ! 26 clm3%g%l%c%p%pepv%annsum_npp - ! 27 clm3%g%l%c%p%pepv%annsum_potential_gpp - ! 28 clm3%g%l%c%p%pepv%dayl - ! 29 clm3%g%l%c%p%pepv%days_active - ! 30 clm3%g%l%c%p%pepv%dormant_flag - ! 31 clm3%g%l%c%p%pepv%offset_counter - ! 32 clm3%g%l%c%p%pepv%offset_fdd - ! 33 clm3%g%l%c%p%pepv%offset_flag - ! 34 clm3%g%l%c%p%pepv%offset_swi - ! 35 clm3%g%l%c%p%pepv%onset_counter - ! 36 clm3%g%l%c%p%pepv%onset_fdd - ! 37 clm3%g%l%c%p%pepv%onset_flag - ! 38 clm3%g%l%c%p%pepv%onset_gdd - ! 39 clm3%g%l%c%p%pepv%onset_gddflag - ! 40 clm3%g%l%c%p%pepv%onset_swi - ! 41 clm3%g%l%c%p%pepv%prev_frootc_to_litter - ! 42 clm3%g%l%c%p%pepv%prev_leafc_to_litter - ! 43 clm3%g%l%c%p%pepv%tempavg_t2m - ! 44 clm3%g%l%c%p%pepv%tempmax_retransn - ! 45 clm3%g%l%c%p%pepv%tempsum_npp - ! 46 clm3%g%l%c%p%pepv%tempsum_potential_gpp - ! 47 clm3%g%l%c%p%pepv%xsmrpool_recover - ! 48 clm3%g%l%c%p%pns%deadcrootn - ! 49 clm3%g%l%c%p%pns%deadcrootn_storage - ! 50 clm3%g%l%c%p%pns%deadcrootn_xfer - ! 51 clm3%g%l%c%p%pns%deadstemn - ! 52 clm3%g%l%c%p%pns%deadstemn_storage - ! 53 clm3%g%l%c%p%pns%deadstemn_xfer - ! 54 clm3%g%l%c%p%pns%frootn - ! 55 clm3%g%l%c%p%pns%frootn_storage - ! 56 clm3%g%l%c%p%pns%frootn_xfer - ! 57 clm3%g%l%c%p%pns%leafn - ! 58 clm3%g%l%c%p%pns%leafn_storage - ! 59 clm3%g%l%c%p%pns%leafn_xfer - ! 60 clm3%g%l%c%p%pns%livecrootn - ! 61 clm3%g%l%c%p%pns%livecrootn_storage - ! 62 clm3%g%l%c%p%pns%livecrootn_xfer - ! 63 clm3%g%l%c%p%pns%livestemn - ! 64 clm3%g%l%c%p%pns%livestemn_storage - ! 65 clm3%g%l%c%p%pns%livestemn_xfer - ! 66 clm3%g%l%c%p%pns%npool - ! 67 clm3%g%l%c%p%pns%pft_ntrunc - ! 68 clm3%g%l%c%p%pns%retransn - ! 69 clm3%g%l%c%p%pps%elai - ! 70 clm3%g%l%c%p%pps%esai - ! 71 clm3%g%l%c%p%pps%hbot - ! 72 clm3%g%l%c%p%pps%htop - ! 73 clm3%g%l%c%p%pps%tlai - ! 74 clm3%g%l%c%p%pps%tsai - - end do OUT_TILE - - i = 1 - do nv = 1,VAR_COL - do nz = 1,nzone - STATUS = NF_PUT_VARA_REAL(OutID,VarID(OUTID,'CNCOL'), (/1,i/), (/NTILES,1 /),var_col_out(:, nz,nv)) - i = i + 1 - end do - end do - - i = 1 - do iv = 1,VAR_PFT - do nv = 1,nveg - do nz = 1,nzone - STATUS = NF_PUT_VARA_REAL(OutID,VarID(OUTID,'CNPFT'), (/1,i/), (/NTILES,1 /),var_pft_out(:, nz,nv,iv)) - i = i + 1 - end do - end do - end do - - VAR_DUM = 0. - - do nz = 1,nzone - STATUS = NF_PUT_VARA_REAL(OutID,VarID(OUTID,'TGWM'), (/1,nz/), (/NTILES,1 /),VAR_DUM(:)) - STATUS = NF_PUT_VARA_REAL(OutID,VarID(OUTID,'RZMM'), (/1,nz/), (/NTILES,1 /),VAR_DUM(:)) - end do - - STATUS = NF_PUT_VARA_REAL(OutID,VarID(OUTID,'SFMCM'), (/1/), (/NTILES/),VAR_DUM(:)) - STATUS = NF_PUT_VARA_REAL(OutID,VarID(OUTID,'BFLOWM'), (/1/), (/NTILES/),VAR_DUM(:)) - STATUS = NF_PUT_VARA_REAL(OutID,VarID(OUTID,'TOTWATM'), (/1/), (/NTILES/),VAR_DUM(:)) - STATUS = NF_PUT_VARA_REAL(OutID,VarID(OUTID,'TAIRM'), (/1/), (/NTILES/),VAR_DUM(:)) - STATUS = NF_PUT_VARA_REAL(OutID,VarID(OUTID,'TPM'), (/1/), (/NTILES/),VAR_DUM(:)) - STATUS = NF_PUT_VARA_REAL(OutID,VarID(OUTID,'CNSUM'), (/1/), (/NTILES/),VAR_DUM(:)) - STATUS = NF_PUT_VARA_REAL(OutID,VarID(OUTID,'SNDZM'), (/1/), (/NTILES/),VAR_DUM(:)) - STATUS = NF_PUT_VARA_REAL(OutID,VarID(OUTID,'ASNOWM'), (/1/), (/NTILES/),VAR_DUM(:)) - - do nv = 1,nzone - do nz = 1,nveg - STATUS = NF_PUT_VARA_REAL(OutID,VarID(OUTID,'PSNSUNM'), (/1,nz,nv/), (/NTILES,1,1/),VAR_DUM(:)) - STATUS = NF_PUT_VARA_REAL(OutID,VarID(OUTID,'PSNSHAM'), (/1,nz,nv/), (/NTILES,1,1/),VAR_DUM(:)) - end do - end do - - STATUS = NF_CLOSE (NCFID) - STATUS = NF_CLOSE (OutID) - - deallocate (var_off_col,var_off_pft,var_col_out,var_pft_out) - deallocate (CLMC_pf1, CLMC_pf2, CLMC_sf1, CLMC_sf2) - deallocate (CLMC_pt1, CLMC_pt2, CLMC_st1, CLMC_st2) - - endif - - call MPI_Barrier(MPI_COMM_WORLD, STATUS) - - - END SUBROUTINE regrid_carbon_vars - - ! ***************************************************************************** - - SUBROUTINE NCDF_reshape_getOput (NCFID,CID,col,pft, get_var) - - implicit none - - integer, intent (in) :: NCFID,CID - logical, intent (in) :: get_var - real, intent (inout) :: col (nzone * VAR_COL) - real, intent (inout) :: pft (nzone * nveg * var_PFT) - integer :: STATUS - - if (get_var) then - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'CNCOL'), (/CID,1/), (/1,nzone * VAR_COL /),col) - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'CNPFT'), (/CID,1/), (/1,nzone * nveg * var_PFT/),pft) - else - STATUS = NF_PUT_VARA_REAL(NCFID,VarID(NCFID,'CNCOL'), (/CID,1/), (/1,nzone * VAR_COL /),col) - STATUS = NF_PUT_VARA_REAL(NCFID,VarID(NCFID,'CNPFT'), (/CID,1/), (/1,nzone * nveg * var_PFT/),pft) - endif - - IF ((STATUS .NE. NF_NOERR).and.(get_var)) then - print *,CID - CALL HANDLE_ERR(STATUS, 'Out : NCDF_reshape_getOput') - ENDIF - - IF ((STATUS .NE. NF_NOERR).and.(.not.get_var)) then - print *,CID - CALL HANDLE_ERR(STATUS, 'In : NCDF_reshape_getOput') - ENDIF - END SUBROUTINE NCDF_reshape_getOput - - ! ***************************************************************************** - - SUBROUTINE NCDF_whole_getOput (NCFID,NTILES,col,pft, get_var) - - implicit none - - integer, intent (in) :: NCFID,NTILES - logical, intent (in) :: get_var - real, intent (inout) :: col (NTILES, nzone * VAR_COL) - real, intent (inout) :: pft (NTILES, nzone * nveg * var_PFT) - integer :: STATUS, J - - if (get_var) then - DO J = 1,nzone * VAR_COL - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'CNCOL'), (/1,J/), (/NTILES,1 /),col(:,j)) - END DO - DO J = 1, nzone * nveg * var_PFT - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'CNPFT'), (/1,J/), (/NTILES,1/),pft(:,J)) - END DO - else - DO J = 1,nzone * VAR_COL - STATUS = NF_PUT_VARA_REAL(NCFID,VarID(NCFID,'CNCOL'), (/1,J/), (/NTILES,1 /),col(:,J)) - END DO - DO J = 1, nzone * nveg * var_PFT - STATUS = NF_PUT_VARA_REAL(NCFID,VarID(NCFID,'CNPFT'), (/1,J/), (/NTILES,1/) ,pft(:,J)) - END DO - endif - - IF ((STATUS .NE. NF_NOERR).and.(get_var)) CALL HANDLE_ERR(STATUS, 'Out : NCDF_whole_getOput') - IF ((STATUS .NE. NF_NOERR).and.(.not.get_var)) CALL HANDLE_ERR(STATUS, 'In : NCDF_whole_getOput') - - END SUBROUTINE NCDF_whole_getOput - - ! ----------------------------------------------------------------------- - - SUBROUTINE HANDLE_ERR(STATUS, Line) - - INTEGER, INTENT (IN) :: STATUS - CHARACTER(*), INTENT (IN) :: Line - - IF (STATUS .NE. NF_NOERR) THEN - PRINT *, trim(Line),': ',NF_STRERROR(STATUS) - STOP 'Stopped' - ENDIF - - END SUBROUTINE HANDLE_ERR - - ! ***************************************************************************** - - integer function VarID (NCFID, VNAME) - - integer, intent (in) :: NCFID - character(*), intent (in) :: VNAME - integer :: status - - STATUS = NF_INQ_VARID (NCFID, trim(VNAME) ,VarID) - IF (STATUS .NE. NF_NOERR) & - CALL HANDLE_ERR(STATUS, trim(VNAME)) - - end function VarID - - ! ***************************************************************************** - - SUBROUTINE regrid_hyd_vars (NTILES, OutFMT) - - implicit none - integer, intent (in) :: NTILES - - ! =============================================================================================== - - integer, allocatable, dimension(:) :: Id_glb, Id_loc - integer, allocatable, dimension(:) :: ld_reorder, tid_offl - real , allocatable, dimension(:) :: tmp_var - integer :: n,i,j, nv, nx, offl_cell, STATUS,NCFID, req - integer :: outid, local_id - real , pointer, dimension (:) :: lonc, latc, LATT, LONN, long, latg - integer, allocatable :: low_ind(:), upp_ind(:), nt_local (:) - type(Netcdf4_Fileformatter) :: InFmt, OutFmt - - allocate (tid_offl (ntiles_cn)) - allocate (tmp_var (ntiles_cn)) - - allocate(low_ind ( numprocs)) - allocate(upp_ind ( numprocs)) - allocate(nt_local( numprocs)) - - low_ind (:) = 1 - upp_ind (:) = NTILES - nt_local(:) = NTILES - - ! Domain decomposition - ! -------------------- - - if (numprocs > 1) then - do i = 1, numprocs - 1 - upp_ind(i) = low_ind(i) + (ntiles/numprocs) - 1 - low_ind(i+1) = upp_ind(i) + 1 - nt_local(i) = upp_ind(i) - low_ind(i) + 1 - end do - nt_local(numprocs) = upp_ind(numprocs) - low_ind(numprocs) + 1 - endif - - allocate (id_loc (nt_local (myid + 1))) - allocate (lonn (nt_local (myid + 1))) - allocate (latt (nt_local (myid + 1))) - allocate (lonc (1:ntiles_cn)) - allocate (latc (1:ntiles_cn)) - - if (root_proc) then - - allocate (long (ntiles)) - allocate (latg (ntiles)) - allocate (ld_reorder(ntiles_cn)) - - call ReadTileFile_RealLatLon (OutTileFile, i, xlon=long, xlat=latg) - - ! --------------------------------------------- - ! Read exact lonc, latc from offline .til File - ! --------------------------------------------- - - call ReadTileFile_RealLatLon(trim(InCNTilFile), i,xlon=lonc,xlat=latc) - - STATUS = NF_OPEN (trim(InCNRestart),NF_NOWRITE,NCFID) - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'TILE_ID' ), (/1/), (/NTILES_CN/),tmp_var) - STATUS = NF_CLOSE (NCFID) - - do n = 1, ntiles_cn - ld_reorder ( NINT(tmp_var(n))) = n - tid_offl(n) = n - end do - - deallocate (tmp_var) - - endif - - call MPI_Barrier(MPI_COMM_WORLD, STATUS) - - do i = 1, numprocs - if((I == 1).and.(myid == 0)) then - lonn(:) = long(low_ind(i) : upp_ind(i)) - latt(:) = latg(low_ind(i) : upp_ind(i)) - else if (I > 1) then - if(I-1 == myid) then - ! receiving from root - call MPI_RECV(lonn,nt_local(i) , MPI_REAL, 0,995,MPI_COMM_WORLD,MPI_STATUS_IGNORE,mpierr) - call MPI_RECV(latt,nt_local(i) , MPI_REAL, 0,994,MPI_COMM_WORLD,MPI_STATUS_IGNORE,mpierr) - else if (myid == 0) then - ! root sends - call MPI_ISend(long(low_ind(i) : upp_ind(i)),nt_local(i),MPI_REAL,i-1,995,MPI_COMM_WORLD,req,mpierr) - call MPI_WAIT (req,MPI_STATUS_IGNORE,mpierr) - call MPI_ISend(latg(low_ind(i) : upp_ind(i)),nt_local(i),MPI_REAL,i-1,994,MPI_COMM_WORLD,req,mpierr) - call MPI_WAIT (req,MPI_STATUS_IGNORE,mpierr) - endif - endif - end do - -! call MPI_SCATTERV ( & -! long,nt_local,low_ind-1,MPI_real, & -! lonn,size(lonn),MPI_real , & -! 0,MPI_COMM_WORLD, mpierr ) -! -! call MPI_SCATTERV ( & -! latg,nt_local,low_ind-1,MPI_real, & -! latt,nt_local(myid+1),MPI_real , & -! 0,MPI_COMM_WORLD, mpierr ) - - if(root_proc) deallocate (long, latg) - - call MPI_BCAST(lonc,ntiles_cn,MPI_REAL,0,MPI_COMM_WORLD,mpierr) - call MPI_BCAST(latc,ntiles_cn,MPI_REAL,0,MPI_COMM_WORLD,mpierr) - call MPI_BCAST(tid_offl,size(tid_offl ),MPI_INTEGER,0,MPI_COMM_WORLD,mpierr) - - ! -------------------------------------------------------------------------------- - ! Here we create transfer index array to map offline restarts to output tile space - ! -------------------------------------------------------------------------------- - - call GetIds(lonc,latc,lonn,latt,id_loc, tid_offl) - - ! Loop through NTILES (# of tiles in output array) find the nearest neighbor from Qing. - - if(root_proc) allocate (id_glb (ntiles)) - - call MPI_Barrier(MPI_COMM_WORLD, STATUS) - - do i = 1, numprocs - if((I == 1).and.(myid == 0)) then - id_glb(low_ind(i) : upp_ind(i)) = Id_loc(:) - else if (I > 1) then - if(I-1 == myid) then - ! send to root - call MPI_ISend(id_loc,nt_local(i),MPI_INTEGER,0,993,MPI_COMM_WORLD,req,mpierr) - call MPI_WAIT (req,MPI_STATUS_IGNORE,mpierr) - else if (myid == 0) then - ! root receives - call MPI_RECV(id_glb(low_ind(i) : upp_ind(i)),nt_local(i) , MPI_INTEGER, i-1,993,MPI_COMM_WORLD,MPI_STATUS_IGNORE,mpierr) - endif - endif - end do - -! call MPI_GATHERV( & -! id_loc, nt_local(myid+1) , MPI_real, & -! id_glb, nt_local,low_ind-1, MPI_real, & -! 0, MPI_COMM_WORLD, mpierr ) - - if (root_proc) call put_land_vars (NTILES, id_glb, ld_reorder, OutFmt) - - call MPI_Barrier(MPI_COMM_WORLD, STATUS) - - END SUBROUTINE regrid_hyd_vars - - ! ***************************************************************************** - SUBROUTINE put_land_vars (NTILES, id_glb, ld_reorder, OutFmt) - - implicit none - - integer, intent (in) :: NTILES - integer, intent (in) :: id_glb(NTILES), ld_reorder (NTILES_CN) - integer :: i,k,n - real , dimension (:), allocatable :: var_get, var_put - type(Netcdf4_Fileformatter) :: OutFmt - integer :: nVars, STATUS, NCFID - - allocate (var_get (NTILES_CN)) - allocate (var_put (NTILES)) - - ! Read catparam - ! ------------- - - STATUS = NF_OPEN (trim(InCNRestart),NF_NOWRITE,NCFID) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'POROS' ), (/1/), (/NTILES_CN/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'POROS',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'COND' ), (/1/), (/NTILES_CN/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'COND',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'PSIS' ), (/1/), (/NTILES_CN/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'PSIS',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'BEE' ), (/1/), (/NTILES_CN/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'BEE',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'WPWET' ), (/1/), (/NTILES_CN/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'WPWET',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'GNU' ), (/1/), (/NTILES_CN/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'GNU',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'VGWMAX' ), (/1/), (/NTILES_CN/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'VGWMAX',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'BF1' ), (/1/), (/NTILES_CN/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'BF1',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'BF2' ), (/1/), (/NTILES_CN/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'BF2',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'BF3' ), (/1/), (/NTILES_CN/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'BF3',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'CDCR1' ), (/1/), (/NTILES_CN/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'CDCR1',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'CDCR2' ), (/1/), (/NTILES_CN/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'CDCR2',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'ARS1' ), (/1/), (/NTILES_CN/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'ARS1',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'ARS2' ), (/1/), (/NTILES_CN/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'ARS2',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'ARS3' ), (/1/), (/NTILES_CN/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'ARS3',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'ARA1' ), (/1/), (/NTILES_CN/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'ARA1',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'ARA2' ), (/1/), (/NTILES_CN/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'ARA2',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'ARA3' ), (/1/), (/NTILES_CN/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'ARA3',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'ARA4' ), (/1/), (/NTILES_CN/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'ARA4',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'ARW1' ), (/1/), (/NTILES_CN/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'ARW1',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'ARW2' ), (/1/), (/NTILES_CN/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'ARW2',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'ARW3' ), (/1/), (/NTILES_CN/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'ARW3',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'ARW4' ), (/1/), (/NTILES_CN/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'ARW4',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'TSA1' ), (/1/), (/NTILES_CN/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'TSA1',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'TSA2' ), (/1/), (/NTILES_CN/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'TSA2',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'TSB1' ), (/1/), (/NTILES_CN/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'TSB1',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'TSB2' ), (/1/), (/NTILES_CN/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'TSB2',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'ATAU' ), (/1/), (/NTILES_CN/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'ATAU',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'BTAU' ), (/1/), (/NTILES_CN/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'BTAU',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'ITY' ), (/1,1/), (/NTILES_CN,1/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'ITY',var_put, offset1=1) - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'ITY' ), (/1,2/), (/NTILES_CN,1/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'ITY',var_put, offset1=2) - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'ITY' ), (/1,3/), (/NTILES_CN,1/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'ITY',var_put, offset1=3) - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'ITY' ), (/1,4/), (/NTILES_CN,1/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'ITY',var_put, offset1=4) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'FVG' ), (/1,1/), (/NTILES_CN,1/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'FVG',var_put, offset1=1) - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'FVG' ), (/1,2/), (/NTILES_CN,1/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'FVG',var_put, offset1=2) - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'FVG' ), (/1,3/), (/NTILES_CN,1/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'FVG',var_put, offset1=3) - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'FVG' ), (/1,4/), (/NTILES_CN,1/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'FVG',var_put, offset1=4) - - ! read restart and regrid - ! ----------------------- - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'TG' ), (/1,1/), (/NTILES_CN,1/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'TG',var_put, offset1=1) ! if you see offset1=1 it is a 2-D var - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'TG' ), (/1,2/), (/NTILES_CN,1/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'TG',var_put, offset1=2) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'TG' ), (/1,3/), (/NTILES_CN,1/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'TG',var_put, offset1=3) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'TC' ), (/1,1/), (/NTILES_CN,1/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'TC',var_put, offset1=1) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'TC' ), (/1,2/), (/NTILES_CN,1/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'TC',var_put, offset1=2) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'TC' ), (/1,3/), (/NTILES_CN,1/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'TC',var_put, offset1=3) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'QC' ), (/1,1/), (/NTILES_CN,1/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'QC',var_put, offset1=1) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'QC' ), (/1,2/), (/NTILES_CN,1/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'QC',var_put, offset1=2) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'QC' ), (/1,3/), (/NTILES_CN,1/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'QC',var_put, offset1=3) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'CAPAC' ), (/1/), (/NTILES_CN/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'CAPAC',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'CATDEF' ), (/1/), (/NTILES_CN/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'CATDEF',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'RZEXC' ), (/1/), (/NTILES_CN/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'RZEXC',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'SRFEXC' ), (/1/), (/NTILES_CN/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'SRFEXC',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'GHTCNT1' ), (/1/), (/NTILES_CN/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'GHTCNT1',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'GHTCNT2' ), (/1/), (/NTILES_CN/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'GHTCNT2',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'GHTCNT3' ), (/1/), (/NTILES_CN/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'GHTCNT3',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'GHTCNT4' ), (/1/), (/NTILES_CN/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'GHTCNT4',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'GHTCNT5' ), (/1/), (/NTILES_CN/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'GHTCNT5',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'GHTCNT6' ), (/1/), (/NTILES_CN/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'GHTCNT6',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'WESNN1' ), (/1/), (/NTILES_CN/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'WESNN1',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'WESNN2' ), (/1/), (/NTILES_CN/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'WESNN2',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'WESNN3' ), (/1/), (/NTILES_CN/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'WESNN3',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'HTSNNN1' ), (/1/), (/NTILES_CN/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'HTSNNN1',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'HTSNNN2' ), (/1/), (/NTILES_CN/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'HTSNNN2',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'HTSNNN3' ), (/1/), (/NTILES_CN/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'HTSNNN3',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'SNDZN1' ), (/1/), (/NTILES_CN/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'SNDZN1',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'SNDZN2' ), (/1/), (/NTILES_CN/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'SNDZN2',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'SNDZN3' ), (/1/), (/NTILES_CN/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'SNDZN3',var_put) - - STATUS = NF_CLOSE ( NCFID) - - deallocate (var_get, var_put) - - END SUBROUTINE put_land_vars - - ! ***************************************************************************** - subroutine init_MPI() - - ! initialize MPI - - call MPI_INIT(mpierr) - - call MPI_COMM_RANK( MPI_COMM_WORLD, myid, mpierr ) - call MPI_COMM_SIZE( MPI_COMM_WORLD, numprocs, mpierr ) - - if (myid .ne. 0) root_proc = .false. - -! write (*,*) "MPI process ", myid, " of ", numprocs, " is alive" -! write (*,*) "MPI process ", myid, ": root_proc=", root_proc - - end subroutine init_MPI - - ! ***************************************************************************** - -end program mk_CatchCNRestarts - diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/mk_CatchRestarts.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/mk_CatchRestarts.F90 deleted file mode 100644 index 26884ad03..000000000 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/mk_CatchRestarts.F90 +++ /dev/null @@ -1,778 +0,0 @@ -#define I_AM_MAIN -#include "MAPL_Generic.h" -program mk_CatchRestarts - -! $Id: - - use MAPL - use mk_restarts_getidsMod, only: GetIDs,ReadTileFile_RealLatLon - use gFTL_StringVector - - implicit none - include 'mpif.h' - ! initialize to non-MPI values - - integer :: myid=0, numprocs=1, mpierr, mpistatus(MPI_STATUS_SIZE) - logical :: root_proc=.true. - - character*256 :: Usage="mk_CatchRestarts OutTileFile InTileFile InRestart SURFLAY " - character*256 :: OutTileFile - character*256 :: InTileFile - character*256 :: InRestart - character*256 :: OutType - character*256 :: arg(6) - - integer :: i, k, iargc, n, ntiles,ntiles_in, nplus, req - integer, pointer :: Id(:), tid_in (:) - real, pointer :: loni(:),lono(:), lati(:), lato(:) - real :: SURFLAY - integer, allocatable :: low_ind(:), upp_ind(:), nt_local (:), Id_loc (:) - real , pointer, dimension (:) :: LATT, LONN - logical :: OutIsOld, havedata - character*256, parameter :: DataDir="OutData/clsm/" - real :: min_lon, max_lon, min_lat, max_lat - logical, allocatable, dimension(:) :: mask - integer, allocatable, dimension (:) :: sub_tid - real , allocatable, dimension (:) :: sub_lon, sub_lat - integer :: status - - call init_MPI() - -!--------------------------------------------------------------------------- - - I = iargc() - - if( I<4 .or. I>5 ) then - print *, "Wrong Number of arguments: ", i - print *, trim(Usage) - call exit(1) - end if - - do n=1,I - call getarg(n,arg(n)) - enddo - read(arg(1),'(a)') OutTileFile - read(arg(2),'(a)') InTileFile - read(arg(3),'(a)') InRestart - read(arg(4),*) SURFLAY - - if(I==5) then - call getarg(6,OutType) - OutIsOld = trim(OutType)=="OutIsOld" - else - OutIsOld = .false. - endif - - if (SURFLAY.ne.20 .and. SURFLAY.ne.50) then - print *, "You must supply a valid SURFLAY value:" - print *, "(Ganymed-3 and earlier) SURFLAY=20.0 for Old Soil Params" - print *, "(Ganymed-4 and later ) SURFLAY=50.0 for New Soil Params" - call exit(2) - end if - - inquire(file=trim(DataDir)//"mosaic_veg_typs_fracs",exist=havedata) - - if (root_proc) then - - ! Read Output/Input .til files - call ReadTileFile_RealLatLon(OutTileFile, ntiles, xlon=lono, xlat=lato) - call ReadTileFile_RealLatLon(InTileFile,ntiles_in,xlon=loni, xlat=lati) - allocate(Id (ntiles)) - ! allocate(mask (ntiles_in)) - ! allocate(tid_in (ntiles_in)) - ! do n = 1, NTILES_IN - ! tid_in (n) = n - ! end do - - endif - - if (havedata) then - if (root_proc) call read_and_write_rst (NTILES, SURFLAY, OutIsOld, NTILES, __RC__) - else - - call MPI_BCAST (ntiles , 1, MPI_INTEGER, 0,MPI_COMM_WORLD, mpierr) - call MPI_BCAST (ntiles_in, 1, MPI_INTEGER, 0,MPI_COMM_WORLD, mpierr) - - allocate(low_ind ( numprocs)) - allocate(upp_ind ( numprocs)) - allocate(nt_local( numprocs)) - - low_ind (:) = 1 - upp_ind (:) = NTILES - nt_local(:) = NTILES - - if (numprocs > 1) then - do i = 1, numprocs - 1 - upp_ind(i) = low_ind(i) + (ntiles/numprocs) - 1 - low_ind(i+1) = upp_ind(i) + 1 - nt_local(i) = upp_ind(i) - low_ind(i) + 1 - end do - nt_local(numprocs) = upp_ind(numprocs) - low_ind(numprocs) + 1 - endif - - ! Get intile lat/lon - -! do i = 2, numprocs -! if (i -1 == myid) then -! ! receive ntiles_in in the block -! call MPI_RECV(ntiles_in, 1, MPI_INTEGER,0,999,MPI_COMM_WORLD,MPI_STATUS_IGNORE,mpierr) -! ! ALLOCATE -! allocate (loni (1:NTILES_IN)) -! allocate (lati (1:NTILES_IN)) -! allocate (tid_in (1:NTILES_IN)) -! -! ! RECEIVE LAT/LON IN -! call MPI_RECV(tid_in, ntiles_in, MPI_INTEGER,0,998,MPI_COMM_WORLD,MPI_STATUS_IGNORE,mpierr) -! call MPI_RECV(loni , ntiles_in, MPI_REAL ,0,997,MPI_COMM_WORLD,MPI_STATUS_IGNORE,mpierr) -! call MPI_RECV(lati , ntiles_in, MPI_REAL ,0,996,MPI_COMM_WORLD,MPI_STATUS_IGNORE,mpierr) -! -! else if (myid == 0) then -! -! ! Send local ntiles_in -! -! min_lon = MAX(MINVAL(lono (low_ind(i) : upp_ind(i))) - 5, -180.) -! max_lon = MIN(MAXVAL(lono (low_ind(i) : upp_ind(i))) + 5, 180.) -! min_lat = MAX(MINVAL(lato (low_ind(i) : upp_ind(i))) - 5, -90.) -! max_lat = MIN(MAXVAL(lato (low_ind(i) : upp_ind(i))) + 5, 90.) -! mask = .false. -! mask = ((lati >= min_lat .and. lati <= max_lat).and.(loni >= min_lon .and. loni <= max_lon)) -! nplus = count(mask = mask) -! -! call MPI_ISend(NPLUS ,1,MPI_INTEGER,i-1,999,MPI_COMM_WORLD,req,mpierr) -! call MPI_WAIT (req,MPI_STATUS_IGNORE,mpierr) -! -! -! ! SEND LAT/LON IN -! allocate (sub_tid (1:nplus)) -! allocate (sub_lon (1:nplus)) -! allocate (sub_lat (1:nplus)) -! -! sub_tid = PACK (tid_in , mask= mask) -! sub_lon = PACK (loni , mask= mask) -! sub_lat = PACK (lati , mask= mask) -! -! call MPI_ISend(sub_tid, nplus,MPI_INTEGER,i-1,998,MPI_COMM_WORLD,req,mpierr) -! call MPI_WAIT (req,MPI_STATUS_IGNORE,mpierr) -! call MPI_ISend(sub_lon, nplus,MPI_REAL ,i-1,997,MPI_COMM_WORLD,req,mpierr) -! call MPI_WAIT (req,MPI_STATUS_IGNORE,mpierr) -! call MPI_ISend(sub_lat, nplus,MPI_REAL ,i-1,996,MPI_COMM_WORLD,req,mpierr) -! call MPI_WAIT (req,MPI_STATUS_IGNORE,mpierr) -! deallocate (sub_tid,sub_lon,sub_lat) -! endif -! end do - - ! Get out tile lat/lots from root - - allocate (id_loc (nt_local (myid + 1))) - allocate (lonn (nt_local (myid + 1))) - allocate (latt (nt_local (myid + 1))) - - do i = 1, numprocs - if((I == 1).and.(myid == 0)) then - lonn(:) = lono(low_ind(i) : upp_ind(i)) - latt(:) = lato(low_ind(i) : upp_ind(i)) - else if (I > 1) then - if(I-1 == myid) then - ! receiving from root - call MPI_RECV(lonn,nt_local(i) , MPI_REAL, 0,995,MPI_COMM_WORLD,MPI_STATUS_IGNORE,mpierr) - call MPI_RECV(latt,nt_local(i) , MPI_REAL, 0,994,MPI_COMM_WORLD,MPI_STATUS_IGNORE,mpierr) - else if (myid == 0) then - ! root sends - call MPI_ISend(lono(low_ind(i) : upp_ind(i)),nt_local(i),MPI_REAL,i-1,995,MPI_COMM_WORLD,req,mpierr) - call MPI_WAIT (req,MPI_STATUS_IGNORE,mpierr) - call MPI_ISend(lato(low_ind(i) : upp_ind(i)),nt_local(i),MPI_REAL,i-1,994,MPI_COMM_WORLD,req,mpierr) - call MPI_WAIT (req,MPI_STATUS_IGNORE,mpierr) - endif - endif - end do - -! call MPI_SCATTERV ( & -! lono,nt_local,low_ind-1,MPI_real, & -! lonn,size(lonn),MPI_real , & -! 0,MPI_COMM_WORLD, mpierr ) -! -! call MPI_SCATTERV ( & -! lato,nt_local,low_ind-1,MPI_real, & -! latt,size(latt),MPI_real , & -! 0,MPI_COMM_WORLD, mpierr ) - - if(myid > 0) allocate (loni (1:NTILES_IN)) - if(myid > 0) allocate (lati (1:NTILES_IN)) - - call MPI_BCAST(loni,ntiles_in,MPI_REAL,0,MPI_COMM_WORLD,mpierr) - call MPI_BCAST(lati,ntiles_in,MPI_REAL,0,MPI_COMM_WORLD,mpierr) - - allocate(tid_in (ntiles_in)) - do n = 1, NTILES_IN - tid_in (n) = n - end do - - call GetIds(loni,lati,lonn,latt,Id_loc, tid_in) - call MPI_Barrier(MPI_COMM_WORLD, mpierr) -! call MPI_GATHERV( & -! id_loc (:), nt_local(myid+1), MPI_real, & -! id, nt_local,low_ind-1, MPI_real, & -! 0, MPI_COMM_WORLD, mpierr ) - - do i = 1, numprocs - if((I == 1).and.(myid == 0)) then - id(low_ind(i) : upp_ind(i)) = Id_loc(:) - else if (I > 1) then - if(I-1 == myid) then - ! send to root - call MPI_ISend(id_loc,nt_local(i),MPI_INTEGER,0,993,MPI_COMM_WORLD,req,mpierr) - call MPI_WAIT (req,MPI_STATUS_IGNORE,mpierr) - else if (myid == 0) then - ! root receives - call MPI_RECV(id(low_ind(i) : upp_ind(i)),nt_local(i) , MPI_INTEGER, i-1,993,MPI_COMM_WORLD,MPI_STATUS_IGNORE,mpierr) - endif - endif - end do - - deallocate (loni,lati,lonn,latt, tid_in) - call MPI_Barrier(MPI_COMM_WORLD, mpierr) - - if (root_proc) call read_and_write_rst (NTILES, SURFLAY, OutIsOld, NTILES_IN, id, __RC__) - - endif - - call MPI_BARRIER( MPI_COMM_WORLD, mpierr) - call MPI_FINALIZE(mpierr) - -contains - - SUBROUTINE read_and_write_rst (NTILES, SURFLAY, OutIsOld, NTILES_IN, idi, rc) - - implicit none - real, intent (in) :: SURFLAY - logical, intent (in) :: OutIsOld - integer, intent (in) :: NTILES, NTILES_IN - integer, pointer, dimension(:), optional, intent (in) :: idi - integer, optional, intent(out) :: rc - logical :: havedata, NewLand - character(len=256), parameter :: Names(29) = & - (/'BF1 ','BF2 ','BF3 ','VGWMAX','CDCR1 ', & - 'CDCR2 ','PSIS ','BEE ','POROS ','WPWET ', & - 'COND ','GNU ','ARS1 ','ARS2 ','ARS3 ', & - 'ARA1 ','ARA2 ','ARA3 ','ARA4 ','ARW1 ', & - 'ARW2 ','ARW3 ','ARW4 ','TSA1 ','TSA2 ', & - 'TSB1 ','TSB2 ','ATAU ','BTAU '/) - - integer, pointer :: ity(:) - real, allocatable :: BF1(:), BF2(:), BF3(:), VGWMAX(:) - real, allocatable :: CDCR1(:), CDCR2(:), PSIS(:), BEE(:) - real, allocatable :: POROS(:), WPWET(:), COND(:), GNU(:) - real, allocatable :: ARS1(:), ARS2(:), ARS3(:) - real, allocatable :: ARA1(:), ARA2(:), ARA3(:), ARA4(:) - real, allocatable :: ARW1(:), ARW2(:), ARW3(:), ARW4(:) - real, allocatable :: TSA1(:), TSA2(:), TSB1(:), TSB2(:) - real, allocatable :: ATAU2(:), BTAU2(:), DP2BR(:), rity(:) - - real :: zdep1, zdep2, zdep3, zmet, term1, term2, rdum - real, allocatable :: var1(:),var2(:,:) - character*256 :: vname - character*256 :: OutFileName - integer :: i, n, j,k,ncatch,idum - logical,allocatable :: written(:) - integer :: ndims,filetype - integer :: dimSizes(3),nVars - logical :: file_exists - integer, pointer :: Ido(:), idx(:), id(:) - logical :: InIsOld - type(NetCDF4_Fileformatter) :: InFmt,OutFmt,CatchFmt - type(FileMetadata) :: InCfg,OutCfg - type(StringVariableMap), pointer :: variables - type(Variable), pointer :: myVariable - type(StringVariableMapIterator) :: var_iter - character(len=:), pointer :: var_name,dname - type(StringVector), pointer :: var_dimensions - integer :: dim1, dim2 - character(256) :: Iam = "read_and_write_rst" - integer :: status - - print *, 'SURFLAY: ',SURFLAY - - inquire(file=trim(DataDir)//"mosaic_veg_typs_fracs",exist=havedata) - inquire(file=trim(DataDir)//"CLM_veg_typs_fracs" ,exist=NewLand ) - - print *, 'havedata = ',havedata - - call MAPL_NCIOGetFileType(InRestart, filetype,__RC__) - - if (filetype == 0) then - - call InFmt%open(InRestart,pFIO_READ,__RC__) - InCfg=InFmt%read(__RC__) - call MAPL_IOChangeRes(InCfg,OutCfg,(/'tile'/),(/ntiles/),__RC__) - i = index(InRestart,'/',back=.true.) - OutFileName = "OutData/"//trim(InRestart(i+1:)) - call OutFmt%create(OutFileName,__RC__) - call OutFmt%write(OutCfg,__RC__) - call MAPL_IOCountNonDimVars(OutCfg,nvars,__RC__) - - allocate(written(nvars)) - written=.false. - - else - - open(unit=50,FILE=InRestart,form='unformatted',& - status='old',convert='little_endian') - - do i=1,58 - read(50,end=2001) - end do -2001 continue - InIsOld = I==59 - - rewind(50) - - i = index(InRestart,'/',back=.true.) - - open(unit=40,FILE="OutData/"//trim(InRestart(i+1:)),form='unformatted',& - status='unknown',convert='little_endian') - - end if - - HAVE: if(havedata) then - - print *,'Working from Sariths data pretiled for this resolution' - - ! Get number of catchments - - open(unit=22, & - file=trim(DataDir)//"catchment.def",status='old',form='formatted') - - read (22, *) ncatch - - close(22) - - if(ncatch==ntiles) then - print *, "Read ",Ncatch," land tiles." - allocate (ido (ntiles)) - do i=1,ncatch - ido(i) = i - enddo - else - print *, "Number of tiles in data, ",Ncatch," does not match number in til file ", size(Ido) - call exit(1) - endif - - allocate(ity(ncatch),rity(ncatch)) - allocate ( BF1(ncatch), BF2 (ncatch), BF3(ncatch) ) - allocate (VGWMAX(ncatch), CDCR1(ncatch), CDCR2(ncatch) ) - allocate ( PSIS(ncatch), BEE(ncatch), POROS(ncatch) ) - allocate ( WPWET(ncatch), COND(ncatch), GNU(ncatch) ) - allocate ( ARS1(ncatch), ARS2(ncatch), ARS3(ncatch) ) - allocate ( ARA1(ncatch), ARA2(ncatch), ARA3(ncatch) ) - allocate ( ARA4(ncatch), ARW1(ncatch), ARW2(ncatch) ) - allocate ( ARW3(ncatch), ARW4(ncatch), TSA1(ncatch) ) - allocate ( TSA2(ncatch), TSB1(ncatch), TSB2(ncatch) ) - allocate ( ATAU2(ncatch), BTAU2(ncatch), DP2BR(ncatch) ) - - inquire(file = trim(DataDir)//'/catch_params.nc4', exist=file_exists) - - if(file_exists) then - print *,'FILE FORMAT FOR LAND BCS IS NC4' - call CatchFmt%open(trim(DataDir)//'/catch_params.nc4',pFIO_Read, __RC__) - call MAPL_VarRead ( catchFmt ,'OLD_ITY', rity, __RC__) - call MAPL_VarRead ( catchFmt ,'ARA1', ARA1, __RC__) - call MAPL_VarRead ( catchFmt ,'ARA2', ARA2, __RC__) - call MAPL_VarRead ( catchFmt ,'ARA3', ARA3, __RC__) - call MAPL_VarRead ( catchFmt ,'ARA4', ARA4, __RC__) - call MAPL_VarRead ( catchFmt ,'ARS1', ARS1, __RC__) - call MAPL_VarRead ( catchFmt ,'ARS2', ARS2, __RC__) - call MAPL_VarRead ( catchFmt ,'ARS3', ARS3, __RC__) - call MAPL_VarRead ( catchFmt ,'ARW1', ARW1, __RC__) - call MAPL_VarRead ( catchFmt ,'ARW2', ARW2, __RC__) - call MAPL_VarRead ( catchFmt ,'ARW3', ARW3, __RC__) - call MAPL_VarRead ( catchFmt ,'ARW4', ARW4, __RC__) - - if( SURFLAY.eq.20.0 ) then - call MAPL_VarRead ( catchFmt ,'ATAU2', ATAU2, __RC__) - call MAPL_VarRead ( catchFmt ,'BTAU2', BTAU2, __RC__) - endif - - if( SURFLAY.eq.50.0 ) then - call MAPL_VarRead ( catchFmt ,'ATAU5', ATAU2, __RC__) - call MAPL_VarRead ( catchFmt ,'BTAU5', BTAU2, __RC__) - endif - - call MAPL_VarRead ( catchFmt ,'PSIS', PSIS, __RC__) - call MAPL_VarRead ( catchFmt ,'BEE', BEE, __RC__) - call MAPL_VarRead ( catchFmt ,'BF1', BF1, __RC__) - call MAPL_VarRead ( catchFmt ,'BF2', BF2, __RC__) - call MAPL_VarRead ( catchFmt ,'BF3', BF3, __RC__) - call MAPL_VarRead ( catchFmt ,'TSA1', TSA1, __RC__) - call MAPL_VarRead ( catchFmt ,'TSA2', TSA2, __RC__) - call MAPL_VarRead ( catchFmt ,'TSB1', TSB1, __RC__) - call MAPL_VarRead ( catchFmt ,'TSB2', TSB2, __RC__) - call MAPL_VarRead ( catchFmt ,'COND', COND, __RC__) - call MAPL_VarRead ( catchFmt ,'GNU', GNU, __RC__) - call MAPL_VarRead ( catchFmt ,'WPWET', WPWET, __RC__) - call MAPL_VarRead ( catchFmt ,'DP2BR', DP2BR, __RC__) - call MAPL_VarRead ( catchFmt ,'POROS', POROS, __RC__) - call catchFmt%close(__RC__) - - else - open(unit=21, file=trim(DataDir)//"mosaic_veg_typs_fracs",status='old',form='formatted') - open(unit=22, file=trim(DataDir)//'bf.dat' ,form='formatted') - open(unit=23, file=trim(DataDir)//'soil_param.dat' ,form='formatted') - open(unit=24, file=trim(DataDir)//'ar.new' ,form='formatted') - open(unit=25, file=trim(DataDir)//'ts.dat' ,form='formatted') - open(unit=26, file=trim(DataDir)//'tau_param.dat' ,form='formatted') - - do n=1,ncatch - read (21,*) I, j, ITY(N) - read (22, *) i,j, GNU(n), BF1(n), BF2(n), BF3(n) - - read (23, *) i,j, idum, idum, BEE(n), PSIS(n),& - POROS(n), COND(n), WPWET(n), DP2BR(n) - - read (24, *) i,j, rdum, ARS1(n), ARS2(n), ARS3(n), & - ARA1(n), ARA2(n), ARA3(n), ARA4(n), & - ARW1(n), ARW2(n), ARW3(n), ARW4(n) - - read (25, *) i,j, rdum, TSA1(n), TSA2(n), TSB1(n), TSB2(n) - - if( SURFLAY.eq.20.0 ) read (26, *) i,j, ATAU2(n), BTAU2(n), rdum, rdum ! for old soil params - if( SURFLAY.eq.50.0 ) read (26, *) i,j, rdum , rdum, ATAU2(n), BTAU2(n) ! for new soil params - end do - - rity = float(ity) - CLOSE (21, STATUS = 'KEEP') - CLOSE (22, STATUS = 'KEEP') - CLOSE (23, STATUS = 'KEEP') - CLOSE (24, STATUS = 'KEEP') - CLOSE (25, STATUS = 'KEEP') - - endif - - do n=1,ncatch - - zdep2=1000. - zdep3=amax1(1000.,DP2BR(n)) - - if (zdep2 > 0.75*zdep3) then - zdep2 = 0.75*zdep3 - end if - - zdep1=20. - zmet=zdep3/1000. - - term1=-1.+((PSIS(n)-zmet)/PSIS(n))**((BEE(n)-1.)/BEE(n)) - term2=PSIS(n)*BEE(n)/(BEE(n)-1) - - VGWMAX(n) = POROS(n)*zdep2 - CDCR1(n) = 1000.*POROS(n)*(zmet-(-term2*term1)) - CDCR2(n) = (1.-WPWET(n))*POROS(n)*zdep3 - enddo - - - if (filetype /=0) then - do i=1,30 - read(50) - enddo - end if - - idx => ido - - else - - print *,'Working from restarts alone' - - ncatch = NTILES_IN - - allocate ( rity(ncatch)) - allocate ( BF1(ncatch), BF2 (ncatch), BF3(ncatch) ) - allocate (VGWMAX(ncatch), CDCR1(ncatch), CDCR2(ncatch) ) - allocate ( PSIS(ncatch), BEE(ncatch), POROS(ncatch) ) - allocate ( WPWET(ncatch), COND(ncatch), GNU(ncatch) ) - allocate ( ARS1(ncatch), ARS2(ncatch), ARS3(ncatch) ) - allocate ( ARA1(ncatch), ARA2(ncatch), ARA3(ncatch) ) - allocate ( ARA4(ncatch), ARW1(ncatch), ARW2(ncatch) ) - allocate ( ARW3(ncatch), ARW4(ncatch), TSA1(ncatch) ) - allocate ( TSA2(ncatch), TSB1(ncatch), TSB2(ncatch) ) - allocate ( ATAU2(ncatch), BTAU2(ncatch), DP2BR(ncatch) ) - - if (filetype == 0) then - - call MAPL_VarRead(InFmt,names(1),BF1, __RC__) - call MAPL_VarRead(InFmt,names(2),BF2, __RC__) - call MAPL_VarRead(InFmt,names(3),BF3, __RC__) - call MAPL_VarRead(InFmt,names(4),VGWMAX, __RC__) - call MAPL_VarRead(InFmt,names(5),CDCR1, __RC__) - call MAPL_VarRead(InFmt,names(6),CDCR2, __RC__) - call MAPL_VarRead(InFmt,names(7),PSIS, __RC__) - call MAPL_VarRead(InFmt,names(8),BEE, __RC__) - call MAPL_VarRead(InFmt,names(9),POROS, __RC__) - call MAPL_VarRead(InFmt,names(10),WPWET, __RC__) - - call MAPL_VarRead(InFmt,names(11),COND, __RC__) - call MAPL_VarRead(InFmt,names(12),GNU, __RC__) - call MAPL_VarRead(InFmt,names(13),ARS1, __RC__) - call MAPL_VarRead(InFmt,names(14),ARS2, __RC__) - call MAPL_VarRead(InFmt,names(15),ARS3, __RC__) - call MAPL_VarRead(InFmt,names(16),ARA1, __RC__) - call MAPL_VarRead(InFmt,names(17),ARA2, __RC__) - call MAPL_VarRead(InFmt,names(18),ARA3, __RC__) - call MAPL_VarRead(InFmt,names(19),ARA4, __RC__) - call MAPL_VarRead(InFmt,names(20),ARW1, __RC__) - - call MAPL_VarRead(InFmt,names(21),ARW2, __RC__) - call MAPL_VarRead(InFmt,names(22),ARW3, __RC__) - call MAPL_VarRead(InFmt,names(23),ARW4, __RC__) - call MAPL_VarRead(InFmt,names(24),TSA1, __RC__) - call MAPL_VarRead(InFmt,names(25),TSA2, __RC__) - call MAPL_VarRead(InFmt,names(26),TSB1, __RC__) - call MAPL_VarRead(InFmt,names(27),TSB2, __RC__) - call MAPL_VarRead(InFmt,names(28),ATAU2, __RC__) - call MAPL_VarRead(InFmt,names(29),BTAU2, __RC__) - call MAPL_VarRead(InFmt,'OLD_ITY',rITY, __RC__) - - else - - read(50) BF1 - read(50) BF2 - read(50) BF3 - read(50) VGWMAX - read(50) CDCR1 - read(50) CDCR2 - read(50) PSIS - read(50) BEE - read(50) POROS - read(50) WPWET - - read(50) COND - read(50) GNU - read(50) ARS1 - read(50) ARS2 - read(50) ARS3 - read(50) ARA1 - read(50) ARA2 - read(50) ARA3 - read(50) ARA4 - read(50) ARW1 - - read(50) ARW2 - read(50) ARW3 - read(50) ARW4 - read(50) TSA1 - read(50) TSA2 - read(50) TSB1 - read(50) TSB2 - read(50) ATAU2 - read(50) BTAU2 - read(50) rITY - - end if - - idx => idi - - endif HAVE - - if (filetype == 0) then - call MAPL_VarWrite(OutFmt,names(1),BF1(Idx)) - call MAPL_VarWrite(OutFmt,names(2),BF2(Idx)) - call MAPL_VarWrite(OutFmt,names(3),BF3(Idx)) - call MAPL_VarWrite(OutFmt,names(4),VGWMAX(Idx)) - call MAPL_VarWrite(OutFmt,names(5),CDCR1(Idx)) - call MAPL_VarWrite(OutFmt,names(6),CDCR2(Idx)) - call MAPL_VarWrite(OutFmt,names(7),PSIS(Idx)) - call MAPL_VarWrite(OutFmt,names(8),BEE(Idx)) - call MAPL_VarWrite(OutFmt,names(9),POROS(Idx)) - call MAPL_VarWrite(OutFmt,names(10),WPWET(Idx)) - call MAPL_VarWrite(OutFmt,names(11),COND(Idx)) - call MAPL_VarWrite(OutFmt,names(12),GNU(Idx)) - call MAPL_VarWrite(OutFmt,names(13),ARS1(Idx)) - call MAPL_VarWrite(OutFmt,names(14),ARS2(Idx)) - call MAPL_VarWrite(OutFmt,names(15),ARS3(Idx)) - call MAPL_VarWrite(OutFmt,names(16),ARA1(Idx)) - call MAPL_VarWrite(OutFmt,names(17),ARA2(Idx)) - call MAPL_VarWrite(OutFmt,names(18),ARA3(Idx)) - call MAPL_VarWrite(OutFmt,names(19),ARA4(Idx)) - call MAPL_VarWrite(OutFmt,names(20),ARW1(Idx)) - call MAPL_VarWrite(OutFmt,names(21),ARW2(Idx)) - call MAPL_VarWrite(OutFmt,names(22),ARW3(Idx)) - call MAPL_VarWrite(OutFmt,names(23),ARW4(Idx)) - call MAPL_VarWrite(OutFmt,names(24),TSA1(Idx)) - call MAPL_VarWrite(OutFmt,names(25),TSA2(Idx)) - call MAPL_VarWrite(OutFmt,names(26),TSB1(Idx)) - call MAPL_VarWrite(OutFmt,names(27),TSB2(Idx)) - call MAPL_VarWrite(OutFmt,names(28),ATAU2(Idx)) - call MAPL_VarWrite(OutFmt,names(29),BTAU2(Idx)) - call MAPL_VarWrite(OutFmt,'OLD_ITY',rity(Idx)) - - - call MAPL_IOCountNonDimVars(InCfg,nvars) - - variables => InCfg%get_variables() - var_iter = variables%begin() - i = 0 - do while (var_iter /= variables%end()) - - var_name => var_iter%key() - i=i+1 - do j=1,29 - if ( trim(var_name) == trim(names(j)) ) written(i) = .true. - enddo - if (trim(var_name) == "OLD_ITY" ) written(i) = .true. - - call var_iter%next() - - enddo - - variables => InCfg%get_variables() - var_iter = variables%begin() - n=0 - allocate(var1(NTILES_IN)) - do while (var_iter /= variables%end()) - - var_name => var_iter%key() - myVariable => var_iter%value() - - if (.not.InCfg%is_coordinate_variable(var_name)) then - - n=n+1 - if (.not.written(n) ) then - - var_dimensions => myVariable%get_dimensions() - - ndims = var_dimensions%size() - - if (ndims == 1) then - call MAPL_VarRead(InFmt,var_name,var1, __RC__) - call MAPL_VarWrite(OutFmt,var_name,var1(idx)) - else if (ndims == 2) then - - dname => myVariable%get_ith_dimension(2) - dim1=InCfg%get_dimension(dname) - do j=1,dim1 - call MAPL_VarRead(InFmt,var_name,var1,offset1=j, __RC__) - call MAPL_VarWrite(OutFmt,var_name,var1(idx),offset1=j) - enddo - else if (ndims == 3) then - - dname => myVariable%get_ith_dimension(2) - dim1=InCfg%get_dimension(dname) - dname => myVariable%get_ith_dimension(3) - dim2=InCfg%get_dimension(dname) - do k=1,dim2 - do j=1,dim1 - call MAPL_VarRead(InFmt,var_name,var1,offset1=j,offset2=k, __RC__) - call MAPL_VarWrite(OutFmt,var_name,var1(idx),offset1=j,offset2=k) - enddo - enddo - - end if - - end if - end if - call var_iter%next() - - enddo - - else - - write(40) BF1(Idx) - write(40) BF2(Idx) - write(40) BF3(Idx) - write(40) VGWMAX(Idx) - write(40) CDCR1(Idx) - write(40) CDCR2(Idx) - write(40) PSIS(Idx) - write(40) BEE(Idx) - write(40) POROS (Idx) - write(40) WPWET(Idx) - write(40) COND(Idx) - write(40) GNU(Idx) - write(40) ARS1(Idx) - write(40) ARS2(Idx) - write(40) ARS3(Idx) - write(40) ARA1(Idx) - write(40) ARA2(Idx) - write(40) ARA3(Idx) - write(40) ARA4(Idx) - write(40) ARW1(Idx) - write(40) ARW2(Idx) - write(40) ARW3(Idx) - write(40) ARW4(Idx) - write(40) TSA1(Idx) - write(40) TSA2(Idx) - write(40) TSB1(Idx) - write(40) TSB2(Idx) - write(40) ATAU2(Idx) - write(40) BTAU2(Idx) - write(40) rITY(Idx) - - - allocate(var1(NTILES_IN)) - allocate(var2(NTILES_IN,4)) - - ! TC QC - - do n=1,2 - read (50) var2 - write(40) ((var2(idx(i),j),i=1,ntiles),j=1,4) - end do - - !CAPAC CATDEF RZEXC SRFEXC ... SNDZN3 - - do n=1,20 - read (50) var1 - write(40) var1(Idx) - enddo - - ! CH CM CQ FR - - do n=1,4 - read (50) var2 - write(40) ((var2(idx(i),j),i=1,ntiles),j=1,4) - end do - - ! These are the 2 prev/next pairs that dont are not - ! in the internal in fortuna-2_0 and later. Earlier the - ! record are there, but their values are not needed, since - ! they are initialized on start-up. - - if(InIsOld) then - do n=1,4 - read (50) - enddo - endif - - if(OutIsOld) then - var1 = 0.0 - do n=1,4 - write(40) (var1(idx(i)),i = 1, ntiles) - end do - endif - - ! WW - - read (50) var2 - write(40) ((var2(idx(i),j),i=1,ntiles),j=1,4) - end if - if (present(rc)) rc =0 - !_RETURN(_SUCCESS) - END SUBROUTINE read_and_write_rst - - ! ***************************************************************************** - - subroutine init_MPI() - - ! initialize MPI - - call MPI_INIT(mpierr) - - call MPI_COMM_RANK( MPI_COMM_WORLD, myid, mpierr ) - call MPI_COMM_SIZE( MPI_COMM_WORLD, numprocs, mpierr ) - - if (myid .ne. 0) root_proc = .false. - -! write (*,*) "MPI process ", myid, " of ", numprocs, " is alive" -! write (*,*) "MPI process ", myid, ": root_proc=", root_proc - - end subroutine init_MPI - -end program mk_CatchRestarts - diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/mk_GEOSldasRestarts.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/mk_GEOSldasRestarts.F90 deleted file mode 100644 index 5e3da8d3a..000000000 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/mk_GEOSldasRestarts.F90 +++ /dev/null @@ -1,3917 +0,0 @@ -#define I_AM_MAIN -#include "MAPL_Generic.h" - -PROGRAM mk_GEOSldasRestarts - -! USAGE/HELP (NOTICE mpirun -np 1) -! mpirun -np 1 bin/mk_GEOSldasRestarts.x -h -! -! (1) to create an initial catch(cn)_internal_rst file ready for an offline experiment : -! -------------------------------------------------------------------------------------- -! (1.1) mpirun -np 1 bin/mk_GEOSldasRestarts.x -a SPONSORCODE -b BCSDIR -m MODEL -s SURFLAY(20/50) -t TILFILE -! where MODEL : catch or catchcn -! (1.2) sbatch mkLDAS.j -! -! (2) to reorder an LDASsa restart file to the order of the BCs for use in an GCM experiment : -! -------------------------------------------------------------------------------------------- -! mpirun -np 1 bin/mk_GEOSldasRestarts.x -b BCSDIR -d YYYYMMDD -e EXPNAME -l EXPDIR -m MODEL -s SURFLAY(20/50) -r Y -t TILFILE -p PARAMFILE - use netcdf - use MAPL - use mk_restarts_getidsMod, only: GetIDs, ReadTileFile_RealLatLon - use gFTL_StringVector - use ieee_arithmetic, only: isnan => ieee_is_nan - USE STIEGLITZSNOW, ONLY : & - StieglitzSnow_calc_tpsnow - implicit none - include 'mpif.h' - INCLUDE 'netcdf.inc' - - ! initialize to non-MPI values - - integer :: myid=0, numprocs=1, mpierr - logical :: root_proc=.true. - - ! Carbon model specifics - ! ---------------------- - - character*256 :: Usage="mk_GEOSldasRestarts.x -a SPONSORCODE -b BCSDIR -d YYYYMMDDHH -e EXPNAME -j JOBFILE -k ENS -l EXPDIR -m MODEL -r REORDER -s SURFLAY -t TILFILE -p PARAMFILE -f RSTFILE" - character*256 :: BCSDIR, SPONSORCODE, EXPNAME, EXPDIR, TILFILE, SFL, PFILE - character*400 :: CMD - character*10 :: YYYYMMDDHH - character(len=:), allocatable :: model, catch_scaler, rstfile - - real, parameter :: ECCENTRICITY = 0.0167 - real, parameter :: PERIHELION = 102.0 - real, parameter :: OBLIQUITY = 23.45 - integer, parameter :: EQUINOX = 80 - - integer, parameter :: nveg = 4 - integer, parameter :: nzone = 3 - integer, parameter :: VAR_COL_CLM40 = 40 ! number of CN column restart variables - integer, parameter :: VAR_PFT_CLM40 = 74 ! number of CN PFT variables per column - integer, parameter :: npft = 19 - integer, parameter :: npft_clm45 = 19 - integer, parameter :: VAR_COL_CLM45 = 35 ! number of CN column restart variables - integer, parameter :: VAR_PFT_CLM45 = 75 ! number of CN PFT variables per column - - real, parameter :: nan = O'17760000000' - real, parameter :: fmin= 1.e-4 ! ignore vegetation fractions at or below this value - integer, parameter :: OutUnit = 40, InUnit = 50 - character*256 :: arg, tmpstring, ESMADIR - character*1 :: opt, REORDER='N', JOBFILE ='N' - character*4 :: ENS='0000' - integer :: ntiles, rc, nxt - character(len=300) :: OutFileName - integer :: VAR_COL, VAR_PFT - integer :: iclass(npft) = (/1,1,2,3,3,4,5,5,6,7,8,9,10,11,12,11,12,11,12/) - - ! =============================================================================================== - ! Below hard-wired ldas restart file is from a global offline simulation on the SMAP M09 grid - ! after 1000s of years of simulations - - integer, parameter :: ntiles_cn = 1684725, ntiles_cat = 1653157 - character(len=300), parameter :: & - InCNRestart = '/discover/nobackup/projects/gmao/ssd/land/l_data/LandRestarts_for_Regridding/CatchCN/M09/20151231/catchcn_internal_rst', & - InCNTilFile = '/discover/nobackup/projects/gmao/bcs_shared/legacy_bcs/Heracles-NL/SMAP_EASEv2_M09/SMAP_EASEv2_M09_3856x1624.til', & - InCatRestart= '/discover/nobackup/projects/gmao/ssd/land/l_data/LandRestarts_for_Regridding/Catch/M09/20170101/catch_internal_rst', & - InCatTilFile= '/discover/nobackup/projects/gmao/ssd/land/l_data/geos5/bcs/CLSM_params/mkCatchParam_SMAP_L4SM_v002/' & - //'SMAP_EASEv2_M09/SMAP_EASEv2_M09_3856x1624.til', & - InCatRest45 = '/discover/nobackup/projects/gmao/ssd/land/l_data/LandRestarts_for_Regridding/Catch/M09/20170101/catch_internal_rst', & - InCatTil45 = '/discover/nobackup/projects/gmao/ssd/land/l_data/geos5/bcs/CLSM_params/mkCatchParam_SMAP_L4SM_v002/' & - //'SMAP_EASEv2_M09/SMAP_EASEv2_M09_3856x1624.til' - REAL :: SURFLAY = 50. - integer :: STATUS - - character(len=256), parameter :: CatNames (57) = & - (/'BF1 ', 'BF2 ', 'BF3 ', 'VGWMAX ', 'CDCR1 ', & - 'CDCR2 ', 'PSIS ', 'BEE ', 'POROS ', 'WPWET ', & - 'COND ', 'GNU ', 'ARS1 ', 'ARS2 ', 'ARS3 ', & - 'ARA1 ', 'ARA2 ', 'ARA3 ', 'ARA4 ', 'ARW1 ', & - 'ARW2 ', 'ARW3 ', 'ARW4 ', 'TSA1 ', 'TSA2 ', & - 'TSB1 ', 'TSB2 ', 'ATAU ', 'BTAU ', 'OLD_ITY', & - 'TC ', 'QC ', 'CAPAC ', 'CATDEF ', 'RZEXC ', & - 'SRFEXC ', 'GHTCNT1', 'GHTCNT2', 'GHTCNT3', 'GHTCNT4', & - 'GHTCNT5', 'GHTCNT6', 'TSURF ', 'WESNN1 ', 'WESNN2 ', & - 'WESNN3 ', 'HTSNNN1', 'HTSNNN2', 'HTSNNN3', 'SNDZN1 ', & - 'SNDZN2 ', 'SNDZN3 ', 'CH ', 'CM ', 'CQ ', & - 'FR ', 'WW '/) - - character(len=256), parameter :: CarbNames (68) = & - (/'BF1 ', 'BF2 ', 'BF3 ', 'VGWMAX ', 'CDCR1 ', & - 'CDCR2 ', 'PSIS ', 'BEE ', 'POROS ', 'WPWET ', & - 'COND ', 'GNU ', 'ARS1 ', 'ARS2 ', 'ARS3 ', & - 'ARA1 ', 'ARA2 ', 'ARA3 ', 'ARA4 ', 'ARW1 ', & - 'ARW2 ', 'ARW3 ', 'ARW4 ', 'TSA1 ', 'TSA2 ', & - 'TSB1 ', 'TSB2 ', 'ATAU ', 'BTAU ', 'ITY ', & - 'FVG ', 'TC ', 'QC ', 'TG ', 'CAPAC ', & - 'CATDEF ', 'RZEXC ', 'SRFEXC ', 'GHTCNT1', 'GHTCNT2', & - 'GHTCNT3', 'GHTCNT4', 'GHTCNT5', 'GHTCNT6', 'TSURF ', & - 'WESNN1 ', 'WESNN2 ', 'WESNN3 ', 'HTSNNN1', 'HTSNNN2', & - 'HTSNNN3', 'SNDZN1 ', 'SNDZN2 ', 'SNDZN3 ', 'CH ', & - 'CM ', 'CQ ', 'FR ', 'WW ', 'TILE_ID', & - 'NDEP ', 'CLI_T2M', 'BGALBVR', 'BGALBVF', 'BGALBNR', & - 'BGALBNF', 'CNCOL ', 'CNPFT ' /) - - CHARACTER( * ), PARAMETER :: LOWER_CASE = 'abcdefghijklmnopqrstuvwxyz' - CHARACTER( * ), PARAMETER :: UPPER_CASE = 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' - logical :: clm45 = .false. - logical :: second_visit - integer :: zoom, k, n, infos - character*100 :: InRestart - character(100) :: Iam = "mk_GEOSldasRestarts" - - VAR_COL = VAR_COL_CLM40 - VAR_PFT = VAR_PFT_CLM40 - - call init_MPI() - call MPI_Info_create(infos, STATUS) ; VERIFY_(STATUS) - call MPI_Info_set(infos, "romio_cb_read", "automatic", STATUS) ; VERIFY_(STATUS) - call MPI_Barrier(MPI_COMM_WORLD, STATUS) - ! process commands - ! ---------------- - - CALL get_command (cmd) - call getenv ("ESMADIR" ,ESMADIR ) - nxt = 1 - - call getarg(nxt,arg) - rstfile = 'NONE' - do while(arg(1:1)=='-') - - opt=arg(2:2) - if(len(trim(arg))==2) then - nxt = nxt + 1 - call getarg(nxt,arg) - else - arg = arg(3:) - end if - - select case (opt) - case ('a') - SPONSORCODE = trim(arg) - case ('b') - BCSDIR = trim(arg) - case ('d') - YYYYMMDDHH = trim(arg) - case ('e') - EXPNAME = trim(arg) - case ('h') - print *,' ' - print *,'(1) to create an initial catch(cn)_internal_rst file ready for an offline experiment :' - print *,'--------------------------------------------------------------------------------------' - print *,'(1.1) mpirun -np 1 bin/mk_GEOSldasRestarts.x -a SPONSORCODE -b BCSDIR -m MODEL -s SURFLAY(20/50)' - print *,'where MODEL : catch, catchcnclm40, catchcnclm45' - print *,'(1.2) sbatch mkLDAS.j' - print *,' ' - print *,'(2) to reorder an LDASsa restart file to the order of the BCs for use in an GCM experiment :' - print *,'--------------------------------------------------------------------------------------------' - print *,'mpirun -np 1 bin/mk_GEOSldasRestarts.x -b BCSDIR -d YYYYMMDDHH -e EXPNAME -l EXPDIR -m MODEL -s SURFLAY(20/50) -r Y -t TILFILE -p PARAMFILE' - stop - case ('j') - JOBFILE = trim(arg) - case ('k') - ENS = trim(arg) - case ('l') - EXPDIR = trim(arg) - case ('m') - MODEL = StrLowCase(trim(arg)) - case ('r') - REORDER = trim(arg) - case ('s') - SFL = trim(arg) - read(arg,*) SURFLAY - case ('t') - TILFILE = trim(arg) - case ('p') - PFILE = trim(arg) - case ('f') - RSTFILE = trim(arg) - case default - print *, trim(Usage) - call exit(1) - end select - nxt = nxt + 1 - call getarg(nxt,arg) - end do - - if (index(model, 'catchcn') /=0 ) then - if((INDEX(BCSDIR, 'NL') == 0).AND.(INDEX(BCSDIR, 'OutData') == 0)) then - print *,'Land BCs in : ',trim(BCSDIR) - print *,'do not support ',trim (model) - stop - endif - - if (index(model,'45') /=0) then - clm45 = .true. - VAR_COL = VAR_COL_CLM45 - VAR_PFT = VAR_PFT_CLM45 - endif - catch_scaler = 'Scale_CatchCN' - else - catch_scaler = 'Scale_Catch' - endif - - - if(trim(REORDER) == 'Y') then - - ! This call is to reorder a LDASsa restart file (RESTART: 1) - - call reorder_LDASsa_restarts (SURFLAY, BCSDIR, YYYYMMDDHH, EXPNAME, EXPDIR, MODEL, ENS, rstfile, __RC__) - - call MPI_Barrier(MPI_COMM_WORLD, STATUS) - call MPI_FINALIZE(mpierr) - call exit(0) - - elseif (trim(REORDER) == 'R') then - - ! This call is to regrid LDASsa/GEOSldas restarts from a different grid (RESTART: 2) - - call regrid_from_xgrid (SURFLAY, BCSDIR, YYYYMMDDHH, EXPNAME, EXPDIR, MODEL, PFILE, rstfile) - - call MPI_Barrier(MPI_COMM_WORLD, STATUS) - call MPI_FINALIZE(mpierr) - call exit(0) - - else - - ! The user does not have restarts, thus cold start (RESTART: 0) - - if(JOBFILE == 'N') then - - call system('mkdir -p InData/ OutData/') - tmpstring = 'cp '//trim(BCSDIR)//'/'//trim(TILFILE)//' InData/OutTileFile' - call system(tmpstring) - tmpstring = 'cp '//trim(BCSDIR)//'/'//trim(TILFILE)//' OutData/OutTileFile' - call system(tmpstring) - tmpstring = 'ln -s '//trim(BCSDIR)//'/clsm OutData/clsm' - call system(tmpstring) - - open (10, file ='mkLDASsa.j', form = 'formatted', status ='unknown', action = 'write') - write(10,'(a)')'#!/bin/csh -fx' - write(10,'(a)')' ' - write(10,'(a)')'#SBATCH --account='//trim(SPONSORCODE) - write(10,'(a)')'#SBATCH --time=1:00:00' - write(10,'(a)')'#SBATCH --ntasks=56' - write(10,'(a)')'#SBATCH --job-name=mkLDAS' - write(10,'(a)')'###SBATCH --constraint=hasw' - write(10,'(a)')'#SBATCH --output=mkLDAS.o' - write(10,'(a)')'#SBATCH --error=mkLDAS.e' - write(10,'(a)')' ' - write(10,'(a)')'limit stacksize unlimited' - write(10,'(a)')'source bin/g5_modules' - !tmpstring = "set BINDIR=`ls -l bin | cut -d'>' -f2`" - !write(10,'(a)')trim(tmpstring) - !tmpstring = "setenv ESMADIR `echo $BINDIR | sed 's/Linux\/bin//g'`" - write(10,'(a)')'setenv ESMADIR '//trim(ESMADIR) - write(10,'(a)')'setenv MKL_CBWR SSE4_2 # ensure zero-diff across archs' - write(10,'(a)')'setenv MV2_ON_DEMAND_THRESHOLD 8192 # MVAPICH2' - write(10,'(a)')' ' - write(10,'(a)')'mpirun -np 56 '//trim(cmd)//' -j Y' - - write(10,'(a)')'bin/'//trim(catch_scaler)//' InData/'//model//'_internal_rst OutData/'//model//'_internal_rst '//model//'_internal_rst '//trim(SFL) - - close (10, status ='keep') - call system('chmod 755 mkLDASsa.j') - stop - endif - endif - - if (root_proc) then - - ! read in ntiles - ! ---------------------------- - - open (10,file = trim(BCSDIR)//'/clsm/catchment.def', form = 'formatted', status ='old', action = 'read') - read (10,*) ntiles - close (10, status ='keep') - - endif - - call MPI_BCAST(NTILES , 1, MPI_INTEGER , 0,MPI_COMM_WORLD,mpierr) - - ! Regridding - inquire(file='InData/'//trim(MODEL)//'_internal_rst',exist=second_visit ) - - if(.not. second_visit) then - call regrid_hyd_vars (NTILES, trim(MODEL)) - call MPI_Barrier(MPI_COMM_WORLD, STATUS) - stop - endif - if (root_proc) then - call read_bcs_data (NTILES, SURFLAY, trim(MODEL),'OutData/clsm/','OutData/'//trim(MODEL)//'_internal_rst', __RC__) - endif - - call MPI_Barrier(MPI_COMM_WORLD, STATUS) - - if(index(MODEL,'catchcn') /=0) then - - call regrid_carbon_vars (NTILES, model) - - endif - - call MPI_FINALIZE(mpierr) - -contains - - ! ***************************************************************************** - - SUBROUTINE regrid_from_xgrid (SURFLAY, BCSDIR, YYYYMMDDHH, EXPNAME, EXPDIR, MODEL, PFILE, rstfile) - - implicit none - - real, intent (in) :: SURFLAY - character(*), intent (in) :: BCSDIR, YYYYMMDDHH, EXPNAME, EXPDIR, MODEL, PFILE, rstfile - character(256) :: tile_coord, vname - character(300) :: rst_file - integer :: NTILES, nv, iv, i,j,k,n, nx, nz, ndims,dimSizes(3), NTILES_RST,nplus, STATUS,NCFID, req, filetype, OUTID - integer, allocatable :: LDAS2BCS (:), tile_id(:) - real, allocatable :: var1(:), var2(:),wesn1(:), htsn1(:), lon_rst(:), lat_rst(:) - logical :: fexist, bin_out = .false., lendian = .true. - real , allocatable, dimension (:) :: LATT, LONN, DAYX - real , pointer , dimension (:) :: long, latg, lonc, latc - integer, allocatable, dimension (:) :: low_ind, upp_ind, nt_local - integer, allocatable, dimension (:) :: Id_glb, id_loc - integer, allocatable, dimension (:,:) :: Id_glb_cn, id_loc_cn - integer, allocatable, dimension (:) :: ld_reorder, tid_offl - real, allocatable, dimension (:) :: CLMC_pf1, CLMC_pf2, CLMC_sf1, CLMC_sf2, & - CLMC_pt1, CLMC_pt2,CLMC_st1,CLMC_st2, var_dum2 - integer :: AGCM_YY,AGCM_MM,AGCM_DD,AGCM_HR=0,AGCM_DATE - real, allocatable, dimension(:,:) :: fveg_offl, ityp_offl, fveg_tmp, ityp_tmp - real, allocatable :: var_off_col (:,:,:), var_off_pft (:,:,:,:) - type(Netcdf4_FileFormatter) :: ldFmt - type(FileMetadata) :: meta_data - character(256) :: Iam = "regrid_from_xgrid" - ! read NTILES from output BCs and tile_coord from GEOSldas/LDASsa input restarts - - open (10,file =trim(BCSDIR)//"clsm/catchment.def",status='old',form='formatted') - read (10,*) ntiles - close (10, status = 'keep') - - ! Determine whether LDASsa or GEOSldas - if (trim(rstfile) == "NONE") then - if (trim(MODEL) == 'catch') then - rst_file = trim(EXPDIR)//'rs/ens'//ENS//'/Y'//YYYYMMDDHH(1:4)//'/M'//YYYYMMDDHH(5:6)//'/'//trim(ExpName)//& - '.catch_internal_rst.'//YYYYMMDDHH(1:8)//'_'//YYYYMMDDHH(9:10)//'00' - inquire(file = trim(rst_file), exist=fexist) - if (.not.fexist) then - rst_file = trim(EXPDIR)//'rs/ens'//ENS//'/Y'//YYYYMMDDHH(1:4)//'/M'//YYYYMMDDHH(5:6)//'/' & - //trim(ExpName)//'.ens'//ENS//'.catch_ldas_rst.'// & - YYYYMMDDHH(1:8)//'_'//YYYYMMDDHH(9:10)//'00z.bin' - lendian = .false. - endif - else !catchcn - rst_file = trim(EXPDIR)//'rs/ens'//ENS//'/Y'//YYYYMMDDHH(1:4)//'/M'//YYYYMMDDHH(5:6)//'/'//trim(ExpName)//& - '.'//trim(MODEL)//'_internal_rst.'//YYYYMMDDHH(1:8)//'_'//YYYYMMDDHH(9:10)//'00' - inquire(file = trim(rst_file), exist=fexist) - if (.not. fexist) then - rst_file = trim(EXPDIR)//'rs/ens'//ENS//'/Y'//YYYYMMDDHH(1:4)//'/M'//YYYYMMDDHH(5:6)//'/'//trim(ExpName)//& - '.ens'//ENS//'.'//trim(MODEL)//'_ldas_rst.'//YYYYMMDDHH(1:8)//'_'//YYYYMMDDHH(9:10)//'00z' - lendian = .false. - endif - endif ! catch - else ! rstfile is provided - rst_file = rstfile - if (index(rst_file, "_ldas_rst") /=0) lendian = .false. - endif - - if (index(MODEL, 'catchcn') /=0) then - call ldFmt%open(trim(rst_file) , pFIO_READ,__RC__) - meta_data = ldFmt%read(__RC__) - call ldFmt%close(__RC__) - if(meta_data%get_dimension('unknown_dim3',rc=status) == 105) then - clm45 = .true. - VAR_COL = VAR_COL_CLM45 - VAR_PFT = VAR_PFT_CLM45 - if (root_proc) print *, 'Processing CLM45 restarts : ', VAR_COL, VAR_PFT, clm45 - else - if (root_proc) print *, 'Processing CLM40 restarts : ', VAR_COL, VAR_PFT, clm45 - endif - endif - - ! Open input tile_coord - tile_coord = trim(EXPDIR)//'rc_out/'//trim(expname)//'.ldas_tilecoord.bin' - inquire(file = trim(tile_coord), exist=fexist) - if ( .not. fexist ) then - print*, tile_coord // " file not exists" - stop " no tile_coord file" - endif - - if(lendian) then - open (10,file =trim(tile_coord),status='old',form='unformatted', action = 'read') - else - open (10,file =trim(tile_coord),status='old',form='unformatted', action = 'read', convert ='big_endian') - endif - - read (10) NTILES_RST - - if(root_proc) then - print *,'NTILES in BCs : ',NTILES - print *,'NTILES in restarts : ',NTILES_RST - endif - - ! Domain decomposition - ! -------------------- - - allocate(low_ind ( numprocs)) - allocate(upp_ind ( numprocs)) - allocate(nt_local( numprocs)) - - low_ind (:) = 1 - upp_ind (:) = NTILES - nt_local(:) = NTILES - - if (numprocs > 1) then - do i = 1, numprocs - 1 - upp_ind(i) = low_ind(i) + (ntiles/numprocs) - 1 - low_ind(i+1) = upp_ind(i) + 1 - nt_local(i) = upp_ind(i) - low_ind(i) + 1 - end do - nt_local(numprocs) = upp_ind(numprocs) - low_ind(numprocs) + 1 - endif - - allocate (id_loc (nt_local (myid + 1))) - allocate (lonn (nt_local (myid + 1))) - allocate (latt (nt_local (myid + 1))) - allocate (lonc (1:ntiles_rst)) - allocate (latc (1:ntiles_rst)) - allocate (tid_offl (ntiles_rst)) - - if (root_proc) then - allocate (long (ntiles)) - allocate (latg (ntiles)) - allocate (ld_reorder(ntiles_rst)) - allocate (tile_id (1:ntiles_rst)) - allocate (LDAS2BCS (1:ntiles_rst)) - allocate (lon_rst (1:ntiles_rst)) - allocate (lat_rst (1:ntiles_rst)) - - call ReadTileFile_RealLatLon ('InData/OutTileFile', i, xlon=long, xlat=latg); VERIFY_(i-ntiles) - - read (10) LDAS2BCS - read (10) tile_id - read (10) tile_id - read (10) lon_rst - read (10) lat_rst - - tile_id = LDAS2BCS - - do n = 1, NTILES_RST - ld_reorder (tile_id(n)) = n - tid_offl(n) = n - end do - do n = 1, NTILES_RST - lonc(n) = lon_rst(ld_reorder(n)) - latc(n) = lat_rst(ld_reorder(n)) - END DO - deallocate (lon_rst, lat_rst) - endif - - close (10, status = 'keep') - call MPI_Barrier(MPI_COMM_WORLD, STATUS) - - do i = 1, numprocs - if((I == 1).and.(myid == 0)) then - lonn(:) = long(low_ind(i) : upp_ind(i)) - latt(:) = latg(low_ind(i) : upp_ind(i)) - else if (I > 1) then - if(I-1 == myid) then - ! receiving from root - call MPI_RECV(lonn,nt_local(i) , MPI_REAL, 0,995,MPI_COMM_WORLD,MPI_STATUS_IGNORE,mpierr) - call MPI_RECV(latt,nt_local(i) , MPI_REAL, 0,994,MPI_COMM_WORLD,MPI_STATUS_IGNORE,mpierr) - else if (myid == 0) then - ! root sends - call MPI_ISend(long(low_ind(i) : upp_ind(i)),nt_local(i),MPI_REAL,i-1,995,MPI_COMM_WORLD,req,mpierr) - call MPI_WAIT (req,MPI_STATUS_IGNORE,mpierr) - call MPI_ISend(latg(low_ind(i) : upp_ind(i)),nt_local(i),MPI_REAL,i-1,994,MPI_COMM_WORLD,req,mpierr) - call MPI_WAIT (req,MPI_STATUS_IGNORE,mpierr) - endif - endif - end do - - if(root_proc) deallocate (long) - - call MPI_BCAST(lonc,ntiles_rst,MPI_REAL,0,MPI_COMM_WORLD,mpierr) - call MPI_BCAST(latc,ntiles_rst,MPI_REAL,0,MPI_COMM_WORLD,mpierr) - call MPI_BCAST(tid_offl,size(tid_offl ),MPI_INTEGER,0,MPI_COMM_WORLD,mpierr) - - ! -------------------------------------------------------------------------------- - ! Here we create transfer index array to map offline restarts to output tile space - ! -------------------------------------------------------------------------------- - - ! id_glb for hydrologic variable - - call GetIds(lonc,latc,lonn,latt,id_loc, tid_offl) - if(root_proc) allocate (id_glb (ntiles)) - - call MPI_Barrier(MPI_COMM_WORLD, STATUS) -! call MPI_GATHERV( & -! id_loc, nt_local(myid+1) , MPI_real, & -! id_glb, nt_local,low_ind-1, MPI_real, & -! 0, MPI_COMM_WORLD, mpierr ) - do i = 1, numprocs - if((I == 1).and.(myid == 0)) then - id_glb(low_ind(i) : upp_ind(i)) = Id_loc(:) - else if (I > 1) then - if(I-1 == myid) then - ! send to root - call MPI_ISend(id_loc,nt_local(i),MPI_INTEGER,0,993,MPI_COMM_WORLD,req,mpierr) - call MPI_WAIT (req,MPI_STATUS_IGNORE,mpierr) - else if (myid == 0) then - ! root receives - call MPI_RECV(id_glb(low_ind(i) : upp_ind(i)),nt_local(i) , MPI_INTEGER, i-1,993,MPI_COMM_WORLD,MPI_STATUS_IGNORE,mpierr) - endif - endif - end do - - deallocate (id_loc) - - if(root_proc) then - - inquire(file = trim(rst_file), exist=fexist) - if (.not. fexist) then - print*, "WARNING!!" - print*, trim(rst_file) // " does not exist .. !" - stop - endif - - ! =========================================================== - ! Map restart nearest restart to output grid (hydrologic var) - ! =========================================================== - - filetype = 0 - call MAPL_NCIOGetFileType(rst_file, filetype,__RC__) - if(filetype == 0) then - ! GEOSldas CATCH/CATCHCN or CATCHCN LDASsa - call put_land_vars (NTILES, ntiles_rst, id_glb, ld_reorder, model, rst_file) - else - call read_ldas_restarts (NTILES, ntiles_rst, id_glb, ld_reorder, rst_file, pfile) - endif - - ! ==================== - ! READ AND PUT OUT BCS - ! ==================== - - do i = 1,10000 - ! just delaying few seconds to allow the system to copy the file - end do - - call read_bcs_data (NTILES, SURFLAY, trim(MODEL),'OutData/clsm/','OutData/'//trim(model)//'_internal_rst', __RC__) - - endif - - call MPI_Barrier(MPI_COMM_WORLD, STATUS) - - ! ============= - ! REGRID Carbon - ! ============= - - if (index(MODEL, 'catchcn') /=0) then - - allocate (CLMC_pf1(nt_local (myid + 1))) - allocate (CLMC_pf2(nt_local (myid + 1))) - allocate (CLMC_sf1(nt_local (myid + 1))) - allocate (CLMC_sf2(nt_local (myid + 1))) - allocate (CLMC_pt1(nt_local (myid + 1))) - allocate (CLMC_pt2(nt_local (myid + 1))) - allocate (CLMC_st1(nt_local (myid + 1))) - allocate (CLMC_st2(nt_local (myid + 1))) - allocate (ityp_offl (ntiles_rst,nveg)) - allocate (fveg_offl (ntiles_rst,nveg)) - allocate (id_loc_cn (nt_local (myid + 1),nveg)) - -! STATUS = NF90_OPEN ('OutData/catchcn_internal_rst',NF_WRITE,OUTID) ; VERIFY_(STATUS) - STATUS = NF_OPEN_PAR ('OutData/'//trim(model)//'_internal_rst',IOR(NF_WRITE,NF_MPIIO),MPI_COMM_WORLD, infos,OUTID) ; VERIFY_(STATUS) - STATUS = NF_GET_VARA_REAL(OUTID,VarID(OUTID,'ITY'), (/low_ind(myid+1),1/), (/nt_local(myid+1),1/),CLMC_pt1) - STATUS = NF_GET_VARA_REAL(OUTID,VarID(OUTID,'ITY'), (/low_ind(myid+1),2/), (/nt_local(myid+1),1/),CLMC_pt2) - STATUS = NF_GET_VARA_REAL(OUTID,VarID(OUTID,'ITY'), (/low_ind(myid+1),3/), (/nt_local(myid+1),1/),CLMC_st1) - STATUS = NF_GET_VARA_REAL(OUTID,VarID(OUTID,'ITY'), (/low_ind(myid+1),4/), (/nt_local(myid+1),1/),CLMC_st2) - STATUS = NF_GET_VARA_REAL(OUTID,VarID(OUTID,'FVG'), (/low_ind(myid+1),1/), (/nt_local(myid+1),1/),CLMC_pf1) - STATUS = NF_GET_VARA_REAL(OUTID,VarID(OUTID,'FVG'), (/low_ind(myid+1),2/), (/nt_local(myid+1),1/),CLMC_pf2) - STATUS = NF_GET_VARA_REAL(OUTID,VarID(OUTID,'FVG'), (/low_ind(myid+1),3/), (/nt_local(myid+1),1/),CLMC_sf1) - STATUS = NF_GET_VARA_REAL(OUTID,VarID(OUTID,'FVG'), (/low_ind(myid+1),4/), (/nt_local(myid+1),1/),CLMC_sf2) - - if (root_proc) then - - allocate (ityp_tmp (ntiles_rst,nveg)) - allocate (fveg_tmp (ntiles_rst,nveg)) - allocate (DAYX (NTILES)) - - READ(YYYYMMDDHH(1:8),'(I8)') AGCM_DATE - AGCM_YY = AGCM_DATE / 10000 - AGCM_MM = (AGCM_DATE - AGCM_YY*10000) / 100 - AGCM_DD = (AGCM_DATE - AGCM_YY*10000 - AGCM_MM*100) - - call compute_dayx ( & - NTILES, AGCM_YY, AGCM_MM, AGCM_DD, AGCM_HR, & - LATG, DAYX) - - STATUS = NF_OPEN (trim(rst_file),NF_NOWRITE,NCFID) ; VERIFY_(STATUS) - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'ITY'), (/1,1/), (/ntiles_rst,4/),ityp_tmp) - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'FVG'), (/1,1/), (/ntiles_rst,4/),fveg_tmp) - - do n = 1, NTILES_RST - ityp_offl (n,:) = ityp_tmp (ld_reorder(n),:) - fveg_offl (n,:) = fveg_tmp (ld_reorder(n),:) - - if((ityp_offl(N,3) == 0).and.(ityp_offl(N,4) == 0)) then - if(ityp_offl(N,1) /= 0) then - ityp_offl(N,3) = ityp_offl(N,1) - else - ityp_offl(N,3) = ityp_offl(N,2) - endif - endif - - if((ityp_offl(N,1) == 0).and.(ityp_offl(N,2) /= 0)) ityp_offl(N,1) = ityp_offl(N,2) - if((ityp_offl(N,2) == 0).and.(ityp_offl(N,1) /= 0)) ityp_offl(N,2) = ityp_offl(N,1) - if((ityp_offl(N,3) == 0).and.(ityp_offl(N,4) /= 0)) ityp_offl(N,3) = ityp_offl(N,4) - if((ityp_offl(N,4) == 0).and.(ityp_offl(N,3) /= 0)) ityp_offl(N,4) = ityp_offl(N,3) - end do - deallocate (ityp_tmp, fveg_tmp) - endif - - call MPI_BCAST(ityp_offl,size(ityp_offl),MPI_REAL ,0,MPI_COMM_WORLD,mpierr) - call MPI_BCAST(fveg_offl,size(fveg_offl),MPI_REAL ,0,MPI_COMM_WORLD,mpierr) - - call GetIds(lonc,latc,lonn,latt,id_loc_cn, tid_offl, & - CLMC_pf1, CLMC_pf2, CLMC_sf1, CLMC_sf2, CLMC_pt1, CLMC_pt2,CLMC_st1,CLMC_st2, & - fveg_offl, ityp_offl) - - if(root_proc) allocate (id_glb_cn (ntiles,nveg)) - - allocate (id_loc (ntiles)) - call MPI_Barrier(MPI_COMM_WORLD, STATUS) - deallocate (CLMC_pf1, CLMC_pf2, CLMC_sf1, CLMC_sf2) - deallocate (CLMC_pt1, CLMC_pt2, CLMC_st1, CLMC_st2) - - do nv = 1, nveg - call MPI_Barrier(MPI_COMM_WORLD, STATUS) - ! call MPI_GATHERV( & - ! id_loc (:,nv), nt_local(myid+1) , MPI_real, & - ! id_vec, nt_local,low_ind-1, MPI_real, & - ! 0, MPI_COMM_WORLD, mpierr ) - - do i = 1, numprocs - if((I == 1).and.(myid == 0)) then - id_loc(low_ind(i) : upp_ind(i)) = Id_loc_cn(:,nv) - else if (I > 1) then - if(I-1 == myid) then - ! send to root - call MPI_ISend(id_loc_cn(:,nv),nt_local(i),MPI_INTEGER,0,994,MPI_COMM_WORLD,req,mpierr) - call MPI_WAIT (req,MPI_STATUS_IGNORE,mpierr) - else if (myid == 0) then - ! root receives - call MPI_RECV(id_loc(low_ind(i) : upp_ind(i)),nt_local(i) , MPI_INTEGER, i-1,994,MPI_COMM_WORLD,MPI_STATUS_IGNORE,mpierr) - endif - endif - end do - - if(root_proc) id_glb_cn (:,nv) = id_loc - - end do - - if(root_proc) then - - allocate (var_off_col (1: NTILES_RST, 1 : nzone,1 : var_col)) - allocate (var_off_pft (1: NTILES_RST, 1 : nzone,1 : nveg, 1 : var_pft)) - allocate (var_dum2 (1:ntiles_rst)) - - i = 1 - do nv = 1,VAR_COL - do nz = 1,nzone - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'CNCOL'), (/1,i/), (/NTILES_RST,1 /),VAR_DUM2) - do k = 1, NTILES_RST - var_off_col(k, nz,nv) = VAR_DUM2(ld_reorder(k)) - end do - i = i + 1 - end do - end do - - i = 1 - do iv = 1,VAR_PFT - do nv = 1,nveg - do nz = 1,nzone - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'CNPFT'), (/1,i/), (/NTILES_RST,1 /),VAR_DUM2) - do k = 1, NTILES_RST - var_off_pft(K, nz,nv,iv) = VAR_DUM2(ld_reorder(k)) - end do - i = i + 1 - end do - end do - end do - - where(isnan(var_off_pft)) var_off_pft = 0. - where(var_off_pft /= var_off_pft) var_off_pft = 0. - print *, 'Writing regridded carbn' - call write_regridded_carbon (NTILES, ntiles_rst, NCFID, OUTID, id_glb_cn, & - DAYX, var_off_col,var_off_pft, ityp_offl, fveg_offl) - deallocate (var_off_col,var_off_pft) - endif - call MPI_Barrier(MPI_COMM_WORLD, STATUS) - STATUS = NF_CLOSE (OutID) - endif - - END SUBROUTINE regrid_from_xgrid - - ! ***************************************************************************** - - SUBROUTINE reorder_LDASsa_restarts (SURFLAY, BCSDIR, YYYYMMDDHH, EXPNAME, EXPDIR, MODEL, ENS, rstfile, rc) - - implicit none - - real, intent (in) :: SURFLAY - character(*), intent (in) :: BCSDIR, YYYYMMDDHH, EXPNAME, EXPDIR, MODEL, ENS, rstfile - integer, optional, intent(out) :: rc - character(256) :: tile_coord - character(300) :: rst_file, out_rst_file - type(Netcdf4_FileFormatter) :: InFmt,OutFmt, ldFmt - type(FileMetadata) :: meta_data - integer :: NTILES, i,j,k,n, ndims,dimSizes(3) - integer, allocatable :: LDAS2BCS (:), g2d(:), tile_id(:) - real, allocatable :: var1(:), var2(:),wesn1(:), htsn1(:) - integer :: dim1,dim2 - type(StringVariableMap), pointer :: variables - type(Variable), pointer :: var - type(StringVariableMapIterator) :: var_iter - type(StringVector), pointer :: var_dimensions - character(len=:), pointer :: vname,dname - logical :: fexist, bin_out = .false. - character(len=:), allocatable :: ftype - character*256 :: Iam = "reorder_LDASsa_restarts" - integer :: status - - if (trim(rstfile) == "NONE") then - ftype = '' - if(trim(MODEL) == 'catch') ftype='.bin' - rst_file = trim(EXPDIR)//'rs/ens'//ENS//'/Y'//YYYYMMDDHH(1:4)//'/M'//YYYYMMDDHH(5:6)//'/'//trim(ExpName)//& - '.ens'//ENS//'.'//trim(model)//'_ldas_rst.'//YYYYMMDDHH(1:8)//'_'//YYYYMMDDHH(9:10)//'00z'//trim(ftype) - else - rst_file = rstfile - endif - - inquire(file = trim(rst_file), exist=fexist) - if (.not. fexist) then - print*, "WARNING!!" - print*, rst_file // "does not exsit" - print*, "MAY USE ENS0000 only!!" - return - endif - - out_rst_file = trim(model)//ENS//'_internal_rst.'//YYYYMMDDHH(1:8) - - if (index(model,'catchcn') /=0) then - call ldFmt%open(trim(rst_file) , pFIO_READ,__RC__) - meta_data = ldFmt%read(__RC__) - call ldFmt%close(__RC__) - if(meta_data%get_dimension('unknown_dim3',rc=status) == 105) then - VAR_COL = VAR_COL_CLM45 - VAR_PFT = VAR_PFT_CLM45 - if ( .not. clm45) stop ' ERROR: Given clm45 restart, but the model is not clm45' - if (root_proc) print *, 'Processing CLM45 restarts : ', VAR_COL, VAR_PFT, clm45 - else - if (root_proc) print *, 'Processing CLM40 restarts : ', VAR_COL, VAR_PFT, clm45 - endif - endif - - open (10,file =trim(BCSDIR)//"clsm/catchment.def",status='old',form='formatted') - read (10,*) ntiles - close (10, status = 'keep') - - ! read NTILES from BCs and tile_coord from LDASsa experiment - - tile_coord = trim(EXPDIR)//'rc_out/'//trim(expname)//'.ldas_tilecoord.bin' - inquire(file = tile_coord, exist=fexist) - if (.not. fexist) then - print*, trim(tile_coord) // " file should be provided" - stop "no tile_coord file" - endif - - open (10,file =trim(tile_coord),status='old',form='unformatted',convert='big_endian') - read (10) i - if (i /= ntiles) then - print *,'NTILES BCs/LDASsa mismatch:', i,ntiles - stop - endif - - if(trim(MODEL) == 'catch') then - call InFmt%open('/discover/nobackup/projects/gmao/ssd/land/l_data/LandRestarts_for_Regridding/Catch/catch_internal_rst' , pFIO_READ,__RC__) - end if - if(index(MODEL, 'catchcn') /=0) then - if (clm45) then - call InFmt%open('/discover/nobackup/projects/gmao/ssd/land/l_data/LandRestarts_for_Regridding/CatchCN/catchcn_internal_clm45',PFIO_READ, __RC__) - else - call InFmt%open('/discover/nobackup/projects/gmao/ssd/land/l_data/LandRestarts_for_Regridding/CatchCN/catchcn_internal_dummy' , pFIO_READ, __RC__) - endif - end if - meta_data = InFmt%read(__RC__) - call inFmt%close(__RC__) - - call meta_data%modify_dimension('tile',ntiles,__RC__) - - call OutFmt%create(trim(out_rst_file),__RC__) - call OutFmt%write(meta_data, __RC__) - - - allocate (tile_id (1:ntiles)) - allocate (LDAS2BCS (1:ntiles)) - allocate (g2d (1:ntiles)) - - read (10) LDAS2BCS - close (10, status = 'keep') - - ! ========================== - ! READ/WRITE LDASsa RESTARTS - ! ========================== - - allocate(var1(ntiles)) - allocate(var2(ntiles)) - allocate(wesn1 (ntiles)) - allocate(htsn1 (ntiles)) - ! CH CM CQ FR WW - ! WW - var1 = 0.1 - do j = 1,4 - call MAPL_VarWrite(OutFmt,'WW',var1 ,offset1=j) - end do - ! FR - var1 = 0.25 - do j = 1,4 - call MAPL_VarWrite(OutFmt,'FR',var1 ,offset1=j) - end do - ! CH CM CQ - var1 = 0.001 - do j = 1,4 - call MAPL_VarWrite(OutFmt,'CH',var1 ,offset1=j) - call MAPL_VarWrite(OutFmt,'CM',var1 ,offset1=j) - call MAPL_VarWrite(OutFmt,'CQ',var1 ,offset1=j) - end do - - tile_id = LDAS2BCS - do n = 1, NTILES - G2D(tile_id(n)) = n - end do - - if(trim(MODEL) == 'catch') then - - open(10, file=trim(rst_file), form='unformatted', status='old', & - convert='big_endian', action='read') - - var1 = real(tile_id) - var2 = var1 (tile_id) - do n = 1, NTILES - var2(n) = var1(g2d(n)) - end do - call MAPL_VarWrite(OutFmt,'TILE_ID' ,var2) - - read(10) var1 - var2 = var1 (tile_id) - do n = 1, NTILES - var2(n) = var1(g2d(n)) - end do - call MAPL_VarWrite(OutFmt,'TC' ,var2, offset1=1) - read(10) var1 - var2 = var1 (tile_id) - do n = 1, NTILES - var2(n) = var1(g2d(n)) - end do - call MAPL_VarWrite(OutFmt,'TC' ,var2, offset1=2) - read(10) var1 - var2 = var1 (tile_id) - do n = 1, NTILES - var2(n) = var1(g2d(n)) - end do - call MAPL_VarWrite(OutFmt,'TC' ,var2, offset1=3) - - read(10) var1 - var2 = var1 (tile_id) - do n = 1, NTILES - var2(n) = var1(g2d(n)) - end do - call MAPL_VarWrite(OutFmt,'QC' ,var2, offset1=1) - read(10) var1 - var2 = var1 (tile_id) - do n = 1, NTILES - var2(n) = var1(g2d(n)) - end do - call MAPL_VarWrite(OutFmt,'QC' ,var2, offset1=2) - read(10) var1 - var2 = var1 (tile_id) - do n = 1, NTILES - var2(n) = var1(g2d(n)) - end do - call MAPL_VarWrite(OutFmt,'QC' ,var2, offset1=3) - call MAPL_VarWrite(OutFmt,'QC' ,var2, offset1=4) - - read(10) var1 - var2 = var1 (tile_id) - do n = 1, NTILES - var2(n) = var1(g2d(n)) - end do - call MAPL_VarWrite(OutFmt,'CAPAC' ,var2) - read(10) var1 - var2 = var1 (tile_id) - do n = 1, NTILES - var2(n) = var1(g2d(n)) - end do - call MAPL_VarWrite(OutFmt,'CATDEF' ,var2) - read(10) var1 - var2 = var1 (tile_id) - do n = 1, NTILES - var2(n) = var1(g2d(n)) - end do - call MAPL_VarWrite(OutFmt,'RZEXC' ,var2) - read(10) var1 - var2 = var1 (tile_id) - do n = 1, NTILES - var2(n) = var1(g2d(n)) - end do - call MAPL_VarWrite(OutFmt,'SRFEXC' ,var2) - read(10) var1 - var2 = var1 (tile_id) - do n = 1, NTILES - var2(n) = var1(g2d(n)) - end do - call MAPL_VarWrite(OutFmt,'GHTCNT1' ,var2) - read(10) var1 - var2 = var1 (tile_id) - do n = 1, NTILES - var2(n) = var1(g2d(n)) - end do - call MAPL_VarWrite(OutFmt,'GHTCNT2' ,var2) - read(10) var1 - var2 = var1 (tile_id) - do n = 1, NTILES - var2(n) = var1(g2d(n)) - end do - call MAPL_VarWrite(OutFmt,'GHTCNT3' ,var2) - read(10) var1 - var2 = var1 (tile_id) - do n = 1, NTILES - var2(n) = var1(g2d(n)) - end do - call MAPL_VarWrite(OutFmt,'GHTCNT4' ,var2) - read(10) var1 - var2 = var1 (tile_id) - do n = 1, NTILES - var2(n) = var1(g2d(n)) - end do - call MAPL_VarWrite(OutFmt,'GHTCNT5' ,var2) - read(10) var1 - var2 = var1 (tile_id) - do n = 1, NTILES - var2(n) = var1(g2d(n)) - end do - call MAPL_VarWrite(OutFmt,'GHTCNT6' ,var2) - read(10) var1 - var2 = var1 (tile_id) - - do n = 1, NTILES - var2(n) = var1(g2d(n)) - end do - wesn1 = var2 - call MAPL_VarWrite(OutFmt,'WESNN1' ,var2) - read(10) var1 - var2 = var1 (tile_id) - do n = 1, NTILES - var2(n) = var1(g2d(n)) - end do - call MAPL_VarWrite(OutFmt,'WESNN2' ,var2) - read(10) var1 - var2 = var1 (tile_id) - do n = 1, NTILES - var2(n) = var1(g2d(n)) - end do - call MAPL_VarWrite(OutFmt,'WESNN3' ,var2) - read(10) var1 - var2 = var1 (tile_id) - do n = 1, NTILES - var2(n) = var1(g2d(n)) - end do - htsn1 = var2 - call MAPL_VarWrite(OutFmt,'HTSNNN1' ,var2) - read(10) var1 - var2 = var1 (tile_id) - do n = 1, NTILES - var2(n) = var1(g2d(n)) - end do - call MAPL_VarWrite(OutFmt,'HTSNNN2' ,var2) - read(10) var1 - var2 = var1 (tile_id) - do n = 1, NTILES - var2(n) = var1(g2d(n)) - end do - call MAPL_VarWrite(OutFmt,'HTSNNN3' ,var2) - read(10) var1 - var2 = var1 (tile_id) - do n = 1, NTILES - var2(n) = var1(g2d(n)) - end do - call MAPL_VarWrite(OutFmt,'SNDZN1' ,var2) - read(10) var1 - var2 = var1 (tile_id) - do n = 1, NTILES - var2(n) = var1(g2d(n)) - end do - call MAPL_VarWrite(OutFmt,'SNDZN2' ,var2) - read(10) var1 - var2 = var1 (tile_id) - do n = 1, NTILES - var2(n) = var1(g2d(n)) - end do - call MAPL_VarWrite(OutFmt,'SNDZN3' ,var2) - call STIEGLITZSNOW_CALC_TPSNOW(NTILES, HTSN1(:), WESN1(:), var2, var1) - var2 = var2 + 273.16 - call MAPL_VarWrite(OutFmt,'TC' ,var2, offset1=4) - deallocate (var1, var2) - call OutFmt%close() - close(10) - - else ! CATCHCN - - call InFmt%open(trim(rst_file),pFIO_READ,__RC__) - meta_data = InFmt%read(__RC__) - - call MAPL_VarRead ( InFmt,'TILE_ID',var1, __RC__) - if(sum (nint(var1) - LDAS2BCS) /= 0) then - print *, 'Tile order mismatch ', sum(var1)/ntiles, sum(LDAS2BCS)/ntiles - stop - endif - - variables => meta_data%get_variables() - var_iter = variables%begin() - do while (var_iter /= variables%end()) - - vname => var_iter%key() - var => var_iter%value() - var_dimensions => var%get_dimensions() - - ndims = var_dimensions%size() - - if (ndims == 1) then - call MAPL_VarRead ( InFmt,vname,var1, __RC__) - var2 = var1 (tile_id) - do n = 1, NTILES - var2(n) = var1(g2d(n)) - end do - if(trim(vname) == 'SFMCM' ) var2 = 0. - if(trim(vname) == 'BFLOWM' ) var2 = 0. - if(trim(vname) == 'TOTWATM') var2 = 0. - if(trim(vname) == 'TAIRM' ) var2 = 0. - if(trim(vname) == 'TPM' ) var2 = 0. - if(trim(vname) == 'CNSUM' ) var2 = 0. - if(trim(vname) == 'SNDZM' ) var2 = 0. - if(trim(vname) == 'ASNOWM' ) var2 = 0. - if(trim(vname) == 'TSURF' ) var2 = 0. - - call MAPL_VarWrite(OutFmt,vname,var2) - - else if (ndims == 2) then - - dname => var%get_ith_dimension(2) - dim1=meta_data%get_dimension(dname) - do j=1,dim1 - call MAPL_VarRead ( InFmt,vname,var1 ,offset1=j, __RC__) - var2 = var1 (tile_id) - do n = 1, NTILES - var2(n) = var1(g2d(n)) - end do - if(trim(vname) == 'TGWM' ) var2 = 0. - if(trim(vname) == 'RZMM' ) var2 = 0. - if(trim(vname) == 'WW' ) var2 = 0.1 - if(trim(vname) == 'FR' ) var2 = 0.25 - if(trim(vname) == 'CQ' ) var2 = 0.001 - if(trim(vname) == 'CN' ) var2 = 0.001 - if(trim(vname) == 'CM' ) var2 = 0.001 - if(trim(vname) == 'CH' ) var2 = 0.001 - call MAPL_VarWrite(OutFmt,vname,var2 ,offset1=j) - enddo - - else if (ndims == 3) then - - dname => var%get_ith_dimension(2) - dim1=meta_data%get_dimension(dname) - dname => var%get_ith_dimension(3) - dim2=meta_data%get_dimension(dname) - do i=1,dim2 - do j=1,dim1 - call MAPL_VarRead ( InFmt,vname,var1 ,offset1=j,offset2=i, __RC__) - var2 = var1 (tile_id) - do n = 1, NTILES - var2(n) = var1(g2d(n)) - end do - if(trim(vname) == 'PSNSUNM' ) var2 = 0. - if(trim(vname) == 'PSNSHAM' ) var2 = 0. - call MAPL_VarWrite(OutFmt,vname,var2 ,offset1=j,offset2=i) - enddo - enddo - - end if - call var_iter%next() - enddo - - call InFmt%close() - call OutFmt%close() - deallocate (var1, var2, tile_id) - endif - - call read_bcs_data (ntiles, SURFLAY, trim(MODEL), trim(BCSDIR)//'/clsm/',trim(out_rst_file), __RC__) - - if(bin_out) then - call InFmt%open(trim(out_rst_file),pFIO_READ,__RC__) - open(unit=30, file=trim(out_rst_file)//'.bin', form='unformatted') - call write_bin (30, InFmt, NTILES) - close(30) - call InFmt%close() - endif - if (present(rc)) rc =0 - !_RETURN(_SUCCESS) - - END SUBROUTINE reorder_LDASsa_restarts - - ! ***************************************************************************** - - SUBROUTINE regrid_hyd_vars (NTILES, model) - - implicit none - integer, intent (in) :: NTILES - character(*), intent (in) :: model - - ! =============================================================================================== - - integer, allocatable, dimension(:) :: Id_glb, Id_loc - integer, allocatable, dimension(:) :: ld_reorder, tid_offl - real , allocatable, dimension(:) :: tmp_var - integer :: n,i,nplus, STATUS,NCFID, req - integer :: local_id, ntiles_smap - real , allocatable, dimension (:) :: LATT, LONN - real , pointer , dimension (:) :: long, latg, lonc, latc - integer, allocatable :: low_ind(:), upp_ind(:), nt_local (:) - - logical :: all_found - character(256) :: Iam="regrid_hyd_vars" - - if(index(MODEL, 'catchcn') /=0) ntiles_smap = ntiles_cn - if(trim(MODEL) == 'catch' ) ntiles_smap = ntiles_cat - - allocate (tid_offl (ntiles_smap)) - allocate (tmp_var (ntiles_smap)) - - allocate(low_ind ( numprocs)) - allocate(upp_ind ( numprocs)) - allocate(nt_local( numprocs)) - - low_ind (:) = 1 - upp_ind (:) = NTILES - nt_local(:) = NTILES - - ! Domain decomposition - ! -------------------- - - if (numprocs > 1) then - do i = 1, numprocs - 1 - upp_ind(i) = low_ind(i) + (ntiles/numprocs) - 1 - low_ind(i+1) = upp_ind(i) + 1 - nt_local(i) = upp_ind(i) - low_ind(i) + 1 - end do - nt_local(numprocs) = upp_ind(numprocs) - low_ind(numprocs) + 1 - endif - - allocate (id_loc (nt_local (myid + 1))) - allocate (lonn (nt_local (myid + 1))) - allocate (latt (nt_local (myid + 1))) - allocate (lonc (1:ntiles_smap)) - allocate (latc (1:ntiles_smap)) - - if (root_proc) then - - allocate (long (ntiles)) - allocate (latg (ntiles)) - allocate (ld_reorder(ntiles_smap)) - - call ReadTileFile_RealLatLon ('InData/OutTileFile', i, xlon=long, xlat=latg); VERIFY_(i-ntiles) - ! --------------------------------------------- - ! Read exact lonc, latc from offline .til File - ! --------------------------------------------- - - if(index(MODEL,'catchcn') /=0) then - call ReadTileFile_RealLatLon(trim(InCNTilFile ),i,xlon=lonc,xlat=latc) - VERIFY_(i-ntiles_smap) - endif - if(trim(MODEL) == 'catch' ) then - call ReadTileFile_RealLatLon(trim(InCatTilFile),i,xlon=lonc,xlat=latc) - VERIFY_(i-ntiles_smap) - endif - if(index(MODEL,'catchcn') /=0) then - STATUS = NF_OPEN (trim(InCNRestart ),NF_NOWRITE,NCFID) ; VERIFY_(STATUS) - endif - if(trim(MODEL) == 'catch' ) then - STATUS = NF_OPEN (trim(InCatRestart),NF_NOWRITE,NCFID) ; VERIFY_(STATUS) - endif - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'TILE_ID' ), (/1/), (/NTILES_SMAP/),tmp_var) - STATUS = NF_CLOSE (NCFID) - - do n = 1, ntiles_smap - ld_reorder ( NINT(tmp_var(n))) = n - tid_offl(n) = n - end do - - deallocate (tmp_var) - - endif - - call MPI_Barrier(MPI_COMM_WORLD, STATUS) - - do i = 1, numprocs - if((I == 1).and.(myid == 0)) then - lonn(:) = long(low_ind(i) : upp_ind(i)) - latt(:) = latg(low_ind(i) : upp_ind(i)) - else if (I > 1) then - if(I-1 == myid) then - ! receiving from root - call MPI_RECV(lonn,nt_local(i) , MPI_REAL, 0,995,MPI_COMM_WORLD,MPI_STATUS_IGNORE,mpierr) - call MPI_RECV(latt,nt_local(i) , MPI_REAL, 0,994,MPI_COMM_WORLD,MPI_STATUS_IGNORE,mpierr) - else if (myid == 0) then - ! root sends - call MPI_ISend(long(low_ind(i) : upp_ind(i)),nt_local(i),MPI_REAL,i-1,995,MPI_COMM_WORLD,req,mpierr) - call MPI_WAIT (req,MPI_STATUS_IGNORE,mpierr) - call MPI_ISend(latg(low_ind(i) : upp_ind(i)),nt_local(i),MPI_REAL,i-1,994,MPI_COMM_WORLD,req,mpierr) - call MPI_WAIT (req,MPI_STATUS_IGNORE,mpierr) - endif - endif - end do - -! call MPI_SCATTERV ( & -! long,nt_local,low_ind-1,MPI_real, & -! lonn,size(lonn),MPI_real , & -! 0,MPI_COMM_WORLD, mpierr ) -! -! call MPI_SCATTERV ( & -! latg,nt_local,low_ind-1,MPI_real, & -! latt,nt_local(myid+1),MPI_real , & -! 0,MPI_COMM_WORLD, mpierr ) - - if(root_proc) deallocate (long, latg) - - call MPI_BCAST(lonc,ntiles_smap,MPI_REAL,0,MPI_COMM_WORLD,mpierr) - call MPI_BCAST(latc,ntiles_smap,MPI_REAL,0,MPI_COMM_WORLD,mpierr) - call MPI_BCAST(tid_offl,size(tid_offl ),MPI_INTEGER,0,MPI_COMM_WORLD,mpierr) - - ! -------------------------------------------------------------------------------- - ! Here we create transfer index array to map offline restarts to output tile space - ! -------------------------------------------------------------------------------- - - call GetIds(lonc,latc,lonn,latt,id_loc, tid_offl) - - ! Loop through NTILES (# of tiles in output array) find the nearest neighbor from Qing. - - if(root_proc) allocate (id_glb (ntiles)) - - call MPI_Barrier(MPI_COMM_WORLD, STATUS) -! call MPI_GATHERV( & -! id_loc, nt_local(myid+1) , MPI_real, & -! id_glb, nt_local,low_ind-1, MPI_real, & -! 0, MPI_COMM_WORLD, mpierr ) - do i = 1, numprocs - if((I == 1).and.(myid == 0)) then - id_glb(low_ind(i) : upp_ind(i)) = Id_loc(:) - else if (I > 1) then - if(I-1 == myid) then - ! send to root - call MPI_ISend(id_loc,nt_local(i),MPI_INTEGER,0,993,MPI_COMM_WORLD,req,mpierr) - call MPI_WAIT (req,MPI_STATUS_IGNORE,mpierr) - else if (myid == 0) then - ! root receives - call MPI_RECV(id_glb(low_ind(i) : upp_ind(i)),nt_local(i) , MPI_INTEGER, i-1,993,MPI_COMM_WORLD,MPI_STATUS_IGNORE,mpierr) - endif - endif - end do - - if (root_proc) call put_land_vars (NTILES, ntiles_smap, id_glb, ld_reorder, model) - - call MPI_Barrier(MPI_COMM_WORLD, STATUS) - - END SUBROUTINE regrid_hyd_vars - - - ! ***************************************************************************** - - SUBROUTINE read_bcs_data (ntiles, SURFLAY,MODEL, DataDir, InRestart, rc) - - ! This subroutine : - ! 1) reads BCs from BCSDIR and hydrological varables from InRestart. - ! InRestart is a catchcn_internal_rst nc4 file. - ! - ! 2) writes out BCs and hydrological variables in catchcn_internal_rst (1:72). - ! output catchcn_internal_rst is nc4. - - implicit none - real, intent (in) :: SURFLAY - integer, intent (in) :: ntiles - character(*), intent (in) :: MODEL, DataDir, InRestart - integer, optional, intent(out) :: rc - real, allocatable :: CLMC_pf1(:), CLMC_pf2(:), CLMC_sf1(:), CLMC_sf2(:) - real, allocatable :: CLMC_pt1(:), CLMC_pt2(:), CLMC_st1(:), CLMC_st2(:) - real, allocatable :: CLMC45_pf1(:), CLMC45_pf2(:), CLMC45_sf1(:), CLMC45_sf2(:) - real, allocatable :: CLMC45_pt1(:), CLMC45_pt2(:), CLMC45_st1(:), CLMC45_st2(:) - real, allocatable :: BF1(:), BF2(:), BF3(:), VGWMAX(:) - real, allocatable :: CDCR1(:), CDCR2(:), PSIS(:), BEE(:) - real, allocatable :: POROS(:), WPWET(:), COND(:), GNU(:) - real, allocatable :: ARS1(:), ARS2(:), ARS3(:) - real, allocatable :: ARA1(:), ARA2(:), ARA3(:), ARA4(:) - real, allocatable :: ARW1(:), ARW2(:), ARW3(:), ARW4(:) - real, allocatable :: TSA1(:), TSA2(:), TSB1(:), TSB2(:) - real, allocatable :: ATAU2(:), BTAU2(:), DP2BR(:), CanopH(:) - real, allocatable :: NDEP(:), BVISDR(:), BVISDF(:), BNIRDR(:), BNIRDF(:) - real, allocatable :: T2(:), var1(:), hdm(:), fc(:), gdp(:), peatf(:), RITY(:) - integer, allocatable :: ity(:), abm (:) - integer :: NCFID, STATUS - integer :: idum, i,j,n, ib, nv - real :: rdum, zdep1, zdep2, zdep3, zmet, term1, term2, bare,fvg(4) - logical :: NEWLAND, isCatchCN - logical :: file_exists - type(NetCDF4_Fileformatter) :: CatchFmt,CatchCNFmt - character*256 :: Iam = "read_bcs_data" - - allocate ( BF1(ntiles), BF2 (ntiles), BF3(ntiles) ) - allocate (VGWMAX(ntiles), CDCR1(ntiles), CDCR2(ntiles) ) - allocate ( PSIS(ntiles), BEE(ntiles), POROS(ntiles) ) - allocate ( WPWET(ntiles), COND(ntiles), GNU(ntiles) ) - allocate ( ARS1(ntiles), ARS2(ntiles), ARS3(ntiles) ) - allocate ( ARA1(ntiles), ARA2(ntiles), ARA3(ntiles) ) - allocate ( ARA4(ntiles), ARW1(ntiles), ARW2(ntiles) ) - allocate ( ARW3(ntiles), ARW4(ntiles), TSA1(ntiles) ) - allocate ( TSA2(ntiles), TSB1(ntiles), TSB2(ntiles) ) - allocate ( ATAU2(ntiles), BTAU2(ntiles), DP2BR(ntiles) ) - allocate (BVISDR(ntiles), BVISDF(ntiles), BNIRDR(ntiles) ) - allocate (BNIRDF(ntiles), T2(ntiles), NDEP(ntiles) ) - allocate ( ity(ntiles), CanopH(ntiles) ) - allocate (CLMC_pf1(ntiles), CLMC_pf2(ntiles), CLMC_sf1(ntiles)) - allocate (CLMC_sf2(ntiles), CLMC_pt1(ntiles), CLMC_pt2(ntiles)) - allocate (CLMC45_pf1(ntiles), CLMC45_pf2(ntiles), CLMC45_sf1(ntiles)) - allocate (CLMC45_sf2(ntiles), CLMC45_pt1(ntiles), CLMC45_pt2(ntiles)) - allocate (CLMC_st1(ntiles), CLMC_st2(ntiles)) - allocate (CLMC45_st1(ntiles), CLMC45_st2(ntiles)) - allocate (hdm(ntiles), fc(ntiles), gdp(ntiles)) - allocate (peatf(ntiles), abm(ntiles), var1(ntiles), RITY(ntiles)) - - inquire(file = trim(DataDir)//'/catchcn_params.nc4', exist=file_exists) - inquire(file = trim(DataDir)//"CLM_veg_typs_fracs" ,exist=NewLand ) - - isCatchCN = (index(model,'catchcn') /=0) - - if(file_exists) then - - print *,'FILE FORMAT FOR LAND BCS IS NC4' - call CatchFmt%Open(trim(DataDir)//'/catch_params.nc4', pFIO_READ, __RC__) - call MAPL_VarRead ( CatchFmt ,'OLD_ITY', RITY, __RC__) - ITY = NINT (RITY) - call MAPL_VarRead ( CatchFmt ,'ARA1', ARA1, __RC__) - call MAPL_VarRead ( CatchFmt ,'ARA2', ARA2, __RC__) - call MAPL_VarRead ( CatchFmt ,'ARA3', ARA3, __RC__) - call MAPL_VarRead ( CatchFmt ,'ARA4', ARA4, __RC__) - call MAPL_VarRead ( CatchFmt ,'ARS1', ARS1, __RC__) - call MAPL_VarRead ( CatchFmt ,'ARS2', ARS2, __RC__) - call MAPL_VarRead ( CatchFmt ,'ARS3', ARS3, __RC__) - call MAPL_VarRead ( CatchFmt ,'ARW1', ARW1, __RC__) - call MAPL_VarRead ( CatchFmt ,'ARW2', ARW2, __RC__) - call MAPL_VarRead ( CatchFmt ,'ARW3', ARW3, __RC__) - call MAPL_VarRead ( CatchFmt ,'ARW4', ARW4, __RC__) - - if( SURFLAY.eq.20.0 ) then - call MAPL_VarRead ( CatchFmt ,'ATAU2', ATAU2, __RC__) - call MAPL_VarRead ( CatchFmt ,'BTAU2', BTAU2, __RC__) - endif - - if( SURFLAY.eq.50.0 ) then - call MAPL_VarRead ( CatchFmt ,'ATAU5', ATAU2, __RC__) - call MAPL_VarRead ( CatchFmt ,'BTAU5', BTAU2, __RC__) - endif - - call MAPL_VarRead ( CatchFmt ,'PSIS', PSIS, __RC__) - call MAPL_VarRead ( CatchFmt ,'BEE', BEE, __RC__) - call MAPL_VarRead ( CatchFmt ,'BF1', BF1, __RC__) - call MAPL_VarRead ( CatchFmt ,'BF2', BF2, __RC__) - call MAPL_VarRead ( CatchFmt ,'BF3', BF3, __RC__) - call MAPL_VarRead ( CatchFmt ,'TSA1', TSA1, __RC__) - call MAPL_VarRead ( CatchFmt ,'TSA2', TSA2, __RC__) - call MAPL_VarRead ( CatchFmt ,'TSB1', TSB1, __RC__) - call MAPL_VarRead ( CatchFmt ,'TSB2', TSB2, __RC__) - call MAPL_VarRead ( CatchFmt ,'COND', COND, __RC__) - call MAPL_VarRead ( CatchFmt ,'GNU', GNU, __RC__) - call MAPL_VarRead ( CatchFmt ,'WPWET', WPWET, __RC__) - call MAPL_VarRead ( CatchFmt ,'DP2BR', DP2BR, __RC__) - call MAPL_VarRead ( CatchFmt ,'POROS', POROS, __RC__) - call CatchFmt%close() - if(isCatchCN) then - call CatchCNFmt%Open(trim(DataDir)//'/catchcn_params.nc4', pFIO_READ, __RC__) - call MAPL_VarRead ( CatchCNFmt ,'BGALBNF', BNIRDF, __RC__) - call MAPL_VarRead ( CatchCNFmt ,'BGALBNR', BNIRDR, __RC__) - call MAPL_VarRead ( CatchCNFmt ,'BGALBVF', BVISDF, __RC__) - call MAPL_VarRead ( CatchCNFmt ,'BGALBVR', BVISDR, __RC__) - call MAPL_VarRead ( CatchCNFmt ,'NDEP', NDEP, __RC__) - call MAPL_VarRead ( CatchCNFmt ,'T2_M', T2, __RC__) - call MAPL_VarRead(CatchCNFmt,'ITY',CLMC_pt1,offset1=1, __RC__) ! 30 - call MAPL_VarRead(CatchCNFmt,'ITY',CLMC_pt2,offset1=2, __RC__) ! 31 - call MAPL_VarRead(CatchCNFmt,'ITY',CLMC_st1,offset1=3, __RC__) ! 32 - call MAPL_VarRead(CatchCNFmt,'ITY',CLMC_st2,offset1=4, __RC__) ! 33 - call MAPL_VarRead(CatchCNFmt,'FVG',CLMC_pf1,offset1=1, __RC__) ! 34 - call MAPL_VarRead(CatchCNFmt,'FVG',CLMC_pf2,offset1=2, __RC__) ! 35 - call MAPL_VarRead(CatchCNFmt,'FVG',CLMC_sf1,offset1=3, __RC__) ! 36 - call MAPL_VarRead(CatchCNFmt,'FVG',CLMC_sf2,offset1=4, __RC__) ! 37 - call CatchCNFmt%close() - if(clm45) then - open(unit=30, file=trim(DataDir)//'CLM4.5_abm_peatf_gdp_hdm_fc' ,form='formatted') - do n=1,ntiles - read (30, *) i, j, abm(n), peatf(n), & - gdp(n), hdm(n), fc(n) - end do - CLOSE (30, STATUS = 'KEEP') - endif - endif - - - else - open(unit=21, file=trim(DataDir)//'mosaic_veg_typs_fracs',form='formatted') - open(unit=22, file=trim(DataDir)//'bf.dat' ,form='formatted') - open(unit=23, file=trim(DataDir)//'soil_param.dat' ,form='formatted') - open(unit=24, file=trim(DataDir)//'ar.new' ,form='formatted') - open(unit=25, file=trim(DataDir)//'ts.dat' ,form='formatted') - open(unit=26, file=trim(DataDir)//'tau_param.dat' ,form='formatted') - - if(NewLand .and. isCatchCN) then - open(unit=27, file=trim(DataDir)//'CLM_veg_typs_fracs' ,form='formatted') - open(unit=28, file=trim(DataDir)//'CLM_NDep_SoilAlb_T2m' ,form='formatted') - if(clm45) then - open(unit=29, file=trim(DataDir)//'CLM4.5_veg_typs_fracs',form='formatted') - open(unit=30, file=trim(DataDir)//'CLM4.5_abm_peatf_gdp_hdm_fc' ,form='formatted') - endif - endif - - do n=1,ntiles - var1 (n) = real (n) - ! W.J notes: CanopH is not used. If CLM_veg_typs_fracs exists, the read some dummy ???? Ask Sarith - if (NewLand) then - read(21,*) I, j, ITY(N),idum, rdum, rdum, CanopH(N) - else - read(21,*) I, j, ITY(N),idum, rdum, rdum - endif - - read (22, *) i,j, GNU(n), BF1(n), BF2(n), BF3(n) - - read (23, *) i,j, idum, idum, BEE(n), PSIS(n),& - POROS(n), COND(n), WPWET(n), DP2BR(n) - - read (24, *) i,j, rdum, ARS1(n), ARS2(n), ARS3(n), & - ARA1(n), ARA2(n), ARA3(n), ARA4(n), & - ARW1(n), ARW2(n), ARW3(n), ARW4(n) - - read (25, *) i,j, rdum, TSA1(n), TSA2(n), TSB1(n), TSB2(n) - - if( SURFLAY.eq.20.0 ) read (26, *) i,j, ATAU2(n), BTAU2(n), rdum, rdum ! for old soil params - if( SURFLAY.eq.50.0 ) read (26, *) i,j, rdum , rdum, ATAU2(n), BTAU2(n) ! for new soil params - - if (NewLand .and. isCatchCN) then - read (27, *) i,j, CLMC_pt1(n), CLMC_pt2(n), CLMC_st1(n), CLMC_st2(n), & - CLMC_pf1(n), CLMC_pf2(n), CLMC_sf1(n), CLMC_sf2(n) - - read (28, *) NDEP(n), BVISDR(n), BVISDF(n), BNIRDR(n), BNIRDF(n), T2(n) ! MERRA-2 Annual Mean Temp is default. - if(clm45) then - read (29, *) i,j, CLMC45_pt1(n), CLMC45_pt2(n), CLMC45_st1(n), CLMC45_st2(n), & - CLMC45_pf1(n), CLMC45_pf2(n), CLMC45_sf1(n), CLMC45_sf2(n) - - read (30, *) i, j, abm(n), peatf(n), & - gdp(n), hdm(n), fc(n) - endif - endif - end do - - CLOSE (21, STATUS = 'KEEP') - CLOSE (22, STATUS = 'KEEP') - CLOSE (23, STATUS = 'KEEP') - CLOSE (24, STATUS = 'KEEP') - CLOSE (25, STATUS = 'KEEP') - CLOSE (26, STATUS = 'KEEP') - - if(NewLand .and. isCatchCN) then - CLOSE (27, STATUS = 'KEEP') - CLOSE (28, STATUS = 'KEEP') - if(clm45) then - CLOSE (29, STATUS = 'KEEP') - CLOSE (30, STATUS = 'KEEP') - endif - endif - endif - - - do n=1,ntiles - var1 (n) = real (n) - - zdep2=1000. - zdep3=amax1(1000.,DP2BR(n)) - - if (zdep2 .gt.0.75*zdep3) then - zdep2 = 0.75*zdep3 - end if - - zdep1=20. - zmet=zdep3/1000. - - term1=-1.+((PSIS(n)-zmet)/PSIS(n))**((BEE(n)-1.)/BEE(n)) - term2=PSIS(n)*BEE(n)/(BEE(n)-1) - - VGWMAX(n) = POROS(n)*zdep2 - CDCR1(n) = 1000.*POROS(n)*(zmet-(-term2*term1)) - CDCR2(n) = (1.-WPWET(n))*POROS(n)*zdep3 - - if( isCatchCN) then - - BVISDR(n) = amax1(1.e-6, BVISDR(n)) - BVISDF(n) = amax1(1.e-6, BVISDF(n)) - BNIRDR(n) = amax1(1.e-6, BNIRDR(n)) - BNIRDF(n) = amax1(1.e-6, BNIRDF(n)) - - ! convert % to fractions - - CLMC_pf1(n) = CLMC_pf1(n) / 100. - CLMC_pf2(n) = CLMC_pf2(n) / 100. - CLMC_sf1(n) = CLMC_sf1(n) / 100. - CLMC_sf2(n) = CLMC_sf2(n) / 100. - - fvg(1) = CLMC_pf1(n) - fvg(2) = CLMC_pf2(n) - fvg(3) = CLMC_sf1(n) - fvg(4) = CLMC_sf2(n) - - BARE = 1. - - DO NV = 1, NVEG - BARE = BARE - FVG(NV)! subtract vegetated fractions - END DO - - if (BARE /= 0.) THEN - IB = MAXLOC(FVG(:),1) - FVG (IB) = FVG(IB) + BARE ! This also corrects all cases sum ne 0. - ENDIF - - CLMC_pf1(n) = fvg(1) - CLMC_pf2(n) = fvg(2) - CLMC_sf1(n) = fvg(3) - CLMC_sf2(n) = fvg(4) - - if(CLM45) then - ! CLM 45 - - CLMC45_pf1(n) = CLMC45_pf1(n) / 100. - CLMC45_pf2(n) = CLMC45_pf2(n) / 100. - CLMC45_sf1(n) = CLMC45_sf1(n) / 100. - CLMC45_sf2(n) = CLMC45_sf2(n) / 100. - - fvg(1) = CLMC45_pf1(n) - fvg(2) = CLMC45_pf2(n) - fvg(3) = CLMC45_sf1(n) - fvg(4) = CLMC45_sf2(n) - - BARE = 1. - - DO NV = 1, NVEG - BARE = BARE - FVG(NV)! subtract vegetated fractions - END DO - - if (BARE /= 0.) THEN - IB = MAXLOC(FVG(:),1) - FVG (IB) = FVG(IB) + BARE ! This also corrects all cases sum ne 0. - ENDIF - - CLMC45_pf1(n) = fvg(1) - CLMC45_pf2(n) = fvg(2) - CLMC45_sf1(n) = fvg(3) - CLMC45_sf2(n) = fvg(4) - endif - endif - enddo - - if( isCatchCN) then - - NDEP = NDEP * 1.e-9 - - ! prevent trivial fractions - ! ------------------------- - do n = 1,ntiles - if(CLMC_pf1(n) <= 1.e-4) then - CLMC_pf2(n) = CLMC_pf2(n) + CLMC_pf1(n) - CLMC_pf1(n) = 0. - endif - - if(CLMC_pf2(n) <= 1.e-4) then - CLMC_pf1(n) = CLMC_pf1(n) + CLMC_pf2(n) - CLMC_pf2(n) = 0. - endif - - if(CLMC_sf1(n) <= 1.e-4) then - if(CLMC_sf2(n) > 1.e-4) then - CLMC_sf2(n) = CLMC_sf2(n) + CLMC_sf1(n) - else if(CLMC_pf2(n) > 1.e-4) then - CLMC_pf2(n) = CLMC_pf2(n) + CLMC_sf1(n) - else if(CLMC_pf1(n) > 1.e-4) then - CLMC_pf1(n) = CLMC_pf1(n) + CLMC_sf1(n) - else - stop 'fveg3' - endif - CLMC_sf1(n) = 0. - endif - - if(CLMC_sf2(n) <= 1.e-4) then - if(CLMC_sf1(n) > 1.e-4) then - CLMC_sf1(n) = CLMC_sf1(n) + CLMC_sf2(n) - else if(CLMC_pf2(n) > 1.e-4) then - CLMC_pf2(n) = CLMC_pf2(n) + CLMC_sf2(n) - else if(CLMC_pf1(n) > 1.e-4) then - CLMC_pf1(n) = CLMC_pf1(n) + CLMC_sf2(n) - else - stop 'fveg4' - endif - CLMC_sf2(n) = 0. - endif - - if (clm45) then - ! CLM45 - if(CLMC45_pf1(n) <= 1.e-4) then - CLMC45_pf2(n) = CLMC45_pf2(n) + CLMC45_pf1(n) - CLMC45_pf1(n) = 0. - endif - - if(CLMC45_pf2(n) <= 1.e-4) then - CLMC45_pf1(n) = CLMC45_pf1(n) + CLMC45_pf2(n) - CLMC45_pf2(n) = 0. - endif - - if(CLMC45_sf1(n) <= 1.e-4) then - if(CLMC45_sf2(n) > 1.e-4) then - CLMC45_sf2(n) = CLMC45_sf2(n) + CLMC45_sf1(n) - else if(CLMC45_pf2(n) > 1.e-4) then - CLMC45_pf2(n) = CLMC45_pf2(n) + CLMC45_sf1(n) - else if(CLMC45_pf1(n) > 1.e-4) then - CLMC45_pf1(n) = CLMC45_pf1(n) + CLMC45_sf1(n) - else - stop 'fveg3' - endif - CLMC45_sf1(n) = 0. - endif - - if(CLMC45_sf2(n) <= 1.e-4) then - if(CLMC45_sf1(n) > 1.e-4) then - CLMC45_sf1(n) = CLMC45_sf1(n) + CLMC45_sf2(n) - else if(CLMC45_pf2(n) > 1.e-4) then - CLMC45_pf2(n) = CLMC45_pf2(n) + CLMC45_sf2(n) - else if(CLMC45_pf1(n) > 1.e-4) then - CLMC45_pf1(n) = CLMC45_pf1(n) + CLMC45_sf2(n) - else - stop 'fveg4' - endif - CLMC45_sf2(n) = 0. - endif - endif - end do - endif - - - ! Vegdyn Boundary Condition - ! ------------------------- - - ! open(20,file=trim("vegdyn_internal_rst"), & - ! status="unknown", & - ! form="unformatted",convert="little_endian") - ! write(20) real(ity) - ! if(NewLand) write(20) CanopH - ! close(20) - ! print *, "Wrote vegdyn_internal_restart" - - ! Now writing BCs (from BCSDIR) and regridded hydrological variables 1-72 - ! ----------------------------------------------------------------------- - - STATUS = NF_OPEN (trim(InRestart),NF_WRITE,NCFID) ; VERIFY_(STATUS) - STATUS = NF_PUT_VARA_REAL(NCFID,VarID(NCFID,'BF1'), (/1/), (/NTILES/),BF1) - STATUS = NF_PUT_VARA_REAL(NCFID,VarID(NCFID,'BF2'), (/1/), (/NTILES/),BF2) - STATUS = NF_PUT_VARA_REAL(NCFID,VarID(NCFID,'BF3'), (/1/), (/NTILES/),BF3) - STATUS = NF_PUT_VARA_REAL(NCFID,VarID(NCFID,'VGWMAX'), (/1/), (/NTILES/),VGWMAX) - STATUS = NF_PUT_VARA_REAL(NCFID,VarID(NCFID,'CDCR1'), (/1/), (/NTILES/),CDCR1) - STATUS = NF_PUT_VARA_REAL(NCFID,VarID(NCFID,'CDCR2'), (/1/), (/NTILES/),CDCR2) - STATUS = NF_PUT_VARA_REAL(NCFID,VarID(NCFID,'PSIS'), (/1/), (/NTILES/),PSIS) - STATUS = NF_PUT_VARA_REAL(NCFID,VarID(NCFID,'BEE'), (/1/), (/NTILES/),BEE) - STATUS = NF_PUT_VARA_REAL(NCFID,VarID(NCFID,'POROS'), (/1/), (/NTILES/),POROS) - STATUS = NF_PUT_VARA_REAL(NCFID,VarID(NCFID,'WPWET'), (/1/), (/NTILES/),WPWET) - STATUS = NF_PUT_VARA_REAL(NCFID,VarID(NCFID,'COND'), (/1/), (/NTILES/),COND) - STATUS = NF_PUT_VARA_REAL(NCFID,VarID(NCFID,'GNU'), (/1/), (/NTILES/),GNU) - STATUS = NF_PUT_VARA_REAL(NCFID,VarID(NCFID,'ARS1'), (/1/), (/NTILES/),ARS1) - STATUS = NF_PUT_VARA_REAL(NCFID,VarID(NCFID,'ARS2'), (/1/), (/NTILES/),ARS2) - STATUS = NF_PUT_VARA_REAL(NCFID,VarID(NCFID,'ARS3'), (/1/), (/NTILES/),ARS3) - STATUS = NF_PUT_VARA_REAL(NCFID,VarID(NCFID,'ARA1'), (/1/), (/NTILES/),ARA1) - STATUS = NF_PUT_VARA_REAL(NCFID,VarID(NCFID,'ARA2'), (/1/), (/NTILES/),ARA2) - STATUS = NF_PUT_VARA_REAL(NCFID,VarID(NCFID,'ARA3'), (/1/), (/NTILES/),ARA3) - STATUS = NF_PUT_VARA_REAL(NCFID,VarID(NCFID,'ARA4'), (/1/), (/NTILES/),ARA4) - STATUS = NF_PUT_VARA_REAL(NCFID,VarID(NCFID,'ARW1'), (/1/), (/NTILES/),ARW1) - STATUS = NF_PUT_VARA_REAL(NCFID,VarID(NCFID,'ARW2'), (/1/), (/NTILES/),ARW2) - STATUS = NF_PUT_VARA_REAL(NCFID,VarID(NCFID,'ARW3'), (/1/), (/NTILES/),ARW3) - STATUS = NF_PUT_VARA_REAL(NCFID,VarID(NCFID,'ARW4'), (/1/), (/NTILES/),ARW4) - STATUS = NF_PUT_VARA_REAL(NCFID,VarID(NCFID,'TSA1'), (/1/), (/NTILES/),TSA1) - STATUS = NF_PUT_VARA_REAL(NCFID,VarID(NCFID,'TSA2'), (/1/), (/NTILES/),TSA2) - STATUS = NF_PUT_VARA_REAL(NCFID,VarID(NCFID,'TSB1'), (/1/), (/NTILES/),TSB1) - STATUS = NF_PUT_VARA_REAL(NCFID,VarID(NCFID,'TSB2'), (/1/), (/NTILES/),TSB2) - STATUS = NF_PUT_VARA_REAL(NCFID,VarID(NCFID,'ATAU'), (/1/), (/NTILES/),ATAU2) - STATUS = NF_PUT_VARA_REAL(NCFID,VarID(NCFID,'BTAU'), (/1/), (/NTILES/),BTAU2) - STATUS = NF_PUT_VARA_REAL(NCFID,VarID(NCFID,'TILE_ID'), (/1/), (/NTILES/),VAR1) - - if( isCatchCN ) then - - STATUS = NF_PUT_VARA_REAL(NCFID,VarID(NCFID,'ITY'), (/1,1/), (/NTILES,1/),CLMC_pt1) - STATUS = NF_PUT_VARA_REAL(NCFID,VarID(NCFID,'ITY'), (/1,2/), (/NTILES,1/),CLMC_pt2) - STATUS = NF_PUT_VARA_REAL(NCFID,VarID(NCFID,'ITY'), (/1,3/), (/NTILES,1/),CLMC_st1) - STATUS = NF_PUT_VARA_REAL(NCFID,VarID(NCFID,'ITY'), (/1,4/), (/NTILES,1/),CLMC_st2) - - STATUS = NF_PUT_VARA_REAL(NCFID,VarID(NCFID,'FVG'), (/1,1/), (/NTILES,1/),CLMC_pf1) - STATUS = NF_PUT_VARA_REAL(NCFID,VarID(NCFID,'FVG'), (/1,2/), (/NTILES,1/),CLMC_pf2) - STATUS = NF_PUT_VARA_REAL(NCFID,VarID(NCFID,'FVG'), (/1,3/), (/NTILES,1/),CLMC_sf1) - STATUS = NF_PUT_VARA_REAL(NCFID,VarID(NCFID,'FVG'), (/1,4/), (/NTILES,1/),CLMC_sf2) - - - STATUS = NF_PUT_VARA_REAL(NCFID,VarID(NCFID,'NDEP' ), (/1/), (/NTILES/),NDEP) - STATUS = NF_PUT_VARA_REAL(NCFID,VarID(NCFID,'CLI_T2M'), (/1/), (/NTILES/),T2) - STATUS = NF_PUT_VARA_REAL(NCFID,VarID(NCFID,'BGALBVR'), (/1/), (/NTILES/),BVISDR) - STATUS = NF_PUT_VARA_REAL(NCFID,VarID(NCFID,'BGALBVF'), (/1/), (/NTILES/),BVISDF) - STATUS = NF_PUT_VARA_REAL(NCFID,VarID(NCFID,'BGALBNR'), (/1/), (/NTILES/),BNIRDR) - STATUS = NF_PUT_VARA_REAL(NCFID,VarID(NCFID,'BGALBNF'), (/1/), (/NTILES/),BNIRDF) - - if(CLM45) then - - STATUS = NF_PUT_VARA_REAL(NCFID,VarID(NCFID,'ABM' ), (/1/), (/NTILES/),real(ABM)) - STATUS = NF_PUT_VARA_REAL(NCFID,VarID(NCFID,'FIELDCAP'), (/1/), (/NTILES/),FC) - STATUS = NF_PUT_VARA_REAL(NCFID,VarID(NCFID,'HDM' ), (/1/), (/NTILES/),HDM) - STATUS = NF_PUT_VARA_REAL(NCFID,VarID(NCFID,'GDP' ), (/1/), (/NTILES/),GDP) - STATUS = NF_PUT_VARA_REAL(NCFID,VarID(NCFID,'PEATF' ), (/1/), (/NTILES/),PEATF) - endif - - else - STATUS = NF_PUT_VARA_REAL(NCFID,VarID(NCFID,'OLD_ITY'), (/1/), (/NTILES/),real(ITY)) - endif - - STATUS = NF_CLOSE ( NCFID) - - deallocate ( BF1, BF2, BF3 ) - deallocate (VGWMAX, CDCR1, CDCR2 ) - deallocate ( PSIS, BEE, POROS ) - deallocate ( WPWET, COND, GNU ) - deallocate ( ARS1, ARS2, ARS3 ) - deallocate ( ARA1, ARA2, ARA3 ) - deallocate ( ARA4, ARW1, ARW2 ) - deallocate ( ARW3, ARW4, TSA1 ) - deallocate ( TSA2, TSB1, TSB2 ) - deallocate ( ATAU2, BTAU2, DP2BR ) - deallocate (BVISDR, BVISDF, BNIRDR ) - deallocate (BNIRDF, T2, NDEP ) - deallocate ( ity, CanopH) - deallocate (CLMC_pf1, CLMC_pf2, CLMC_sf1) - deallocate (CLMC_sf2, CLMC_pt1, CLMC_pt2) - deallocate (CLMC_st1,CLMC_st2) - if (present(rc)) rc =0 - !_RETURN(_SUCCESS) - END SUBROUTINE read_bcs_data - - ! ***************************************************************************** - - SUBROUTINE regrid_carbon_vars (NTILES, model) - - implicit none - - integer, intent (in) :: NTILES - character(*), intent (in) :: model - character*300 :: OutTileFile = 'InData/OutTileFile' - character*300 :: OutFileName - integer :: AGCM_YY=2015,AGCM_MM=1,AGCM_DD=1,AGCM_HR=0 - real, allocatable, dimension (:) :: CLMC_pf1, CLMC_pf2, CLMC_sf1, CLMC_sf2, & - CLMC_pt1, CLMC_pt2,CLMC_st1,CLMC_st2 - - ! =============================================================================================== - - integer, allocatable, dimension(:,:) :: Id_glb, Id_loc - integer, allocatable, dimension(:) :: tid_offl, id_vec - real, allocatable, dimension(:,:) :: fveg_offl, ityp_offl - integer :: n,i,j, k, offl_cell, STATUS,NCFID, req - integer :: outid, local_id, nv, nz, iv - real , allocatable, dimension (:) :: LATT, LONN, DAYX, TILE_ID, var_dum2 - real, allocatable :: var_off_col (:,:,:), var_off_pft (:,:,:,:) - integer, allocatable :: low_ind(:), upp_ind(:), nt_local (:) - real , pointer , dimension (:) :: long, latg, lonc, latc - character*256 :: Iam = "regrid_carbon_vars" - - OutFileName='OutData/'//trim(model)//'_internal_rst' - - allocate (tid_offl (ntiles_cn)) - allocate (ityp_offl (ntiles_cn,nveg)) - allocate (fveg_offl (ntiles_cn,nveg)) - - allocate(low_ind ( numprocs)) - allocate(upp_ind ( numprocs)) - allocate(nt_local( numprocs)) - - low_ind (:) = 1 - upp_ind (:) = NTILES - nt_local(:) = NTILES - - ! Domain decomposition - ! -------------------- - - if (numprocs > 1) then - do i = 1, numprocs - 1 - upp_ind(i) = low_ind(i) + (ntiles/numprocs) - 1 - low_ind(i+1) = upp_ind(i) + 1 - nt_local(i) = upp_ind(i) - low_ind(i) + 1 - end do - nt_local(numprocs) = upp_ind(numprocs) - low_ind(numprocs) + 1 - endif - - allocate (id_loc (nt_local (myid + 1),4)) - allocate (lonn (nt_local (myid + 1))) - allocate (latt (nt_local (myid + 1))) - allocate (CLMC_pf1(nt_local (myid + 1))) - allocate (CLMC_pf2(nt_local (myid + 1))) - allocate (CLMC_sf1(nt_local (myid + 1))) - allocate (CLMC_sf2(nt_local (myid + 1))) - allocate (CLMC_pt1(nt_local (myid + 1))) - allocate (CLMC_pt2(nt_local (myid + 1))) - allocate (CLMC_st1(nt_local (myid + 1))) - allocate (CLMC_st2(nt_local (myid + 1))) - allocate (lonc (1:ntiles_cn)) - allocate (latc (1:ntiles_cn)) - - if (root_proc) then - - ! -------------------------------------------- - ! Read exact lonn, latt from output .til file - ! -------------------------------------------- - - allocate (long (ntiles)) - allocate (latg (ntiles)) - allocate (DAYX (NTILES)) - - call ReadTileFile_RealLatLon (OutTileFile, i, xlon=long, xlat=latg); VERIFY_(i-ntiles) - - ! Compute DAYX - ! ------------ - - call compute_dayx ( & - NTILES, AGCM_YY, AGCM_MM, AGCM_DD, AGCM_HR, & - LATG, DAYX) - - ! --------------------------------------------- - ! Read exact lonc, latc from offline .til File - ! --------------------------------------------- - - call ReadTileFile_RealLatLon(trim(InCNTilFile),i,xlon=lonc,xlat=latc); VERIFY_(i-ntiles_cn) - - endif - -! call MPI_SCATTERV ( & -! long,nt_local,low_ind-1,MPI_real, & -! lonn,size(lonn),MPI_real , & -! 0,MPI_COMM_WORLD, mpierr ) - -! call MPI_SCATTERV ( & -! latg,nt_local,low_ind-1,MPI_real, & -! latt,nt_local(myid+1),MPI_real , & -! 0,MPI_COMM_WORLD, mpierr ) - - do i = 1, numprocs - if((I == 1).and.(myid == 0)) then - lonn(:) = long(low_ind(i) : upp_ind(i)) - latt(:) = latg(low_ind(i) : upp_ind(i)) - else if (I > 1) then - if(I-1 == myid) then - ! receiving from root - call MPI_RECV(lonn,nt_local(i) , MPI_REAL, 0,995,MPI_COMM_WORLD,MPI_STATUS_IGNORE,mpierr) - call MPI_RECV(latt,nt_local(i) , MPI_REAL, 0,994,MPI_COMM_WORLD,MPI_STATUS_IGNORE,mpierr) - else if (myid == 0) then - ! root sends - call MPI_ISend(long(low_ind(i) : upp_ind(i)),nt_local(i),MPI_REAL,i-1,995,MPI_COMM_WORLD,req,mpierr) - call MPI_WAIT (req,MPI_STATUS_IGNORE,mpierr) - call MPI_ISend(latg(low_ind(i) : upp_ind(i)),nt_local(i),MPI_REAL,i-1,994,MPI_COMM_WORLD,req,mpierr) - call MPI_WAIT (req,MPI_STATUS_IGNORE,mpierr) - endif - endif - end do - - - if(root_proc) deallocate (long, latg) - - call MPI_BCAST(lonc,ntiles_cn,MPI_REAL,0,MPI_COMM_WORLD,mpierr) - call MPI_BCAST(latc,ntiles_cn,MPI_REAL,0,MPI_COMM_WORLD,mpierr) - - ! Open GKW/Fzeng SMAP M09 catchcn_internal_rst and output catchcn_internal_rst - ! ---------------------------------------------------------------------------- - - STATUS = NF_OPEN_PAR (trim(OutFileName),IOR(NF_WRITE ,NF_MPIIO),MPI_COMM_WORLD, infos,OUTID) - IF (STATUS .NE. NF_NOERR) CALL HANDLE_ERR(STATUS, 'OUTPUT RESTART FAILED') - - STATUS = NF_GET_VARA_REAL(OUTID,VarID(OUTID,'ITY'), (/low_ind(myid+1),1/), (/nt_local(myid+1),1/),CLMC_pt1) - STATUS = NF_GET_VARA_REAL(OUTID,VarID(OUTID,'ITY'), (/low_ind(myid+1),2/), (/nt_local(myid+1),1/),CLMC_pt2) - STATUS = NF_GET_VARA_REAL(OUTID,VarID(OUTID,'ITY'), (/low_ind(myid+1),3/), (/nt_local(myid+1),1/),CLMC_st1) - STATUS = NF_GET_VARA_REAL(OUTID,VarID(OUTID,'ITY'), (/low_ind(myid+1),4/), (/nt_local(myid+1),1/),CLMC_st2) - STATUS = NF_GET_VARA_REAL(OUTID,VarID(OUTID,'FVG'), (/low_ind(myid+1),1/), (/nt_local(myid+1),1/),CLMC_pf1) - STATUS = NF_GET_VARA_REAL(OUTID,VarID(OUTID,'FVG'), (/low_ind(myid+1),2/), (/nt_local(myid+1),1/),CLMC_pf2) - STATUS = NF_GET_VARA_REAL(OUTID,VarID(OUTID,'FVG'), (/low_ind(myid+1),3/), (/nt_local(myid+1),1/),CLMC_sf1) - STATUS = NF_GET_VARA_REAL(OUTID,VarID(OUTID,'FVG'), (/low_ind(myid+1),4/), (/nt_local(myid+1),1/),CLMC_sf2) - - if (root_proc) then - STATUS = NF_OPEN (trim(InCNRestart),NF_NOWRITE,NCFID) - allocate (TILE_ID (1:ntiles_cn)) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'TILE_ID' ), (/1/), (/NTILES_CN/),TILE_ID) - - do n = 1,ntiles_cn - - K = NINT (TILE_ID (n)) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'ITY'), (/n,1/), (/1,4/),ityp_offl(K,:)) - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'FVG'), (/n,1/), (/1,4/),fveg_offl(K,:)) - - tid_offl (n) = n - - do nv = 1,nveg - if(ityp_offl(K,nv)<0 .or. ityp_offl(K,nv)>npft) stop 'ityp' - if(fveg_offl(K,nv)<0..or. fveg_offl(K,nv)>1.00001) stop 'fveg' - end do - - if((ityp_offl(K,3) == 0).and.(ityp_offl(K,4) == 0)) then - if(ityp_offl(K,1) /= 0) then - ityp_offl(K,3) = ityp_offl(K,1) - else - ityp_offl(K,3) = ityp_offl(K,2) - endif - endif - - if((ityp_offl(K,1) == 0).and.(ityp_offl(K,2) /= 0)) ityp_offl(K,1) = ityp_offl(K,2) - if((ityp_offl(K,2) == 0).and.(ityp_offl(K,1) /= 0)) ityp_offl(K,2) = ityp_offl(K,1) - if((ityp_offl(K,3) == 0).and.(ityp_offl(K,4) /= 0)) ityp_offl(K,3) = ityp_offl(K,4) - if((ityp_offl(K,4) == 0).and.(ityp_offl(K,3) /= 0)) ityp_offl(K,4) = ityp_offl(K,3) - - end do - - endif - - call MPI_BCAST(tid_offl ,size(tid_offl ),MPI_INTEGER,0,MPI_COMM_WORLD,mpierr) - call MPI_BCAST(ityp_offl,size(ityp_offl),MPI_REAL ,0,MPI_COMM_WORLD,mpierr) - call MPI_BCAST(fveg_offl,size(fveg_offl),MPI_REAL ,0,MPI_COMM_WORLD,mpierr) - - ! -------------------------------------------------------------------------------- - ! Here we create transfer index array to map offline restarts to output tile space - ! -------------------------------------------------------------------------------- - - call GetIds(lonc,latc,lonn,latt,id_loc, tid_offl, & - CLMC_pf1, CLMC_pf2, CLMC_sf1, CLMC_sf2, CLMC_pt1, CLMC_pt2,CLMC_st1,CLMC_st2, & - fveg_offl, ityp_offl) - - ! update id_glb in root - - if(root_proc) then - allocate (id_glb (ntiles, nveg)) - allocate (id_vec (ntiles)) - endif - - do nv = 1, nveg - call MPI_Barrier(MPI_COMM_WORLD, STATUS) - ! call MPI_GATHERV( & - ! id_loc (:,nv), nt_local(myid+1) , MPI_real, & - ! id_vec, nt_local,low_ind-1, MPI_real, & - ! 0, MPI_COMM_WORLD, mpierr ) - - do i = 1, numprocs - if((I == 1).and.(myid == 0)) then - id_vec(low_ind(i) : upp_ind(i)) = Id_loc(:,nv) - else if (I > 1) then - if(I-1 == myid) then - ! send to root - call MPI_ISend(id_loc(:,nv),nt_local(i),MPI_INTEGER,0,993,MPI_COMM_WORLD,req,mpierr) - call MPI_WAIT (req,MPI_STATUS_IGNORE,mpierr) - else if (myid == 0) then - ! root receives - call MPI_RECV(id_vec(low_ind(i) : upp_ind(i)),nt_local(i) , MPI_INTEGER, i-1,993,MPI_COMM_WORLD,MPI_STATUS_IGNORE,mpierr) - endif - endif - end do - - if(root_proc) id_glb (:,nv) = id_vec - - end do - - if(root_proc) then - - allocate (var_off_col (1: NTILES_CN, 1 : nzone,1 : var_col)) - allocate (var_off_pft (1: NTILES_CN, 1 : nzone,1 : nveg, 1 : var_pft)) - allocate (var_dum2 (1:ntiles_cn)) - i = 1 - do nv = 1,VAR_COL - do nz = 1,nzone - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'CNCOL'), (/1,i/), (/NTILES_CN,1 /),VAR_DUM2) - do k = 1, NTILES_CN - var_off_col(TILE_ID(K), nz,nv) = VAR_DUM2(K) - end do - i = i + 1 - end do - end do - - i = 1 - do iv = 1,VAR_PFT - do nv = 1,nveg - do nz = 1,nzone - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'CNPFT'), (/1,i/), (/NTILES_CN,1 /),VAR_DUM2) - do k = 1, NTILES_CN - var_off_pft(TILE_ID(K), nz,nv,iv) = VAR_DUM2(K) - end do - i = i + 1 - end do - end do - end do - - where(isnan(var_off_pft)) var_off_pft = 0. - where(var_off_pft /= var_off_pft) var_off_pft = 0. - - call write_regridded_carbon (NTILES, ntiles_cn, NCFID, OUTID, id_glb, & - DAYX, var_off_col, var_off_pft, ityp_offl, fveg_offl) - deallocate (var_off_col,var_off_pft) - endif - - call MPI_Barrier(MPI_COMM_WORLD, STATUS) - - END SUBROUTINE regrid_carbon_vars - -! --------------------------------------------------------------------------------------------------------- - - SUBROUTINE write_regridded_carbon (NTILES, ntiles_rst, NCFID, OUTID, id_glb, & - DAYX, var_off_col, var_off_pft, ityp_offl, fveg_offl) - - ! write out regridded carbon variables - implicit none - integer, intent (in) :: NTILES, ntiles_rst,NCFID, OUTID, id_glb (ntiles,nveg) - real, intent (in) :: DAYX (NTILES), var_off_col(NTILES_RST,NZONE,var_col), var_off_pft(NTILES_RST,NZONE, NVEG, var_pft) - real, intent (in), dimension(ntiles_rst,nveg) :: fveg_offl, ityp_offl - real, allocatable, dimension (:) :: CLMC_pf1, CLMC_pf2, CLMC_sf1, CLMC_sf2, & - CLMC_pt1, CLMC_pt2,CLMC_st1,CLMC_st2, var_dum - real, allocatable :: var_col_out (:,:,:), var_pft_out (:,:,:,:) - integer :: N, STATUS, nv, nx, offl_cell, ityp_new, i, j, nz, iv - real :: fveg_new - character(256) :: Iam = "write_regridded_carbon" - - - allocate (CLMC_pf1(NTILES)) - allocate (CLMC_pf2(NTILES)) - allocate (CLMC_sf1(NTILES)) - allocate (CLMC_sf2(NTILES)) - allocate (CLMC_pt1(NTILES)) - allocate (CLMC_pt2(NTILES)) - allocate (CLMC_st1(NTILES)) - allocate (CLMC_st2(NTILES)) - allocate (VAR_DUM (NTILES)) - - STATUS = NF_GET_VARA_REAL(OUTID,VarID(OUTID,'ITY'), (/1,1/), (/NTILES,1/),CLMC_pt1) ; VERIFY_(STATUS) - STATUS = NF_GET_VARA_REAL(OUTID,VarID(OUTID,'ITY'), (/1,2/), (/NTILES,1/),CLMC_pt2) ; VERIFY_(STATUS) - STATUS = NF_GET_VARA_REAL(OUTID,VarID(OUTID,'ITY'), (/1,3/), (/NTILES,1/),CLMC_st1) ; VERIFY_(STATUS) - STATUS = NF_GET_VARA_REAL(OUTID,VarID(OUTID,'ITY'), (/1,4/), (/NTILES,1/),CLMC_st2) ; VERIFY_(STATUS) - STATUS = NF_GET_VARA_REAL(OUTID,VarID(OUTID,'FVG'), (/1,1/), (/NTILES,1/),CLMC_pf1) ; VERIFY_(STATUS) - STATUS = NF_GET_VARA_REAL(OUTID,VarID(OUTID,'FVG'), (/1,2/), (/NTILES,1/),CLMC_pf2) ; VERIFY_(STATUS) - STATUS = NF_GET_VARA_REAL(OUTID,VarID(OUTID,'FVG'), (/1,3/), (/NTILES,1/),CLMC_sf1) ; VERIFY_(STATUS) - STATUS = NF_GET_VARA_REAL(OUTID,VarID(OUTID,'FVG'), (/1,4/), (/NTILES,1/),CLMC_sf2) ; VERIFY_(STATUS) - - allocate (var_col_out (1: NTILES, 1 : nzone,1 : var_col)) - allocate (var_pft_out (1: NTILES, 1 : nzone,1 : nveg, 1 : var_pft)) - - var_col_out = 0. - var_pft_out = NaN - - OUT_TILE : DO N = 1, NTILES - - ! if(mod (n,1000) == 0) print *, myid +1, n, Id_glb(n,:) - - NVLOOP2 : do nv = 1, nveg - - if(nv <= 2) then ! index for secondary PFT index if primary or primary if secondary - nx = nv + 2 - else - nx = nv - 2 - endif - - if (nv == 1) ityp_new = CLMC_pt1(n) - if (nv == 1) fveg_new = CLMC_pf1(n) - if (nv == 2) ityp_new = CLMC_pt2(n) - if (nv == 2) fveg_new = CLMC_pf2(n) - if (nv == 3) ityp_new = CLMC_st1(n) - if (nv == 3) fveg_new = CLMC_sf1(n) - if (nv == 4) ityp_new = CLMC_st2(n) - if (nv == 4) fveg_new = CLMC_sf2(n) - - if (fveg_new > fmin) then - - offl_cell = Id_glb(n,nv) - - if(ityp_new == ityp_offl (offl_cell,nv) .and. fveg_offl (offl_cell,nv)> fmin) then - iv = nv ! same type fraction (primary of secondary) - else if(ityp_new == ityp_offl (offl_cell,nx) .and. fveg_offl (offl_cell,nx)> fmin) then - iv = nx ! not same fraction - else if(iclass(ityp_new)==iclass(ityp_offl(offl_cell,nv)) .and. fveg_offl (offl_cell,nv)> fmin) then - iv = nv ! primary, other type (same class) - else if(fveg_offl (offl_cell,nx)> fmin) then - iv = nx ! secondary, other type (same class) - endif - - ! Get col and pft variables for the Id_glb(nv) grid cell from offline catchcn_internal_rst - ! ---------------------------------------------------------------------------------------- - - ! call NCDF_reshape_getOput (NCFID,Id_glb(n,nv),var_off_col,var_off_pft,.true.) - - var_pft_out (n,:,nv,:) = var_off_pft(Id_glb(n,nv), :,iv,:) - var_col_out (n,:,:) = var_col_out(n,:,:) + fveg_new * var_off_col(Id_glb(n,nv), :,:) ! gkw: column state simple weighted mean; ! could use "woody" fraction? - - ! Check whether var_pft_out is realistic - do nz = 1, nzone - do j = 1, VAR_PFT - if (isnan(var_pft_out (n, nz,nv,j))) print *,j,nv,nz,n,var_pft_out (n, nz,nv,j),fveg_new - !if(isnan(var_pft_out (n, nz,nv,69))) var_pft_out (n, nz,nv,69) = 1.e-6 - !if(isnan(var_pft_out (n, nz,nv,70))) var_pft_out (n, nz,nv,70) = 1.e-6 - !if(isnan(var_pft_out (n, nz,nv,73))) var_pft_out (n, nz,nv,73) = 1.e-6 - !if(isnan(var_pft_out (n, nz,nv,74))) var_pft_out (n, nz,nv,74) = 1.e-6 - end do - end do - endif - - end do NVLOOP2 - - ! reset carbon if negative < 10g - ! ------------------------ - - NZLOOP : do nz = 1, nzone - - if(var_col_out (n, nz,14) < 10.) then - - var_col_out(n, nz, 1) = max(var_col_out(n, nz, 1), 0.) - var_col_out(n, nz, 2) = max(var_col_out(n, nz, 2), 0.) - var_col_out(n, nz, 3) = max(var_col_out(n, nz, 3), 0.) - var_col_out(n, nz, 4) = max(var_col_out(n, nz, 4), 0.) - var_col_out(n, nz, 5) = max(var_col_out(n, nz, 5), 0.) - var_col_out(n, nz,10) = max(var_col_out(n, nz,10), 0.) - var_col_out(n, nz,11) = max(var_col_out(n, nz,11), 0.) - var_col_out(n, nz,12) = max(var_col_out(n, nz,12), 0.) - var_col_out(n, nz,13) = max(var_col_out(n, nz,13),10.) ! soil4c - var_col_out(n, nz,14) = max(var_col_out(n, nz,14), 0.) - var_col_out(n, nz,15) = max(var_col_out(n, nz,15), 0.) - var_col_out(n, nz,16) = max(var_col_out(n, nz,16), 0.) - var_col_out(n, nz,17) = max(var_col_out(n, nz,17), 0.) - var_col_out(n, nz,18) = max(var_col_out(n, nz,18), 0.) - var_col_out(n, nz,19) = max(var_col_out(n, nz,19), 0.) - var_col_out(n, nz,20) = max(var_col_out(n, nz,20), 0.) - var_col_out(n, nz,24) = max(var_col_out(n, nz,24), 0.) - var_col_out(n, nz,25) = max(var_col_out(n, nz,25), 0.) - var_col_out(n, nz,26) = max(var_col_out(n, nz,26), 0.) - var_col_out(n, nz,27) = max(var_col_out(n, nz,27), 0.) - var_col_out(n, nz,28) = max(var_col_out(n, nz,28), 1.) - var_col_out(n, nz,29) = max(var_col_out(n, nz,29), 0.) - - NVLOOP3 : do nv = 1,nveg - - if (nv == 1) ityp_new = CLMC_pt1(n) - if (nv == 1) fveg_new = CLMC_pf1(n) - if (nv == 2) ityp_new = CLMC_pt2(n) - if (nv == 2) fveg_new = CLMC_pf2(n) - if (nv == 3) ityp_new = CLMC_st1(n) - if (nv == 3) fveg_new = CLMC_sf1(n) - if (nv == 4) ityp_new = CLMC_st2(n) - if (nv == 4) fveg_new = CLMC_sf2(n) - - if(fveg_new > fmin) then - var_pft_out(n, nz,nv, 1) = max(var_pft_out(n, nz,nv, 1),0.) - var_pft_out(n, nz,nv, 2) = max(var_pft_out(n, nz,nv, 2),0.) - var_pft_out(n, nz,nv, 3) = max(var_pft_out(n, nz,nv, 3),0.) - var_pft_out(n, nz,nv, 4) = max(var_pft_out(n, nz,nv, 4),0.) - - if(ityp_new <= 12) then ! tree or shrub deadstemc - var_pft_out(n, nz,nv, 5) = max(var_pft_out(n, nz,nv, 5),0.1) - else - var_pft_out(n, nz,nv, 5) = max(var_pft_out(n, nz,nv, 5),0.0) - endif - - var_pft_out(n, nz,nv, 6) = max(var_pft_out(n, nz,nv, 6),0.) - var_pft_out(n, nz,nv, 7) = max(var_pft_out(n, nz,nv, 7),0.) - var_pft_out(n, nz,nv, 8) = max(var_pft_out(n, nz,nv, 8),0.) - var_pft_out(n, nz,nv, 9) = max(var_pft_out(n, nz,nv, 9),0.) - var_pft_out(n, nz,nv,10) = max(var_pft_out(n, nz,nv,10),0.) - var_pft_out(n, nz,nv,11) = max(var_pft_out(n, nz,nv,11),0.) - var_pft_out(n, nz,nv,12) = max(var_pft_out(n, nz,nv,12),0.) - - if(ityp_new <=2 .or. ityp_new ==4 .or. ityp_new ==5 .or. ityp_new == 9) then - var_pft_out(n, nz,nv,13) = max(var_pft_out(n, nz,nv,13),1.) ! leaf carbon display for evergreen - var_pft_out(n, nz,nv,14) = max(var_pft_out(n, nz,nv,14),0.) - else - var_pft_out(n, nz,nv,13) = max(var_pft_out(n, nz,nv,13),0.) - var_pft_out(n, nz,nv,14) = max(var_pft_out(n, nz,nv,14),1.) ! leaf carbon storage for deciduous - endif - - var_pft_out(n, nz,nv,15) = max(var_pft_out(n, nz,nv,15),0.) - var_pft_out(n, nz,nv,16) = max(var_pft_out(n, nz,nv,16),0.) - var_pft_out(n, nz,nv,17) = max(var_pft_out(n, nz,nv,17),0.) - var_pft_out(n, nz,nv,18) = max(var_pft_out(n, nz,nv,18),0.) - var_pft_out(n, nz,nv,19) = max(var_pft_out(n, nz,nv,19),0.) - var_pft_out(n, nz,nv,20) = max(var_pft_out(n, nz,nv,20),0.) - var_pft_out(n, nz,nv,21) = max(var_pft_out(n, nz,nv,21),0.) - var_pft_out(n, nz,nv,22) = max(var_pft_out(n, nz,nv,22),0.) - var_pft_out(n, nz,nv,23) = max(var_pft_out(n, nz,nv,23),0.) - var_pft_out(n, nz,nv,25) = max(var_pft_out(n, nz,nv,25),0.) - var_pft_out(n, nz,nv,26) = max(var_pft_out(n, nz,nv,26),0.) - var_pft_out(n, nz,nv,27) = max(var_pft_out(n, nz,nv,27),0.) - var_pft_out(n, nz,nv,41) = max(var_pft_out(n, nz,nv,41),0.) - var_pft_out(n, nz,nv,42) = max(var_pft_out(n, nz,nv,42),0.) - var_pft_out(n, nz,nv,44) = max(var_pft_out(n, nz,nv,44),0.) - var_pft_out(n, nz,nv,45) = max(var_pft_out(n, nz,nv,45),0.) - var_pft_out(n, nz,nv,46) = max(var_pft_out(n, nz,nv,46),0.) - var_pft_out(n, nz,nv,47) = max(var_pft_out(n, nz,nv,47),0.) - var_pft_out(n, nz,nv,48) = max(var_pft_out(n, nz,nv,48),0.) - var_pft_out(n, nz,nv,49) = max(var_pft_out(n, nz,nv,49),0.) - var_pft_out(n, nz,nv,50) = max(var_pft_out(n, nz,nv,50),0.) - var_pft_out(n, nz,nv,51) = max(var_pft_out(n, nz,nv, 5)/500.,0.) - var_pft_out(n, nz,nv,52) = max(var_pft_out(n, nz,nv,52),0.) - var_pft_out(n, nz,nv,53) = max(var_pft_out(n, nz,nv,53),0.) - var_pft_out(n, nz,nv,54) = max(var_pft_out(n, nz,nv,54),0.) - var_pft_out(n, nz,nv,55) = max(var_pft_out(n, nz,nv,55),0.) - var_pft_out(n, nz,nv,56) = max(var_pft_out(n, nz,nv,56),0.) - var_pft_out(n, nz,nv,57) = max(var_pft_out(n, nz,nv,13)/25.,0.) - var_pft_out(n, nz,nv,58) = max(var_pft_out(n, nz,nv,14)/25.,0.) - var_pft_out(n, nz,nv,59) = max(var_pft_out(n, nz,nv,59),0.) - var_pft_out(n, nz,nv,60) = max(var_pft_out(n, nz,nv,60),0.) - var_pft_out(n, nz,nv,61) = max(var_pft_out(n, nz,nv,61),0.) - var_pft_out(n, nz,nv,62) = max(var_pft_out(n, nz,nv,62),0.) - var_pft_out(n, nz,nv,63) = max(var_pft_out(n, nz,nv,63),0.) - var_pft_out(n, nz,nv,64) = max(var_pft_out(n, nz,nv,64),0.) - var_pft_out(n, nz,nv,65) = max(var_pft_out(n, nz,nv,65),0.) - var_pft_out(n, nz,nv,66) = max(var_pft_out(n, nz,nv,66),0.) - var_pft_out(n, nz,nv,67) = max(var_pft_out(n, nz,nv,67),0.) - var_pft_out(n, nz,nv,68) = max(var_pft_out(n, nz,nv,68),0.) - var_pft_out(n, nz,nv,69) = max(var_pft_out(n, nz,nv,69),0.) - var_pft_out(n, nz,nv,70) = max(var_pft_out(n, nz,nv,70),0.) - var_pft_out(n, nz,nv,73) = max(var_pft_out(n, nz,nv,73),0.) - var_pft_out(n, nz,nv,74) = max(var_pft_out(n, nz,nv,74),0.) - if(clm45) var_pft_out(n, nz,nv,75) = max(var_pft_out(n, nz,nv,75),0.) - endif - end do NVLOOP3 ! end veg loop - endif ! end carbon check - end do NZLOOP ! end zone loop - - ! Update dayx variable var_pft_out (:,:,28) - - do j = 28, 28 ! 1,VAR_PFT var_pft_out (:,:,:,28) - do nv = 1,nveg - do nz = 1,nzone - var_pft_out (n, nz,nv,j) = dayx(n) - end do - end do - end do - - ! call NCDF_reshape_getOput (OutID,N,var_col_out,var_pft_out,.false.) - - ! column vars clm40 clm45 - ! ----------------- --------------------- - ! 1 clm3%g%l%c%ccs%col_ctrunc ! 1 ccs%col_ctrunc_vr (:,1) - ! 2 clm3%g%l%c%ccs%cwdc ! 2 ccs%decomp_cpools_vr(:,1,4) ! cwdc - ! 3 clm3%g%l%c%ccs%litr1c ! 3 ccs%decomp_cpools_vr(:,1,1) ! litr1c - ! 4 clm3%g%l%c%ccs%litr2c ! 4 ccs%decomp_cpools_vr(:,1,2) ! litr2c - ! 5 clm3%g%l%c%ccs%litr3c ! 5 ccs%decomp_cpools_vr(:,1,3) ! litr3c - ! 6 clm3%g%l%c%ccs%pcs_a%totvegc ! 6 ccs%totvegc_col - ! 7 clm3%g%l%c%ccs%prod100c ! 7 ccs%prod100c - ! 8 clm3%g%l%c%ccs%prod10c ! 8 ccs%prod10c - ! 9 clm3%g%l%c%ccs%seedc ! 9 ccs%seedc - ! 10 clm3%g%l%c%ccs%soil1c ! 10 ccs%decomp_cpools_vr(:,1,5) ! soil1c - ! 11 clm3%g%l%c%ccs%soil2c ! 11 ccs%decomp_cpools_vr(:,1,6) ! soil2c - ! 12 clm3%g%l%c%ccs%soil3c ! 12 ccs%decomp_cpools_vr(:,1,7) ! soil3c - ! 13 clm3%g%l%c%ccs%soil4c ! 13 ccs%decomp_cpools_vr(:,1,8) ! soil4c - ! 14 clm3%g%l%c%ccs%totcolc ! 14 ccs%totcolc - ! 15 clm3%g%l%c%ccs%totlitc ! 15 ccs%totlitc - ! 16 clm3%g%l%c%cns%col_ntrunc ! 16 cns%col_ntrunc_vr (:,1) - ! 17 clm3%g%l%c%cns%cwdn ! 17 cns%decomp_npools_vr(:,1,4) ! cwdn - ! 18 clm3%g%l%c%cns%litr1n ! 18 cns%decomp_npools_vr(:,1,1) ! litr1n - ! 19 clm3%g%l%c%cns%litr2n ! 19 cns%decomp_npools_vr(:,1,2) ! litr2n - ! 20 clm3%g%l%c%cns%litr3n ! 20 cns%decomp_npools_vr(:,1,3) ! litr3n - ! 21 clm3%g%l%c%cns%prod100n ! 21 cns%prod100n - ! 22 clm3%g%l%c%cns%prod10n ! 22 cns%prod10n - ! 23 clm3%g%l%c%cns%seedn ! 23 cns%seedn - ! 24 clm3%g%l%c%cns%sminn ! 24 cns%sminn_vr (:,1) - ! 25 clm3%g%l%c%cns%soil1n ! 25 cns%decomp_npools_vr(:,1,5) ! soil1n - ! 26 clm3%g%l%c%cns%soil2n ! 26 cns%decomp_npools_vr(:,1,6) ! soil2n - ! 27 clm3%g%l%c%cns%soil3n ! 27 cns%decomp_npools_vr(:,1,7) ! soil3n - ! 28 clm3%g%l%c%cns%soil4n ! 28 cns%decomp_npools_vr(:,1,8) ! soil4n - ! 29 clm3%g%l%c%cns%totcoln ! 29 cns%totcoln - ! 30 clm3%g%l%c%cps%ann_farea_burned ! 30 cps%fpg - ! 31 clm3%g%l%c%cps%annsum_counter ! 31 cps%annsum_counter - ! 32 clm3%g%l%c%cps%cannavg_t2m ! 32 cps%cannavg_t2m - ! 33 clm3%g%l%c%cps%cannsum_npp ! 33 cps%cannsum_npp - ! 34 clm3%g%l%c%cps%farea_burned ! 34 cps%farea_burned - ! 35 clm3%g%l%c%cps%fire_prob ! 35 cps%fpi_vr (:,1) - ! 36 clm3%g%l%c%cps%fireseasonl ! OLD ! 30 cps%altmax - ! 37 clm3%g%l%c%cps%fpg ! OLD ! 31 cps%annsum_counter - ! 38 clm3%g%l%c%cps%fpi ! OLD ! 32 cps%cannavg_t2m - ! 39 clm3%g%l%c%cps%me ! OLD ! 33 cps%cannsum_npp - ! 40 clm3%g%l%c%cps%mean_fire_prob ! OLD ! 34 cps%farea_burned - ! OLD ! 35 cps%altmax_lastyear - ! OLD ! 36 cps%altmax_indx - ! OLD ! 37 cps%fpg - ! OLD ! 38 cps%fpi_vr (:,1) - ! OLD ! 39 cps%altmax_lastyear_indx - - ! PFT vars CLM40 CLM45 - ! -------------- ----- - ! 1 clm3%g%l%c%p%pcs%cpool ! 1 pcs%cpool - ! 2 clm3%g%l%c%p%pcs%deadcrootc ! 2 pcs%deadcrootc - ! 3 clm3%g%l%c%p%pcs%deadcrootc_storage ! 3 pcs%deadcrootc_storage - ! 4 clm3%g%l%c%p%pcs%deadcrootc_xfer ! 4 pcs%deadcrootc_xfer - ! 5 clm3%g%l%c%p%pcs%deadstemc ! 5 pcs%deadstemc - ! 6 clm3%g%l%c%p%pcs%deadstemc_storage ! 6 pcs%deadstemc_storage - ! 7 clm3%g%l%c%p%pcs%deadstemc_xfer ! 7 pcs%deadstemc_xfer - ! 8 clm3%g%l%c%p%pcs%frootc ! 8 pcs%frootc - ! 9 clm3%g%l%c%p%pcs%frootc_storage ! 9 pcs%frootc_storage - ! 10 clm3%g%l%c%p%pcs%frootc_xfer ! 10 pcs%frootc_xfer - ! 11 clm3%g%l%c%p%pcs%gresp_storage ! 11 pcs%gresp_storage - ! 12 clm3%g%l%c%p%pcs%gresp_xfer ! 12 pcs%gresp_xfer - ! 13 clm3%g%l%c%p%pcs%leafc ! 13 pcs%leafc - ! 14 clm3%g%l%c%p%pcs%leafc_storage ! 14 pcs%leafc_storage - ! 15 clm3%g%l%c%p%pcs%leafc_xfer ! 15 pcs%leafc_xfer - ! 16 clm3%g%l%c%p%pcs%livecrootc ! 16 pcs%livecrootc - ! 17 clm3%g%l%c%p%pcs%livecrootc_storage ! 17 pcs%livecrootc_storage - ! 18 clm3%g%l%c%p%pcs%livecrootc_xfer ! 18 pcs%livecrootc_xfer - ! 19 clm3%g%l%c%p%pcs%livestemc ! 19 pcs%livestemc - ! 20 clm3%g%l%c%p%pcs%livestemc_storage ! 20 pcs%livestemc_storage - ! 21 clm3%g%l%c%p%pcs%livestemc_xfer ! 21 pcs%livestemc_xfer - ! 22 clm3%g%l%c%p%pcs%pft_ctrunc ! 22 pcs%pft_ctrunc - ! 23 clm3%g%l%c%p%pcs%xsmrpool ! 23 pcs%xsmrpool - ! 24 clm3%g%l%c%p%pepv%annavg_t2m ! 24 pepv%annavg_t2m - ! 25 clm3%g%l%c%p%pepv%annmax_retransn ! 25 pepv%annmax_retransn - ! 26 clm3%g%l%c%p%pepv%annsum_npp ! 26 pepv%annsum_npp - ! 27 clm3%g%l%c%p%pepv%annsum_potential_gpp ! 27 pepv%annsum_potential_gpp - ! 28 clm3%g%l%c%p%pepv%dayl ! 28 pepv%dayl - ! 29 clm3%g%l%c%p%pepv%days_active ! 29 pepv%days_active - ! 30 clm3%g%l%c%p%pepv%dormant_flag ! 30 pepv%dormant_flag - ! 31 clm3%g%l%c%p%pepv%offset_counter ! 31 pepv%offset_counter - ! 32 clm3%g%l%c%p%pepv%offset_fdd ! 32 pepv%offset_fdd - ! 33 clm3%g%l%c%p%pepv%offset_flag ! 33 pepv%offset_flag - ! 34 clm3%g%l%c%p%pepv%offset_swi ! 34 pepv%offset_swi - ! 35 clm3%g%l%c%p%pepv%onset_counter ! 35 pepv%onset_counter - ! 36 clm3%g%l%c%p%pepv%onset_fdd ! 36 pepv%onset_fdd - ! 37 clm3%g%l%c%p%pepv%onset_flag ! 37 pepv%onset_flag - ! 38 clm3%g%l%c%p%pepv%onset_gdd ! 38 pepv%onset_gdd - ! 39 clm3%g%l%c%p%pepv%onset_gddflag ! 39 pepv%onset_gddflag - ! 40 clm3%g%l%c%p%pepv%onset_swi ! 40 pepv%onset_swi - ! 41 clm3%g%l%c%p%pepv%prev_frootc_to_litter ! 41 pepv%prev_frootc_to_litter - ! 42 clm3%g%l%c%p%pepv%prev_leafc_to_litter ! 42 pepv%prev_leafc_to_litter - ! 43 clm3%g%l%c%p%pepv%tempavg_t2m ! 43 pepv%tempavg_t2m - ! 44 clm3%g%l%c%p%pepv%tempmax_retransn ! 44 pepv%tempmax_retransn - ! 45 clm3%g%l%c%p%pepv%tempsum_npp ! 45 pepv%tempsum_npp - ! 46 clm3%g%l%c%p%pepv%tempsum_potential_gpp ! 46 pepv%tempsum_potential_gpp - ! 47 clm3%g%l%c%p%pepv%xsmrpool_recover ! 47 pepv%xsmrpool_recover - ! 48 clm3%g%l%c%p%pns%deadcrootn ! 48 pns%deadcrootn - ! 49 clm3%g%l%c%p%pns%deadcrootn_storage ! 49 pns%deadcrootn_storage - ! 50 clm3%g%l%c%p%pns%deadcrootn_xfer ! 50 pns%deadcrootn_xfer - ! 51 clm3%g%l%c%p%pns%deadstemn ! 51 pns%deadstemn - ! 52 clm3%g%l%c%p%pns%deadstemn_storage ! 52 pns%deadstemn_storage - ! 53 clm3%g%l%c%p%pns%deadstemn_xfer ! 53 pns%deadstemn_xfer - ! 54 clm3%g%l%c%p%pns%frootn ! 54 pns%frootn - ! 55 clm3%g%l%c%p%pns%frootn_storage ! 55 pns%frootn_storage - ! 56 clm3%g%l%c%p%pns%frootn_xfer ! 56 pns%frootn_xfer - ! 57 clm3%g%l%c%p%pns%leafn ! 57 pns%leafn - ! 58 clm3%g%l%c%p%pns%leafn_storage ! 58 pns%leafn_storage - ! 59 clm3%g%l%c%p%pns%leafn_xfer ! 59 pns%leafn_xfer - ! 60 clm3%g%l%c%p%pns%livecrootn ! 60 pns%livecrootn - ! 61 clm3%g%l%c%p%pns%livecrootn_storage ! 61 pns%livecrootn_storage - ! 62 clm3%g%l%c%p%pns%livecrootn_xfer ! 62 pns%livecrootn_xfer - ! 63 clm3%g%l%c%p%pns%livestemn ! 63 pns%livestemn - ! 64 clm3%g%l%c%p%pns%livestemn_storage ! 64 pns%livestemn_storage - ! 65 clm3%g%l%c%p%pns%livestemn_xfer ! 65 pns%livestemn_xfer - ! 66 clm3%g%l%c%p%pns%npool ! 66 pns%npool - ! 67 clm3%g%l%c%p%pns%pft_ntrunc ! 67 pns%pft_ntrunc - ! 68 clm3%g%l%c%p%pns%retransn ! 68 pns%retransn - ! 69 clm3%g%l%c%p%pps%elai ! 69 pps%elai - ! 70 clm3%g%l%c%p%pps%esai ! 70 pps%esai - ! 71 clm3%g%l%c%p%pps%hbot ! 71 pps%hbot - ! 72 clm3%g%l%c%p%pps%htop ! 72 pps%htop - ! 73 clm3%g%l%c%p%pps%tlai ! 73 pps%tlai - ! 74 clm3%g%l%c%p%pps%tsai ! 74 pps%tsai - ! 75 pepv%plant_ndemand - ! OLD ! 75 pps%gddplant - ! OLD ! 76 pps%gddtsoi - ! OLD ! 77 pps%peaklai - ! OLD ! 78 pps%idop - ! OLD ! 79 pps%aleaf - ! OLD ! 80 pps%aleafi - ! OLD ! 81 pps%astem - ! OLD ! 82 pps%astemi - ! OLD ! 83 pps%htmx - ! OLD ! 84 pps%hdidx - ! OLD ! 85 pps%vf - ! OLD ! 86 pps%cumvd - ! OLD ! 87 pps%croplive - ! OLD ! 88 pps%cropplant - ! OLD ! 89 pps%harvdate - ! OLD ! 90 pps%gdd1020 - ! OLD ! 91 pps%gdd820 - ! OLD ! 92 pps%gdd020 - ! OLD ! 93 pps%gddmaturity - ! OLD ! 94 pps%huileaf - ! OLD ! 95 pps%huigrain - ! OLD ! 96 pcs%grainc - ! OLD ! 97 pcs%grainc_storage - ! OLD ! 98 pcs%grainc_xfer - ! OLD ! 99 pns%grainn - ! OLD !100 pns%grainn_storage - ! OLD !101 pns%grainn_xfer - ! OLD !102 pepv%fert_counter - ! OLD !103 pnf%fert - ! OLD !104 pepv%grain_flag - - end do OUT_TILE - - i = 1 - do nv = 1,VAR_COL - do nz = 1,nzone - STATUS = NF_PUT_VARA_REAL(OutID,VarID(OutID,'CNCOL'), (/1,i/), (/NTILES,1 /),var_col_out(:, nz,nv)) ; VERIFY_(STATUS) - i = i + 1 - end do - end do - - i = 1 - if(clm45) then - do iv = 1,VAR_PFT - do nv = 1,nveg - do nz = 1,nzone - if(iv <= 74) then - STATUS = NF_PUT_VARA_REAL(OutID,VarID(OutID,'CNPFT'), (/1,i/), (/NTILES,1 /),var_pft_out(:, nz,nv,iv)) ; VERIFY_(STATUS) - else - if((iv == 78) .OR. (iv == 89)) then ! idop and harvdate - var_dum = 999 - STATUS = NF_PUT_VARA_REAL(OutID,VarID(OutID,'CNPFT'), (/1,i/), (/NTILES,1 /),var_dum) ; VERIFY_(STATUS) - else - var_dum = 0. - STATUS = NF_PUT_VARA_REAL(OutID,VarID(OutID,'CNPFT'), (/1,i/), (/NTILES,1 /),var_dum) ; VERIFY_(STATUS) - endif - endif - i = i + 1 - end do - end do - end do - else - do iv = 1,VAR_PFT - do nv = 1,nveg - do nz = 1,nzone - STATUS = NF_PUT_VARA_REAL(OutID,VarID(OutID,'CNPFT'), (/1,i/), (/NTILES,1 /),var_pft_out(:, nz,nv,iv)) ; VERIFY_(STATUS) - i = i + 1 - end do - end do - end do - endif - - VAR_DUM = 0. - - do nz = 1,nzone - STATUS = NF_PUT_VARA_REAL(OutID,VarID(OUTID,'TGWM'), (/1,nz/), (/NTILES,1 /),VAR_DUM(:)) ; VERIFY_(STATUS) - STATUS = NF_PUT_VARA_REAL(OutID,VarID(OUTID,'RZMM'), (/1,nz/), (/NTILES,1 /),VAR_DUM(:)) ; VERIFY_(STATUS) - if(clm45) STATUS = NF_PUT_VARA_REAL(OutID,VarID(OUTID,'SFMM'), (/1,nz/), (/NTILES,1 /),VAR_DUM(:)) ; VERIFY_(STATUS) - end do - - STATUS = NF_PUT_VARA_REAL(OutID,VarID(OUTID,'BFLOWM' ), (/1/), (/NTILES/),VAR_DUM(:)) ; VERIFY_(STATUS) - STATUS = NF_PUT_VARA_REAL(OutID,VarID(OUTID,'TOTWATM'), (/1/), (/NTILES/),VAR_DUM(:)) ; VERIFY_(STATUS) - STATUS = NF_PUT_VARA_REAL(OutID,VarID(OUTID,'TAIRM' ), (/1/), (/NTILES/),VAR_DUM(:)) ; VERIFY_(STATUS) - STATUS = NF_PUT_VARA_REAL(OutID,VarID(OUTID,'TPM' ), (/1/), (/NTILES/),VAR_DUM(:)) ; VERIFY_(STATUS) - STATUS = NF_PUT_VARA_REAL(OutID,VarID(OUTID,'CNSUM' ), (/1/), (/NTILES/),VAR_DUM(:)) ; VERIFY_(STATUS) - STATUS = NF_PUT_VARA_REAL(OutID,VarID(OUTID,'SNDZM' ), (/1/), (/NTILES/),VAR_DUM(:)) ; VERIFY_(STATUS) - STATUS = NF_PUT_VARA_REAL(OutID,VarID(OUTID,'ASNOWM' ), (/1/), (/NTILES/),VAR_DUM(:)) ; VERIFY_(STATUS) - - if(clm45) then - STATUS = NF_PUT_VARA_REAL(OutID,VarID(OUTID,'AR1M' ), (/1/), (/NTILES/),VAR_DUM(:)) ; VERIFY_(STATUS) - STATUS = NF_PUT_VARA_REAL(OutID,VarID(OUTID,'RAINFM' ), (/1/), (/NTILES/),VAR_DUM(:)) ; VERIFY_(STATUS) - STATUS = NF_PUT_VARA_REAL(OutID,VarID(OUTID,'RHM' ), (/1/), (/NTILES/),VAR_DUM(:)) ; VERIFY_(STATUS) - STATUS = NF_PUT_VARA_REAL(OutID,VarID(OUTID,'RUNSRFM' ), (/1/), (/NTILES/),VAR_DUM(:)) ; VERIFY_(STATUS) - STATUS = NF_PUT_VARA_REAL(OutID,VarID(OUTID,'SNOWFM' ), (/1/), (/NTILES/),VAR_DUM(:)) ; VERIFY_(STATUS) - STATUS = NF_PUT_VARA_REAL(OutID,VarID(OUTID,'WINDM' ), (/1/), (/NTILES/),VAR_DUM(:)) ; VERIFY_(STATUS) - STATUS = NF_PUT_VARA_REAL(OutID,VarID(OUTID,'TPREC10D'), (/1/), (/NTILES/),VAR_DUM(:)) ; VERIFY_(STATUS) - STATUS = NF_PUT_VARA_REAL(OutID,VarID(OUTID,'TPREC60D'), (/1/), (/NTILES/),VAR_DUM(:)) ; VERIFY_(STATUS) - STATUS = NF_PUT_VARA_REAL(OutID,VarID(OUTID,'T2M10D' ), (/1/), (/NTILES/),VAR_DUM(:)) ; VERIFY_(STATUS) - else - STATUS = NF_PUT_VARA_REAL(OutID,VarID(OUTID,'SFMCM'), (/1/), (/NTILES/),VAR_DUM(:)) ; VERIFY_(STATUS) - endif - - do nv = 1,nzone - do nz = 1,nveg - STATUS = NF_PUT_VARA_REAL(OutID,VarID(OUTID,'PSNSUNM'), (/1,nz,nv/), (/NTILES,1,1/),VAR_DUM(:)) ; VERIFY_(STATUS) - STATUS = NF_PUT_VARA_REAL(OutID,VarID(OUTID,'PSNSHAM'), (/1,nz,nv/), (/NTILES,1,1/),VAR_DUM(:)) ; VERIFY_(STATUS) - end do - end do - - VAR_DUM = 0.1 - do i = 1,4 - STATUS = NF_PUT_VARA_REAL(OutID,VarID(OUTID,'WW'), (/1,i/), (/NTILES,1 /),VAR_DUM(:)) - end do - - VAR_DUM = 0.25 - do i = 1,4 - STATUS = NF_PUT_VARA_REAL(OutID,VarID(OUTID,'FR'), (/1,i/), (/NTILES,1 /),VAR_DUM(:)) - end do - - VAR_DUM = 0.001 - do i = 1,4 - STATUS = NF_PUT_VARA_REAL(OutID,VarID(OUTID,'CH'), (/1,i/), (/NTILES,1 /),VAR_DUM(:)) - STATUS = NF_PUT_VARA_REAL(OutID,VarID(OUTID,'CM'), (/1,i/), (/NTILES,1 /),VAR_DUM(:)) - STATUS = NF_PUT_VARA_REAL(OutID,VarID(OUTID,'CQ'), (/1,i/), (/NTILES,1 /),VAR_DUM(:)) - end do - - STATUS = NF_CLOSE (NCFID) - - deallocate (var_col_out,var_pft_out) - deallocate (CLMC_pf1, CLMC_pf2, CLMC_sf1, CLMC_sf2) - deallocate (CLMC_pt1, CLMC_pt2, CLMC_st1, CLMC_st2) - - END SUBROUTINE write_regridded_carbon - - ! ***************************************************************************** - - SUBROUTINE put_land_vars (NTILES, ntiles_rst, id_glb, ld_reorder, model, rst_file) - - implicit none - character(*), intent (in) :: model - integer, intent (in) :: NTILES, ntiles_rst - integer, intent (in) :: id_glb(NTILES), ld_reorder (ntiles_rst) - integer :: k, rc - real , dimension (:), allocatable :: var_get, var_put - type(Netcdf4_FileFormatter):: OutFmt, InFmt - type(FileMetadata) :: meta_data - integer :: STATUS, NCFID, OUTID - character(*), intent (in), optional :: rst_file - character(256) :: Iam = "put_land_vars" - - allocate (var_get (NTILES_RST)) - allocate (var_put (NTILES)) - - ! create output catchcn_internal_rst - if(index(model,'catchcn') /=0) then - if (clm45) then - call InFmt%open('/discover/nobackup/projects/gmao/ssd/land/l_data/LandRestarts_for_Regridding/CatchCN/catchcn_internal_clm45',PFIO_READ, __RC__) - else - call InFmt%open(trim(InCNRestart ), pFIO_READ, __RC__) - endif - endif - if(trim(model) == 'catch' ) then - call InFmt%open(trim(InCatRestart), pFIO_READ, __RC__) - endif - meta_data = InFmt%read(__RC__) - call InFmt%close(__RC__) - - call meta_data%modify_dimension('tile', ntiles, __RC__) - - OutFileName = "InData/"//trim(model)//"_internal_rst" - - call OutFmt%create(trim(OutFileName),__RC__) - call OutFmt%write(meta_data,__RC__) - - if (present(rst_file)) then - STATUS = NF_OPEN (trim(rst_file ),NF_NOWRITE,NCFID) ; VERIFY_(STATUS) - else - if(index(model, 'catchcn') /=0 ) then - STATUS = NF_OPEN (trim(InCNRestart ),NF_NOWRITE,NCFID) ; VERIFY_(STATUS) - endif - if(trim(model) == 'catch') then - STATUS = NF_OPEN (trim(InCatRestart),NF_NOWRITE,NCFID) ; VERIFY_(STATUS) - endif - endif - - ! Read catparam - ! ------------- - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'POROS' ), (/1/), (/NTILES_RST/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'POROS',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'COND' ), (/1/), (/NTILES_RST/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'COND',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'PSIS' ), (/1/), (/NTILES_RST/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'PSIS',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'BEE' ), (/1/), (/NTILES_RST/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'BEE',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'WPWET' ), (/1/), (/NTILES_RST/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'WPWET',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'GNU' ), (/1/), (/NTILES_RST/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'GNU',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'VGWMAX' ), (/1/), (/NTILES_RST/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'VGWMAX',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'BF1' ), (/1/), (/NTILES_RST/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'BF1',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'BF2' ), (/1/), (/NTILES_RST/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'BF2',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'BF3' ), (/1/), (/NTILES_RST/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'BF3',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'CDCR1' ), (/1/), (/NTILES_RST/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'CDCR1',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'CDCR2' ), (/1/), (/NTILES_RST/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'CDCR2',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'ARS1' ), (/1/), (/NTILES_RST/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'ARS1',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'ARS2' ), (/1/), (/NTILES_RST/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'ARS2',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'ARS3' ), (/1/), (/NTILES_RST/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'ARS3',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'ARA1' ), (/1/), (/NTILES_RST/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'ARA1',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'ARA2' ), (/1/), (/NTILES_RST/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'ARA2',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'ARA3' ), (/1/), (/NTILES_RST/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'ARA3',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'ARA4' ), (/1/), (/NTILES_RST/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'ARA4',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'ARW1' ), (/1/), (/NTILES_RST/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'ARW1',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'ARW2' ), (/1/), (/NTILES_RST/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'ARW2',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'ARW3' ), (/1/), (/NTILES_RST/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'ARW3',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'ARW4' ), (/1/), (/NTILES_RST/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'ARW4',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'TSA1' ), (/1/), (/NTILES_RST/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'TSA1',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'TSA2' ), (/1/), (/NTILES_RST/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'TSA2',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'TSB1' ), (/1/), (/NTILES_RST/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'TSB1',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'TSB2' ), (/1/), (/NTILES_RST/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'TSB2',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'ATAU' ), (/1/), (/NTILES_RST/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'ATAU',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'BTAU' ), (/1/), (/NTILES_RST/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'BTAU',var_put) - - if(index(model,'catchcn') /=0) then - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'ITY' ), (/1,1/), (/NTILES_RST,1/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'ITY',var_put, offset1=1) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'ITY' ), (/1,2/), (/NTILES_RST,1/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'ITY',var_put, offset1=2) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'ITY' ), (/1,3/), (/NTILES_RST,1/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'ITY',var_put, offset1=3) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'ITY' ), (/1,4/), (/NTILES_RST,1/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'ITY',var_put, offset1=4) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'FVG' ), (/1,1/), (/NTILES_RST,1/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'FVG',var_put, offset1=1) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'FVG' ), (/1,2/), (/NTILES_RST,1/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'FVG',var_put, offset1=2) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'FVG' ), (/1,3/), (/NTILES_RST,1/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'FVG',var_put, offset1=3) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'FVG' ), (/1,4/), (/NTILES_RST,1/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'FVG',var_put, offset1=4) - - ! read restart and regrid - ! ----------------------- - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'TG' ), (/1,1/), (/NTILES_RST,1/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'TG',var_put, offset1=1) ! if you see offset1=1 it is a 2-D var - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'TG' ), (/1,2/), (/NTILES_RST,1/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'TG',var_put, offset1=2) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'TG' ), (/1,3/), (/NTILES_RST,1/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'TG',var_put, offset1=3) - - endif - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'TC' ), (/1,1/), (/NTILES_RST,1/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'TC',var_put, offset1=1) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'TC' ), (/1,2/), (/NTILES_RST,1/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'TC',var_put, offset1=2) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'TC' ), (/1,3/), (/NTILES_RST,1/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'TC',var_put, offset1=3) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'QC' ), (/1,1/), (/NTILES_RST,1/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'QC',var_put, offset1=1) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'QC' ), (/1,2/), (/NTILES_RST,1/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'QC',var_put, offset1=2) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'QC' ), (/1,3/), (/NTILES_RST,1/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'QC',var_put, offset1=3) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'CAPAC' ), (/1/), (/NTILES_RST/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'CAPAC',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'CATDEF' ), (/1/), (/NTILES_RST/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'CATDEF',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'RZEXC' ), (/1/), (/NTILES_RST/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'RZEXC',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'SRFEXC' ), (/1/), (/NTILES_RST/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'SRFEXC',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'GHTCNT1' ), (/1/), (/NTILES_RST/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'GHTCNT1',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'GHTCNT2' ), (/1/), (/NTILES_RST/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'GHTCNT2',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'GHTCNT3' ), (/1/), (/NTILES_RST/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'GHTCNT3',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'GHTCNT4' ), (/1/), (/NTILES_RST/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'GHTCNT4',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'GHTCNT5' ), (/1/), (/NTILES_RST/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'GHTCNT5',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'GHTCNT6' ), (/1/), (/NTILES_RST/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'GHTCNT6',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'WESNN1' ), (/1/), (/NTILES_RST/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'WESNN1',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'WESNN2' ), (/1/), (/NTILES_RST/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'WESNN2',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'WESNN3' ), (/1/), (/NTILES_RST/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'WESNN3',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'HTSNNN1' ), (/1/), (/NTILES_RST/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'HTSNNN1',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'HTSNNN2' ), (/1/), (/NTILES_RST/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'HTSNNN2',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'HTSNNN3' ), (/1/), (/NTILES_RST/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'HTSNNN3',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'SNDZN1' ), (/1/), (/NTILES_RST/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'SNDZN1',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'SNDZN2' ), (/1/), (/NTILES_RST/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'SNDZN2',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'SNDZN3' ), (/1/), (/NTILES_RST/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'SNDZN3',var_put) - - ! CH CM CQ FR WW - ! WW - VAR_PUT = 0.1 - do k = 1,4 - call MAPL_VarWrite(OutFmt,'WW',VAR_PUT ,offset1=k) - end do - ! FR - VAR_PUT = 0.25 - do k = 1,4 - call MAPL_VarWrite(OutFmt,'FR',VAR_PUT ,offset1=k) - end do - ! CH CM CQ - VAR_PUT = 0.001 - do k = 1,4 - call MAPL_VarWrite(OutFmt,'CH',VAR_PUT ,offset1=k) - call MAPL_VarWrite(OutFmt,'CM',VAR_PUT ,offset1=k) - call MAPL_VarWrite(OutFmt,'CQ',VAR_PUT ,offset1=k) - end do - - call OutFmt%close(__RC__) - STATUS = NF_CLOSE ( NCFID) - - deallocate (var_get, var_put) - CALL EXECUTE_COMMAND_LINE('/bin/cp InData/'//trim(model)//'_internal_rst OutData/'//trim(model)//'_internal_rst', .TRUE.) - - END SUBROUTINE put_land_vars - - ! ***************************************************************************** - - subroutine init_MPI() - - ! initialize MPI - - call MPI_INIT(mpierr) - - call MPI_COMM_RANK( MPI_COMM_WORLD, myid, mpierr ) - call MPI_COMM_SIZE( MPI_COMM_WORLD, numprocs, mpierr ) - - if (myid .ne. 0) root_proc = .false. - -! call init_MPI_types() - - write (*,*) "MPI process ", myid, " of ", numprocs, " is alive" - write (*,*) "MPI process ", myid, ": root_proc=", root_proc - - end subroutine init_MPI - - ! ----------------------------------------------------------------------- - - SUBROUTINE HANDLE_ERR(STATUS, Line) - - INTEGER, INTENT (IN) :: STATUS - CHARACTER(*), INTENT (IN) :: Line - - IF (STATUS .NE. NF_NOERR) THEN - PRINT *, trim(Line),': ',NF_STRERROR(STATUS) - STOP 'Stopped' - ENDIF - - END SUBROUTINE HANDLE_ERR - - ! ***************************************************************************** - - subroutine compute_dayx ( & - NTILES, AGCM_YY, AGCM_MM, AGCM_DD, AGCM_HR, & - LATT, DAYX) - - implicit none - - integer, intent (in) :: NTILES,AGCM_YY,AGCM_MM,AGCM_DD,AGCM_HR - real, dimension (NTILES), intent (in) :: LATT - real, dimension (NTILES), intent (out) :: DAYX - integer, parameter :: DT = 900 - integer, parameter :: ncycle = 1461 ! number of days in a 4-year leap cycle (365*4 + 1) - real, dimension(ncycle) :: zc, zs - integer :: dofyr, sec,YEARS_PER_CYCLE, DAYS_PER_CYCLE, year, iday, idayp1, nn, n - real :: fac, YEARLEN, zsin, zcos, declin - - dofyr = AGCM_DD - if(AGCM_MM > 1) dofyr = dofyr + 31 - if(AGCM_MM > 2) then - dofyr = dofyr + 28 - if(mod(AGCM_YY,4) == 0) dofyr = dofyr + 1 - endif - if(AGCM_MM > 3) dofyr = dofyr + 31 - if(AGCM_MM > 4) dofyr = dofyr + 30 - if(AGCM_MM > 5) dofyr = dofyr + 31 - if(AGCM_MM > 6) dofyr = dofyr + 30 - if(AGCM_MM > 7) dofyr = dofyr + 31 - if(AGCM_MM > 8) dofyr = dofyr + 31 - if(AGCM_MM > 9) dofyr = dofyr + 30 - if(AGCM_MM > 10) dofyr = dofyr + 31 - if(AGCM_MM > 11) dofyr = dofyr + 30 - - sec = AGCM_HR * 3600 - DT ! subtract DT to get time of previous physics step - fac = real(sec) / 86400. - - call orbit_create(zs,zc,ncycle) ! GEOS5 leap cycle routine - - YEARLEN = 365.25 - - ! Compute length of leap cycle - !------------------------------ - - if(YEARLEN-int(YEARLEN) > 0.) then - YEARS_PER_CYCLE = nint(1./(YEARLEN-int(YEARLEN))) - else - YEARS_PER_CYCLE = 1 - endif - - DAYS_PER_CYCLE=nint(YEARLEN*YEARS_PER_CYCLE) - - ! declination & daylength - ! ----------------------- - - YEAR = mod(AGCM_YY-1,YEARS_PER_CYCLE) - - IDAY = YEAR*int(YEARLEN)+dofyr - IDAYP1 = mod(IDAY,DAYS_PER_CYCLE) + 1 - - ZSin = ZS(IDAYP1)*FAC + ZS(IDAY)*(1.-FAC) ! sine of solar declination - ZCos = ZC(IDAYP1)*FAC + ZC(IDAY)*(1.-FAC) ! cosine of solar declination - - nn = 0 - do n = 1,days_per_cycle - nn = nn + 1 - if(nn > 365) nn = nn - 365 - ! print *, 'cycle:',n,nn,asin(ZS(n)) - end do - - declin = asin(ZSin) - - ! compute daylength on input tile space (accounts for any change in physics time step) - ! do n = 1,ntiles_cn - ! fac = -(sin((latc(n)/zoom)*(MAPL_PI/180.))*zsin)/(cos((latc(n)/zoom)*(MAPL_PI/180.))*zcos) - ! fac = min(1.,max(-1.,fac)) - ! dayl(n) = (86400./MAPL_PI) * acos(fac) ! daylength (seconds) - ! end do - - ! compute daylength on output tile space (accounts for lat shift due to split & change in time step) - - do n = 1,ntiles - fac = -(sin(latt(n)*(MAPL_PI/180.))*zsin)/(cos(latt(n)*(MAPL_PI/180.))*zcos) - fac = min(1.,max(-1.,fac)) - dayx(n) = (86400./MAPL_PI) * acos(fac) ! daylength (seconds) - end do - - ! print *,'DAYX : ', minval(dayx),maxval(dayx), minval(latt), maxval(latt), zsin, zcos, dofyr, iday, idayp1, declin - - end subroutine compute_dayx - - ! ***************************************************************************** - - subroutine orbit_create(zs,zc,ncycle) - - implicit none - - integer, intent(in) :: ncycle - real, intent(out), dimension(ncycle) :: zs, zc - - integer :: YEARS_PER_CYCLE, DAYS_PER_CYCLE - integer :: K, KP !, KM - real*8 :: T1, T2, T3, T4, FUN, Y, SOB, OMG, PRH, TT - real*8 :: YEARLEN - - ! STATEMENT FUNCTION - - FUN(Y) = OMG*(1.0-ECCENTRICITY*cos(Y-PRH))**2 - - YEARLEN = 365.25 - - ! Factors involving the orbital parameters - !------------------------------------------ - - OMG = (2.0*MAPL_PI/YEARLEN) / (sqrt(1.-ECCENTRICITY**2)**3) - PRH = PERIHELION*(MAPL_PI/180.) - SOB = sin(OBLIQUITY*(MAPL_PI/180.)) - - ! Compute length of leap cycle - !------------------------------ - - if(YEARLEN-int(YEARLEN) > 0.) then - YEARS_PER_CYCLE = nint(1./(YEARLEN-int(YEARLEN))) - else - YEARS_PER_CYCLE = 1 - endif - - DAYS_PER_CYCLE=nint(YEARLEN*YEARS_PER_CYCLE) - - if(days_per_cycle /= ncycle) stop 'bad cycle' - - ! ZS: Sine of declination - ! ZC: Cosine of declination - - ! Begin integration at vernal equinox - - KP = EQUINOX - TT = 0.0 - ZS(KP) = sin(TT)*SOB - ZC(KP) = sqrt(1.0-ZS(KP)**2) - - ! Integrate orbit for entire leap cycle using Runge-Kutta - - do K=2,DAYS_PER_CYCLE - T1 = FUN(TT ) - T2 = FUN(TT+T1*0.5) - T3 = FUN(TT+T2*0.5) - T4 = FUN(TT+T3 ) - KP = mod(KP,DAYS_PER_CYCLE) + 1 - TT = TT + (T1 + 2.0*(T2 + T3) + T4) / 6.0 - ZS(KP) = sin(TT)*SOB - ZC(KP) = sqrt(1.0-ZS(KP)**2) - end do - - end subroutine orbit_create - -! ***************************************************************************** - -! function to_radian(degree) result(rad) -! -! ! degrees to radians -! real,intent(in) :: degree -! real :: rad -! -! rad = degree*MAPL_PI/180. -! -! end function to_radian -! -! ! ***************************************************************************** -! -! real function haversine(deglat1,deglon1,deglat2,deglon2) -! ! great circle distance -- adapted from Matlab -! real,intent(in) :: deglat1,deglon1,deglat2,deglon2 -! real :: a,c, dlat,dlon,lat1,lat2 -! real,parameter :: radius = MAPL_radius -! -!! dlat = to_radian(deglat2-deglat1) -!! dlon = to_radian(deglon2-deglon1) -! ! lat1 = to_radian(deglat1) -!! lat2 = to_radian(deglat2) -! dlat = deglat2-deglat1 -! dlon = deglon2-deglon1 -! lat1 = deglat1 -! lat2 = deglat2 -! a = (sin(dlat/2))**2 + cos(lat1)*cos(lat2)*(sin(dlon/2))**2 -! if(a>=0. .and. a<=1.) then -! c = 2*atan2(sqrt(a),sqrt(1-a)) -! haversine = radius*c / 1000. -! else -! haversine = 1.e20 -! endif -! end function -! -! ! ---------------------------------------------------------------------- - - integer function VarID (NCFID, VNAME) - - integer, intent (in) :: NCFID - character(*), intent (in) :: VNAME - integer :: status - - STATUS = NF_INQ_VARID (NCFID, trim(VNAME) ,VarID) - IF (STATUS .NE. NF_NOERR) & - CALL HANDLE_ERR(STATUS, trim(VNAME)) - - end function VarID -! ! ----------------------------------------------------------------------------- -! - - FUNCTION StrUpCase ( Input_String ) RESULT ( Output_String ) - ! -- Argument and result - CHARACTER( * ), INTENT( IN ) :: Input_String - CHARACTER( LEN( Input_String ) ) :: Output_String - ! -- Local variables - INTEGER :: i, n - - - ! -- Copy input string - Output_String = Input_String - ! -- Loop over string elements - DO i = 1, LEN( Output_String ) - ! -- Find location of letter in lower case constant string - n = INDEX( LOWER_CASE, Output_String( i:i ) ) - ! -- If current substring is a lower case letter, make it upper case - IF ( n /= 0 ) Output_String( i:i ) = UPPER_CASE( n:n ) - END DO - END FUNCTION StrUpCase - - ! ----------------------------------------------------------------------------- - - FUNCTION StrLowCase ( Input_String ) RESULT ( Output_String ) - ! -- Argument and result - CHARACTER( * ), INTENT( IN ) :: Input_String - CHARACTER( LEN( Input_String ) ) :: Output_String - ! -- Local variables - INTEGER :: i, n - - ! -- Copy input string - Output_String = Input_String - ! -- Loop over string elements - DO i = 1, LEN( Output_String ) - ! -- Find location of letter in upper case constant string - n = INDEX( UPPER_CASE, Output_String( i:i ) ) - ! -- If current substring is an upper case letter, make it lower case - IF ( n /= 0 ) Output_String( i:i ) = LOWER_CASE( n:n ) - END DO - END FUNCTION StrLowCase - - ! ----------------------------------------------------------------------------- - - FUNCTION StrExtName ( Input_String ) RESULT ( Output_String ) - ! -- Argument and result - CHARACTER( * ), INTENT( IN ) :: Input_String - CHARACTER( LEN( Input_String ) ) :: Output_String - ! -- Local variables - INTEGER :: i, n1, n2, n3, n4, n5, n, k - - ! -- Copy input string - ! Output_String = Input_String - ! -- Loop over string elements - - k = 1 - - DO i = 1, LEN( Input_String ) - - ! -- Find location of letter in upper case constant string - n1 = INDEX( UPPER_CASE, Input_String( i:i ) ) - n2 = INDEX( LOWER_CASE, Input_String( i:i ) ) - n3 = INDEX( '.', Input_String( i:i ) ) - n4 = INDEX( '-', Input_String( i:i ) ) - n5 = INDEX( '_', Input_String( i:i ) ) - - n = 0 - Output_String(i:i) = '' - - if (n1 /= 0) n = n1 - if (n2 /= 0) n = n2 - if (n3 /= 0) n = n3 - if (n4 /= 0) n = n4 - if (n5 /= 0) n = n5 - - ! -- If current substring is acceptable - IF ( n /= 0 ) then - Output_String( k:k ) = Input_String( i:i ) - k = k + 1 - endif - - END DO - - END FUNCTION StrExtName - - ! ---------------------------------------------------------------------------- - - SUBROUTINE write_bin (unit, InFmt, NTILES) - - implicit none - integer :: ntiles - integer :: unit - type(Netcdf4_FileFormatter) :: InFmt - - - real :: bf1(ntiles) - real :: bf2(ntiles) - real :: bf3(ntiles) - real :: vgwmax(ntiles) - real :: cdcr1(ntiles) - real :: cdcr2(ntiles) - real :: psis(ntiles) - real :: bee(ntiles) - real :: poros(ntiles) - real :: wpwet(ntiles) - real :: cond(ntiles) - real :: gnu(ntiles) - real :: ars1(ntiles) - real :: ars2(ntiles) - real :: ars3(ntiles) - real :: ara1(ntiles) - real :: ara2(ntiles) - real :: ara3(ntiles) - real :: ara4(ntiles) - real :: arw1(ntiles) - real :: arw2(ntiles) - real :: arw3(ntiles) - real :: arw4(ntiles) - real :: tsa1(ntiles) - real :: tsa2(ntiles) - real :: tsb1(ntiles) - real :: tsb2(ntiles) - real :: atau(ntiles) - real :: btau(ntiles) - real :: ity(ntiles) - real :: tc(ntiles,4) - real :: qc(ntiles,4) - real :: capac(ntiles) - real :: catdef(ntiles) - real :: rzexc(ntiles) - real :: srfexc(ntiles) - real :: ghtcnt1(ntiles) - real :: ghtcnt2(ntiles) - real :: ghtcnt3(ntiles) - real :: ghtcnt4(ntiles) - real :: ghtcnt5(ntiles) - real :: ghtcnt6(ntiles) - real :: tsurf(ntiles) - real :: wesnn1(ntiles) - real :: wesnn2(ntiles) - real :: wesnn3(ntiles) - real :: htsnnn1(ntiles) - real :: htsnnn2(ntiles) - real :: htsnnn3(ntiles) - real :: sndzn1(ntiles) - real :: sndzn2(ntiles) - real :: sndzn3(ntiles) - real :: ch(ntiles,4) - real :: cm(ntiles,4) - real :: cq(ntiles,4) - real :: fr(ntiles,4) - real :: ww(ntiles,4) - character*256 :: Iam = "Write bin" - integer :: status - - call MAPL_VarRead(InFmt,"BF1",bf1, __RC__) - call MAPL_VarRead(InFmt,"BF2",bf2, __RC__) - call MAPL_VarRead(InFmt,"BF3",bf3, __RC__) - call MAPL_VarRead(InFmt,"VGWMAX",vgwmax, __RC__) - call MAPL_VarRead(InFmt,"CDCR1",cdcr1, __RC__) - call MAPL_VarRead(InFmt,"CDCR2",cdcr2, __RC__) - call MAPL_VarRead(InFmt,"PSIS",psis, __RC__) - call MAPL_VarRead(InFmt,"BEE",bee, __RC__) - call MAPL_VarRead(InFmt,"POROS",poros, __RC__) - call MAPL_VarRead(InFmt,"WPWET",wpwet, __RC__) - call MAPL_VarRead(InFmt,"COND",cond, __RC__) - call MAPL_VarRead(InFmt,"GNU",gnu, __RC__) - call MAPL_VarRead(InFmt,"ARS1",ars1, __RC__) - call MAPL_VarRead(InFmt,"ARS2",ars2, __RC__) - call MAPL_VarRead(InFmt,"ARS3",ars3, __RC__) - call MAPL_VarRead(InFmt,"ARA1",ara1, __RC__) - call MAPL_VarRead(InFmt,"ARA2",ara2, __RC__) - call MAPL_VarRead(InFmt,"ARA3",ara3, __RC__) - call MAPL_VarRead(InFmt,"ARA4",ara4, __RC__) - call MAPL_VarRead(InFmt,"ARW1",arw1, __RC__) - call MAPL_VarRead(InFmt,"ARW2",arw2, __RC__) - call MAPL_VarRead(InFmt,"ARW3",arw3, __RC__) - call MAPL_VarRead(InFmt,"ARW4",arw4, __RC__) - call MAPL_VarRead(InFmt,"TSA1",tsa1, __RC__) - call MAPL_VarRead(InFmt,"TSA2",tsa2, __RC__) - call MAPL_VarRead(InFmt,"TSB1",tsb1, __RC__) - call MAPL_VarRead(InFmt,"TSB2",tsb2, __RC__) - call MAPL_VarRead(InFmt,"ATAU",atau, __RC__) - call MAPL_VarRead(InFmt,"BTAU",btau, __RC__) - call MAPL_VarRead(InFmt,"OLD_ITY",ity, __RC__) - call MAPL_VarRead(InFmt,"TC",tc, __RC__) - call MAPL_VarRead(InFmt,"QC",qc, __RC__) - call MAPL_VarRead(InFmt,"OLD_ITY",ity, __RC__) - call MAPL_VarRead(InFmt,"CAPAC",capac, __RC__) - call MAPL_VarRead(InFmt,"CATDEF",catdef, __RC__) - call MAPL_VarRead(InFmt,"RZEXC",rzexc, __RC__) - call MAPL_VarRead(InFmt,"SRFEXC",srfexc, __RC__) - call MAPL_VarRead(InFmt,"GHTCNT1",ghtcnt1, __RC__) - call MAPL_VarRead(InFmt,"GHTCNT2",ghtcnt2, __RC__) - call MAPL_VarRead(InFmt,"GHTCNT3",ghtcnt3, __RC__) - call MAPL_VarRead(InFmt,"GHTCNT4",ghtcnt4, __RC__) - call MAPL_VarRead(InFmt,"GHTCNT5",ghtcnt5, __RC__) - call MAPL_VarRead(InFmt,"GHTCNT6",ghtcnt6, __RC__) - call MAPL_VarRead(InFmt,"TSURF",tsurf, __RC__) - call MAPL_VarRead(InFmt,"WESNN1",wesnn1, __RC__) - call MAPL_VarRead(InFmt,"WESNN2",wesnn2, __RC__) - call MAPL_VarRead(InFmt,"WESNN3",wesnn3, __RC__) - call MAPL_VarRead(InFmt,"HTSNNN1",htsnnn1, __RC__) - call MAPL_VarRead(InFmt,"HTSNNN2",htsnnn2, __RC__) - call MAPL_VarRead(InFmt,"HTSNNN3",htsnnn3, __RC__) - call MAPL_VarRead(InFmt,"SNDZN1",sndzn1, __RC__) - call MAPL_VarRead(InFmt,"SNDZN2",sndzn2, __RC__) - call MAPL_VarRead(InFmt,"SNDZN3",sndzn3, __RC__) - call MAPL_VarRead(InFmt,"CH",ch, __RC__) - call MAPL_VarRead(InFmt,"CM",cm, __RC__) - call MAPL_VarRead(InFmt,"CQ",cq, __RC__) - call MAPL_VarRead(InFmt,"FR",fr, __RC__) - call MAPL_VarRead(InFmt,"WW",ww, __RC__) - - write(unit) bf1 - write(unit) bf2 - write(unit) bf3 - write(unit) vgwmax - write(unit) cdcr1 - write(unit) cdcr2 - write(unit) psis - write(unit) bee - write(unit) poros - write(unit) wpwet - write(unit) cond - write(unit) gnu - write(unit) ars1 - write(unit) ars2 - write(unit) ars3 - write(unit) ara1 - write(unit) ara2 - write(unit) ara3 - write(unit) ara4 - write(unit) arw1 - write(unit) arw2 - write(unit) arw3 - write(unit) arw4 - write(unit) tsa1 - write(unit) tsa2 - write(unit) tsb1 - write(unit) tsb2 - write(unit) atau - write(unit) btau - write(unit) ity - write(unit) tc - write(unit) qc - write(unit) capac - write(unit) catdef - write(unit) rzexc - write(unit) srfexc - write(unit) ghtcnt1 - write(unit) ghtcnt2 - write(unit) ghtcnt3 - write(unit) ghtcnt4 - write(unit) ghtcnt5 - write(unit) ghtcnt6 - write(unit) tsurf - write(unit) wesnn1 - write(unit) wesnn2 - write(unit) wesnn3 - write(unit) htsnnn1 - write(unit) htsnnn2 - write(unit) htsnnn3 - write(unit) sndzn1 - write(unit) sndzn2 - write(unit) sndzn3 - write(unit) ch - write(unit) cm - write(unit) cq - write(unit) fr - write(unit) ww - - END SUBROUTINE write_bin - - ! ---------------------------------------------------------------------------- - - SUBROUTINE read_ldas_restarts (NTILES, ntiles_rst, id_glb, ld_reorder, rst_file, pfile) - - implicit none - integer, intent (in) :: NTILES, ntiles_rst - integer, intent (in) :: id_glb(NTILES), ld_reorder (ntiles_rst) - integer :: k - character(*), intent (in) :: rst_file, pfile - real , dimension (:), allocatable :: var_get, var_put - type(Netcdf4_FileFormatter) :: OutFmt, InFmt - type(FileMetadata) :: meta_data - - allocate (var_get (NTILES_RST)) - allocate (var_put (NTILES)) - - call InFmt%Open(trim(InCatRestart), pFIO_READ, __RC__) - meta_data = InFmt%read(__RC__) - call InFmt%close() - call meta_data%modify_dimension('tile', ntiles, __RC__) - - OutFileName = "InData/catch_internal_rst" - call OutFmt%create(OutFileName, __RC__) - call OutFmt%write(meta_data, __RC__) - - open(10, file=trim(rst_file), form='unformatted', status='old', & - convert='big_endian', action='read') - - read (10) var_get ! (cat_progn(n)%tc1, n=1,N_catd) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'TC',var_put, offset1=1) - - read (10) var_get ! (cat_progn(n)%tc2, n=1,N_catd) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'TC',var_put, offset1=2) - - read (10) var_get ! (cat_progn(n)%tc4, n=1,N_catd) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'TC',var_put, offset1=3) - - read (10) var_get ! (cat_progn(n)%qa1, n=1,N_catd) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'QC',var_put, offset1=1) - - read (10) var_get ! (cat_progn(n)%qa2, n=1,N_catd) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'QC',var_put, offset1=2) - - read (10) var_get ! (cat_progn(n)%qa4, n=1,N_catd) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'QC',var_put, offset1=3) - call MAPL_VarWrite(OutFmt,'QC',var_put, offset1=4) - - read (10) var_get ! (cat_progn(n)%capac, n=1,N_catd) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'CAPAC',var_put) - - read (10) var_get ! (cat_progn(n)%catdef, n=1,N_catd) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'CATDEF',var_put) - - read (10) var_get ! (cat_progn(n)%rzexc, n=1,N_catd) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'RZEXC',var_put) - - read (10) var_get ! (cat_progn(n)%srfexc, n=1,N_catd) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'SRFEXC',var_put) - - read (10) var_get ! (cat_progn(n)%ght(k), n=1,N_catd) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'GHTCNT1',var_put) - read (10) var_get ! (cat_progn(n)%ght(k), n=1,N_catd) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'GHTCNT2',var_put) - read (10) var_get ! (cat_progn(n)%ght(k), n=1,N_catd) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'GHTCNT3',var_put) - read (10) var_get ! (cat_progn(n)%ght(k), n=1,N_catd) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'GHTCNT4',var_put) - read (10) var_get ! (cat_progn(n)%ght(k), n=1,N_catd) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'GHTCNT5',var_put) - read (10) var_get ! (cat_progn(n)%ght(k), n=1,N_catd) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'GHTCNT6',var_put) - - read (10) var_get !(cat_progn(n)%wesn(k), n=1,N_catd) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'WESNN1',var_put) - read (10) var_get !(cat_progn(n)%wesn(k), n=1,N_catd) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'WESNN2',var_put) - read (10) var_get !(cat_progn(n)%wesn(k), n=1,N_catd) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'WESNN3',var_put) - - read (10) var_get !(cat_progn(n)%htsn(k), n=1,N_catd) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'HTSNNN1',var_put) - read (10) var_get !(cat_progn(n)%htsn(k), n=1,N_catd) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'HTSNNN2',var_put) - read (10) var_get !(cat_progn(n)%htsn(k), n=1,N_catd) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'HTSNNN3',var_put) - - read (10) var_get !(cat_progn(n)%sndz(k), n=1,N_catd) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'SNDZN1',var_put) - read (10) var_get !(cat_progn(n)%sndz(k), n=1,N_catd) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'SNDZN2',var_put) - read (10) var_get !(cat_progn(n)%sndz(k), n=1,N_catd) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'SNDZN3',var_put) - - close (10) - -! PARAM - - open(10, file=trim(pfile), form='unformatted', status='old', & - convert='big_endian', action='read') - - - read (10) var_get !(cat_param(n)%dpth, n=1,N_catd) - - read (10) var_get !(cat_param(n)%dzsf, n=1,N_catd) - read (10) var_get !(cat_param(n)%dzrz, n=1,N_catd) - read (10) var_get !(cat_param(n)%dzpr, n=1,N_catd) - - do k=1,6 - read (10) var_get !(cat_param(n)%dzgt(k), n=1,N_catd) - end do - do k = 1, NTILES - VAR_PUT(k) = id_glb(k) - end do - call MAPL_VarWrite(OutFmt,'TILE_ID',var_put) - - read (10) var_get !(cat_param(n)%poros, n=1,N_catd) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'POROS',var_put) - - read (10) var_get !(cat_param(n)%cond, n=1,N_catd) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'COND',var_put) - - read (10) var_get !(cat_param(n)%psis, n=1,N_catd) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'PSIS',var_put) - - read (10) var_get !(cat_param(n)%bee, n=1,N_catd) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'BEE',var_put) - - read (10) var_get !(cat_param(n)%wpwet, n=1,N_catd) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'WPWET',var_put) - - read (10) var_get !(cat_param(n)%gnu, n=1,N_catd) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'GNU',var_put) - - read (10) var_get !(cat_param(n)%vgwmax, n=1,N_catd) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'VGWMAX',var_put) - - read (10) var_get !(cat_param(n)%vegcls, n=1,N_catd) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'OLD_ITY',var_put) - - read (10) var_get !(cat_param(n)%soilcls30, n=1,N_catd) - read (10) var_get !(cat_param(n)%soilcls100, n=1,N_catd) - - read (10) var_get !(cat_param(n)%bf1, n=1,N_catd) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'BF1',var_put) - - read (10) var_get !(cat_param(n)%bf2, n=1,N_catd) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'BF2',var_put) - - read (10) var_get !(cat_param(n)%bf3, n=1,N_catd) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'BF3',var_put) - - read (10) var_get !(cat_param(n)%cdcr1, n=1,N_catd) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'CDCR1',var_put) - - read (10) var_get !(cat_param(n)%cdcr2, n=1,N_catd) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'CDCR2',var_put) - - read (10) var_get !(cat_param(n)%ars1, n=1,N_catd) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'ARS1',var_put) - - read (10) var_get !(cat_param(n)%ars2, n=1,N_catd) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'ARS2',var_put) - - read (10) var_get !(cat_param(n)%ars3, n=1,N_catd) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'ARS3',var_put) - - read (10) var_get !(cat_param(n)%ara1, n=1,N_catd) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'ARA1',var_put) - - read (10) var_get !(cat_param(n)%ara2, n=1,N_catd) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'ARA2',var_put) - - read (10) var_get !(cat_param(n)%ara3, n=1,N_catd) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'ARA3',var_put) - - read (10) var_get !(cat_param(n)%ara4, n=1,N_catd) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'ARA4',var_put) - - read (10) var_get !(cat_param(n)%arw1, n=1,N_catd) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'ARW1',var_put) - - read (10) var_get !(cat_param(n)%arw2, n=1,N_catd) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'ARW2',var_put) - - read (10) var_get !(cat_param(n)%arw3, n=1,N_catd) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'ARW3',var_put) - - read (10) var_get !(cat_param(n)%arw4, n=1,N_catd) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'ARW4',var_put) - - read (10) var_get !(cat_param(n)%tsa1, n=1,N_catd) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'TSA1',var_put) - - read (10) var_get !(cat_param(n)%tsa2, n=1,N_catd) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'TSA2',var_put) - - read (10) var_get !(cat_param(n)%tsb1, n=1,N_catd) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'TSB1',var_put) - - read (10) var_get !(cat_param(n)%tsb2, n=1,N_catd) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'TSB2',var_put) - - read (10) var_get !(cat_param(n)%atau, n=1,N_catd) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'ATAU',var_put) - - read (10) var_get !(cat_param(n)%btau, n=1,N_catd) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'BTAU',var_put) - - read (10) var_get !(cat_param(n)%gravel30, n=1,N_catd) - read (10) var_get !(cat_param(n)%orgC30 , n=1,N_catd) - read (10) var_get !(cat_param(n)%orgC , n=1,N_catd) - read (10) var_get !(cat_param(n)%sand30 , n=1,N_catd) - read (10) var_get !(cat_param(n)%clay30 , n=1,N_catd) - read (10) var_get !(cat_param(n)%sand , n=1,N_catd) - read (10) var_get !(cat_param(n)%clay , n=1,N_catd) - read (10) var_get !(cat_param(n)%wpwet30 , n=1,N_catd) - read (10) var_get !(cat_param(n)%poros30 , n=1,N_catd) - - close (10, status = 'keep') - deallocate (var_get, var_put) - - call OutFmt%close() - - call system('/bin/cp InData/catch_internal_rst OutData/catch_internal_rst') - - END SUBROUTINE read_ldas_restarts - - END PROGRAM mk_GEOSldasRestarts diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/mk_Restarts b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/mk_Restarts deleted file mode 100755 index 7040cf2a6..000000000 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/mk_Restarts +++ /dev/null @@ -1,404 +0,0 @@ -#!/usr/bin/env perl -#======================================================================= -# name - mk_Restarts -# purpose - wrapper script to run programs which regrid surface restarts -#======================================================================= -use strict; -use warnings; -use FindBin qw($Bin); -use lib ("$Bin"); -use Cwd qw(getcwd); - -# global variables -#----------------- -my ($saltwater, $openwater, $seaice, $lake, $landice, $route); -my ($catchFLG, $catchcn, $catchcnFLG, @cnlist, @cnlen); -my ($surflay, $rsttime, $grpID, $numtasks, $walltime, $rescale, $qos, $partition, $constraint, $yyyymm); -my ($mk_catch_j, $mk_catch_log, $weminIN, $weminOUT, $weminDFLT); -my ($zoom); - -# mk_catch job and log file names (also applies to catchcn) -#---------------------------------------------------------- -$mk_catch_j = "mk_catch.j"; -$mk_catch_log = "mk_catch.log"; - -# main program -#------------- -{ - my ($cmd, $line, $pid); - - init(); - - #--------------------------- - # catch and catchcn restarts - #--------------------------- - if ($catchFLG or $catchcnFLG) { - write_mk_catch_j() unless -e $mk_catch_j; - - # run interactively if already on interactive job nodes - #------------------------------------------------------ - if (-x $mk_catch_j) { - $cmd = "./$mk_catch_j"; - system_($cmd); - } - else { - $cmd = "sbatch -W $mk_catch_j"; - print "$cmd\n"; - chomp($line = `$cmd`); - $pid = (split /\s+/, $line)[-1]; - } - } - - #------------------ - # saltwater restart - #------------------ - if ($saltwater) { - $cmd = "$Bin/mk_LakeLandiceSaltRestarts " - . "OutData/\*.til " - . "InData/\*.til " - . "InData/\*saltwater_internal_rst\* 0 $zoom"; - system_($cmd); - } - - if ($openwater) { - $cmd = "$Bin/mk_LakeLandiceSaltRestarts " - . "OutData/\*.til " - . "InData/\*.til " - . "InData/\*openwater_internal_rst\* 0 $zoom"; - system_($cmd); - } - - if ($seaice) { - $cmd = "$Bin/mk_LakeLandiceSaltRestarts " - . "OutData/\*.til " - . "InData/\*.til " - . "InData/\*seaicethermo_internal_rst\* 0 $zoom"; - system_($cmd); - } - - #------------- - # lake restart - #------------- - if ($lake) { - $cmd = "$Bin/mk_LakeLandiceSaltRestarts " - . "OutData/\*.til " - . "InData/\*.til " - . "InData/\*lake_internal_rst\* 19 $zoom"; - system_($cmd); - } - - #---------------- - # landice restart - #---------------- - if ($landice) { - $cmd = "$Bin/mk_LakeLandiceSaltRestarts " - . "OutData/\*.til " - . "InData/\*.til " - . "InData/\*landice_internal_rst\* 20 $zoom"; - system_($cmd); - } - - #-------------- - # route restart - #-------------- - if ($route) { - $cmd = "$Bin/mk_RouteRestarts OutData/\*.til $yyyymm"; - system_($cmd); - } - wait_for_pid($pid) if $pid; -} - -#======================================================================= -# name - init -# purpose - get runtime flags to determine which restarts to regrid -#======================================================================= -sub init { - use Getopt::Long; - my $help; - $| = 1; # flush buffer after each output operation - - GetOptions( "saltwater" => \$saltwater, - "openwater" => \$openwater, - "seaice" => \$seaice, - "lake" => \$lake, - "landice" => \$landice, - "catch" => \$catchFLG, - "catchcn=s" => \$catchcn, - "wemin=i" => \$weminIN, - "wemout=i" => \$weminOUT, - "route" => \$route, - - "surflay=i" => \$surflay, - "rsttime=i" => \$rsttime, - "grpID=s" => \$grpID, - - "constraint=s" => \$constraint, - - "ntasks=i" => \$numtasks, - "walltime=s"=> \$walltime, - "rescale" => \$rescale, - "qos=s" => \$qos, - "partition=s" => \$partition, - "zoom=i" => \$zoom, - "h|help" => \$help ); - # defaults - #--------- - $rsttime = 0 unless $rsttime; - $catchcnFLG = 0 unless $catchcn; - $rescale = 0 unless $rescale; - $weminDFLT = 26; - $weminIN = $weminDFLT unless defined($weminIN); - $weminOUT = $weminDFLT unless defined($weminOUT); - $zoom = 8 unless $zoom; - - usage() if $help; - - # unpack catchcn values - #---------------------- - if ($catchcn) { - $catchcnFLG = 1; - @cnlist = split(/,/, $catchcn); - @cnlen = scalar(@cnlist); - } - - # error if no restart specified - #------------------------------ - die "Error. No restart specified;" - unless $saltwater or $lake or $landice or $catchFLG or $catchcnFLG; - - # rsttime and grpID values are needed for catchcn - #---------------------------------------------- - if ($catchcnFLG) { - die "Error. Must specify rsttime for catchcn;" unless $rsttime; - die "Error. rsttime not in yyyymmddhh format: $rsttime;" - unless $rsttime =~ m/^\d{10}$/; - } - if ($catchFLG or $catchcnFLG) { - unless ($grpID) { - $grpID = `$Bin/getsponsor.pl -d`; - print "Using default grpID = $grpID\n"; - } - unless ($walltime) { $walltime = "1:00:00" } - unless ($numtasks) { $numtasks = 84 } - $qos = "" unless $qos; - $partition = "" unless $partition; - $constraint = "" unless $constraint; - } - - # rsttime value is needed for route - #---------------------------------- - if ($route) { - die "Error. Must specify rsttime for route;" unless $rsttime; - die "Error. Cannot extract yyyymm from rsttime: $rsttime" - unless $rsttime =~ m/^\d{6,}$/; - $yyyymm = $1 if $rsttime =~ /^(\d{6})/; - } -} - -#======================================================================= -# name - write_mk_catch_j -# purpose - write job file to make catch and/or catchcn restart -#======================================================================= -sub write_mk_catch_j { - my ($grouplist, $cwd, $QOSline, $PARTline, $CONSline, $FH); - - $grouplist = ""; - $grouplist = "SBATCH --account=$grpID" if $grpID; - - $cwd = getcwd; - - $QOSline = ""; - if ($qos) { - $QOSline = "SBATCH --qos=$qos"; - if ($qos eq "debug") { - $QOSline = "" unless $numtasks <= 532 and $walltime le "1:00:00"; - } - } - $PARTline = ""; - if ($partition) { - $PARTline = "SBATCH --partition=$partition"; - } - $CONSline = ""; - if ($constraint) { - $CONSline = "SBATCH --constraint=$constraint"; - } - print("\nWriting jobscript: $mk_catch_j\n"); - open CNj, ">> $mk_catch_j" or die "Error opening $mk_catch_j: $!"; - - $FH = select; - select CNj; - - print <<"EOF"; -#!/bin/csh -f -#$grouplist -#SBATCH --ntasks=$numtasks -#SBATCH --time=$walltime -#SBATCH --job-name=catchcnj -#SBATCH --output=$cwd/$mk_catch_log -#$QOSline -#$PARTline -#$CONSline - -source $Bin/g5_modules -set echo - -#limit stacksize unlimited -unlimit - -set catchFLG = $catchFLG -set catchcnFLG = $catchcnFLG -set weminIN = $weminIN -set weminOUT = $weminOUT -set rescaleFLG = $rescale - -set numtasks = $numtasks -set rsttime = $rsttime -set surflay = $surflay -set zoom = $zoom - -set esma_mpirun_X = ( $Bin/esma_mpirun -np \$numtasks ) -set mk_CatchRestarts_X = ( \$esma_mpirun_X $Bin/mk_CatchRestarts ) -set mk_CatchCNRestarts_X = ( \$esma_mpirun_X $Bin/mk_CatchCNRestarts ) -set mk_GEOSldasRestarts_X = ( \$esma_mpirun_X $Bin/mk_GEOSldasRestarts ) -set Scale_Catch_X = $Bin/Scale_Catch -set Scale_CatchCN_X = $Bin/Scale_CatchCN - -set OUT_til = OutData/\*.til -set IN_til = InData/\*.til - -if (\$catchFLG) then - set catchIN = InData/\*catch_internal_rst\* - set params = ( \$OUT_til \$IN_til \$catchIN \$surflay ) - \$mk_CatchRestarts_X \$params - - if (\$rescaleFLG) then - set catch_regrid = OutData/\$catchIN:t - set catch_scaled = \${catch_regrid}.scaled - set params = ( \$catchIN \$catch_regrid \$catch_scaled \$surflay ) - set params = ( \$params \$weminIN \$weminOUT ) - \$Scale_Catch_X \$params - - mv \$catch_regrid \${catch_regrid}.1 - mv \$catch_scaled \$catch_regrid - endif -endif - -if (\$catchcnFLG) then - if ($cnlen[0] == 1) then - set catchcnIN = InData/\*catchcn_internal_rst\* - set params = ( \$OUT_til \$IN_til \$catchcnIN \$surflay \$rsttime ) - \$mk_CatchCNRestarts_X \$params - endif - if ($cnlen[0] == 4) then - set OUT_til = `ls OutData/\*.til | cut -d '/' -f2` - /bin/cp OutData/\*.til OutData/OutTileFile - /bin/cp OutData/\*.til InData/OutTileFile - set CN_VERSION = $cnlist[0] - set RESTART_ID = $cnlist[1] - set RESTART_PATH = $cnlist[2] - set RESTART_DOMAIN = $cnlist[3] - set RESTART_short = \${RESTART_PATH}/\${RESTART_ID}/output/\${RESTART_DOMAIN}/ - set YYYY = `echo \${rsttime} | cut -c1-4` - set MM = `echo \${rsttime} | cut -c5-6` - set PARAM_FILE = `ls \$RESTART_short/rc_out/Y\${YYYY}/M\${MM}/*ldas_catparam* | head -1` - set params = ( -b OutData/ -d \$rsttime -e \$RESTART_ID -m catchcn\$CN_VERSION -s \$surflay -j Y -r R -p \$PARAM_FILE -l \$RESTART_short) - \$mk_GEOSldasRestarts_X \$params - endif - if (\$rescaleFLG) then - set catchcnIN = InData/catchcn\${CN_VERSION}_internal_rst\* - set catchcn_regrid = OutData/\$catchcnIN:t - set catchcn_scaled = \${catchcn_regrid}.scaled - set params = ( \$catchcnIN \$catchcn_regrid \$catchcn_scaled \$surflay ) - set params = ( \$params \$weminIN \$weminOUT ) - \$Scale_CatchCN_X \$params - - mv \$catchcn_regrid \${catchcn_regrid}.1 - mv \$catchcn_scaled \$catchcn_regrid - endif -endif -exit -EOF -; - close CNj; - select $FH; - chmod 0755, $mk_catch_j if $ENV{"SLURM_JOBID"}; -} - -#======================================================================= -# name - system_ -# purpose - wrapper for perl system command -#======================================================================= -sub system_ { - my $cmd = shift @_; - print "\n$cmd\n"; - die "Error: $!;" if system($cmd); -} - -#======================================================================= -# name - wait_for_pid -# purpose - wait for batch job to finish -# -# input parameter -# => $pid: process ID of batch job to wait for -#======================================================================= -sub wait_for_pid { - my ($pid, $first, %found, $line, $id); - $pid = shift @_; - return unless $pid; - - $first = 1; - while (1) { - %found = (); - #--foreach $line (`qstat | grep $ENV{"USER"}`) { - foreach $line (`squeue | grep $ENV{"USER"}`) { - $line =~ s/^\s+//; - $id = (split /\s+/, $line)[0]; - $found{$id} = 1; - } - last unless $found{$pid}; - print "\nWaiting for job $pid to finish\n" if $first; - $first = 0; - sleep 10; - } - print "Job $pid is DONE\n\n" unless $first; -} - -#======================================================================= -# name - usage -# purpose - print usage information -#======================================================================= -sub usage { - use File::Basename ("basename"); - my $name = basename $0; - print <<"EOF"; - -usage $name [-saltwater] [-lake] [-landice] [-catch] [-h] - -option flags - -saltwater regrid saltwater internal restart - -lake regrid lake internal restart - -landice regrid landice internal restart - -catch regrid catchment internal restart - -catchcn regrid catchment CN internal restart - -wemin weminIN minimum snow water equivalent threshold for input catch/cn [$weminDFLT] - -wemout weminOUT minimum snow water equivalent threshold for output catch/cn [$weminDFLT] - -route create the route internal restart - -surflay n thickness [mm] of surface soil moisture layer (catch & catchcn) - Ganymed-3 and earlier: SURFLAY=20 - Ganymed-4 and later : SURFLAY=50 - -rsttime n10 restart time in format, yyyymmddhh (catchcn) or yyyymm (route) - -grpID grpID group ID for batch submittal (catchcn) - -ntasks nt number of tasks to assign to catchcn batch job [112] - -walltime wt walltime in format \"hh:mm:ss\" for catchcn batch job [1:00:00] - -rescale - -qos val use \"SBATCH --qos=val directive\" for batch jobs; - \"-qos debug\" will not work unless these conditions are met - -> numtasks <= 532 - -> walltime le \"1:00:00\" - -partition val use \"SBATCH --partition=val directive\" for batch jobs - -zoom n zoom value to send to land regridding codes [8] - -h print usage information - -EOF -exit; -} diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/obsolete/catchplt b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/obsolete/catchplt deleted file mode 100755 index dd2d3fc40..000000000 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/obsolete/catchplt +++ /dev/null @@ -1,25 +0,0 @@ -n = 1 -while ( n < 64 ) - -m = n -if( m < 10 ) ; m = 0n ; endif - -'set dfile 1' -'setx' -'set y 1' -'set z 1' -'set cmark 0' -'d var'm'.1' - -'set dfile 2' -'setx' -'set y 1' -'set z 1' -'set cmark 0' -'d var'm'.2' - -'draw title Var: 'm -pull flag -'c' -n = n + 1 -endwhile diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/obsolete/check_land_restarts.pro b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/obsolete/check_land_restarts.pro deleted file mode 100755 index 54afd3705..000000000 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/obsolete/check_land_restarts.pro +++ /dev/null @@ -1,1167 +0,0 @@ -; ========================================================================= -; USAGE : -; Edit lines to 44-47 specify paths to BCs dir and yjecatch{cn}_internal_rst file -; ========================================================================= -;_____________________________________________________________________ -;_____________________________________________________________________ - -FUNCTION NCDF_ISNCDF, FILENAME - -;- Set return values - -false = 0B -true = 1B - -;- Establish error handler - -catch, error_status -if error_status ne 0 then begin - catch, /cancel - return, false -endif - -;- Try opening the file - -cdfid = ncdf_open( filename ) - -;- If we get this far, open must have worked - -ncdf_close, cdfid -catch, /cancel -return, true - -END - -;_____________________________________________________________________ -;_____________________________________________________________________ - -pro plot_rst - -; ********************************************************************************************************** -; STEP (1) Specify below: -; ----------------------- - -BCSDIR = '/discover/nobackup/smahanam/bcs/Heracles-4_3/Heracles-4_3_MERRA-3/CF0180x6C_DE1440xPE0720/' -GFILE = 'CF0180x6C_DE1440xPE0720-Pfafstetter' -OutDir = 'OutData2/' -int_rst = 'catchcn_internal_rst' - -; STEP (2) save : -; --------------- -; On dali : (a) module load tool/idl-8.5, (b) idl (c) .compile chk_restarts -; and (d) plot_rst - -; ********************************************************************************************************** - -; Setting up and select variables for plotting -; -------------------------------------------- - -TILFILE = BCSDIR + 'til/' + GFILE + '.til' -RSTFILE = BCSDIR + 'rst/' + GFILE + '.rst' - -NTILES = 0l -NG = 0l -NC = 0l -NR = 0l - -openr,1,BCSDIR + 'clsm/catchment.def' -readf,1,NTILES -close,1 - -openr,1,TILFILE -readf,1,NG,NC,NR -close,1 - -Var_Names = [ $ - 'CDCR2' , $ ; 0 - 'BEE' , $ ; 1 - 'POROS' , $ ; 2 - 'ITY1' , $ ; 3 - 'ITY2' , $ ; 4 - 'ITY3' , $ ; 5 - 'ITY4' , $ ; 6 - 'TC1' , $ ; 7 - 'TC2' , $ ; 8 - 'TC3' , $ ; 9 - 'TC4' , $ ;10 - 'CATDEF' , $ ;11 - 'RZEXC' , $ ;12 - 'SFEXC' ] - -N_VARS = N_ELEMENTS (Var_Names) -PLOT_VARS = fltarr (NTILES,N_VARS) -TMP_VAR1 = fltarr (NTILES) -TMP_VAR2 = fltarr (NTILES,4) - - -; Get file information : (1) model, (2) file format -; ------------------------------------------------- - -catch_model = boolean (strcmp(int_rst,'catchcn',7,/fold_case) eq 0) -ncdf_file = boolean (ncdf_isncdf(OutDir + int_rst)) - -; Set up vector to grid for plotting -; ---------------------------------- - -NC_plot = 4320 -NR_plot = 2160 - -tileid_plot = lonarr (NC_plot,NR_plot) - -dx = NC/NC_plot -dy = NR/NR_plot - -catrow = lonarr(nc) -cat = lonarr(nc,dy) - -openr,1,RSTFILE,/F77_UNFORMATTED - -for j = 0l, NR_plot -1 do begin - - for i=0,dy -1 do begin - readu,1,catrow - cat (*,i) = catrow - endfor - - for i = 0, NC_plot -1 do begin - subset = cat (i*dx: (i+1)*dx -1,*) - if (min (subset) le NTILES) then begin - min1 = min(subset) - subset(where (subset gt NTILES)) = 0 - hh = histogram(subset,bin=1,min = min1, locations=loc_val) - dom_tile = max(hh,loc) - tileid_plot[i,j] = loc_val(loc) - endif - endfor - -endfor - -close,1 - -; Reading catch*_internal_rst -; --------------------------- - -if (ncdf_file) then begin - - ncid = NCDF_OPEN(OutDir + int_rst,/NOWRITE) - result = ncdf_inquire( ncid) - if(result.nvars gt 60) then catch_model = boolean (result.nvars lt 60) - NCDF_VARGET, ncid,'CDCR2' ,TMP_VAR1 - PLOT_VARS (*,0) = TMP_VAR1 - NCDF_VARGET, ncid,'BEE' ,TMP_VAR1 - PLOT_VARS (*,1) = TMP_VAR1 - NCDF_VARGET, ncid,'POROS' ,TMP_VAR1 - PLOT_VARS (*,2) = TMP_VAR1 - NCDF_VARGET, ncid,'TC' ,TMP_VAR2 - PLOT_VARS (*,7) = TMP_VAR2(*,0) - PLOT_VARS (*,8) = TMP_VAR2(*,1) - PLOT_VARS (*,9) = TMP_VAR2(*,2) - PLOT_VARS (*,10)= TMP_VAR2(*,3) - NCDF_VARGET, ncid,'CATDEF' ,TMP_VAR1 - PLOT_VARS (*,11) = TMP_VAR1 - NCDF_VARGET, ncid,'RZEXC' ,TMP_VAR1 - PLOT_VARS (*,12) = TMP_VAR1 - NCDF_VARGET, ncid,'SRFEXC' ,TMP_VAR1 - PLOT_VARS (*,13) = TMP_VAR1 - - if(catch_model) then begin - - NCDF_VARGET, ncid,'OLD_ITY' ,TMP_VAR1 - PLOT_VARS (*,3) = TMP_VAR1 - - endif else begin - - NCDF_VARGET, ncid,'ITY' ,TMP_VAR2 - PLOT_VARS (*,3) = TMP_VAR2(*,0) - PLOT_VARS (*,4) = TMP_VAR2(*,1) - PLOT_VARS (*,5) = TMP_VAR2(*,2) - PLOT_VARS (*,6) = TMP_VAR2(*,3) - - endelse - - NCDF_CLOSE, ncid - -endif else begin - - openr,1,OutDir + int_rst, /F77_UNFORMATTED - - if(catch_model) then begin - - for i = 1,30 do begin - readu,1,TMP_VAR1 - if (i eq 6) then PLOT_VARS (*,0) = TMP_VAR1 - if (i eq 8) then PLOT_VARS (*,1) = TMP_VAR1 - if (i eq 9) then PLOT_VARS (*,2) = TMP_VAR1 - if (i eq 30) then PLOT_VARS (*,3) = TMP_VAR1 - endfor - - readu,1,TMP_VAR2 - PLOT_VARS (*,7) = TMP_VAR2(*,0) - PLOT_VARS (*,8) = TMP_VAR2(*,1) - PLOT_VARS (*,9) = TMP_VAR2(*,2) - PLOT_VARS (*,10)= TMP_VAR2(*,3) - - readu,1,TMP_VAR2 - readu,1,TMP_VAR1 - readu,1,TMP_VAR1 - PLOT_VARS (*,11) = TMP_VAR1 - readu,1,TMP_VAR1 - PLOT_VARS (*,12) = TMP_VAR1 - readu,1,TMP_VAR1 - PLOT_VARS (*,13) = TMP_VAR1 - - endif else begin - - for i = 1,37 do begin - readu,1,TMP_VAR1 - if (i eq 6) then PLOT_VARS (*,0) = TMP_VAR1 - if (i eq 8) then PLOT_VARS (*,1) = TMP_VAR1 - if (i eq 9) then PLOT_VARS (*,2) = TMP_VAR1 - if (i eq 30) then PLOT_VARS (*,3) = TMP_VAR1 - if (i eq 31) then PLOT_VARS (*,4) = TMP_VAR1 - if (i eq 32) then PLOT_VARS (*,5) = TMP_VAR1 - if (i eq 33) then PLOT_VARS (*,6) = TMP_VAR1 - endfor - readu,1,TMP_VAR2 - PLOT_VARS (*,7) = TMP_VAR2(*,0) - PLOT_VARS (*,8) = TMP_VAR2(*,1) - PLOT_VARS (*,9) = TMP_VAR2(*,2) - PLOT_VARS (*,10)= TMP_VAR2(*,3) - - readu,1,TMP_VAR2 - readu,1,TMP_VAR2 - readu,1,TMP_VAR1 - readu,1,TMP_VAR1 - PLOT_VARS (*,11) = TMP_VAR1 - readu,1,TMP_VAR1 - PLOT_VARS (*,12) = TMP_VAR1 - readu,1,TMP_VAR1 - PLOT_VARS (*,13) = TMP_VAR1 - - endelse - - close,1 - -endelse - -; Plotting -; -------- - -spawn, 'mkdir -p ' + OutDir + 'plots' -load_colors - -thisDevice = !D.Name -set_plot,'Z' -Device, Set_Resolution=[720,800], Z_Buffer=0 -Erase,255 -!p.background = 255 - -!P.position=0 -!P.Multi = [0, 2, 3, 0, 0] - -plot_6maps, ntiles, tileid_plot, PLOT_VARS(*,0), [min(PLOT_VARS(*,0)), max(PLOT_VARS(*,0))] , Var_Names (0) -plot_6maps, ntiles, tileid_plot, PLOT_VARS(*,1), [min(PLOT_VARS(*,1)), max(PLOT_VARS(*,1))] , Var_Names (1),advance =1 -plot_6maps, ntiles, tileid_plot, PLOT_VARS(*,2), [0.37,0.8] , Var_Names (2),advance =1 -plot_6maps, ntiles, tileid_plot, PLOT_VARS(*,11),[min(PLOT_VARS(*,11)), max(PLOT_VARS(*,11))], Var_Names (11),advance =1 -plot_6maps, ntiles, tileid_plot, PLOT_VARS(*,12),[min(PLOT_VARS(*,12)), max(PLOT_VARS(*,12))], Var_Names (12),advance =1 -plot_6maps, ntiles, tileid_plot, PLOT_VARS(*,13),[min(PLOT_VARS(*,13)), max(PLOT_VARS(*,13))], Var_Names (13),advance =1 - -snapshot = TVRD() -TVLCT, r, g, b, /Get -Device, Z_Buffer=1 -Set_Plot, thisDevice -image24 = BytArr(3, 720, 800) -image24[0,*,*] = r[snapshot] -image24[1,*,*] = g[snapshot] -image24[2,*,*] = b[snapshot] -Write_JPEG, OutDir + 'plots/soil_var.jpg', image24, True=1, Quality=100 - -plot_tc, NTILES, tileid_plot,OutDir + 'plots/', plot_vars (*,7), plot_vars (*,8), plot_vars (*,9), plot_vars (*,10) - -if(catch_model) then begin - plot_mosaic, ntiles, OutDir + 'plots/', tileid_plot, fix(plot_vars (*,3)) -endif else begin - plot_carbon, ntiles, OutDir + 'plots/', tileid_plot, fix(plot_vars (*,3:6)) -endelse - -end - -;_____________________________________________________________________ -;_____________________________________________________________________ - -pro check_regrid_carbon - -; ********************************************************************************************************** -; STEP (1) Specify below: -; ----------------------- - -BCSDIR1 = '/discover/nobackup/smahanam/bcs/Heracles-4_3/Heracles-4_3_MERRA-3/SMAP_EASEv2_M09/' -GFILE1 = 'SMAP_EASEv2_M09_3856x1624' -OutDir1 = '/discover/nobackup/projects/gmao/ssd/land/l_data/LandRestarts_for_Regridding/CatchCN/M09/20151231/' -int_rst1 = 'catchcn_internal_rst' - -BCSDIR2 = '/discover/nobackup/smahanam/bcs/Heracles-4_3/Heracles-4_3_MERRA-3/CF0180x6C_DE1440xPE0720/' -GFILE2 = 'CF0180x6C_DE1440xPE0720-Pfafstetter' -OutDir2 = '' -int_rst2 = 'catchcn_internal_rst' - -; STEP (2) save : -; --------------- -; On dali : (a) module load tool/idl-8.5, (b) idl (c) .compile chk_restarts -; and (d) plot_rst - -; ********************************************************************************************************** - -; Setting up and select variables for plotting -; -------------------------------------------- -Var_Names = [ $ - 'CDCR2' , $ ; 0 - 'BEE' , $ ; 1 - 'POROS' , $ ; 2 - 'ITY1' , $ ; 3 - 'ITY2' , $ ; 4 - 'ITY3' , $ ; 5 - 'ITY4' , $ ; 6 - 'TC1' , $ ; 7 - 'TC2' , $ ; 8 - 'TC3' , $ ; 9 - 'TC4' , $ ;10 - 'CATDEF' , $ ;11 - 'RZEXC' , $ ;12 - 'SFEXC' ] -NC_plot = 4320 -NR_plot = 2160 - -;goto, jump - -for resol = 1,2 do begin - -if(resol eq 1) then begin - BCSDIR = BCSDIR1 - TILFILE = BCSDIR1 + 'til/' + GFILE1 + '.til' - RSTFILE = BCSDIR1 + 'rst/' + GFILE1 + '.rst' -endif else begin - BCSDIR = BCSDIR2 - TILFILE = BCSDIR2 + 'til/' + GFILE2 + '.til' - RSTFILE = BCSDIR2 + 'rst/' + GFILE2 + '.rst' -endelse - - -NTILES = 0l -NG = 0l -NC = 0l -NR = 0l - -openr,1,BCSDIR + 'clsm/catchment.def' -readf,1,NTILES -close,1 - -openr,1,TILFILE -readf,1,NG,NC,NR -close,1 -; Set up vector to grid for plotting -; ---------------------------------- - - - -tileid_plot = lonarr (NC_plot,NR_plot) - -dx = NC/NC_plot -dy = NR/NR_plot - -catrow = lonarr(nc) -cat = lonarr(nc,dy) - -openr,1,RSTFILE,/F77_UNFORMATTED - -for j = 0l, NR_plot -1 do begin - - for i=0,dy -1 do begin - readu,1,catrow - cat (*,i) = catrow - endfor - - for i = 0, NC_plot -1 do begin - subset = cat (i*dx: (i+1)*dx -1,*) - if (min (subset) le NTILES) then begin - min1 = min(subset) - subset(where (subset gt NTILES)) = 0 - hh = histogram(subset,bin=1,min = min1, locations=loc_val) - dom_tile = max(hh,loc) - tileid_plot[i,j] = loc_val(loc) - endif - endfor - -endfor - -close,1 -if (resol eq 1) then begin - tileid_plot1 = tileid_plot - NTILES1 = NTILES -endif else begin - tileid_plot2 = tileid_plot - NTILES2 = NTILES -endelse -endfor - -cnpft1 = fltarr (ntiles1, 888) -cnpft2 = fltarr (ntiles2, 888) -fvg1 = fltarr (ntiles1, 4) -fvg2 = fltarr (ntiles2, 4) -ncid = NCDF_OPEN(OutDir1 + int_rst1,/NOWRITE) -NCDF_VARGET, ncid,'TILE_ID' ,TILE_ID -NCDF_VARGET, ncid,'CNPFT' ,CNPFT1 -NCDF_VARGET, ncid,'FVG' ,fvg1 -TILE_ID = long (TILE_ID) - 1l - -CNPFT=CNPFT1 -FVG =FVG1 - -for k =0l,n_elements (CNPFT1(*,0)) -1l do CNPFT1(TILE_ID(k),*) = CNPFT(k,*) -for k =0l,n_elements (FVG1 (*,0)) -1l do FVG1 (TILE_ID(k),*) = FVG (k,*) - -CNPFT=0. -FVG =0. -NCDF_CLOSE, ncid - -ncid = NCDF_OPEN(OutDir2 + int_rst2,/NOWRITE) -NCDF_VARGET, ncid,'CNPFT' ,CNPFT2 -NCDF_VARGET, ncid,'FVG' ,fvg2 -NCDF_CLOSE, ncid -save,NTILES1,NTILES2,tileid_plot1,tileid_plot2,CNPFT1,CNPFT2, fvg1, fvg2,file = 'temp_file.idl' -;stop - -jump: - -restore,'temp_file.idl' - -; Plotting -; -------- - -spawn, 'mkdir -p plots' -load_colors -limits = [-60,-180,90,180] - -plot_varid = 14 -cnpft1 = reform ( cnpft1,[ntiles1,3,4,74],/overwrite) -cnpft2 = reform ( cnpft2,[ntiles2,3,4,74],/overwrite) - -for iv = 1,4 do begin - -plot_vars1 = cnpft1(*,0,iv - 1,plot_varid-1) -plot_vars2 = cnpft2(*,0,iv - 1,plot_varid-1) - - -thisDevice = !D.Name -set_plot,'Z' -Device, Set_Resolution=[720,1000], Z_Buffer=0 -Erase,255 -!p.background = 255 - -!P.position=0 -!P.Multi = [0, 1, 2, 0, 1] - -plot_2maps, ntiles1, tileid_plot1, plot_vars1(*), [min([PLOT_VARS1,plot_vars2],/nan),max([PLOT_VARS1,plot_vars2],/nan)], string(plot_varid,'(i2.2)')+'_v' + string(iv,'(i1.1)') -plot_2maps, ntiles2, tileid_plot2, plot_vars2(*), [min([PLOT_VARS1,plot_vars2],/nan),max([PLOT_VARS1,plot_vars2],/nan)], string(plot_varid,'(i2.2)')+'_v' + string(iv,'(i1.1)'),advance =1 - -snapshot = TVRD() -TVLCT, r, g, b, /Get -Device, Z_Buffer=1 -Set_Plot, thisDevice -image24 = BytArr(3, 720, 1000) -image24[0,*,*] = r[snapshot] -image24[1,*,*] = g[snapshot] -image24[2,*,*] = b[snapshot] -Write_JPEG, 'plots/pft_'+ string(plot_varid,'(i2.2)')+'_v' + string(iv,'(i1.1)') +'.jpg', image24, True=1, Quality=100 -endfor -fvg1(where (fvg1 le 1.e-4)) = !VALUES.F_NAN -fvg2(where (fvg2 le 1.e-4)) = !VALUES.F_NAN - -plot_fr, NTILES1, tileid_plot1,'plots/offl_', fvg1 (*,0), fvg1 (*,1), fvg1 (*,2), fvg1 (*,3) - -plot_fr, NTILES2, tileid_plot2,'plots/agcm_', fvg2 (*,0), fvg2 (*,1), fvg2 (*,2), fvg2 (*,3) - -end -;_____________________________________________________________________ -;_____________________________________________________________________ - -PRO plot_2maps, ncat, tile_id, data, vlim, vname,advance = advance - -lwval = vlim(0) -upval = vlim(1) - -im = n_elements(tile_id[*,0]) -jm = n_elements(tile_id[0,*]) - -dx = 360. / im -dy = 180. / jm - -x = indgen(im)*dx -180. + dx/2. -y = indgen(jm)*dy -90. + dy/2. - -data_grid = fltarr (im,jm) -data_grid (*,*) = !VALUES.F_NAN - -for j = 0l, jm -1l do begin - for i = 0l, im -1 do begin - if(tile_id[i,j] gt 0) then data_grid(i,j) = data(tile_id[i,j] -1) - endfor -endfor - -limits = [-60,-180,90,180] - -colors = [27,26,25,24,23,22,21,20,40,41,42,43,44,45,46,47,48] -n_levels = n_elements (colors) - -levels = [lwval,lwval+(upval-lwval)/(n_levels -1) +indgen(n_levels -1)*(upval-lwval)/(n_levels -1)] - -if keyword_set (advance) then begin - -MAP_SET,/CYLINDRICAL,/hires,color= 0,/NoErase,limit=limits,/ADVANCE,/ISOTROPIC,/NOBORDER, title =vname -endif else begin -MAP_SET,/CYLINDRICAL,/hires,color= 0,/NoErase,limit=limits,/ISOTROPIC,/NOBORDER, title =vname -endelse - -contour, data_grid,x,y,levels = levels,c_colors=colors,/cell_fill,/overplot - -levels_x = levels - -alpha=fltarr(n_levels,2) -alpha(*,0)=levels -alpha(*,1)=levels -h=[0,1] - -dx = (240.)/(n_levels-1) - -clev = levels -clev (*) = 1 -n=0 -k = 0 -fmt_string = '(f7.2)' -!P.position=[0.30, 0.0+0.005, 0.70, 0.015+0.005] - -contour,alpha,levels_x,h,levels=levels,c_colors=colors,/fill,/xstyle,/ystyle, $ - /noerase,yticks=1,ytickname=[' ',' '] ,xrange=[min(levels),max(levels)], $ - xtitle=' ', color=0,xtickv=levels, $ - C_charsize=1.0, charsize=0.5 ,xtickformat = "(A1)" -contour,alpha,levels_x,h,levels=levels,color=0,/overplot,c_label=clev - for k = 0,n_elements(colors) -1 do xyouts,levels_x[k],1.1,string(levels[k],format=fmt_string) ,orientation=90,color=0,charsize =0.8 - -!P.position=0 - -END - -;_____________________________________________________________________ -;_____________________________________________________________________ - -pro plot_fr, ncat, tile_id,out_path, VISDR, VISDF, NIRDR, NIRDF - -load_colors -thisDevice = !D.Name -set_plot,'Z' -Device, Set_Resolution=[720,500], Z_Buffer=0 -Erase,255 -!p.background = 255 - -!P.position=0 -!P.Multi = [0, 2, 2, 0, 0] -limits = [-60,-180,90,180] - -lwval = 0. -upval = 1. - -im = n_elements(tile_id[*,0]) -jm = n_elements(tile_id[0,*]) - -dx = 360. / im -dy = 180. / jm - -x = indgen(im)*dx -180. + dx/2. -y = indgen(jm)*dy -90. + dy/2. - -colors = [27,26,25,24,23,22,21,20,40,41,42,43,44,45,46,47,48] -n_levels = n_elements (colors) - -for map = 1,4 do begin - - if (map eq 1) then data = VISDR - if (map eq 2) then data = VISDF - if (map eq 3) then data = NIRDR - if (map eq 4) then data = NIRDF - - if (map eq 1) then ctitle = 'PF1' - if (map eq 2) then ctitle = 'PF2' - if (map eq 3) then ctitle = 'SF1' - if (map eq 4) then ctitle = 'SF2' - - levels = [lwval,lwval+(upval-lwval)/(n_levels -1) +indgen(n_levels -1)*(upval-lwval)/(n_levels -1)] - - data_grid = fltarr (im,jm) - data_grid (*,*) = !VALUES.F_NAN - - for j = 0l, jm -1l do begin - for i = 0l, im -1 do begin - if(tile_id[i,j] gt 0) then data_grid(i,j) = data(tile_id[i,j] -1) - endfor - endfor - - if(map eq 1) then begin - MAP_SET,/CYLINDRICAL,/hires,color= 0,/NoErase,limit=limits,/ISOTROPIC,/NOBORDER, title = ctitle - endif else begin - MAP_SET,/CYLINDRICAL,/hires,color= 0,/NoErase,limit=limits,/ADVANCE,/ISOTROPIC,/NOBORDER, title = ctitle - endelse - - contour, data_grid,x,y,levels = levels,c_colors=colors,/cell_fill,/overplot - if(map eq 3) then begin - !P.position=[0.25, 0.05, 0.75, 0.075] - - alpha=fltarr(n_levels,2) - alpha(*,0)=levels - alpha(*,1)=levels - h=[0,1] - clev = levels - clev (*) = 1 - n=0 - k = 0 - fmt_string = '(f6.2)' - contour,alpha,levels,h,levels=levels,c_colors=colors,/fill,/xstyle,/ystyle, $ - /noerase,yticks=1,ytickname=[' ',' '] ,xrange=[min(levels),max(levels)], $ - xtitle=' ', color=0,xtickv=levels, $ - C_charsize=1.0, charsize=0.5 ,xtickformat = "(A1)" - contour,alpha,levels,h,levels=levels,color=0,/overplot,c_label=clev - for k = 0,n_elements(colors) -1 do xyouts,levels[k],1.1,string(levels[k],format=fmt_string) ,orientation=90,color=0,charsize =0.8 - !P.position=0 - endif -endfor - -snapshot = TVRD() -TVLCT, r, g, b, /Get -Device, Z_Buffer=1 -Set_Plot, thisDevice -image24 = BytArr(3, 720, 500) -image24[0,*,*] = r[snapshot] -image24[1,*,*] = g[snapshot] -image24[2,*,*] = b[snapshot] -Write_JPEG, out_path +'FR.jpg', image24, True=1, Quality=100 - -end - -;_____________________________________________________________________ -;_____________________________________________________________________ - -pro load_colors - -R = intarr (256) -G = intarr (256) -B = intarr (256) - -R (*) = 255 -G (*) = 255 -B (*) = 255 - -r_drought = [0, 0, 0, 0, 47, 200, 255, 255, 255, 255, 249, 197] -g_drought = [0, 115, 159, 210, 255, 255, 255, 255, 219, 157, 0, 0] -b_drought = [0, 0, 0, 0, 67, 130, 255, 0, 0, 0, 0, 0] - -colors = indgen (11) + 1 -R (0:11) = r_drought -G (0:11) = g_drought -B (0:11) = b_drought - -r_green = [200, 150, 47, 60, 0, 0, 0, 0] -g_green = [255, 255, 255, 230, 219, 187, 159, 131] -b_green = [200, 150, 67, 15, 0, 0, 0, 0] - -r_blue = [ 55, 0, 0, 0, 0, 0, 0, 0, 0, 0] -g_blue = [255, 255, 227, 195, 167, 115, 83, 0, 0, 0] -b_blue = [199, 255, 255, 255, 255, 255, 255, 255, 200, 130] - -r_red = [255, 240, 255, 255, 255, 255, 255, 233, 197] -g_red = [255, 255, 219, 187, 159, 131, 51, 23, 0] -b_red = [153, 15, 0, 0, 0, 0, 0, 0, 0] - -r_grey = [245, 225, 205, 185, 165, 145, 125, 105, 85] -g_grey = [245, 225, 205, 185, 165, 145, 125, 105, 85] -b_grey = [245, 225, 205, 185, 165, 145, 125, 105, 85] - -r_type = [255,106,202,251, 0, 29, 77,109,142,233,255,255,255,127,164,164,217,217,204,104, 0] -g_type = [245, 91,178,154, 85,115,145,165,185, 23,131,131,191, 39, 53, 53, 72, 72,204,104, 70] -b_type = [215,154,214,153, 0, 0, 0, 0, 13, 0, 0,200, 0, 4, 3,200, 1,200,204,200,200] - -R (20:27) = r_green -G (20:27) = g_green -B (20:27) = b_green - -R (30:39) = r_blue -G (30:39) = g_blue -B (30:39) = b_blue - -R (40:48) = r_red -G (40:48) = g_red -B (40:48) = b_red - -R (50:58) = r_grey -G (50:58) = g_grey -B (50:58) = b_grey - -R (60:80) = r_type -G (60:80) = g_type -B (60:80) = b_type - -TVLCT,R ,G ,B - -end - -;_____________________________________________________________________ -;_____________________________________________________________________ - -PRO plot_6maps, ncat, tile_id, data, vlim, vname,advance = advance - -lwval = vlim(0) -upval = vlim(1) -if (vname eq 'SOILDEPTH') then upval = 5000. - -im = n_elements(tile_id[*,0]) -jm = n_elements(tile_id[0,*]) - -dx = 360. / im -dy = 180. / jm - -x = indgen(im)*dx -180. + dx/2. -y = indgen(jm)*dy -90. + dy/2. - -data_grid = fltarr (im,jm) -data_grid (*,*) = !VALUES.F_NAN - -for j = 0l, jm -1l do begin - for i = 0l, im -1 do begin - if(tile_id[i,j] gt 0) then data_grid(i,j) = data(tile_id[i,j] -1) - endfor -endfor - -limits = [-60,-180,90,180] -if file_test ('limits.idl') then restore,'limits.idl' - -colors = [27,26,25,24,23,22,21,20,40,41,42,43,44,45,46,47,48] -n_levels = n_elements (colors) - -levels = [lwval,lwval+(upval-lwval)/(n_levels -1) +indgen(n_levels -1)*(upval-lwval)/(n_levels -1)] - -if(vname eq 'POROS') then $ -levels = [lwval,lwval+(0.57-lwval)/(n_levels -2) +indgen(n_levels -2)*(0.57-lwval)/(n_levels -2),upval] - -if keyword_set (advance) then begin - -MAP_SET,/CYLINDRICAL,/hires,color= 0,/NoErase,limit=limits,/ADVANCE,/ISOTROPIC,/NOBORDER, title =vname -endif else begin -MAP_SET,/CYLINDRICAL,/hires,color= 0,/NoErase,limit=limits,/ISOTROPIC,/NOBORDER, title =vname -endelse - -contour, data_grid,x,y,levels = levels,c_colors=colors,/cell_fill,/overplot - -levels_x = levels - -if(vname eq 'POROS') then begin -dxp = (0.8-0.37)/16. -levels_x = indgen(17)*dxp+ 0.37 -endif - -alpha=fltarr(n_levels,2) -alpha(*,0)=levels -alpha(*,1)=levels -h=[0,1] - -dx = (240.)/(n_levels-1) - -clev = levels -clev (*) = 1 -n=0 -k = 0 -fmt_string = '(f7.2)' - -if(vname eq 'CDCR2' ) then !P.position=[0.064, 0.675, 0.41, 0.69] -if(vname eq 'BEE' ) then !P.position=[0.58, 0.675, 0.92, 0.69] -if(vname eq 'POROS' ) then !P.position=[0.064, 0.345, 0.41, 0.36] -if(vname eq 'CATDEF') then !P.position=[0.58, 0.345, 0.92, 0.36] -if(vname eq 'RZEXC' ) then !P.position=[0.064, 0.015, 0.41, 0.03] -if(vname eq 'SFEXC' ) then !P.position=[0.58, 0.015, 0.92, 0.03] - -;!P.position=[0.064, 0.675, 0.41, 0.69] -;!P.position=[0.58, 0.0+0.005, 0.92, 0.015+0.005] - -contour,alpha,levels_x,h,levels=levels,c_colors=colors,/fill,/xstyle,/ystyle, $ - /noerase,yticks=1,ytickname=[' ',' '] ,xrange=[min(levels),max(levels)], $ - xtitle=' ', color=0,xtickv=levels, $ - C_charsize=1.0, charsize=0.5 ,xtickformat = "(A1)" -contour,alpha,levels_x,h,levels=levels,color=0,/overplot,c_label=clev - for k = 0,n_elements(colors) -1 do xyouts,levels_x[k],1.1,string(levels[k],format=fmt_string) ,orientation=90,color=0,charsize =0.8 - -;for l = 0,n_levels -2 do begin -; k = l -; xbox = [-120. + k*dx,-120. + k*dx, -120. + (k+1)*dx, -120. + (k+1)*dx,-120. + k*dx] -; ybox = [-65., -55.,-55.,-65.,-65.] -; polyfill, xbox,ybox,color=colors [k] -; -; xyouts,xbox[1],ybox[2]+0.05,string(levels[l],format=fmt_string),color =0, orientation =90,charsize =0.8 -; k = k + 1 -;endfor -; -;l = n_levels -1 -;xyouts,-120. + l*dx,ybox[2]+0.05,string(levels[l],format=fmt_string),color =0, orientation =90,charsize =0.8 -!P.position=0 - -END -;_____________________________________________________________________ -;_____________________________________________________________________ - -pro plot_tc, ncat, tile_id,out_path, VISDR, VISDF, NIRDR, NIRDF - -load_colors -thisDevice = !D.Name -set_plot,'Z' -Device, Set_Resolution=[720,500], Z_Buffer=0 -Erase,255 -!p.background = 255 - -!P.position=0 -!P.Multi = [0, 2, 2, 0, 0] -limits = [-60,-180,90,180] - -lwval = min ([min(VISDR), min(VISDF), min(NIRDR), min(NIRDF)]) -upval = max ([max(VISDR), max(VISDF), max(NIRDR), max(NIRDF)]) - -im = n_elements(tile_id[*,0]) -jm = n_elements(tile_id[0,*]) - -dx = 360. / im -dy = 180. / jm - -x = indgen(im)*dx -180. + dx/2. -y = indgen(jm)*dy -90. + dy/2. - -colors = [27,26,25,24,23,22,21,20,40,41,42,43,44,45,46,47,48] -n_levels = n_elements (colors) - -for map = 1,4 do begin - - if (map eq 1) then data = VISDR - if (map eq 2) then data = VISDF - if (map eq 3) then data = NIRDR - if (map eq 4) then data = NIRDF - - if (map eq 1) then ctitle = 'TC1' - if (map eq 2) then ctitle = 'TC2' - if (map eq 3) then ctitle = 'TC3' - if (map eq 4) then ctitle = 'TC4' - - levels = [lwval,lwval+(upval-lwval)/(n_levels -1) +indgen(n_levels -1)*(upval-lwval)/(n_levels -1)] - - data_grid = fltarr (im,jm) - data_grid (*,*) = !VALUES.F_NAN - - for j = 0l, jm -1l do begin - for i = 0l, im -1 do begin - if(tile_id[i,j] gt 0) then data_grid(i,j) = data(tile_id[i,j] -1) - endfor - endfor - - if(map eq 1) then begin - MAP_SET,/CYLINDRICAL,/hires,color= 0,/NoErase,limit=limits,/ISOTROPIC,/NOBORDER, title = ctitle - endif else begin - MAP_SET,/CYLINDRICAL,/hires,color= 0,/NoErase,limit=limits,/ADVANCE,/ISOTROPIC,/NOBORDER, title = ctitle - endelse - - contour, data_grid,x,y,levels = levels,c_colors=colors,/cell_fill,/overplot - if(map eq 3) then begin - !P.position=[0.25, 0.05, 0.75, 0.075] - - alpha=fltarr(n_levels,2) - alpha(*,0)=levels - alpha(*,1)=levels - h=[0,1] - clev = levels - clev (*) = 1 - n=0 - k = 0 - fmt_string = '(f6.2)' - contour,alpha,levels,h,levels=levels,c_colors=colors,/fill,/xstyle,/ystyle, $ - /noerase,yticks=1,ytickname=[' ',' '] ,xrange=[min(levels),max(levels)], $ - xtitle=' ', color=0,xtickv=levels, $ - C_charsize=1.0, charsize=0.5 ,xtickformat = "(A1)" - contour,alpha,levels,h,levels=levels,color=0,/overplot,c_label=clev - for k = 0,n_elements(colors) -1 do xyouts,levels[k],1.1,string(levels[k],format=fmt_string) ,orientation=90,color=0,charsize =0.8 - !P.position=0 - endif -endfor - -snapshot = TVRD() -TVLCT, r, g, b, /Get -Device, Z_Buffer=1 -Set_Plot, thisDevice -image24 = BytArr(3, 720, 500) -image24[0,*,*] = r[snapshot] -image24[1,*,*] = g[snapshot] -image24[2,*,*] = b[snapshot] -Write_JPEG, out_path +'TC.jpg', image24, True=1, Quality=100 - -end -; ============================================================================== -; Mosaic classes -; ============================================================================== - -PRO plot_mosaic, ncat, outdir, tile_id, mos_type - -im = n_elements(tile_id[*,0]) -jm = n_elements(tile_id[0,*]) - -dx = 360. / im -dy = 180. / jm - -x = indgen(im)*dx -180. + dx/2. -y = indgen(jm)*dy -90. + dy/2. - -mos_grid = intarr (im,jm) -mos_grid (*,*) = !VALUES.F_NAN - -for j = 0l, jm -1l do begin - for i = 0l, im -1 do begin - if(tile_id[i,j] gt 0) then mos_grid(i,j) = mos_type(tile_id[i,j] -1) - endfor -endfor - -limits = [-60,-180,90,180] -if file_test ('limits.idl') then restore,'limits.idl' - -thisDevice = !D.Name -set_plot,'Z' -Device, Set_Resolution=[700,500], Z_Buffer=0 - -r_in = [233,255,255,255,210, 0, 0, 0,204,170,255,220,205, 0, 0,170, 0, 40,120,140,190,150,255,255, 0, 0, 0,195,255, 0,255, 0] -g_in = [ 23,131,191,255,255,255,155, 0,204,240,255,240,205,100,160,200, 60,100,130,160,150,100,180,235,120,150,220, 20,245, 70,255, 0] -b_in = [ 0, 0, 0,178,255,255,255,200,204,240,100,100,102, 0, 0, 0, 0, 0, 0, 0, 0, 0, 50,175, 90,120,130, 0,215,200,255, 0] -vtypes =[ 1, 2, 3, 4, 5, 6, 7, 8, 10, 11, 14, 20, 30, 40, 50, 60, 70, 90,100,110,120,130,140,150,160,170,180,190,200,210,220,230] - -red = intarr (256) -green= intarr (256) -blue = intarr (256) -red (255) = 255 -green(255) = 255 -blue (255) = 255 - -for k = 0, n_elements(vtypes) -1 do begin - red (vtypes(k)) = r_in (k) - green(vtypes(k)) = g_in (k) - blue (vtypes(k)) = b_in (k) -endfor - -TVLCT,red,green,blue - -colors = vtypes -levels = vtypes - -Erase,255 -!p.background = 255 -!P.position=0 -!P.Multi = [0, 1, 1, 0, 1] -MAP_SET,/CYLINDRICAL,/hires,color= 0,/NoErase,limit=limits -contour, mos_grid,x,y,levels = levels,c_colors=colors,/cell_fill,/overplot - -mos_name = strarr(6) -mos_name( 0) = 'BL Evergreen' -mos_name( 1) = 'BL Deciduous' -mos_name( 2) = 'Needleleaf' -mos_name( 3) = 'Grassland' -mos_name( 4) = 'BL Shrubs' -mos_name( 5) = 'Dwarf' - -n_levels = 6;n_elements(vtypes) -alpha=fltarr(n_levels,2) -alpha(*,0)=levels [0:n_levels-1] -alpha(*,1)=levels [0:n_levels-1] -h=[0,1] -!P.position=[0.30, 0.0+0.005, 0.70, 0.015+0.005] -clev = levels -clev (*) = 1 -contour,alpha,levels[0:5],h,levels=levels,c_colors=colors,/fill,/xstyle,/ystyle, $ - /noerase,yticks=1,ytickname=[' ',' '] ,xrange=[1,7], $ - xtitle=' ', color=0,xtickv=levels, $ - C_charsize=1.0, charsize=0.5 ,xtickformat = "(A1)" -contour,alpha,levels[0:5],h,levels=levels,color=0,/overplot,c_label=clev -for k = 0,5 do xyouts,levels[k]+0.5,1.2,mos_name[k] ,orientation=90,color=0 - -snapshot = TVRD() -TVLCT, r, g, b, /Get -Device, Z_Buffer=1 -Set_Plot, thisDevice -image24 = BytArr(3, 700, 500) -image24[0,*,*] = r[snapshot] -image24[1,*,*] = g[snapshot] -image24[2,*,*] = b[snapshot] -Write_JPEG, outdir + '/mosaic_prim.jpg', image24, True=1, Quality=100 - - -END -; ============================================================================== -; CLM-Carbon classes -; ============================================================================== - -PRO plot_carbon,ncat, OutDir, tile_id, clm_type - -im = n_elements(tile_id[*,0]) -jm = n_elements(tile_id[0,*]) - -dx = 360. / im -dy = 180. / jm - -x = indgen(im)*dx -180. + dx/2. -y = indgen(jm)*dy -90. + dy/2. - -clm_grid = intarr (im,jm,4) - -clm_grid (*,*,*) = !VALUES.F_NAN - -for j = 0l, jm -1l do begin - for i = 0l, im -1 do begin - if(tile_id[i,j] gt 0) then begin - clm_grid(i,j,0) = clm_type(tile_id[i,j] -1,0) - clm_grid(i,j,1) = clm_type(tile_id[i,j] -1,1) - clm_grid(i,j,2) = clm_type(tile_id[i,j] -1,2) - clm_grid(i,j,3) = clm_type(tile_id[i,j] -1,3) - endif - endfor -endfor - -clm_type = 0 - -limits = [-60,-180,90,180] -if file_test ('limits.idl') then restore,'limits.idl' - -thisDevice = !D.Name -set_plot,'Z' -Device, Set_Resolution=[700,1000], Z_Buffer=0 -;types= [ 2, 3, 4, 5, 6, 7, 8, 9, 10, 11,11a, 12, 13, 14,14a, 15,15a, 16,16a, 17] -r_in = [106,202,251, 0, 29, 77,109,142,233,255,255,255,127,164,164,217,217,204,104, 0] -g_in = [ 91,178,154, 85,115,145,165,185, 23,131,131,191, 39, 53, 53, 72, 72,204,104, 70] -b_in = [154,214,153, 0, 0, 0, 0, 13, 0, 0,200, 0, 4, 3,200, 1,200,204,200,200] -vtypes= [ 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20] - -red = intarr (256) -green= intarr (256) -blue = intarr (256) - -red (255) = 255 -green(255) = 255 -blue (255) = 255 - -for k = 0, n_elements(vtypes) -1 do begin - red (vtypes(k)) = r_in (k) - green(vtypes(k)) = g_in (k) - blue (vtypes(k)) = b_in (k) -endfor - -TVLCT,red,green,blue - -colors = vtypes -levels = vtypes - -clm_name = strarr(19) -clm_name( 0) = 'NLEt' ; 1 needleleaf evergreen temperate tree -clm_name( 1) = 'NLEB' ; 2 needleleaf evergreen boreal tree -clm_name( 2) = 'NLDB' ; 3 needleleaf deciduous boreal tree -clm_name( 3) = 'BLET' ; 4 broadleaf evergreen tropical tree -clm_name( 4) = 'BLEt' ; 5 broadleaf evergreen temperate tree -clm_name( 5) = 'BLDT' ; 6 broadleaf deciduous tropical tree -clm_name( 6) = 'BLDt' ; 7 broadleaf deciduous temperate tree -clm_name( 7) = 'BLDB' ; 8 broadleaf deciduous boreal tree -clm_name( 8) = 'BLEtS' ; 9 broadleaf evergreen temperate shrub -clm_name( 9) = 'BLDtS' ; 10 broadleaf deciduous temperate shrub [moisture + deciduous] -clm_name(10) = 'BLDtSm'; 11 broadleaf deciduous temperate shrub [moisture stress only] -clm_name(11) = 'BLDBS' ; 12 broadleaf deciduous boreal shrub -clm_name(12) = 'AC3G' ; 13 arctic c3 grass -clm_name(13) = 'CC3G' ; 14 cool c3 grass [moisture + deciduous] -clm_name(14) = 'CC3Gm' ; 15 cool c3 grass [moisture stress only] -clm_name(15) = 'WC4G' ; 16 warm c4 grass [moisture + deciduous] -clm_name(16) = 'WC4Gm' ; 17 warm c4 grass [moisture stress only] -clm_name(17) = 'CROP' ; 18 crop [moisture + deciduous] -clm_name(18) = 'CROPm' ; 19 crop [moisture stress only] - -Erase,255 -!p.background = 255 -!P.position=0 -!P.Multi = [0, 1, 2, 0, 1] - -MAP_SET,/CYLINDRICAL,/hires,color= 0,/NoErase,limit=limits -contour, clm_grid[*,*,0],x,y,levels = levels,c_colors=colors,/cell_fill,/overplot - -MAP_SET,/CYLINDRICAL,/hires,color= 0,/NoErase,limit=limits,/advance -contour, clm_grid[*,*,1],x,y,levels = levels,c_colors=colors,/cell_fill,/overplot - -n_levels = n_elements(vtypes) -alpha=fltarr(n_levels,2) -alpha(*,0)=levels (0:n_levels-1) -alpha(*,1)=levels (0:n_levels-1) -h=[0,1] - -!P.position=[0.30, 0.0+0.005, 0.70, 0.015+0.005] -clev = levels -clev (*) = 1 -contour,alpha,levels,h,levels=levels,c_colors=colors,/fill,/xstyle,/ystyle, $ - /noerase,yticks=1,ytickname=[' ',' '] ,xrange=[min(levels),max(levels)], $ - xtitle=' ', color=0,xtickv=levels, $ - C_charsize=1.0, charsize=0.5 ,xtickformat = "(A1)" -contour,alpha,levels,h,levels=levels,color=0,/overplot,c_label=clev - for k = 0,n_elements(vtypes) -2 do xyouts,levels[k]+0.5,1.1,clm_name(k) ,orientation=90,color=0 -snapshot = TVRD() - -TVLCT, r, g, b, /Get -Device, Z_Buffer=1 -Set_Plot, thisDevice -image24 = BytArr(3, 700, 1000) -image24[0,*,*] = r[snapshot] -image24[1,*,*] = g[snapshot] -image24[2,*,*] = b[snapshot] -Write_JPEG, OutDir + '/CLM-Carbon_PRIM_veg_typs.jpg', image24, True=1, Quality=100 - -; now plotting secondary -thisDevice = !D.Name -set_plot,'Z' -Device, Set_Resolution=[700,1000], Z_Buffer=0 - -Erase,255 -!p.background = 255 -!P.position=0 -!P.Multi = [0, 1, 2, 0, 1] - -MAP_SET,/CYLINDRICAL,/hires,color= 0,/NoErase,limit=limits -contour, clm_grid[*,*,2],x,y,levels = levels,c_colors=colors,/cell_fill,/overplot - -MAP_SET,/CYLINDRICAL,/hires,color= 0,/NoErase,limit=limits,/advance -contour, clm_grid[*,*,3],x,y,levels = levels,c_colors=colors,/cell_fill,/overplot - -n_levels = n_elements(vtypes) -alpha=fltarr(n_levels,2) -alpha(*,0)=levels (0:n_levels-1) -alpha(*,1)=levels (0:n_levels-1) -h=[0,1] - -!P.position=[0.30, 0.0+0.005, 0.70, 0.015+0.005] -clev = levels -clev (*) = 1 -contour,alpha,levels,h,levels=levels,c_colors=colors,/fill,/xstyle,/ystyle, $ - /noerase,yticks=1,ytickname=[' ',' '] ,xrange=[min(levels),max(levels)], $ - xtitle=' ', color=0,xtickv=levels, $ - C_charsize=1.0, charsize=0.5 ,xtickformat = "(A1)" -contour,alpha,levels,h,levels=levels,color=0,/overplot,c_label=clev - for k = 0,n_elements(vtypes) -2 do xyouts,levels[k]+0.5,1.1,clm_name(k) ,orientation=90,color=0 -snapshot = TVRD() - -TVLCT, r, g, b, /Get -Device, Z_Buffer=1 -Set_Plot, thisDevice -image24 = BytArr(3, 700, 1000) -image24[0,*,*] = r[snapshot] -image24[1,*,*] = g[snapshot] -image24[2,*,*] = b[snapshot] -Write_JPEG, OutDir + '/CLM-Carbon_SEC_veg_typs.jpg', image24, True=1, Quality=100 - -END diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/obsolete/mk_catch_restart b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/obsolete/mk_catch_restart deleted file mode 100755 index 0aa20db94..000000000 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/obsolete/mk_catch_restart +++ /dev/null @@ -1,29 +0,0 @@ -#!/bin/csh - -setenv ARCH `uname` -setenv LANDIR /land/l_data/geos5/bcs/SiB2_V2 -setenv HOMDIR /home1/ltakacs/catchment/ -setenv WRKDIR $HOMDIR/wrk -cd $WRKDIR -/bin/rm mk_catch_restart.x - - -setenv old_rslv 540x361 -setenv old_dateline DC -setenv old_tilefile FV_540x361_DC_360x180_DE.til -setenv old_restart d500_eros_01.catch_internal_rst.20060529_21z.bin - -setenv new_rslv 1080x721 -setenv new_tilefile FV_1080x721_DC_360x180_DE.til -setenv new_dateline DC - - -if( $ARCH == 'IRIX64' ) then - f90 -o mk_catch_restart.x -g $HOMDIR/mk_catch_restart.F90 -endif - -if( $ARCH == 'OSF1' ) then - f90 -o mk_catch_restart.x -g -convert big_endian -assume byterecl $HOMDIR/mk_catch_restart.F90 -endif - -./mk_catch_restart.x diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/obsolete/mk_catch_restart.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/obsolete/mk_catch_restart.F90 deleted file mode 100755 index 4b54e203a..000000000 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/obsolete/mk_catch_restart.F90 +++ /dev/null @@ -1,859 +0,0 @@ -PROGRAM mk_catch_internal -implicit none - -integer :: im_gcm_old, jm_gcm_old -integer :: im_ocn_old, jm_ocn_old -integer :: im_gcm_new, jm_gcm_new -integer :: im_ocn_new, jm_ocn_new -integer :: ntiles_old, ntiles_new -integer :: nland_old, nland_new - -integer qtile -parameter ( qtile = 45848 ) - -real, allocatable :: lats_old(:), lats_new(:), lats_tmp(:) -real, allocatable :: lons_old(:), lons_new(:), lons_tmp(:) -integer, allocatable :: ii_old(:), ii_new(:), ii_tmp(:) -integer, allocatable :: jj_old(:), jj_new(:), jj_tmp(:) -real, allocatable :: fr_old(:), fr_new(:), fr_tmp(:) -integer, allocatable :: typ_tmp(:) - -character*20 :: version1, version2 -character*400 :: landir,wrkdir, old_tilefile, new_tilefile, arch, flag -character*400 :: old_rslv, old_dateline, oldtilnam -character*400 :: new_rslv, new_dateline, newtildir, newtilnam -character*400 :: old_restart, new_restart, sarithpath, home -character*400 :: maxtilnam, maxtildir, logfile -character*400 :: old_diag_grids, new_diag_grids - -logical :: maxoldtoggle, twotiles -integer :: ierr, indr1, indr2, indr3, ig, jg, indx_dum, ip1, ip2 -real :: fr_ocn, rdum -integer :: dum,n,nn,nta,v,loc,idum -character*4 :: bak=char(8)//char(8)//char(8)//char(8) -real, allocatable :: oldprogvars(:,:), oldparmvars(:,:), oldallvars(:,:) -real, allocatable :: newallvars(:,:) -real, allocatable :: oldvargrids(:,:,:) -real, allocatable :: newvargrids(:,:,:), dumtile(:,:), dumgrid(:,:) -real, allocatable :: tiletilevar(:,:), tilevar(:) -integer :: numrecs, allrecs, numparmrecs, numsubtiles -logical, allocatable :: ttlookup(:) -integer, allocatable :: corners_lookup(:,:) -real, allocatable :: weights_lookup(:,:) -real, allocatable :: BF1(:), BF2(:), BF3(:), VGWMAX(:) -real, allocatable :: CDCR1(:), CDCR2(:), PSIS(:), BEE(:) -real, allocatable :: POROS(:), WPWET(:), COND(:), GNU(:) -real, allocatable :: ARS1(:), ARS2(:), ARS3(:) -real, allocatable :: ARA1(:), ARA2(:), ARA3(:), ARA4(:) -real, allocatable :: ARW1(:), ARW2(:), ARW3(:), ARW4(:) -real, allocatable :: TSA1(:), TSA2(:), TSB1(:), TSB2(:) -real, allocatable :: ATAU2(:), BTAU2(:), ITY0(:) -integer, allocatable :: ity_int(:) -integer :: ity2, nmin -real :: frc1, frc2, dmin, dist -real, allocatable :: DP2BR(:), tmp_wgt(:,:), tmp_sum(:,:) -real :: zdep1, zdep2, zdep3, zmet, term1, term2 -integer :: catindex21, catindex22, catindex23 -integer :: catindex24, catindex25, catindex26 -integer :: catid, checksum -integer :: ii0, jj0, i,j -real :: fr0, val0, ESMF_MISSING -real :: lata, latb,lona, lonb, vaa, vbb, vab, vba -real :: lat00_old, lon00_old, dx_old, dy_old -real :: lonIM_old, lon0, lat0, d1,d2,d3,d4 -integer :: ia, ib, ja, jb -real :: waa, wab, wba, wbb, wsum, tol, tempval -!real :: mindist, olddist, thislat, thislon - -! ------------------------------------------------------------------------------- -! Strategy: -! 1. Read in the "old" .til definition file -! 2. Read in the "new" .til definition file -! 3. Read in the "old" restart from a previous run -! 4. Read in Sarith's tilespace catchment parameters -! 5. Convert the prognostic variables from the old restart -! to the new catchment definitions -! a. Create aggregate imxjm grid of progs from old restart -! b. Create reasonable interolated values based on centroids -! in the new .til definitions file. -! 6. Write the restart using stored values -! ------------------------------------------------------------------------------- - -! user parameters -! --------------- - - call getenv ('ARCH' ,arch ) - call getenv ('LANDIR' ,landir ) - call getenv ('WRKDIR' ,wrkdir ) - - call getenv ('old_rslv' ,old_rslv ) - call getenv ('old_dateline',old_dateline) - call getenv ('old_tilefile',old_tilefile) - call getenv ('old_restart' ,old_restart ) - - call getenv ('new_rslv' ,new_rslv ) - call getenv ('new_dateline',new_dateline) - call getenv ('new_tilefile',new_tilefile) - - if( ARCH == 'OSF1' ) flag = 'no' - if( ARCH == 'IRIX64' ) flag = 'yes' - -old_restart = trim(wrkdir) // '/' // trim(old_restart) -new_restart = trim(old_restart) // '.' // trim(new_rslv) // '_' // trim(new_dateline) - sarithpath = trim(landir) // '/' - -numsubtiles = 4 -numrecs = 61 ! number of records in the restart (includes tiletile vars) -numparmrecs = 30 ! number of parameters at the beginning of restart - -allrecs = numrecs + 7*3 ! all records, with tile-tile prognostic variables expanded - -allocate(ttlookup(numrecs)) -ttlookup(:) = .false. ! ttlookup specifies which records in restart are tile-tile -ttlookup(31:32) = .true. ! or tileonly (.false.=tileonly) -ttlookup(53:56) = .true. -ttlookup(61) = .true. - -twotiles=.false. ! set this to true to force a two tile test -ESMF_MISSING=-999.0 ! missing value in old restart prognostic variables -tol=1.0E-6 -logfile='mk_catch_restart.log' - -old_diag_grids = 'old_grids.dat' -new_diag_grids = 'new_grids.dat' - -! ------------------------------------------------------------------------------- -! 1. Read in the old .til file and store the I, J, FR's -! ------------------------------------------------------------------------------- - -newtildir = trim(sarithpath) // trim(new_dateline) // '/FV_' // trim(new_rslv) - -oldtilnam = trim(wrkdir) // '/' // trim(old_tilefile) -newtilnam = trim(wrkdir) // '/' // trim(new_tilefile) -print *, 'newtilenam1 = ',newtilnam -!newtilnam = trim(newtildir) // '/FV_' // trim(new_rslv) //'_'//trim(new_dateline)//'_360x180_DE_NO_TINY.til' -!newtilnam = trim(newtildir) // '/FV_' // trim(new_rslv) //'_'//trim(new_dateline)//'_576x540_DE_NO_TINY.til' -print *, 'newtilenam2 = ',newtilnam - -open(9, file=trim(logfile),action='write',form='formatted') - -write (*,*) -write (*,*) '---------------------------------------------------------------------' -write (*,*) 'Reading source (old) tile definitions from:' -write (9,*) '---------------------------------------------------------------------' -write (9,*) 'Reading source (old) tile definitions from:' -write (9,*) trim(oldtilnam) -write (*,*) trim(oldtilnam) - -open (10,file=trim(oldtilnam),status='old', action='read',form='formatted') -read (10,*) ntiles_old -read (10,*) dum -read (10,'(a)')version1 -read (10,*)im_gcm_old -read (10,*)jm_gcm_old -read (10,'(a)')version2 -read (10,*) im_ocn_old -read (10,*) jm_ocn_old -write(9,*) 'Header: ', ntiles_old, dum, trim(version1), im_gcm_old, jm_gcm_old, & - trim(version2), im_ocn_old, jm_ocn_old - -allocate(lats_tmp(ntiles_old)) -allocate(lons_tmp(ntiles_old)) -allocate( fr_tmp(ntiles_old)) -allocate( ii_tmp(ntiles_old)) -allocate( jj_tmp(ntiles_old)) -allocate( typ_tmp(ntiles_old)) - -write(*, 40, advance=trim(flag)) -nland_old=0 -do n = 1,ntiles_old - read(10,'(i10,i9,2f10.4,2i5,f10.6,3i8,f10.6,i8)',IOSTAT=ierr)typ_tmp(n),& - indr1,lons_tmp(n),lats_tmp(n),ii_tmp(n),jj_tmp(n),fr_tmp(n),indx_dum,indr2,dum,fr_ocn,indr3 - if (typ_tmp(n) == 100) then - ip2=n - nland_old=nland_old+1 - endif - if (typ_tmp(n) == 0) then - ip1=n - endif - if(ierr /= 0) write (*,*) 'Problem reading' - write(*, 50, advance=trim(flag)) bak, floor(float(n)/float(ntiles_old)*100) -end do -close (10,status='keep') - -write(9,*) 'Last ocean index:', ip1 -write(9,*) 'Last land index:', ip2 -write(9,*) 'NTILES LAND:', nland_old -write(*,*) - -!write(*,*) 'Packing land coordinate arrays...' - -allocate ( lats_old(nland_old) ) -allocate ( lons_old(nland_old) ) -allocate ( fr_old(nland_old) ) -allocate ( ii_old(nland_old) ) -allocate ( jj_old(nland_old) ) - -lats_old = pack(lats_tmp, mask=typ_tmp .eq. 100) -lons_old = pack(lons_tmp, mask=typ_tmp .eq. 100) - fr_old = pack( fr_tmp, mask=typ_tmp .eq. 100) - ii_old = pack( ii_tmp, mask=typ_tmp .eq. 100) - jj_old = pack( jj_tmp, mask=typ_tmp .eq. 100) - -write(9,*) 'lats', size(lats_old), minval(lats_old), maxval(lats_old) -write(9,*) 'lons', size(lons_old), minval(lons_old), maxval(lons_old) -write(9,*) 'fr ', size (fr_old), minval (fr_old), maxval (fr_old) -write(9,*) 'ii ', size (ii_old), minval (ii_old), maxval (ii_old) -write(9,*) 'jj ', size (jj_old), minval (jj_old), maxval (jj_old) - -deallocate(lats_tmp) -deallocate(lons_tmp) -deallocate( fr_tmp) -deallocate( ii_tmp) -deallocate( jj_tmp) -deallocate( typ_tmp) - -! ------------------------------------------------------------------------------- -! 2. Read in the new .til file and store the I, J, FR's -! ------------------------------------------------------------------------------- - -write (*,*) -write (*,*) '---------------------------------------------------------------------' -write (*,*) 'Reading source (new) tile definitions from:' -write (*,*) trim(newtilnam) -write (9,*) '---------------------------------------------------------------------' -write (9,*) 'Reading source (new) tile definitions from:' -write (9,*) trim(newtilnam) - -open (10,file=trim(newtilnam),status='old',action='read',form='formatted') -read (10,*) ntiles_new -read (10,*) dum -read (10,'(a)')version1 -read (10,*)im_gcm_new -read (10,*)jm_gcm_new -read (10,'(a)')version2 -read (10,*) im_ocn_new -read (10,*) jm_ocn_new -write(9,*) 'Header: ', ntiles_new, dum, trim(version1), im_gcm_new, jm_gcm_new, & - trim(version2), im_ocn_new, jm_ocn_new - -allocate ( lats_tmp(ntiles_new) ) -allocate ( lons_tmp(ntiles_new) ) -allocate ( fr_tmp(ntiles_new) ) -allocate ( ii_tmp(ntiles_new) ) -allocate ( jj_tmp(ntiles_new) ) -allocate ( typ_tmp(ntiles_new) ) - - write(*, 40, advance=trim(flag)) -nland_new=0 -do n = 1,ntiles_new - read(10,'(i10,i9,2f10.4,2i5,f10.6,3i8,f10.6,i8)',IOSTAT=ierr)typ_tmp(n),& - indr1,lons_tmp(n),lats_tmp(n),ii_tmp(n),jj_tmp(n),fr_tmp(n),indx_dum,indr2,dum,fr_ocn,indr3 - if (typ_tmp(n) == 100) then - ip2=n - nland_new=nland_new+1 - endif - if (typ_tmp(n) == 0) then - ip1=n - endif - if(ierr /= 0) write (*,*) 'Problem reading' - write(*, 50, advance=trim(flag)) bak, floor(float(n)/float(ntiles_new)*100) -end do -close (10,status='keep') - -write(9,*) 'Last ocean index:', ip1 -write(9,*) 'Last land index:', ip2 -write(9,*) 'NTILES LAND:', nland_new -write(*,*) - -allocate ( lats_new(nland_new) ) -allocate ( lons_new(nland_new) ) -allocate ( fr_new(nland_new) ) -allocate ( ii_new(nland_new) ) -allocate ( jj_new(nland_new) ) - -lats_new = pack(lats_tmp, mask=typ_tmp .eq. 100) -lons_new = pack(lons_tmp, mask=typ_tmp .eq. 100) - fr_new = pack( fr_tmp, mask=typ_tmp .eq. 100) - ii_new = pack( ii_tmp, mask=typ_tmp .eq. 100) - jj_new = pack( jj_tmp, mask=typ_tmp .eq. 100) - -write(9,*) 'lats', size(lats_new), minval(lats_new), maxval(lats_new) -write(9,*) 'lons', size(lons_new), minval(lons_new), maxval(lons_new) -write(9,*) 'fr ', size(fr_new), minval(fr_new), maxval(fr_new) -write(9,*) 'ii ', size(ii_new), minval(ii_new), maxval(ii_new) -write(9,*) 'jj ', size(jj_new), minval(jj_new), maxval(jj_new) - -deallocate(lats_tmp) -deallocate(lons_tmp) -deallocate( fr_tmp) -deallocate( ii_tmp) -deallocate( jj_tmp) -deallocate( typ_tmp) - -! ------------------------------------------------------------------------------- -! 3. Read in the old restart from a previous run -! Here, I separate the parameters and prognostic variables. Some of the -! prognostic variables are printed out by catch-finalize as var(ntiles, 4) -! This routine takes that into account, and I put the parameters and -! prognostics in separate arrays. Then, the parameters will be replaced by -! something Sarith makes, while the prognostics will be regridded. If you -! wish, you can also retain the soil parameters in the trivial case (eg. -! you want to keep same land specification but just adjust the initialization -! to a different date) -! ------------------------------------------------------------------------------- - -allocate(oldparmvars(nland_old, numparmrecs)) -allocate(oldprogvars(nland_old,allrecs-numparmrecs)) - -allocate( oldallvars(nland_old,allrecs)) -allocate(tiletilevar(nland_old, numsubtiles)) -allocate( tilevar(nland_old)) - -open(unit=30, file=trim(old_restart),form='unformatted') - -write (*,*) -write (*,*) '---------------------------------------------------------------------' -write (*,*) 'Reading old restart from:' -write (*,*) trim(old_restart) - -write (9,*) -write (9,*) '---------------------------------------------------------------------' -write (9,*) 'Reading '//trim(old_restart) -write (9,*) 'Sizes', size(tiletilevar), size(tilevar) - - write(*, 70, advance=trim(flag)) -open(unit=65, file='old_catch.dat' ,form='unformatted') - -nta=1 -do n=1, numrecs - if (ttlookup(n)) then - read(30) tiletilevar - do nn=1, numsubtiles - oldallvars(:,nta)=tiletilevar(:,nn) - write (65) tiletilevar(:,nn) ! Write Grads-Formatted Catchment File - nta=nta+1 - enddo - else - read(30) tilevar - oldallvars(:,nta)=tilevar(:) - write (65) tilevar(:) ! Write Grads-Formatted Catchment File - nta=nta+1 - endif - write(*, 50, advance=trim(flag)) bak, floor(float(n)/float(numrecs)*100) -enddo - -close(30) -deallocate(tiletilevar) -deallocate(tilevar) - -write(*,*) 'Separating parameter and prognostic variables' -write(9,*) 'Separating parameter and prognostic variables' - -do n=1, numparmrecs - oldparmvars(:,n)=oldallvars(:,n) -enddo -do n=1, allrecs-numparmrecs - oldprogvars(:,n)=oldallvars(:,n+numparmrecs) -end do - -loc = 0 -do n=1,numrecs - nta = 1 - if( ttlookup(n) ) nta = numsubtiles - do nn = 1,nta - loc = loc+1 - if( loc.le.numparmrecs ) then - write(9,*) ' Transferred old parameter (',n,',',nn,') ', & - minval(oldallvars(:,loc)), maxval(oldallvars(:,loc)) - else - write(9,*) ' Transferred old prognostic (',n,',',nn,') ', & - minval(oldallvars(:,loc)), maxval(oldallvars(:,loc)) - endif - enddo -enddo - - -! ------------------------------------------------------------------------------- -! 4. Read in the soil parameter variables (there are 29 of them) from Sarith -! vegetation type is also read in here, from an old Aries format (this needs -! to be changed, so vegtype is in .til file!) -! ------------------------------------------------------------------------------- - -allocate ( BF1(nland_new), BF2 (nland_new), BF3(nland_new) ) -allocate (VGWMAX(nland_new), CDCR1(nland_new), CDCR2(nland_new) ) -allocate ( PSIS(nland_new), BEE(nland_new), POROS(nland_new) ) -allocate ( WPWET(nland_new), COND(nland_new), GNU(nland_new) ) -allocate ( ARS1(nland_new), ARS2(nland_new), ARS3(nland_new) ) -allocate ( ARA1(nland_new), ARA2(nland_new), ARA3(nland_new) ) -allocate ( ARA4(nland_new), ARW1(nland_new), ARW2(nland_new) ) -allocate ( ARW3(nland_new), ARW4(nland_new), TSA1(nland_new) ) -allocate ( TSA2(nland_new), TSB1(nland_new), TSB2(nland_new) ) -allocate ( ATAU2(nland_new), BTAU2(nland_new), DP2BR(nland_new) ) -allocate ( ITY0(nland_new), ity_int(nland_new)) - -write(*,*) -write(*,*) '---------------------------------------------------------------------' -write(9,*) -write(9,*) '---------------------------------------------------------------------' -write(9,*) 'Reading Sarith parameters from:' -write(9,*) trim(newtildir) -write(9,*) 'Sample output ... ' -write(*,*) 'Reading Sarith parameters from:' -write(*,*) trim(newtildir) -write(*,*) 'Sample output ... ' - -open(unit=21, file=trim(newtildir) // '/' //'mosaic_veg_typs_fracs',form='formatted') -open(unit=22, file=trim(newtildir) // '/' //'bf.dat' ,form='formatted') -open(unit=23, file=trim(newtildir) // '/' //'soil_param.dat' ,form='formatted') -open(unit=24, file=trim(newtildir) // '/' //'ar.new' ,form='formatted') -open(unit=25, file=trim(newtildir) // '/' //'ts.dat' ,form='formatted') -open(unit=26, file=trim(newtildir) // '/' //'tau_param.dat' ,form='formatted') - - write(*, 80, advance=trim(flag)) - -do n=1,nland_new -! read (21, *) catindex21, catid, ity_int(n), ity2, frc1, frc2, rdum - read (21, *) catindex21, catid, ity_int(n), ity2, frc1, frc2 ! version 2 doesnt have rdum variable - ITY0(n)=1.0*ity_int(n) - read (22, *) catindex22, catid, GNU(n), BF1(n), BF2(n), BF3(n) - read (23, *) catindex23, catid, idum, idum, BEE(n), PSIS(n), POROS(n), COND(n), WPWET(n), DP2BR(n) - - read (24, *) catindex24, catid, rdum, ARS1(n), ARS2(n), ARS3(n), & - ARA1(n), ARA2(n), ARA3(n), ARA4(n), & - ARW1(n), ARW2(n), ARW3(n), ARW4(n) - - read (25, *) catindex25, catid, rdum, TSA1(n), TSA2(n), TSB1(n), TSB2(n) - - read (26, *) catindex26, catid, ATAU2(n), BTAU2(n), rdum, rdum - - checksum=catindex21+catindex22+catindex23+catindex24+catindex25+catindex26-6*(n+ip1) - zdep2=1000. - zdep3=amax1(1000.,DP2BR(n)) - if (zdep2 .gt.0.75*zdep3) then - zdep2 = 0.75*zdep3 - end if - zdep1=20. - zmet=zdep3/1000. - term1=-1.+((PSIS(n)-zmet)/PSIS(n))**((BEE(n)-1.)/BEE(n)) - term2=PSIS(n)*BEE(n)/(BEE(n)-1) - VGWMAX(n)=POROS(n)*zdep2 - CDCR1(n)=1000.*POROS(n)*(zmet-(-term2*term1)) - CDCR2(n)=(1.-WPWET(n))*POROS(n)*zdep3 - if (checksum .ne. 0) then - write(9,*) 'Catchment id mismatch with following id list at n=', n - write(9,*) catindex22, catindex23, catindex24, catindex25, catindex26, ip1+n - write(*,*) 'Halted on catchment mismatch' - STOP - else - if (modulo(n, 1000).eq.1 .or. n.eq.qtile ) then - write(9,*) - write(9,*) n, 'mosaic_vegtype: ', ity_int(n) - write(9,*) n, 'bf.dat: ', catindex22, catid, GNU(n), BF1(n), BF2(n) - write(9,*) n, 'bf.dat: ', BF3(n) - write(9,*) n, 'soil_param.dat: ', catindex23, catid, rdum, BEE(n), PSIS(n) - write(9,*) n, 'soil_param.dat: ', POROS(n), COND(n), WPWET(n), DP2BR(n) - write(9,*) n, 'ar.dat: ', catindex24, catid, rdum, ARS1(n), ARS2(n) - write(9,*) n, 'ar.dat: ', ARS3(n), ARA1(n), ARA2(n), ARA3(n), ARA4(n) - write(9,*) n, 'ar.dat: ', ARW1(n), ARW2(n), ARW3(n), ARW4(n) - write(9,*) n, 'ts.dat: ', catindex25, catid, rdum, TSA1(n), TSA2(n) - write(9,*) n, 'ts.dat: ', TSB1(n), TSB2(n) - write(9,*) n, 'tau_param.dat: ', catindex26, catid, ATAU2(n), BTAU2(n) - write(9,*) n, 'Computed: ', VGWMAX(n), CDCR1(n), CDCR2(n) - end if - endif - write(*, 50, advance=trim(flag)) bak, floor(float(n)/float(nland_new)*100) -end do - -close (21) -close (22) -close (23) -close (24) -close (25) -close (26) - -! ------------------------------------------------------------------------------- -! 5. Regrid all variables to im_gcm_oldXjm_gcm_old grid -! Then, find interpolated values based upon the centroids of tiles in -! new .til definitions. Missing values: if a single tile is missing, -! it's influence on the gridded value is ignored, except if there are no -! non-missing values in an i,j cell, then the new tile is defined as missing -! -! Alternatives for future development: -! -! a. Nearest neighbor -! b. Nearest neighbor of same/similar vegetation type, latitude, etc. -! c. Gridding, ungridding (this is done currently) -! d. Krieging of some kind, pick a radius of influence and weigh by inverse -! square of distance, or limit to veg type, or whatever. -! -! ------------------------------------------------------------------------------- - -open(unit=8, file=trim(old_diag_grids),form='unformatted') - -allocate( tmp_sum(im_gcm_old,jm_gcm_old)) -allocate( tmp_wgt(im_gcm_old,jm_gcm_old)) -allocate(oldvargrids(im_gcm_old,jm_gcm_old,allrecs)) -allocate( dumgrid(im_gcm_old,jm_gcm_old)) - -loc = 0 -do v=1, numrecs - nta = 1 - if( ttlookup(v) ) nta = numsubtiles - do nn = 1,nta - loc = loc+1 - tmp_sum(:,:)=0.0 - tmp_wgt(:,:)=0.0 - do n=1, nland_old - val0=oldallvars(n,loc) - ii0=ii_old(n) - jj0=jj_old(n) - fr0=fr_old(n) - if (abs(val0-ESMF_MISSING) .gt. tol) then - tmp_sum(ii0,jj0) = tmp_sum(ii0,jj0) + fr0*val0 - tmp_wgt(ii0,jj0) = tmp_wgt(ii0,jj0) + fr0 - else - print *, 'Old_Catch_Val = ',val0,' n = ',n,' loc = ',loc - endif - enddo - do j=1,jm_gcm_old - do i=1,im_gcm_old - if (tmp_wgt(i,j) .gt. tol) then - oldvargrids(i,j,loc)=tmp_sum(i,j)/tmp_wgt(i,j) - else - oldvargrids(i,j,loc)=ESMF_MISSING - endif - dumgrid(i,j) =oldvargrids(i,j,loc) - enddo - enddo - write (8) dumgrid - enddo -enddo - -deallocate(dumgrid) -deallocate(tmp_sum) -deallocate(tmp_wgt) -close(8) - -allocate( corners_lookup(nland_new, 4) ) -allocate( weights_lookup(nland_new, 4) ) - -lat00_old = -90 - dx_old = (360.0)/ im_gcm_old - dy_old = (180.0)/(jm_gcm_old-1) - -if (old_dateline .eq. 'DC') then - lon00_old = -180 - lonIM_old = 180-dx_old -else - lon00_old = -180+0.5*dx_old - lonIM_old = 180-0.5*dx_old -end if - -write(*,*) -write(*,*) '---------------------------------------------------------------------' -write(*,*) 'Computing interpolation lookup table for new tiles' -write(9,*) -write(9,*) '---------------------------------------------------------------------' -write(9,*) 'Computing interpolation lookup table for new tiles' - write(*, 90, advance=trim(flag)) - -do n=1,nland_new - lat0=lats_new(n) ! latitude of tile centroid to find - lon0=lons_new(n) ! longitude of tile centroid - if ((lon0 .gt. lonIM_old) .or. (lon0 .lt. lon00_old)) then - ia=im_gcm_old - ib=1 - lona=lonIM_old - lonb=lon00_old - else - ia=floor((lon0-lon00_old)/dx_old)+1 - ib=ia+1 - lona=(ia-1)*dx_old+lon00_old - lonb=lona+dx_old - end if - ja=floor((lat0-lat00_old)/dy_old)+1 ! left bottom corner y coordinate - jb=ja+1 ! right top corner y coordinate - lata=(ja-1)*dy_old+lat00_old ! latitude of left bottom corner - latb=lata+dy_old - - if( ia.lt.1 .or. ia.gt.im_gcm_old .or. & - ib.lt.1 .or. ib.gt.im_gcm_old .or. & - ja.lt.1 .or. ja.gt.jm_gcm_old .or. & - jb.lt.1 .or. jb.gt.jm_gcm_old ) then - print *, 'Warning, bad indicies!' - print *, 'New Land variable: ',n,ia,ib,ja,jb - stop - endif - - if (modulo(n, 1000).eq.1 .or. n.eq.qtile) then - write (9,*) - write (9,*) n, lona, lon0, lonb, ia, ib - write (9,*) n, lata, lat0, latb, ja, jb - end if - corners_lookup(n,1)=ia - corners_lookup(n,2)=ib - corners_lookup(n,3)=ja - corners_lookup(n,4)=jb - waa=sqrt((lat0-lata)**2+(lon0-lona)**2) - wab=sqrt((lat0-lata)**2+(lon0-lonb)**2) - wba=sqrt((lat0-latb)**2+(lon0-lona)**2) - wbb=sqrt((lat0-latb)**2+(lon0-lonb)**2) - wsum=waa+wab+wba+wbb - weights_lookup(n,1)=waa - weights_lookup(n,2)=wab - weights_lookup(n,3)=wba - weights_lookup(n,4)=wbb - write(*, 50, advance=trim(flag)) bak, floor(float(n)/float(nland_new)*100) -end do - -allocate(newallvars(nland_new, allrecs)) -! new allvars allocated by number of new land tiles X number of total restart records -write(*,*) -write(*,*) '---------------------------------------------------------------------' -write(*,*) 'Interpolating prognostic records to new tile definitions' -write(9,*) -write(9,*) '---------------------------------------------------------------------' -write(9,*) 'Interpolating prognostic records to new tile definitions' - write(*, 90, advance=trim(flag)) - write(*, 50, advance=trim(flag)) bak, 0 - -do v=31, allrecs - do n=1, nland_new - ia=corners_lookup(n,1) - ib=corners_lookup(n,2) - ja=corners_lookup(n,3) - jb=corners_lookup(n,4) - waa=weights_lookup(n,1) - wbb=weights_lookup(n,4) - wab=weights_lookup(n,2) - wba=weights_lookup(n,3) - wsum=0 - tempval=0 - vaa=oldvargrids(ia,ja, v) - vbb=oldvargrids(ib,jb, v) - vab=oldvargrids(ia,jb, v) - vba=oldvargrids(ib,ja, v) - if (abs(vaa-ESMF_MISSING) .gt. tol) then - tempval=tempval+vaa*waa - wsum=waa+wsum - end if - if (abs(vab-ESMF_MISSING) .gt. tol) then - tempval=tempval+vab*wab - wsum=wab+wsum - end if - if (abs(vba-ESMF_MISSING) .gt. tol) then - tempval=tempval+vba*wba - wsum=wsum+wba - end if - if (abs(vbb-ESMF_MISSING) .gt. tol) then - tempval=tempval+vbb*wbb - wsum=wsum+wbb - end if - if (abs(wsum) .lt. tol) then - dmin = 1e15 - nmin = 0 - do nn = 1,nland_old - dist = sqrt( (lats_old(nn)-lats_new(n))**2 & - + (lons_old(nn)-lons_new(n))**2 ) - if( dist.lt.dmin ) then - nmin = nn - dmin = dist - endif - enddo - tempval=oldallvars(nmin,v) ! Find nearest old tile to new tile - print *, 'NewVal = ',tempval,' nmin = ',nmin,' loc = ',v - print *, 'newlat = ',lats_new(n),' oldlat = ',lats_old(nmin) - print *, 'newlon = ',lons_new(n),' oldlon = ',lons_old(nmin) - print * - else - tempval=tempval/(1.0*wsum) - end if - newallvars(n, v)=tempval - if (modulo(n, 1000) .eq. 1) then - write(9,*) - write(9,*) n, 'Interpolation summary' - write(9,*) n, 'Weights:', waa, wab, wba, wbb - write(9,*) n, 'Values:', vaa, vab, vba, vbb - write(9,*) n, 'Results:', tempval, wsum - end if - end do - - write(*,*) v - write(*, 50, advance=trim(flag)) bak, floor((float(v-31)/float(allrecs-31)*100)) -end do - -! I am now finished with the old tiles, get rid of them -deallocate(oldprogvars, oldparmvars, oldallvars) -deallocate(corners_lookup, weights_lookup) - -! ------------------------------------------------------------------------------- -! 6. Create the restart from stored values -! a. 29 Sarith tilespace records from his parameter files -! b. The vegetation type from Sarith's mosaic_veg_typ_file -! (I have used the PRIMARY veg type for this work, as opposed -! to the second one that also has a fraction. I am assuming that -! the catchment fraction is totally composed of the PRIMARY veg type) -! c. The modified/regridded prognostic variables that have been regridded -! At this point, the variable newallvars contains ALL records for the -! restart, including estimates of Sarith's parameters based upon -! the old values interpolated from the old restart. These are skipped, but -! might be useful for comparison in a debugging situation -! ------------------------------------------------------------------------------- - -open(unit=41, file=trim(new_restart),form='unformatted') -open(unit=66, file='new_catch.dat' ,form='unformatted') - -! replace the old interpolated parameters in newallvars with the new Sarith ones - - write(9,*) ' Min/Max for ARS1: ', minval(ARS1), maxval(ARS1) - write(9,*) ' Min/Max for ARS2: ', minval(ARS2), maxval(ARS2) - write(9,*) ' Min/Max for ARS3: ', minval(ARS3), maxval(ARS3) - -newallvars(:,1)=BF1 -newallvars(:,2)=BF2 -newallvars(:,3)=BF3 -newallvars(:,4)=VGWMAX -newallvars(:,5)=CDCR1 -newallvars(:,6)=CDCR2 -newallvars(:,7)=PSIS -newallvars(:,8)=BEE -newallvars(:,9)=POROS -newallvars(:,10)=WPWET -newallvars(:,11)=COND -newallvars(:,12)=GNU -newallvars(:,13)=ARS1 -newallvars(:,14)=ARS2 -newallvars(:,15)=ARS3 -newallvars(:,16)=ARA1 -newallvars(:,17)=ARA2 -newallvars(:,18)=ARA3 -newallvars(:,19)=ARA4 -newallvars(:,20)=ARW1 -newallvars(:,21)=ARW2 -newallvars(:,22)=ARW3 -newallvars(:,23)=ARW4 -newallvars(:,24)=TSA1 -newallvars(:,25)=TSA2 -newallvars(:,26)=TSB1 -newallvars(:,27)=TSB2 -newallvars(:,28)=ATAU2 -newallvars(:,29)=BTAU2 -newallvars(:,30)=ITY0 - -write(*,*) -write(*,*) '---------------------------------------------------------------------' -write(*,*) 'Writing new restart' -write(9,*) -write(9,*) '---------------------------------------------------------------------' -write(9,*) 'Writing new restart' - -loc = 0 -do v=1,numrecs - nta = 1 - if( ttlookup(v) ) nta = numsubtiles - allocate( dumtile(nland_new,nta) ) - do nn = 1,nta - loc = loc+1 - dumtile(:,nn) = newallvars(:,loc) - write (66) dumtile(:,nn) ! Write Grads-Formatted Catchment File - enddo - write (41) dumtile - write(9,*) 'NEW RESTART RECORD #', v , ' Size = ',size(dumtile) - deallocate ( dumtile ) -enddo -close(41) - -loc = 0 -do n=1,numrecs - nta = 1 - if( ttlookup(n) ) nta = numsubtiles - do nn = 1,nta - loc = loc+1 - if( loc.le.numparmrecs ) then - write(9,*) ' Transferred new parameter (',n,',',nn,') ', & - minval(newallvars(:,loc)), maxval(newallvars(:,loc)) - else - write(9,*) ' Transferred new prognostic (',n,',',nn,') ', & - minval(newallvars(:,loc)), maxval(newallvars(:,loc)) - endif - enddo -enddo - - -! ------------------------------------------------------------------------------- -! 7. Save a gridded copy of the new restart on rectangular grid found in the -! new .til file definitions. This can be used to check the results. -! ------------------------------------------------------------------------------- - -open(unit=42, file=trim(new_diag_grids),form='unformatted') - -allocate( tmp_sum(im_gcm_new, jm_gcm_new)) -allocate( tmp_wgt(im_gcm_new, jm_gcm_new)) -allocate( dumgrid(im_gcm_new, jm_gcm_new)) - -loc = 0 -do v=1, numrecs - nta = 1 - if( ttlookup(v) ) nta = numsubtiles - do nn = 1,nta - loc = loc+1 - tmp_sum(:,:)=0.0 - tmp_wgt(:,:)=0.0 - do n=1, nland_new - val0=newallvars(n,loc) - ii0=ii_new(n) - jj0=jj_new(n) - fr0=fr_new(n) - if (abs(val0-ESMF_MISSING) .gt. tol) then - tmp_sum(ii0,jj0)=tmp_sum(ii0,jj0)+fr0*val0 - tmp_wgt(ii0,jj0)=tmp_wgt(ii0,jj0)+fr0 - endif - enddo - do i=1,im_gcm_new - do j=1,jm_gcm_new - if (tmp_wgt(i,j) .gt. tol) then - dumgrid(i,j)=tmp_sum(i,j)/tmp_wgt(i,j) - else - dumgrid(i,j)=ESMF_MISSING - endif - enddo - enddo - write (42) dumgrid - enddo -enddo -close(42) - -deallocate(tmp_sum) -deallocate(tmp_wgt) -deallocate( dumgrid ) - -deallocate(BF1, BF2, BF3, VGWMAX) -deallocate(CDCR1, CDCR2, PSIS, BEE) -deallocate(POROS, WPWET, COND, GNU) -deallocate(ARS1, ARS2, ARS3) -deallocate(ARA1, ARA2, ARA3) -deallocate(ARA4, ARW1, ARW2, ARW3, ARW4) -deallocate(TSA1, TSA2, TSB1, TSB2) -deallocate(DP2BR, ATAU2, BTAU2) -deallocate(ITY0, ity_int) - -deallocate(lats_old) -deallocate(lons_old) -deallocate(fr_old) -deallocate(ii_old) -deallocate(jj_old) -deallocate(lats_new) -deallocate(lons_new) -deallocate(fr_new) -deallocate(ii_new) -deallocate(jj_new) -deallocate(ttlookup) - -40 FORMAT(' Percent tile definitions read: ') -50 FORMAT(A4, I3.3, '%') -60 FORMAT(' Percent MODIS data read: ') -70 FORMAT(' Percent restart read: ') -80 FORMAT(' Percent Sarith catchment parameters read: ') -90 FORMAT(' Percent completed: ') -END diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/obsolete/mk_vegdyn_restart b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/obsolete/mk_vegdyn_restart deleted file mode 100755 index 86e90e73a..000000000 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/obsolete/mk_vegdyn_restart +++ /dev/null @@ -1,23 +0,0 @@ -#!/bin/csh - -setenv ARCH `uname` -setenv LANDIR /land/l_data/geos5/bcs/SiB2_V2 -setenv HOMDIR /home1/ltakacs/catchment -setenv WRKDIR $HOMDIR/wrk -cd $WRKDIR - -setenv rslv 1080x721 -setenv dateline DC -setenv nland 374925 # Note, check mk_catch LOG file for number of land tiles - - -if( $ARCH == 'IRIX64' ) then - f90 -o mk_vegdyn_restart.x $HOMDIR/mk_vegdyn_restart.F90 -endif - -if( $ARCH == 'OSF1' ) then - f90 -o mk_vegdyn_restart.x -convert big_endian -assume byterecl $HOMDIR/mk_vegdyn_restart.F90 -endif - -mk_vegdyn_restart.x - diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/obsolete/mk_vegdyn_restart.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/obsolete/mk_vegdyn_restart.F90 deleted file mode 100755 index 849e9f8e4..000000000 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/obsolete/mk_vegdyn_restart.F90 +++ /dev/null @@ -1,54 +0,0 @@ -PROGRAM mk_vegdyn_internal -implicit none -real, allocatable :: dummy(:),ity0(:) -integer,allocatable :: ity0_int(:) -real :: filler, dum0 -integer :: vvv -integer :: bi,li -integer :: nland, nt, index, id, dum -character*256 outpath, sarithdir, dateline, restag, vegname, numland -character*256 landir - -!--------------------------------------------------------------------------- - call GETENV ( 'LANDIR' , landir ) - call GETENV ( 'rslv' , restag ) - call GETENV ( 'dateline', dateline ) - call GETENV ( 'nland' , numland ) - read(numland,*)nland - -outpath = 'vegdyn_internal_restart.' // trim(restag) // '_' // trim(dateline) -!--------------------------------------------------------------------------- - -allocate(dummy (nland)) -allocate(ity0 (nland)) -allocate(ity0_int(nland)) - -dummy(:)=-999.0 -sarithdir = trim(landir) // '/' // trim(dateline) // '/FV_' // trim(restag) // '/' -vegname = trim(sarithdir)//'mosaic_veg_typs_fracs' -write (*,*) 'Reading '//vegname - -open(unit=21, file=trim(vegname),form='formatted') -DO nt=1,nland -! read (21, *) index, id, ity0_int(nt), dum, dum0, dum0, dum0 - read (21, *) index, id, ity0_int(nt), dum, dum0, dum0 ! version 2 doesn't have frc3 - print *, ity0_int(nt) -ENDDO -ity0=ity0_int*1.0 -close(21) - - -open(unit=30, file=trim(outpath),form='unformatted') -! write out dummy lai_prev, lai_next, grn_prev, grn_next -print *, ' VEGTYPES', minval(ity0), maxval(ity0) -write (30) dummy -write (30) dummy -write (30) dummy -write (30) dummy -write (30) ity0 -close (30) -deallocate(ity0) -deallocate(ity0_int) -deallocate(dummy) -END - diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/obsolete/new_catch.ctl b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/obsolete/new_catch.ctl deleted file mode 100755 index b48983d75..000000000 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/obsolete/new_catch.ctl +++ /dev/null @@ -1,73 +0,0 @@ -dset wrk/new_catch.dat -options sequential template big_endian -undef -9999.0 -xdef 45147 linear 1 1 -ydef 1 linear 1 1 -zdef 4 linear 1 1 -tdef 1 linear jan1900 1mo -* -VARS 63 -var01 0 99 topo_baseflow_param_1 -var02 0 99 topo_baseflow_param_2 -var03 0 99 topo_baseflow_param_3 -var04 0 99 max_rootzone_water_content -var05 0 99 moisture_threshold -var06 0 99 max_water_content_unsat_zone -var07 0 99 saturated_matrix_potential -var08 0 99 clapp_hornberger_b -var09 0 99 soil_porosity -var10 0 99 wetness_at_wilting_point -var11 0 99 sfc_sat_hydraulic_conduct -var12 0 99 vertical_transmissivity -var13 0 99 wetness_param_1 -var14 0 99 wetness_param_2 -var15 0 99 wetness_param_3 -var16 0 99 shape_param_1 -var17 0 99 shape_param_2 -var18 0 99 shape_param_3 -var19 0 99 shape_param_4 -var20 0 99 min_theta_1 -var21 0 99 min_theta_2 -var22 0 99 min_theta_3 -var23 0 99 min_theta_4 -var24 0 99 water_transfer_1 -var25 0 99 water_transfer_2 -var26 0 99 water_transfer_3 -var27 0 99 water_transfer_4 -var28 0 99 soil_param_1 -var29 0 99 soil_param_2 -var30 0 99 vegetation_type -var31 4 99 canopy_temperature_1,2,3,4 -var32 4 99 canopy_specific_humidity_1,2,3,4 -var33 0 99 interception_reservoir_capac -var34 0 99 catchment_deficit -var35 0 99 root_zone_excess -var36 0 99 surface_excess -var37 0 99 soil_heat_content_layer1 -var38 0 99 soil_heat_content_layer2 -var39 0 99 soil_heat_content_layer3 -var40 0 99 soil_heat_content_layer4 -var41 0 99 soil_heat_content_layer5 -var42 0 99 soil_heat_content_layer6 -var43 0 99 mean_catchment_temp_incl_snow -var44 0 99 water_eq_snow_layer1 -var45 0 99 water_eq_snow_layer2 -var46 0 99 water_eq_snow_layer3 -var47 0 99 heat_content_snow_layer1 -var48 0 99 heat_content_snow_layer2 -var49 0 99 heat_content_snow_layer3 -var50 0 99 snow_depth_layer1 -var51 0 99 snow_depth_layer2 -var52 0 99 snow_depth_layer3 -var53 4 99 surface_heat_exchange_coefficient_1,2,3,4 -var54 4 99 surface_momentum_exchange_coefficient_1,2,3,4 -var55 4 99 surface_moisture_exchange_coefficient_1,2,3,4 -var56 4 99 subtile_fractions_1,2,3,4 -var57 0 99 observed_albedo_minimum_previous -var58 0 99 observed_albedo_minimum_next -var59 0 99 observed_albedo_mean_previous -var60 0 99 observed_albedo_mean_next -var61 0 99 observed_albedo_maxmindif_previous -var62 0 99 observed_albedo_maxmindir_next -var63 4 99 vertical_velocity_scale_squared_1,2,3,4 -ENDVARS diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/obsolete/newcatch.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/obsolete/newcatch.F90 deleted file mode 100644 index 0ad4f26e3..000000000 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/obsolete/newcatch.F90 +++ /dev/null @@ -1,91 +0,0 @@ -#define VERIFY_(A) if(A /=0)then;print *,'ERROR code',A,'at',__LINE__;call exit(3);endif - -program newcatch - implicit none - -#ifndef __GFORTRAN__ - integer*4 :: iargc - external :: iargc - integer*8 :: ftell - external :: ftell -#endif - character(256) :: str, f_in, f_out - - integer :: m - integer :: status - integer*8 :: bpos, epos, rsize - real, allocatable :: a(:) - -! Begin - - if (iargc() /= 2) then - call getarg(0,str) - write(*,*) "Usage:",trim(str)," " - call exit(2) - end if - - call getarg(1,f_in) - - open(unit=10, file=trim(f_in), form='unformatted') - -! Count the records in the files -! ------------------------------ -! Valid numbers are: -! 61 - old catch_internal_restart -! 57 - old catch_internal_restart - m=0 - do while(.true.) - read(10, end=50, err=200) ! skip to next record - m = m+1 - end do -50 continue - rewind(10) - - if (m == 57) then - print *,'WARNING: this file contains ', m, ' records and appears to have been already convered' - print *,'Refuse to convert!' - print *,'Exiting ...' - call exit(1) - else if (m /= 61) then - print *,'ERROR: this file contains ',m, & - ' records and does not appear to be a valid catchment internal restart' - print *,'Exiting ...' - call exit(2) - end if - -! Open the output file -! -------------------- - call getarg(2,f_out) - open(unit=20, file=trim(f_out), form='unformatted') - - m=0 - bpos=0 - do while(.true.) - m = m+1 - read(10, end=100, err=200) ! skip to next record - epos = ftell(10) ! ending position of file pointer - backspace(10) - - rsize = (epos-bpos)/4-2 ! record size (in 4 byte words; - bpos = epos - allocate(a(rsize), stat=status) - VERIFY_(status) - read (10) a - if (m < 57 .or. m > 60) then - print *,'Writing record ',m - write(20) a - else - print *,'Skipping record ',m - end if - deallocate(a) - end do -100 continue - close(10) - close(20) - stop - -! If we are here something must have gone wrong -200 VERIFY_(200) - -end program newcatch - diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/obsolete/newvegdyn.f90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/obsolete/newvegdyn.f90 deleted file mode 100644 index beafa8424..000000000 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/obsolete/newvegdyn.f90 +++ /dev/null @@ -1,57 +0,0 @@ -program newvegdyn - implicit none - - real, pointer :: var(:) - - integer :: i, bpos, epos, status - integer :: rsize - character(256) :: str, f_in, f_out - integer*4 :: ftell - external :: ftell - - integer*4 :: iargc - external :: iargc - -! Begin - - if (iargc() /= 2) then - call getarg(0,str) - write(*,*) "Usage:",trim(str)," " - call exit(2) - end if - - call getarg(1,f_in) - call getarg(2,f_out) - - open(unit=10, file=trim(f_in), form='unformatted') - open(unit=20, file=trim(f_out), form='unformatted') - - print *,'New Restart Format for File: ',trim(f_in) - - bpos=0 - read(10, err=200) ! skip to next record - epos = ftell(10) ! ending position of file pointer - - rsize = (epos-bpos)/4-2 ! record size (in 4 byte words; - ! 2 is the number of fortran control words) - allocate(var(rsize), stat=status) - if (status /= 0) then - print *, 'Error: allocation ', rsize, ' failed!' - call exit(11) - end if - - read(10, err=200) ! skip to next record - read(10, err=200) ! skip to next record - read(10, err=200) ! skip to next record -! alltogather we skip 4 record - read (10) var - write(20) var - deallocate(var) - close(10) - close(20) - stop - -200 print *,'Error reading file ',trim(f_in) - call exit(11) - -end diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/obsolete/old_catch.ctl b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/obsolete/old_catch.ctl deleted file mode 100755 index b98d32163..000000000 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/obsolete/old_catch.ctl +++ /dev/null @@ -1,73 +0,0 @@ -dset wrk/old_catch.dat -options sequential template big_endian -undef -9999.0 -xdef 76847 linear 1 1 -ydef 1 linear 1 1 -zdef 4 linear 1 1 -tdef 1 linear jan1900 1mo -* -VARS 63 -var01 0 99 topo_baseflow_param_1 -var02 0 99 topo_baseflow_param_2 -var03 0 99 topo_baseflow_param_3 -var04 0 99 max_rootzone_water_content -var05 0 99 moisture_threshold -var06 0 99 max_water_content_unsat_zone -var07 0 99 saturated_matrix_potential -var08 0 99 clapp_hornberger_b -var09 0 99 soil_porosity -var10 0 99 wetness_at_wilting_point -var11 0 99 sfc_sat_hydraulic_conduct -var12 0 99 vertical_transmissivity -var13 0 99 wetness_param_1 -var14 0 99 wetness_param_2 -var15 0 99 wetness_param_3 -var16 0 99 shape_param_1 -var17 0 99 shape_param_2 -var18 0 99 shape_param_3 -var19 0 99 shape_param_4 -var20 0 99 min_theta_1 -var21 0 99 min_theta_2 -var22 0 99 min_theta_3 -var23 0 99 min_theta_4 -var24 0 99 water_transfer_1 -var25 0 99 water_transfer_2 -var26 0 99 water_transfer_3 -var27 0 99 water_transfer_4 -var28 0 99 soil_param_1 -var29 0 99 soil_param_2 -var30 0 99 vegetation_type -var31 4 99 canopy_temperature_1,2,3,4 -var32 4 99 canopy_specific_humidity_1,2,3,4 -var33 0 99 interception_reservoir_capac -var34 0 99 catchment_deficit -var35 0 99 root_zone_excess -var36 0 99 surface_excess -var37 0 99 soil_heat_content_layer1 -var38 0 99 soil_heat_content_layer2 -var39 0 99 soil_heat_content_layer3 -var40 0 99 soil_heat_content_layer4 -var41 0 99 soil_heat_content_layer5 -var42 0 99 soil_heat_content_layer6 -var43 0 99 mean_catchment_temp_incl_snow -var44 0 99 water_eq_snow_layer1 -var45 0 99 water_eq_snow_layer2 -var46 0 99 water_eq_snow_layer3 -var47 0 99 heat_content_snow_layer1 -var48 0 99 heat_content_snow_layer2 -var49 0 99 heat_content_snow_layer3 -var50 0 99 snow_depth_layer1 -var51 0 99 snow_depth_layer2 -var52 0 99 snow_depth_layer3 -var53 4 99 surface_heat_exchange_coefficient_1,2,3,4 -var54 4 99 surface_momentum_exchange_coefficient_1,2,3,4 -var55 4 99 surface_moisture_exchange_coefficient_1,2,3,4 -var56 4 99 subtile_fractions_1,2,3,4 -var57 0 99 observed_albedo_minimum_previous -var58 0 99 observed_albedo_minimum_next -var59 0 99 observed_albedo_mean_previous -var60 0 99 observed_albedo_mean_next -var61 0 99 observed_albedo_maxmindif_previous -var62 0 99 observed_albedo_maxmindir_next -var63 4 99 vertical_velocity_scale_squared_1,2,3,4 -ENDVARS diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/obsolete/replace_params.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/obsolete/replace_params.F90 deleted file mode 100644 index 09fa5c26b..000000000 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/obsolete/replace_params.F90 +++ /dev/null @@ -1,296 +0,0 @@ -PROGRAM replace_params - implicit none - - integer :: nland_old, nland_new - character*400 :: tilefile - character*400 :: old_restart, new_restart, sarithpath - - real, allocatable :: var1(:),var2(:,:) - integer :: numrecs, allrecs, numparmrecs - - real, allocatable :: BF1(:), BF2(:), BF3(:), VGWMAX(:) - real, allocatable :: CDCR1(:), CDCR2(:), PSIS(:), BEE(:) - real, allocatable :: POROS(:), WPWET(:), COND(:), GNU(:) - real, allocatable :: ARS1(:), ARS2(:), ARS3(:) - real, allocatable :: ARA1(:), ARA2(:), ARA3(:), ARA4(:) - real, allocatable :: ARW1(:), ARW2(:), ARW3(:), ARW4(:) - real, allocatable :: TSA1(:), TSA2(:), TSB1(:), TSB2(:) - real, allocatable :: ATAU2(:), BTAU2(:), ITY0(:) - integer, allocatable :: ity_int(:) - integer :: ity2, nmin, type - real, allocatable :: DP2BR(:), tmp_wgt(:,:), tmp_sum(:,:) - real :: zdep1, zdep2, zdep3, zmet, term1, term2 - integer :: catindex21, catindex22, catindex23 - integer :: catindex24, catindex25, catindex26 - real :: frc1, frc2, rdum - integer :: catid, checksum, ntilesold - integer :: ii0, jj0, i,j,n, idum,II - integer :: IARGC - - - II = iargc() - - if(II /= 4) then - print *, "Wrong Number of arguments: ", ii - call exit(66) - end if - - call getarg(1,old_restart) - call getarg(2,new_restart) - call getarg(3,tilefile) - call getarg(4,sarithpath) - - sarithpath = "/land/l_data/geos5/bcs/SiB2_V2/DC/"//trim(sarithpath) - - numrecs = 61 - numparmrecs = 30 - - ! read .til file - - open (10,file=trim(tilefile),status='old',form='formatted') - read (10,*) ntilesold - read (10,*) - read (10,*) - read (10,*) - read (10,*) - read (10,*) - read (10,*) - read (10,*) - nland_old=0 - do n = 1,ntilesold - read(10,*) type - if (type == 100) then - nland_old=nland_old+1 - endif - end do - close (10,status='keep') - - print *, ' Number of land tiles = ', nland_old - - nland_new = nland_old - - allocate ( BF1(nland_new), BF2 (nland_new), BF3(nland_new) ) - allocate (VGWMAX(nland_new), CDCR1(nland_new), CDCR2(nland_new) ) - allocate ( PSIS(nland_new), BEE(nland_new), POROS(nland_new) ) - allocate ( WPWET(nland_new), COND(nland_new), GNU(nland_new) ) - allocate ( ARS1(nland_new), ARS2(nland_new), ARS3(nland_new) ) - allocate ( ARA1(nland_new), ARA2(nland_new), ARA3(nland_new) ) - allocate ( ARA4(nland_new), ARW1(nland_new), ARW2(nland_new) ) - allocate ( ARW3(nland_new), ARW4(nland_new), TSA1(nland_new) ) - allocate ( TSA2(nland_new), TSB1(nland_new), TSB2(nland_new) ) - allocate ( ATAU2(nland_new), BTAU2(nland_new), DP2BR(nland_new) ) - allocate ( ITY0(nland_new), ity_int(nland_new)) - - - - open(unit=21, file=trim(sarithpath) // '/' //'mosaic_veg_typs_fracs',form='formatted') - open(unit=22, file=trim(sarithpath) // '/' //'bf.dat' ,form='formatted') - open(unit=23, file=trim(sarithpath) // '/' //'soil_param.dat' ,form='formatted') - open(unit=24, file=trim(sarithpath) // '/' //'ar.new' ,form='formatted') - open(unit=25, file=trim(sarithpath) // '/' //'ts.dat' ,form='formatted') - open(unit=26, file=trim(sarithpath) // '/' //'tau_param.dat' ,form='formatted') - - - print *, 'opened units' - - do n=1,nland_new - read (21, *) catindex21, catid, ity_int(n), ity2, frc1, frc2 - ITY0(n)=1.0*ity_int(n) - - read (22, *) catindex22, catid, GNU(n), BF1(n), BF2(n), BF3(n) - - read (23, *) catindex23, catid, idum, idum, BEE(n), PSIS(n), POROS(n), COND(n), WPWET(n), DP2BR(n) - - read (24, *) catindex24, catid, rdum, ARS1(n), ARS2(n), ARS3(n), & - ARA1(n), ARA2(n), ARA3(n), ARA4(n), & - ARW1(n), ARW2(n), ARW3(n), ARW4(n) - - read (25, *) catindex25, catid, rdum, TSA1(n), TSA2(n), TSB1(n), TSB2(n) - - read (26, *) catindex26, catid, ATAU2(n), BTAU2(n), rdum, rdum - - zdep2=1000. - zdep3=amax1(1000.,DP2BR(n)) - if (zdep2 .gt.0.75*zdep3) then - zdep2 = 0.75*zdep3 - end if - zdep1=20. - zmet=zdep3/1000. - - term1=-1.+((PSIS(n)-zmet)/PSIS(n))**((BEE(n)-1.)/BEE(n)) - term2=PSIS(n)*BEE(n)/(BEE(n)-1) - - VGWMAX(n) = POROS(n)*zdep2 - CDCR1(n) = 1000.*POROS(n)*(zmet-(-term2*term1)) - CDCR2(n) = (1.-WPWET(n))*POROS(n)*zdep3 - enddo - - close (21) - close (22) - close (23) - close (24) - close (25) - close (26) - - - print *, ' Doing restarts' - - open(unit=30, file=trim(old_restart),form='unformatted',status='old',convert='little_endian') - open(unit=40, file=trim(new_restart),form='unformatted',status='unknown',convert='little_endian') - - allocate(var1(nland_old)) - allocate(var2(nland_old,4)) - - print *, 'Opened restart files' - print *, 30, trim(old_restart) - print *, 40, trim(new_restart) - - - - write(40) BF1 - read(30) var1 - print *, "BF1",maxval(BF1), maxval(var1), minval(BF1),minval(var1) - - write(40) BF2 - read(30) var1 - print *, "BF2",maxval(BF2), maxval(var1), minval(BF2),minval(var1) - - write(40) BF3 - read(30) var1 - print *, "BF3",maxval(BF3), maxval(var1), minval(BF3),minval(var1) - - write(40) VGWMAX - read(30) var1 - print *, "VGWMAX",maxval(VGWMAX), maxval(var1), minval(VGWMAX),minval(var1) - - write(40) CDCR1 - read(30) var1 - print *, "CDCR1",maxval(CDCR1), maxval(var1), minval(CDCR1),minval(var1) - - write(40) CDCR2 - read(30) var1 - print *, "CDCR2",maxval(CDCR2), maxval(var1), minval(CDCR2),minval(var1) - - write(40) PSIS - read(30) var1 - print *, "PSIS",maxval(PSIS), maxval(var1), minval(PSIS),minval(var1) - - write(40) BEE - read(30) var1 - print *, "BEE",maxval(BEE), maxval(var1), minval(BEE),minval(var1) - - write(40) POROS - read(30) var1 - print *, "POROS ",maxval(POROS ), maxval(var1), minval(POROS ),minval(var1) - - write(40) WPWET - read(30) var1 - print *, "WPWET",maxval(WPWET), maxval(var1), minval(WPWET),minval(var1) - - write(40) COND - read(30) var1 - print *, "COND",maxval(COND), maxval(var1), minval(COND),minval(var1) - - write(40) GNU - read(30) var1 - print *, "GNU",maxval(GNU), maxval(var1), minval(GNU),minval(var1) - - write(40) ARS1 - read(30) var1 - print *, "ARS1",maxval(ARS1), maxval(var1), minval(ARS1),minval(var1) - - write(40) ARS2 - read(30) var1 - print *, "ARS2",maxval(ARS2), maxval(var1), minval(ARS2),minval(var1) - - write(40) ARS3 - read(30) var1 - print *, "ARS3",maxval(ARS3), maxval(var1), minval(ARS3),minval(var1) - - write(40) ARA1 - read(30) var1 - print *, "ARA1",maxval(ARA1), maxval(var1), minval(ARA1),minval(var1) - - write(40) ARA2 - read(30) var1 - print *, "ARA2",maxval(ARA2), maxval(var1), minval(ARA2),minval(var1) - - write(40) ARA3 - read(30) var1 - print *, "ARA3",maxval(ARA3), maxval(var1), minval(ARA3),minval(var1) - - write(40) ARA4 - read(30) var1 - print *, "ARA4",maxval(ARA4), maxval(var1), minval(ARA4),minval(var1) - - write(40) ARW1 - read(30) var1 - print *, "ARW1",maxval(ARW1), maxval(var1), minval(ARW1),minval(var1) - - write(40) ARW2 - read(30) var1 - print *, "ARW2",maxval(ARW2), maxval(var1), minval(ARW2),minval(var1) - - write(40) ARW3 - read(30) var1 - print *, "ARW3",maxval(ARW3), maxval(var1), minval(ARW3),minval(var1) - - write(40) ARW4 - read(30) var1 - print *, "ARW4",maxval(ARW4), maxval(var1), minval(ARW4),minval(var1) - - write(40) TSA1 - read(30) var1 - print *, "TSA1",maxval(TSA1), maxval(var1), minval(TSA1),minval(var1) - - write(40) TSA2 - read(30) var1 - print *, "TSA2",maxval(TSA2), maxval(var1), minval(TSA2),minval(var1) - - write(40) TSB1 - read(30) var1 - print *, "TSB1",maxval(TSB1), maxval(var1), minval(TSB1),minval(var1) - - write(40) TSB2 - read(30) var1 - print *, "TSB2",maxval(TSB2), maxval(var1), minval(TSB2),minval(var1) - - write(40) ATAU2 - read(30) var1 - print *, "ATAU2",maxval(ATAU2), maxval(var1), minval(ATAU2),minval(var1) - - write(40) BTAU2 - read(30) var1 - print *, "BTAU2",maxval(BTAU2), maxval(var1), minval(BTAU2),minval(var1) - - write(40) ITY0 - read(30) var1 - print *, "ITY0",maxval(ITY0), maxval(var1), minval(ITY0),minval(var1) - - - print *, 'Wrote parameters' - - do n=1,2 - read (30) var2 - write(40) var2 - end do - - do n=1,20 - read (30) var1 - write(40) var1 - enddo - - do n=1,4 - read (30) var2 - write(40) var2 - end do - - do n=1,4 - read (30) var1 - write(40) var1 - enddo - - read (30) var2 - write(40) var2 - -END PROGRAM replace_params diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/obsolete/strip_vegdyn.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/obsolete/strip_vegdyn.F90 deleted file mode 100644 index 2fd95d2b8..000000000 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/obsolete/strip_vegdyn.F90 +++ /dev/null @@ -1,78 +0,0 @@ -#define VERIFY_(A) if(A /=0)then;print *,'ERROR code',A,'at',__LINE__;call exit(3);endif - -program checkVegDyn - implicit none - -#ifndef __GFORTRAN__ - integer*4 :: iargc - external :: iargc - integer :: ftell - external :: ftell -#endif - character(256) :: str, f_in, f_out - - integer :: m, n - integer :: status - integer :: bpos, epos, nt - integer, parameter :: unit=10 - real, allocatable :: a(:) - integer, allocatable :: veg(:) - integer :: minVegType - integer :: maxVegType - -! Begin - - if (iargc() /= 2) then - call getarg(0,str) - write(*,*) "Usage:",trim(str)," "," " - call exit(2) - end if - - call getarg(1,f_in) - call getarg(2,f_out) - - open(unit=unit, file=trim(f_in), form='unformatted') - -! count the records - m=0 - do while(.true.) - read(unit, end=50, err=200) ! skip to next record - m = m+1 - end do -50 continue - if (m == 1) then - print *, 'File ', trim(f_in), 'contains only only record. Exiting ...' - goto 100 - end if - - rewind(unit) - - open(unit=20, file=trim(f_out), form='unformatted') - -! determine number of tiles by the size of the first record - - bpos=0 - read(unit, err=200) ! skip to next record - epos = ftell(unit) ! ending position of file pointer - nt = (epos-bpos)/4-2 ! record size (in 4 byte words; - rewind(unit) - - allocate(a(nt), stat=status) - VERIFY_(status) - -! Read and copy first record - read (unit) a - write(20) a - - close(20) - -! clean up -100 continue - close(unit) - stop - -! If we are here, something must have gone wrong -200 VERIFY_(200) - -end program checkVegDyn - diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/GEOS_TurbulenceGridComp.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/GEOS_TurbulenceGridComp.F90 index 0687658e9..8f6b55cef 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/GEOS_TurbulenceGridComp.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/GEOS_TurbulenceGridComp.F90 @@ -185,10 +185,9 @@ module GEOS_TurbulenceGridCompMod logical :: dflt_false = .false. character(len=ESMF_MAXSTR) :: dflt_q = 'Q' -! Beljaars parameters - real, parameter :: & - dxmin_ss = 3000.0, & ! minimum grid length for Beljaars - dxmax_ss = 12000.0 ! maximum grid length for Beljaars + + logical :: DEBUG_TRB + contains !============================================================================= @@ -252,6 +251,9 @@ subroutine SetServices ( GC, RC ) call MAPL_GetObjectFromGC ( GC, MAPL, RC=STATUS) VERIFY_(STATUS) + call MAPL_GetResource( MAPL, DEBUG_TRB, Label="DEBUG_TRB:", default=.FALSE., RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetResource ( MAPL, DO_WAVES, Label="USE_WAVES:", DEFAULT=0, RC=STATUS) VERIFY_(STATUS) @@ -368,6 +370,36 @@ subroutine SetServices ( GC, RC ) RC=STATUS ) VERIFY_(STATUS) + call MAPL_AddImportSpec(GC, & + SHORT_NAME = 'QRTOT', & + LONG_NAME = 'suspended_rain_mixing_ratio', & + UNITS = 'kg kg-1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RESTART = MAPL_RestartSkip, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddImportSpec(GC, & + SHORT_NAME = 'QSTOT', & + LONG_NAME = 'suspended_snow_mixing_ratio', & + UNITS = 'kg kg-1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RESTART = MAPL_RestartSkip, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddImportSpec(GC, & + SHORT_NAME = 'QGTOT', & + LONG_NAME = 'suspended_graupel_mixing_ratio', & + UNITS = 'kg kg-1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RESTART = MAPL_RestartSkip, & + RC=STATUS ) + VERIFY_(STATUS) + call MAPL_AddImportSpec(GC, & SHORT_NAME = 'FCLD', & LONG_NAME = 'cloud_fraction', & @@ -1096,6 +1128,15 @@ subroutine SetServices ( GC, RC ) RC=STATUS ) VERIFY_(STATUS) + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'EDMF_ice_water_source_term', & + UNITS = 'kg kg-1 s-1', & + SHORT_NAME = 'QISRCMF', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RC=STATUS ) + VERIFY_(STATUS) + call MAPL_AddExportSpec(GC, & SHORT_NAME = 'SLFLXMF', & LONG_NAME = 'liquid_water_static_energy_flux_by_MF', & @@ -1455,6 +1496,34 @@ subroutine SetServices ( GC, RC ) RC=STATUS ) VERIFY_(STATUS) + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'trade_inversion_base_pressure', & + UNITS = 'Pa', & + SHORT_NAME = 'TRINVBS', & + DIMS = MAPL_DimsHorzOnly, & + VLOCATION = MAPL_VLocationNone, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'trade_inversion_temperature_jump', & + UNITS = 'K', & + SHORT_NAME = 'TRINVDELT', & + DIMS = MAPL_DimsHorzOnly, & + VLOCATION = MAPL_VLocationNone, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'trade_inversion_frequency', & + UNITS = '1', & + SHORT_NAME = 'TRINVFRQ', & + DIMS = MAPL_DimsHorzOnly, & + VLOCATION = MAPL_VLocationNone, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & LONG_NAME = 'Buoyancy_jump_across_inversion', & UNITS = 'm s-2', & @@ -1860,7 +1929,7 @@ subroutine SetServices ( GC, RC ) call MAPL_AddExportSpec(GC, & SHORT_NAME = 'TKEBUOY', & - LONG_NAME = 'tke_buoyancy_production_from_SHOC', & + LONG_NAME = 'tke_buoyancy_tendency_from_SHOC', & UNITS = 'm+2 s-3', & DIMS = MAPL_DimsHorzVert, & VLOCATION = MAPL_VLocationCenter, RC=STATUS ) @@ -1874,15 +1943,6 @@ subroutine SetServices ( GC, RC ) VLOCATION = MAPL_VLocationCenter, RC=STATUS ) VERIFY_(STATUS) - call MAPL_AddExportSpec(GC, & - SHORT_NAME = 'TKETRANS', & - LONG_NAME = 'tke_transport_from_SHOC', & - UNITS = 'm+2 s-3', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & SHORT_NAME = 'ISOTROPY', & LONG_NAME = 'return_to_isotropy_timescale', & @@ -1939,22 +1999,6 @@ subroutine SetServices ( GC, RC ) VLOCATION = MAPL_VLocationCenter, RC=STATUS ) VERIFY_(STATUS) - call MAPL_AddExportSpec(GC, & - SHORT_NAME = 'BRUNTDRY', & - LONG_NAME = 'Brunt_Vaisala_frequency_from_SHOC', & - UNITS = 's-1', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - SHORT_NAME = 'BRUNTEDGE', & - LONG_NAME = 'Brunt_Vaisala_frequency_from_SHOC', & - UNITS = 's-1', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationEdge, RC=STATUS ) - VERIFY_(STATUS) - call MAPL_AddExportSpec(GC, & LONG_NAME = 'edge_height_above_surface', & SHORT_NAME = 'ZLES', & @@ -2146,34 +2190,13 @@ subroutine SetServices ( GC, RC ) RC=STATUS ) VERIFY_(STATUS) - - call MAPL_AddInternalSpec(GC, & - LONG_NAME = 'sensitivity_of_tendency_to_surface_value_for_s', & - SHORT_NAME = 'DKSS', & - UNITS = 's-1', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, & - RESTART = MAPL_RestartSkip, & - RC=STATUS ) - VERIFY_(STATUS) - call MAPL_AddInternalSpec(GC, & - LONG_NAME = 'sensitivity_of_tendency_to_surface_value_for_q', & - SHORT_NAME = 'DKQQ', & - UNITS = 's-1', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, & - RESTART = MAPL_RestartSkip, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddInternalSpec(GC, & - LONG_NAME = 'sensitivity_of_tendency_to_surface_value_for_u', & - SHORT_NAME = 'DKUU', & - UNITS = 's-1', & + LONG_NAME = 'SHOC_TKE_dissipation_rate', & + SHORT_NAME = 'TKEDISS', & + UNITS = 'J kg-1 s-1', & DIMS = MAPL_DimsHorzVert, & VLOCATION = MAPL_VLocationCenter, & - RESTART = MAPL_RestartSkip, & + RESTART = MAPL_RestartSkip, & RC=STATUS ) VERIFY_(STATUS) @@ -2584,7 +2607,6 @@ subroutine RUN1 ( GC, IMPORT, EXPORT, CLOCK, RC ) real, dimension(:,:,:), pointer :: AKSS, BKSS, CKSS, YS real, dimension(:,:,:), pointer :: AKQQ, BKQQ, CKQQ, YQV,YQL,YQI real, dimension(:,:,:), pointer :: AKUU, BKUU, CKUU, YU,YV - real, dimension(:,:,:), pointer :: DKSS, DKQQ, DKUU ! SHOC-related variables integer :: DO_SHOC, SCM_SL @@ -2760,12 +2782,6 @@ subroutine RUN1 ( GC, IMPORT, EXPORT, CLOCK, RC ) ! edmf variables ! - call MAPL_GetPointer(INTERNAL, DKSS, 'DKSS', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(INTERNAL, DKQQ, 'DKQQ', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(INTERNAL, DKUU, 'DKUU', RC=STATUS) - VERIFY_(STATUS) ! a,b,c and rhs for s call MAPL_GetPointer(INTERNAL, AKSS, 'AKSS', RC=STATUS) VERIFY_(STATUS) @@ -2926,18 +2942,19 @@ subroutine REFRESH(IM,JM,LM,RC) real, dimension(:,:,:), pointer :: TH, U, V, OMEGA, Q, T, RI, DU, RADLW, RADLWC, LWCRT real, dimension(:,: ), pointer :: AREA, VARFLT - real, dimension(:,:,:), pointer :: KH, KM, QLTOT, QITOT, FCLD + real, dimension(:,:,:), pointer :: KH, KM, QLTOT, QITOT, QRTOT, QSTOT, QGTOT, FCLD real, dimension(:,:,:), pointer :: ALH real, dimension(: ), pointer :: PREF real, dimension(IM,JM,1:LM-1) :: TVE, RDZ real, dimension(IM,JM,LM) :: THV, TV, Z, DMI, PLO, QL, QI, QA, TSM, USM, VSM real, dimension(IM,JM,0:LM) :: ZL0 + real, dimension(IM,JM) :: drycblh integer, dimension(IM,JM) :: SMTH_LEV ! real, dimension(:,:,:), pointer :: MFQTSRC, MFTHSRC, MFW, MFAREA real, dimension(:,:,:), pointer :: EKH, EKM, KHLS, KMLS, KHRAD, KHSFC - real, dimension(:,: ), pointer :: BSTAR, USTAR, PPBL, WERAD, WESFC,VSCRAD,KERAD,DBUOY,ZSML,ZCLD,ZRADML,FRLAND + real, dimension(:,: ), pointer :: BSTAR, USTAR, PPBL, WERAD, WESFC,VSCRAD,KERAD,DBUOY,ZSML,ZCLD,ZRADML,FRLAND,TRINVBS,TRINVFRQ,TRINVDELT real, dimension(:,: ), pointer :: TCZPBL => null() real, dimension(:,: ), pointer :: ZPBL2 => null() real, dimension(:,: ), pointer :: ZPBL10P => null() @@ -2959,11 +2976,11 @@ subroutine REFRESH(IM,JM,LM,RC) real, dimension(:,:,:), pointer :: AKQODT, CKQODT real, dimension(:,:,:), pointer :: AKVODT, CKVODT - real, dimension(:,:,:), pointer :: LSHOC,BRUNTSHOC,BRUNTDRY, BRUNTEDGE,ISOTROPY, & + real, dimension(:,:,:), pointer :: LSHOC,BRUNTSHOC,ISOTROPY, & LSHOC1,LSHOC2,LSHOC3, & SHOCPRNUM,& - TKEBUOY,TKESHEAR,TKEDISS,TKETRANS, & - SL2, SL3, W2, W3, WQT, WSL, SLQT, W3CANUTO, QT2DIAG,SL2DIAG,SLQTDIAG + TKEBUOY,TKESHEAR,TKEDISS,TKEDISSx, & + SL2, SL3, W2, W3, WSL, SLQT, W3CANUTO, QT2DIAG,SL2DIAG,SLQTDIAG real, dimension(:,:), pointer :: LMIX, edmf_depth ! EDMF variables @@ -2978,10 +2995,10 @@ subroutine REFRESH(IM,JM,LM,RC) edmf_wsl, edmf_qt3, edmf_sl3, & edmf_entx, edmf_tke, slflxmf, & qtflxmf, mfaw, edmf_dqrdt, edmf_dqsdt, & - ssrcmf,qvsrcmf,qlsrcmf + ssrcmf,qvsrcmf,qlsrcmf,qisrcmf real, dimension(IM,JM,0:LM) :: ae3,aw3,aws3,awqv3,awql3,awqi3,awu3,awv3 - real, dimension(IM,JM,1:LM) :: ssrc,qvsrc,qlsrc + real, dimension(IM,JM,1:LM) :: ssrc,qvsrc,qlsrc,qisrc real, dimension(IM,JM) :: zpbl_test @@ -2992,16 +3009,16 @@ subroutine REFRESH(IM,JM,LM,RC) logical :: ALLOC_ZPBL10p, CALC_ZPBL10p logical :: PDFALLOC - real :: LOUIS, ALHFAC, ALMFAC + real :: LOUISKH, LOUISKM, ALHFAC, ALMFAC real :: LAMBDAM, LAMBDAM2 real :: LAMBDAH, LAMBDAH2 - real :: ZKMENV, ZKHENV + real :: ZKHMENV real :: MINTHICK real :: MINSHEAR real :: AKHMMAX - real :: C_B, LAMBDA_B, HGT_SURFACE, LOUIS_MEMORY + real :: FKV_LIM, C_B, LAMBDA_B, LOUIS_MEMORY real :: PRANDTLSFC,PRANDTLRAD,BETA_RAD,BETA_SURF,KHRADFAC,TPFAC_SURF,ENTRATE_SURF - real :: PCEFF_SURF, VSCALE_SURF, PERTOPT_SURF, KHSFCFAC_LND, KHSFCFAC_OCN, ZCHOKE + real :: PCEFF_SURF, VSCALE_SURF, KHSFCFAC_LND, KHSFCFAC_OCN real :: SMTH_HGT integer :: I,J,L,LOCK_ON,ITER @@ -3069,7 +3086,7 @@ subroutine REFRESH(IM,JM,LM,RC) real, dimension( IM, JM, LM ) :: QPL,QPI integer :: DO_SHOC, DOPROGQT2, DOCANUTO real :: SL2TUNE, QT2TUNE, SLQT2TUNE, & - QT3_TSCALE, AFRC_TSCALE + SKEW_TGEN, SKEW_TDIS real :: PDFSHAPE real :: lambdadiss @@ -3125,29 +3142,14 @@ subroutine REFRESH(IM,JM,LM,RC) call MAPL_GetPointer(IMPORT,RADLWC, 'RADLWC', RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(IMPORT, QLTOT, 'QLTOT', RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(IMPORT, QITOT, 'QITOT', RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(IMPORT, QRTOT, 'QRTOT', RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(IMPORT, QSTOT, 'QSTOT', RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(IMPORT, QGTOT, 'QGTOT', RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(IMPORT, FCLD, 'FCLD', RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(IMPORT, BSTAR, 'BSTAR', RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(IMPORT, USTAR, 'USTAR', RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(IMPORT,FRLAND, 'FRLAND', RC=STATUS); VERIFY_(STATUS) - if (LM .eq. 72) then - call MAPL_GetResource (MAPL, JASON_TRB, "JASON_TRB:", default=.TRUE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, HGT_SURFACE, "HGT_SURFACE:", default=0.0, RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, PBLHT_OPTION, trim(COMP_NAME)//"_PBLHT_OPTION:", default=4, RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, SMTH_HGT, trim(COMP_NAME)//"_SMTH_HGT:", default=0.0, RC=STATUS); VERIFY_(STATUS) - else - call MAPL_GetResource (MAPL, JASON_TRB, "JASON_TRB:", default=.FALSE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, HGT_SURFACE, "HGT_SURFACE:", default=50.0, RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, PBLHT_OPTION, trim(COMP_NAME)//"_PBLHT_OPTION:", default=3, RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, SMTH_HGT, trim(COMP_NAME)//"_SMTH_HGT:", default=5000.0, RC=STATUS); VERIFY_(STATUS) - endif - - if (JASON_TRB) then - call MAPL_GetResource (MAPL, C_B, trim(COMP_NAME)//"_C_B:", default=6.0, RC=STATUS); VERIFY_(STATUS) - else - call MAPL_GetResource (MAPL, C_B, trim(COMP_NAME)//"_C_B:", default=-30.0, RC=STATUS); VERIFY_(STATUS) - endif - ! Imports for CLASP heterogeneity coupling in EDMF ! call MAPL_GetPointer(IMPORT, MFTHSRC, 'MFTHSRC',RC=STATUS); VERIFY_(STATUS) ! call MAPL_GetPointer(IMPORT, MFQTSRC, 'MFQTSRC',RC=STATUS); VERIFY_(STATUS) @@ -3156,66 +3158,102 @@ subroutine REFRESH(IM,JM,LM,RC) ! Get turbulence parameters from configuration !--------------------------------------------- - call MAPL_GetResource (MAPL, LOUIS, trim(COMP_NAME)//"_LOUIS:", default=5.0, RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, ALHFAC, trim(COMP_NAME)//"_ALHFAC:", default=1.2, RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, ALMFAC, trim(COMP_NAME)//"_ALMFAC:", default=1.2, RC=STATUS); VERIFY_(STATUS) - if (JASON_TRB) then - call MAPL_GetResource (MAPL, LAMBDADISS, trim(COMP_NAME)//"_LAMBDADISS:", default=50.0, RC=STATUS); VERIFY_(STATUS) + if (LM .eq. 72) then + call MAPL_GetResource (MAPL, JASON_TRB, "JASON_TRB:", default=.TRUE., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, PBLHT_OPTION, trim(COMP_NAME)//"_PBLHT_OPTION:", default=4, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, SMTH_HGT, trim(COMP_NAME)//"_SMTH_HGT:", default=0.0, RC=STATUS); VERIFY_(STATUS) else - call MAPL_GetResource (MAPL, LAMBDADISS, trim(COMP_NAME)//"_LAMBDADISS:", default=15.0, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, JASON_TRB, "JASON_TRB:", default=.FALSE., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, PBLHT_OPTION, trim(COMP_NAME)//"_PBLHT_OPTION:", default=3, RC=STATUS); VERIFY_(STATUS) + SMTH_HGT = MAX(2.5,DT/180.0)*100.0 + call MAPL_GetResource (MAPL, SMTH_HGT, trim(COMP_NAME)//"_SMTH_HGT:", default=SMTH_HGT, RC=STATUS); VERIFY_(STATUS) endif - call MAPL_GetResource (MAPL, LAMBDAM, trim(COMP_NAME)//"_LAMBDAM:", default=160.0, RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, LAMBDAM2, trim(COMP_NAME)//"_LAMBDAM2:", default=1.0, RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, LAMBDAH, trim(COMP_NAME)//"_LAMBDAH:", default=160.0, RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, LAMBDAH2, trim(COMP_NAME)//"_LAMBDAH2:", default=1.0, RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, ZKMENV, trim(COMP_NAME)//"_ZKMENV:", default=3000., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, ZKHENV, trim(COMP_NAME)//"_ZKHENV:", default=3000., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, MINTHICK, trim(COMP_NAME)//"_MINTHICK:", default=0.1, RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, MINSHEAR, trim(COMP_NAME)//"_MINSHEAR:", default=0.0030, RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, LAMBDA_B, trim(COMP_NAME)//"_LAMBDA_B:", default=1500., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, AKHMMAX, trim(COMP_NAME)//"_AKHMMAX:", default=500., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, LOCK_ON, trim(COMP_NAME)//"_LOCK_ON:", default=1, RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, PRANDTLSFC, trim(COMP_NAME)//"_PRANDTLSFC:", default=1.0, RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, PRANDTLRAD, trim(COMP_NAME)//"_PRANDTLRAD:", default=0.75, RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, BETA_SURF, trim(COMP_NAME)//"_BETA_SURF:", default=0.25, RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, BETA_RAD, trim(COMP_NAME)//"_BETA_RAD:", default=0.20, RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, KHRADFAC, trim(COMP_NAME)//"_KHRADFAC:", default=0.85, RC=STATUS); VERIFY_(STATUS) if (JASON_TRB) then - call MAPL_GetResource (MAPL, KHSFCFAC_LND, trim(COMP_NAME)//"_KHSFCFAC_LND:", default=0.60, RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, KHSFCFAC_OCN, trim(COMP_NAME)//"_KHSFCFAC_OCN:", default=0.30, RC=STATUS); VERIFY_(STATUS) - else - call MAPL_GetResource (MAPL, KHSFCFAC_LND, trim(COMP_NAME)//"_KHSFCFAC_LND:", default=0.60, RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, KHSFCFAC_OCN, trim(COMP_NAME)//"_KHSFCFAC_OCN:", default=0.60, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, LOUISKH, trim(COMP_NAME)//"_LOUISKH:", default=5.0, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, LOUISKM, trim(COMP_NAME)//"_LOUISKM:", default=5.0, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, ALHFAC, trim(COMP_NAME)//"_ALHFAC:", default=1.2, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, ALMFAC, trim(COMP_NAME)//"_ALMFAC:", default=1.2, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, C_B, trim(COMP_NAME)//"_C_B:", default=6.0, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, FKV_LIM, trim(COMP_NAME)//"_FKV_LIM:", default=10.0, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, LAMBDADISS, trim(COMP_NAME)//"_LAMBDADISS:", default=50.0, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, KHRADFAC, trim(COMP_NAME)//"_KHRADFAC:", default=0.85, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, KHSFCFAC_LND, trim(COMP_NAME)//"_KHSFCFAC_LND:", default=0.60, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, KHSFCFAC_OCN, trim(COMP_NAME)//"_KHSFCFAC_OCN:", default=0.30, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, PRANDTLSFC, trim(COMP_NAME)//"_PRANDTLSFC:", default=1.0, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, PRANDTLRAD, trim(COMP_NAME)//"_PRANDTLRAD:", default=0.75, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, BETA_RAD, trim(COMP_NAME)//"_BETA_RAD:", default=0.20, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, BETA_SURF, trim(COMP_NAME)//"_BETA_SURF:", default=0.25, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, ENTRATE_SURF, trim(COMP_NAME)//"_ENTRATE_SURF:", default=1.5e-3, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, TPFAC_SURF, trim(COMP_NAME)//"_TPFAC_SURF:", default=20.0, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, PCEFF_SURF, trim(COMP_NAME)//"_PCEFF_SURF:", default=0.5, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, LAMBDAM, trim(COMP_NAME)//"_LAMBDAM:", default=1500.0, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, LAMBDAM2, trim(COMP_NAME)//"_LAMBDAM2:", default=1.0, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, LAMBDAH, trim(COMP_NAME)//"_LAMBDAH:", default=4500.0, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, LAMBDAH2, trim(COMP_NAME)//"_LAMBDAH2:", default=1.0, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, ZKHMENV, trim(COMP_NAME)//"_ZKHMENV:", default=3000., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, MINTHICK, trim(COMP_NAME)//"_MINTHICK:", default=2.0, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, MINSHEAR, trim(COMP_NAME)//"_MINSHEAR:", default=0.0030, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, LAMBDA_B, trim(COMP_NAME)//"_LAMBDA_B:", default=1500., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, AKHMMAX, trim(COMP_NAME)//"_AKHMMAX:", default=500., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, LOCK_ON, trim(COMP_NAME)//"_LOCK_ON:", default=1, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, VSCALE_SURF, trim(COMP_NAME)//"_VSCALE_SURF:", default=2.5e-3, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, LOUIS_MEMORY, trim(COMP_NAME)//"_LOUIS_MEMORY:", default=-999., RC=STATUS); VERIFY_(STATUS) + else + call MAPL_GetResource (MAPL, LOUISKH, trim(COMP_NAME)//"_LOUISKH:", default=5.0, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, LOUISKM, trim(COMP_NAME)//"_LOUISKM:", default=5.0, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, ALHFAC, trim(COMP_NAME)//"_ALHFAC:", default=1.0, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, ALMFAC, trim(COMP_NAME)//"_ALMFAC:", default=1.0, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, C_B, trim(COMP_NAME)//"_C_B:", default=-3.0, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, FKV_LIM, trim(COMP_NAME)//"_FKV_LIM:", default=10.0, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, LAMBDADISS, trim(COMP_NAME)//"_LAMBDADISS:", default=15., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, KHRADFAC, trim(COMP_NAME)//"_KHRADFAC:", default=0.85, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, KHSFCFAC_LND, trim(COMP_NAME)//"_KHSFCFAC_LND:", default=1.0, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, KHSFCFAC_OCN, trim(COMP_NAME)//"_KHSFCFAC_OCN:", default=1.0, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, PRANDTLSFC, trim(COMP_NAME)//"_PRANDTLSFC:", default=1.0, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, PRANDTLRAD, trim(COMP_NAME)//"_PRANDTLRAD:", default=0.75, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, BETA_RAD, trim(COMP_NAME)//"_BETA_RAD:", default=0.20, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, BETA_SURF, trim(COMP_NAME)//"_BETA_SURF:", default=0.25, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, ENTRATE_SURF, trim(COMP_NAME)//"_ENTRATE_SURF:", default=1.15e-3,RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, TPFAC_SURF, trim(COMP_NAME)//"_TPFAC_SURF:", default=0.0, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, PCEFF_SURF, trim(COMP_NAME)//"_PCEFF_SURF:", default=0.0, RC=STATUS); VERIFY_(STATUS) + LAMBDAM = (MIN(1.0,300.0/DT)**2)*150.0 ! Critical for INTDIS stability with long DTs + LAMBDAH = (MIN(1.0,300.0/DT)**2)*150.0 ! Critical for INTDIS stability with long DTs + call MAPL_GetResource (MAPL, LAMBDAM, trim(COMP_NAME)//"_LAMBDAM:", default=LAMBDAM, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, LAMBDAM2, trim(COMP_NAME)//"_LAMBDAM2:", default=1.0, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, LAMBDAH, trim(COMP_NAME)//"_LAMBDAH:", default=LAMBDAH, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, LAMBDAH2, trim(COMP_NAME)//"_LAMBDAH2:", default=1.0, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, ZKHMENV, trim(COMP_NAME)//"_ZKHMENV:", default=3000., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, MINTHICK, trim(COMP_NAME)//"_MINTHICK:", default=2.0, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, MINSHEAR, trim(COMP_NAME)//"_MINSHEAR:", default=0.0030, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, LAMBDA_B, trim(COMP_NAME)//"_LAMBDA_B:", default=1500., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, AKHMMAX, trim(COMP_NAME)//"_AKHMMAX:", default=500., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, LOCK_ON, trim(COMP_NAME)//"_LOCK_ON:", default=1, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, VSCALE_SURF, trim(COMP_NAME)//"_VSCALE_SURF:", default=2.5e-3, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, LOUIS_MEMORY, trim(COMP_NAME)//"_LOUIS_MEMORY:", default=-999., RC=STATUS); VERIFY_(STATUS) endif - call MAPL_GetResource (MAPL, TPFAC_SURF, trim(COMP_NAME)//"_TPFAC_SURF:", default=20.0, RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, ENTRATE_SURF, trim(COMP_NAME)//"_ENTRATE_SURF:", default=1.5e-3, RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, PCEFF_SURF, trim(COMP_NAME)//"_PCEFF_SURF:", default=0.5, RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, VSCALE_SURF, trim(COMP_NAME)//"_VSCALE_SURF:", default=2.5e-3, RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, PERTOPT_SURF, trim(COMP_NAME)//"_PERTOPT_SURF:", default=0., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, LOUIS_MEMORY, trim(COMP_NAME)//"_LOUIS_MEMORY:", default=-999., RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource (MAPL, DO_SHOC, trim(COMP_NAME)//"_DO_SHOC:", default=0, RC=STATUS); VERIFY_(STATUS) if (DO_SHOC /= 0) then call MAPL_GetResource (MAPL, SHOCPARAMS%PRNUM, trim(COMP_NAME)//"_SHC_PRNUM:", default=-1.0, RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, SHOCPARAMS%LAMBDA, trim(COMP_NAME)//"_SHC_LAMBDA:", default=0.08, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, SHOCPARAMS%LAMBDA, trim(COMP_NAME)//"_SHC_LAMBDA:", default=0.25, RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource (MAPL, SHOCPARAMS%TSCALE, trim(COMP_NAME)//"_SHC_TSCALE:", default=400., RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource (MAPL, SHOCPARAMS%CKVAL, trim(COMP_NAME)//"_SHC_CK:", default=0.1, RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource (MAPL, SHOCPARAMS%CEFAC, trim(COMP_NAME)//"_SHC_CEFAC:", default=1.0, RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource (MAPL, SHOCPARAMS%CESFAC, trim(COMP_NAME)//"_SHC_CESFAC:", default=4., RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource (MAPL, SHOCPARAMS%LENOPT, trim(COMP_NAME)//"_SHC_LENOPT:", default=3, RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, SHOCPARAMS%LENFAC1, trim(COMP_NAME)//"_SHC_LENFAC1:", default=10.0, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, SHOCPARAMS%LENFAC1, trim(COMP_NAME)//"_SHC_LENFAC1:", default=8.0, RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource (MAPL, SHOCPARAMS%LENFAC2, trim(COMP_NAME)//"_SHC_LENFAC2:", default=2.0, RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, SHOCPARAMS%LENFAC3, trim(COMP_NAME)//"_SHC_LENFAC3:", default=3.0, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, SHOCPARAMS%LENFAC3, trim(COMP_NAME)//"_SHC_LENFAC3:", default=1.0, RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource (MAPL, SHOCPARAMS%BUOYOPT, trim(COMP_NAME)//"_SHC_BUOY_OPTION:", default=2, RC=STATUS); VERIFY_(STATUS) end if call MAPL_GetResource (MAPL, PDFSHAPE, 'PDFSHAPE:', DEFAULT = 1.0 , RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource (MAPL, DOPROGQT2, 'DOPROGQT2:', DEFAULT = 1 , RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource (MAPL, SL2TUNE, 'SL2TUNE:', DEFAULT = 4.0 , RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, QT2TUNE, 'QT2TUNE:', DEFAULT = 5.0 , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, QT2TUNE, 'QT2TUNE:', DEFAULT = 1.0 , RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource (MAPL, SLQT2TUNE, 'SLQT2TUNE:', DEFAULT = 7.0 , RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, QT3_TSCALE, 'QT3_TSCALE:', DEFAULT = 1600.0, RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, AFRC_TSCALE,'AFRC_TSCALE:',DEFAULT = 1600.0, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, SKEW_TDIS, 'SKEW_TDIS:', DEFAULT = 1600.0, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, SKEW_TGEN, 'SKEW_TGEN:', DEFAULT = 900.0, RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource (MAPL, DOCANUTO, 'DOCANUTO:', DEFAULT = 0, RC=STATUS); VERIFY_(STATUS) ! Get pointers from export state... @@ -3229,7 +3267,7 @@ subroutine REFRESH(IM,JM,LM,RC) VERIFY_(STATUS) call MAPL_GetPointer(EXPORT, RI, 'RI', ALLOC=.TRUE., RC=STATUS) VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, DU, 'DU', ALLOC=.TRUE., RC=STATUS) + call MAPL_GetPointer(EXPORT, DU, 'DU', RC=STATUS) VERIFY_(STATUS) call MAPL_GetPointer(EXPORT, EKH, 'EKH', ALLOC=.TRUE., RC=STATUS) VERIFY_(STATUS) @@ -3283,6 +3321,12 @@ subroutine REFRESH(IM,JM,LM,RC) VERIFY_(STATUS) call MAPL_GetPointer(EXPORT, DBUOY, 'DBUOY', RC=STATUS) VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, TRINVBS, 'TRINVBS', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, TRINVDELT, 'TRINVDELT', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, TRINVFRQ, 'TRINVFRQ', RC=STATUS) + VERIFY_(STATUS) call MAPL_GetPointer(EXPORT, VSCRAD, 'VSCRAD', RC=STATUS) VERIFY_(STATUS) call MAPL_GetPointer(EXPORT, VSCsfc, 'VSCSFC', RC=STATUS) @@ -3345,12 +3389,8 @@ subroutine REFRESH(IM,JM,LM,RC) VERIFY_(STATUS) call MAPL_GetPointer(EXPORT, edmf_buoyf, 'EDMF_BUOYF', RC=STATUS) VERIFY_(STATUS) -! call MAPL_GetPointer(EXPORT, edmf_sl2, 'EDMF_SL2', RC=STATUS) -! VERIFY_(STATUS) call MAPL_GetPointer(EXPORT, edmf_slqt, 'EDMF_SLQT', RC=STATUS) VERIFY_(STATUS) -! call MAPL_GetPointer(EXPORT, edmf_qt2, 'EDMF_QT2', RC=STATUS) -! VERIFY_(STATUS) call MAPL_GetPointer(EXPORT, edmf_w2, 'EDMF_W2', RC=STATUS) VERIFY_(STATUS) call MAPL_GetPointer(EXPORT, edmf_w3, 'EDMF_W3', RC=STATUS) @@ -3371,8 +3411,8 @@ subroutine REFRESH(IM,JM,LM,RC) VERIFY_(STATUS) call MAPL_GetPointer(EXPORT, sl2, 'SL2', ALLOC=PDFALLOC, RC=STATUS) VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, wqt, 'WQT', ALLOC=PDFALLOC, RC=STATUS) - VERIFY_(STATUS) +! call MAPL_GetPointer(EXPORT, wqt, 'WQT', ALLOC=PDFALLOC, RC=STATUS) +! VERIFY_(STATUS) call MAPL_GetPointer(EXPORT, wsl, 'WSL', ALLOC=PDFALLOC, RC=STATUS) VERIFY_(STATUS) call MAPL_GetPointer(EXPORT, qt2diag, 'QT2DIAG', ALLOC=PDFALLOC, RC=STATUS) @@ -3387,7 +3427,7 @@ subroutine REFRESH(IM,JM,LM,RC) VERIFY_(STATUS) call MAPL_GetPointer(EXPORT, edmf_tke, 'EDMF_TKE', RC=STATUS) VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, edmf_mfx, 'EDMF_MF', RC=STATUS) + call MAPL_GetPointer(EXPORT, edmf_mfx, 'EDMF_MF', ALLOC=PDFALLOC, RC=STATUS) VERIFY_(STATUS) call MAPL_GetPointer(EXPORT, ssrcmf, 'SSRCMF', RC=STATUS) VERIFY_(STATUS) @@ -3395,6 +3435,8 @@ subroutine REFRESH(IM,JM,LM,RC) VERIFY_(STATUS) call MAPL_GetPointer(EXPORT, qlsrcmf, 'QLSRCMF', RC=STATUS) VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, qisrcmf, 'QISRCMF', RC=STATUS) + VERIFY_(STATUS) call MAPL_GetPointer(EXPORT, edmf_dry_a, 'EDMF_DRY_A', RC=STATUS) VERIFY_(STATUS) call MAPL_GetPointer(EXPORT, edmf_moist_a, 'EDMF_MOIST_A', RC=STATUS) @@ -3423,7 +3465,7 @@ subroutine REFRESH(IM,JM,LM,RC) VERIFY_(STATUS) call MAPL_GetPointer(EXPORT, edmf_moist_qc, 'EDMF_MOIST_QC', RC=STATUS) VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, edmf_entx, 'EDMF_ENTR', RC=STATUS) + call MAPL_GetPointer(EXPORT, edmf_entx, 'EDMF_ENTR', ALLOC=.TRUE., RC=STATUS) VERIFY_(STATUS) call MAPL_GetPointer(EXPORT, edmf_depth, 'EDMF_DEPTH', RC=STATUS) VERIFY_(STATUS) @@ -3435,14 +3477,12 @@ subroutine REFRESH(IM,JM,LM,RC) VERIFY_(STATUS) !========== SHOC =========== - call MAPL_GetPointer(EXPORT, TKEDISS, 'TKEDISS', RC=STATUS) + call MAPL_GetPointer(EXPORT, TKEDISSx, 'TKEDISS', RC=STATUS) VERIFY_(STATUS) call MAPL_GetPointer(EXPORT, TKEBUOY, 'TKEBUOY', RC=STATUS) VERIFY_(STATUS) call MAPL_GetPointer(EXPORT, TKESHEAR,'TKESHEAR', RC=STATUS) VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, TKETRANS,'TKETRANS', RC=STATUS) - VERIFY_(STATUS) call MAPL_GetPointer(EXPORT, ISOTROPY,'ISOTROPY', ALLOC=.TRUE., RC=STATUS) VERIFY_(STATUS) call MAPL_GetPointer(EXPORT, LSHOC, 'LSHOC', RC=STATUS) @@ -3457,13 +3497,10 @@ subroutine REFRESH(IM,JM,LM,RC) VERIFY_(STATUS) call MAPL_GetPointer(EXPORT, BRUNTSHOC, 'BRUNTSHOC', ALLOC=PDFALLOC, RC=STATUS) VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, BRUNTDRY, 'BRUNTDRY', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, BRUNTEDGE, 'BRUNTEDGE', RC=STATUS) - VERIFY_(STATUS) call MAPL_GetPointer(EXPORT, SHOCPRNUM,'SHOCPRNUM', RC=STATUS) VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL, TKEDISS, 'TKEDISS' , RC=STATUS); VERIFY_(STATUS) ! Initialize some arrays LWCRT = RADLW - RADLWC @@ -3471,7 +3508,6 @@ subroutine REFRESH(IM,JM,LM,RC) KH = 0.0 KM = 0.0 RI = 0.0 - DU = 0.0 EKH = 0.0 EKM = 0.0 KHSFC = 0.0 @@ -3504,17 +3540,17 @@ subroutine REFRESH(IM,JM,LM,RC) ALLOC_TCZPBL = .TRUE. endif + do L=0,LM + ZL0(:,:,L) = ZLE(:,:,L) - ZLE(:,:,LM) ! edge height above the surface + enddo + if (SMTH_HGT > 0) then - ! Use Pressure Thickness at the surface to determine index + ! Use Thickness at the surface to determine index SMTH_LEV=LM do L=LM,1,-1 - do J=1,JM - do I=1,IM - if ( (SMTH_LEV(I,J) == LM) .AND. ((ZLE(I,J,L)-ZLE(I,J,LM)) >= SMTH_HGT) ) then - SMTH_LEV(I,J)=L - end if - enddo - enddo + where (ZL0(:,:,L) <= SMTH_HGT .and. ZL0(:,:,L-1) > SMTH_HGT) + SMTH_LEV=L + endwhere enddo else SMTH_LEV=LM-5 @@ -3522,15 +3558,11 @@ subroutine REFRESH(IM,JM,LM,RC) call MAPL_TimerOn(MAPL,"---PRELIMS") - do L=0,LM - ZL0(:,:,L) = ZLE(:,:,L) - ZLE(:,:,LM) ! edge height above the surface - enddo - ! Layer height, pressure, and virtual temperatures !------------------------------------------------- - QL = QLTOT - QI = QITOT + QL = QLTOT+QRTOT + QI = QITOT+QSTOT+QGTOT QA = FCLD Z = 0.5*(ZL0(:,:,0:LM-1)+ZL0(:,:,1:LM)) ! layer height above surface PLO = 0.5*(PLE(:,:,0:LM-1)+PLE(:,:,1:LM)) @@ -3555,16 +3587,13 @@ subroutine REFRESH(IM,JM,LM,RC) VSM = V if (DO_SHOC == 0) then !===> Running 1-2-1 smooth of bottom levels of THV, U and V - if (SMTH_HGT >= 0) then - TSM(:,:,LM) = TSM(:,:,LM-1)*0.25 + TSM(:,:,LM )*0.75 - USM(:,:,LM) = USM(:,:,LM-1)*0.25 + USM(:,:,LM )*0.75 - VSM(:,:,LM) = VSM(:,:,LM-1)*0.25 + VSM(:,:,LM )*0.75 + if (SMTH_HGT > 0) then do J=1,JM do I=1,IM do L=LM-1,SMTH_LEV(I,J),-1 - TSM(I,J,L) = TSM(I,J,L-1)*0.25 + TSM(I,J,L)*0.50 + TSM(I,J,L+1)*0.25 - USM(I,J,L) = USM(I,J,L-1)*0.25 + USM(I,J,L)*0.50 + USM(I,J,L+1)*0.25 - VSM(I,J,L) = VSM(I,J,L-1)*0.25 + VSM(I,J,L)*0.50 + VSM(I,J,L+1)*0.25 + TSM(I,J,L) = THV(I,J,L-1)*0.25 + THV(I,J,L)*0.50 + THV(I,J,L+1)*0.25 + USM(I,J,L) = U(I,J,L-1)*0.25 + U(I,J,L)*0.50 + U(I,J,L+1)*0.25 + VSM(I,J,L) = V(I,J,L-1)*0.25 + V(I,J,L)*0.50 + V(I,J,L+1)*0.25 end do end do end do @@ -3595,26 +3624,29 @@ subroutine REFRESH(IM,JM,LM,RC) ! get updraft constants call MAPL_GetResource (MAPL, DOMF, "EDMF_DOMF:", default=0, RC=STATUS) - + MFPARAMS%DOTRACERS = .false. + if ( DOMF /= 0 ) then ! number of updrafts call MAPL_GetResource (MAPL, MFPARAMS%NUP, "EDMF_NUMUP:", default=10, RC=STATUS) + call MAPL_GetResource (MAPL, MFPARAMS%DOTRACERS, "EDMF_DOTRACERS:", default=.false., RC=STATUS) + ! boundaries for the updraft area (min/max sigma of w pdf) - call MAPL_GetResource (MAPL, MFPARAMS%PWMIN, "EDMF_PWMIN:", default=1., RC=STATUS) + call MAPL_GetResource (MAPL, MFPARAMS%PWMIN, "EDMF_PWMIN:", default=1.2, RC=STATUS) call MAPL_GetResource (MAPL, MFPARAMS%PWMAX, "EDMF_PWMAX:", default=3., RC=STATUS) ! - call MAPL_GetResource (MAPL, MFPARAMS%ENTUFAC, "EDMF_ENTUFAC:", default=1.6, RC=STATUS) + call MAPL_GetResource (MAPL, MFPARAMS%ENTUFAC, "EDMF_ENTUFAC:", default=2.0, RC=STATUS) call MAPL_GetResource (MAPL, MFPARAMS%WA, "EDMF_WA:", default=1.0, RC=STATUS) call MAPL_GetResource (MAPL, MFPARAMS%WB, "EDMF_WB:", default=1.5, RC=STATUS) ! coefficients for surface forcing, appropriate for L137 call MAPL_GetResource (MAPL, MFPARAMS%AlphaW, "EDMF_ALPHAW:", default=0.05, RC=STATUS) call MAPL_GetResource (MAPL, MFPARAMS%AlphaQT, "EDMF_ALPHAQT:", default=1.0, RC=STATUS) - call MAPL_GetResource (MAPL, MFPARAMS%AlphaTH, "EDMF_ALPHATH:", default=1.0, RC=STATUS) + call MAPL_GetResource (MAPL, MFPARAMS%AlphaTH, "EDMF_ALPHATH:", default=1.0, RC=STATUS) ! Entrainment rate options call MAPL_GetResource (MAPL, MFPARAMS%ET, "EDMF_ET:", default=2, RC=STATUS) ! constant entrainment rate - call MAPL_GetResource (MAPL, MFPARAMS%ENT0, "EDMF_ENT0:", default=0.25, RC=STATUS) - call MAPL_GetResource (MAPL, MFPARAMS%ENT0LTS, "EDMF_ENT0LTS:", default=1.2, RC=STATUS) + call MAPL_GetResource (MAPL, MFPARAMS%ENT0, "EDMF_ENT0:", default=0.4, RC=STATUS) + call MAPL_GetResource (MAPL, MFPARAMS%ENT0LTS, "EDMF_ENT0LTS:", default=0.8, RC=STATUS) ! L0 if ET==1 call MAPL_GetResource (MAPL, MFPARAMS%L0, "EDMF_L0:", default=100., RC=STATUS) ! L0fac if ET==2 @@ -3641,6 +3673,9 @@ subroutine REFRESH(IM,JM,LM,RC) ! call MAPL_GetResource (MAPL, EDMF_RHO_QB, "EDMF_RHO_QB:", default=0.5, RC=STATUS) ! call MAPL_GetResource (MAPL, C_KH_MF, "C_KH_MF:", default=0., RC=STATUS) ! call MAPL_GetResource (MAPL, NumUpQ, "EDMF_NumUpQ:", default=1, RC=STATUS) + call MAPL_GetResource (MAPL, MFPARAMS%TREFF, "EDMF_TREFF:", default=100., RC=STATUS) + else + call MAPL_GetResource (MAPL, MFPARAMS%TREFF, "EDMF_TREFF:", default=0., RC=STATUS) end if call MAPL_GetResource(MAPL, SCM_SL, 'SCM_SL:', DEFAULT=0 ) @@ -3693,16 +3728,25 @@ subroutine REFRESH(IM,JM,LM,RC) sh_scm, evap_scm, zeta_scm, & ustar_scm, cu_scm, ct_scm) + cu_scm = 0.015 cu => cu_scm ct => ct_scm cq => ct_scm - ustar_scm = 0.3 ! sqrt(CU*UU/RHOS) -! bstar_scm = (MAPL_GRAV/(RHOS*sqrt(CM*max(UU,1.e-30)/RHOS))) * & -! (CT*(TH-TA-(MAPL_GRAV/MAPL_CP)*DZ)/TA + MAPL_VIREPS*CQ*(QH-QA)) - - ustar => ustar_scm + sh => sh_scm evap => evap_scm + + ustar_scm = sqrt( CU*sqrt(U(:,:,LM)**2+V(:,:,LM)**2+0.01) / RHOE(:,:,LM) ) + + bstar_scm = (MAPL_GRAV/(RHOE(:,:,LM)*ustar_scm)) * & + (SH/MAPL_CP/THV(:,:,LM) + MAPL_VIREPS*EVAP) + + bstar => bstar_scm + ustar => ustar_scm + + + print *,'bstar=',bstar_scm,' ustar=',ustar_scm + call MAPL_TimerOff(MAPL,"---SURFACE") end if @@ -3729,6 +3773,8 @@ subroutine REFRESH(IM,JM,LM,RC) ssrc = 0.0 qvsrc = 0.0 qlsrc = 0.0 + qisrc = 0.0 + IF(DOMF /= 0) then @@ -3745,14 +3791,13 @@ subroutine REFRESH(IM,JM,LM,RC) T, & THL, & THV, & - QT, & Q, & - QL, & - QI, & + QLTOT, & + QITOT, & SH, & EVAP, & - FRLAND, & - ZPBL, & + FRLAND, & + ZPBL, & ! MFTHSRC, MFQTSRC, MFW, MFAREA, & ! CLASP inputs !== Outputs for trisolver == ae3, & @@ -3766,14 +3811,13 @@ subroutine REFRESH(IM,JM,LM,RC) ssrc, & qvsrc, & qlsrc, & + qisrc, & !== Outputs for ADG PDF == mfw2, & mfw3, & mfqt3, & mfsl3, & mfwqt, & -! mfqt2, & -! mfsl2, & mfslqt, & mfwsl, & !== Outputs for SHOC == @@ -3805,14 +3849,13 @@ subroutine REFRESH(IM,JM,LM,RC) if (associated(edmf_moist_a)) edmf_moist_a = edmfmoista if (associated(edmf_buoyf)) edmf_buoyf = buoyf if (associated(edmf_mfx)) edmf_mfx = edmf_mf - if (associated(mfaw)) mfaw = edmf_mf/rhoe + if (associated(mfaw)) mfaw = aw3 !edmf_mf/rhoe if (associated(slflxmf)) slflxmf = (aws3-awql3*mapl_alhl-awqi3*mapl_alhs)/mapl_cp if (associated(qtflxmf)) qtflxmf = awqv3+awql3+awqi3 if (associated(ssrcmf)) ssrcmf = ssrc if (associated(qvsrcmf)) qvsrcmf = qvsrc if (associated(qlsrcmf)) qlsrcmf = qlsrc -! if (associated(edmf_sl2)) edmf_sl2 = mfsl2 -! if (associated(edmf_qt2)) edmf_qt2 = mfqt2 + if (associated(qisrcmf)) qisrcmf = qisrc if (associated(edmf_w2)) edmf_w2 = mfw2 if (associated(edmf_w3)) edmf_w3 = mfw3 if (associated(edmf_qt3)) edmf_qt3 = mfqt3 @@ -3823,6 +3866,15 @@ subroutine REFRESH(IM,JM,LM,RC) if (associated(edmf_tke)) edmf_tke = mftke if (associated(EDMF_FRC)) EDMF_FRC = 0.5*(edmfdrya(:,:,0:LM-1)+edmfdrya(:,:,1:LM) & + edmfmoista(:,:,0:LM-1)+edmfmoista(:,:,1:LM)) + do i = 1,IM + do j = 1,JM + k = LM + do while (edmfdrya(i,j,k).gt.0.01 .and. edmfmoista(i,j,k).lt.1e-4 .and. k.gt.1) + k = k-1 + end do + drycblh(i,j) = ZL0(i,j,k) + end do + end do ELSE ! if there is no mass-flux ae3 = 1.0 @@ -3854,11 +3906,10 @@ subroutine REFRESH(IM,JM,LM,RC) if (associated(mfaw)) mfaw = 0.0 if (associated(ssrcmf)) ssrcmf = 0.0 if (associated(qlsrcmf)) qlsrcmf = 0.0 + if (associated(qisrcmf)) qisrcmf = 0.0 if (associated(qvsrcmf)) qvsrcmf = 0.0 if (associated(slflxmf)) slflxmf = 0.0 if (associated(qtflxmf)) qtflxmf = 0.0 -! if (associated(edmf_sl2)) edmf_sl2 = mfsl2 -! if (associated(edmf_qt2)) edmf_qt2 = mfqt2 if (associated(edmf_w2)) edmf_w2 = mfw2 if (associated(edmf_w3)) edmf_w3 = mfw3 if (associated(edmf_qt3)) edmf_qt3 = mfqt3 @@ -3868,7 +3919,8 @@ subroutine REFRESH(IM,JM,LM,RC) if (associated(edmf_wsl)) edmf_wsl = mfwsl if (associated(edmf_tke)) edmf_tke = mftke if (associated(EDMF_FRC)) EDMF_FRC = 0. - + + drycblh = 0. ENDIF call MAPL_TimerOff(MAPL,"---MASSFLUX") @@ -3909,15 +3961,15 @@ subroutine REFRESH(IM,JM,LM,RC) WTHV2(:,:,1:LM), & BUOYF(:,:,1:LM), & MFTKE(:,:,0:LM), & - ZPBL(:,:), & + DRYCBLH(:,:), & !== Input-Outputs == TKESHOC(:,:,1:LM), & TKH(:,:,1:LM), & !== Outputs == KM(:,:,1:LM), & ISOTROPY(:,:,1:LM), & - !== Diagnostics == ! not used elsewhere TKEDISS, & + !== Diagnostics == ! not used elsewhere TKEBUOY, & TKESHEAR, & LSHOC, & @@ -3931,6 +3983,7 @@ subroutine REFRESH(IM,JM,LM,RC) !== Tuning params == SHOCPARAMS ) + if (associated(TKEDISSx)) TKEDISSx = TKEDISS KH(:,:,1:LM) = TKH(:,:,1:LM) call MAPL_TimerOff (MAPL,name="---SHOC" ,RC=STATUS) @@ -3945,16 +3998,15 @@ subroutine REFRESH(IM,JM,LM,RC) VERIFY_(STATUS) if (DO_SHOC == 0) then - call LOUIS_KS( & - Z,ZL0(:,:,1:LM-1),TSM,USM,VSM,ZPBL, & - KH(:,:,1:LM-1),KM(:,:,1:LM-1), & - RI(:,:,1:LM-1),DU(:,:,1:LM-1), & - LOUIS, MINSHEAR, MINTHICK, & + call LOUIS_KS( IM,JM,LM, & + Z,ZL0,TSM,USM,VSM,ZPBL, & + KH, KM, RI, LOUISKH, LOUISKM, & + MINSHEAR, MINTHICK, & LAMBDAM, LAMBDAM2, & LAMBDAH, LAMBDAH2, & ALHFAC, ALMFAC, & - ZKMENV, ZKHENV, AKHMMAX, & - ALH, KMLS, KHLS ) + ZKHMENV, AKHMMAX, & + DU, ALH, KMLS, KHLS ) end if @@ -4153,7 +4205,7 @@ subroutine REFRESH(IM,JM,LM,RC) PRANDTLSFC, PRANDTLRAD, & BETA_SURF, BETA_RAD, & TPFAC_SURF, ENTRATE_SURF, & - PCEFF_SURF, VSCALE_SURF, PERTOPT_SURF, KHRADFAC, KHSFCFAC_LND, KHSFCFAC_OCN ) + PCEFF_SURF, VSCALE_SURF, KHRADFAC, KHSFCFAC_LND, KHSFCFAC_OCN ) STATUS = cudaGetLastError() @@ -4357,7 +4409,7 @@ subroutine REFRESH(IM,JM,LM,RC) PRANDTLSFC, PRANDTLRAD, & BETA_SURF, BETA_RAD, & TPFAC_SURF, ENTRATE_SURF, & - PCEFF_SURF, VSCALE_SURF, PERTOPT_SURF, KHRADFAC, KHSFCFAC_LND, KHSFCFAC_OCN ) + PCEFF_SURF, VSCALE_SURF, KHRADFAC, KHSFCFAC_LND, KHSFCFAC_OCN ) #endif @@ -4407,7 +4459,7 @@ subroutine REFRESH(IM,JM,LM,RC) end if ! TKE ! Update the higher order moments required for the ADG PDF - if ( (PDFSHAPE.eq.5) .AND. (DO_SHOC /= 0) ) then + if ( (PDFSHAPE.ge.5) ) then SL = T + (MAPL_GRAV*Z - MAPL_ALHL*QLTOT - MAPL_ALHS*QITOT)/MAPL_CP call update_moments(IM, JM, LM, DT, & SH, & ! in @@ -4424,7 +4476,6 @@ subroutine REFRESH(IM,JM,LM,RC) ! edmf_mf(:,:,1:LM)/rhoe(:,:,1:LM), & ! MFQT2, & MFQT3, & -! MFHL2, & MFSL3, & MFW2, & MFW3, & @@ -4440,7 +4491,6 @@ subroutine REFRESH(IM,JM,LM,RC) w2, & w3, & w3canuto, & - wqt, & wsl, & slqt, & qt2diag, & @@ -4450,8 +4500,8 @@ subroutine REFRESH(IM,JM,LM,RC) sl2tune, & qt2tune, & slqt2tune, & - qt3_tscale, & - afrc_tscale, & + skew_tgen, & + skew_tdis, & docanuto ) end if @@ -4701,6 +4751,47 @@ subroutine REFRESH(IM,JM,LM,RC) end if ! SBITOP, SBIFRQ + ! Trade inversion base height + if (associated(TRINVBS)) then + TRINVBS = MAPL_UNDEF + TRINVDELT = MAPL_UNDEF + TRINVFRQ = 0. + do I = 1,IM + do J = 1,JM + K = LM + + do while (PLO(I,J,K).gt.95000.) + K = K-1 + end do + do L = K,1,-1 ! K is first level above 950mb + if (PLO(I,J,L).lt.60000.) exit + + if (T(I,J,L-1).ge.T(I,J,L)) then ! if next level is warmer... + LTOP = L ! L is index of minimum T so far + do while (T(I,J,LTOP).ge.T(I,J,L)) ! find depth of warm layer + LTOP = LTOP-1 + end do + LTOP = LTOP+1 ! LTOP is index of highest level inside warm layer + + if ( MAXVAL(T(I,J,LTOP:L))-T(I,J,L).ge.0.5 .or. & + (MAXVAL(T(I,J,LTOP:L))-T(I,J,L).gt.0.01 .and. PLO(I,J,L)-PLO(I,J,LTOP)>2500.) ) then + + ! only save if DELTA-T exceeds any previous inversion + if ( TRINVFRQ(I,J).eq.0. .or. & + (TRINVFRQ(I,J).ne.0. .and. MAXVAL(T(I,J,LTOP:L))-T(I,J,L).gt.TRINVDELT(I,J)) ) then + TRINVBS(I,J) = PLO(I,J,L) + TRINVDELT(I,J) = MAXVAL(T(I,J,LTOP:L))-T(I,J,L) + TRINVFRQ(I,J) = 1. + end if + + end if + end if ! next level warmer + + end do ! L vert loop + + end do + end do + end if SELECT CASE(PBLHT_OPTION) @@ -4733,28 +4824,34 @@ subroutine REFRESH(IM,JM,LM,RC) KPBL = MAX(KPBL,float(KPBLMIN)) ! Calc KPBL using surface turbulence, for use in shallow scheme - if(associated(KPBL_SC) .OR. associated(ZPBL_SC)) then - KPBL_SC = MAPL_UNDEF - do I = 1, IM - do J = 1, JM + if (associated(KPBL_SC)) then + KPBL_SC = MAPL_UNDEF + do I = 1, IM + do J = 1, JM if (DO_SHOC==0) then temparray(1:LM+1) = KHSFC(I,J,0:LM) else temparray(1:LM+1) = KH(I,J,0:LM) - end if + endif maxkh = maxval(temparray) do L=LM-1,2,-1 - if ( (temparray(L) < 0.1*maxkh) .and. (temparray(L+1) >= 0.1*maxkh) & - .and. (KPBL_SC(I,J) == MAPL_UNDEF ) ) then - KPBL_SC(I,J) = float(L) - end if + if ( (temparray(L) < 0.1*maxkh) .and. (temparray(L+1) >= 0.1*maxkh) & + .and. (KPBL_SC(I,J) == MAPL_UNDEF ) ) then + KPBL_SC(I,J) = float(L) + end if end do if ( KPBL_SC(I,J) .eq. MAPL_UNDEF .or. (maxkh.lt.1.)) then - KPBL_SC(I,J) = float(LM) + KPBL_SC(I,J) = float(LM) endif - if (associated(ZPBL_SC)) ZPBL_SC(I,J) = Z(I,J,KPBL_SC(I,J)) - end do - end do + end do + end do + endif + if (associated(KPBL_SC) .and. associated(ZPBL_SC)) then + do I = 1, IM + do J = 1, JM + ZPBL_SC(I,J) = Z(I,J,KPBL_SC(I,J)) + end do + end do endif if (associated(PPBL)) then @@ -4766,23 +4863,25 @@ subroutine REFRESH(IM,JM,LM,RC) PPBL = MAX(PPBL,PLO(:,:,KPBLMIN)) end if + RHOAW3=RHOE*AW3 ! mass flux (positive) + ! Second difference coefficients for scalars; RDZ is RHO/DZ, DMI is (G DT)/DP ! --------------------------------------------------------------------------- - CKS(:,:,1:LM-1) = -KH(:,:,1:LM-1) * RDZ(:,:,1:LM-1) + CKS(:,:,1:LM-1) = -(KH(:,:,1:LM-1)+MFPARAMS%TREFF*RHOAW3(:,:,1:LM-1)) * RDZ(:,:,1:LM-1) AKS(:,:,1 ) = 0.0 AKS(:,:,2:LM ) = CKS(:,:,1:LM-1) * DMI(:,:,2:LM ) CKS(:,:,1:LM-1) = CKS(:,:,1:LM-1) * DMI(:,:,1:LM-1) CKS(:,:, LM ) = -CT * DMI(:,:, LM ) - ! Fill KH at level LM+1 with CT * RDZ for diagnostic output + ! Fill KH at level LM+1 with CT / RDZ for diagnostic output ! --------------------------------------------------------- KH(:,:,LM) = CT * Z(:,:,LM)*((MAPL_RGAS * TV(:,:,LM))/PLE(:,:,LM)) TKH = KH - ! Water vapor can differ at the surface - !-------------------------------------- + ! Water vapor exchange coefficient can differ at the surface + !----------------------------------------------------------- AKQ = AKS CKQ = CKS @@ -4801,10 +4900,10 @@ subroutine REFRESH(IM,JM,LM,RC) CKV(:,:, LM ) = - CU * DMI(:,:, LM ) EKV(:,:, LM ) = MAPL_GRAV * CU - ! Fill KM at level LM with CU * RDZ for diagnostic output + ! Fill KM at level LM with CU / RDZ for diagnostic output ! ------------------------------------------------------- - KM(:,:,LM) = CU * (PLE(:,:,LM)/(MAPL_RGAS * TV(:,:,LM))) / Z(:,:,LM) + KM(:,:,LM) = CU * Z(:,:,LM)*(MAPL_RGAS * TV(:,:,LM)) / PLE(:,:,LM) !Z/rho ! Setup the tridiagonal matrix ! ---------------------------- @@ -4891,8 +4990,8 @@ subroutine REFRESH(IM,JM,LM,RC) YS(:,:,1:LM-1) = DMI(:,:,1:LM-1)*( RHOE(:,:,1:LM-1)*AWS3(:,:,1:LM-1) - RHOE(:,:,0:LM-2)*AWS3(:,:,0:LM-2) + SSRC(:,:,1:LM-1) ) YQV(:,:,1:LM-1) = DMI(:,:,1:LM-1)*( RHOE(:,:,1:LM-1)*AWQV3(:,:,1:LM-1) - RHOE(:,:,0:LM-2)*AWQV3(:,:,0:LM-2) + QVSRC(:,:,1:LM-1) ) YQL(:,:,1:LM-1) = DMI(:,:,1:LM-1)*( RHOE(:,:,1:LM-1)*AWQL3(:,:,1:LM-1) - RHOE(:,:,0:LM-2)*AWQL3(:,:,0:LM-2) + QLSRC(:,:,1:LM-1) ) + YQI(:,:,1:LM-1) = DMI(:,:,1:LM-1)*( RHOE(:,:,1:LM-1)*AWQI3(:,:,1:LM-1) - RHOE(:,:,0:LM-2)*AWQI3(:,:,0:LM-2) + QISRC(:,:,1:LM-1) ) - YQI(:,:,1:LM-1) = DMI(:,:,1:LM-1)*( RHOE(:,:,1:LM-1)*AWQI3(:,:,1:LM-1) - RHOE(:,:,0:LM-2)*AWQI3(:,:,0:LM-2) ) YU(:,:,1:LM-1) = DMI(:,:,1:LM-1)*( RHOE(:,:,1:LM-1)*AWU3(:,:,1:LM-1) - RHOE(:,:,0:LM-2)*AWU3(:,:,0:LM-2) ) YV(:,:,1:LM-1) = DMI(:,:,1:LM-1)*( RHOE(:,:,1:LM-1)*AWV3(:,:,1:LM-1) - RHOE(:,:,0:LM-2)*AWV3(:,:,0:LM-2) ) @@ -4950,10 +5049,11 @@ subroutine REFRESH(IM,JM,LM,RC) if (C_B /= 0.0) then call BELJAARS(IM, JM, LM, DT, & LAMBDA_B, C_B, & - KPBL, HGT_SURFACE, & + KPBL, & U, V, Z, AREA, & VARFLT, PLE, & - BKV, BKUU, FKV ) + BKV, BKUU, FKV, & + FKV_LIM) endif call MAPL_TimerOff(MAPL,"---BELJAARS") @@ -5014,10 +5114,6 @@ subroutine REFRESH(IM,JM,LM,RC) call VTRISOLVESURF(BKQ,CKQ,DKQ) call VTRISOLVESURF(BKV,CKV,DKV) - call VTRISOLVESURF(BKSS,CKSS,DKSS) - call VTRISOLVESURF(BKQQ,CKQQ,DKQQ) - call VTRISOLVESURF(BKUU,CKUU,DKUU) - call MAPL_TimerOff(MAPL,"---DECOMP") if(ALLOC_TCZPBL) deallocate(TCZPBL) @@ -5072,13 +5168,12 @@ subroutine DIFFUSE(IM,JM,LM,RC) real, dimension(:,:,:), pointer :: DX real, dimension(:,:,:), pointer :: AK, BK, CK -! real, dimension(:,:,:), allocatable :: U, V, H, QV, QLLS, QLCN, ZLO, QL - integer :: KM, K,L logical :: FRIENDLY logical :: WEIGHTED + logical :: OPT ! selects algorithm in VTRISOLVE - real, dimension(IM,JM,LM) :: DP + real, dimension(IM,JM,LM) :: DP,DZ real(kind=MAPL_R8), dimension(IM,JM,LM) :: SX real :: DOMF @@ -5089,6 +5184,11 @@ subroutine DIFFUSE(IM,JM,LM,RC) integer :: SCM_SL, SCM_SL_FLUX real :: SCM_SH, SCM_EVAP + ! EDMF transport + real :: EntExp, EntDyn + real, dimension(LM) :: UPSX + real, dimension(:,:,:), pointer :: edmf_mf, edmf_entx + ! pointers to exports after diffuse real, dimension(:,:,:), pointer :: UAFDIFFUSE, VAFDIFFUSE, SAFDIFFUSE, QAFDIFFUSE @@ -5168,6 +5268,11 @@ subroutine DIFFUSE(IM,JM,LM,RC) call MAPL_GetPointer(EXPORT, SAFDIFFUSE , 'SAFDIFFUSE' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(EXPORT, QAFDIFFUSE , 'QAFDIFFUSE' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) + + call MAPL_GetPointer(EXPORT, edmf_mf, 'EDMF_MF', RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, edmf_entx, 'EDMF_ENTR', RC=STATUS); VERIFY_(STATUS) + + ! Count the firlds in TR... !-------------------------- @@ -5194,6 +5299,7 @@ subroutine DIFFUSE(IM,JM,LM,RC) !----------------------------- DP = PLE(:,:,1:LM)-PLE(:,:,0:LM-1) + DZ = ZLE(:,:,0:LM-1)-ZLE(:,:,1:LM) ! Loop over all quantities to be diffused. !---------------------------------------- @@ -5273,6 +5379,8 @@ subroutine DIFFUSE(IM,JM,LM,RC) ! Pick the right exchange coefficients !------------------------------------- +OPT = .TRUE. + if ( (trim(name) /= 'S' ) .and. (trim(name) /= 'Q' ) .and. & (trim(name) /= 'QLLS') .and. (trim(name) /= 'QILS') .and. & (trim(name) /= 'U' ) .and. (trim(name) /= 'V' )) then @@ -5299,34 +5407,63 @@ subroutine DIFFUSE(IM,JM,LM,RC) SX = S + ! Calculate EDMF tracer transport + if (MFPARAMS%DOTRACERS) then + do I=1,IM + do J=1,JM + if (edmf_mf(I,J,LM-1).gt.1e-8) then + UPSX(:) = 0. + UPSX(LM-1) = SX(I,J,LM) + L = LM-2 + do while (edmf_mf(I,J,L).gt.1e-8 .and. L.gt.1) + entdyn = max(0.,edmf_mf(I,J,L)-edmf_mf(I,J,L+1))/(edmf_mf(I,J,L+1)*DZ(I,J,L+1)) ! dynamical entrainment + entexp = exp(-(entdyn+EDMF_ENTX(I,J,L+1))*DZ(I,J,L+1)) + + ! Effect of mixing on tracers in updraft + UPSX(L) = SX(I,J,L+1)*(1.-entexp)+UPSX(L+1)*entexp + L = L-1 + end do + do ll = 1,2 ! substep + SX(I,J,2:LM) = SX(I,J,2:LM) + 0.5*(DT*MAPL_GRAV/DP(I,J,L+1))* & + ( edmf_mf(I,J,2:LM) * (UPSX(2:LM) - SX(I,J,2:LM) ) & + -edmf_mf(I,J,1:LM-1) * (UPSX(1:LM-1) - SX(I,J,1:LM-1) ) ) + end do + end if + end do ! JM + end do ! IM + SX = max( 0., SX ) ! prevent negative values from roundoff + end if + elseif (trim(name) =='S') then CX => CT - DX => DKSS + DX => DKS AK => AKSS; BK => BKSS; CK => CKSS SX=S+YS elseif (trim(name)=='Q') then CX => CQ - DX => DKQQ + DX => DKQ AK => AKQQ; BK => BKQQ; CK => CKQQ SX=S+YQV elseif (trim(name)=='QLLS') then CX => CQ - DX => DKQQ + DX => DKQ AK => AKQQ; BK => BKQQ; CK => CKQQ SX=S+YQL +! OPT = .FALSE. elseif (trim(name)=='QILS') then CX => CQ - DX => DKQQ + DX => DKQ AK => AKQQ; BK => BKQQ; CK => CKQQ SX=S+YQI +! OPT = .FALSE. elseif (trim(name)=='U') then CX => CU - DX => DKUU + DX => DKV AK => AKUU; BK => BKUU; CK => CKUU SX=S+YU elseif (trim(name)=='V') then CX => CU - DX => DKUU + DX => DKV AK => AKUU; BK => BKUU; CK => CKUU SX=S+YV end if @@ -5335,7 +5472,7 @@ subroutine DIFFUSE(IM,JM,LM,RC) ! Solve for semi-implicit changes. This modifies SX ! ------------------------------------------------- - call VTRISOLVE(AK,BK,CK,SX,SG) + call VTRISOLVE(AK,BK,CK,SX,SG,OPT) ! Compute the surface fluxes !--------------------------- @@ -5363,11 +5500,11 @@ subroutine DIFFUSE(IM,JM,LM,RC) end if if (DO_WAVES /= 0 .and. DO_SEA_SPRAY /= 0) then - if (NAME == 'S') then + if (trim(name) == 'S') then SF = SF + SH_SPRAY end if - if (NAME == 'Q') then + if (trim(name) == 'Q') then SF = SF + LH_SPRAY/MAPL_ALHL end if end if @@ -5384,16 +5521,16 @@ subroutine DIFFUSE(IM,JM,LM,RC) end if if (DO_WAVES /= 0 .and. DO_SEA_SPRAY /= 0) then - if (NAME == 'S') then + if (trim(name) == 'S') then SX(:,:,LM) = SX(:,:,LM) + (SH_SPRAY/(DP(:,:,LM)/MAPL_GRAV))*DT end if - if (NAME == 'Q') then + if (trim(name) == 'Q') then SX(:,:,LM) = SX(:,:,LM) + (LH_SPRAY/(MAPL_ALHL*DP(:,:,LM)/MAPL_GRAV))*DT end if end if - if( NAME=='S' ) then + if( trim(name)=='S' ) then SINC = ( (SX - S)/DT ) end if @@ -5405,16 +5542,16 @@ subroutine DIFFUSE(IM,JM,LM,RC) end if ! Fill exports of U,V and S after diffusion - if( TYPE=='U' ) then + if( trim(name) == 'U' ) then if(associated(UAFDIFFUSE)) UAFDIFFUSE = SX endif - if( TYPE=='V' ) then + if( trim(name) == 'V' ) then if(associated(VAFDIFFUSE)) VAFDIFFUSE = SX endif - if( TYPE=='S' ) then + if( trim(name) == 'S' ) then if(associated(SAFDIFFUSE)) SAFDIFFUSE = SX endif - if( TYPE=='Q' ) then + if( trim(name) == 'Q' ) then if(associated(QAFDIFFUSE)) QAFDIFFUSE = SX endif @@ -5584,17 +5721,17 @@ subroutine UPDATE(IM,JM,LM,LATS,RC) real, dimension(:,: ), pointer :: DSG, SF, SDF, SRFDIS real, dimension(:,: ), pointer :: HGTLM5, LM50M real, dimension(:,: ), pointer :: KETRB, KESRF, KETOP, KEINT - real, dimension(:,:,:), pointer :: DKS, DKV, DKQ, DKSS, DKUU, DKQQ, DKX, EKV, FKV + real, dimension(:,:,:), pointer :: DKS, DKV, DKQ, DKX, EKV, FKV real, dimension(:,:,:), pointer :: DPDTTRB real, dimension(:,:,:), pointer :: QTFLXTRB, SLFLXTRB, WSL, WQT, MFWSL, & MFWQT, TKH, UFLXTRB, VFLXTRB, QTX, SLX, & - SLFLXMF, QTFLXMF, MFAW + SLFLXMF, QTFLXMF, MFAW, TKEDISS integer :: KM, K, L, I, J logical :: FRIENDLY logical :: WEIGHTED - real, dimension(IM,JM,LM) :: DP, SX - real, dimension(IM,JM,LM-1) :: DF + real, dimension(IM,JM,LM) :: DZ, DP, SX + real, dimension(IM,JM,LM) :: DF real, dimension(IM,JM,LM) :: QT,SL,U,V,ZLO real, dimension(IM,JM,0:LM) :: ZL0 real, allocatable :: tmp3d(:,:,:) @@ -5606,7 +5743,7 @@ subroutine UPDATE(IM,JM,LM,LATS,RC) real, dimension(IM,JM,LM) :: SOIOFS, XINC real, dimension(IM,JM) :: z500, z1500, z7000, STDV - integer, dimension(IM,JM) :: L500, L1500, L7000, L200 + integer, dimension(IM,JM) :: L300, L500, L1500, L7000, LSURF integer, dimension(IM,JM) :: LTOPS,LBOT,LTOPQ logical, dimension(IM,JM) :: DidSHVC real :: REDUFAC, SUMSOI @@ -5617,7 +5754,8 @@ subroutine UPDATE(IM,JM,LM,LATS,RC) real :: SHVC_ALPHA, SHVC_EFFECT, SHVC_SCALING logical :: DO_SHVC logical :: ALLOC_TMP - integer :: KS + integer :: KS, DO_SHOC + real :: HGT_SURFACE, WGTSUM ! For idealized SCM surface layer integer :: SCM_SL @@ -5633,6 +5771,7 @@ subroutine UPDATE(IM,JM,LM,LATS,RC) ALLOC_TMP = .FALSE. call MAPL_GetPointer(INTERNAL, TKH , 'TKH' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL, TKEDISS, 'TKEDISS' , RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(EXPORT, QTX , 'QT' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(EXPORT, SLX , 'SL' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) @@ -5671,6 +5810,13 @@ subroutine UPDATE(IM,JM,LM,LATS,RC) RC=STATUS) VERIFY_(STATUS) + HGT_SURFACE = 50.0 + if (LM .eq. 72) HGT_SURFACE = 0.0 + call MAPL_GetResource( MAPL, HGT_SURFACE, 'HGT_SURFACE:', default=HGT_SURFACE, RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_GetResource (MAPL, DO_SHOC, trim(COMP_NAME)//"_DO_SHOC:", default=0, RC=STATUS); VERIFY_(STATUS) + ! SHVC Resource parameters. SHVC_EFFECT can be set to zero to turn-off SHVC. ! SHVC_EFFECT = 1. is the tuned value for 2 degree horizontal resolution. ! It should be set to a lower number at higher resolution. @@ -5712,12 +5858,7 @@ subroutine UPDATE(IM,JM,LM,LATS,RC) VERIFY_(STATUS) call MAPL_GetPointer(INTERNAL, DKQ, 'DKQ', RC=STATUS) VERIFY_(STATUS) - call MAPL_GetPointer(INTERNAL, DKQQ, 'DKQQ', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(INTERNAL, DKSS, 'DKSS', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(INTERNAL, DKUU, 'DKUU', RC=STATUS) - VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL, EKV, 'EKV', RC=STATUS) VERIFY_(STATUS) call MAPL_GetPointer(INTERNAL, FKV, 'FKV', RC=STATUS) @@ -5779,9 +5920,11 @@ subroutine UPDATE(IM,JM,LM,LATS,RC) DP = PLE(:,:,1:LM)-PLE(:,:,0:LM-1) do L=0,LM - ZL0(:,:,L) = ZLE(:,:,L) - ZLE(:,:,LM) ! height above the surface + ZL0(:,:,L) = ZLE(:,:,L) - ZLE(:,:,LM) ! Edge heights above the surface enddo - ZLO = 0.5*(ZL0(:,:,1:LM)+ZL0(:,:,0:LM-1)) + ZLO = 0.5*(ZL0(:,:,1:LM)+ZL0(:,:,0:LM-1)) ! Layer heights above the surface + + DZ = ZLE(:,:,0:LM-1) - ZLE(:,:,1:LM) ! Layer thickness (positive m) ! Diagnostics call MAPL_GetPointer(EXPORT, HGTLM5 , 'HGTLM5' , RC=STATUS); VERIFY_(STATUS) @@ -5792,16 +5935,30 @@ subroutine UPDATE(IM,JM,LM,LATS,RC) if(associated(LM50M)) then LM50M = LM do L=LM,2,-1 - where (ZL0(:,:,L) <= 150. .and. ZL0(:,:,L-1) > 150.) + where (ZL0(:,:,L) <= 50. .and. ZL0(:,:,L-1) > 50.) LM50M=L-1 endwhere enddo end if - L200=LM - do L=LM,2,-1 - where (ZL0(:,:,L) <= 200. .and. ZL0(:,:,L-1) > 200.) - L200=L-1 + LSURF=LM + do L=LM,1,-1 + where (ZL0(:,:,L) <= HGT_SURFACE .and. ZL0(:,:,L-1) > HGT_SURFACE) + LSURF=L + endwhere + enddo + + L300=1. + do L=LM,1,-1 + where (ZL0(:,:,L) <= 300. .and. ZL0(:,:,L-1) > 300.) + L300=L + endwhere + enddo + + L500=1. + do L=LM,1,-1 + where (ZL0(:,:,L) <= 500. .and. ZL0(:,:,L-1) > 500.) + L500=L endwhere enddo @@ -5861,8 +6018,6 @@ subroutine UPDATE(IM,JM,LM,LATS,RC) z7000 = z1500 + SHVC_ZDEPTH - - L500=1. do L=LM,2,-1 where (ZL0(:,:,L) <= z500 .and. ZL0(:,:,L-1) > z500) @@ -5899,6 +6054,10 @@ subroutine UPDATE(IM,JM,LM,LATS,RC) ! Loop over all quantities to be diffused. !----------------------------------------- + if (associated(INTDIS) .and. DO_SHOC /= 0) then + INTDIS(:,:,1:LM) = -1.*TKEDISS(:,:,1:LM)*DP(:,:,1:LM)/MAPL_CP + endif + TRACERS: do KS=1,KM K = KK(KS) @@ -5962,13 +6121,13 @@ subroutine UPDATE(IM,JM,LM,LATS,RC) RETURN_(ESMF_FAILURE) end if if( trim(NAME)=='QV' ) then - DKX => DKQQ + DKX => DKQ end if if( trim(NAME)=='S') then - DKX => DKSS + DKX => DKS end if if( trim(NAME)=='U' .or. trim(NAME)=='V' ) then - DKX => DKUU + DKX => DKV end if ! Update diffused quantity @@ -5986,65 +6145,34 @@ subroutine UPDATE(IM,JM,LM,LATS,RC) !-------------------------- if( TYPE=='U' ) then - if(associated(KETRB )) KETRB = 0.0 - if(associated(KESRF )) KESRF = 0.0 - if(associated(KETOP )) KETOP = 0.0 - if(associated(KEINT )) KEINT = 0.0 if(associated(INTDIS)) then - - DF = (0.5/(MAPL_CP))*EKV(:,:,1:LM-1)*(SX(:,:,1:LM-1)-SX(:,:,2:LM))**2 - INTDIS(:,:,1:LM-1) = INTDIS(:,:,1:LM-1) + DF - INTDIS(:,:,2:LM ) = INTDIS(:,:,2:LM ) + DF - - !DF(:,:,1) = sum(DP(:,:,LM-10:LM),3) - !DF(:,:,1) = ((1.0/(MAPL_CP))*EKV(:,:,LM)*SX(:,:,LM)**2)/DF(:,:,1) - !do L=LM-10,LM - ! INTDIS(:,:,L) = INTDIS(:,:,L) + DF(:,:,1)*DP(:,:,L) - !end do - - ! Add surface dissipation to lower 200m - do J=1,JM - do I=1,IM - DF(I,J,1) = sum(DP(I,J,L200(I,J):LM)) - DF(I,J,1) = ((1.0/(MAPL_CP))*EKV(I,J,LM)*SX(I,J,LM)**2)/DF(I,J,1) - end do - end do + if (DO_SHOC==0) then + DF(:,:,1:LM-1) = (0.5/MAPL_CP)*EKV(:,:,1:LM-1)*(SX(:,:,1:LM-1)-SX(:,:,2:LM))**2 ! Shear + DF(:,:, LM ) = 0.0 ! no shear at the surface, surface friction added later + INTDIS(:,:,1:LM-1) = INTDIS(:,:,1:LM-1) + DF(:,:,1:LM-1) + INTDIS(:,:,2:LM ) = INTDIS(:,:,2:LM ) + DF(:,:,1:LM-1) + endif + ! Add surface dissipation to lower levels do J=1,JM do I=1,IM - do L=L200(I,J),LM - INTDIS(I,J,L) = INTDIS(I,J,L) + DF(I,J,1)*DP(I,J,L) + WGTSUM = 0.0 + do L=L300(I,J),LM + WGTSUM = WGTSUM + DZ(I,J,L)*(1.0-ZL0(I,J,L)/ZL0(I,J,L300(I,J)))**2 end do + ! weighted by the layer thickness + DF(I,J,LM) = (1.0/MAPL_CP)*EKV(I,J,LM)*SX(I,J,LSURF(I,J))**2 ! Use Surface Winds + DF(I,J,LM) = DF(I,J,LM)/WGTSUM + do L=L300(I,J),LM + INTDIS(I,J,L) = INTDIS(I,J,L) + DF(I,J,LM)*DZ(I,J,L)*(1.0-ZL0(I,J,L)/ZL0(I,J,L300(I,J)))**2 + end do end do end do - - if(associated(KETRB)) then - do L=1,LM - KETRB = KETRB - INTDIS(:,:,L)* (MAPL_CP/MAPL_GRAV) - end do - end if - if(associated(KEINT)) then - do L=1,LM - KEINT = KEINT - INTDIS(:,:,L)* (MAPL_CP/MAPL_GRAV) - end do - end if endif if(associated(TOPDIS)) then - TOPDIS = TOPDIS + (1.0/(MAPL_CP))*FKV*SX**2 - if(associated(KETRB)) then - do L=1,LM - KETRB = KETRB - TOPDIS(:,:,L)* (MAPL_CP/MAPL_GRAV) - end do - end if - if(associated(KETOP)) then - do L=1,LM - KETOP = KETOP - TOPDIS(:,:,L)* (MAPL_CP/MAPL_GRAV) - end do - end if + TOPDIS = TOPDIS + (1.0/MAPL_CP)*FKV*SX**2 endif if(associated(SRFDIS)) then - SRFDIS = SRFDIS + (1.0/(MAPL_CP))*EKV(:,:,LM)*SX(:,:,LM)**2 - if(associated(KETRB)) KETRB = KETRB - SRFDIS* (MAPL_CP/MAPL_GRAV) - if(associated(KESRF)) KESRF = KESRF - SRFDIS* (MAPL_CP/MAPL_GRAV) + SRFDIS = SRFDIS + (1.0/MAPL_CP)*EKV(:,:,LM)*SX(:,:,LM)**2 endif end if @@ -6181,8 +6309,6 @@ subroutine UPDATE(IM,JM,LM,LATS,RC) if( name=='Q' .or. name=='QLLS' .or. name=='QLCN' .or. & name=='QILS' .or. name=='QICN' ) then -! name=='QILS' .or. name=='QICN' .or. & -! name=='QRAIN' .or. name=='QSNOW' .or. name=='QGRAUPEL') then if(associated(QTFLXTRB).or.associated(QTX)) QT = QT + SX endif @@ -6234,6 +6360,7 @@ subroutine UPDATE(IM,JM,LM,LATS,RC) if (associated(QTFLXTRB)) QTFLXTRB = tmp3d + QTFLXMF if (associated(WQT)) WQT = 0.5*( tmp3d(:,:,1:LM)+tmp3d(:,:,0:LM-1) + QTFLXMF(:,:,1:LM)+QTFLXMF(:,:,0:LM-1) ) end if + if (associated(SLFLXTRB).or.associated(WSL)) then tmp3d(:,:,1:LM-1) = (SL(:,:,1:LM-1)-SL(:,:,2:LM))/(ZLO(:,:,1:LM-1)-ZLO(:,:,2:LM)) tmp3d(:,:,1:LM-1) = -1.*TKH(:,:,1:LM-1)*tmp3d(:,:,1:LM-1) @@ -6241,7 +6368,7 @@ subroutine UPDATE(IM,JM,LM,LATS,RC) tmp3d(:,:,0) = 0.0 if (associated(SLFLXMF).and.MFPARAMS%IMPLICIT.eq.1) then SLFLXMF(:,:,1:LM-1) = SLFLXMF(:,:,1:LM-1)-MFAW(:,:,1:LM-1)*SL(:,:,1:LM-1)/MAPL_CP - SLFLXMF(:,:,LM) = SLFLXMF(:,:,LM-1) + SLFLXMF(:,:,LM) = 0. SLFLXMF(:,:,0) = 0. end if if (associated(SLFLXTRB)) SLFLXTRB = tmp3d/MAPL_CP + SLFLXMF @@ -6261,6 +6388,44 @@ subroutine UPDATE(IM,JM,LM,LATS,RC) VFLXTRB(:,:,0) = 0.0 end if + if(associated(INTDIS)) then + !! limit INTDIS to 2-deg/hour + !do L=1,LM + ! do J=1,JM + ! do I=1,IM + ! INTDIS(I,J,L) = SIGN(min(2.0/3600.0,ABS(INTDIS(I,J,L))/DP(I,J,L))*DP(I,J,L),INTDIS(I,J,L)) + ! end do + ! end do + !end do + if(associated(KETRB)) then + do L=1,LM + KETRB = KETRB - INTDIS(:,:,L)* (MAPL_CP/MAPL_GRAV) + end do + end if + if(associated(KEINT)) then + do L=1,LM + KEINT = KEINT - INTDIS(:,:,L)* (MAPL_CP/MAPL_GRAV) + end do + if(associated(SRFDIS)) KEINT = KEINT + SRFDIS* (MAPL_CP/MAPL_GRAV) ! avoid double-counting SRF in INT + end if + end if + + if(associated(TOPDIS)) then + if(associated(KETRB)) then + do L=1,LM + KETRB = KETRB - TOPDIS(:,:,L)* (MAPL_CP/MAPL_GRAV) + end do + end if + if(associated(KETOP)) then + do L=1,LM + KETOP = KETOP - TOPDIS(:,:,L)* (MAPL_CP/MAPL_GRAV) + end do + end if + endif + if(associated(SRFDIS)) then + if(associated(KESRF)) KESRF = KESRF - SRFDIS* (MAPL_CP/MAPL_GRAV) + endif + RETURN_(ESMF_SUCCESS) end subroutine UPDATE @@ -6281,39 +6446,40 @@ end subroutine RUN2 ! !INTERFACE: - subroutine LOUIS_KS( & + subroutine LOUIS_KS( IM,JM,LM, & ZZ,ZE,PV,UU,VV,ZPBL, & - KH,KM,RI,DU, & - LOUIS, MINSHEAR, MINTHICK, & + KH,KM,RI,LOUISKH,LOUISKM, & + MINSHEAR, MINTHICK, & LAMBDAM, LAMBDAM2, & LAMBDAH, LAMBDAH2, & ALHFAC, ALMFAC, & - ZKMENV, ZKHENV, AKHMMAX, & - ALH_DIAG,KMLS_DIAG,KHLS_DIAG) + ZKHMENV, AKHMMAX, & + DU_DIAG, ALH_DIAG,KMLS_DIAG,KHLS_DIAG) ! !ARGUMENTS: ! Inputs - real, intent(IN ) :: ZZ(:,:,:) ! Height of layer center above the surface (m). - real, intent(IN ) :: PV(:,:,:) ! Virtual potential temperature at layer center (K). - real, intent(IN ) :: UU(:,:,:) ! Eastward velocity at layer center (m s-1). - real, intent(IN ) :: VV(:,:,:) ! Northward velocity at layer center (m s-1). - real, intent(IN ) :: ZE(:,:,:) ! Height of layer base above the surface (m). - real, intent(IN ) :: ZPBL(:,: ) ! PBL Depth (m) + integer, intent(IN ) :: IM,JM,LM + real, intent(IN ) :: ZZ(IM,JM, LM) ! Height of layer center above the surface (m). + real, intent(IN ) :: PV(IM,JM, LM) ! Virtual potential temperature at layer center (K). + real, intent(IN ) :: UU(IM,JM, LM) ! Eastward velocity at layer center (m s-1). + real, intent(IN ) :: VV(IM,JM, LM) ! Northward velocity at layer center (m s-1). + real, intent(IN ) :: ZE(IM,JM,0:LM) ! Height of layer base above the surface (m). + real, intent(IN ) :: ZPBL(IM,JM ) ! PBL Depth (m) ! Outputs - real, intent( OUT) :: KM(:,:,:) ! Momentum diffusivity at base of each layer (m+2 s-1). - real, intent( OUT) :: KH(:,:,:) ! Heat diffusivity at base of each layer (m+2 s-1). - real, intent( OUT) :: RI(:,:,:) ! Richardson number - real, intent( OUT) :: DU(:,:,:) ! Magnitude of wind shear (s-1). + real, intent( OUT) :: KM(IM,JM,0:LM) ! Momentum diffusivity at base of each layer (m+2 s-1). + real, intent( OUT) :: KH(IM,JM,0:LM) ! Heat diffusivity at base of each layer (m+2 s-1). + real, intent( OUT) :: RI(IM,JM,0:LM) ! Richardson number ! Diagnostic outputs + real, pointer :: DU_DIAG(:,:,:) ! Magnitude of wind shear (s-1). real, pointer :: ALH_DIAG(:,:,:) ! Blackadar Length Scale diagnostic (m) [Optional] real, pointer :: KMLS_DIAG(:,:,:) ! Momentum diffusivity at base of each layer (m+2 s-1). real, pointer :: KHLS_DIAG(:,:,:) ! Heat diffusivity at base of each layer (m+2 s-1). ! These are constants - real, intent(IN ) :: LOUIS ! Louis scheme parameters (usually 5). + real, intent(IN ) :: LOUISKH, LOUISKM ! Louis scheme parameters (usually 5). real, intent(IN ) :: MINSHEAR ! Min shear allowed in Ri calculation (s-1). real, intent(IN ) :: MINTHICK ! Min layer thickness (m). real, intent(IN ) :: LAMBDAM ! Blackadar(1962) length scale parameter for momentum (m). @@ -6322,8 +6488,7 @@ subroutine LOUIS_KS( & real, intent(IN ) :: LAMBDAH2 ! Second Blackadar parameter for heat (m). real, intent(IN ) :: ALHFAC real, intent(IN ) :: ALMFAC - real, intent(IN ) :: ZKMENV ! Transition height for Blackadar param for momentum (m) - real, intent(IN ) :: ZKHENV ! Transition height for Blackadar param for heat (m) + real, intent(IN ) :: ZKHMENV ! Transition height for reduction of diffusivity in the free atm (m) real, intent(IN ) :: AKHMMAX ! Maximum allowe diffusivity (m+2 s-1). ! !DESCRIPTION: Computes Louis et al.(1979) Richardson-number-based diffusivites, @@ -6413,22 +6578,20 @@ subroutine LOUIS_KS( & ! Locals - real, dimension(size(KM,1),size(KM,2),size(KM,3)) :: ALH, ALM, DZ, DT, TM, PS, LAMBDAM_X, LAMBDAH_X - real, dimension(size(KM,1),size(KM,2) ) :: pbllocal + real, dimension(IM,JM,LM-1) :: ALH, ALM, DV, DZ, DT, TM, LAMBDAM_X, LAMBDAH_X, RLS + real, dimension(IM,JM ) :: pbllocal - integer :: L, LM - !real :: Zchoke + integer :: I,J,L + real :: PS + real, parameter :: r13 = 1.0/3.0 + real, parameter :: r32 = 3.0/2.0 ! Begin... -!===> Number of layers; edge levels will be one less (LM-1). - - LM = size(ZZ,3) !===> Initialize output arrays KH = 0.0 KM = 0.0 - DU = 0.0 RI = 0.0 !===> Initialize pbllocal @@ -6436,84 +6599,109 @@ subroutine LOUIS_KS( & pbllocal = ZPBL where ( pbllocal .LE. ZZ(:,:,LM) ) pbllocal = ZZ(:,:,LM) -!===> Quantities needed for Richardson number +!===> Quantities needed for Richardson number (all layer edges above the surface layer) DZ(:,:,:) = (ZZ(:,:,1:LM-1) - ZZ(:,:,2:LM)) TM(:,:,:) = (PV(:,:,1:LM-1) + PV(:,:,2:LM))*0.5 DT(:,:,:) = (PV(:,:,1:LM-1) - PV(:,:,2:LM)) - DU(:,:,:) = (UU(:,:,1:LM-1) - UU(:,:,2:LM))**2 + & + DV(:,:,:) = (UU(:,:,1:LM-1) - UU(:,:,2:LM))**2 + & (VV(:,:,1:LM-1) - VV(:,:,2:LM))**2 !===> Limits on distance between layer centers and vertical shear at edges. - DZ = max(DZ, MINTHICK) - DU = sqrt(DU)/DZ + DZ = max(DZ, MINTHICK) + DV = SQRT(DV)/DZ + DT = DT/DZ !===> Richardson number ( RI = G*(DTheta_v/DZ) / (Theta_v*|DV/DZ|^2) ) - RI = MAPL_GRAV*(DT/DZ)/(TM*( max(DU, MINSHEAR)**2)) + RI(:,:,1:LM-1) = MAPL_GRAV*DT/(TM*(MAX(DV, MINSHEAR)**2)) -!===> Blackadar(1962) length scale: $1/l = 1/(kz) + 1/\lambda$ + if (DEBUG_TRB) call MAPL_MaxMin('LOUIS: DZ', DZ) + if (DEBUG_TRB) call MAPL_MaxMin('LOUIS: TM', TM) + if (DEBUG_TRB) call MAPL_MaxMin('LOUIS: DT', DT) + if (DEBUG_TRB) call MAPL_MaxMin('LOUIS: DV', DV) + if (DEBUG_TRB) call MAPL_MaxMin('LOUIS: RI', RI) -!!! LAMBDAM_X = MAX( LAMBDAM * EXP( -(ZE / ZKMENV )**2 ) , LAMBDAM2 ) -!!! LAMBDAH_X = MAX( LAMBDAH * EXP( -(ZE / ZKHENV )**2 ) , LAMBDAH2 ) +!===> Blackadar(1962) length scale: $1/l = 1/(kz) + 1/\lambda$ + ! 0.1 * local PBL includes diurnal variability on the Blackadar length scale + pbllocal = 0.1*pbllocal do L = 1, LM-1 - LAMBDAM_X(:,:,L) = MAX( 0.1 * pbllocal(:,:) * EXP( -(ZE(:,:,L) / ZKMENV )**2 ) , LAMBDAM2 ) - LAMBDAH_X(:,:,L) = MAX( 0.1 * pbllocal(:,:) * EXP( -(ZE(:,:,L) / ZKHENV )**2 ) , LAMBDAH2 ) + LAMBDAM_X(:,:,L) = MAX( pbllocal , LAMBDAM2) + LAMBDAH_X(:,:,L) = MAX( pbllocal , LAMBDAH2) end do - ALM = ALMFAC * ( MAPL_KARMAN*ZE/( 1.0 + MAPL_KARMAN*(ZE/LAMBDAM_X) ) )**2 - ALH = ALHFAC * ( MAPL_KARMAN*ZE/( 1.0 + MAPL_KARMAN*(ZE/LAMBDAH_X) ) )**2 + if (DEBUG_TRB) call MAPL_MaxMin('LOUIS: LM', LAMBDAM_X) + if (DEBUG_TRB) call MAPL_MaxMin('LOUIS: LH', LAMBDAH_X) - if (associated(ALH_DIAG)) ALH_DIAG(:,:,1:LM-1) = SQRT( ALH ) + ! cap the Blackadar length scales + LAMBDAM_X = MIN(LAMBDAM_X,LAMBDAM) + LAMBDAH_X = MIN(LAMBDAH_X,LAMBDAH) - where ( RI < 0.0 ) - PS = ( (ZZ(:,:,1:LM-1)/ZZ(:,:,2:LM))**(1./3.) - 1.0 ) ** 3 - PS = ALH*sqrt( PS/(ZE*(DZ**3)) ) - PS = RI/(1.0 + (3.0*LOUIS*LOUIS)*PS*sqrt(-RI)) + ALM = ( MAPL_KARMAN*ZE(:,:,1:LM-1)/( 1.0 + MAPL_KARMAN*(ZE(:,:,1:LM-1)/LAMBDAM_X) ) )**2 + ALH = ( MAPL_KARMAN*ZE(:,:,1:LM-1)/( 1.0 + MAPL_KARMAN*(ZE(:,:,1:LM-1)/LAMBDAH_X) ) )**2 - KH = 1.0 - (LOUIS*3.0)*PS - KM = 1.0 - (LOUIS*2.0)*PS - end where + if (associated(ALH_DIAG)) then + ALH_DIAG(:,:,0) = 0.0 + ALH_DIAG(:,:,1:LM-1) = SQRT( ALH ) + ALH_DIAG(:,:,LM) = 0.0 + endif -!===> Unstable case: Uses (3.14, 3.18, 3.27) in Louis-scheme -! should approach (3.13) for small -RI. + do L=1,LM-1 + do J=1,JM + do I=1,IM + if ( RI(I,J,L) < 0.0 ) then + !===> UnStable case PS from eqs 14 and 24 of Louis, 1979 + PS = ( (ZZ(I,J,L)/ZZ(I,J,L+1))**r13 - 1.0 )**3 + PS = SQRT( (PS/(ZE(I,J,L)*(DZ(I,J,L)**3))) * ABS(RI(I,J,L)) ) + + KM(I,J,L) = 1.0 - 10.0*RI(I,J,L) / & + (1.0 + 15.0*LOUISKM*ALM(I,J,L)*PS) + KH(I,J,L) = 1.0 - 15.0*RI(I,J,L) / & + (1.0 + 15.0*LOUISKH*ALH(I,J,L)*PS) + else + !===> Stable case + PS = sqrt(1.0 + 5.0*RI(I,J,L)) -!===> Choke off unstable KH below Zchoke (m). JTB 2/2/06 -!!! Zchoke = 500. -!!! where( (RI < 0.0) .and. (ZE < Zchoke ) ) -!!! KH = KH * (( ZE / Zchoke )**3) -!!! endwhere + KM(I,J,L) = 1.0 / (1.0 + 10.0*RI(I,J,L)/PS) + KH(I,J,L) = 1.0 / (1.0 + 15.0*RI(I,J,L)*PS) + end if + end do + end do + end do -!===> Stable case +!===> Reduction length in the free atmosphere eq 3.12 (IFS Documentation Cycle CY25r1) - where ( RI >= 0.0 ) - PS = sqrt (1.0 + LOUIS *RI ) + RLS = (0.2 + (0.8)/(1.0 + (ZE(:,:,1:LM-1)/ZKHMENV)**2))**2 - KH = 1.0 / (1.0 + (LOUIS*3.0)*RI*PS) - KM = PS / (PS + (LOUIS*2.0)*RI ) - end where +!===> DIMENSIONALIZE Kz and LIMIT DIFFUSIVITY -!===> DIMENSIONALIZE Kz and LIMIT DIFFUSIVITY + KM(:,:,1:LM-1) = ALMFAC*ALM*KM(:,:,1:LM-1)*DV*RLS + KH(:,:,1:LM-1) = ALHFAC*ALH*KH(:,:,1:LM-1)*DV*RLS - ALM = DU*ALM - ALH = DU*ALH + if (DEBUG_TRB) call MAPL_MaxMin('LOUIS: KM', KM) + if (DEBUG_TRB) call MAPL_MaxMin('LOUIS: KH', KH) - KM = min(KM*ALM, AKHMMAX) - KH = min(KH*ALH, AKHMMAX) + KM = min(KM, AKHMMAX) + KH = min(KH, AKHMMAX) - if (associated(KMLS_DIAG)) KMLS_DIAG(:,:,1:LM-1) = KM(:,:,1:LM-1) - if (associated(KHLS_DIAG)) KHLS_DIAG(:,:,1:LM-1) = KH(:,:,1:LM-1) + if (associated( DU_DIAG)) then + DU_DIAG(:,:,0) = 0.0 + DU_DIAG(:,:,1:LM-1) = DV + DU_DIAG(:,:,LM) = 0.0 + endif + if (associated(KMLS_DIAG)) KMLS_DIAG = KM + if (associated(KHLS_DIAG)) KHLS_DIAG = KH end subroutine LOUIS_KS subroutine BELJAARS(IM, JM, LM, DT, & LAMBDA_B, C_B, & - KPBL, HGT_SURFACE, & + KPBL, & U, V, Z, AREA, & VARFLT, PLE, & - BKV, BKVV, FKV ) + BKV, BKVV, FKV, FKV_LIM ) !BOP ! @@ -6534,7 +6722,8 @@ subroutine BELJAARS(IM, JM, LM, DT, & integer, intent(IN ) :: IM,JM,LM real, intent(IN ) :: DT real, intent(IN ) :: LAMBDA_B - real, intent(IN ) :: C_B, HGT_SURFACE + real, intent(IN ) :: C_B + real, intent(IN ) :: FKV_LIM real, intent(IN ), dimension(:,:,: ) :: U real, intent(IN ), dimension(:,:,: ) :: V @@ -6547,7 +6736,9 @@ subroutine BELJAARS(IM, JM, LM, DT, & real, intent( OUT), dimension(:,:,: ) :: FKV integer :: I,J,L - real :: CBl, wsp0, wsp, FKV_temp, Hefold + real :: CBl, wsp, FKV_temp + real :: CBl2D(IM,JM), SIGMA + real, parameter :: C_TOFD = 9.031E-09 * 12.0 if (C_B > 0.0) then do I = 1, IM @@ -6568,29 +6759,36 @@ subroutine BELJAARS(IM, JM, LM, DT, & end do end do else + ! C_TOFD is the end product of all coeficients in eq 16 of Beljaars, 2003 (doi: 10.1256/qj.03.73) + ! C_B is a factor used to amplify the variance of the filtered topography + ! resolution dependent amplification factor based on Arakawa sigma function of cell area + do J = 1, JM + do I = 1, IM + SIGMA = MAX(1.e-9,MIN(1.0,1.0-0.9839*EXP(-0.09835*(SQRT(AREA(i,j))/750.0))))**2 + CBl2D(I,J) = C_TOFD * (ABS(C_B)*SIGMA + (1.0-SIGMA))**2 + end do + end do do L = LM, 1, -1 do J = 1, JM do I = 1, IM - ! determine the resolution dependent tuning factor - CBl = 1.08371722e-7 * VARFLT(i,j) * & - MAX(0.0,MIN(1.0,dxmax_ss*(1.-dxmin_ss/SQRT(AREA(i,j))/(dxmax_ss-dxmin_ss)))) - ! determine the efolding height - Hefold = LAMBDA_B !MIN(MAX(2*SQRT(VARFLT(i,j)),Z(i,j,KPBL(i,j))),LAMBDA_B) FKV(I,J,L) = 0.0 - if (CBl > 0.0 .AND. Z(I,J,L) < 4.0*Hefold) then - wsp0 = SQRT(U(I,J,L)**2+V(I,J,L)**2) - wsp = SQRT(MIN(wsp0/ABS(C_B),1.0))*MAX(ABS(C_B),wsp0) ! enhance winds - FKV_temp = Z(I,J,L)/Hefold - FKV_temp = exp(-FKV_temp*sqrt(FKV_temp))*(FKV_temp**(-1.2)) - FKV_temp = CBl*(FKV_temp/Hefold)*wsp - - BKV(I,J,L) = BKV(I,J,L) + DT*FKV_temp - BKVV(I,J,L) = BKVV(I,J,L) + DT*FKV_temp - FKV(I,J,L) = FKV_temp * (PLE(I,J,L)-PLE(I,J,L-1)) + if (VARFLT(i,j) > 0.0 .AND. Z(I,J,L) < 4.0*LAMBDA_B) then + wsp = SQRT(U(I,J,L)**2+V(I,J,L)**2) + FKV_temp = exp(-1*(Z(I,J,L)/LAMBDA_B)**1.5) * Z(I,J,L)**(-1.2) + FKV_temp = CBl2D(I,J) * VARFLT(i,j) * FKV_temp * wsp + FKV(I,J,L) = MIN(FKV_LIM,FKV_temp * (PLE(I,J,L)-PLE(I,J,L-1))) ! include limit on this forcing for stability + FKV_temp = FKV(I,J,L)/(PLE(I,J,L)-PLE(I,J,L-1)) + BKV(I,J,L) = BKV(I,J,L) + DT*FKV_temp + BKVV(I,J,L) = BKVV(I,J,L) + DT*FKV_temp end if end do end do end do + + if (DEBUG_TRB) call MAPL_MaxMin('TOFD: BKV ', BKV) + if (DEBUG_TRB) call MAPL_MaxMin('TOFD: FKV ', FKV*(PLE(:,:,1:LM)-PLE(:,:,0:LM-1))) + if (DEBUG_TRB) call MAPL_MaxMin('TOFD: FKVP', FKV) + endif end subroutine BELJAARS @@ -6723,13 +6921,14 @@ end subroutine VTRISOLVESURF ! !INTERFACE: - subroutine VTRISOLVE ( A,B,C,Y,YG ) + subroutine VTRISOLVE ( A,B,C,Y,YG,OPT ) ! !ARGUMENTS: real, dimension(:,:,:), intent(IN ) :: A, B, C real(kind=MAPL_R8), dimension(:,:,:), intent(INOUT) :: Y real, dimension(:,:), intent(IN) :: YG + logical, intent(IN) :: OPT ! !DESCRIPTION: Solves tridiagonal system that has been LU decomposed ! $LU x = f$. This is done by first solving $L g = f$ for $g$, and @@ -6774,9 +6973,10 @@ subroutine VTRISOLVE ( A,B,C,Y,YG ) if(size(YG)>0) then Y(:,:,LM) = (Y(:,:,LM) - C(:,:,LM) * YG )*B(:,:,LM) - else + else if (OPT) then Y(:,:,LM) = Y(:,:,LM)*B(:,:,LM-1)/(B(:,:,LM-1) - A(:,:,LM)*(1.0+C(:,:,LM-1)*B(:,:,LM-1) )) - ! Y(:,:,LM) = Y(:,:,LM)*B(:,:,LM)/( 1.0+C(:,:,LM)*B(:,:,LM) ) ! Alternate formulation + else + Y(:,:,LM) = Y(:,:,LM)*B(:,:,LM)/( 1.0+C(:,:,LM)*B(:,:,LM) ) ! Alternate formulation endif do L = LM-1,1,-1 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/LockEntrain.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/LockEntrain.F90 index 1f079aaa0..325bc9760 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/LockEntrain.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/LockEntrain.F90 @@ -88,18 +88,15 @@ module LockEntrain ! NOTE: GPUs use the QSAT and DQSAT at the end of this module #endif - use MAPL_ConstantsMod, only: MAPL_GRAV, MAPL_KARMAN, MAPL_CP, & - MAPL_RGAS, MAPL_RVAP, MAPL_ALHL, & - MAPL_ALHS, MAPL_TICE, MAPL_VIREPS, & - MAPL_P00, MAPL_KAPPA, MAPL_H2OMW, & - MAPL_AIRMW, MAPL_R4, MAPL_R8 - use MAPL, only: MAPL_UNDEF + use MAPL implicit none #ifndef _CUDA private + logical :: use_kludges = .true. + !----------------------------------------------------------------------- ! ! public interfaces @@ -260,6 +257,7 @@ module LockEntrain real, parameter :: ramp = 20. + real, parameter :: r13 = 1.0/3.0 !----------------------------------------------------------------------- ! @@ -350,7 +348,6 @@ subroutine entrain( & entrate_sfc, & pceff_sfc, & vscale_sfc, & - pertopt_sfc, & khradfac, & khsfcfac_lnd, & khsfcfac_ocn ) @@ -470,14 +467,14 @@ subroutine entrain( & integer, value, intent(in) :: icol,jcol,nlev real, value, intent(in) :: prandtlsfc,prandtlrad,beta_surf,beta_rad - real, value, intent(in) :: khradfac,tpfac_sfc,entrate_sfc,vscale_sfc,pertopt_sfc + real, value, intent(in) :: khradfac,tpfac_sfc,entrate_sfc,vscale_sfc real, value, intent(in) :: pceff_sfc,khsfcfac_lnd,khsfcfac_ocn real, device, intent(in), dimension(icol,jcol,nlev) :: tdtlw_in real, device, intent(in), dimension(icol,jcol) :: u_star,b_star,frland,evap,sh real, device, intent(in), dimension(icol,jcol,nlev) :: t,qv,qlls,qils real, device, intent(in), dimension(icol,jcol,nlev) :: u,v,zfull,pfull - real, device, intent(in), dimension(icol,jcol,1:nlev+1) :: zhalf, phalf ! 0:72 in GC, 1:73 here. + real, device, intent(in), dimension(icol,jcol,1:nlev+1) :: zhalf, phalf real, device, intent(inout), dimension(icol,jcol,1:nlev+1) :: diff_m,diff_t real, device, intent(out), dimension(icol,jcol,1:nlev+1) :: k_m_entr,k_t_entr real, device, intent(out), dimension(icol,jcol,1:nlev+1) :: k_rad,k_sfc @@ -495,14 +492,14 @@ subroutine entrain( & real, intent(in), dimension(icol,jcol) :: u_star,b_star,frland,evap,sh real, intent(in), dimension(icol,jcol,nlev) :: t,qv,qlls,qils real, intent(in), dimension(icol,jcol,nlev) :: u,v,zfull,pfull - real, intent(in), dimension(icol,jcol,1:nlev+1) :: zhalf, phalf ! 0:72 in GC, 1:73 here. + real, intent(in), dimension(icol,jcol,1:nlev+1) :: zhalf, phalf real, intent(inout), dimension(icol,jcol,1:nlev+1) :: diff_m,diff_t real, intent(out), dimension(icol,jcol,1:nlev+1) :: k_m_entr,k_t_entr real, intent(out), dimension(icol,jcol,1:nlev+1) :: k_rad,k_sfc real, intent(out), dimension(icol,jcol) :: zsml,zradml,zcloud,zradbase real, intent(in) :: prandtlsfc,prandtlrad,beta_surf,beta_rad - real, intent(in) :: khradfac,tpfac_sfc,entrate_sfc, vscale_sfc, pertopt_sfc + real, intent(in) :: khradfac,tpfac_sfc,entrate_sfc, vscale_sfc real, intent(in) :: pceff_sfc,khsfcfac_lnd,khsfcfac_ocn real, pointer, dimension(:,:) :: wentr_rad_diag, wentr_sfc_diag ,del_buoy_diag @@ -709,7 +706,6 @@ subroutine entrain( & entrate_sfc, & pceff_sfc, & vscale_sfc, & - pertopt_sfc, & t, & qv, & u, & @@ -775,26 +771,14 @@ subroutine entrain( & (tmp1+tmp2) ) ) !---------------------------------------- -! fudgey adjustment of entrainment to reduce it +! AMM fudgey adjustment of entrainment to reduce it ! for shallow boundary layers, and increase for -! deep ones - if ( zsml(i,j) .lt. 1600. ) then - wentr_tmp = wentr_tmp * ( zsml(i,j) / 800. ) - else - wentr_tmp = 2.*wentr_tmp +! deep ones. Linear from 0 to 1600m + if (use_kludges) then + wentr_tmp = wentr_tmp * MIN(2.0, zsml(i,j)/800.) endif !----------------------------------------- -!!AMM106 !---------------------------------------- -!!AMM106 ! More fudgey adjustment of entrainment. -!!AMM106 ! Zeroes entr if bulk shear in PBL > vbulk_scale -!!AMM106 if ( vbulkshr .gt. vbulk_scale ) wentr_tmp = 0.0 -!!AMM106 if ( ( vbulkshr .gt. 0.5*vbulk_scale ) & -!!AMM106 .and. ( vbulkshr .le. vbulk_scale ) ) then -!!AMM106 wentr_tmp = wentr_tmp * ( vbulk_scale - vbulkshr ) *2 & -!!AMM106 / vbulk_scale -!!AMM106 endif - k_entr_tmp = wentr_tmp*(zfull(i,j,ipbl-1)-zfull(i,j,ipbl)) k_entr_tmp = min ( k_entr_tmp, akmax ) @@ -1051,24 +1035,16 @@ subroutine entrain( & wentr_brv = beta_rad*vbr3/zradml(i,j)/(tmp1+tmp2) - !---------------------------------------- -! fudgey adjustment of entrainment to reduce it +! AMM107 fudgey adjustment of entrainment to reduce it ! for shallow boundary layers, and increase for -! deep ones - -!!AMM107 - if ( zradtop .lt. 500. ) then - wentr_rad = 0.00 - endif - if (( zradtop .gt. 500.) .and. (zradtop .le. 800. )) then - wentr_rad = wentr_rad * ( zradtop-500.) / 300. - endif - - if ( zradtop .lt. 2400. ) then - wentr_rad = wentr_rad * ( zradtop / 800. ) +! deep ones: piecewise linear function 500-800m & 800-2400m + if (use_kludges) then + if ( zradtop .le. 800. ) then + wentr_rad = wentr_rad * max(0.0,(zradtop-500.)/300.) else - wentr_rad = 3.*wentr_rad + wentr_rad = wentr_rad * min(3.0,(zradtop/800.)) + endif endif !----------------------------------------- @@ -1207,7 +1183,7 @@ end subroutine entrain #ifdef _CUDA attributes(device) & #endif - subroutine mpbl_depth(i,j,icol,jcol,nlev,tpfac, entrate, pceff, vscale, pertopt, t, q, u, v, z, p, b_star, u_star , evap, sh, ipbl, ztop ) + subroutine mpbl_depth(i,j,icol,jcol,nlev,tpfac, entrate, pceff, vscale, t, q, u, v, z, p, b_star, u_star , evap, sh, ipbl, ztop ) ! ! ----- @@ -1236,7 +1212,7 @@ subroutine mpbl_depth(i,j,icol,jcol,nlev,tpfac, entrate, pceff, vscale, pertopt, integer, intent(in ) :: i, j, nlev, icol, jcol real, intent(in ), dimension(icol,jcol,nlev) :: t, z, q, p, u, v real, intent(in ), dimension(icol,jcol) :: b_star, u_star, evap, sh - real, intent(in ) :: tpfac, entrate, pceff, vscale, pertopt + real, intent(in ) :: tpfac, entrate, pceff, vscale integer, intent( out) :: ipbl real, intent( out),dimension(icol,jcol) :: ztop @@ -1251,30 +1227,22 @@ subroutine mpbl_depth(i,j,icol,jcol,nlev,tpfac, entrate, pceff, vscale, pertopt, !calculate surface parcel properties - if (pertopt /= 0) then - zrho = p(i,j,nlev)/(287.04*(t(i,j,nlev)*(1.+0.608*q(i,j,nlev)))) - - buoyflx = (sh(i,j)/MAPL_CP+0.608*t(i,j,nlev)*evap(i,j))/zrho ! K m s-1 - delzg = (50.0)*MAPL_GRAV ! assume 50m surface scale - wstar = max(0.,0.001+0.41*buoyflx*delzg/t(i,j,nlev)) ! m3 s-3 - - if (wstar > 0.001) then - wstar = 1.0*wstar**.3333 -! print *,'sh=',sh(i,j),'evap=',evap(i,j),'wstar=',wstar - tep = t(i,j,nlev) + 0.4 + 2.*sh(i,j)/(zrho*wstar*MAPL_CP) - qp = q(i,j,nlev) + 2.*evap(i,j)/(zrho*wstar) -! print *,'tpert=',2.*sh(i,j)/(zrho*wstar*MAPL_CP) + if (tpfac == 0) then + zrho = p(i,j,nlev)/(MAPL_RDRY*(t(i,j,nlev)*(1.+MAPL_VIREPS*q(i,j,nlev)))) + buoyflx = (sh(i,j)/MAPL_CP+MAPL_VIREPS*t(i,j,nlev)*evap(i,j))/zrho ! K m s-1 + delzg = 50.0*MAPL_GRAV ! assume 50m surface scale + wstar = max(0.,0.001+0.41*buoyflx*delzg/t(i,j,nlev)) ! m3 s-3 + if (wstar > 0.0) then + wstar = wstar**r13 + tep = t(i,j,nlev) + 0.4 + 2.* sh(i,j)/(zrho*wstar*MAPL_CP) + qp = q(i,j,nlev) + 2.*evap(i,j)/(zrho*wstar) else - tep = t(i,j,nlev) + 0.4 - qp = q(i,j,nlev) + tep = (t(i,j,nlev) + 0.4) * (1.+ min(0.01, b_star(i,j)/MAPL_GRAV)) + qp = q(i,j,nlev) end if else ! tpfac scales up bstar by inv. ratio of ! heat-bubble area to stagnant area - if (nlev.eq.72) then - tep = (t(i,j,nlev) + 0.4) * (1.+ tpfac * b_star(i,j)/MAPL_GRAV) - else - tep = (t(i,j,nlev) + 0.4) * (1.+ min(0.01,tpfac * b_star(i,j)/MAPL_GRAV)) - end if + tep = (t(i,j,nlev) + 0.4) * (1.+ min(0.01,tpfac * b_star(i,j)/MAPL_GRAV)) qp = q(i,j,nlev) end if @@ -1291,16 +1259,14 @@ subroutine mpbl_depth(i,j,icol,jcol,nlev,tpfac, entrate, pceff, vscale, pertopt, !search for level where this is exceeded lts = 0.0 -! LTS using TH at 3km abve surface - if (nlev.ne.72) then - do k = nlev-1,2,-1 - if (z(i,j,k).gt.3000.0) then - lts = t(i,j,k-1)*(1e5/p(i,j,k))**0.286 - exit - end if - end do - lts = lts - t(i,j,nlev-1)*(1e5/p(i,j,nlev-1))**0.286 - end if + ! LTS using TH at 3km abve surface + do k = nlev-1,2,-1 + if (z(i,j,k).gt.3000.0) then + lts = t(i,j,k-1)*(1e5/p(i,j,k))**0.286 + exit + end if + end do + lts = lts - t(i,j,nlev-1)*(1e5/p(i,j,nlev-1))**0.286 t1 = t(i,j,nlev) v1 = v(i,j,nlev) @@ -1314,7 +1280,6 @@ subroutine mpbl_depth(i,j,icol,jcol,nlev,tpfac, entrate, pceff, vscale, pertopt, v2 = v(i,j,k) pp = p(i,j,k) -!!Old Shear du = sqrt ( ( u(i,j,k) - u1 )**2 + ( v(i,j,k) - v1 )**2 ) du = sqrt ( ( u2 - u1 )**2 + ( v2 - v1 )**2 ) / (z2-z1) du = min(du,1.0e-8) @@ -1426,11 +1391,7 @@ subroutine radml_depth(i, j, icol, jcol, nlev, toplev, botlev, & svpar = svp h1 = zf(i,j,toplev) t1 = t(toplev) - if (nlev.eq.72) then - entrate = 0.2/200. - else - entrate = 1.0/1000. - endif + entrate = 1.0/1000. !search for level where parcel is warmer than env diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/SOURCE.txt b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/SOURCE.txt new file mode 100644 index 000000000..706eda6e4 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/SOURCE.txt @@ -0,0 +1 @@ +/discover/nobackup/projects/gmao/osse2/GIT/GEOS-LM_v12-rc3/GEOSgcm/src/Components/@GEOSgcm_GridComp/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/edmf.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/edmf.F90 index 1b60b8cca..eae0b4a6c 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/edmf.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/edmf.F90 @@ -23,6 +23,7 @@ module edmf_mod r = 2. type EDMFPARAMS_TYPE + logical :: DOTRACERS integer :: DISCRETE integer :: IMPLICIT integer :: ENTRAIN @@ -55,6 +56,7 @@ module edmf_mod real :: MFLIMFAC real :: ICE_RAMP real :: PRCPCRIT + real :: TREFF endtype EDMFPARAMS_TYPE type (EDMFPARAMS_TYPE) :: MFPARAMS @@ -74,7 +76,6 @@ SUBROUTINE RUN_EDMF(its,ite, jts,jte, kts,kte, dt, & ! Inputs t3, & thl3, & thv3, & - qt3, & qv3, & ql3, & qi3, & @@ -96,6 +97,7 @@ SUBROUTINE RUN_EDMF(its,ite, jts,jte, kts,kte, dt, & ! Inputs ssrc3, & qvsrc3, & qlsrc3, & + qisrc3, & ! Outputs required for SHOC and ADG PDF mfw2, & mfw3, & @@ -137,7 +139,6 @@ SUBROUTINE RUN_EDMF(its,ite, jts,jte, kts,kte, dt, & ! Inputs V3, & T3, & THL3, & - QT3, & THV3, & QV3, & QL3, & @@ -172,8 +173,8 @@ SUBROUTINE RUN_EDMF(its,ite, jts,jte, kts,kte, dt, & ! Inputs mfwqt, & mftke - REAL,DIMENSION(ITS:ITE,JTS:JTE,KTS:KTE), INTENT(OUT) :: buoyf,mfw2,mfw3,mfqt3,mfhl3,&!mfqt2,mfhl2,& - mfhlqt,dqrdt,dqsdt,ssrc3,qvsrc3,qlsrc3 + REAL,DIMENSION(ITS:ITE,JTS:JTE,KTS:KTE), INTENT(OUT) :: buoyf,mfw2,mfw3,mfqt3,mfhl3,& + mfhlqt,dqrdt,dqsdt,ssrc3,qvsrc3,qlsrc3,qisrc3 ! Diagnostic outputs @@ -228,11 +229,6 @@ SUBROUTINE RUN_EDMF(its,ite, jts,jte, kts,kte, dt, & ! Inputs LOGICAL :: calc_avg_diag -! velocity equation parameters -! REAL,PARAMETER :: Wa=1., & ! buoyancy term -! Wb=1.5 ! entrainment term -! Wa=1., & ! original -! Wb=1.5 ! min values to avoid singularities REAL,PARAMETER :: & @@ -284,6 +280,7 @@ SUBROUTINE RUN_EDMF(its,ite, jts,jte, kts,kte, dt, & ! Inputs ssrc3 =0. qvsrc3=0. qlsrc3=0. + qisrc3=0. buoyf =0. mfw2 =0. mfw3 =0. @@ -310,7 +307,6 @@ SUBROUTINE RUN_EDMF(its,ite, jts,jte, kts,kte, dt, & ! Inputs wthl=wthl2(IH,JH)/mapl_cp wqt=wqt2(IH,JH) - !ust=ust2(IH,JH) pblh=pblh2(IH,JH) pblh=max(pblh,pblhmin) @@ -319,12 +315,9 @@ SUBROUTINE RUN_EDMF(its,ite, jts,jte, kts,kte, dt, & ! Inputs ! if CLASP enabled: mass flux is input ! if CLASP disabled: mass-flux if positive surface buoyancy flux and ! TKE at 2nd model level above threshold -! IF ( (wthv > 0.0 .and. TKE3(IH,JH,kte-1)>0.01 .and. MFPARAMS%doclasp==0 .and. phis(IH,JH).lt.2e4) & IF ( (wthv > 0.0 .and. MFPARAMS%doclasp==0 .and. phis(IH,JH).lt.3e4) & .or. (any(mfsrcthl(IH,JH,1:MFPARAMS%NUP) >= -2.0) .and. MFPARAMS%doclasp/=0)) then -! print *,'wthv=',wthv,' wqt=',wqt,' wthl=',wthl,' edmfdepth=',edmfdepth(IH,JH) - if (MFPARAMS%doclasp/=0) then nup2 = count(mfsrcthl(IH,JH,1:MFPARAMS%NUP)>=-2.0) else @@ -361,7 +354,7 @@ SUBROUTINE RUN_EDMF(its,ite, jts,jte, kts,kte, dt, & ! Inputs end if end do lts = lts - thv3(IH,JH,kte) - L0 = L0/( 1.0 + (mfparams%ent0lts/mfparams%ent0-1.)*(0.5+0.5*tanh(0.3*(lts-19.))) ) + L0 = L0/( 1.0 + (mfparams%ent0lts/mfparams%ent0-1.)*(0.5+0.5*tanh(0.3*(lts-18.5))) ) end if else ! if mfparams%ET not 2 L0 = mfparams%L0 @@ -376,7 +369,6 @@ SUBROUTINE RUN_EDMF(its,ite, jts,jte, kts,kte, dt, & ! Inputs v(k)=v3(IH,JH,kte-k+kts) thl(k)=thl3(IH,JH,kte-k+kts) thv(k)=thv3(IH,JH,kte-k+kts) - qt(k)=qt3(IH,JH,kte-k+kts) qv(k)=qv3(IH,JH,kte-k+kts) ql(k)=ql3(IH,JH,kte-k+kts) qi(k)=qi3(IH,JH,kte-k+kts) @@ -385,7 +377,6 @@ SUBROUTINE RUN_EDMF(its,ite, jts,jte, kts,kte, dt, & ! Inputs ui(k) = 0.5*( u3(IH,JH,kte-k+kts) + u3(IH,JH,kte-k+kts-1) ) vi(k) = 0.5*( v3(IH,JH,kte-k+kts) + v3(IH,JH,kte-k+kts-1) ) thli(k) = 0.5*( thl3(IH,JH,kte-k+kts) + thl3(IH,JH,kte-k+kts-1) ) - qti(k) = 0.5*( qt3(IH,JH,kte-k+kts) + qt3(IH,JH,kte-k+kts-1) ) qvi(k) = 0.5*( qv3(IH,JH,kte-k+kts) + qv3(IH,JH,kte-k+kts-1) ) qli(k) = 0.5*( ql3(IH,JH,kte-k+kts) + ql3(IH,JH,kte-k+kts-1) ) qii(k) = 0.5*( qi3(IH,JH,kte-k+kts) + qi3(IH,JH,kte-k+kts-1) ) @@ -393,7 +384,6 @@ SUBROUTINE RUN_EDMF(its,ite, jts,jte, kts,kte, dt, & ! Inputs ui(k) = u3(IH,JH,kte-k+kts-1) vi(k) = v3(IH,JH,kte-k+kts-1) thli(k) = thl3(IH,JH,kte-k+kts-1) - qti(k) = qt3(IH,JH,kte-k+kts-1) qvi(k) = qv3(IH,JH,kte-k+kts-1) qli(k) = ql3(IH,JH,kte-k+kts-1) qii(k) = qi3(IH,JH,kte-k+kts-1) @@ -403,17 +393,17 @@ SUBROUTINE RUN_EDMF(its,ite, jts,jte, kts,kte, dt, & ! Inputs ui(kte) = u(kte) vi(kte) = v(kte) thli(kte) = thl(kte) - qti(kte) = qt(kte) qvi(kte) = qv(kte) qli(kte) = ql(kte) qii(kte) = qi(kte) ui(kts-1) = u(kts) vi(kts-1) = v(kts) thli(kts-1) = thl(kts) ! approximate - qti(kts-1) = qt(kts) qvi(kts-1) = qv(kts) qli(kts-1) = ql(kts) qii(kts-1) = qi(kts) + qt = qv+ql+qi + qti = qvi+qli+qii DO k=kts-1,kte rhoe(k) = rhoe3(IH,JH,kte-k+kts-1) @@ -446,9 +436,9 @@ SUBROUTINE RUN_EDMF(its,ite, jts,jte, kts,kte, dt, & ! Inputs call Poisson(1,Nup2,kts,kte,ENTf,ENTi,the_seed) do i=1,Nup2 do k=kts,kte - ENT(k,i) = (1.-MFPARAMS%STOCHFRAC) * MFPARAMS%Ent0/L0 & - + MFPARAMS%STOCHFRAC * real(ENTi(k,i))*MFPARAMS%Ent0/(ZW(k)-ZW(k-1)) - ! Increase ent above 2000m to limit deepest plumes + ENT(k,i) = (1.-MFPARAMS%STOCHFRAC) * MFPARAMS%Ent0/L0 & + + MFPARAMS%STOCHFRAC * real(ENTi(k,i))*MFPARAMS%Ent0/(ZW(k)-ZW(k-1)) + ! Increase ent above 2500m to limit deepest plumes if (ZW(k).gt.2500.) ENT(k,i) = ENT(k,i)*(1.+(ZW(k)-2500.)/500.) enddo enddo @@ -460,12 +450,6 @@ SUBROUTINE RUN_EDMF(its,ite, jts,jte, kts,kte, dt, & ! Inputs + MFPARAMS%STOCHFRAC * real(ENTi(k,i))*MFPARAMS%Ent0/(ZW(k)-ZW(k-1)) ) !& enddo enddo - else if (MFPARAMS%ENTRAIN==2) then - do i=1,Nup2 ! alternate approach from Soares et al 2004 - do k=kts,kte - ENT(k,i) = MFPARAMS%Ent0*(1./(ZW(k)+ZW(k)-ZW(k-1))+1./(max(0.,L0-ZW(k))+ZW(k)-ZW(k-1))) - enddo - enddo end if else ! if L0 <= 0 @@ -507,7 +491,6 @@ SUBROUTINE RUN_EDMF(its,ite, jts,jte, kts,kte, dt, & ! Inputs else UPW(kts-1,I)=min(0.5*(wlv+wtv), 5.) if (MFPARAMS%UPABUOYDEP/=0) then -! UPA(kts-1,I)=MIN(1.0,0.5+wthv/0.2)*(0.5*ERF(wtv/(sqrt(2.)*sigmaW))-0.5*ERF(wlv/(sqrt(2.)*sigmaW))) UPA(kts-1,I)=(0.5+0.5*TANH((wthv-0.02)/0.09))*(0.5*ERF(wtv/(sqrt(2.)*sigmaW))-0.5*ERF(wlv/(sqrt(2.)*sigmaW))) else UPA(kts-1,I)=(0.5*ERF(wtv/(sqrt(2.)*sigmaW))-0.5*ERF(wlv/(sqrt(2.)*sigmaW))) @@ -521,7 +504,6 @@ SUBROUTINE RUN_EDMF(its,ite, jts,jte, kts,kte, dt, & ! Inputs UPQT(kts-1,I)=QT(kts)+MFSRCQT(IH,JH,I) UPTHV(kts-1,I)=THV(kts)+MFSRCTHL(IH,JH,I) else -! UPQT(kts-1,I)=QT(kts)-(-1.**I)*0.32*UPW(kts-1,I)*sigmaQT/sigmaW UPQT(kts-1,I)=QT(kts)+0.32*UPW(kts-1,I)*sigmaQT/sigmaW UPTHV(kts-1,I)=THV(kts)+0.58*UPW(kts-1,I)*sigmaTH/sigmaW end if @@ -552,13 +534,13 @@ SUBROUTINE RUN_EDMF(its,ite, jts,jte, kts,kte, dt, & ! Inputs THVsrfF = THVsrfF+UPW(kts-1,I)*UPA(kts-1,I)*(UPTHV(kts-1,I)-THV(kts)) ENDDO - ! Adjust updraft THV so updraft flux is 90% of surface flux + ! Adjust updraft THV so updraft flux is <90% of surface flux if (THVsrfF .gt. 0.9*wthv .and. THVsrfF .gt. 0.1) then UPTHV(kts-1,:)=(UPTHV(kts-1,:)-THV(kts))*0.9*wthv/THVsrfF+THV(kts) ! print *,'adjusting surface THV perturbation by a factor',0.9*wthv/THVsrfF endif - ! Adjust updraft QT so updraft flux is 90% of surface flux + ! Adjust updraft QT so updraft flux is <90% of surface flux IF ( (QTsrfF .gt. 0.9*wqt) .and. (wqt .gt. 0.) ) then UPQT(kts-1,:)=(UPQT(kts-1,:)-QT(kts))*0.9*wqt/QTsrfF+QT(kts) ! print *,'adjusting surface QT perturbation by a factor',0.9*wqt/QTsrfF @@ -583,9 +565,6 @@ SUBROUTINE RUN_EDMF(its,ite, jts,jte, kts,kte, dt, & ! Inputs if (MFPARAMS%ENTRAIN==3) then ! dynamic entrainment rates ENT(K,I) = MFPARAMS%ENT0*max(1e-4,B)/max(0.1,UPW(K,I)**2) elseif (MFPARAMS%ENTRAIN==4) then - ! ENT(K,I) = (1.-MFPARAMS%STOCHFRAC)*MFPARAMS%Ent0/L0 & - ! + MFPARAMS%STOCHFRAC*MFPARAMS%ENT0*0.0032/max(0.1,UPW(K-1,I)) - ! ENT(K,I) = 1e-3*(MFPARAMS%Ent0/(max(min(UPW(K-1,I),2.0),0.5))-0.5) ENT(K,I) = ENT(K,I)*(1.+3.0*sqrt(TKE3(IH,JH,I))/max(0.1,UPW(K-1,I))) end if @@ -618,7 +597,7 @@ SUBROUTINE RUN_EDMF(its,ite, jts,jte, kts,kte, dt, & ! Inputs Wn2=UPW(K-1,I)**2+2.*MFPARAMS%WA*B*(ZW(k)-ZW(k-1)) ELSE EntW=exp(-2.*WP*(ZW(k)-ZW(k-1))) - Wn2=EntW*UPW(k-1,I)**2+MFPARAMS%WA*B/WP*(1.-EntW) + Wn2=EntW*UPW(k-1,I)**2+(1.-EntW)*MFPARAMS%WA*B/WP END IF @@ -635,10 +614,17 @@ SUBROUTINE RUN_EDMF(its,ite, jts,jte, kts,kte, dt, & ! Inputs ! trisolver source terms due to condensation. assumes that condensation is responsible ! for any increase in condesate flux with height. ignores lateral mixing. - tmp = max(0.,UPA(K,I)*(RHOE(K)*UPW(K,I)*UPQL(K,I)-RHOE(K-1)*UPW(K-1,I)*UPQL(K-1,I))) + tmp = max(0.,UPA(K,I)*(RHOE(K)*UPW(K,I)*UPQL(K,I)-RHOE(K-1)*UPW(K-1,I)*UPQL(K-1,I))) ! qlflx divergence qlsrc3(IH,JH,KTE+KTS-K) = qlsrc3(IH,JH,KTE+KTS-K) + tmp qvsrc3(IH,JH,KTE+KTS-K) = qvsrc3(IH,JH,KTE+KTS-K) - tmp ssrc3(IH,JH,KTE+KTS-K) = ssrc3(IH,JH,KTE+KTS-K) + tmp*MAPL_ALHL + tmp2 = max(0.,UPA(K,I)*(RHOE(K)*UPW(K,I)*UPQI(K,I)-RHOE(K-1)*UPW(K-1,I)*UPQI(K-1,I))) ! qiflx divergence + qisrc3(IH,JH,KTE+KTS-K) = qisrc3(IH,JH,KTE+KTS-K) + tmp2 + tmp = max(0.,UPA(K,I)*(RHOE(K-1)*UPW(K-1,I)*UPQL(K-1,I)-RHOE(K)*UPW(K,I)*UPQL(K,I))) ! qlflx convergence + ! if ql convergence, assume ice came from ql, with remainder from qv + qlsrc3(IH,JH,KTE+KTS-K) = qlsrc3(IH,JH,KTE+KTS-K) - min(tmp,tmp2) + qvsrc3(IH,JH,KTE+KTS-K) = qvsrc3(IH,JH,KTE+KTS-K) - (tmp2-min(tmp,tmp2)) + ssrc3(IH,JH,KTE+KTS-K) = ssrc3(IH,JH,KTE+KTS-K) + tmp2*MAPL_ALHS ELSE UPW(K,I) = 0. UPA(K,I) = 0. @@ -647,26 +633,6 @@ SUBROUTINE RUN_EDMF(its,ite, jts,jte, kts,kte, dt, & ! Inputs end if ! check if updraft still rising ENDDO ! I: loop over updrafts - ! Near-surface CFL: To prevent instability, rescale updraft velocities - ! if mass flux exceeds MFLIMFAC times the layer mass -! if (ZW(k)<300.) then -! mf = SUM(RHOE(k)*UPA(k,:)*UPW(k,:)) -! factor = (2.+(MFPARAMS%MFLIMFAC-2.)*(ZW(k)/300.))*dp(K)/(1e-8+mf*MAPL_GRAV*dt) -! if (factor .lt. 1.0) then -! UPW(k,:) = UPW(k,:)*factor -! ! print *,'rescaling UPW by factor: ',factor -! end if -! end if - -! if (ZW(k)<100.) then -! mf = SUM(RHOE(k)*UPA(k,:)*UPW(k,:)) -! factor = (1.5+(MFPARAMS%MFLIMFAC-1.5)*(ZW(k)/100.))*dp(K)/(1e-8+mf*MAPL_GRAV*dt) -! if (factor .lt. 1.0) then -! UPW(k,:) = UPW(k,:)*factor -! ! print *,'rescaling UPW by factor: ',factor -! end if -! end if - ! loop over vertical ENDDO vertint @@ -697,22 +663,30 @@ SUBROUTINE RUN_EDMF(its,ite, jts,jte, kts,kte, dt, & ! Inputs UPA = factor*UPA QR = factor*QR QS = factor*QS + ssrc3 = factor*ssrc3 + qvsrc3 = factor*qvsrc3 + qlsrc3 = factor*qlsrc3 + qisrc3 = factor*qisrc3 ! Rescale UPA if MF TKE more than half of prognostic TKE near surface ! Prevents instability due to MF without KH K = KTS tmp = 0. tmp2 = 0. - DO WHILE (ZW(K).lt.70. .and. K.lt.KTE) + DO WHILE (ZW(K).lt.100. .and. K.lt.KTE) tmp = tmp + 0.5*SUM(UPA(K,:)*UPW(K,:)*UPW(K,:)) tmp2 = tmp2 + TKE3(IH,JH,KTE-K+KTS) -! UPW(K,:) = UPW(K,:)*exp(-(100.-ZW(K))**2/1e4) K = K+1 END DO if (tmp.gt.0.5*tmp2) then - UPA = UPA*(0.5*tmp2/tmp) - QR = QR*(0.5*tmp2/tmp) - QS = QS*(0.5*tmp2/tmp) + factor = 0.5*tmp2/tmp + UPA = factor*UPA + QR = factor*QR + QS = factor*QS + ssrc3 = factor*ssrc3 + qvsrc3 = factor*qvsrc3 + qlsrc3 = factor*qlsrc3 + qisrc3 = factor*qisrc3 end if DO k=KTS,KTE @@ -721,25 +695,11 @@ SUBROUTINE RUN_EDMF(its,ite, jts,jte, kts,kte, dt, & ! Inputs DQRDT(IH,JH,KTS:KTE) = QR(KTE:KTS:-1)/DT DQSDT(IH,JH,KTS:KTE) = QS(KTE:KTS:-1)/DT - ! - ! do tracer transport with 'bulk' plume - ! - -! DO n=1,NTR - ! Find tracer flux profile -! DO k=KTS-1,KTE -! trflx( -! END DO - - ! Add tracer tendency directly to bundle - -! END DO ! ! writing updraft properties for output ! all variables, except Areas are now multipled by the area ! - dry_a = 0. moist_a = 0. @@ -937,8 +897,6 @@ SUBROUTINE RUN_EDMF(its,ite, jts,jte, kts,kte, dt, & ! Inputs mfqt3(IH,JH,K) = 0.5*(s_aqt3(KTE+KTS-K-1)+s_aqt3(KTE+KTS-K)) mfhl3(IH,JH,K) = 0.5*(s_ahl3(KTE+KTS-K-1)+s_ahl3(KTE+KTS-K)) end if - ! mfhl2(IH,JH,K)=0.5*(s_ahl2(KTE+KTS-K-1)+s_ahl2(KTE+KTS-K)) ! no longer needed - ! mfqt2(IH,JH,K)=0.5*(s_aqt2(KTE+KTS-K-1)+s_aqt2(KTE+KTS-K)) ! no longer needed ENDDO @@ -1038,7 +996,7 @@ subroutine condensation_edmf(QT,THL,P,THV,QC,wf,ice_ramp) real :: diff,exn,t,qs,qcold ! max number of iterations -niter=50 +niter=20 ! minimum difference diff=2.e-5 @@ -1082,7 +1040,7 @@ subroutine condensation_edmfA(THV,QT,P,THL,QL,QI,ice_ramp) real :: diff,exn,t,qs,qcold,wf,qc ! max number of iterations -niter=50 +niter=20 ! minimum difference diff=2.e-5 diff --git a/GEOSmkiau_GridComp/pyMKIAU/pyMKIAU/__init__.py b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/grads.txt similarity index 100% rename from GEOSmkiau_GridComp/pyMKIAU/pyMKIAU/__init__.py rename to GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/grads.txt diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/shoc.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/shoc.F90 index 92cb6eac1..64c696d3d 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/shoc.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/shoc.F90 @@ -60,7 +60,6 @@ subroutine run_shoc( nx, ny, nzm, nz, dtn, & ! in smixt_inv, lmix_out, smixt1_inv, & ! out smixt2_inv,smixt3_inv, & ! out bruntmst_inv, ri_inv, prnum_inv, & ! out -! bruntmst_inv, bruntdry_inv, bruntedg_inv, ri_inv, prnum_inv, & ! out shocparams ) @@ -100,15 +99,14 @@ subroutine run_shoc( nx, ny, nzm, nz, dtn, & ! in real, intent(in ) :: qpl_inv (nx,ny,nzm) ! rain mixing ratio, kg/kg real, intent(in ) :: qpi_inv (nx,ny,nzm) ! snow mixing ratio, kg/kg real, intent(in ) :: cld_sgs_inv(nx,ny,nzm) ! sgs cloud fraction -! real, intent(in ) :: dtdtrad (nx,ny,nzm) ! radiative cooling tendency real, intent(in ) :: tke_mf (nx,ny,nz) ! MF vertical velocity on edges, m/s real, intent(in ) :: zpbl (nx,ny) ! PBLH diagnosed in TurbGridComp real, intent(inout) :: tke_inv (nx,ny,nzm) ! turbulent kinetic energy. m**2/s**2 real, intent(inout) :: tkh_inv (nx,ny,nzm) ! eddy scalar diffusivity real, intent( out) :: tkm_inv (nx,ny,nzm) ! eddy momentum diffusivity real, intent( out) :: isotropy_inv(nx,ny,nzm) ! return to isotropy timescale + real, intent(inout) :: tkesbdiss_inv(nx,ny,nzm) ! dissipation - real, dimension(:,:,:), pointer :: tkesbdiss_inv ! dissipation real, dimension(:,:,:), pointer :: tkesbbuoy_inv ! buoyancy production real, dimension(:,:,:), pointer :: tkesbshear_inv ! shear production @@ -118,7 +116,8 @@ subroutine run_shoc( nx, ny, nzm, nz, dtn, & ! in real, dimension(:,:,:), pointer :: smixt2_inv ! length scale, term 2 real, dimension(:,:,:), pointer :: smixt3_inv ! length scale, term 3 real, dimension(:,:,:), pointer :: bruntmst_inv ! moist Brunt vaisala frequency -! real, dimension(:,:,:), pointer :: bruntdry_inv ! Brunt vaisala frequency on edges +! real, dimension(:,:,:), pointer :: bruntcld_inv ! moist Brunt vaisala frequency +! real, dimension(:,:,:), pointer :: bruntdry_inv ! Dry Brunt vaisala frequency ! real, dimension(:,:,:), pointer :: bruntedg_inv ! Brunt vaisala frequency on edges real, dimension(:,:,:), pointer :: ri_inv real, dimension(:,:,:), pointer :: prnum_inv @@ -163,11 +162,11 @@ subroutine run_shoc( nx, ny, nzm, nz, dtn, & ! in real omega (nx,ny,nzm) ! pressure velocity, Pa/s real tabs (nx,ny,nzm) ! absolute temperature, K real qwv (nx,ny,nzm) ! specific humidity, kg/kg - real qpl (nx,ny,nzm) - real qpi (nx,ny,nzm) + real qpl (nx,ny,nzm) ! liquid precip + real qpi (nx,ny,nzm) ! ice precip real cld_sgs (nx,ny,nzm) ! cloud fraction real tke (nx,ny,nzm) ! turbulent kinetic energy, m2/s2 - real tkh (nx,ny,nzm) + real tkh (nx,ny,nzm) ! diffusivity for heat real prnum (nx,ny,nz) ! Prandtl number real wthv_sec(nx,ny,nzm) ! Total buoyancy flux real wthv_mf(nx,ny,nzm) ! Buoyancy flux diagnosed from MF @@ -176,15 +175,15 @@ subroutine run_shoc( nx, ny, nzm, nz, dtn, & ! in real tkesbshear(nx,ny,nzm) ! TKE tendency from shear ! Eddy length formulation - real smixt (nx,ny,nzm) ! Turbulent length scale, m - real smixt1 (nx,ny,nzm) ! Turbulent length scale, m + real smixt (nx,ny,nzm) ! Total length scale, m + real smixt1 (nx,ny,nzm) ! Surface length scale, m real smixt2 (nx,ny,nzm) ! Turbulent length scale, m - real smixt3 (nx,ny,nzm) ! Turbulent length scale, m + real smixt3 (nx,ny,nzm) ! Stability length scale, m real isotropy (nx,ny,nzm) ! "Return-to-isotropy" eddy dissipation time scale, s real brunt (nx,ny,nzm) ! Moist Brunt-Vaisalla frequency, s^-1 real, dimension(nx,ny,nzm) :: total_water, brunt2, def2, thv, l_par - real, dimension(nx,ny,nz) :: brunt_edge !, brunt_dry + real, dimension(nx,ny,nz) :: brunt_edge, brunt_dry, brunt_cld real, dimension(nx,ny) :: l_inf, l_mix, zcb, lts!, l_par!, denom, numer, cldarr @@ -193,10 +192,9 @@ subroutine run_shoc( nx, ny, nzm, nz, dtn, & ! in tkes, pval, pkap, thlsec, qwsec, & qwthlsec, wqwsec, wthlsec, dum, sm, & prespot, wrk, wrk1, wrk2, wrk3, & - tkeavg, dtqw, dtqi !, l_par + tkeavg, dtqw, dtqi integer i,j,k,km1,ku,kd,ka,kb,kinv,strt,fnsh,cnvl -! integer, dimension(nx,ny) :: cldbasek real, parameter :: bruntmin = 1e-7 real, parameter :: vonk = 0.4 @@ -290,14 +288,13 @@ subroutine run_shoc( nx, ny, nzm, nz, dtn, & ! in !=== Assign exports and flip vertical ===! - tkh_inv(:,:,1:nzm) = tkh(:,:,nzm:1:-1) - tkm_inv(:,:,1:nzm) = min(tkhmax,tkh(:,:,nzm:1:-1)*prnum(:,:,nzm:1:-1)) - isotropy_inv(:,:,1:nzm) = isotropy(:,:,nzm:1:-1) - tke_inv(:,:,1:nzm) = tke(:,:,nzm:1:-1) + tkh_inv(:,:,1:nzm) = tkh(:,:,nzm:1:-1) + tkm_inv(:,:,1:nzm) = min(tkhmax,tkh(:,:,nzm:1:-1)*prnum(:,:,nzm:1:-1)) + isotropy_inv(:,:,1:nzm) = isotropy(:,:,nzm:1:-1) + tke_inv(:,:,1:nzm) = tke(:,:,nzm:1:-1) + tkesbdiss_inv(:,:,1:nzm) = tkesbdiss(:,:,nzm:1:-1) ! Below exports are optional - - if (associated(tkesbdiss_inv)) tkesbdiss_inv(:,:,1:nzm) = tkesbdiss(:,:,nzm:1:-1) if (associated(tkesbbuoy_inv)) tkesbbuoy_inv(:,:,1:nzm) = tkesbbuoy(:,:,nzm:1:-1) if (associated(tkesbshear_inv)) tkesbshear_inv(:,:,1:nzm) = tkesbshear(:,:,nzm:1:-1) @@ -379,7 +376,6 @@ subroutine tke_shoc() end if buoy_sgs = brunt(i,j,k) -! buoy_sgs = - a_prod_bu / (wrk + 0.0001) ! tkh is eddy thermal diffussivity !Compute $c_k$ (variable Cee) for the TKE dissipation term following Eq. 11 in Deardorff (1980) if (buoy_sgs <= 0.0) then @@ -391,11 +387,8 @@ subroutine tke_shoc() Cee = Cek* (pt19 + pt51*smix/grd) wrk = 0.5 * wrk * (prnum(i,j,ku) + prnum(i,j,kd)) - if (nx.eq.1) then - a_prod_sh = min(min(tkhmax,wrk)*def2(i,j,k),0.0001) ! TKE shear production term - else - a_prod_sh = min(min(tkhmax,wrk)*def2(i,j,k),0.01) ! TKE shear production term - end if + + a_prod_sh = min(min(tkhmax,wrk)*def2(i,j,k),0.1) ! TKE shear production term ! Semi-implicitly integrate TKE equation forward in time wtke = tke(i,j,k) @@ -407,14 +400,9 @@ subroutine tke_shoc() do itr=1,nitr ! iterate for implicit solution wtke = min(max(wrk2, wtke), max_tke) a_diss = wrk*sqrt(wtke) ! Coefficient in the TKE dissipation term -! if (a_diss.ne.-1.) then - wtke = wrk1 / (1.+a_diss) -! else -! wtke = wrk1 / (1.01+a_diss) -! end if + wtke = wrk1 / (1.+a_diss) wtke = tkef1*wtke + tkef2*wtk2 ! tkef1+tkef2 = 1.0 wtk2 = wtke - enddo tke(i,j,k) = min(max(wrk2, wtke), max_tke) @@ -442,54 +430,29 @@ subroutine tke_shoc() do j=1,ny do i=1,nx ! Calculate "return-to-isotropy" eddy dissipation time scale, see Eq. 8 in BK13 - if (brunt_edge(i,j,k) <= bruntmin) then + ! ignore stability dependence within the lower CBL, to prevent occasional + if (brunt_edge(i,j,k) <= 1e-5 .or. zl(i,j,k).lt.0.7*zpbl(i,j)) then isotropy(i,j,k) = max(30.,min(max_eddy_dissipation_time_scale,0.5*(tscale1(i,j,k)+tscale1(i,j,k-1)))) else wrk = 0.5*(tscale1(i,j,k)+tscale1(i,j,k-1)) isotropy(i,j,k) = max(30.,min(max_eddy_dissipation_time_scale,wrk/(1.0+lambda*brunt_edge(i,j,k)*wrk*wrk))) -! isotropy(i,j,k) = max(30.,min(max_eddy_dissipation_time_scale,wrk/(1.0+lambda*0.5*(brunt(i,j,k)+brunt(i,j,k-1))*wrk*wrk))) endif -! if (k.ge.cldbasek(i,j)) then -! isotropy(i,j,k) = min(200.+(0.5+0.5*tanh(0.3*(lts(i,j)-19.)))*(max_eddy_dissipation_time_scale-200.),isotropy(i,j,k)) -! end if if (tke(i,j,k).lt.2e-4) isotropy(i,j,k) = 30. wrk1 = ck / prnum(i,j,k) -! tkh(i,j,k) = 0.5*( smixt(i,j,k)*sqrt(tke(i,j,k)) & ! alternate form -! + smixt(i,j,k-1)*sqrt(tke(i,j,k-1)) ) + tkh(i,j,k) = wrk1*isotropy(i,j,k)*0.5*(tke(i,j,k)+tke(i,j,k-1)) -! tke_env = max(min_tke,0.5*(tke(i,j,k)+tke(i,j,k-1))-0.*tke_mf(i,j,nz-k+1)) - tkh(i,j,k) = wrk1*isotropy(i,j,k)*0.5*(tke(i,j,k)+tke(i,j,k-1)) ! & -! *(tke_env) ! remove MF TKE tkh(i,j,k) = min(tkh(i,j,k),tkhmax) end do ! i end do ! j end do ! k isotropy(:,:,1) = isotropy(:,:,2) -! add radiation-driven entrainment (simplified) -! do j=1,ny -! do i=1,nx -! do k=2,nzm-1 -! if (zl(i,j,k).gt.4000.) exit -! if (cld_sgs(i,j,k).gt.0.1 .and. cld_sgs(i,j,k+1).lt.0.1) then - -! dbuoy = max( 0.1, (thv(i,j,k)/ggr)*brunt(i,j,k) ) -! krad = -1.*adzl(i,j,k)*shocparams%kradfac*minval(dtdtrad(i,j,nzm-k-1:nzm-k+1))/dbuoy -! tkh(i,j,k+1) = tkh(i,j,k+1) + krad !add to KH at interface between cloud>0.1 and <0.1 -! print *,'krad=',krad,' ztop=',zi(i,j,k+1) - -! exit -! end if -! end do -! end do -! end do - end subroutine tke_shoc subroutine calc_numbers() - ! Defines Richardson number and Prandtl number on edges + ! Defines Richardson number and Prandtl number on edges real, dimension(nx,ny,nzm-1) :: DU DU = (U(:,:,1:nzm-1) - U(:,:,2:nzm))**2 + & ! shear on edges @@ -501,7 +464,6 @@ subroutine calc_numbers() / ( 0.5*( THV(:,:,1:nzm-1)+THV(:,:,2:nzm) ) * (DU**2) ) if (SHOCPARAMS%PRNUM.lt.0.) then -! where (RI.le.0. .or. tke_mf(:,:,nz:1:-1).gt.1e-6) where (RI.le.0. .or. tke_mf(:,:,nz:1:-1).gt.1e-4) PRNUM = -1.*SHOCPARAMS%PRNUM elsewhere @@ -594,17 +556,8 @@ subroutine eddy_length() ! This subroutine computes the turbulent length scale ! Local variables - real wrk, wrk1, wrk2, wrk3!, zdecay - integer i, j, k, kk, kl, ku, kb, kc!, ktop - -! do j=1,ny -! do i=1,nx -! cldarr(i,j) = 0.0 -! numer(i,j) = 0.0 -! denom(i,j) = 0.0 -! enddo -! enddo - + real wrk, wrk1, wrk2, wrk3 + integer i, j, k, kk, kl, ku, kb, kc do k=1,nzm kb = k-1 @@ -626,90 +579,15 @@ subroutine eddy_length() endif betdz = bet(i,j,k) / thedz - -! brunt_edge(i,j,k) = (2.*ggr/(thv(i,j,k)+thv(i,j,kb)))*(thv(i,j,k)-thv(i,j,kb))/adzi(i,j,k) !g/thv/dz *(thv-thv) ! brunt_dry(i,j,k) = (thv(i,j,kc)-thv(i,j,kb))*betdz ! Reinitialize the mixing length related arrays to zero smixt(i,j,k) = 1.0 ! shoc_mod module variable smixt brunt(i,j,k) = 0.0 -!Eq. 11 in BK13 (Eq. 4.13 in Pete's dissertation) -!Outside of cloud, integrate from the surface to the cloud base -!Should the 'if' below check if the cloud liquid < a small constant instead? - -! if (qcl(i,j,k)+qci(i,j,k) <= 1e-6 .and. cldarr(i,j).eq.0.0) then -! if (qcl(i,j,k)+qci(i,j,k) <= 0.) then -! tkes = sqrt(tke(i,j,k)) * adzl(i,j,k) -! numer(i,j) = numer(i,j) + tkes*zl(i,j,k) ! Numerator in Eq. 11 in BK13 -! denom(i,j) = denom(i,j) + tkes ! Denominator in Eq. 11 in BK13 - -! else -! cldarr(i,j) = 1.0 ! Take note of columns containing cloud. -! endif enddo enddo enddo -! brunt_edge(:,:,nz) = brunt_edge(:,:,nzm) - -! Calculate the measure of PBL depth, Eq. 11 in BK13 (Is this really PBL depth?) -! cldbasek(:,:) = 1 - do j=1,ny - do i=1,nx - -! do k=1,nzm -! if (zl(i,j,k).gt.3000. .or. cld_sgs(i,j,k).gt.0.01) exit -! tkes = sqrt(tke(i,j,k)) * adzl(i,j,k) -! numer(i,j) = numer(i,j) + tkes*zl(i,j,k) ! Numerator in Eq. 11 in BK13 -! denom(i,j) = denom(i,j) + tkes ! Denominator in Eq. 11 in BK13 -! end do - -! if (denom(i,j) > 0.0 .and. numer(i,j) > 0.0) then -!! l_inf(i,j) = max(min(0.1 * (numer(i,j)/denom(i,j)),300.),10.) -! l_inf(i,j) = max(min( numer(i,j)/denom(i,j), 1000. ),100.) -! else -! l_inf(i,j) = 100. -! endif - - ! Identify mixed layer top as level where THV exceeds THV(3) + 0.4 K - ! Interpolate for final height based on gradient - ! Ignore single isolated levels -! kk = 4 -! do while (thv(i,j,3)+0.4 .gt. thv(i,j,kk) .or. thv(i,j,3)+0.4 .gt. thv(i,j,kk+1)) -! kk = kk+1 -! end do -! dum = (thv(i,j,kk-1)-thv(i,j,kk-2)) - -! if (abs(dum) .gt. 1e-3) then -! l_mix(i,j) = max(zl(i,j,kk-1)+0.*(thv(i,j,3)+0.4-thv(i,j,kk-1))*(zl(i,j,kk-1)-zl(i,j,kk-2))/dum,100.) -! else -! l_mix(i,j) = max(zl(i,j,kk-1),100.) -! end if - -! do while ((zl(i,j,cldbasek(i,j)).lt.300.) .or. (cld_sgs(i,j,cldbasek(i,j)).lt.0.001 .and. cldbasek(i,j).lt.nzm)) -! cldbasek(i,j) = cldbasek(i,j) + 1 -! end do - - kk = 1 - do while (zl(i,j,kk) .lt. 3000. .or. kk.eq.nzm) - kk = kk + 1 - end do - lts(i,j) = thv(i,j,kk) - thv(i,j,1) - -! Alternate cloud base calculation -! tep = tabs(i,j,1) -! qsp = MAPL_EQsat(tabs(i,j,1),prsl(i,j,1),dtqw) -! kk = 1 -! do while (qsp .gt. total_water(i,j,1) .and. zl(i,j,kk).lt.1500.) -! kk = kk+1 -! tep = tep - ggr*( zl(i,j,kk)-zl(i,j,kk-1) )/cp -! qsp = MAPL_EQsat(tep,prsl(i,j,kk),dtqw) -! end do -! zcb(i,j) = max(200.,zl(i,j,kk-1)) !kk-1 is highest level *before* condensation -! if (nx.eq.1) print *,'zcb=',zcb(i,j) - enddo - enddo - !Calculate length scale outside of cloud, Eq. 10 in BK13 (Eq. 4.12 in Pete's dissertation) do k=1,nzm @@ -742,8 +620,6 @@ subroutine eddy_length() wrk = qcl(i,j,k) + qci(i,j,k) -! Find the in-cloud Brunt-Vaisalla frequency - ! ideally we should use fQi or ice_fraction() from MoistGC here omn = qcl(i,j,k) / (wrk+1.e-20) ! Ratio of liquid water to total water @@ -763,7 +639,6 @@ subroutine eddy_length() ! + (1.-omn) * dtqsati(tabs(i,j,k),prsl(i,j,k)) dqsat = omn * dtqw + (1.-omn) * dtqi -! liquid/ice moist static energy static energy divided by cp? bbb = (1. + epsv*qsatt-wrk-qpl(i,j,k)-qpi(i,j,k) & + 1.61*tabs(i,j,k)*dqsat) / (1.+lstarn*dqsat) @@ -795,6 +670,7 @@ subroutine eddy_length() + (bbb*fac_cond-tabs(i,j,k))*(qpl(i,j,kc)-qpl(i,j,kb)) & + (bbb*fac_sub -tabs(i,j,k))*(qpi(i,j,kc)-qpi(i,j,kb)) ) +! Calc outside-of-cloud on edges bbb = 0.5*(bbb + 1. + epsv*qv(i,j,k-1) - qpl(i,j,k-1) - qpi(i,j,k-1)) if (k.gt.1) then brunt_edge(i,j,k) = brunt_edge(i,j,k) + (1.-0.5*(cld_sgs(i,j,k)+cld_sgs(i,j,k-1)))*betdz*( bbb*(hl(i,j,k)-hl(i,j,k-1)) & @@ -806,10 +682,10 @@ subroutine eddy_length() ! Reduction of mixing length in the stable regions (where B.-V. freq. > 0) is required. ! Here we find regions of Brunt-Vaisalla freq. > 0 for later use. - if (brunt(i,j,k) >= bruntmin) then - brunt2(i,j,k) = brunt(i,j,k) - else + if (brunt(i,j,k) < 1e-5 .or. zl(i,j,k).lt.0.7*zpbl(i,j)) then brunt2(i,j,k) = bruntmin + else + brunt2(i,j,k) = brunt(i,j,K) endif end do @@ -821,20 +697,8 @@ subroutine eddy_length() brunt2(:,:,1) = brunt2(:,:,2) brunt2(:,:,nzm) = brunt2(:,:,nzm-1) -! do j=1,ny -! do i=1,nx -! kk = 1 -! l_mix(i,j) = 0. -! do while (l_mix(i,j).lt.1e-5 .and. kk.lt.nzm) -! l_mix(i,j) = l_mix(i,j) + brunt(i,j,kk)*adzl(i,j,kk) -! kk = kk+1 -! end do -! l_mix(i,j) = zl(i,j,kk) -! end do -! end do - -! brunt_dry = max( bruntmin, brunt_dry ) +!=========== Length scale calculations =========== do k=1,nzm do j=1,ny do i=1,nx @@ -844,42 +708,24 @@ subroutine eddy_length() ! Calculate turbulent length scale in the boundary layer. ! See Eq. 10 in BK13 (Eq. 4.12 in Pete's dissertation) - !---------------------------------- ! calculate parcel mixing length !---------------------------------- kk = k - wrk = thv(i,j,k)+0.2 !max(0.001,3.*wthv_sec(i,j,k)) / max(0.05,sqrt(0.667)*tkes) ! upward T perturbation + wrk = thv(i,j,k)+0.2 ! upward T perturbation do while (wrk .gt. thv(i,j,kk+1) .and. kk.lt.nzm) kk = kk+1 end do l_par(i,j,k) = zl(i,j,kk) + max(0.,(wrk-thv(i,j,kk))* & (zl(i,j,kk+1)-zl(i,j,kk)) / (thv(i,j,kk+1)-thv(i,j,kk))) kk = k - wrk = thv(i,j,k)-0.2 !max(0.001,3.*wthv_sec(i,j,k)) / max(0.05,sqrt(0.667)*tkes) ! downward T perturbation + wrk = thv(i,j,k)-0.2 ! downward T perturbation do while (wrk .lt. thv(i,j,kk-1) .and. kk .gt. 1) kk = kk-1 end do l_par(i,j,k) = l_par(i,j,k) - zl(i,j,kk) + max(0.,(thv(i,j,kk)-wrk)* & (zl(i,j,kk)-zl(i,j,kk-1))/(thv(i,j,kk)-thv(i,j,kk-1))) - l_par(i,j,k) = max(min(l_par(i,j,k),1500.),25.) - - - !---------------------------------- - ! calculate 'TKE' mixing length - !---------------------------------- -! l_mix(i,j) = 0. -! kinv = k -! do while (tke(i,j,kinv).gt.0.02) -! l_mix(i,j) = l_mix(i,j) + adzl(i,j,kinv) -! kinv = kinv+1 -! end do -! kinv = k-1 -! do while (tke(i,j,kinv).gt.0.02) -! l_mix(i,j) = l_mix(i,j) + adzl(i,j,kinv) -! kinv = kinv-1 -! end do -! l_mix(i,j) = 0.1*l_mix(i,j) + l_par(i,j,k) = max(min(l_par(i,j,k),1500.),25.) if ( shocparams%LENOPT .lt. 4 ) then ! SHOC-MF length scale @@ -889,21 +735,20 @@ subroutine eddy_length() ! smixt1(i,j,k) = sqrt(400.*tkes*vonk*zl(i,j,k))*shocparams%LENFAC1 ! original SHOC, includes TKE ! Turbulent length scale - smixt2(i,j,k) = sqrt(l_par(i,j,k)*400.*tkes)*(shocparams%LENFAC2) + smixt2(i,j,k) = sqrt(l_par(i,j,k)*400.*tkes)*shocparams%LENFAC2 ! Stability length scale - smixt3(i,j,k) = max(0.1,tkes)*shocparams%LENFAC3/(sqrt(brunt2(i,j,k))) - + smixt3(i,j,k) = max(0.05,tkes)*shocparams%LENFAC3/(sqrt(brunt2(i,j,k))) !=== Combine component length scales === if (shocparams%LENOPT .eq. 1) then ! JPL blending approach (w/SHOC length scales) - wrk1 = 2./(1./smixt2(i,j,k)+1./smixt3(i,j,k)) + wrk1 = SQRT(3./(1./smixt2(i,j,k)**2+1./smixt3(i,j,k)**2)) if (zl(i,j,k).lt.300.) then - smixt(i,j,k) = wrk1 + (smixt1(i,j,k)-wrk1)*exp(-(zl(i,j,k)/100.)**2) + smixt(i,j,k) = wrk1 + (smixt1(i,j,k)-wrk1)*exp(-(zl(i,j,k)/60.)) else smixt(i,j,k) = wrk1 end if - else if (shocparams%LENOPT .eq. 2) then ! Geometric average + else if (shocparams%LENOPT .eq. 2) then ! Harmonic mean smixt(i,j,k) = min(max_eddy_length_scale, 3./(1./smixt1(i,j,k)+1./smixt2(i,j,k)+1./smixt3(i,j,k)) ) else if (shocparams%LENOPT .eq. 3) then ! SHOC classic approach smixt(i,j,k) = min(max_eddy_length_scale, SQRT(3.)/SQRT(1./smixt1(i,j,k)**2+1./smixt2(i,j,k)**2+1./smixt3(i,j,k)**2) ) @@ -919,13 +764,11 @@ subroutine eddy_length() end if ! Enforce minimum and maximum length scales - wrk = 0.1*min(200.,adzl(i,j,k)) ! Minimum 0.1 of local dz (up to 200 m) - if (zl(i,j,k) .lt. 5000.) then - smixt(i,j,k) = max(wrk, smixt(i,j,k)) - else if (zl(i,j,k) .lt. 9500) then ! Between 5-10 km the max length scale reduces with height - smixt(i,j,k) = max(wrk, min(max_eddy_length_scale*(1e4-zl(i,j,k))/5e3,smixt(i,j,k))) - else - smixt(i,j,k) = max(wrk, min(max_eddy_length_scale*0.1,smixt(i,j,k))) + wrk = 40. !0.5*min(100.,adzl(i,j,k)) ! Minimum 0.1 of local dz (up to 200 m) + if (zl(i,j,k) .lt. 2000.) then + smixt(i,j,k) = max(wrk, smixt(i,j,k)) + else if (zl(i,j,k).gt.zpbl(i,j)) then ! if above 2 km and dry CBL top, cap length scale + smixt(i,j,k) = max(wrk, min(200.,smixt(i,j,k))) end if end do end do @@ -936,61 +779,6 @@ subroutine eddy_length() end subroutine eddy_length - -! subroutine buoyancy_single_gaussian() - -! Compute SGS buoyancy flux using analytic SINGLE-gaussian PDF -! for moisture and liquid water static energy. - -! Local variables - -! integer i,j,k,ku,kd -! real a,b,c,alpha,beta,cc,s,stds - -! DO k=1,nzm - -! kd = k -! ku = k + 1 -! if (k == nzm) ku = k - -! DO j=1,ny -! DO i=1,nx - -! pval = prsl(i,j,k) -! pkap = (pval/100000.0) ** kapa - -! wqwsec = 0.5 * (wqw_sec(i,j,kd) + wqw_sec(i,j,ku)) -! wthlsec = 0.5 * (wthl_sec(i,j,kd) + wthl_sec(i,j,ku)) - - ! following Bechtold et al 1995 -! b = tabs(i,j,k) - fac_cond*qcl(i,j,k) ! Bechtold eqn 4 -! c = MAPL_EQsat(b,prsl(i,j,k),dtqw) -! s = total_water(i,j,k) - MAPL_EQsat(tabs(i,j,k),prsl(i,j,k)) - -! a = 1. / (1.+fac_cond*dtqw) ! Bechtold eqn 6 -! b = a * (1./pkap) * dtqw -! c = a*(total_water(i,j,k) - c) - -! alpha = 0.61 * (tabs(i,j,k)/pkap) ! Bechtold eqn 12 -! beta = (1./pkap) * fac_cond - 1.61*(tabs(i,j,k)/pkap) - - ! Bechtold eqn -! stds = alpha**2 *qwsec + beta**2 * thlsec & -! - 2.*alpha*beta*qwthlsec - - ! Cloud fraction, assuming single Gaussian qt distribution -! cc = 0.5 + 0.5*erf(s/(sqrt2*stds)) - -! wthv_sec(i,j,k) = wthlsec*( 1.+0.61*total_water(i,j,k) & -! - beta*b*cc ) & -! + wqwsec*( alpha + beta*a*cc ) - -! ENDDO -! ENDDO -! ENDDO - -! end subroutine buoyancy_single_gaussian - end subroutine run_shoc @@ -1023,7 +811,7 @@ subroutine update_moments( IM, JM, LM, & ! in w2, & ! out w3, & ! out w3can, & ! out - wqt, & ! out +! wqt, & ! out whl, & ! out hlqt, & ! out qt2diag, & ! out @@ -1033,8 +821,8 @@ subroutine update_moments( IM, JM, LM, & ! in hl2tune, & qt2tune, & hlqt2tune, & - qt3_tscale, & - afrc_tscale,& + skew_tgen, & + skew_tdis, & docanuto ) @@ -1067,7 +855,7 @@ subroutine update_moments( IM, JM, LM, & ! in real, intent( out) :: w2 (IM,JM,LM) ! vertical velocity variance real, intent( out) :: w3 (IM,JM,LM) ! third moment vertical velocity real, intent( out) :: w3can(IM,JM,LM) ! third moment vertical velocity - real, intent( out) :: wqt (IM,JM,LM) ! vertical flux of total water +! real, intent( out) :: wqt (IM,JM,LM) ! vertical flux of total water real, intent( out) :: whl (IM,JM,LM) ! vertical flux of liquid water static energy real, intent( out) :: hlqt (IM,JM,LM) ! total water, static energy covariance real, intent( out) :: qt2diag(IM,JM,LM) @@ -1077,8 +865,8 @@ subroutine update_moments( IM, JM, LM, & ! in real, intent(in ) :: HL2TUNE, & ! tuning parameters HLQT2TUNE, & QT2TUNE, & - QT3_TSCALE, & - AFRC_TSCALE + SKEW_TGEN, & + SKEW_TDIS integer, intent(in ) :: DOPROGQT2, & ! prognostic QT2 switch DOCANUTO @@ -1090,8 +878,8 @@ subroutine update_moments( IM, JM, LM, & ! in integer :: k, kd, ku real, dimension(IM,JM) :: wrk1, wrk2, wrk3 real, dimension(IM,JM) :: sm, onemmf - real, dimension(IM,JM,0:LM) :: qt2_edge, & - qt2_edge_nomf, & + real, dimension(IM,JM,0:LM) :: qt2prod_edge, & + qt2prod_edge_nomf, & hl2_edge, & hl2_edge_nomf, & wqt_edge, & @@ -1115,8 +903,10 @@ subroutine update_moments( IM, JM, LM, & ! in qt2diag = 0. hl2diag = 0. hlqtdiag = 0. + whl_edge(:,:,LM) = SH(:,:)/cp ! used only for Canuto below + - ! define resolved gradients on edges + ! Initial calculations on edges do k=1,LM-1 wrk1 = 1.0 / (ZL(:,:,k)-ZL(:,:,k+1)) wrk3 = KH(:,:,k) * wrk1 @@ -1127,101 +917,63 @@ subroutine update_moments( IM, JM, LM, & ! in wrk1 = HL(:,:,k) - HL(:,:,k+1) whl_edge(:,:,k) = - wrk3 * wrk1 - ! SGS vertical flux of total water. Eq 2 in BK13 - wrk2 = QT(:,:,k) - QT(:,:,k+1) - wqt_edge(:,:,k) = - wrk3 * wrk2 - ! Second moment of liquid/ice water static energy. Eq 4 in BK13 hl2_edge_nomf(:,:,k) = HL2TUNE * sm * wrk1 * wrk1 hl2_edge(:,:,k) = HL2TUNE * 0.5*ISOTROPY(:,:,k) * & (wrk3*wrk1-MFWHL(:,:,k)) * wrk1/(ZL(:,:,k)-ZL(:,:,k+1)) - ! Second moment of total water mixing ratio. Eq 3 in BK13 - qtgrad(:,:,k) = wrk2 / (ZL(:,:,k)-ZL(:,:,k+1)) - qt2_edge(:,:,k) = (KH(:,:,k)*qtgrad(:,:,k)-MFWQT(:,:,k)-WQT_DC(:,:,k))*qtgrad(:,:,k) ! gradient production - qt2_edge_nomf(:,:,k) = (KH(:,:,k)*qtgrad(:,:,k))*qtgrad(:,:,k) ! gradient production + ! Total water gradient + qtgrad(:,:,k) = (QT(:,:,k) - QT(:,:,k+1)) / (ZL(:,:,k)-ZL(:,:,k+1)) + + ! Mean gradient production of total water variance, with and without MF contribution + qt2prod_edge(:,:,k) = (KH(:,:,k)*qtgrad(:,:,k)-MFWQT(:,:,k)-0.*WQT_DC(:,:,k))*qtgrad(:,:,k) + qt2prod_edge_nomf(:,:,k) = (KH(:,:,k)*qtgrad(:,:,k))*qtgrad(:,:,k) ! Covariance of total water mixing ratio and liquid/ice water static energy. Eq 5 in BK13 hlqt_edge(:,:,k) = HLQT2TUNE * sm * wrk1 * wrk2 end do ! set lower boundary conditions - whl_edge(:,:,LM) = SH(:,:)/cp - wqt_edge(:,:,LM) = EVAP(:,:) hl2_edge(:,:,LM) = hl2_edge(:,:,LM-1) hl2_edge_nomf(:,:,LM) = hl2_edge_nomf(:,:,LM-1) - qt2_edge(:,:,LM) = qt2_edge(:,:,LM-1) - qt2_edge_nomf(:,:,LM) = qt2_edge_nomf(:,:,LM-1) + qt2prod_edge(:,:,LM) = qt2prod_edge(:,:,LM-1) + qt2prod_edge_nomf(:,:,LM) = qt2prod_edge_nomf(:,:,LM-1) hlqt_edge(:,:,LM) = hlqt_edge(:,:,LM-1) - qtgrad(:,:,LM) = qtgrad(:,:,LM-1) - qtgrad(:,:,0) = qtgrad(:,:,1) - - - ! Update PDF_A - if (AFRC_TSCALE.gt.0.) then - pdf_a = (pdf_a+mffrc)/(1.+DT/AFRC_TSCALE) - else - pdf_a = pdf_a/(1.-DT/AFRC_TSCALE) - end if - where (mffrc.gt.pdf_a) - pdf_a = mffrc - end where - pdf_a = min(0.5,max(0.,pdf_a)) + ! Full level calculations do k=1,LM kd = k-1 ku = k if (k==1) kd = k - if (DOCANUTO/=0) then - w2(:,:,k) = 0.667*TKE(:,:,k) - - hl2(:,:,k) = 0.5*( hl2_edge(:,:,kd) + hl2_edge(:,:,ku) ) + onemmf = 1.0 - MFFRC(:,:,k) - wrk1 = 0.5*(qt2_edge(:,:,kd)+qt2_edge(:,:,ku)) ! averaging gradient production term - if (DOPROGQT2 /= 0) then - qt2(:,:,k) = (qt2(:,:,k)+DT*wrk1) / (1. + DT*QT2TUNE*1.5e-4) - else - qt2(:,:,k) = QT2TUNE*ISOTROPY(:,:,k)*wrk1 - end if + w2(:,:,k) = onemmf*0.667*TKE(:,:,k) - hlqt(:,:,k) = 0.5*( hlqt_edge(:,:,kd) + hlqt_edge(:,:,ku) ) + hl2(:,:,k) = 0.5*( hl2_edge(:,:,kd) + hl2_edge(:,:,ku) ) + hl2diag(:,:,k) = 0.5*( hl2_edge_nomf(:,:,kd) + hl2_edge_nomf(:,:,ku) ) - wqt(:,:,k) = 0.5*( wqt_edge(:,:,kd) + wqt_edge(:,:,ku) ) + wrk1 = 0.5*(qt2prod_edge(:,:,kd)+qt2prod_edge(:,:,ku)) + if (DOPROGQT2 /= 0) then +! wrk3 = QT2TUNE*1.5e-4 ! dissipation + qt2(:,:,k) = (qt2(:,:,k)+wrk1*DT) / (1. + DT/SKEW_TGEN) + qt2diag(:,:,k) = QT2TUNE*ISOTROPY(:,:,k)*0.5*(qt2prod_edge_nomf(:,:,kd)+qt2prod_edge_nomf(:,:,ku)) else - onemmf = 1.0 - MFFRC(:,:,k) - - w2(:,:,k) = onemmf*0.667*TKE(:,:,k) + MFW2(:,:,k) - -! hl2(:,:,k) = onemmf*0.5*( hl2_edge(:,:,kd) + hl2_edge(:,:,ku) ) !+ MFHL2(:,:,k) - hl2(:,:,k) = 0.5*( hl2_edge(:,:,kd) + hl2_edge(:,:,ku) ) - hl2diag(:,:,k) = 0.5*( hl2_edge_nomf(:,:,kd) + hl2_edge_nomf(:,:,ku) ) - - wrk1 = 0.5*(qt2_edge(:,:,kd)+qt2_edge(:,:,ku)) ! averaging gradient production term - if (DOPROGQT2 /= 0) then - wrk3 = QT2TUNE*1.5e-4 ! dissipation - qt2(:,:,k) = (qt2(:,:,k)+DT*wrk1) / (1. + DT*wrk3) - qt2diag(:,:,k) = QT2TUNE*ISOTROPY(:,:,k)*0.5*(qt2_edge(:,:,kd)+qt2_edge(:,:,ku)) - else -! qt2(:,:,k) = QT2TUNE*ISOTROPY(:,:,k)*wrk1 + MFQT2(:,:,k) - qt2(:,:,k) = QT2TUNE*ISOTROPY(:,:,k)*wrk1 - qt2diag(:,:,k) = QT2TUNE*ISOTROPY(:,:,k)*0.5*(qt2_edge_nomf(:,:,kd)+qt2_edge_nomf(:,:,ku)) - end if - - hlqt(:,:,k) = onemmf*0.5*( hlqt_edge(:,:,kd) + hlqt_edge(:,:,ku) ) + MFHLQT(:,:,k) - hlqtdiag(:,:,k) = 0.5*( hlqt_edge(:,:,kd) + hlqt_edge(:,:,ku) ) - - wqt(:,:,k) = onemmf*0.5*( wqt_edge(:,:,kd) + wqt_edge(:,:,ku) ) + MFWQT(:,:,k) - +! qt2(:,:,k) = QT2TUNE*ISOTROPY(:,:,k)*wrk1 + qt2(:,:,k) = QT2TUNE*SKEW_TGEN*wrk1 + qt2diag(:,:,k) = 1.0*ISOTROPY(:,:,k)*0.5*(qt2prod_edge_nomf(:,:,kd)+qt2prod_edge_nomf(:,:,ku)) end if - whl(:,:,k) = onemmf*0.5*( whl_edge(:,:,kd) + whl_edge(:,:,ku) ) !+ MFWHL(:,:,k) - whl_can(:,:,k) = onemmf*0.5*( whl_edge(:,:,kd) + whl_edge(:,:,ku) ) !+ mfwhl(:,:,kd) + mfwhl(:,:,ku)) + hlqt(:,:,k) = onemmf*0.5*( hlqt_edge(:,:,kd) + hlqt_edge(:,:,ku) ) + MFHLQT(:,:,k) + hlqtdiag(:,:,k) = 0.5*( hlqt_edge(:,:,kd) + hlqt_edge(:,:,ku) ) - ! Restrict QT variance, 3-25% of total water. - qt2(:,:,k) = max(min(qt2(:,:,k),(0.25*QT(:,:,k))**2),(0.03*QT(:,:,k))**2) - qt2diag(:,:,k) = max(min(qt2diag(:,:,k),(0.25*QT(:,:,k))**2),(0.03*QT(:,:,k))**2) + whl(:,:,k) = onemmf*0.5*( whl_edge(:,:,kd) + whl_edge(:,:,ku)) + 0.5*( mfwhl(:,:,kd) + mfwhl(:,:,ku) ) + whl_can(:,:,k) = whl(:,:,k) + + ! Restrict QT variance, 2-25% of total water. + qt2(:,:,k) = max(min(qt2(:,:,k),(0.25*QT(:,:,k))**2),(0.02*QT(:,:,k))**2) + qt2diag(:,:,k) = max(min(qt2diag(:,:,k),(0.25*QT(:,:,k))**2),(0.02*QT(:,:,k))**2) hl2(:,:,k) = max(min(hl2(:,:,k),HL2MAX),HL2MIN) hl2diag(:,:,k) = max(min(hl2diag(:,:,k),HL2MAX),HL2MIN) @@ -1232,18 +984,38 @@ subroutine update_moments( IM, JM, LM, & ! in end do + ! Update PDF_A and third moments + if (DOPROGQT2 /= 0) then + if (SKEW_TDIS.gt.0.) then + pdf_a = (pdf_a+mffrc*DT/SKEW_TGEN)/(1.+DT/SKEW_TDIS) + else + pdf_a = pdf_a/(1.-DT/SKEW_TDIS) + end if + where (mffrc.gt.pdf_a) + pdf_a = mffrc + end where + qt3 = ( qt3 + max(MFQT3,0.)*DT/SKEW_TGEN ) / ( 1. + DT/SKEW_TDIS ) + else + pdf_a = mffrc + qt3 = max(MFQT3,0.) + end if + pdf_a = min(0.5,max(0.,pdf_a)) + if (DOCANUTO==0) then - qt3 = ( qt3 + max(MFQT3,0.) ) / ( 1. + DT/QT3_TSCALE ) + qt3 = ( qt3 + max(MFQT3,0.)*DT/SKEW_TGEN ) / ( 1. + DT/SKEW_TDIS ) hl3 = MFHL3 w3 = MFW3 else -! pre-define adzl, - do k=2,LM + +!============ Canuto 2001 estimate of third moments ============== +! This code was retained for diagnostic, comparative purpose only +!================================================================= + do k=1,LM km1 = k - 1 do j=1,JM do i=1,IM - adzl(i,j,km1) = (ZLE(i,j,k) - ZLE(i,j,km1)) ! level thickness + adzl(i,j,k) = (ZLE(i,j,km1) - ZLE(i,j,k)) ! level thickness enddo end do end do @@ -1271,62 +1043,59 @@ subroutine update_moments( IM, JM, LM, & ! in thedz2 = adzl(i,j,k)+adzl(i,j,kb) endif -! brunt = (bet(i,j,k)/thedz)*(thv(i,j,kc)-thv(i,j,kb)) - -! if (abs(thedz).le.1e-10) thedz = sign(1e-10,thedz) -! if (abs(thedz).eq.1e-10) print *,'thedz' -! if (abs(thedz2).le.1e-10) thedz2 = sign(1e-10,thedz2) -! if (abs(thedz2).eq.1e-10) print *,'thedz2' thedz = 1. / thedz thedz2 = 1. / thedz2 - iso = 0.5*(isotropy(i,j,k)+isotropy(i,j,kb)) + iso = isotropy(i,j,k) !0.5*(isotropy(i,j,k)+isotropy(i,j,kb)) isosqr = iso*iso ! Two-level average of "return-to-isotropy" time scale squared buoy_sgs2 = isosqr*0.5*(brunt(i,j,k)+brunt(i,j,kb)) - bet2 = 0.5*(bet(i,j,k)+bet(i,j,kb)) !Two-level average of BV frequency squared + bet2 = ggr/hl(i,j,k) !0.5*(bet(i,j,k)+bet(i,j,kb)) !Two-level average of BV frequency squared + ! Compute functions f0-f5, see Eq, 8 in C01 (B.8 in Pete's dissertation) + avew = w2(i,j,k) !0.5*(0.667*TKE(i,j,k)+0.667*TKE(i,j,kb)) +! if (abs(avew).ge.1e10) avew = sign(1e10,avew) - avew = 0.5*(0.667*TKE(i,j,k)+0.667*TKE(i,j,kb)) - if (abs(avew).ge.1e10) avew = sign(1e10,avew) -! if (abs(avew).eq.1e10) print *,'avew' - cond = 1.2*sqrt(max(1.0e-16,2.*avew*avew*avew)) + cond = 1.2*sqrt(max(1.0e-20,2.*avew*avew*avew)) wrk1b = bet2*iso wrk2b = thedz2*wrk1b*wrk1b*iso - wrk3b = hl2diag(i,j,kc) - hl2diag(i,j,kb) +! wrk3b = hl2diag(i,j,kc) - hl2diag(i,j,kb) + wrk3b = hl2diag(i,j,kb) - hl2diag(i,j,kc) f0 = wrk2b * wrk1b * whl_can(i,j,k) * wrk3b - wrk = whl_can(i,j,kc) - whl_can(i,j,kb) +! wrk = whl_can(i,j,kc) - whl_can(i,j,kb) + wrk = whl_can(i,j,kb) - whl_can(i,j,kc) - f1 = wrk2b * (wrk*whl_can(i,j,k) + 0.5*avew*wrk3b) + f1 = wrk2b * (wrk*whl_can(i,j,k) + 0.5*w2(i,j,k)*wrk3b) wrk1b = bet2*isosqr - f2 = thedz*wrk1b*whl_can(i,j,k)*0.667*(TKE(i,j,k)-TKE(i,j,kb)) & - + (thedz2+thedz2)*bet(i,j,k)*isosqr*avew*wrk + f2 = thedz*wrk1b*whl_can(i,j,k)*0.667*(TKE(i,j,kb)-TKE(i,j,k)) & + + (thedz2+thedz2)*bet2*isosqr*w2(i,j,k)*wrk - f3 = thedz2*wrk1b*wrk*avew + thedz*bet2*isosqr*(whl_can(i,j,k)*(tke(i,j,k)-tke(i,j,kb))) + f3 = thedz2*wrk1b*wrk*w2(i,j,k) + thedz*bet2*isosqr*(whl_can(i,j,k)*(tke(i,j,kb)-tke(i,j,k))) - wrk1b = thedz*iso*avew - f4 = wrk1b*(0.667*TKE(i,j,k)-0.667*TKE(i,j,kb) + tke(i,j,k)-tke(i,j,kb)) + wrk1b = thedz*iso*w2(i,j,k) +! f4 = wrk1b*(0.667*TKE(i,j,kb)-0.667*TKE(i,j,k) + tke(i,j,kb)-tke(i,j,k)) + f4 = wrk1b*(w2(i,j,kb)-w2(i,j,k) + tke(i,j,kb)-tke(i,j,k)) - f5 = wrk1b*0.667*(TKE(i,j,k)-TKE(i,j,kb)) + f5 = wrk1b*0.667*(TKE(i,j,kb)-TKE(i,j,k)) ! Compute the "omega" terms, see Eq. 6 in C01 (B.6 in Pete's dissertation) dum = 1.-a5*buoy_sgs2 - if (abs(dum).le.1e-16) dum = sign(1e-16,dum) -! if (abs(dum).eq.1e-16) print *,'1.-a5*buoy_sgs2' + if (abs(dum).le.1e-20) dum = sign(1e-20,dum) + omega0 = a4 / dum omega1 = omega0 / (c+c) omega2 = omega1*f3+(5./4.)*omega0*f4 ! Compute the X0, Y0, X1, Y1 terms, see Eq. 5 a-b in C01 (B.5 in Pete's dissertation) dum = 1.-(a1+a3)*buoy_sgs2 - if (abs(dum).le.1e-16) dum = sign(1e-16,dum) -! if (abs(dum).eq.1e-16) print *,'1.-(a1+a3)*buoy_sgs2' + if (abs(dum).le.1e-20) dum = sign(1e-20,dum) + wrk1b = 1.0 / dum dum = 1.-a3*buoy_sgs2 - if (abs(dum).le.1e-16) dum = sign(1e-16,dum) -! if (abs(dum).eq.1e-16) print *,'1.-a3*buoy_sgs2' + if (abs(dum).le.1e-20) dum = sign(1e-20,dum) + wrk2b = 1.0 / dum X0 = wrk1b * (a2*buoy_sgs2*(1.-a3*buoy_sgs2)) Y0 = wrk2b * (2.*a2*buoy_sgs2*X0) @@ -1342,9 +1111,10 @@ subroutine update_moments( IM, JM, LM, & ! in ! than the estimate - limit w3. dum = c-1.2*X0+AA0 - if (abs(dum).le.1e-16) dum = sign(1e-16,dum) -! if (abs(dum).eq.1e-16) print *,'c-1.2*X0+AA0=',dum - w3can(i,j,k) = max(-cond, min(cond, (AA1-1.2*X1-1.5*f5)/dum)) + if (abs(dum).le.1e-20) dum = sign(1e-20,dum) + +! w3can(i,j,k) = max(-cond, min(cond, (AA1-1.2*X1-1.5*f5)/dum)) + w3can(i,j,k) = (AA1-1.2*X1-1.5*f5)/dum ! Implemetation of the C01 approach in this subroutine is nearly complete ! (the missing part are Eqs. 5c and 5e which are very simple) ! therefore it's easy to diagnose other third order moments obtained in C01 using this code. @@ -1357,11 +1127,11 @@ subroutine update_moments( IM, JM, LM, & ! in w3can(i,j,LM) = w3can(i,j,LM-1) enddo enddo - w3 = w3can +! w3 = w3can !! skew_w = w3 / w2**1.5 - qt3 = 1.2*w3*(qt2/w2)**1.5 - hl3 = w3 * (hl2 / w2)**1.5 +! qt3 = 1.2*w3*(qt2/w2)**1.5 +! hl3 = w3 * (hl2 / w2)**1.5 end if ! DOCANUTO conditional diff --git a/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/GEOSdatmodyn_GridComp/GEOS_DatmoDynGridComp.F90 b/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/GEOSdatmodyn_GridComp/GEOS_DatmoDynGridComp.F90 index 6df0afe2f..0c71b5e69 100644 --- a/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/GEOSdatmodyn_GridComp/GEOS_DatmoDynGridComp.F90 +++ b/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/GEOSdatmodyn_GridComp/GEOS_DatmoDynGridComp.F90 @@ -1175,7 +1175,7 @@ subroutine RUN ( GC, IMPORT, EXPORT, CLOCK, RC ) type (ESMF_TimeInterval) :: timeStep real :: DT,Fac0,Fac1,DTXX,RELAX_TO_OBS - real :: OROGSGH + real :: OROGSGH,SCMAREA real, dimension(:,:), allocatable :: F0 real :: SCM_UG, SCM_VG @@ -1387,6 +1387,11 @@ subroutine RUN ( GC, IMPORT, EXPORT, CLOCK, RC ) call ESMF_ConfigGetAttribute ( CF, OROGSGH, Label="OROG_STDEV:", & DEFAULT=100., __RC__) + call ESMF_ConfigGetAttribute( cf, SCMAREA, label ='SCM_AREA:', & + DEFAULT=1e10, rc = status ) + + + if ( CFMIP .and. CFMIP2) then print *, " Error - SCM_CFMIP and SCM_CFMIP2 cannot be set at the same time " ! This should never happen RETURN_(ESMF_FAILURE) @@ -1629,11 +1634,12 @@ subroutine RUN ( GC, IMPORT, EXPORT, CLOCK, RC ) ! whenever datmodyn starts using gocart, this will need to be a real value -- ! see fvdycore for example if(associated(DUMMYAREA)) then - DUMMYAREA=1.0 + DUMMYAREA = SCMAREA + print *,'SCM AREA = ',DUMMYAREA end if if(associated(DUMMYDXC)) then - DUMMYDXC=1.0 + DUMMYDXC=sqrt(SCMAREA) end if if(associated(DUMMYW)) then @@ -1645,7 +1651,7 @@ subroutine RUN ( GC, IMPORT, EXPORT, CLOCK, RC ) end if if(associated(DUMMYDYC)) then - DUMMYDYC=1.0 + DUMMYDYC=sqrt(SCMAREA) end if ! added to satisfy desires of da @@ -1837,6 +1843,14 @@ subroutine RUN ( GC, IMPORT, EXPORT, CLOCK, RC ) if ( SCM_CORIOLIS == 0 ) then UTDYN(:,:,l) = 0. VTDYN(:,:,l) = 0. + else if (SCM_CORIOLIS == -1 ) then + if (L.gt.110.) then + UTDYN(:,:,l) = F0*( V(:,:,l) - V(:,:,110) ) + VTDYN(:,:,l) = -F0*( U(:,:,l) - U(:,:,110) ) + else + UTDYN(:,:,l) = 0. + VTDYN(:,:,l) = 0. + end if else UTDYN(:,:,l) = F0*( V(:,:,l) - SCM_VG ) VTDYN(:,:,l) = -F0*( U(:,:,l) - SCM_UG ) @@ -2025,7 +2039,7 @@ subroutine RUN ( GC, IMPORT, EXPORT, CLOCK, RC ) elseif (CFCSE .eq. 11) then zrel=2500. zrelp=3000. - qfloor=0. !3.55e-3 ! not used in Blossey LES, but recommended for future + qfloor=3.55e-3 ! not used in Blossey LES, but recommended for future elseif (CFCSE .eq. 6) then zrel=4000. zrelp=4800. diff --git a/GEOSmkiau_GridComp/CMakeLists.txt b/GEOSmkiau_GridComp/CMakeLists.txt index 283c5981a..13a6b4cc4 100644 --- a/GEOSmkiau_GridComp/CMakeLists.txt +++ b/GEOSmkiau_GridComp/CMakeLists.txt @@ -1,99 +1,31 @@ esma_set_this() -option(BUILD_PYMKIAU_INTERFACE "Build pyMKIAU interface" OFF) - -set (srcs +set(srcs IAU_GridCompMod.F90 GEOS_mkiauGridComp.F90 DFI_GridComp.F90 mkiau_specmod.F90 - DynVec_GridComp.F90 - ) - -if (BUILD_PYMKIAU_INTERFACE) - list (APPEND srcs - pyMKIAU/interface/interface.f90 - pyMKIAU/interface/interface.c) - - message(STATUS "Building pyMKIAU interface") - - add_definitions(-DPYMKIAU_INTEGRATION) - - # The Python library creation requires mpiexec/mpirun to run on a - # compute node. Probably a weird SLURM thing? - find_package(Python3 COMPONENTS Interpreter REQUIRED) - - # Set up some variables in case names change - set(PYMKIAU_INTERFACE_LIBRARY ${CMAKE_CURRENT_BINARY_DIR}/libpyMKIAU_interface_py.so) - set(PYMKIAU_INTERFACE_HEADER_FILE ${CMAKE_CURRENT_BINARY_DIR}/pyMKIAU_interface_py.h) - set(PYMKIAU_INTERFACE_FLAG_HEADER_FILE ${CMAKE_CURRENT_SOURCE_DIR}/pyMKIAU/interface/interface.h) - set(PYMKIAU_INTERFACE_SRCS ${CMAKE_CURRENT_SOURCE_DIR}/pyMKIAU/interface/interface.py) - - # This command creates the shared object library from Python - add_custom_command( - OUTPUT ${PYMKIAU_INTERFACE_LIBRARY} - # Note below is essentially: - # mpirun -np 1 python file - # but we use the CMake options as much as we can for flexibility - COMMAND ${CMAKE_COMMAND} -E copy_if_different ${PYMKIAU_INTERFACE_FLAG_HEADER_FILE} ${CMAKE_CURRENT_BINARY_DIR} - COMMAND ${MPIEXEC_EXECUTABLE} ${MPIEXEC_NUMPROC_FLAG} 1 ${Python3_EXECUTABLE} ${PYMKIAU_INTERFACE_SRCS} - BYPRODUCTS ${PYMKIAU_INTERFACE_HEADER_FILE} - WORKING_DIRECTORY ${CMAKE_CURRENT_BINARY_DIR} - MAIN_DEPENDENCY ${PYMKIAU_INTERFACE_SRCS} - COMMENT "Building pyMKIAU interface library with Python" - VERBATIM - ) - - # This creates a target we can use for dependencies and post build - add_custom_target(generate_pyMKIAU_interface_library DEPENDS ${PYMKIAU_INTERFACE_LIBRARY}) - - # Because of the weird hacking of INTERFACE libraries below, we cannot - # use the "usual" CMake calls to install() the .so. I think it's because - # INTERFACE libraries don't actually produce any artifacts as far as - # CMake is concerned. So we add a POST_BUILD custom command to "install" - # the library into install/lib - add_custom_command(TARGET generate_pyMKIAU_interface_library - POST_BUILD - # We first need to make a lib dir if it doesn't exist. If not, then - # the next command can copy the script into a *file* called lib because - # of a race condition (if install/lib/ isn't mkdir'd first) - COMMAND ${CMAKE_COMMAND} -E make_directory ${CMAKE_INSTALL_PREFIX}/lib - # Now we copy the file (if different...though not sure if this is useful) - COMMAND ${CMAKE_COMMAND} -E copy_if_different "${PYMKIAU_INTERFACE_LIBRARY}" ${CMAKE_INSTALL_PREFIX}/lib - ) - - # We use INTERFACE libraries to create a sort of "fake" target library we can use - # to make libFVdycoreCubed_GridComp.a depend on. It seems to work! - add_library(pyMKIAU_interface_py INTERFACE) - - # The target_include_directories bits were essentially stolen from the esma_add_library - # code... - target_include_directories(pyMKIAU_interface_py INTERFACE - $ - $ # stubs - # modules and copied *.h, *.inc - $ - $ - ) - target_link_libraries(pyMKIAU_interface_py INTERFACE ${PYMKIAU_INTERFACE_LIBRARY}) - - # This makes sure the library is built first - add_dependencies(pyMKIAU_interface_py generate_pyMKIAU_interface_library) - - # This bit is to resolve an issue and Google told me to do this. I'm not - # sure that the LIBRARY DESTINATION bit actually does anything since - # this is using INTERFACE - install(TARGETS pyMKIAU_interface_py - EXPORT ${PROJECT_NAME}-targets - LIBRARY DESTINATION ${CMAKE_INSTALL_PREFIX}/lib - ) - -endif () - -if (BUILD_PYMKIAU_INTERFACE) - set(dependencies pyMKIAU_interface_py MAPL_cfio_r4 NCEP_sp_r4i4 GEOS_Shared GMAO_mpeu MAPL FVdycoreCubed_GridComp ESMF::ESMF NetCDF::NetCDF_Fortran) -else () - set(dependencies MAPL_cfio_r4 NCEP_sp_r4i4 GEOS_Shared GMAO_mpeu MAPL FVdycoreCubed_GridComp ESMF::ESMF NetCDF::NetCDF_Fortran) + DynVec_GridComp.F90) + +if (BUILD_WITH_PYMLINC) + add_compile_definitions(-DHAS_PYMLINC) + set(pymlinc_srcs + pyMLINC/interface/interface.f90 + pyMLINC/interface/interface.c) + list(APPEND srcs ${pymlinc_srcs}) + include(pyMLINC.cmake) + set(dependencies pyMLINC_interface_py) endif () -esma_add_library (${this} SRCS ${srcs} DEPENDENCIES ${dependencies}) +set(dependencies + ${dependencies} + MAPL_cfio_r4 + NCEP_sp_r4i4 + GEOS_Shared + GMAO_mpeu + MAPL + FVdycoreCubed_GridComp + ESMF::ESMF + NetCDF::NetCDF_Fortran) + +esma_add_library(${this} SRCS ${srcs} DEPENDENCIES ${dependencies}) diff --git a/GEOSmkiau_GridComp/GEOS_mkiauGridComp.F90 b/GEOSmkiau_GridComp/GEOS_mkiauGridComp.F90 index 92daadce6..e47296204 100644 --- a/GEOSmkiau_GridComp/GEOS_mkiauGridComp.F90 +++ b/GEOSmkiau_GridComp/GEOS_mkiauGridComp.F90 @@ -20,8 +20,8 @@ module GEOS_mkiauGridCompMod ! use GEOS_RemapMod, only: myremap => remap use MAPL_CubedSphereGridFactoryMod use m_set_eta, only: set_eta -#ifdef PYMKIAU_INTEGRATION - use pyMKIAU_interface_mod +#ifdef HAS_PYMLINC + use pyMLINC_interface_mod, only: pyMLINC_interface_init_f, pyMLINC_interface_run_f use ieee_exceptions, only: ieee_get_halting_mode, ieee_set_halting_mode, ieee_all #endif implicit none @@ -96,13 +96,10 @@ subroutine SetServices ( GC, RC ) type (ESMF_Config) :: CF logical :: BLEND_AT_PBL -#ifdef PYMKIAU_INTEGRATION +#ifdef HAS_PYMLINC ! IEEE trapping see below logical :: halting_mode(5) - ! BOGUS DATA TO SHOW USAGE - type(a_pod_struct_type) :: options - real, allocatable, dimension(:,:,:) :: in_buffer - real, allocatable, dimension(:,:,:) :: out_buffer + integer, parameter :: magic_number = 123456789 #endif !============================================================================= @@ -240,6 +237,51 @@ subroutine SetServices ( GC, RC ) RC=STATUS ) VERIFY_(STATUS) + call MAPL_AddImportSpec(GC, & + SHORT_NAME = 'QLTOT', & + LONG_NAME = 'water_vapor_specific_humdity', & + UNITS = 'kg/kg', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddImportSpec(GC, & + SHORT_NAME = 'QITOT', & + LONG_NAME = 'water_vapor_specific_humdity', & + UNITS = 'kg/kg', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddImportSpec(GC, & + SHORT_NAME = 'QRTOT', & + LONG_NAME = 'water_vapor_specific_humdity', & + UNITS = 'kg/kg', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddImportSpec(GC, & + SHORT_NAME = 'QSTOT', & + LONG_NAME = 'water_vapor_specific_humdity', & + UNITS = 'kg/kg', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddImportSpec(GC, & + SHORT_NAME = 'QGTOT', & + LONG_NAME = 'water_vapor_specific_humdity', & + UNITS = 'kg/kg', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RC=STATUS ) + VERIFY_(STATUS) + if( BLEND_AT_PBL ) then call MAPL_AddImportSpec(GC, & SHORT_NAME = 'PPBL', & @@ -280,6 +322,14 @@ subroutine SetServices ( GC, RC ) VLOCATION = MAPL_VLocationCenter, RC=STATUS ) VERIFY_(STATUS) + call MAPL_AddExportSpec ( gc, & + SHORT_NAME = 'DTDT_ML', & + LONG_NAME = 'ml_computed_temperature_analysis_increment', & + UNITS = 'K', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + _RC) + call MAPL_AddExportSpec ( gc, & SHORT_NAME = 'DPEDT', & LONG_NAME = 'edge_pressure_analysis_increment', & @@ -471,23 +521,16 @@ subroutine SetServices ( GC, RC ) call MAPL_GenericSetServices ( gc, RC=STATUS) VERIFY_(STATUS) -#ifdef PYMKIAU_INTEGRATION - ! Spin the interface - we have to deactivate the ieee error +#ifdef HAS_PYMLINC + ! Spin the interface - we have to deactivate the ieee fpe error ! to be able to load numpy, scipy and other numpy packages ! that generate NaN as an init mechanism for numerical solving call ieee_get_halting_mode(ieee_all, halting_mode) call ieee_set_halting_mode(ieee_all, .false.) - call pyMKIAU_interface_f_setservice() + if (MAPL_AM_I_ROOT()) then + call pyMLINC_interface_init_f(magic_number) + end if call ieee_set_halting_mode(ieee_all, halting_mode) - - ! BOGUS CODE TO SHOW USAGE - options%npx = 10 - options%npy = 11 - options%npz = 12 - allocate (in_buffer(10,11,12), source = 42.42 ) - allocate (out_buffer(10,11,12), source = 0.0 ) - call pyMKIAU_interface_f_run(options, in_buffer, out_buffer) - write(*,*) "[pyMKIAU] From fortran OUT[5,5,5] is ", out_buffer(5,5,5) #endif RETURN_(ESMF_SUCCESS) @@ -707,6 +750,7 @@ subroutine RUN ( GC, IMPORT, EXPORT, CLOCK, RC ) type (ESMF_VM) :: VM integer :: vm_comm integer :: IHAVEAINC + integer :: IHAVEMLINC type (T_MKIAU_STATE), pointer :: mkiau_internal_state type (MKIAU_wrap) :: wrap @@ -835,6 +879,8 @@ subroutine RUN ( GC, IMPORT, EXPORT, CLOCK, RC ) call MAPL_GetResource(MAPL, IHAVEAINC, Label='REPLAY_TO_ANAINC:', default=0, RC=STATUS) VERIFY_(STATUS) + call MAPL_GetResource(MAPL, IHAVEMLINC, Label='REPLAY_TO_MLINC:', default=0, RC=STATUS) + VERIFY_(STATUS) call MAPL_GetResource(MAPL, REPLAY_PHIS, Label="REPLAY_PHIS:", default='YES', RC=STATUS) VERIFY_(STATUS) call MAPL_GetResource(MAPL, REPLAY_TS, Label="REPLAY_TS:", default=trim(REPLAY_TS), RC=STATUS) @@ -1193,6 +1239,12 @@ subroutine RUN ( GC, IMPORT, EXPORT, CLOCK, RC ) call handleANA_ endif +#ifdef HAS_PYMLINC + if ( IHAVEMLINC/=0 ) then + call compute_ml_inc(MAPL, GRIDbkg, import, export, _RC) ! GRIDbkg is current gridcomp's grid + end if +#endif + call MAPL_TimerOff(MAPL,"-RUN") call MAPL_TimerOff(MAPL,"TOTAL") RETURN_(ESMF_SUCCESS) @@ -2657,87 +2709,40 @@ subroutine blend ( plea,ua,va,ta,qa,oa, & ! Locals ! ------ - real pkea(im,jm,lm+1) - real pkeb(im,jm,lm+1) - real phia(im,jm,lm+1) - real phib(im,jm,lm+1) - - real thva(im,jm,lm) - real thvb(im,jm,lm) - real pka(im,jm,lm) - real pkb(im,jm,lm) - real pabove_BL,pbelow_BL real bl_press - real alf,eps,p + real alf,p integer i,j,L - eps = MAPL_RVAP/MAPL_RGAS-1.0 - pkea = plea**MAPL_KAPPA - pkeb = pleb**MAPL_KAPPA - - do L=1,lm - pka(:,:,L) = ( pkea(:,:,L+1)-pkea(:,:,L) ) / ( MAPL_KAPPA*log(plea(:,:,L+1)/plea(:,:,L)) ) - pkb(:,:,L) = ( pkeb(:,:,L+1)-pkeb(:,:,L) ) / ( MAPL_KAPPA*log(pleb(:,:,L+1)/pleb(:,:,L)) ) - thva(:,:,L) = ta(:,:,L)*(1.0+eps*qa(:,:,L)) / pka(:,:,L) - thvb(:,:,L) = tb(:,:,L)*(1.0+eps*qb(:,:,L)) / pkb(:,:,L) - enddo + if ( pabove /= pbelow ) then - phia(:,:,lm+1) = 0.0 - phib(:,:,lm+1) = 0.0 - do L=lm,1,-1 - phia(:,:,L) = phia(:,:,L+1) + MAPL_CP*thva(:,:,L)*( pkea(:,:,L+1)-pkea(:,:,L) ) - phib(:,:,L) = phib(:,:,L+1) + MAPL_CP*thvb(:,:,L)*( pkeb(:,:,L+1)-pkeb(:,:,L) ) - enddo + do j=1,jm + do i=1,im + do L=1,lm + p = 0.5*( plea(i,j,L)+plea(i,j,L+1) ) + if( p.le.pabove ) then + alf = 0.0 ! use the analysis value + else if( p.gt.pabove .and. p.le.pbelow ) then + alf = ((LOG(p) -LOG(pabove))/ & + (LOG(pbelow)-LOG(pabove)))**3 + else + alf = 1.0 ! use the background value + endif - if ( pabove /= pbelow ) then + plea(i,j,L) = pleb(i,j,L) + alf*( plea(i,j,L)- pleb(i,j,L) ) + ua(i,j,L) = ub(i,j,L) + alf*( ua(i,j,L)- ub(i,j,L) ) + va(i,j,L) = vb(i,j,L) + alf*( va(i,j,L)- vb(i,j,L) ) + ta(i,j,L) = tb(i,j,L) + alf*( ta(i,j,L)- tb(i,j,L) ) + qa(i,j,L) = qb(i,j,L) + alf*( qa(i,j,L)- qb(i,j,L) ) + oa(i,j,L) = ob(i,j,L) + alf*( oa(i,j,L)- ob(i,j,L) ) -! Blend mid-level u,v,q and o3 -! ---------------------------- - do L=1,lm - do j=1,jm - do i=1,im - p = 0.5*( plea(i,j,L)+plea(i,j,L+1) ) - if( p.le.pabove ) then - alf = 0.0 - else if( p.gt.pabove .and. p.le.pbelow ) then - alf = (p-pabove)/(pbelow-pabove) - else - alf = 1.0 - endif - ua(i,j,L) = ub(i,j,L) + alf*( ua(i,j,L)- ub(i,j,L) ) - va(i,j,L) = vb(i,j,L) + alf*( va(i,j,L)- vb(i,j,L) ) - oa(i,j,L) = ob(i,j,L) + alf*( oa(i,j,L)- ob(i,j,L) ) - qa(i,j,L) = qb(i,j,L) + alf*( qa(i,j,L)- qb(i,j,L) ) - enddo - enddo - enddo + enddo + plea(i,j,LM+1) = pleb(i,j,LM+1) -! Blend edge-level phi -! -------------------- - do L=1,lm+1 - do j=1,jm - do i=1,im - p = plea(i,j,L) - if( p.le.pabove ) then - alf = 0.0 - else if( p.gt.pabove .and. p.le.pbelow ) then - alf = (p-pabove)/(pbelow-pabove) - else - alf = 1.0 - endif - phia(i,j,L) = phib(i,j,L) + alf*( phia(i,j,L)-phib(i,j,L) ) - enddo - enddo - enddo + enddo + enddo -! Compute T based on blended phi -! ------------------------------ - do L=1,lm - ta(:,:,L) = ( phia(:,:,L)-phia(:,:,L+1) )/( pkea(:,:,L+1)-pkea(:,:,L) ) & - / (MAPL_CP*(1.0+eps*qa(:,:,L))) * pka(:,:,L) - enddo endif ! Blend from surface to blnpp @@ -3425,6 +3430,179 @@ subroutine myremap ( ple_in,ple_out, & return end subroutine myremap +#ifdef HAS_PYMLINC + subroutine compute_ml_inc(mapl, grid_bkg, import_state, export_state, rc) + use MAPL_LatLonGridFactoryMod + type (MAPL_MetaComp), pointer, intent(in) :: mapl + type(ESMF_Grid), intent(in) :: grid_bkg + type(ESMF_State), intent(inout) :: import_state + type(ESMF_State), intent(inout) :: export_state + integer, optional, intent(out) :: rc + + type(ESMF_Grid) :: grid_1deg + class(AbstractRegridder), pointer :: to_1deg => null(), to_native => null() + real, pointer :: ptr3d(:, :, :), ptr2d(:, :) + real, allocatable, dimension(:,:,:) :: u_1deg, v_1deg, t_1deg + real, allocatable, dimension(:,:,:) :: u_global, v_global, t_global + real, allocatable, dimension(:,:,:) :: qv_1deg, ql_1deg, qi_1deg, qr_1deg, qs_1deg, qg_1deg + real, allocatable, dimension(:,:,:) :: qv_global, ql_global, qi_global, qr_global, qs_global, qg_global + real, allocatable, dimension(:,:) :: ps_1deg + real, allocatable, dimension(:,:) :: ps_global + real, allocatable, dimension(:,:,:) :: dtdt_global + real, allocatable, dimension(:,:,:) :: dtdt_1deg + real, allocatable, dimension(:,:,:) :: dtdt + real, pointer, dimension(:, :, :) :: dtdt_ml + integer :: ushape(3), nx_, ny_, num_levels, im_world_tmp, jm_world_tmp + integer :: dims_(3), im_, jm_, im_1deg, jm_1deg, level, status + + integer, parameter :: magic_number = 123456789 + integer, parameter :: im_world_1deg = 360, jm_world_1deg = 181, lm=181 + + ! Grid stuff (native and 1deg lat/lon) + ! -native + call MAPL_GridGet(grid_bkg, localCellCountPerDim=dims_, _RC) + im_ = dims_(1); jm_ = dims_(2) + ! -1-degree-lat-lon + call MAPL_GetResource(MAPL, nx_, 'NX:', default=MAPL_UNDEFINED_INTEGER, _RC) + call MAPL_GetResource(MAPL, ny_, 'NY:', default=MAPL_UNDEFINED_INTEGER, _RC) + grid_1deg = grid_manager%make_grid( & + LatLonGridFactory( & + im_world=im_world_1deg, jm_world=jm_world_1deg, lm=lm, & + nx=nx_, ny=ny_, & + pole="PC", dateline= "DC", & + rc=status)) + call MAPL_GridGet(grid_1deg, localCellCountPerDim=dims_, _RC) + im_1deg = dims_(1); jm_1deg = dims_(2); num_levels = dims_(3) + + ! Regrid - native to 1deg lat/lon + to_1deg => new_regridder_manager%make_regridder(grid_bkg, grid_1deg, REGRID_METHOD_BILINEAR, _RC) + allocate(u_1deg(im_1deg, jm_1deg, lm), source=MAPL_UNDEFINED_REAL) + nullify(ptr3d) + call MAPL_GetPointer(import_state, ptr3d, "U", _RC) + call to_1deg%regrid(ptr3d, u_1deg, _RC) + allocate(v_1deg(im_1deg, jm_1deg, lm), source=MAPL_UNDEFINED_REAL) + nullify(ptr3d) + call MAPL_GetPointer(import_state, ptr3d, "V", _RC) + call to_1deg%regrid(ptr3d, v_1deg, _RC) + allocate(t_1deg(im_1deg, jm_1deg, lm), source=MAPL_UNDEFINED_REAL) + nullify(ptr3d) + call MAPL_GetPointer(import_state, ptr3d, "TV", _RC) + call to_1deg%regrid(ptr3d, t_1deg, _RC) + allocate(qv_1deg(im_1deg, jm_1deg, lm), source=MAPL_UNDEFINED_REAL) + nullify(ptr3d) + call MAPL_GetPointer(import_state, ptr3d, "QV", _RC) + call to_1deg%regrid(ptr3d, qv_1deg, _RC) + allocate(ql_1deg(im_1deg, jm_1deg, lm), source=MAPL_UNDEFINED_REAL) + nullify(ptr3d) + call MAPL_GetPointer(import_state, ptr3d, "QLTOT", _RC) + call to_1deg%regrid(ptr3d, ql_1deg, _RC) + allocate(qi_1deg(im_1deg, jm_1deg, lm), source=MAPL_UNDEFINED_REAL) + nullify(ptr3d) + call MAPL_GetPointer(import_state, ptr3d, "QITOT", _RC) + call to_1deg%regrid(ptr3d, qi_1deg, _RC) + allocate(qr_1deg(im_1deg, jm_1deg, lm), source=MAPL_UNDEFINED_REAL) + nullify(ptr3d) + call MAPL_GetPointer(import_state, ptr3d, "QRTOT", _RC) + call to_1deg%regrid(ptr3d, qr_1deg, _RC) + allocate(qs_1deg(im_1deg, jm_1deg, lm), source=MAPL_UNDEFINED_REAL) + nullify(ptr3d) + call MAPL_GetPointer(import_state, ptr3d, "QSTOT", _RC) + call to_1deg%regrid(ptr3d, qs_1deg, _RC) + allocate(qg_1deg(im_1deg, jm_1deg, lm), source=MAPL_UNDEFINED_REAL) + nullify(ptr3d) + call MAPL_GetPointer(import_state, ptr3d, "QGTOT", _RC) + call to_1deg%regrid(ptr3d, qg_1deg, _RC) + allocate(ps_1deg(im_1deg, jm_1deg), source=MAPL_UNDEFINED_REAL) + nullify(ptr2d) + call MAPL_GetPointer(import_state, ptr2d, "PS", _RC) + call to_1deg%regrid(ptr2d, ps_1deg, _RC) + + ! Gather inputs (u, v, t, q's, ps) on rank 0 + if (MAPL_AM_I_ROOT()) then + im_world_tmp = im_world_1deg + jm_world_tmp = jm_world_1deg + else + im_world_tmp = 0 + jm_world_tmp = 0 + end if + allocate(u_global(im_world_tmp, jm_world_tmp, lm), source=MAPL_UNDEFINED_REAL) + allocate(v_global(im_world_tmp, jm_world_tmp, lm), source=MAPL_UNDEFINED_REAL) + allocate(t_global(im_world_tmp, jm_world_tmp, lm), source=MAPL_UNDEFINED_REAL) + allocate(qv_global(im_world_tmp, jm_world_tmp, lm), source=MAPL_UNDEFINED_REAL) + allocate(ql_global(im_world_tmp, jm_world_tmp, lm), source=MAPL_UNDEFINED_REAL) + allocate(qi_global(im_world_tmp, jm_world_tmp, lm), source=MAPL_UNDEFINED_REAL) + allocate(qr_global(im_world_tmp, jm_world_tmp, lm), source=MAPL_UNDEFINED_REAL) + allocate(qs_global(im_world_tmp, jm_world_tmp, lm), source=MAPL_UNDEFINED_REAL) + allocate(qg_global(im_world_tmp, jm_world_tmp, lm), source=MAPL_UNDEFINED_REAL) + allocate(ps_global(im_world_tmp, jm_world_tmp), source=MAPL_UNDEFINED_REAL) + allocate(dtdt_global(im_world_tmp, jm_world_tmp, lm), source = MAPL_UNDEFINED_REAL) + do level = 1, num_levels + call ArrayGather(local_array=u_1deg(:, :, level), global_array=u_global(:, :, level), grid=grid_1deg, _RC) + call ArrayGather(local_array=v_1deg(:, :, level), global_array=v_global(:, :, level), grid=grid_1deg, _RC) + call ArrayGather(local_array=t_1deg(:, :, level), global_array=t_global(:, :, level), grid=grid_1deg, _RC) + call ArrayGather(local_array=qv_1deg(:, :, level), global_array=qv_global(:, :, level), grid=grid_1deg, _RC) + call ArrayGather(local_array=ql_1deg(:, :, level), global_array=ql_global(:, :, level), grid=grid_1deg, _RC) + call ArrayGather(local_array=qi_1deg(:, :, level), global_array=qi_global(:, :, level), grid=grid_1deg, _RC) + call ArrayGather(local_array=qr_1deg(:, :, level), global_array=qr_global(:, :, level), grid=grid_1deg, _RC) + call ArrayGather(local_array=qs_1deg(:, :, level), global_array=qs_global(:, :, level), grid=grid_1deg, _RC) + call ArrayGather(local_array=qg_1deg(:, :, level), global_array=qg_global(:, :, level), grid=grid_1deg, _RC) + end do + call ArrayGather(local_array=ps_1deg(:, :), global_array=ps_global(:, :), grid=grid_1deg, _RC) + deallocate(u_1deg, v_1deg, t_1deg) + deallocate(qv_1deg, ql_1deg, qi_1deg, qr_1deg, qs_1deg, qg_1deg) + deallocate(ps_1deg) + + ! Root calls the interface to pyMLINC + if (MAPL_AM_I_ROOT()) then + ushape = shape(u_global) + print *, "[pyMLINC] Fortran - u_global: ", ushape + print *, "[pyMLINC] Fortran - u_global: ", sum(u_global), minval(u_global), maxval(u_global) + print *, "[pyMLINC] Fortran - v_global: ", sum(v_global), minval(v_global), maxval(v_global) + print *, "[pyMLINC] Fortran - t_global: ", sum(t_global), minval(t_global), maxval(t_global) + print *, "[pyMLINC] Fortran - qv_global: ", sum(qv_global), minval(qv_global), maxval(qv_global) + print *, "[pyMLINC] Fortran - ql_global: ", sum(ql_global), minval(ql_global), maxval(ql_global) + print *, "[pyMLINC] Fortran - qi_global: ", sum(qi_global), minval(qi_global), maxval(qi_global) + print *, "[pyMLINC] Fortran - qr_global: ", sum(qr_global), minval(qr_global), maxval(qr_global) + print *, "[pyMLINC] Fortran - qs_global: ", sum(qs_global), minval(qs_global), maxval(qs_global) + print *, "[pyMLINC] Fortran - qg_global: ", sum(qg_global), minval(qg_global), maxval(qg_global) + print *, "[pyMLINC] Fortran - ps_global: ", sum(ps_global), minval(ps_global), maxval(ps_global) + print *, "[pyMLINC] Fortran - calling interface to Py code" + call pyMLINC_interface_run_f( & + ! input + ushape(1), ushape(2), ushape(3), & + u_global, v_global, t_global, & + qv_global, ql_global, qi_global, qr_global, qs_global, qg_global, & + ps_global, & + ! output + dtdt_global, & + ! LAST ARGUMENT - input + magic_number) + write(*,*) "[pyMLINC] Fortran - dtdt", sum(dtdt_global), minval(dtdt_global), maxval(dtdt_global) + end if + deallocate(u_global, v_global, t_global) + deallocate(qv_global, ql_global, qi_global, qr_global, qs_global, qg_global) + deallocate(ps_global) + + ! Scatter dtdt back to all ranks + allocate(dtdt_1deg(im_1deg, jm_1deg, lm), source=MAPL_UNDEFINED_REAL) + do level = 1, num_levels + call ArrayScatter(local_array=dtdt_1deg(:, :, level), global_array=dtdt_global(:, :, level), grid=grid_1deg, _RC) + end do + deallocate(dtdt_global) + + ! Regrid dtdt from 1deg lat/lon to native grid + to_native => new_regridder_manager%make_regridder(grid_1deg, grid_bkg, REGRID_METHOD_BILINEAR, _RC) + allocate(dtdt(im_, jm_, lm), source=MAPL_UNDEFINED_REAL) + call to_native%regrid(dtdt_1deg, dtdt, _RC) + + ! Add to export spec + call MAPL_GetPointer(export_state, dtdt_ml, "DTDT_ML", _RC) + if (associated(dtdt_ml)) dtdt_ml = dtdt + + _RETURN(_SUCCESS) + end subroutine compute_ml_inc +#endif + subroutine RedanduncyCheck(rnames) character(len=*), intent(inout) :: rnames(:) diff --git a/GEOSmkiau_GridComp/pyMKIAU/interface/interface.c b/GEOSmkiau_GridComp/pyMKIAU/interface/interface.c deleted file mode 100644 index 28ebad972..000000000 --- a/GEOSmkiau_GridComp/pyMKIAU/interface/interface.c +++ /dev/null @@ -1,31 +0,0 @@ -#include -#include -#include "interface.h" - -extern int pyMKIAU_interface_c_setservice() -{ - // Check magic number - int return_code = pyMKIAU_interface_py_setservices(); - - if (return_code < 0) - { - exit(return_code); - } -} - -extern int pyMKIAU_interface_c_run(a_pod_struct_t *options, const float *in_buffer, float *out_buffer) -{ - // Check magic number - if (options->mn_123456789 != 123456789) - { - printf("Magic number failed, pyMKIAU interface is broken on the C side\n"); - exit(-1); - } - - int return_code = pyMKIAU_interface_py_run(options, in_buffer, out_buffer); - - if (return_code < 0) - { - exit(return_code); - } -} diff --git a/GEOSmkiau_GridComp/pyMKIAU/interface/interface.f90 b/GEOSmkiau_GridComp/pyMKIAU/interface/interface.f90 deleted file mode 100644 index c94b4a06b..000000000 --- a/GEOSmkiau_GridComp/pyMKIAU/interface/interface.f90 +++ /dev/null @@ -1,43 +0,0 @@ -module pyMKIAU_interface_mod - - use iso_c_binding, only: c_int, c_float, c_double, c_bool, c_ptr - - implicit none - - private - public :: pyMKIAU_interface_f_setservice, pyMKIAU_interface_f_run - public :: a_pod_struct_type - - !----------------------------------------------------------------------- - ! See `interface.h` for explanation of the POD-strict struct - !----------------------------------------------------------------------- - type, bind(c) :: a_pod_struct_type - integer(kind=c_int) :: npx - integer(kind=c_int) :: npy - integer(kind=c_int) :: npz - ! Magic number - integer(kind=c_int) :: make_flags_C_interop = 123456789 - end type - - - interface - - subroutine pyMKIAU_interface_f_setservice() bind(c, name='pyMKIAU_interface_c_setservice') - end subroutine pyMKIAU_interface_f_setservice - - subroutine pyMKIAU_interface_f_run(options, in_buffer, out_buffer) bind(c, name='pyMKIAU_interface_c_run') - - import c_float, a_pod_struct_type - - implicit none - ! This is an interface to a C function, the intent ARE NOT enforced - ! by the compiler. Consider them developer hints - type(a_pod_struct_type), intent(in) :: options - real(kind=c_float), dimension(*), intent(in) :: in_buffer - real(kind=c_float), dimension(*), intent(out) :: out_buffer - - end subroutine pyMKIAU_interface_f_run - - end interface - -end module pyMKIAU_interface_mod diff --git a/GEOSmkiau_GridComp/pyMKIAU/interface/interface.h b/GEOSmkiau_GridComp/pyMKIAU/interface/interface.h deleted file mode 100644 index ce8dfb179..000000000 --- a/GEOSmkiau_GridComp/pyMKIAU/interface/interface.h +++ /dev/null @@ -1,40 +0,0 @@ -#pragma once - -/*** - * C Header for the interface to python. - * Define here any POD-strict structures and external functions - * that will get exported by cffi from python (see interface.py) - ***/ - -#include -#include - -// POD-strict structure to pack options and flags efficiently -// Struct CANNOT hold pointers. The iso_c_binding does not allow for foolproof -// pointer memory packing. -// We use the low-embedded trick of the magic number to attempt to catch -// any type mismatch betweeen Fortran and C. This is not a foolproof method -// but it bring a modicum of check at the cost of a single integer. -typedef struct -{ - int npx; - int npy; - int npz; - // Magic number needs to be last item - int mn_123456789; -} a_pod_struct_t; - -// For complex type that can be exported with different -// types (like the MPI communication object), you can rely on C `union` -typedef union -{ - int comm_int; - void *comm_ptr; -} MPI_Comm_t; - -// Python hook functions: defined as external so that the .so can link out ot them -// Though we define `in_buffer` as a `const float*` it is _not_ enforced -// by the interface. Treat as a developer hint only. - -extern int pyMKIAU_interface_py_run(a_pod_struct_t *options, const float *in_buffer, float *out_buffer); -extern int pyMKIAU_interface_py_setservices(); diff --git a/GEOSmkiau_GridComp/pyMKIAU/pyMKIAU/core.py b/GEOSmkiau_GridComp/pyMKIAU/pyMKIAU/core.py deleted file mode 100644 index c3f9684d4..000000000 --- a/GEOSmkiau_GridComp/pyMKIAU/pyMKIAU/core.py +++ /dev/null @@ -1,74 +0,0 @@ -from _cffi_backend import _CDataBase as CFFIObj # type: ignore -import dataclasses -from pyMKIAU.f_py_conversion import FortranPythonConversion -from pyMKIAU.cuda_profiler import TimedCUDAProfiler -import numpy as np -from typing import Dict, List - - -@dataclasses.dataclass -class FPYOptions: - npx: int = 0 - npy: int = 0 - npz: int = 0 - mn_123456789: int = 0 - - -def options_fortran_to_python( - f_options: CFFIObj, -) -> FPYOptions: - if f_options.mn_123456789 != 123456789: # type:ignore - raise RuntimeError( - "Magic number failed, pyMoist interface is broken on the python side" - ) - - py_flags = FPYOptions() - keys = list(filter(lambda k: not k.startswith("__"), dir(type(py_flags)))) - for k in keys: - if hasattr(f_options, k): - setattr(py_flags, k, getattr(f_options, k)) - return py_flags - - -F_PY_MEMORY_CONV = None - - -def pyMKIAU_init(): - print("[pyMKIAU] Init called") - - -def pyMKIAU_run( - f_options: CFFIObj, - f_in_buffer: CFFIObj, - f_out_buffer: CFFIObj, -): - print("[pyMKIAU] Run called") - options = options_fortran_to_python(f_options) - print(f"[pyMKIAU] Options: {options}") - - # Dev Note: this should be doen better in it's own class - # and the `np` should be driven by the user code requirements - # for GPU or CPU memory - global F_PY_MEMORY_CONV - if F_PY_MEMORY_CONV is None: - F_PY_MEMORY_CONV = FortranPythonConversion( - options.npx, - options.npy, - options.npz, - np, - ) - - # Move memory into a manipulable numpy array - in_buffer = F_PY_MEMORY_CONV.fortran_to_python(f_in_buffer) - out_buffer = F_PY_MEMORY_CONV.fortran_to_python(f_out_buffer) - - # Here goes math and dragons - timings: Dict[str, List[float]] = {} - with TimedCUDAProfiler("pyMKIAU bogus math", timings): - out_buffer[:, :, :] = in_buffer[:, :, :] * 2 - - print(f"[pyMKIAU] At 5,5,5 in python OUT is: {out_buffer[5,5,5]}") - print(f"[pyMKIAU] Timers: {timings}") - - # Go back to fortran - F_PY_MEMORY_CONV.python_to_fortran(out_buffer, f_out_buffer) diff --git a/GEOSmkiau_GridComp/pyMLINC.cmake b/GEOSmkiau_GridComp/pyMLINC.cmake new file mode 100644 index 000000000..78b2a56a4 --- /dev/null +++ b/GEOSmkiau_GridComp/pyMLINC.cmake @@ -0,0 +1,90 @@ +message(STATUS "Building pyMLINC interface") + +# The Python library creation requires mpiexec/mpirun to run on a +# compute node. Probably a weird SLURM thing? +find_package(Python3 COMPONENTS Interpreter REQUIRED) + +# Set up some variables in case names change +set(PYMLINC_INTERFACE_LIBRARY ${CMAKE_CURRENT_BINARY_DIR}/libpyMLINC_interface_py.so) +set(PYMLINC_INTERFACE_HEADER_FILE ${CMAKE_CURRENT_BINARY_DIR}/pyMLINC_interface_py.h) +set(PYMLINC_INTERFACE_FLAG_HEADER_FILE ${CMAKE_CURRENT_SOURCE_DIR}/pyMLINC/interface/interface.h) +set(PYMLINC_INTERFACE_SRCS ${CMAKE_CURRENT_SOURCE_DIR}/pyMLINC/interface/interface.py) + +# This command creates the shared object library from Python +add_custom_command( + OUTPUT ${PYMLINC_INTERFACE_LIBRARY} + # Note below is essentially: + # mpirun -np 1 python file + # but we use the CMake options as much as we can for flexibility + COMMAND ${CMAKE_COMMAND} -E copy_if_different ${PYMLINC_INTERFACE_FLAG_HEADER_FILE} ${CMAKE_CURRENT_BINARY_DIR} + COMMAND ${Python3_EXECUTABLE} ${PYMLINC_INTERFACE_SRCS} + BYPRODUCTS ${PYMLINC_INTERFACE_HEADER_FILE} + WORKING_DIRECTORY ${CMAKE_CURRENT_BINARY_DIR} + MAIN_DEPENDENCY ${PYMLINC_INTERFACE_SRCS} + COMMENT "Building pyMLINC interface library with Python" + VERBATIM + ) + +# This creates a target we can use for dependencies and post build +add_custom_target(generate_pyMLINC_interface_library DEPENDS ${PYMLINC_INTERFACE_LIBRARY}) + +# Because of the weird hacking of INTERFACE libraries below, we cannot +# use the "usual" CMake calls to install() the .so. I think it's because +# INTERFACE libraries don't actually produce any artifacts as far as +# CMake is concerned. So we add a POST_BUILD custom command to "install" +# the library into install/lib +add_custom_command(TARGET generate_pyMLINC_interface_library + POST_BUILD + # We first need to make a lib dir if it doesn't exist. If not, then + # the next command can copy the script into a *file* called lib because + # of a race condition (if install/lib/ isn't mkdir'd first) + COMMAND ${CMAKE_COMMAND} -E make_directory ${CMAKE_INSTALL_PREFIX}/lib + # Now we copy the file (if different...though not sure if this is useful) + COMMAND ${CMAKE_COMMAND} -E copy_if_different "${PYMLINC_INTERFACE_LIBRARY}" ${CMAKE_INSTALL_PREFIX}/lib + ) + +# We use INTERFACE libraries to create a sort of "fake" target library we can use +# to make libFVdycoreCubed_GridComp.a depend on. It seems to work! +add_library(pyMLINC_interface_py INTERFACE) + +# The target_include_directories bits were essentially stolen from the esma_add_library +# code... +target_include_directories(pyMLINC_interface_py INTERFACE + $ + $ # stubs + # modules and copied *.h, *.inc + $ + $ + ) +target_link_libraries(pyMLINC_interface_py INTERFACE ${PYMLINC_INTERFACE_LIBRARY}) + +# This makes sure the library is built first +add_dependencies(pyMLINC_interface_py generate_pyMLINC_interface_library) + +# This bit is to resolve an issue and Google told me to do this. I'm not +# sure that the LIBRARY DESTINATION bit actually does anything since +# this is using INTERFACE +install(TARGETS pyMLINC_interface_py + EXPORT ${PROJECT_NAME}-targets + LIBRARY DESTINATION ${CMAKE_INSTALL_PREFIX}/lib + ) + +# Driver for the Fortran interface +ecbuild_add_executable( + TARGET pymlinc-driver + SOURCES pyMLINC/driver/driver.F90 ${pymlinc_srcs} + LIBS ${PYMLINC_INTERFACE_LIBRARY}) + +install( + DIRECTORY pyMLINC/pyMLINC + DESTINATION lib/Python + USE_SOURCE_PERMISSIONS) +find_path(GEOS_STATE_BIAS_DIR processor.py HINTS ${CMAKE_CURRENT_SOURCE_DIR}/pyMLINC/*) +message(STATUS "GEOS STATE BIAS dir: ${GEOS_STATE_BIAS_DIR}") +install( + FILES ${GEOS_STATE_BIAS_DIR}/processor.py + DESTINATION lib/Python/geos_state_bias) +install( + DIRECTORY ${GEOS_STATE_BIAS_DIR}/models ${GEOS_STATE_BIAS_DIR}/utils + DESTINATION lib/Python/geos_state_bias + USE_SOURCE_PERMISSIONS) diff --git a/GEOSmkiau_GridComp/pyMKIAU/.gitignore b/GEOSmkiau_GridComp/pyMLINC/.gitignore similarity index 87% rename from GEOSmkiau_GridComp/pyMKIAU/.gitignore rename to GEOSmkiau_GridComp/pyMLINC/.gitignore index 9ae227288..e2a4d01f7 100644 --- a/GEOSmkiau_GridComp/pyMKIAU/.gitignore +++ b/GEOSmkiau_GridComp/pyMLINC/.gitignore @@ -10,3 +10,4 @@ test_data/ test_data/ sandbox/ *.mod +*geos_state_bias* diff --git a/GEOSmkiau_GridComp/pyMKIAU/README.md b/GEOSmkiau_GridComp/pyMLINC/README.md similarity index 68% rename from GEOSmkiau_GridComp/pyMKIAU/README.md rename to GEOSmkiau_GridComp/pyMLINC/README.md index 61f039520..35bf250b4 100644 --- a/GEOSmkiau_GridComp/pyMKIAU/README.md +++ b/GEOSmkiau_GridComp/pyMLINC/README.md @@ -1,18 +1,18 @@ # Fortran - Python bridge prototype -Nomenclatura: we call the brige "fpy" and "c", "f" and "py" denotes functions in their respective language. +Nomenclature: we call the brige "fpy" and "c", "f" and "py" denotes functions in their respective language. -Building: you have to pass `-DBUILD_PYMKIAU_INTERFACE=ON` to your `cmake` command to turn on the interface build and execution. +Building: you have to pass `-DBUILD_PYMLINC_INTERFACE=ON` to your `cmake` command to turn on the interface build and execution. ## Pipeline Here's a quick rundown of how a buffer travels through the interface and back. -- From Fortran in `GEOS_MKIAUGridComp:488` we call `pyMKIAU_interface_f_run` with the buffer passed as argument -- This pings the interface, located at `pyMKIAU/interface/interface.f90`. This interface uses the `iso_c_binding` to marshall the parameters downward (careful about the user type, look at the code) -- Fortran then call into C at `pyMKIAU/interface/interface.c`. Those functions now expect that a few `extern` hooks have been made available on the python side, they are define in `pyMKIAU/interface/interface.h` -- At runtime, the hooks are found and code carries to the python thanks to cffi. The .so that exposes the hooks is in `pyMKIAU/interface/interface.py`. Within this code, we: expose extern functions via `ffi.extern`, build a shared library to link for runtime and pass the code down to the `pyMKIAU` python package which lives at `pyMKIAU/pyMKIAU` -- In the package, the `serservices` or `run` function is called. +- From Fortran in `GEOS_mkiauGridComp` we call `pyMLINC_interface_f_run` with the buffer passed as argument +- This pings the interface, located at `pyMLINC/interface/interface.f90`. This interface uses the `iso_c_binding` to marshall the parameters downward (careful about the user type, look at the code) +- Fortran then call into C at `pyMLINC/interface/interface.c`. Those functions now expect that a few `extern` hooks have been made available on the python side, they are define in `pyMLINC/interface/interface.h` +- At runtime, the hooks are found and code carries to the python thanks to cffi. The .so that exposes the hooks is in `pyMLINC/interface/interface.py`. Within this code, we: expose extern functions via `ffi.extern`, build a shared library to link for runtime and pass the code down to the `pyMLINC` python package which lives at `pyMLINC/pyMLINC` +- In the package, the `run` function is called. ## Fortran <--> C: iso_c_binding @@ -35,6 +35,6 @@ The last trick is to make sure your package is callable by the `interface.py`. B The easy way to know is that you need to be able to get into your environment and run in a python terminal: ```python -from pyMKIAU.core import pyMKIAU_init -pyMKIAU_init() +from pyMLINC.core import pyMLINC_init +pyMLINC_init() ``` diff --git a/GEOSmkiau_GridComp/pyMLINC/driver/driver.F90 b/GEOSmkiau_GridComp/pyMLINC/driver/driver.F90 new file mode 100644 index 000000000..4fdfe5268 --- /dev/null +++ b/GEOSmkiau_GridComp/pyMLINC/driver/driver.F90 @@ -0,0 +1,10 @@ +program driver + + use pyMLINC_interface_mod, only: pyMLINC_interface_init_f, pyMLINC_interface_run_f + use ieee_exceptions, only: ieee_get_halting_mode, ieee_set_halting_mode, ieee_all + + implicit none + + real :: x + +end program driver diff --git a/GEOSmkiau_GridComp/pyMLINC/driver/driver.py b/GEOSmkiau_GridComp/pyMLINC/driver/driver.py new file mode 100644 index 000000000..28609912e --- /dev/null +++ b/GEOSmkiau_GridComp/pyMLINC/driver/driver.py @@ -0,0 +1,31 @@ +from geos_state_bias.processor import Processor +import xarray as xr +import numpy as np +def main(): + # Load sample data and call the predict function + # This part can be replaced with any data source + # For example, you can load data from a database, csv file, etc. + # You can also pass the data as an argument to the Processor class + # Each array should have shape of (lev, lat, lon), + # excpet for PS which has shape of (lat, lon) + ## Sample data load from a netcdf file + ds = xr.open_dataset("/discover/nobackup/jli30/data/geos_prog/REPLAY_M2-100KM-L181-AMIP-GFDL.geosgcm_prog.20021230_1500z.nc4") + variables = ['U', 'V', 'T', 'QV', 'QI', 'QL', 'QG', 'QR', 'QS', 'PS'] + print(ds["U"].squeeze().shape, flush=True) + print(ds["PS"].squeeze().shape, flush=True) + arrays = [ds[var].to_numpy().squeeze() for var in variables] + + ## Another argument needed is the path to the checkpoint directory + # ckpt_root_path = "/path/to/checkpoint/directory" + # If the path is static, you can hardcode it in the Processor class + #ckpt_root_path = "/discover/nobackup/jli30/data/geos_prog/ckpt" + ckpt_root_path = "/discover/nobackup/jli30/geos_state/SmaAt-UNet/geos_state_bias/checkpoints/batch_2" + ############################################################ + + # Processor class is responsible for making predictions + processor = Processor(ckpt_root_path, *arrays) + outputs = processor.predict() + # np.savez("sample_out.npz", *outputs) + +if __name__ == "__main__": + main() diff --git a/GEOSmkiau_GridComp/pyMLINC/interface/interface.c b/GEOSmkiau_GridComp/pyMLINC/interface/interface.c new file mode 100644 index 000000000..e090d3b1a --- /dev/null +++ b/GEOSmkiau_GridComp/pyMLINC/interface/interface.c @@ -0,0 +1,54 @@ +#include +#include +#include "interface.h" + +extern int pyMLINC_interface_init_c(int magic_number) +{ + // Check magic number + if (magic_number != 123456789) { + printf("[pyMLINC_interface_init_c] Magic number failed\n"); + exit(-1); + } + int rc = pyMLINC_interface_init_py(magic_number); + if (rc != 0) + exit(rc); + return 0; +} + +extern int pyMLINC_interface_run_c( + // input + int xdim, int ydim, int zdim, + const float *u, + const float *v, + const float *t, + const float *qv, + const float *ql, + const float *qi, + const float *qr, + const float *qs, + const float *qg, + const float *ps, + // output + float *dtdt, + // LAST ARGUMENT - input + int magic_number) +{ + // Check magic number + if (magic_number != 123456789) { + printf("[pyMLINC_interface_run_c] Magic number failed\n"); + exit(-1); + } + int rc = pyMLINC_interface_run_py( + // input + xdim, ydim, zdim, + u, v, t, + qv, ql, qi, qr, qs, qg, + ps, + // output + dtdt, + // LAST ARGUMENT - input + magic_number); + if (rc != 0) + exit(rc); + return 0; +} diff --git a/GEOSmkiau_GridComp/pyMLINC/interface/interface.f90 b/GEOSmkiau_GridComp/pyMLINC/interface/interface.f90 new file mode 100644 index 000000000..5c6b581e4 --- /dev/null +++ b/GEOSmkiau_GridComp/pyMLINC/interface/interface.f90 @@ -0,0 +1,50 @@ +module pyMLINC_interface_mod + + use iso_c_binding, only: c_int, c_float, c_double, c_bool, c_ptr + + implicit none + + private + + public :: pyMLINC_interface_init_f, pyMLINC_interface_run_f + + interface + + subroutine pyMLINC_interface_init_f(magic_number) bind(c, name="pyMLINC_interface_init_c") + import c_int + implicit none + integer(kind=c_int), value, intent(in) :: magic_number + end subroutine pyMLINC_interface_init_f + + subroutine pyMLINC_interface_run_f( & + ! Input + xdim, ydim, zdim, & + u, v, t, & + qv, ql, qi, qr, qs, qg, & + ps, & + ! Output + dtdt, & + ! LAST ARGUMENT - input + magic_number) bind(c, name="pyMLINC_interface_run_c") + import c_int, c_float + implicit none + ! This is an interface to a C function, the intent is NOT enforced + ! by the compiler. Consider them developer hints + integer(kind=c_int), value, intent(in) :: xdim, ydim, zdim + real(kind=c_float), dimension(*), intent(in) :: u + real(kind=c_float), dimension(*), intent(in) :: v + real(kind=c_float), dimension(*), intent(in) :: t + real(kind=c_float), dimension(*), intent(in) :: qv + real(kind=c_float), dimension(*), intent(in) :: ql + real(kind=c_float), dimension(*), intent(in) :: qi + real(kind=c_float), dimension(*), intent(in) :: qr + real(kind=c_float), dimension(*), intent(in) :: qs + real(kind=c_float), dimension(*), intent(in) :: qg + real(kind=c_float), dimension(*), intent(in) :: ps + real(kind=c_float), dimension(*), intent(out) :: dtdt + integer(kind=c_int), value, intent(in) :: magic_number + end subroutine pyMLINC_interface_run_f + + end interface + +end module pyMLINC_interface_mod diff --git a/GEOSmkiau_GridComp/pyMLINC/interface/interface.h b/GEOSmkiau_GridComp/pyMLINC/interface/interface.h new file mode 100644 index 000000000..63906205b --- /dev/null +++ b/GEOSmkiau_GridComp/pyMLINC/interface/interface.h @@ -0,0 +1,39 @@ +#pragma once + +/*** + * C Header for the interface to python. + * Define here any POD-strict structures and external functions + * that will get exported by cffi from python (see interface.py) + ***/ + +#include +#include + +// For complex type that can be exported with different +// types (like the MPI communication object), one can rely on C `union` +typedef union { + int comm_int; + void *comm_ptr; +} MPI_Comm_t; + +// Python hook functions: defined as external so that the .so can link out ot them +// Though we define `in_buffer` as a `const float*` it is _not_ enforced +// by the interface. Treat as a developer hint only. + +extern int pyMLINC_interface_init_py(int magic_number); +extern int pyMLINC_interface_run_py( + int xdim, + int ydim, + int zdim, + const float *u, + const float *v, + const float *t, + const float *qv, + const float *ql, + const float *qi, + const float *qr, + const float *qs, + const float *qg, + const float *ps, + float *dtdt, + int magic_number); diff --git a/GEOSmkiau_GridComp/pyMKIAU/interface/interface.py b/GEOSmkiau_GridComp/pyMLINC/interface/interface.py similarity index 68% rename from GEOSmkiau_GridComp/pyMKIAU/interface/interface.py rename to GEOSmkiau_GridComp/pyMLINC/interface/interface.py index c0bfc1c03..9039131eb 100644 --- a/GEOSmkiau_GridComp/pyMKIAU/interface/interface.py +++ b/GEOSmkiau_GridComp/pyMLINC/interface/interface.py @@ -1,21 +1,19 @@ import cffi # type: ignore -TMPFILEBASE = "pyMKIAU_interface_py" +TMPFILEBASE = "pyMLINC_interface_py" ffi = cffi.FFI() source = """ from {} import ffi -from datetime import datetime -from pyMKIAU.core import pyMKIAU_init, pyMKIAU_run #< User code starts here +from pyMLINC.core import pyMLINC_init, pyMLINC_run # <-- User code starts here import traceback @ffi.def_extern() -def pyMKIAU_interface_py_setservices() -> int: - +def pyMLINC_interface_init_py(magic_number) -> int: try: # Calling out off the bridge into the python - pyMKIAU_init() + pyMLINC_init(magic_number) except Exception as err: print("Error in Python:") print(traceback.format_exc()) @@ -23,11 +21,10 @@ def pyMKIAU_interface_py_setservices() -> int: return 0 @ffi.def_extern() -def pyMKIAU_interface_py_run(options, in_buffer, out_buffer) -> int: - +def pyMLINC_interface_run_py(xdim, ydim, zdim, u, v, t, qv, ql, qi, qr, qs, qg, ps, dtdt, magic_number) -> int: try: # Calling out off the bridge into the python - pyMKIAU_run(options, in_buffer, out_buffer) + pyMLINC_run(xdim, ydim, zdim, u, v, t, qv, ql, qi, qr, qs, qg, ps, dtdt, magic_number) except Exception as err: print("Error in Python:") print(traceback.format_exc()) diff --git a/GEOSmkiau_GridComp/pyMLINC/pyMLINC/__init__.py b/GEOSmkiau_GridComp/pyMLINC/pyMLINC/__init__.py new file mode 100644 index 000000000..e69de29bb diff --git a/GEOSmkiau_GridComp/pyMLINC/pyMLINC/core.py b/GEOSmkiau_GridComp/pyMLINC/pyMLINC/core.py new file mode 100644 index 000000000..3687d4ba9 --- /dev/null +++ b/GEOSmkiau_GridComp/pyMLINC/pyMLINC/core.py @@ -0,0 +1,89 @@ +import numpy +import typing +import dataclasses +from _cffi_backend import _CDataBase as CFFIObj # type: ignore + +from pyMLINC.f_py_conversion import FortranPythonConversion +from pyMLINC.cuda_profiler import TimedCUDAProfiler +from geos_state_bias.processor import Processor + + +F_PY_MEMORY_CONV = None + + +def check_magic_number(magic_number: int): + if magic_number != 123456789: # type:ignore + raise RuntimeError("Magic number failed on the Python side") + + +def pyMLINC_init(magic_number: int): + check_magic_number(magic_number) + print(f"[pyMLINC] init", flush=True) + + +def pyMLINC_run( + # input + xdim: int, + ydim: int, + zdim: int, + u_f: CFFIObj, + v_f: CFFIObj, + t_f: CFFIObj, + qv_f: CFFIObj, + ql_f: CFFIObj, + qi_f: CFFIObj, + qr_f: CFFIObj, + qs_f: CFFIObj, + qg_f: CFFIObj, + ps_f: CFFIObj, + # output + dtdt_f: CFFIObj, + # LAST ARGUMENT - input + magic_number: int +): + check_magic_number(magic_number) + global F_PY_MEMORY_CONV + if F_PY_MEMORY_CONV is None: + F_PY_MEMORY_CONV = FortranPythonConversion(xdim, ydim, zdim, numpy) + + # Move memory into a manipulatable numpy array + u = F_PY_MEMORY_CONV.fortran_to_python(u_f).transpose() + v = F_PY_MEMORY_CONV.fortran_to_python(v_f).transpose() + t = F_PY_MEMORY_CONV.fortran_to_python(t_f).transpose() + qv = F_PY_MEMORY_CONV.fortran_to_python(qv_f).transpose() + ql = F_PY_MEMORY_CONV.fortran_to_python(ql_f).transpose() + qi = F_PY_MEMORY_CONV.fortran_to_python(qi_f).transpose() + qr = F_PY_MEMORY_CONV.fortran_to_python(qr_f).transpose() + qs = F_PY_MEMORY_CONV.fortran_to_python(qs_f).transpose() + qg = F_PY_MEMORY_CONV.fortran_to_python(qg_f).transpose() + ps = F_PY_MEMORY_CONV.fortran_to_python(ps_f, dim=[xdim, ydim]).transpose() + print("[pyMLINC] Python - u:", u.shape) + print("[pyMLINC] Python - u:", numpy.sum(u), numpy.min(u), numpy.max(u)) + print("[pyMLINC] Python - v:", numpy.sum(v), numpy.min(v), numpy.max(v)) + print("[pyMLINC] Python - t:", numpy.sum(t), numpy.min(t), numpy.max(t)) + print("[pyMLINC] Python - qv:", numpy.sum(qv), numpy.min(qv), numpy.max(qv)) + print("[pyMLINC] Python - ql:", numpy.sum(ql), numpy.min(ql), numpy.max(ql)) + print("[pyMLINC] Python - qi:", numpy.sum(qi), numpy.min(qi), numpy.max(qi)) + print("[pyMLINC] Python - qr:", numpy.sum(qr), numpy.min(qr), numpy.max(qr)) + print("[pyMLINC] Python - qs:", numpy.sum(qs), numpy.min(qs), numpy.max(qs)) + print("[pyMLINC] Python - qg:", numpy.sum(qg), numpy.min(qg), numpy.max(qg)) + print("[pyMLINC] Python - ps:", numpy.sum(ps), numpy.min(ps), numpy.max(ps)) + print("[pyMLINC] Python - flushing buffer.", flush=True) + + + # Order of vvariables as defined in processor::__init__ + # U, V, T, QV, QI, QL, QG, QR, QS, PS + arrays = [u, v, t, qv, qi, ql, qg, qr, qs, ps] + ckpt_root_path = "/discover/nobackup/jli30/geos_state/SmaAt-UNet/geos_state_bias/checkpoints/batch_2" + + # Here goes math and dragons + timings: typing.Dict[str, typing.List[float]] = {} + with TimedCUDAProfiler("pyMLINC bogus math", timings): + processor = Processor(ckpt_root_path, *arrays) + dtdt = processor.predict() + + print(f"[pyMLINC] run - dtdt:", numpy.sum(dtdt), numpy.min(dtdt), numpy.max(dtdt)) + print(f"[pyMLINC] run - timers: {timings}", flush=True) + + # Output goes back to fortran + F_PY_MEMORY_CONV.python_to_fortran(dtdt.transpose(), dtdt_f) diff --git a/GEOSmkiau_GridComp/pyMKIAU/pyMKIAU/cuda_profiler.py b/GEOSmkiau_GridComp/pyMLINC/pyMLINC/cuda_profiler.py similarity index 100% rename from GEOSmkiau_GridComp/pyMKIAU/pyMKIAU/cuda_profiler.py rename to GEOSmkiau_GridComp/pyMLINC/pyMLINC/cuda_profiler.py diff --git a/GEOSmkiau_GridComp/pyMKIAU/pyMKIAU/f_py_conversion.py b/GEOSmkiau_GridComp/pyMLINC/pyMLINC/f_py_conversion.py similarity index 100% rename from GEOSmkiau_GridComp/pyMKIAU/pyMKIAU/f_py_conversion.py rename to GEOSmkiau_GridComp/pyMLINC/pyMLINC/f_py_conversion.py diff --git a/GEOSmkiau_GridComp/pyMKIAU/setup.py b/GEOSmkiau_GridComp/pyMLINC/setup.py similarity index 78% rename from GEOSmkiau_GridComp/pyMKIAU/setup.py rename to GEOSmkiau_GridComp/pyMLINC/setup.py index 851e0b1b6..683ca4746 100644 --- a/GEOSmkiau_GridComp/pyMKIAU/setup.py +++ b/GEOSmkiau_GridComp/pyMLINC/setup.py @@ -1,7 +1,7 @@ #!/usr/bin/env python # -*- coding: utf-8 -*- -"""pyMKIAU - python sub-component of GEOS MKIAU.""" +"""pyMLINC - python sub-component of GEOS MKIAU.""" from setuptools import find_namespace_packages, setup @@ -19,13 +19,13 @@ "Natural Language :: English", "Programming Language :: Python :: 3.11", ], - description=("pyMKIAU - python sub-component of GEOS MKIAU."), + description=("pyMLINC - python sub-component of GEOS MLINC."), install_requires=[], extras_require={}, long_description=readme, include_package_data=True, - name="pyMKIAU", - packages=find_namespace_packages(include=["pyMKIAU", "pyMKIAU.*"]), + name="pyMLINC", + packages=find_namespace_packages(include=["pyMLINC", "pyMLINC.*"]), setup_requires=[], url="https://github.com/GEOS-ESM/GEOSgcm_GridComp", version="0.0.0",