From 53318127d7c026f292c9f8f4c3e0f84abd5f8d13 Mon Sep 17 00:00:00 2001 From: Man Zhang Date: Mon, 18 Sep 2017 11:47:33 -0600 Subject: [PATCH 01/25] zhao-carr seperation bit-for-bit in masep branch --- GFS_layer/GFS_physics_driver.F90 | 26 ++++++++++++++------ physics/gscond.f | 41 ++++++++++++++++++++++++++++++- physics/precpd.f | 42 ++++++++++++++++++++++++++++++-- 3 files changed, 98 insertions(+), 11 deletions(-) diff --git a/GFS_layer/GFS_physics_driver.F90 b/GFS_layer/GFS_physics_driver.F90 index 9b92e4764..e2802ab4e 100644 --- a/GFS_layer/GFS_physics_driver.F90 +++ b/GFS_layer/GFS_physics_driver.F90 @@ -16,6 +16,8 @@ module module_physics_driver GFS_tbd_type, GFS_cldprop_type, & GFS_radtend_type, GFS_diag_type + use zhaocarr_gscond, only: gscond_init, gscond_run + use zhaocarr_precpd, only: precpd_init, precpd_run implicit none @@ -2372,14 +2374,22 @@ subroutine GFS_physics_driver & psautco_l, prautco_l, Model%evpco, Model%wminco, & Tbd%phy_f3d(1,1,Model%ntot3d-2), lprnt, ipr) else - call gscond (im, ix, levs, dtp, dtf, Statein%prsl, Statein%pgr, & - Stateout%gq0(1,1,1), Stateout%gq0(1,1,Model%ntcw), & - Stateout%gt0, Tbd%phy_f3d(1,1,1), Tbd%phy_f3d(1,1,2), & - Tbd%phy_f2d(1,1), Tbd%phy_f3d(1,1,3), & - Tbd%phy_f3d(1,1,4), Tbd%phy_f2d(1,2), rhc,lprnt, ipr) - - call precpd (im, ix, levs, dtp, del, Statein%prsl, & - Stateout%gq0(1,1,1), Stateout%gq0(1,1,Model%ntcw), & + +! call gscond (im, ix, levs, dtp, dtf, Statein%prsl, Statein%pgr, & + call gscond_run (im, ix, levs, dtp, dtf, Statein%prsl, Statein%pgr,& +! Stateout%gq0(1,1,1), Stateout%gq0(1,1,Model%ntcw), & +! Stateout%gt0, Tbd%phy_f3d(1,1,1), Tbd%phy_f3d(1,1,2), & +! Tbd%phy_f2d(1,1), Tbd%phy_f3d(1,1,3), & +! Tbd%phy_f3d(1,1,4), Tbd%phy_f2d(1,2), rhc,lprnt, ipr) + Stateout%gq0(:,:,1), Stateout%gq0(:,:,Model%ntcw), & + Stateout%gt0, Tbd%phy_f3d(:,:,1), Tbd%phy_f3d(:,:,2), & + Tbd%phy_f2d(:,1), Tbd%phy_f3d(:,:,3), & + Tbd%phy_f3d(:,:,4), Tbd%phy_f2d(:,2), rhc,lprnt, ipr) + +! call precpd (im, ix, levs, dtp, del, Statein%prsl, & + call precpd_run (im, ix, levs, dtp, del, Statein%prsl, & +! Stateout%gq0(1,1,1), Stateout%gq0(1,1,Model%ntcw), & + Stateout%gq0(:,:,1), Stateout%gq0(:,:,Model%ntcw), & Stateout%gt0, rain1, Diag%sr, rainp, rhc, psautco_l, & prautco_l, Model%evpco, Model%wminco, lprnt, ipr) endif diff --git a/physics/gscond.f b/physics/gscond.f index 52fc3a16f..f8811da67 100644 --- a/physics/gscond.f +++ b/physics/gscond.f @@ -81,8 +81,44 @@ !! - \f$E_{c}\f$: evaporation rate of cloud (\f$s^{-1}\f$) !> \section gen_algorithm General Algorithm !> @{ - subroutine gscond (im,ix,km,dt,dtf,prsl,ps,q,cwm,t & + +!zhang + module zhaocarr_gscond + contains + +!> @{ + subroutine gscond_init + end subroutine gscond_init +!> @} + +!> @{ +! subroutine gscond (im,ix,km,dt,dtf,prsl,ps,q,cwm,t & + subroutine gscond_run (im,ix,km,dt,dtf,prsl,ps,q,cwm,t & &, tp, qp, psp, tp1, qp1, psp1, u, lprnt, ipr) + +!!\table +!!| local var name | longname |description | units | rank | type | kind | intent | optional | +!!|----------------|----------------------------------------------------------|----------------------------------------------------------|---------|------|---------|-----------|--------|----------| +!!| im | horizontal_loop_extent | horizontal loop extent, start at 1 | index | 0 | integer | | in | F | +!!| ix | horizontal_dimension | horizontal dimension | index | 0 | integer | | in | F | +!!| km | vertical_dimension | vertical layer dimension | index | 0 | integer | | in | F | +!!| dt | physics_time_step | physics time step | s | 0 | real | kind_phys | in | F | +!!| dtf | dynamics_time_step | dynamics time step | s | 0 | real | kind_phys | in | F | +!!| prsl | air_pressure_layer | layer mean air pressure | Pa | 2 | real | kind_phys | in | F | +!!| ps | surface_air_pressure | surface pressure | Pa | 1 | real | kind_phys | in | F | +!!| q | water_vapor_specific_humidity | water vapor specific humidity | kg kg-1 | 2 | real | kind_phys | inout | F | +!!| cwm | cloud_condensed_water_specific_humidity | cloud condensed water specific humidity | kg kg-1 | 2 | real | kind_phys | inout | F | +!!| t | air_temperature | layer mean air temperature | K | 2 | real | kind_phys | inout | F | +!!| tp | air_temperature_for_restart | updated temperature for restart | K | 2 | real | kind_phys | inout | F | +!!| qp | water_vapor_specific_humidity_for_restart | updated vapor specific humidity for restart | kg kg-1 | 2 | real | kind_phys | inout | F | +!!| psp | surface_air_pressure_for_restart | updated surface pressure for restart | Pa | 1 | real | kind_phys | inout | F | +!!| tp1 | air_temperature_for_restart | updated temperature for restart | K | 2 | real | kind_phys | inout | F | +!!| qp1 | water_vapor_specific_humidity_for_restart | updated vapor specific humidity for restart | kg kg-1 | 2 | real | kind_phys | inout | F | +!!| psp1 | surface_air_pressure_restart | updated surface pressure for restart | Pa | 1 | real | kind_phys | inout | F | +!!| u | relative_humidity_threshold_for_large_scale_condensation | relative humidity threshold for large-scale condensation | 1 | 0 | real | kind_phys | in | F | +!!| lprnt | flag_print | flag for printing diagnostics to output | flag | 0 | logical | | in | F | +!!| ipr | horizontal_index_of_printed_column | horizontal index of printed column | index | 0 | integer | | in | F | + ! ! ****************************************************************** ! * * @@ -517,5 +553,8 @@ subroutine gscond (im,ix,km,dt,dtf,prsl,ps,q,cwm,t & return end !> @} + + end module zhaocarr_gscond +!> @} !! @} !! @} diff --git a/physics/precpd.f b/physics/precpd.f index 9c4ac6949..f64df52d3 100644 --- a/physics/precpd.f +++ b/physics/precpd.f @@ -73,10 +73,45 @@ !! \param[in] lprnt logical print flag !! \param[in] jpr check print point for debugging !> \section general General Algorithm + +!> @{ + + module zhaocarr_precpd + contains + +!> @{ + subroutine precpd_init + end subroutine precpd_init +!> @} + !> @{ - subroutine precpd (im,ix,km,dt,del,prsl,q,cwm,t,rn,sr & +! subroutine precpd (im,ix,km,dt,del,prsl,q,cwm,t,rn,sr & + subroutine precpd_run (im,ix,km,dt,del,prsl,q,cwm,t,rn,sr & &, rainp,u00k,psautco,prautco,evpco,wminco & &, lprnt,jpr) + +!>\table +!!| local var name | longname |description | units | rank | type | kind | intent | optional | +!!|----------------|----------------------------------------------------------|-------------------------------------------------------------------|---------|------|---------|----------|---------|----------| +!!| im | horizontal_loop_extent | horizontal loop extent, start at 1 | index | 0 | integer | | in | F | +!!| ix | horizontal_dimension | horizontal dimension | index | 0 | integer | | in | F | +!!| km | vertical_dimension | vertical layer dimension | index | 0 | integer | | in | F | +!!| dt | physics_time_step | physics time step | s | 0 | real | kind_phys| in | F | +!!| del | air_pressure_layer_difference | pressure level thickness | Pa | 2 | real | kind_phys| in | F | +!!| prsl | air_pressure_layer | layer mean pressure | Pa | 2 | real | kind_phys| in | F | +!!| q | water_vapor_specific_humidity | water vapor specific humidity | kg kg-1 | 2 | real | kind_phys| inout | F | +!!| cwm | cloud_condensed_water_specific_humidity | cloud condensed water specific humidity | kg kg-1 | 2 | real | kind_phys| inout | F | +!!| t | air_temperature | layer mean air temperature | K | 2 | real | kind_phys| inout | F | +!!| rn | large_scale_rainfall_amount | large scale rainfall amount | m | 1 | real | kind_phys| out | F | +!!| sr | ratio_of_snowfall_to_rainfall | ratio of snowfall to large-scale rainfall | 1 | 1 | real | kind_phys| out | F | +!!| rainp | rain_water_path | rainwater path | kg m-3 | 2 | real | kind_phys| out | F | +!!| u00k | relative_humidity_threshold_for_large_scale_condensation | relative humidity threshold for large-scale condensation | 1 | 0 | real | kind_phys| in | F | +!!| psautco | coefficient_from_cloud_ice_to_snow | conversion coefficient from cloud ice to snow | 1 | 0 | real | kind_phys| in | F | +!!| prautco | coefficient_from_cloud_water_to_rain | conversion coefficient from cloud water to rain | 1 | 0 | real | kind_phys| in | F | +!!| evpco | coefficient_for_evaporation_of_rainfall | coefficient for evaporation of rainfall | 1 | 0 | real | kind_phys| in | F | +!!| wminco | cloud_condensed_water_conversion_threshold | conversion coefficient from cloud liquid and ice to precipitation | 1 | 0 | real | kind_phys| in | F | +!!| lprnt | flag_print | flag for printing diagnostics to output | flag | 0 | logical | | in | F | +!!| jpr | horizontal_index_of_printed_column | horizontal index of printed column | index | 0 | integer | | in | F | ! ! ! ****************************************************************** @@ -715,5 +750,8 @@ subroutine precpd (im,ix,km,dt,del,prsl,q,cwm,t,rn,sr & ! return end -!! @} !> @} + end module zhaocarr_precpd +!> @} +!! @} + From 440e23eb46ba0f27742dd7615baef8decb110853 Mon Sep 17 00:00:00 2001 From: "Man.Zhang" Date: Wed, 20 Sep 2017 22:38:47 +0000 Subject: [PATCH 02/25] modifies tables with Ruiyu's suggestion --- physics/gscond.f | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/physics/gscond.f b/physics/gscond.f index f8811da67..7e0c73647 100644 --- a/physics/gscond.f +++ b/physics/gscond.f @@ -96,7 +96,7 @@ end subroutine gscond_init subroutine gscond_run (im,ix,km,dt,dtf,prsl,ps,q,cwm,t & &, tp, qp, psp, tp1, qp1, psp1, u, lprnt, ipr) -!!\table +!>\table !!| local var name | longname |description | units | rank | type | kind | intent | optional | !!|----------------|----------------------------------------------------------|----------------------------------------------------------|---------|------|---------|-----------|--------|----------| !!| im | horizontal_loop_extent | horizontal loop extent, start at 1 | index | 0 | integer | | in | F | @@ -109,12 +109,12 @@ subroutine gscond_run (im,ix,km,dt,dtf,prsl,ps,q,cwm,t & !!| q | water_vapor_specific_humidity | water vapor specific humidity | kg kg-1 | 2 | real | kind_phys | inout | F | !!| cwm | cloud_condensed_water_specific_humidity | cloud condensed water specific humidity | kg kg-1 | 2 | real | kind_phys | inout | F | !!| t | air_temperature | layer mean air temperature | K | 2 | real | kind_phys | inout | F | -!!| tp | air_temperature_for_restart | updated temperature for restart | K | 2 | real | kind_phys | inout | F | -!!| qp | water_vapor_specific_humidity_for_restart | updated vapor specific humidity for restart | kg kg-1 | 2 | real | kind_phys | inout | F | -!!| psp | surface_air_pressure_for_restart | updated surface pressure for restart | Pa | 1 | real | kind_phys | inout | F | -!!| tp1 | air_temperature_for_restart | updated temperature for restart | K | 2 | real | kind_phys | inout | F | -!!| qp1 | water_vapor_specific_humidity_for_restart | updated vapor specific humidity for restart | kg kg-1 | 2 | real | kind_phys | inout | F | -!!| psp1 | surface_air_pressure_restart | updated surface pressure for restart | Pa | 1 | real | kind_phys | inout | F | +!!| tp | air_temperature_at_two_time_step_back | air temperature at two time step back | K | 2 | real | kind_phys | inout | F | +!!| qp | water_vapor_specific_humidity_at_two_time_step_back | water vapor specific humidity at two time step back | kg kg-1 | 2 | real | kind_phys | inout | F | +!!| psp | surface_air_pressure_at_two_time_step_back | surface air pressure at two time step back | Pa | 1 | real | kind_phys | inout | F | +!!| tp1 | air_temperature_at_previous_time_step | air temperature at previous time step | K | 2 | real | kind_phys | inout | F | +!!| qp1 | water_vapor_specific_humidity_at_previous_time_step | water vapor specific humidity at previous time step | kg kg-1 | 2 | real | kind_phys | inout | F | +!!| psp1 | surface_air_pressure_at_previous_time_step | surface air surface pressure at previous time step | Pa | 1 | real | kind_phys | inout | F | !!| u | relative_humidity_threshold_for_large_scale_condensation | relative humidity threshold for large-scale condensation | 1 | 0 | real | kind_phys | in | F | !!| lprnt | flag_print | flag for printing diagnostics to output | flag | 0 | logical | | in | F | !!| ipr | horizontal_index_of_printed_column | horizontal index of printed column | index | 0 | integer | | in | F | From 748e5941d65526603603019e188741c528721076 Mon Sep 17 00:00:00 2001 From: Man Zhang Date: Wed, 20 Sep 2017 21:14:31 -0600 Subject: [PATCH 03/25] add *_finalize in gscond and precpd --- physics/gscond.f | 6 ++++++ physics/precpd.f | 5 +++++ 2 files changed, 11 insertions(+) diff --git a/physics/gscond.f b/physics/gscond.f index 7e0c73647..6584f0fdd 100644 --- a/physics/gscond.f +++ b/physics/gscond.f @@ -90,6 +90,7 @@ module zhaocarr_gscond subroutine gscond_init end subroutine gscond_init !> @} + !> @{ ! subroutine gscond (im,ix,km,dt,dtf,prsl,ps,q,cwm,t & @@ -554,6 +555,11 @@ subroutine gscond_run (im,ix,km,dt,dtf,prsl,ps,q,cwm,t & end !> @} +!> @{ + subroutine gscond_finalize + end subroutine gscond_finalize +!> @} + end module zhaocarr_gscond !> @} !! @} diff --git a/physics/precpd.f b/physics/precpd.f index f64df52d3..a5d207d84 100644 --- a/physics/precpd.f +++ b/physics/precpd.f @@ -751,6 +751,11 @@ subroutine precpd_run (im,ix,km,dt,del,prsl,q,cwm,t,rn,sr & return end !> @} + +!> @{ + subroutine precpd_finalize + end subroutine precpd_finalize +!> @} end module zhaocarr_precpd !> @} !! @} From 709b2284fa39a7db39e6196a32655e829bdfa594 Mon Sep 17 00:00:00 2001 From: "Man.Zhang" Date: Thu, 21 Sep 2017 21:41:31 +0000 Subject: [PATCH 04/25] fix the time step name --- physics/gscond.f | 5 +++-- physics/precpd.f | 2 +- 2 files changed, 4 insertions(+), 3 deletions(-) diff --git a/physics/gscond.f b/physics/gscond.f index 7e0c73647..b0844409c 100644 --- a/physics/gscond.f +++ b/physics/gscond.f @@ -102,8 +102,8 @@ subroutine gscond_run (im,ix,km,dt,dtf,prsl,ps,q,cwm,t & !!| im | horizontal_loop_extent | horizontal loop extent, start at 1 | index | 0 | integer | | in | F | !!| ix | horizontal_dimension | horizontal dimension | index | 0 | integer | | in | F | !!| km | vertical_dimension | vertical layer dimension | index | 0 | integer | | in | F | -!!| dt | physics_time_step | physics time step | s | 0 | real | kind_phys | in | F | -!!| dtf | dynamics_time_step | dynamics time step | s | 0 | real | kind_phys | in | F | +!!| dt | time_step_for_physics | physics time step | s | 0 | real | kind_phys | in | F | +!!| dtf | time_step_for_dynamics | dynamics time step | s | 0 | real | kind_phys | in | F | !!| prsl | air_pressure_layer | layer mean air pressure | Pa | 2 | real | kind_phys | in | F | !!| ps | surface_air_pressure | surface pressure | Pa | 1 | real | kind_phys | in | F | !!| q | water_vapor_specific_humidity | water vapor specific humidity | kg kg-1 | 2 | real | kind_phys | inout | F | @@ -118,6 +118,7 @@ subroutine gscond_run (im,ix,km,dt,dtf,prsl,ps,q,cwm,t & !!| u | relative_humidity_threshold_for_large_scale_condensation | relative humidity threshold for large-scale condensation | 1 | 0 | real | kind_phys | in | F | !!| lprnt | flag_print | flag for printing diagnostics to output | flag | 0 | logical | | in | F | !!| ipr | horizontal_index_of_printed_column | horizontal index of printed column | index | 0 | integer | | in | F | +!! ! ! ****************************************************************** diff --git a/physics/precpd.f b/physics/precpd.f index f64df52d3..255156030 100644 --- a/physics/precpd.f +++ b/physics/precpd.f @@ -96,7 +96,7 @@ subroutine precpd_run (im,ix,km,dt,del,prsl,q,cwm,t,rn,sr & !!| im | horizontal_loop_extent | horizontal loop extent, start at 1 | index | 0 | integer | | in | F | !!| ix | horizontal_dimension | horizontal dimension | index | 0 | integer | | in | F | !!| km | vertical_dimension | vertical layer dimension | index | 0 | integer | | in | F | -!!| dt | physics_time_step | physics time step | s | 0 | real | kind_phys| in | F | +!!| dt | time_step_for_physics | physics time step | s | 0 | real | kind_phys| in | F | !!| del | air_pressure_layer_difference | pressure level thickness | Pa | 2 | real | kind_phys| in | F | !!| prsl | air_pressure_layer | layer mean pressure | Pa | 2 | real | kind_phys| in | F | !!| q | water_vapor_specific_humidity | water vapor specific humidity | kg kg-1 | 2 | real | kind_phys| inout | F | From 1839748e2ba21cc50452f8f6057358ac4f9c836c Mon Sep 17 00:00:00 2001 From: "Man.Zhang" Date: Thu, 21 Sep 2017 22:08:33 +0000 Subject: [PATCH 05/25] change table format --- physics/gscond.f | 8 ++++---- physics/precpd.f | 12 ++++++------ 2 files changed, 10 insertions(+), 10 deletions(-) diff --git a/physics/gscond.f b/physics/gscond.f index cae7afaae..25ff5cc80 100644 --- a/physics/gscond.f +++ b/physics/gscond.f @@ -93,11 +93,8 @@ end subroutine gscond_init !> @{ -! subroutine gscond (im,ix,km,dt,dtf,prsl,ps,q,cwm,t & - subroutine gscond_run (im,ix,km,dt,dtf,prsl,ps,q,cwm,t & - &, tp, qp, psp, tp1, qp1, psp1, u, lprnt, ipr) -!>\table +!!\section arg_table_gscond_run !!| local var name | longname |description | units | rank | type | kind | intent | optional | !!|----------------|----------------------------------------------------------|----------------------------------------------------------|---------|------|---------|-----------|--------|----------| !!| im | horizontal_loop_extent | horizontal loop extent, start at 1 | index | 0 | integer | | in | F | @@ -120,6 +117,9 @@ subroutine gscond_run (im,ix,km,dt,dtf,prsl,ps,q,cwm,t & !!| lprnt | flag_print | flag for printing diagnostics to output | flag | 0 | logical | | in | F | !!| ipr | horizontal_index_of_printed_column | horizontal index of printed column | index | 0 | integer | | in | F | !! + subroutine gscond_run (im,ix,km,dt,dtf,prsl,ps,q,cwm,t & + &, tp, qp, psp, tp1, qp1, psp1, u, lprnt, ipr) + ! ! ****************************************************************** diff --git a/physics/precpd.f b/physics/precpd.f index 9a0482398..d18657741 100644 --- a/physics/precpd.f +++ b/physics/precpd.f @@ -85,12 +85,8 @@ end subroutine precpd_init !> @} !> @{ -! subroutine precpd (im,ix,km,dt,del,prsl,q,cwm,t,rn,sr & - subroutine precpd_run (im,ix,km,dt,del,prsl,q,cwm,t,rn,sr & - &, rainp,u00k,psautco,prautco,evpco,wminco & - &, lprnt,jpr) -!>\table +!!\section arg_table_precpd_run !!| local var name | longname |description | units | rank | type | kind | intent | optional | !!|----------------|----------------------------------------------------------|-------------------------------------------------------------------|---------|------|---------|----------|---------|----------| !!| im | horizontal_loop_extent | horizontal loop extent, start at 1 | index | 0 | integer | | in | F | @@ -112,7 +108,11 @@ subroutine precpd_run (im,ix,km,dt,del,prsl,q,cwm,t,rn,sr & !!| wminco | cloud_condensed_water_conversion_threshold | conversion coefficient from cloud liquid and ice to precipitation | 1 | 0 | real | kind_phys| in | F | !!| lprnt | flag_print | flag for printing diagnostics to output | flag | 0 | logical | | in | F | !!| jpr | horizontal_index_of_printed_column | horizontal index of printed column | index | 0 | integer | | in | F | -! +!! + subroutine precpd_run (im,ix,km,dt,del,prsl,q,cwm,t,rn,sr & + &, rainp,u00k,psautco,prautco,evpco,wminco & + &, lprnt,jpr) + ! ! ****************************************************************** ! * * From cc35a38f275570ccc24918a59068e0b46eb29b3d Mon Sep 17 00:00:00 2001 From: Man Zhang Date: Tue, 26 Sep 2017 15:43:41 -0600 Subject: [PATCH 06/25] fix some var's longname for consistency --- physics/gscond.f | 2 +- physics/precpd.f | 6 +++--- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/physics/gscond.f b/physics/gscond.f index 25ff5cc80..9d7c6b0d4 100644 --- a/physics/gscond.f +++ b/physics/gscond.f @@ -102,7 +102,7 @@ end subroutine gscond_init !!| km | vertical_dimension | vertical layer dimension | index | 0 | integer | | in | F | !!| dt | time_step_for_physics | physics time step | s | 0 | real | kind_phys | in | F | !!| dtf | time_step_for_dynamics | dynamics time step | s | 0 | real | kind_phys | in | F | -!!| prsl | air_pressure_layer | layer mean air pressure | Pa | 2 | real | kind_phys | in | F | +!!| prsl | air_pressure | layer mean air pressure | Pa | 2 | real | kind_phys | in | F | !!| ps | surface_air_pressure | surface pressure | Pa | 1 | real | kind_phys | in | F | !!| q | water_vapor_specific_humidity | water vapor specific humidity | kg kg-1 | 2 | real | kind_phys | inout | F | !!| cwm | cloud_condensed_water_specific_humidity | cloud condensed water specific humidity | kg kg-1 | 2 | real | kind_phys | inout | F | diff --git a/physics/precpd.f b/physics/precpd.f index d18657741..bb0e61e91 100644 --- a/physics/precpd.f +++ b/physics/precpd.f @@ -93,12 +93,12 @@ end subroutine precpd_init !!| ix | horizontal_dimension | horizontal dimension | index | 0 | integer | | in | F | !!| km | vertical_dimension | vertical layer dimension | index | 0 | integer | | in | F | !!| dt | time_step_for_physics | physics time step | s | 0 | real | kind_phys| in | F | -!!| del | air_pressure_layer_difference | pressure level thickness | Pa | 2 | real | kind_phys| in | F | -!!| prsl | air_pressure_layer | layer mean pressure | Pa | 2 | real | kind_phys| in | F | +!!| del | air_pressure_difference_between_midlayers | pressure level thickness | Pa | 2 | real | kind_phys| in | F | +!!| prsl | air_pressure | layer mean pressure | Pa | 2 | real | kind_phys| in | F | !!| q | water_vapor_specific_humidity | water vapor specific humidity | kg kg-1 | 2 | real | kind_phys| inout | F | !!| cwm | cloud_condensed_water_specific_humidity | cloud condensed water specific humidity | kg kg-1 | 2 | real | kind_phys| inout | F | !!| t | air_temperature | layer mean air temperature | K | 2 | real | kind_phys| inout | F | -!!| rn | large_scale_rainfall_amount | large scale rainfall amount | m | 1 | real | kind_phys| out | F | +!!| rn | rainfall_amount | large scale rainfall amount | m | 1 | real | kind_phys| out | F | !!| sr | ratio_of_snowfall_to_rainfall | ratio of snowfall to large-scale rainfall | 1 | 1 | real | kind_phys| out | F | !!| rainp | rain_water_path | rainwater path | kg m-3 | 2 | real | kind_phys| out | F | !!| u00k | relative_humidity_threshold_for_large_scale_condensation | relative humidity threshold for large-scale condensation | 1 | 0 | real | kind_phys| in | F | From 9ab0a8a05dc70b988d6e68e6406b7ceaaed32c35 Mon Sep 17 00:00:00 2001 From: "Grant.Firl" Date: Tue, 10 Oct 2017 10:25:25 -0600 Subject: [PATCH 07/25] updated gscond.f and precpd.f to have uniform doxygen formatting --- physics/gscond.f | 95 +++++++++++++----------------------- physics/precpd.f | 124 +++++++++++++++++++---------------------------- 2 files changed, 83 insertions(+), 136 deletions(-) diff --git a/physics/gscond.f b/physics/gscond.f index b112f3718..f9470d28f 100644 --- a/physics/gscond.f +++ b/physics/gscond.f @@ -3,6 +3,9 @@ !! condensation and evaporation for use in the Zhao and Carr (1997) !! \cite zhao_and_carr_1997 scheme. + module zhaocarr_gscond + contains + !> \defgroup Zhao-Carr Zhao-Carr Microphysics !! @{ !! \brief The GFS scheme for large-scale condensation and precipitation @@ -38,71 +41,32 @@ !! - Routine PRECPD is called from GBPHYS after call to GSCOND !> \defgroup condense Grid-Scale Condensation and Evaporation of Cloud -!! This subroutine computes grid-scale condensation and evaporation of -!! cloud condensate. -!! -!> There are two sources of condensation, one from large-scale -!! processes and the other from convective processes. Both of them -!! produce either cloud water or cloud ice, depending on the cloud -!! substance at and above the grid point at current and previous time -!! steps, and on the temperature. Evaporation of cloud is allowed at -!! points where the relative humidity is lower than the critical value -!! required for condensation. !! @{ -!> \param[in] ix horizontal dimension -!! \param[in] im horizontal number of used pts -!! \param[in] km vertical layer dimension -!! \param[in] dt physics time step in seconds -!! \param[in] dtf dynamics time step in seconds -!! \param[in] prsl pressure values for model layers -!! \param[in] ps surface pressure (Pa) -!! \param[in,out] q model layer specific humidity (gm/gm) -!! \param[in,out] cwm model layer cloud condensate -!! \param[in,out] t model layer mean temperature (K) -!! \param[in,out] tp model layer mean temperature (K) saved for -!! restart -!! \param[in,out] qp model layer specific humidity (gm/gm) saved -!! for restart -!! \param[in,out] psp surface pressure (Pa) saved for restart -!! \param[in,out] tp1 updated model layer mean temperature (K) saved -!! for restart -!! \param[in,out] qp1 updated model layer specific humidity (gm/gm) -!! saved for restart -!! \param[in,out] psp1 updated surface pressure (Pa) saved for -!! restart -!! \param[in] u the critical value of relative humidity for -!! large-scale condensation -!! \param[in] lprnt logical print flag -!! \param[in] ipr check print point for debugging +!> \ingroup condense +!! \brief Brief description of the subroutine !! -!! \section arg_table_Zhao_Carr_run Arguments -!! | local var name | longname | description | units | rank | type | kind | intent | optional | -!! |----------------|-------------------------------------------------------|------------------------------------|---------|------|---------|-----------|--------|----------| -!! | im | horizontal_loop_extent | horizontal loop extent, start at 1 | index | 0 | integer | | in | F | +!! \section arg_table_gscond_init Argument Table !! -!! \section def Definition of symbols -!! - \f$C_{g}\f$: grid-scale condensation rate (\f$s^{-1}\f$) -!! - \f$E_{c}\f$: evaporation rate of cloud (\f$s^{-1}\f$) -!> \section gen_algorithm General Algorithm -!> @{ - -!zhang - module zhaocarr_gscond - contains - -!> @{ subroutine gscond_init end subroutine gscond_init -!> @} - -!> @{ -!!\section arg_table_gscond_run +!> \ingroup condense +!! \brief This subroutine computes grid-scale condensation and evaporation of +!! cloud condensate. +!! +!! There are two sources of condensation, one from large-scale +!! processes and the other from convective processes. Both of them +!! produce either cloud water or cloud ice, depending on the cloud +!! substance at and above the grid point at current and previous time +!! steps, and on the temperature. Evaporation of cloud is allowed at +!! points where the relative humidity is lower than the critical value +!! required for condensation. +!!\section arg_table_gscond_run Argument Table !!| local var name | longname |description | units | rank | type | kind | intent | optional | !!|----------------|----------------------------------------------------------|----------------------------------------------------------|---------|------|---------|-----------|--------|----------| -!!| im | horizontal_loop_extent | horizontal loop extent, start at 1 | index | 0 | integer | | in | F | +!!| im | horizontal_loop_extent | horizontal loop extent, start at 1 | index | 0 | integer | | in | F | !!| ix | horizontal_dimension | horizontal dimension | index | 0 | integer | | in | F | !!| km | vertical_dimension | vertical layer dimension | index | 0 | integer | | in | F | !!| dt | time_step_for_physics | physics time step | s | 0 | real | kind_phys | in | F | @@ -111,7 +75,7 @@ end subroutine gscond_init !!| ps | surface_air_pressure | surface pressure | Pa | 1 | real | kind_phys | in | F | !!| q | water_vapor_specific_humidity | water vapor specific humidity | kg kg-1 | 2 | real | kind_phys | inout | F | !!| cwm | cloud_condensed_water_specific_humidity | cloud condensed water specific humidity | kg kg-1 | 2 | real | kind_phys | inout | F | -!!| t | air_temperature | layer mean air temperature | K | 2 | real | kind_phys | inout | F | +!!| t | air_temperature | layer mean air temperature | K | 2 | real | kind_phys | inout | F | !!| tp | air_temperature_at_two_time_step_back | air temperature at two time step back | K | 2 | real | kind_phys | inout | F | !!| qp | water_vapor_specific_humidity_at_two_time_step_back | water vapor specific humidity at two time step back | kg kg-1 | 2 | real | kind_phys | inout | F | !!| psp | surface_air_pressure_at_two_time_step_back | surface air pressure at two time step back | Pa | 1 | real | kind_phys | inout | F | @@ -120,8 +84,13 @@ end subroutine gscond_init !!| psp1 | surface_air_pressure_at_previous_time_step | surface air surface pressure at previous time step | Pa | 1 | real | kind_phys | inout | F | !!| u | relative_humidity_threshold_for_large_scale_condensation | relative humidity threshold for large-scale condensation | 1 | 0 | real | kind_phys | in | F | !!| lprnt | flag_print | flag for printing diagnostics to output | flag | 0 | logical | | in | F | -!!| ipr | horizontal_index_of_printed_column | horizontal index of printed column | index | 0 | integer | | in | F | +!!| ipr | horizontal_index_of_printed_column | horizontal index of printed column | index | 0 | integer | | in | F | !! +!! \section def Definition of symbols +!! - \f$C_{g}\f$: grid-scale condensation rate (\f$s^{-1}\f$) +!! - \f$E_{c}\f$: evaporation rate of cloud (\f$s^{-1}\f$) +!> \section Zhao-Carr_cond_detailed Detailed Algorithm +!> @{ subroutine gscond_run (im,ix,km,dt,dtf,prsl,ps,q,cwm,t & &, tp, qp, psp, tp1, qp1, psp1, u, lprnt, ipr) @@ -561,12 +530,16 @@ subroutine gscond_run (im,ix,km,dt,dtf,prsl,ps,q,cwm,t & end !> @} -!> @{ +!> \ingroup condense +!! \brief Brief description of the subroutine +!! +!! \section arg_table_gscond_finalize Argument Table +!! subroutine gscond_finalize end subroutine gscond_finalize -!> @} - end module zhaocarr_gscond + !> @} !! @} -!! @} + + end module zhaocarr_gscond diff --git a/physics/precpd.f b/physics/precpd.f index ba0aaac8d..83e8d442c 100644 --- a/physics/precpd.f +++ b/physics/precpd.f @@ -2,12 +2,51 @@ !! This file contains the subroutine that calculates precipitation !! processes from suspended cloud water/ice + module zhaocarr_precpd + contains + !> \ingroup Zhao-Carr !> \defgroup precip Precipitation (snow or rain) Production -!! This subroutine computes the conversion from condensation to +!! @{ + +!> \ingroup precip +!! \brief Brief description of the subroutine +!! +!! \section arg_table_precpd_init Argument Table +!! + subroutine precpd_init () + end subroutine precpd_init + + +!> \ingroup precip +!! \brief This subroutine computes the conversion from condensation to !! precipitation (snow or rain) or evaporation of rain. !! -!> The parameterization of precipitation is required in order to remove +!!\section arg_table_precpd_run Argument Table +!!| local var name | longname |description | units | rank | type | kind | intent | optional | +!!|----------------|----------------------------------------------------------|-------------------------------------------------------------------|---------|------|---------|----------|---------|----------| +!!| im | horizontal_loop_extent | horizontal loop extent, start at 1 | index | 0 | integer | | in | F | +!!| ix | horizontal_dimension | horizontal dimension | index | 0 | integer | | in | F | +!!| km | vertical_dimension | vertical layer dimension | index | 0 | integer | | in | F | +!!| dt | time_step_for_physics | physics time step | s | 0 | real | kind_phys| in | F | +!!| del | air_pressure_difference_between_midlayers | pressure level thickness | Pa | 2 | real | kind_phys| in | F | +!!| prsl | air_pressure | layer mean pressure | Pa | 2 | real | kind_phys| in | F | +!!| q | water_vapor_specific_humidity | water vapor specific humidity | kg kg-1 | 2 | real | kind_phys| inout | F | +!!| cwm | cloud_condensed_water_specific_humidity | cloud condensed water specific humidity | kg kg-1 | 2 | real | kind_phys| inout | F | +!!| t | air_temperature | layer mean air temperature | K | 2 | real | kind_phys| inout | F | +!!| rn | rainfall_amount | large scale rainfall amount | m | 1 | real | kind_phys| out | F | +!!| sr | ratio_of_snowfall_to_rainfall | ratio of snowfall to large-scale rainfall | 1 | 1 | real | kind_phys| out | F | +!!| rainp | rain_water_path | rainwater path | kg m-3 | 2 | real | kind_phys| out | F | +!!| u00k | relative_humidity_threshold_for_large_scale_condensation | relative humidity threshold for large-scale condensation | 1 | 0 | real | kind_phys| in | F | +!!| psautco | coefficient_from_cloud_ice_to_snow | conversion coefficient from cloud ice to snow | 1 | 0 | real | kind_phys| in | F | +!!| prautco | coefficient_from_cloud_water_to_rain | conversion coefficient from cloud water to rain | 1 | 0 | real | kind_phys| in | F | +!!| evpco | coefficient_for_evaporation_of_rainfall | coefficient for evaporation of rainfall | 1 | 0 | real | kind_phys| in | F | +!!| wminco | cloud_condensed_water_conversion_threshold | conversion coefficient from cloud liquid and ice to precipitation | 1 | 0 | real | kind_phys| in | F | +!!| lprnt | flag_print | flag for printing diagnostics to output | flag | 0 | logical | | in | F | +!!| jpr | horizontal_index_of_printed_column | horizontal index of printed column | index | 0 | integer | | in | F | +!! +!! \section general General Algorithm +!! The parameterization of precipitation is required in order to remove !! water from the atmosphere and transport it to the ground. In the !! scheme discussed here, simplifications in the precipitation !! parameterization are used due to computational limitations required @@ -45,76 +84,8 @@ !! gravity. The implementation of the precipitation scheme also !! includes a simplified procedure of computing \f$P_{r}\f$ !! and \f$P_{s}\f$ (Zhao and Carr(1997) \cite zhao_and_carr_1997). +!! \section Zhao-Carr_precip_detailed Detailed Algorithm !! @{ - -!> -!! \section arg_table_Zhao_Carr_run Arguments -!! | local var name | longname | description | units | rank | type | kind | intent | optional | -!! |----------------|-------------------------------------------------------|------------------------------------|---------|------|---------|-----------|--------|----------| -!! | im | horizontal_loop_extent | horizontal loop extent, start at 1 | index | 0 | integer | | in | F | -!! -!! \param[in] im horizontal number of used pts -!! \param[in] ix horizontal dimension -!! \param[in] km vertical layer dimension -!! \param[in] dt time step in seconds -!! \param[in] del pressure layer thickness (bottom to top) -!! \param[in] prsl pressure values for model layers (bottom to top) -!! \param[in,out] q specific humidity (updated in the code) -!! \param[in,out] cwm condensate mixing ratio (updated in the code) -!! \param[in,out] t temperature (updated in the code) -!! \param[out] rn precipitation over one time-step dt (m/dt) -!! \param[out] sr "snow ratio", ratio of snow to total precipitation -!! \param[out] rainp rainwater path -!! \param[in] u00k the critical value of relative humidity for -!! large-scale condensation -!! \param[in] psautco auto conversion coeff from ice to snow -!! \n = 4.0E-4; defined in module_MP_GFS.F90 -!! \param[in] prautco auto conversion coeff from cloud to rain -!! \n = 1.0E-4; defined in module_MP_GFS.F90 -!! \param[in] evpco coeff for evaporation of largescale rain -!! \n = 2.0E-5; defined in module_MP_GFS.F90 -!! \param[in] wminco coeff for water and ice minimum threshold to -!! conversion from condensate to precipitation -!! \n = \1.0E-5, 1.0E-5\; defined in module_MP_GFS.F90 -!! \param[in] lprnt logical print flag -!! \param[in] jpr check print point for debugging -!> \section general General Algorithm - -!> @{ - - module zhaocarr_precpd - contains - -!> @{ - subroutine precpd_init - end subroutine precpd_init -!> @} - -!> @{ - -!!\section arg_table_precpd_run -!!| local var name | longname |description | units | rank | type | kind | intent | optional | -!!|----------------|----------------------------------------------------------|-------------------------------------------------------------------|---------|------|---------|----------|---------|----------| -!!| im | horizontal_loop_extent | horizontal loop extent, start at 1 | index | 0 | integer | | in | F | -!!| ix | horizontal_dimension | horizontal dimension | index | 0 | integer | | in | F | -!!| km | vertical_dimension | vertical layer dimension | index | 0 | integer | | in | F | -!!| dt | time_step_for_physics | physics time step | s | 0 | real | kind_phys| in | F | -!!| del | air_pressure_difference_between_midlayers | pressure level thickness | Pa | 2 | real | kind_phys| in | F | -!!| prsl | air_pressure | layer mean pressure | Pa | 2 | real | kind_phys| in | F | -!!| q | water_vapor_specific_humidity | water vapor specific humidity | kg kg-1 | 2 | real | kind_phys| inout | F | -!!| cwm | cloud_condensed_water_specific_humidity | cloud condensed water specific humidity | kg kg-1 | 2 | real | kind_phys| inout | F | -!!| t | air_temperature | layer mean air temperature | K | 2 | real | kind_phys| inout | F | -!!| rn | rainfall_amount | large scale rainfall amount | m | 1 | real | kind_phys| out | F | -!!| sr | ratio_of_snowfall_to_rainfall | ratio of snowfall to large-scale rainfall | 1 | 1 | real | kind_phys| out | F | -!!| rainp | rain_water_path | rainwater path | kg m-3 | 2 | real | kind_phys| out | F | -!!| u00k | relative_humidity_threshold_for_large_scale_condensation | relative humidity threshold for large-scale condensation | 1 | 0 | real | kind_phys| in | F | -!!| psautco | coefficient_from_cloud_ice_to_snow | conversion coefficient from cloud ice to snow | 1 | 0 | real | kind_phys| in | F | -!!| prautco | coefficient_from_cloud_water_to_rain | conversion coefficient from cloud water to rain | 1 | 0 | real | kind_phys| in | F | -!!| evpco | coefficient_for_evaporation_of_rainfall | coefficient for evaporation of rainfall | 1 | 0 | real | kind_phys| in | F | -!!| wminco | cloud_condensed_water_conversion_threshold | conversion coefficient from cloud liquid and ice to precipitation | 1 | 0 | real | kind_phys| in | F | -!!| lprnt | flag_print | flag for printing diagnostics to output | flag | 0 | logical | | in | F | -!!| jpr | horizontal_index_of_printed_column | horizontal index of printed column | index | 0 | integer | | in | F | -!! subroutine precpd_run (im,ix,km,dt,del,prsl,q,cwm,t,rn,sr & &, rainp,u00k,psautco,prautco,evpco,wminco & &, lprnt,jpr) @@ -758,11 +729,14 @@ subroutine precpd_run (im,ix,km,dt,del,prsl,q,cwm,t,rn,sr & end !> @} -!> @{ +!> \ingroup precip +!! \brief Brief description of the subroutine +!! +!! \section arg_table_precpd_finalize Argument Table +!! subroutine precpd_finalize end subroutine precpd_finalize + !> @} - end module zhaocarr_precpd -!> @} -!! @} + end module zhaocarr_precpd From df2fc2844172a4d329b7d2eb988baba944095834 Mon Sep 17 00:00:00 2001 From: Man Zhang Date: Mon, 23 Oct 2017 13:17:21 -0600 Subject: [PATCH 08/25] add table of calpreciptype.f90 and modulization --- GFS_layer/GFS_physics_driver.F90 | 11 +- GFS_layer/GFS_physics_driver.F90.save | 2829 +++++++++++++++++++++++ GFS_layer/GFS_physics_driver.F90.study | 2866 ++++++++++++++++++++++++ physics/calpreciptype.f90 | 66 +- physics/calpreciptype.f90.save | 1412 ++++++++++++ physics/precpd.f | 2 +- 6 files changed, 7176 insertions(+), 10 deletions(-) create mode 100644 GFS_layer/GFS_physics_driver.F90.save create mode 100644 GFS_layer/GFS_physics_driver.F90.study create mode 100644 physics/calpreciptype.f90.save diff --git a/GFS_layer/GFS_physics_driver.F90 b/GFS_layer/GFS_physics_driver.F90 index e2802ab4e..cd19304fb 100644 --- a/GFS_layer/GFS_physics_driver.F90 +++ b/GFS_layer/GFS_physics_driver.F90 @@ -16,8 +16,9 @@ module module_physics_driver GFS_tbd_type, GFS_cldprop_type, & GFS_radtend_type, GFS_diag_type - use zhaocarr_gscond, only: gscond_init, gscond_run - use zhaocarr_precpd, only: precpd_init, precpd_run + use zhaocarr_gscond, only: gscond_run + use zhaocarr_precpd, only: precpd_run + use calpreciptype, only: calpreciptype_run implicit none @@ -2575,11 +2576,13 @@ subroutine GFS_physics_driver & if (Model%cal_pre) then ! hchuang: add dominant precipitation type algorithm i = min(3,Model%num_p3d) - call calpreciptype (kdt, Model%nrcm, im, ix, levs, levs+1, & +! call calpreciptype (kdt, Model%nrcm, im, ix, levs, levs+1, & + call calpreciptype_run (kdt, Model%nrcm, im, ix, levs, levs+1, & Tbd%rann, Grid%xlat, Grid%xlon, Stateout%gt0, & Stateout%gq0, Statein%prsl, Statein%prsi, & Diag%rain, Statein%phii, Model%num_p3d, & - Sfcprop%tsfc, Diag%sr, Tbd%phy_f3d(1,1,i), & ! input +! Sfcprop%tsfc, Diag%sr, Tbd%phy_f3d(1,1,i), & ! input + Sfcprop%tsfc, Diag%sr, Tbd%phy_f3d(:,:,i), & ! input domr, domzr, domip, doms) ! output ! ! if (lprnt) print*,'debug calpreciptype: DOMR,DOMZR,DOMIP,DOMS ' diff --git a/GFS_layer/GFS_physics_driver.F90.save b/GFS_layer/GFS_physics_driver.F90.save new file mode 100644 index 000000000..e2802ab4e --- /dev/null +++ b/GFS_layer/GFS_physics_driver.F90.save @@ -0,0 +1,2829 @@ +module module_physics_driver + + use machine, only: kind_phys + use physcons, only: con_cp, con_fvirt, con_g, con_rd, & + con_rv, con_hvap, con_hfus, & + con_rerth, con_pi, rhc_max, dxmin,& + dxinv, pa2mb, rlapse + use cs_conv, only: cs_convr + use ozne_def, only: levozp, oz_coeff, oz_pres + use h2o_def, only: levh2o, h2o_coeff, h2o_pres + use gfs_fv3_needs, only: get_prs_fv3, get_phi_fv3 + use module_nst_water_prop, only: get_dtzm_2d + use GFS_typedefs, only: GFS_statein_type, GFS_stateout_type, & + GFS_sfcprop_type, GFS_coupling_type, & + GFS_control_type, GFS_grid_type, & + GFS_tbd_type, GFS_cldprop_type, & + GFS_radtend_type, GFS_diag_type + + use zhaocarr_gscond, only: gscond_init, gscond_run + use zhaocarr_precpd, only: precpd_init, precpd_run + implicit none + + + !--- CONSTANT PARAMETERS + real(kind=kind_phys), parameter :: hocp = con_hvap/con_cp + real(kind=kind_phys), parameter :: qmin = 1.0e-10 + real(kind=kind_phys), parameter :: p850 = 85000.0 + real(kind=kind_phys), parameter :: epsq = 1.e-20 + real(kind=kind_phys), parameter :: hsub = con_hvap+con_hfus + real(kind=kind_phys), parameter :: czmin = 0.0001 ! cos(89.994) + real(kind=kind_phys), parameter :: onebg = 1.0/con_g + real(kind=kind_phys), parameter :: albdf = 0.06 + real(kind=kind_phys) tf, tcr, tcrf + parameter (tf=258.16, tcr=273.16, tcrf=1.0/(tcr-tf)) + + +!> GFS Physics Implementation Layer +!> @brief Layer that invokes individual GFS physics routines +!> @{ +!at tune step===========================================================! +! description: ! +! ! +! usage: ! +! ! +! call gbphys ! +! ! +! --- interface variables ! +! type(GFS_control_type), intent(in) :: Model ! +! type(GFS_statein_type), intent(inout) :: Statein ! +! type(GFS_stateout_type), intent(inout) :: Stateout ! +! type(GFS_sfcprop_type), intent(inout) :: Sfcprop ! +! type(GFS_coupling_type), intent(inout) :: Coupling ! +! type(GFS_grid_type), intent(in) :: Grid ! +! type(GFS_tbd_type), intent(inout :: Tbd ! +! type(GFS_cldprop_type), intent(inout) :: Cldprop ! +! type(GFS_radtend_type), intent(inout) :: Radtend ! +! type(GFS_diag_type), intent(inout) :: Diag ! +! ! +! subprograms called: ! +! ! +! get_prs, dcyc2t2_pre_rad (testing), dcyc2t3, sfc_diff, ! +! sfc_ocean,sfc_drv, sfc_land, sfc_sice, sfc_diag, moninp1, ! +! moninp, moninq1, moninq, gwdps, ozphys, get_phi, ! +! sascnv, sascnvn, rascnv, cs_convr, gwdc, shalcvt3,shalcv,! +! shalcnv, cnvc90, lrgscl, gsmdrive, gscond, precpd, ! +! progt2. ! +! ! +! ! +! program history log: ! +! 19xx - ncep mrf/gfs ! +! 2002 - s. moorthi modify and restructure and add Ferrier ! +! microphysics as an option ! +! 200x - h. juang modify (what?) ! +! nov 2004 - x. wu modify sea-ice model ! +! may 2005 - s. moorthi modify and restructure ! +! 2005 - s. lu modify to include noah lsm ! +! oct 2006 - h. wei modify lsm options to include both ! +! noah and osu lsms. ! +! 2006 - s. moorthi added a. johansson's convective gravity ! +! wave parameterization code ! +! 2007 - s. moorthi added j. han's modified pbl/sas options ! +! dec 2007 - xu li modified the operational version for ! +! nst model ! +! 2008 - s. moorthi applied xu li's nst model to new gfs ! +! mar 2008 - y.-t. hou added sunshine duration var (suntim) as ! +! an input/output argument. ! +! 2008 - jun wang added spfhmax/spfhmin as input/output. ! +! apr 2008 - y.-t. hou added lw sfc emissivity var (sfcemis), ! +! define the lw sfc dn/up fluxes in two forms: atmos! +! and ground. also changed sw sfc net flux direction! +! (positive) from ground -> atmos to the direction ! +! of atmos -> ground. recode the program and add ! +! program documentation block. +! 2008/ - s. moorthi and y.t. hou upgraded the code to more ! +! 2009 modern form and changed all the inputs to MKS units.! +! feb 2009 - s. moorthi upgraded to add Hochun's gocart changes ! +! jul 2009 - s. moorthi added rqtk for sela's semi-lagrangian ! +! aug 2009 - s. moorthi added j. han and h. pan updated shallow ! +! convection package ! +! sep 2009 - s. moorthi updated for the mcica (rrtm3) radiation ! +! dec 2010 - sarah lu lgocart added to input arg; ! +! compute dqdt_v if inline gocart is on ! +! feb 2011 - sarah lu add the option to update surface diag ! +! fields (t2m,q2m,u10m,v10m) at the end ! +! Jun 2011 - s. moorthi and Xu Li - updated the nst model ! +! ! +! sep 2011 - sarah lu correct dqdt_v calculations ! +! apr 2012 - henry juang add idea ! +! sep 2012 - s. moorthi merge with operational version ! +! Mar 2013 - Jun Wang set idea heating rate to tmp tendency ! +! May 2013 - Jun Wang tmp updated after idea phys ! +! Jun 2013 - s. moorthi corrected a bug in 3d diagnostics for T ! +! Aug 2013 - s. moorthi updating J. Whitekar's changes related ! +! to stochastic physics perturnbation ! +! Oct 2013 - Xingren Wu add dusfci/dvsfci ! +! Mar 2014 - Xingren Wu add "_cpl" for coupling ! +! Mar 2014 - Xingren Wu add "nir/vis beam and nir/vis diff" ! +! Apr 2014 - Xingren Wu add "NET LW/SW including nir/vis" ! +! Jan 2014 - Jun Wang merge Moorthi's gwdc change and H.Juang ! +! and F. Yang's energy conversion from GWD! +! jan 2014 - y-t hou revised sw sfc spectral component fluxes! +! for coupled mdl, added estimation of ocean albedo ! +! without ice contamination. ! +! Jun 2014 - Xingren Wu update net SW fluxes over the ocean ! +! (no ice contamination) ! +! Jul 2014 - Xingren Wu add Sea/Land/Ice Mask - slmsk_cpl ! +! Jul 2014 - s. moorthi merge with standalone gfs and cleanup ! +! Aug 2014 - s. moorthi add tracer fixer ! +! Sep 2014 - Sarah Lu disable the option to compute tracer ! +! scavenging in GFS phys (set fscav=0.) ! +! Dec 2014 - Jun Wang add cnvqc_v for gocart ! + +! ==================== defination of variables ==================== ! +! --- 2014 - D. Dazlich Added Chikira-Sugiyama (CS) convection ! +! as an option in opr GFS. ! +! Apr 2015 S. Moorthi Added CS scheme to NEMS/GSM ! +! Jun 2015 S. Moorthi Added SHOC to NEMS/GSM ! +! Aug 2015 - Xu Li change nst_fcst to be nstf_name ! +! and introduce depth mean SST ! +! Sep 2015 - Xingren Wu remove oro_cpl & slmsk_cpl ! +! Sep 2015 - Xingren Wu add sfc_cice ! +! Sep 2015 - Xingren Wu connect CICE output to sfc_cice ! +! Jan 2016 - P. Tripp NUOPC/GSM merge ! +! Mar 2016 - J. Han - add ncnvcld3d integer ! +! for convective cloudiness enhancement ! +! Mar 2016 - J. Han - change newsas & sashal to imfdeepcnv ! +! & imfshalcnv, respectively ! +! Mar 2016 F. Yang add pgr to rayleigh damping call ! +! Mar 2016 S. Moorthi add ral_ts ! +! Mar 2016 Ann Cheng add morrison 2m microphysics (gsfc) ! +! May 2016 S. Moorthi cleanup 2m microphysics implementation ! +! Jun 2016 X. Li change all nst_fld as inout ! +! jul 2016 S. Moorthi fix some bugs in shoc/2m microphysics ! +! au-nv2016a S. Moorthi CS with AW and connect with shoc/2m ! +! Dec 2016 Anning C. Add prognostic rain and snow with 2M ! +! +! ==================== end of description ===================== +! ==================== definition of variables ==================== ! + +!> @details This subroutine is the suite driver for the GFS atmospheric physics and surface. +!! It is responsible for calculating and applying tendencies of the atmospheric state +!! variables due to the atmospheric physics and due to the surface layer scheme. In addition, +!! this routine applies radiative heating rates that were calculated during the +!! antecedent call to the radiation scheme. Code within this subroutine is executed on the +!! physics sub-timestep. The sub-timestep loop is executed in the subroutine gloopb. +!! +!! \section general General Algorithm +!! -# Prepare input variables for calling individual parameterizations. +!! -# Using a two-iteration loop, calculate the state variable tendencies for the surface layer. +!! -# Calculate the state variable tendencies due to the PBL (vertical diffusion) scheme. +!! -# Calculate the state variable tendencies due to orographic gravity wave drag and Rayleigh damping. +!! -# Apply tendencies to the state variables calculated so far: +!! - for temperature: radiation, surface, PBL, oro. GWD, Rayleigh damping +!! - for momentum: surface, PBL, oro. GWD, Rayleigh damping +!! - for water vapor: surface, PBL +!! -# Calculate and apply the tendency of ozone. +!! -# Prepare input variables for physics routines that update the state variables within their subroutines. +!! -# If SHOC is active and is supposed to be called before convection, call it and update the state variables within. +!! -# Calculate and apply the state variable tendencies (within the subroutine) due to deep convection. +!! -# Calculate the state variable tendencies due to convective gravity wave drag and apply them afterwards. +!! -# Calculate and apply the state variable tendencies (within the subroutine) due to shallow convection. +!! -# If SHOC is active and is supposed to be called after convection, call it and update the state variables within. +!! -# Prepare for microphysics call by calculating preliminary variables. +!! -# If necessary, call the moist convective adjustment subroutine and update the state temperature and moisture variable within. +!! -# Calculate and apply the state variable tendencies (within the subroutine) due to microphysics. +!! -# Determine the precipitation type and update land surface properties if necessary. +!! -# Fill the output variables from the local variables as necessary and deallocate allocatable arrays. +!! \section detailed Detailed Algorithm +!! ## Prepare input variables for calling individual parameterizations. +!! Before calling any parameterizations, there is a section at the beginning of the subroutine for +!! preparing input arguments to the various schemes based on general input to the driver and initializing +!! variables used throughout the driver. +!! - General initialization: +!! - set a flag for running in debug mode and the horizontal index of the column to print +!! - calculate the pressure at layer centers, the exner function at layer centers and interfaces, +!! geopotential at layer centers and interfaces, and the layer-centered pressure difference +!! - calculate the ratio of dynamics time step to physics time step for applying tendencies +!! - initialize local tendency arrays to zero +!! - Radiation: +!! - adjust radiative fluxes and heating rates to the shorter physics time step (from the longer radiation time step), +!! unless idealized physics is true (lsidea) where radiative heating rates are set to 0 +!! - compute diagnostics from the radiation scheme needed for other schemes (e.g., downward longwave flux absorbed by the surface) +!! - accumulate the upward and downward longwave fluxes at the surface +!! - Surface: +!! - set NOAH and OSU scheme variables from gbphys input arguments and initialize local soil moisture variables +!! - set local sea ice variables from gbphys arguments +!! - set up A/O/I coupling variables from gbphys arguments +!! - PBL: +!! - set the number of tracers that are diffused vertically +!! - SHOC: +!! - determine the index of TKE (ntk) in the convectively transported tracer array (clw) +!! - allocate precipitation mixing ratio cloud droplet number concentration arrays +!! - Deep Convection: +!! - determine which tracers in the tracer input array undergo convective transport (valid only for the RAS and Chikira-Sugiyama schemes) and allocate a local convective transported tracer array (clw) +!! - apply an adjustment to the tracers from the dynamics +!! - calculate horizontal grid-related parameters needed for some parameterizations +!! - calculate the maxiumum cloud base updraft speed for the Chikira-Sugiyama scheme +!! - allocate array for cloud water and cloud cover (for non-RAS and non-Chikira-Sugiyama deep convective schemes) +!! - Shallow Convection: +!! - when using the Tiedtke shallow convection scheme with the stratus modifications, find the lowest +!! model level where a temperature inversion exists in the absence of CTEI +!! - Microphysics: +!! - for the Morrison (MGB) scheme, calculate 'FRLAND' if the grid point is over land +!! - allocate arrays associated with the Morrison scheme +!! - assign the local critical relative humidity variables from the gbphys arguments +!! - Gravity Wave Drag: +!! - calculate the deep convective cloud fraction at cloud top for the convective GWD scheme +!! . +!! ## Using a two-iteration loop, calculate the state variable tendencies for the surface layer. +!! - Each iteration of the loop calls the following: +!! - 'sfc_diff' to calculate surface exchange coefficients and near-surface wind +!! - surface energy balances routines are called regardless of surface type; the surface type is checked within each to determine whether the routine is "active" +!! - for the surface energy balance over the ocean, call 'sfc_nst' if NSST is on, otherwise, call 'sfc_ocean' +!! - for the surface energy balance over the land, call 'sfc_drv' for the NOAH model and 'sfc_land' for the OSU model +!! - for the surface energy balance over sea ice, call sfc_sice; if A/O/I coupling, call sfc_cice +!! - The initial iteration has flag_guess = F unless wind < 2 m/s; flag_iter = T +!! - After the initial iteration, flag_guess = F and flag_iter = F (unless wind < 2 m/s and over a land surface or an ocean surface with NSST on) +!! - The following actions are performed after the iteration to calculate surface energy balance: +!! - set surface output variables from their local values +!! - call 'sfc_diag' to calculate state variable values at 2 and 10 m as appropriate from near-surface model levels and the surface exchange coefficients +!! - if A/O/I coupling, set coupling variables from local variables and calculate the open water albedo +!! - finally, accumulate surface-related diagnostics and calculate the max/min values of T and q at 2 m height. +!! . +!! ## Calculate the state variable tendencies due to the PBL (vertical diffusion) scheme. +!! - Call the vertical diffusion scheme (PBL) based on the following logical flags: do_shoc, hybedmf, old_monin, mstrat +!! - the PBL scheme is expected to return tendencies of the state variables +!! - If A/O/I coupling and the surface is sea ice, overwrite some surface-related variables to their states before PBL was called +!! - For diagnostics, do the following: +!! - accumulate surface state variable tendencies and set the instantaneous values for output +!! - accumulate the temperature tendency due to the PBL scheme in dt3dt(:,:,3), subtracting out the radiative heating rate if necessary +!! - accumulate the u, v tendencies due to the PBL in du3dt(:,:,1:2) and dv3dt(:,:,1:2) +!! - accumulate the water vapor tendency due to the PBL in dq3dt(:,:,1) +!! - accumulate the ozone tendency in dq3dt(:,:,5) +!! . +!! ## Calculate the state variable tendencies due to orographic gravity wave drag and Rayleigh damping. +!! - Based on the variable nmtvr, unpack orographic gravity wave varibles from the hprime array +!! - Call 'gwdps' to calculate tendencies of u, v, T, and surface stress +!! - Accumulate gravity wave drag surface stresses. +!! - Accumulate change in u, v, and T due to oro. gravity wave drag in du3dt(:,:,2), dv3dt(:,:,2), and dt3dt(:,:,2) +!! - Call 'rayleigh_damp' to calculate tendencies to u, v, and T due to Rayleigh friction +!! . +!! ## Apply tendencies to the state variables calculated so far. +!! ## Calculate and apply the tendency of ozone. +!! - Call the convective adjustment scheme for IDEA +!! - Call 'ozphys_2015' or 'ozphys' depending on the value of pl_coeff, updating the ozone tracer within and outputing the tendency of ozone in dq3dt(:,:,6) +!! - Call 'h20phys' if necessary ("adaptation of NRL H20 phys for stratosphere and mesophere") +!! . +!! ## Prepare input variables for physics routines that update the state variables within their subroutines. +!! - If diagnostics is active, save the updated values of the state variables in 'dudt', 'dvdt', 'dTdt', and 'dqdt(:,:,1)' +!! - Call 'get_phi' to calculate geopotential from p, q, T +!! - Initialize the cloud water and ice portions of the convectively transported tracer array (clw) and (if the deep convective scheme is not RAS or Chikira-Sugiyama) the convective cloud water and cloud cover. +!! - If the dep convective scheme is RAS or Chikira-Sugiyama, fill the 'clw' array with tracers to be transported by convection +!! - Initialize 'ktop' and 'kbot' (to be modified by all convective schemes except Chikira-Sugiyama) +!! - Prepare for microphysics call (if cloud condensate is in the input tracer array): +!! - all schemes: calculate critical relative humidity +!! - Morrison et al. scheme (occasionally denoted MGB) (when ncld==2): set clw(:,:,1) to cloud ice and clw(:,:,2) to cloud liquid water +!! - Ferrier scheme (num_p3d==3): set the cloud water variable and separate hydrometeors into cloud ice, cloud water, and rain; set clw(:,:,1) to cloud ice and clw(:,:,2) to cloud liquid water +!! - Zhao-Carr scheme (num_p3d==4): calculate autoconversion coefficients from input constants and grid info; set set clw(:,:,1) to cloud liquid water +!! - otherwise: set autoconversion parameters like in Zhao-Carr and set critical relative humidity to 1 +!! . +!! ## If SHOC is active and is supposed to be called before convection, call it and update the state variables within. +!! - Prior to calling SHOC, prepare some microphysics variables: +!! - if Morrison et al. scheme: set 'skip_macro', fill clw(:,:,1,2) with cloud ice, liquid from the tracer array, and fill cloud droplet number concentration arrays from the input tracer array +!! - if Zhao-Carr scheme: initialize precip. mixing ratios to 0, fill clw(:,:,1,2) with cloud ice, liquid from the tracer array (as a function of temperature) +!! - Call 'shoc' (modifies state variables within the subroutine) +!! - Afterward, set updated cloud number concentrations in the tracer array from the updated 'ncpl' and 'ncpi' +!! . +!! ## Calculate and apply the state variable tendencies (within the subroutine) due to deep convection. +!! - Call deep convective scheme according to the parameter 'imfdeepcnv', 'ras', and 'cscnv'. +!! - if imfdeepcnv == 0, 1, or 2, no special processing is needed +!! - if the Chikira-Sugiyama scheme (cscnv), convert rain rate to accumulated rain (rain1) +!! - if RAS, initialize 'ccwfac', 'dlqfac', 'lmh', and revap before the call to 'rascnv' +!! - Zero out 'cld1d' (cloud work function calculated in non-RAS, non-Chikira-Sugiyama schemes) +!! - If 'lgocart', accumulate convective mass fluxes and convective cloud water +!! - Update tracers in the tracer array (gq0) due to convective transport (RAS, CS only) from the 'clw' array +!! - Calculate accumulated surface convective precip. for this physics time step (rainc) +!! - If necessary, accumulate cloud work function, convective precipitation, and convective mass fluxes; accumulate dt3dt(:,:,4), dq3dt(:,:,2), du3dt(:,:,3), dv3dt(:,:,3) as change in state variables due to deep convection +!! - If 'lgocart', repeat the accumulation of convective mass fluxes and convective cloud water; save convective tendency for water vapor in 'dqdt_v' +!! - If PDF-based clouds are active and Zhao-Carr microphysics, save convective cloud cover and water in 'phy_f3d' array +!! - otherwise, if non-PDF-based clouds and the "convective cloudiness enhancement" is active, save convective cloud water in 'phy_f3d' array +!! . +!! ## Calculate the state variable tendencies due to convective gravity wave drag and apply them afterwards. +!! - Calculate the average deep convective heating rate in the column to pass into 'gwdc' +!! - Call 'gwdc' to calculate tendencies of u, v due to convective GWD +!! - For diagnostics, accumulate the vertically-integrated change in u, v due to conv. GWD; accumulate change in u, v, due to conv. GWD in du3dt(:,:,4) and dv3dt(:,:,4) +!! - Calculate updated values of u, v, T using conv. GWD tendencies +!! . +!! ## Calculate and apply the state variable tendencies (within the subroutine) due to shallow convection. +!! - If diagnostics are active, set 'dtdt' and 'dqdt' to updated values of T and q before shallow convection +!! - If SHOC is not active, do the following: +!! - for the mass-flux shallow convection scheme (imfdeepcnv == 1), call 'shalcnv' +!! - for the scale- and aerosol-aware scheme (imfshalcnv == 2), call 'mfshalcnv' +!! - for either of the first two schemes, perform the following after the call: +!! - if Zhao-Carr microphysics with PDF-based clouds, save convective cloud water an cover in 'phy_f3d' +!! - if non-PDF-based clouds and convective cloudiness enhancement is active, save convective cloud water in 'phy_f3d' +!! - calculate shallow convective precip. and add it to convective precip; accumulate convective precip. +!! - for the Tiedtke scheme (imfshalcnv == 0), find the top level where shallow convection must stratosphere +!! - if using Moorthi's approach to stratus, call 'shalcv' +!! - otherwise, call 'shalcvt3' +!! - for diagnostics, accumulate the change in water vapor due to shallow convection and save in dqdt_v if 'lgocart'; +!! - save the change in T and q due to shallow convection in dt3dt(:,:,5) and dq3dt(:,:,3); reset dtdt and dqdt to the updated values of T, q after shallow Convection +!! - if 'clw' is not partitioned into ice/water, set 'clw(ice)' to zero +!! - If SHOC is active (and shocaftcnv) +!! - if Morrison et al. scheme: set 'skip_macro' and fill cloud droplet number concentration arrays from the input tracer array +!! - initialize precip. mixing ratios to 0 +!! - call 'shoc' (modifies state variables within the subroutine) +!! - afterward, set updated cloud number concentrations in the tracer array from the updated 'ncpl' and 'ncpi' +!! . +!! ## Prepare for microphysics call by calculating preliminary variables. +!! - For Morrison et al. microphysics, set cloud water and ice arrays to the convecitvely transported values +!! - For Ferrier microphysics, combine convectively transported cloud water and ice with column rain and save in cloud water array +!! - calculate and save ice fraction and rain fraction in phy_f3d(1),(2) +!! - For Zhao-Carr, combine convectively transported cloud water and ice into the cloud water array +!! - Otherwise, combine convectively transported cloud water and ice into the convectively transported cloud water +!! - Call 'cnvc90'; a "legacy routine which determines convective clouds"; outputs 'acv','acvb','acvt','cv','cvb','cvt' +!! . +!! ## If necessary, call the moist convective adjustment subroutine and update the state temperature and moisture variable within. +!! - Updates T, q, 'rain1', cloud water array +!! - Accumulate convective precip +!! - For diagnostics, accumulate the change in T, q due to moist convective adjustment; reset 'dtdt' and 'dqdt' to updated T, q before call to microphysics +!! . +!! ## Calculate and apply the state variable tendencies (within the subroutine) due to microphysics. +!! - If 'lgocart', calculate instantaneous moisture tendency in dqdt_v +!! - If no cloud microphysics (ncld == 0), call 'lrgscl' to update T, q and output large scale precipitation and cloud water +!! - Otherwise, a more advanced microphysics scheme is called (which scheme depends on values of 'num_p3d','do_shoc',and 'ncld') +!! - Ferrier scheme (num_p3d == 3): +!! - calculate droplet number concentration and minimum large ice fraction +!! - call 'gsmdrive' (modifies T, q, cloud water, 'f_ice', 'f_rain', 'f_rimef', 'rain1') +!! - Zhao-Carr-Sundqvist scheme (num_p3d == 4): +!! - if non-PDF-based clouds: +!! - if 'do_shoc', call 'precpd_shoc' (precpd modified for SHOC) +!! - else, call 'gscond' (grid-scale condensation/evaporation); updates water vapor, cloud water, temperature +!! - call 'precpd'; updates water vapor, cloud water, temperature and outputs precip., snow ratio, and rain water path +!! - for PDF-based clouds: +!! - call 'gscondp' followed by 'precpdp' (similar arguments to gscond, precpd above) +!! - Morrison et al. scheme (ncld = 2): +!! - if 'do_shoc', set clw(1),(2) from updated values; set phy_f3d(:,:,1) from phy_f3d(:,:,ntot3d-2) +!! - else, set clw(1),(2) from updated values; set phy_f3d(:,:,1) to cloud cover from previous time step + convective cloud water from convective scheme +!! - call 'm_micro_driver'; updates water vapor, temperature, droplet number concentrations, cloud cover +!! - Combine large scale and convective precip. +!! - For diagnostics, accumulate total surface precipitation and accumulate change in T and q due to microphysics in dt3dt(:,:,6) and dq3dt(:,:,4) +!! . +!! ## Determine the precipitation type and update land surface properties if necessary. +!! - If 'cal_pre', diagnose the surface precipitation type +!! - call 'calpreciptype'; set snow flag to 1 if snow or sleet, 0 otherwise +!! - For rain/snow decision, calculate temperature at 850 hPa (\f$T_{850}\f$) +!! - If not 'cal_pre', set snow flag to 1 if \f$T_{850}\f$ is below freezing +!! - For coupling, accumulate rain if \f$T_{850}\f$ is above freezing, otherwise accumulate snow +!! - If using the OSU land model, accumulate surface snow depth if \f$T_{850}\f$ is below freezing and not over an ocean surface +!! - call 'progt2' (canopy and soil moisture?) and set the soil liquid water equal to soil total water +!! - if 'lgocart', call 'sfc_diag' to update near-surface state variables (this "allows gocart to use filtered wind fields") +!! - If necessary (lssav), update the 2m max/min values of T and q +!! - If necessary (lssav), accumulate total runoff and surface runoff. +!! . +!! ## Fill the output variables from the local variables as necessary and deallocate allocatable arrays. +!! - Set global sea ice thickness and concentration as well as the temperature of the sea ice +!! - Set global soil moisture variables +!! - Calculate precipitable water and water vapor mass change due to all physics for the column +!! - Deallocate arrays for SHOC scheme, deep convective scheme, and Morrison et al. microphysics + + + public GFS_physics_driver + + CONTAINS +!******************************************************************************************* + + subroutine GFS_physics_driver & + (Model, Statein, Stateout, Sfcprop, Coupling, & + Grid, Tbd, Cldprop, Radtend, Diag) + + implicit none +! +! --- interface variables + type(GFS_control_type), intent(in) :: Model + type(GFS_statein_type), intent(inout) :: Statein + type(GFS_stateout_type), intent(inout) :: Stateout + type(GFS_sfcprop_type), intent(inout) :: Sfcprop + type(GFS_coupling_type), intent(inout) :: Coupling + type(GFS_grid_type), intent(in) :: Grid + type(GFS_tbd_type), intent(inout) :: Tbd + type(GFS_cldprop_type), intent(inout) :: Cldprop + type(GFS_radtend_type), intent(inout) :: Radtend + type(GFS_diag_type), intent(inout) :: Diag +! +! --- local variables + + !--- INTEGER VARIABLES + integer :: me, lprint, ipr, ix, im, levs, ntrac, nvdiff, kdt + integer :: i, kk, ic, k, n, k1, iter, levshcm, tracers, & + trc_shft, tottracer, num2, num3, nshocm, nshoc, ntk + + integer, dimension(size(Grid%xlon,1)) :: & + kbot, ktop, kcnv, soiltyp, vegtype, kpbl, slopetyp, kinver, & + lmh, levshc, islmsk, & + !--- coupling inputs for physics + islmsk_cice + + !--- LOGICAL VARIABLES + logical :: lprnt, revap, do_awdd + + logical, dimension(size(Grid%xlon,1)) :: & + flag_iter, flag_guess, invrsn, skip_macro, & + !--- coupling inputs for physics + flag_cice + + logical, dimension(Model%ntrac-Model%ncld+2,2) :: & + otspt + + !--- REAL VARIABLES + real(kind=kind_phys) :: & + dtf, dtp, rhbbot, rhbtop, rhpbl, frain, tem, tem1, tem2, & + xcosz_loc, zsea1, zsea2, eng0, eng1, dpshc, & + !--- experimental for shoc sub-stepping + dtshoc + + real(kind=kind_phys), dimension(size(Grid%xlon,1)) :: & + ccwfac, garea, dlength, cumabs, cice, zice, tice, gflx, & + rain1, raincs, snowmt, cd, cdq, qss, dusfcg, dvsfcg, dusfc1, & + dvsfc1, dtsfc1, dqsfc1, rb, drain, cld1d, evap, hflx, & + stress, t850, ep1d, gamt, gamq, sigmaf, oc, theta, gamma, & + sigma, elvmax, wind, work1, work2, runof, xmu, fm10, fh2, & + tsurf, tx1, tx2, ctei_r, evbs, evcw, trans, sbsno, snowc, & + frland, adjsfcdsw, adjsfcnsw, adjsfcdlw, adjsfculw, & + adjnirbmu, adjnirdfu, adjvisbmu, adjvisdfu, adjnirbmd, & + adjnirdfd, adjvisbmd, adjvisdfd, gabsbdlw, xcosz, tseal, & + snohf, dlqfac, work3, ctei_rml, cldf, domr, domzr, domip, & + doms, psautco_l, prautco_l, ocalnirbm_cpl, ocalnirdf_cpl, & + ocalvisbm_cpl, ocalvisdf_cpl, dtzm, temrain1, fscav, fswtr, & + !--- coupling inputs for physics + dtsfc_cice, dqsfc_cice, dusfc_cice, dvsfc_cice, ulwsfc_cice, & + tisfc_cice, tsea_cice, hice_cice, fice_cice, & + !--- for CS-convection + wcbmax + + real(kind=kind_phys), dimension(size(Grid%xlon,1),4) :: & + oa4, clx + + real(kind=kind_phys), dimension(size(Grid%xlon,1),Model%lsoil) :: & + smsoil, stsoil, slsoil + + real(kind=kind_phys), dimension(size(Grid%xlon,1),Model%levs) :: & + del, rhc, dtdt, dudt, dvdt, gwdcu, gwdcv, dtdtc, rainp, & + ud_mf, dd_mf, dt_mf, prnum, dkt, sigmatot, sigmafrac + + !--- GFDL modification for FV3 + real(kind=kind_phys), dimension(size(Grid%xlon,1),Model%levs+1) ::& + del_gz + + real(kind=kind_phys), dimension(size(Grid%xlon,1),Model%levs,Model%ntrac) :: & + dqdt + + real(kind=kind_phys), dimension(size(Grid%xlon,1),Model%levs,Model%nctp) :: & + sigmai, vverti + + real(kind=kind_phys), dimension(size(Grid%xlon,1),Model%levs,oz_coeff+5) :: & + dq3dt_loc + + !--- ALLOCATABLE ELEMENTS + !--- in clw, the first two varaibles are cloud water and ice. + !--- from third to ntrac are convective transportable tracers, + !--- third being the ozone, when ntrac=3 (valid only with ras) + !--- Anning Cheng 9/21/2016 leave a hook here for diagnosed snow, + !--- rain, and their number + real(kind=kind_phys), allocatable :: & + clw(:,:,:), qpl(:,:), qpi(:,:), ncpl(:,:), ncpi(:,:), & + qrn(:,:), qsnw(:,:), ncpr(:,:), ncps(:,:), cnvc(:,:), & + cnvw(:,:) + !--- for 2 M microphysics + real(kind=kind_phys), allocatable, dimension(:) :: & + cn_prc, cn_snr + real(kind=kind_phys), allocatable, dimension(:,:) :: & + qlcn, qicn, w_upi, cf_upi, CNV_MFD, CNV_PRC3, CNV_DQLDT, & + CLCN, CNV_FICE, CNV_NDROP, CNV_NICE + +! +! +!===> ... begin here + + me = Model%me + ix = size(Grid%xlon,1) + im = size(Grid%xlon,1) + levs = Model%levs + ntrac = Model%ntrac + dtf = Model%dtf + dtp = Model%dtp + kdt = Model%kdt + lprnt = Model%lprnt + nvdiff = ntrac ! vertical diffusion of all tracers! + ipr = min(im,10) + + do i = 1, im + if(nint(Sfcprop%slmsk(i)) == 1) then + frland(i) = 1.0 + else + frland(i) = 0. + endif + enddo +! +! --- ... figure out number of extra tracers +! + tottracer = 0 ! no convective transport of tracers + if (Model%trans_trac .or. Model%cscnv) then + if (Model%ntcw > 0) then + if (Model%ntoz < Model%ntcw) then + trc_shft = Model%ntcw + Model%ncld - 1 + else + trc_shft = Model%ntoz + endif + elseif (Model%ntoz > 0) then + trc_shft = Model%ntoz + else + trc_shft = 1 + endif + + tracers = Model%ntrac - trc_shft + tottracer = tracers + if (Model%ntoz > 0) tottracer = tottracer + 1 ! ozone is added separately + endif + if (Model%ntke > 0) ntk = Model%ntke - trc_shft + 3 + +! if (lprnt) write(0,*)' trans_trac=',trans_trac,' tottracer=', & +! write(0,*)' trans_trac=',trans_trac,' tottracer=', & +! & tottracer,' trc_shft=',trc_shft,' kdt=',kdt +! &, ntrac-ncld+2,' clstp=',clstp,' kdt=',kdt +! &,' ntk=',ntk,' lat=',lat + + skip_macro = .false. + + allocate ( clw(ix,levs,tottracer+2) ) + if (Model%imfdeepcnv >= 0 .or. Model%imfshalcnv > 0) then + allocate (cnvc(ix,levs), cnvw(ix,levs)) + endif +! +! --- set initial quantities for stochastic physics deltas + if (Model%do_sppt) then + Tbd%dtdtr = 0.0 + Tbd%dtotprcp (:) = Diag%rain (:) + Tbd%dcnvprcp (:) = Diag%rainc (:) + Tbd%drain_cpl (:) = Coupling%rain_cpl (:) + Tbd%dsnow_cpl (:) = Coupling%snow_cpl (:) + endif + + if (Model%do_shoc) then + allocate (qpl(im,levs), qpi(im,levs), ncpl(im,levs), ncpi(im,levs)) + do k=1,levs + do i=1,im + ncpl(i,k) = 0.0 + ncpi(i,k) = 0.0 + enddo + enddo + endif + + if (Model%ncld == 2) then ! For MGB double moment microphysics + allocate (qlcn(im,levs), qicn(im,levs), w_upi(im,levs), & + cf_upi(im,levs), CNV_MFD(im,levs), CNV_PRC3(im,levs), & + CNV_DQLDT(im,levs), clcn(im,levs), cnv_fice(im,levs), & + cnv_ndrop(im,levs), cnv_nice(im,levs)) + allocate (cn_prc(im), cn_snr(im)) + allocate (qrn(im,levs), qsnw(im,levs), ncpr(im,levs), ncps(im,levs)) + else + allocate (qlcn(1,1), qicn(1,1), w_upi(1,1), cf_upi(1,1), & + CNV_MFD(1,1), CNV_PRC3(1,1), CNV_DQLDT(1,1), & + clcn(1,1), cnv_fice(1,1), cnv_ndrop(1,1), cnv_nice(1,1)) + endif + + +#ifdef GFS_HYDRO + call get_prs(im, ix, levs, ntrac, Statein%tgrs, Statein%qgrs, & + Model%thermodyn_id, Model%sfcpress_id, & + Model%gen_coord_hybrid, Statein%prsi, Statein%prsik, & + Statein%prsl, Statein%prslk, Statein%phii, Statein%phil, del) +#else +!GFDL Adjust the geopotential height hydrostatically in a way consistent with FV3 discretization + call get_prs_fv3 (ix, levs, ntrac, Statein%phii, Statein%prsi, & + Statein%tgrs, Statein%qgrs, del, del_gz) +#endif +! + rhbbot = Model%crtrh(1) + rhpbl = Model%crtrh(2) + rhbtop = Model%crtrh(3) +! +! --- ... frain=factor for centered difference scheme correction of rain amount. + + frain = dtf / dtp + + do i = 1, im + sigmaf(i) = max( Sfcprop%vfrac(i),0.01 ) + islmsk(i) = nint(Sfcprop%slmsk(i)) + + if (islmsk(i) == 2) then + if (Model%isot == 1) then + soiltyp(i) = 16 + else + soiltyp(i) = 9 + endif + if (Model%ivegsrc == 1) then + vegtype(i) = 15 + elseif(Model%ivegsrc == 2) then + vegtype(i) = 13 + endif + slopetyp(i) = 9 + else + soiltyp(i) = int( Sfcprop%stype(i)+0.5 ) + vegtype(i) = int( Sfcprop%vtype(i)+0.5 ) + slopetyp(i) = int( Sfcprop%slope(i)+0.5 ) !! clu: slope -> slopetyp + endif +! --- ... xw: transfer ice thickness & concentration from global to local variables + zice(i) = Sfcprop%hice(i) + cice(i) = Sfcprop%fice(i) + tice(i) = Sfcprop%tisfc(i) +! +!GFDL work1(i) = (log(coslat(i) / (nlons(i)*latr)) - dxmin) * dxinv +! work1(i) = (log(Grid%dx(i)) - dxmin) * dxinv + work1(i) = (log(Grid%area(i)) - dxmin) * dxinv + work1(i) = max(0.0, min(1.0,work1(i))) + work2(i) = 1.0 - work1(i) + Diag%psurf(i) = Statein%pgr(i) + work3(i) = Statein%prsik(i,1) / Statein%prslk(i,1) +!GFDL tem1 = con_rerth * (con_pi+con_pi)*coslat(i)/nlons(i) +!GFDL tem2 = con_rerth * con_pi / latr +!GFDL garea(i) = tem1 * tem2 + tem1 = Grid%dx(i) + tem2 = Grid%dx(i) + garea(i) = Grid%area(i) + dlength(i) = sqrt( tem1*tem1+tem2*tem2 ) + cldf(i) = Model%cgwf(1)*work1(i) + Model%cgwf(2)*work2(i) + wcbmax(i) = Model%cs_parm(1)*work1(i) + Model%cs_parm(2)*work2(i) + enddo +! + if (Model%cplflx) then + do i = 1, im + islmsk_cice(i) = nint(Coupling%slimskin_cpl(i)) + flag_cice(i) = (islmsk_cice(i) == 4) + + ulwsfc_cice(i) = Coupling%ulwsfcin_cpl(i) + dusfc_cice(i) = Coupling%dusfcin_cpl(i) + dvsfc_cice(i) = Coupling%dvsfcin_cpl(i) + dtsfc_cice(i) = Coupling%dtsfcin_cpl(i) + dqsfc_cice(i) = Coupling%dqsfcin_cpl(i) + tisfc_cice(i) = Sfcprop%tisfc(i) + tsea_cice(i) = Sfcprop%tsfc(i) + fice_cice(i) = Sfcprop%fice(i) + hice_cice(i) = Sfcprop%hice(i) + enddo + endif + +! --- ... transfer soil moisture and temperature from global to local variables + smsoil(:,:) = Sfcprop%smc(:,:) + stsoil(:,:) = Sfcprop%stc(:,:) + slsoil(:,:) = Sfcprop%slc(:,:) !! clu: slc -> slsoil + dudt(:,:) = 0. + dvdt(:,:) = 0. + dtdt(:,:) = 0. + dtdtc(:,:) = 0. + dqdt(:,:,:) = 0. + +! --- ... initialize dtdt with heating rate from dcyc2 + +! --- ... adjust mean radiation fluxes and heating rates to fit for +! faster model time steps. +! sw: using cos of zenith angle as scaling factor +! lw: using surface air skin temperature as scaling factor + + if (Model%pre_rad) then + call dcyc2t3_pre_rad & +! --- inputs: + ( Model%solhr, Model%slag, Model%sdec, Model%cdec, Grid%sinlat, & + Grid%coslat, Grid%xlon, Radtend%coszen, Sfcprop%tsfc, & + Statein%tgrs(1,1), Statein%tgrs(1,1), Coupling%sfcdsw, & + Coupling%sfcnsw, Coupling%sfcdlw, Radtend%htrsw, Radtend%htrlw,& + Coupling%nirbmui, Coupling%nirdfui, Coupling%visbmui, & + Coupling%visdfui, Coupling%nirbmdi, Coupling%nirdfdi, & + Coupling%visbmdi, Coupling%visdfdi, ix, im, levs, & +! --- input/output: + dtdt, & +! --- outputs: + adjsfcdsw, adjsfcnsw, adjsfcdlw, adjsfculw, xmu, xcosz, & + adjnirbmu, adjnirdfu, adjvisbmu, adjvisdfu, & + adjnirbmd, adjnirdfd, adjvisbmd, adjvisdfd & + ) + + else + + call dcyc2t3 & +! --- inputs: + ( Model%solhr, Model%slag, Model%sdec, Model%cdec, Grid%sinlat, & + Grid%coslat, Grid%xlon, Radtend%coszen, Sfcprop%tsfc, & + Statein%tgrs(1,1), Radtend%tsflw, Radtend%semis, & + Coupling%sfcdsw, Coupling%sfcnsw, Coupling%sfcdlw, & + Radtend%htrsw, Radtend%swhc, Radtend%htrlw, Radtend%lwhc, & + Coupling%nirbmui, Coupling%nirdfui, Coupling%visbmui, & + Coupling%visdfui, Coupling%nirbmdi, Coupling%nirdfdi, & + Coupling%visbmdi, Coupling%visdfdi, ix, im, levs, & +! --- input/output: + dtdt, dtdtc, & +! --- outputs: + adjsfcdsw, adjsfcnsw, adjsfcdlw, adjsfculw, xmu, xcosz, & + adjnirbmu, adjnirdfu, adjvisbmu, adjvisdfu, & + adjnirbmd, adjnirdfd, adjvisbmd, adjvisdfd & + ) + +! +! save temp change due to radiation - need for sttp stochastic physics +!--------------------------------------------------------------------- + endif +! + if (Model%lsidea) then !idea jw + dtdt(:,:) = 0. + endif + +! --- convert lw fluxes for land/ocean/sea-ice models +! note: for sw: adjsfcdsw and adjsfcnsw are zenith angle adjusted downward/net fluxes. +! for lw: adjsfcdlw is (sfc temp adjusted) downward fluxe with no emiss effect. +! adjsfculw is (sfc temp adjusted) upward fluxe including emiss effect. +! one needs to be aware that that the absorbed downward lw flux (used by land/ocean +! models as downward flux) is not the same as adjsfcdlw but a value reduced by +! the factor of emissivity. however, the net effects are the same when seeing +! it either above the surface interface or below. +! +! - flux above the interface used by atmosphere model: +! down: adjsfcdlw; up: adjsfculw = sfcemis*sigma*T**4 + (1-sfcemis)*adjsfcdlw +! net = up - down = sfcemis * (sigma*T**4 - adjsfcdlw) +! - flux below the interface used by lnd/oc/ice models: +! down: sfcemis*adjsfcdlw; up: sfcemis*sigma*T**4 +! net = up - down = sfcemis * (sigma*T**4 - adjsfcdlw) + +! --- ... define the downward lw flux absorbed by ground + + gabsbdlw(:) = Radtend%semis(:) * adjsfcdlw(:) + + if (Model%lssav) then ! --- ... accumulate/save output variables + +! --- ... sunshine duration time is defined as the length of time (in mdl output +! interval) that solar radiation falling on a plane perpendicular to the +! direction of the sun >= 120 w/m2 + + do i = 1, im + if ( xcosz(i) >= czmin ) then ! zenth angle > 89.994 deg + tem1 = adjsfcdsw(i) / xcosz(i) + if ( tem1 >= 120.0 ) then + Diag%suntim(i) = Diag%suntim(i) + dtf + endif + endif + enddo + +! --- ... sfc lw fluxes used by atmospheric model are saved for output + + if (Model%cplflx) then + do i = 1, im + if (flag_cice(i)) adjsfculw(i) = ulwsfc_cice(i) + enddo + endif + Diag%dlwsfc(:) = Diag%dlwsfc(:) + adjsfcdlw(:)*dtf + Diag%ulwsfc(:) = Diag%ulwsfc(:) + adjsfculw(:)*dtf + Diag%psmean(:) = Diag%psmean(:) + Statein%pgr(:)*dtf ! mean surface pressure + + if (Model%ldiag3d) then + if (Model%lsidea) then + Diag%dt3dt(:,:,1) = Diag%dt3dt(:,:,1) + Radtend%lwhd(:,:,1)*dtf + Diag%dt3dt(:,:,2) = Diag%dt3dt(:,:,2) + Radtend%lwhd(:,:,2)*dtf + Diag%dt3dt(:,:,3) = Diag%dt3dt(:,:,3) + Radtend%lwhd(:,:,3)*dtf + Diag%dt3dt(:,:,4) = Diag%dt3dt(:,:,4) + Radtend%lwhd(:,:,4)*dtf + Diag%dt3dt(:,:,5) = Diag%dt3dt(:,:,5) + Radtend%lwhd(:,:,5)*dtf + Diag%dt3dt(:,:,6) = Diag%dt3dt(:,:,6) + Radtend%lwhd(:,:,6)*dtf + else + do k = 1, levs + Diag%dt3dt(:,k,1) = Diag%dt3dt(:,k,1) + Radtend%htrlw(:,k)*dtf + Diag%dt3dt(:,k,2) = Diag%dt3dt(:,k,2) + Radtend%htrsw(:,k)*dtf*xmu(:) + enddo + endif + endif + endif ! end if_lssav_block + + kcnv(:) = 0 + kinver(:) = levs + invrsn(:) = .false. + tx1(:) = 0.0 + tx2(:) = 10.0 + ctei_r(:) = 10.0 + +! Only used for old shallow convection with mstrat=.true. + + if (((Model%imfshalcnv == 0 .and. Model%shal_cnv) .or. Model%old_monin) & + .and. Model%mstrat) then + ctei_rml(:) = Model%ctei_rm(1)*work1(:) + Model%ctei_rm(2)*work2(:) + do k = 1, levs/2 + do i = 1, im + if (Statein%prsi(i,1)-Statein%prsi(i,k+1) < 0.35*Statein%prsi(i,1) & + .and. (.not. invrsn(i))) then + tem = (Statein%tgrs(i,k+1)-Statein%tgrs(i,k)) / (Statein%prsl(i,k)-Statein%prsl(i,k+1)) + + if (((tem > 0.00010) .and. (tx1(i) < 0.0)) .or. & + ((tem-abs(tx1(i)) > 0.0) .and. (tx2(i) < 0.0))) then + invrsn(i) = .true. + + if (Statein%qgrs(i,k,1) > Statein%qgrs(i,k+1,1)) then + tem1 = Statein%tgrs(i,k+1) + hocp*max(Statein%qgrs(i,k+1,1),qmin) + tem2 = Statein%tgrs(i,k) + hocp*max(Statein%qgrs(i,k,1),qmin) + + tem1 = tem1 / Statein%prslk(i,k+1) - tem2 / Statein%prslk(i,k) + +! --- ... (cp/l)(deltathetae)/(deltatwater) > ctei_rm -> conditon for CTEI + ctei_r(i) = (1.0/hocp)*tem1/(Statein%qgrs(i,k+1,1)-Statein%qgrs(i,k,1) & + + Statein%qgrs(i,k+1,Model%ntcw)-Statein%qgrs(i,k,Model%ntcw)) + else + ctei_r(i) = 10 + endif + + if ( ctei_rml(i) > ctei_r(i) ) then + kinver(i) = k + else + kinver(i) = levs + endif + endif + + tx2(i) = tx1(i) + tx1(i) = tem + endif + enddo + enddo + endif + +! --- ... lu: initialize flag_guess, flag_iter, tsurf + + tsurf(:) = Sfcprop%tsfc(:) + flag_guess(:) = .false. + flag_iter(:) = .true. + drain(:) = 0.0 + ep1d(:) = 0.0 + runof(:) = 0.0 + hflx(:) = 0.0 + evap(:) = 0.0 + evbs(:) = 0.0 + evcw(:) = 0.0 + trans(:) = 0.0 + sbsno(:) = 0.0 + snowc(:) = 0.0 + snohf(:) = 0.0 + Diag%zlvl(:) = Statein%phil(:,1) * onebg + Diag%smcwlt2(:) = 0.0 + Diag%smcref2(:) = 0.0 + +! --- ... lu: iter-loop over (sfc_diff,sfc_drv,sfc_ocean,sfc_sice) + + do iter = 1, 2 + +! --- ... surface exchange coefficients +! +! if (lprnt) write(0,*)' tsea=',tsea(ipr),' tsurf=',tsurf(ipr),iter + + call sfc_diff (im,Statein%pgr, Statein%ugrs, Statein%vgrs, & + Statein%tgrs, Statein%qgrs, Diag%zlvl, & + Sfcprop%snowd, Sfcprop%tsfc, Sfcprop%zorl, cd, & + cdq, rb, Statein%prsl(1,1), work3, islmsk, stress, & + Sfcprop%ffmm, Sfcprop%ffhh, Sfcprop%uustar, & + wind, Tbd%phy_f2d(1,Model%num_p2d), fm10, fh2, & + sigmaf, vegtype, Sfcprop%shdmax, Model%ivegsrc, & + tsurf, flag_iter, Model%redrag) + +! --- ... lu: update flag_guess + + do i = 1, im + if (iter == 1 .and. wind(i) < 2.0) then + flag_guess(i) = .true. + endif + enddo + + if (Model%nstf_name(1) > 0) then + + do i = 1, im + if ( islmsk(i) == 0 ) then + tem = (Sfcprop%oro(i)-Sfcprop%oro_uf(i)) * rlapse + tseal(i) = Sfcprop%tsfc(i) + tem + tsurf(i) = tsurf(i) + tem + endif + enddo + + call sfc_nst (im, Model%lsoil, Statein%pgr, Statein%ugrs, & + Statein%vgrs, Statein%tgrs, Statein%qgrs, & + Sfcprop%tref, cd, cdq, Statein%prsl(1,1), work3, & + islmsk, Grid%xlon, Grid%sinlat, stress, & + Radtend%semis, gabsbdlw, adjsfcnsw, Sfcprop%tprcp, & + dtf, kdt, Model%solhr, xcosz, & + Tbd%phy_f2d(1,Model%num_p2d), flag_iter, & + flag_guess, Model%nstf_name, lprnt, ipr, & +! --- Input/output + tseal, tsurf, Sfcprop%xt, Sfcprop%xs, Sfcprop%xu, & + Sfcprop%xv, Sfcprop%xz, Sfcprop%zm, Sfcprop%xtts, & + Sfcprop%xzts, Sfcprop%dt_cool, Sfcprop%z_c, & + Sfcprop%c_0, Sfcprop%c_d, Sfcprop%w_0, Sfcprop%w_d,& + Sfcprop%d_conv, Sfcprop%ifd, Sfcprop%qrain, & +! --- outputs: + qss, gflx, Diag%cmm, Diag%chh, evap, hflx, ep1d) + +! if (lprnt) print *,' tseaz2=',tseal(ipr),' tref=',tref(ipr), +! & ' dt_cool=',dt_cool(ipr),' dt_warm=',2.0*xt(ipr)/xz(ipr), +! & ' kdt=',kdt + + do i = 1, im + if ( islmsk(i) == 0 ) then + tsurf(i) = tsurf(i) - (Sfcprop%oro(i)-Sfcprop%oro_uf(i)) * rlapse + endif + enddo + +! --- ... run nsst model ... --- + + if (Model%nstf_name(1) > 1) then + zsea1 = 0.001*real(Model%nstf_name(4)) + zsea2 = 0.001*real(Model%nstf_name(5)) + call get_dtzm_2d (Sfcprop%xt, Sfcprop%xz, Sfcprop%dt_cool, & + Sfcprop%z_c, Sfcprop%slmsk, zsea1, zsea2, & + im, 1, dtzm) + do i = 1, im + if ( islmsk(i) == 0 ) then + Sfcprop%tsfc(i) = max(271.2,Sfcprop%tref(i) + dtzm(i)) - & + (Sfcprop%oro(i)-Sfcprop%oro_uf(i))*rlapse + endif + enddo + endif + +! if (lprnt) print *,' tseaz2=',tsea(ipr),' tref=',tref(ipr), & +! & ' dt_cool=',dt_cool(ipr),' dt_warm=',dt_warm(ipr),' kdt=',kdt + + else + +! --- ... surface energy balance over ocean + + call sfc_ocean & +! --- inputs: + (im, Statein%pgr, Statein%ugrs, Statein%vgrs, Statein%tgrs, & + Statein%qgrs, Sfcprop%tsfc, cd, cdq, Statein%prsl(1,1), & + work3, islmsk, Tbd%phy_f2d(1,Model%num_p2d), flag_iter, & +! --- outputs: + qss, Diag%cmm, Diag%chh, gflx, evap, hflx, ep1d) + + endif ! if ( nstf_name(1) > 0 ) then + +! if (lprnt) write(0,*)' sfalb=',sfalb(ipr),' ipr=',ipr & +! &, ' weasd=',weasd(ipr),' snwdph=',snwdph(ipr) & +! &, ' tprcp=',tprcp(ipr),' kdt=',kdt,' iter=',iter & +! &,' tseabefland=',tsea(ipr) + +! --- ... surface energy balance over land +! + if (Model%lsm == 1) then ! noah lsm call + +! if (lprnt) write(0,*)' tsead=',tsea(ipr),' tsurf=',tsurf(ipr),iter +! &,' pgr=',pgr(ipr),' sfcemis=',sfcemis(ipr) + + call sfc_drv & +! --- inputs: + (im, Model%lsoil, Statein%pgr, Statein%ugrs, Statein%vgrs, & + Statein%tgrs, Statein%qgrs, soiltyp, vegtype, sigmaf, & + Radtend%semis, gabsbdlw, adjsfcdsw, adjsfcnsw, dtf, & + Sfcprop%tg3, cd, cdq, Statein%prsl(1,1), work3, DIag%zlvl, & + islmsk, Tbd%phy_f2d(1,Model%num_p2d), slopetyp, & + Sfcprop%shdmin, Sfcprop%shdmax, Sfcprop%snoalb, & + Radtend%sfalb, flag_iter, flag_guess, Model%isot, & + Model%ivegsrc, & +! --- in/outs: + Sfcprop%weasd, Sfcprop%snowd, Sfcprop%tsfc, Sfcprop%tprcp, & + Sfcprop%srflag, smsoil, stsoil, slsoil, Sfcprop%canopy, & + trans, tsurf, Sfcprop%zorl, & +! --- outputs: + Sfcprop%sncovr, qss, gflx, drain, evap, hflx, ep1d, runof, & + Diag%cmm, Diag%chh, evbs, evcw, sbsno, snowc, Diag%soilm, & + snohf, Diag%smcwlt2, Diag%smcref2, Diag%wet1) + +! if (lprnt) write(0,*)' tseae=',tsea(ipr),' tsurf=',tsurf(ipr),iter +! &,' phy_f2d=',phy_f2d(ipr,num_p2d) + + endif + +! if (lprnt) write(0,*)' tseabeficemodel =',tsea(ipr),' me=',me & +! &, ' kdt=',kdt + +! --- ... surface energy balance over seaice + + if (Model%cplflx) then + do i = 1, im + if (flag_cice(i)) then + islmsk (i) = islmsk_cice(i) + endif + enddo + endif + + call sfc_sice & +! --- inputs: + (im, Model%lsoil, Statein%pgr, Statein%ugrs, Statein%vgrs, & + Statein%tgrs, Statein%qgrs, dtf, Radtend%semis, gabsbdlw, & + adjsfcnsw, adjsfcdsw, Sfcprop%srflag, cd, cdq, & + Statein%prsl(1,1), work3, islmsk, & + Tbd%phy_f2d(1,Model%num_p2d), flag_iter, Model%mom4ice, & + Model%lsm, lprnt, ipr, & +! --- input/outputs: + zice, cice, tice, Sfcprop%weasd, Sfcprop%tsfc, & + Sfcprop%tprcp, stsoil, ep1d, & +! --- outputs: + Sfcprop%snowd, qss, snowmt, gflx, Diag%cmm, Diag%chh, evap, & + hflx) + + if (Model%cplflx) then + do i = 1, im + if (flag_cice(i)) then + islmsk(i) = nint(Sfcprop%slmsk(i)) + endif + enddo + + call sfc_cice & +! --- inputs: + (im, Statein%ugrs, Statein%vgrs, Statein%tgrs, Statein%qgrs, & + cd, cdq, Statein%prsl(1,1), work3, islmsk_cice, & + Tbd%phy_f2d(1,Model%num_p2d),flag_iter, dqsfc_cice, & + dtsfc_cice, & +! --- outputs: + qss, Diag%cmm, Diag%chh, evap, hflx) + endif + +! --- ... lu: update flag_iter and flag_guess + + do i = 1, im + flag_iter(i) = .false. + flag_guess(i) = .false. + + if (iter == 1 .and. wind(i) < 2.0) then + if ((islmsk(i) == 1) .or. ((islmsk(i) == 0) .and. & + (Model%nstf_name(1) > 0))) then + flag_iter(i) = .true. + endif + endif + +! if(islmsk(i) == 1 .and. iter == 1) then +! if (wind(i) < 2.0) flag_iter(i) = .true. +! elseif (islmsk(i) == 0 .and. iter == 1 & +! & .and. nstf_name(1) > 0) then +! if (wind(i) < 2.0) flag_iter(i) = .true. +! endif + enddo + + enddo ! end iter_loop + + Diag%epi(:) = ep1d(:) + Diag%dlwsfci(:) = adjsfcdlw(:) + Diag%ulwsfci(:) = adjsfculw(:) + Diag%uswsfci(:) = adjsfcdsw(:) - adjsfcnsw(:) + Diag%dswsfci(:) = adjsfcdsw(:) + Diag%gfluxi(:) = gflx(:) + Diag%t1(:) = Statein%tgrs(:,1) + Diag%q1(:) = Statein%qgrs(:,1,1) + Diag%u1(:) = Statein%ugrs(:,1) + Diag%v1(:) = Statein%vgrs(:,1) + +! --- ... update near surface fields + + call sfc_diag (im, Statein%pgr, Statein%ugrs, Statein%vgrs, & + Statein%tgrs, Statein%qgrs, Sfcprop%tsfc, qss, & + Sfcprop%f10m, Diag%u10m, Diag%v10m, & + Sfcprop%t2m, Sfcprop%q2m, work3, evap, & + Sfcprop%ffmm, Sfcprop%ffhh, fm10, fh2) + + Tbd%phy_f2d(:,Model%num_p2d) = 0.0 + + if (Model%cplflx) then + Coupling%dlwsfci_cpl (:) = adjsfcdlw(:) + Coupling%dswsfci_cpl (:) = adjsfcdsw(:) + Coupling%dlwsfc_cpl (:) = Coupling%dlwsfc_cpl(:) + adjsfcdlw(:)*dtf + Coupling%dswsfc_cpl (:) = Coupling%dswsfc_cpl(:) + adjsfcdsw(:)*dtf + Coupling%dnirbmi_cpl (:) = adjnirbmd(:) + Coupling%dnirdfi_cpl (:) = adjnirdfd(:) + Coupling%dvisbmi_cpl (:) = adjvisbmd(:) + Coupling%dvisdfi_cpl (:) = adjvisdfd(:) + Coupling%dnirbm_cpl (:) = Coupling%dnirbm_cpl(:) + adjnirbmd(:)*dtf + Coupling%dnirdf_cpl (:) = Coupling%dnirdf_cpl(:) + adjnirdfd(:)*dtf + Coupling%dvisbm_cpl (:) = Coupling%dvisbm_cpl(:) + adjvisbmd(:)*dtf + Coupling%dvisdf_cpl (:) = Coupling%dvisdf_cpl(:) + adjvisdfd(:)*dtf + Coupling%nlwsfci_cpl (:) = adjsfcdlw(:) - adjsfculw(:) + Coupling%nlwsfc_cpl (:) = Coupling%nlwsfc_cpl(:) + Coupling%nlwsfci_cpl(:)*dtf + Coupling%t2mi_cpl (:) = Sfcprop%t2m(:) + Coupling%q2mi_cpl (:) = Sfcprop%q2m(:) + Coupling%u10mi_cpl (:) = Diag%u10m(:) + Coupling%v10mi_cpl (:) = Diag%v10m(:) + Coupling%tsfci_cpl (:) = Sfcprop%tsfc(:) + Coupling%psurfi_cpl (:) = Statein%pgr(:) + +! --- estimate mean albedo for ocean point without ice cover and apply +! them to net SW heat fluxes + + do i = 1, im + if (islmsk(i) /= 1) then ! not a land point +! --- compute open water albedo + xcosz_loc = max( 0.0, min( 1.0, xcosz(i) )) + ocalnirdf_cpl(i) = 0.06 + ocalnirbm_cpl(i) = max(albdf, 0.026/(xcosz_loc**1.7+0.065) & + & + 0.15 * (xcosz_loc-0.1) * (xcosz_loc-0.5) & + & * (xcosz_loc-1.0)) + ocalvisdf_cpl(i) = 0.06 + ocalvisbm_cpl(i) = ocalnirbm_cpl(i) + + Coupling%nnirbmi_cpl(i) = adjnirbmd(i)-adjnirbmd(i)*ocalnirbm_cpl(i) + Coupling%nnirdfi_cpl(i) = adjnirdfd(i)-adjnirdfd(i)*ocalnirdf_cpl(i) + Coupling%nvisbmi_cpl(i) = adjvisbmd(i)-adjvisbmd(i)*ocalvisbm_cpl(i) + Coupling%nvisdfi_cpl(i) = adjvisdfd(i)-adjvisdfd(i)*ocalvisdf_cpl(i) + else + Coupling%nnirbmi_cpl(i) = adjnirbmd(i) - adjnirbmu(i) + Coupling%nnirdfi_cpl(i) = adjnirdfd(i) - adjnirdfu(i) + Coupling%nvisbmi_cpl(i) = adjvisbmd(i) - adjvisbmu(i) + Coupling%nvisdfi_cpl(i) = adjvisdfd(i) - adjvisdfu(i) + endif + Coupling%nswsfci_cpl(i) = Coupling%nnirbmi_cpl(i) + Coupling%nnirdfi_cpl(i) + & + Coupling%nvisbmi_cpl(i) + Coupling%nvisdfi_cpl(i) + Coupling%nswsfc_cpl(i) = Coupling%nswsfc_cpl(i) + Coupling%nswsfci_cpl(i)*dtf + Coupling%nnirbm_cpl(i) = Coupling%nnirbm_cpl(i) + Coupling%nnirbmi_cpl(i)*dtf + Coupling%nnirdf_cpl(i) = Coupling%nnirdf_cpl(i) + Coupling%nnirdfi_cpl(i)*dtf + Coupling%nvisbm_cpl(i) = Coupling%nvisbm_cpl(i) + Coupling%nvisbmi_cpl(i)*dtf + Coupling%nvisdf_cpl(i) = Coupling%nvisdf_cpl(i) + Coupling%nvisdfi_cpl(i)*dtf + enddo + endif + + if (Model%lssav) then + Diag%gflux(:) = Diag%gflux(:) + gflx(:) * dtf + Diag%evbsa(:) = Diag%evbsa(:) + evbs(:) * dtf + Diag%evcwa(:) = Diag%evcwa(:) + evcw(:) * dtf + Diag%transa(:) = Diag%transa(:) + trans(:) * dtf + Diag%sbsnoa(:) = Diag%sbsnoa(:) + sbsno(:) * dtf + Diag%snowca(:) = Diag%snowca(:) + snowc(:) * dtf + Diag%snohfa(:) = Diag%snohfa(:) + snohf(:) * dtf + Diag%ep(:) = Diag%ep(:) + ep1d(:) * dtf + + Diag%tmpmax(:) = max(Diag%tmpmax(:),Sfcprop%t2m(:)) + Diag%tmpmin(:) = min(Diag%tmpmin(:),Sfcprop%t2m(:)) + + Diag%spfhmax(:) = max(Diag%spfhmax(:),Sfcprop%q2m(:)) + Diag%spfhmin(:) = min(Diag%spfhmin(:),Sfcprop%q2m(:)) + endif + +!!!!!!!!!!!!!!!!!Commented by Moorthi on July 18, 2012 !!!!!!!!!!!!!!!!!!! +! do i = 1, im +! --- ... compute coefficient of evaporation in evapc +! +! if (evapc(i) > 1.0e0) evapc(i) = 1.0e0 +! --- ... over snow cover or ice or sea, coef of evap =1.0e0 +! if (weasd(i) > 0.0 .or. slmsk(i) /= 1.0) evapc(i) = 1.0e0 +! enddo +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +! --- ... Boundary Layer and Free atmospheic turbulence parameterization + +! if (lprnt) write(0,*)' tsea3=',tsea(ipr),' slmsk=',slmsk(ipr) & +! &, ' kdt=',kdt,' evap=',evap(ipr) +! if (lprnt) write(0,*)' dtdtb=',(dtdt(ipr,k),k=1,15) + +! do i = 1, im +! if (islmsk(i) == 0) then +! oro_land(i) = 0.0 +! else +! oro_land(i) = oro(i) +! endif +! enddo + +! write(0,*)' before monin clstp=',clstp,' kdt=',kdt,' lat=',lat + + if (Model%do_shoc) then + call moninshoc(ix, im, levs, ntrac, Model%ntcw, dvdt, dudt, dtdt, dqdt, & + Statein%ugrs, Statein%vgrs, Statein%tgrs, Statein%qgrs, & + Tbd%phy_f3d(1,1,Model%ntot3d-1), prnum, Model%ntke, & + Statein%prsik(1,1), rb, Sfcprop%zorl, Diag%u10m, & + Diag%v10m, Sfcprop%ffmm, Sfcprop%ffhh, Sfcprop%tsfc, hflx,& + evap, stress, wind, kpbl, Statein%prsi, del, Statein%prsl,& + Statein%prslk, Statein%phii, Statein%phil, dtp, dusfc1, & + dvsfc1, dtsfc1, dqsfc1, dkt, Diag%hpbl, kinver, & + Model%xkzm_m, Model%xkzm_h, Model%xkzm_s, lprnt, ipr, me) + else + if (Model%hybedmf) then + call moninedmf(ix, im, levs, nvdiff, Model%ntcw, dvdt, dudt, dtdt, dqdt,& + Statein%ugrs, Statein%vgrs, Statein%tgrs, Statein%qgrs, & + Radtend%htrsw, Radtend%htrlw, xmu, Statein%prsik(1,1), & + rb, Sfcprop%zorl, Diag%u10m, Diag%v10m, Sfcprop%ffmm, & + Sfcprop%ffhh, Sfcprop%tsfc, qss, hflx, evap, stress, & + wind, kpbl, Statein%prsi, del, Statein%prsl, & + Statein%prslk, Statein%phii, Statein%phil, dtp, & + Model%dspheat, dusfc1, dvsfc1, dtsfc1, dqsfc1, Diag%hpbl,& + gamt, gamq, dkt, kinver, Model%xkzm_m, Model%xkzm_h, & + Model%xkzm_s, lprnt, ipr) +! if (lprnt) write(0,*)' dtdtm=',(dtdt(ipr,k),k=1,15) +! if (lprnt) write(0,*)' dqdtm=',(dqdt(ipr,k,1),k=1,15) + elseif (.not. Model%old_monin) then + call moninq(ix, im, levs, nvdiff, Model%ntcw, dvdt, dudt, dtdt, dqdt, & + Statein%ugrs, Statein%vgrs, Statein%tgrs, Statein%qgrs, & + Radtend%htrsw, Radtend%htrlw, xmu, Statein%prsik(1,1), rb,& + Sfcprop%ffmm, Sfcprop%ffhh, Sfcprop%tsfc, qss, hflx, evap,& + stress, wind, kpbl, Statein%prsi, del, Statein%prsl, & + Statein%prslk, Statein%phii, Statein%phil, dtp, & + Model%dspheat, dusfc1, dvsfc1, dtsfc1, dqsfc1, Diag%hpbl, & + gamt, gamq, dkt, kinver, Model%xkzm_m, Model%xkzm_h, & + Model%xkzm_s, lprnt, ipr) + else + if (Model%mstrat) then + call moninp1(ix, im, levs, nvdiff, dvdt, dudt, dtdt, dqdt, & + Statein%ugrs, Statein%vgrs, Statein%tgrs, Statein%qgrs,& + Statein%prsik(1,1), rb, Sfcprop%ffmm, Sfcprop%ffhh, & + Sfcprop%tsfc, qss, hflx, evap, stress, wind, kpbl, & + Statein%prsi, del, Statein%prsl, Statein%prslk, & + Statein%phii, Statein%phil, dtp, dusfc1, dvsfc1, & + dtsfc1, dqsfc1, Diag%hpbl, gamt, gamq, dkt, kinver, & + Model%xkzm_m, Model%xkzm_h) + else + call moninp(ix, im, levs, nvdiff, dvdt, dudt, dtdt, dqdt, & + Statein%ugrs, Statein%vgrs, Statein%tgrs, Statein%qgrs, & + Statein%prsik(1,1), rb, Sfcprop%ffmm, Sfcprop%ffhh, & + Sfcprop%tsfc, qss, hflx, evap, stress, wind, kpbl, & + Statein%prsi, del, Statein%prsl, Statein%phii, & + Statein%phil, dtp, dusfc1, dvsfc1, dtsfc1, dqsfc1, & + Diag%hpbl, gamt, gamq, dkt, Model%xkzm_m, Model%xkzm_h) + endif + + endif ! end if_hybedmf + endif ! end if_do_shoc + + if (Model%cplflx) then + do i = 1, im + if (flag_cice(i)) then + cice(i) = fice_cice(i) + Sfcprop%tsfc(i) = tsea_cice(i) + dusfc1(i) = dusfc_cice(i) + dvsfc1(i) = dvsfc_cice(i) + dqsfc1(i) = dqsfc_cice(i) + dtsfc1(i) = dtsfc_cice(i) + endif + enddo + endif + +! if (lprnt) then +! write(0,*) ' dusfc1=',dusfc1(ipr),' kdt=',kdt,' lat=',lat +! write(0,*)' dtsfc1=',dtsfc1(ipr) +! write(0,*)' dqsfc1=',dqsfc1(ipr) +! write(0,*)' dtdtc=',(dtdt(ipr,k),k=1,15) +! write(0,*)' dqdtc=',(dqdt(ipr,k,1),k=1,15) +! print *,' dudtm=',dudt(ipr,:) +! endif + +! --- ... coupling insertion + + if (Model%cplflx) then + Coupling%dusfc_cpl (:) = Coupling%dusfc_cpl(:) + dusfc1(:)*dtf + Coupling%dvsfc_cpl (:) = Coupling%dvsfc_cpl(:) + dvsfc1(:)*dtf + Coupling%dtsfc_cpl (:) = Coupling%dtsfc_cpl(:) + dtsfc1(:)*dtf + Coupling%dqsfc_cpl (:) = Coupling%dqsfc_cpl(:) + dqsfc1(:)*dtf + Coupling%dusfci_cpl(:) = dusfc1(:) + Coupling%dvsfci_cpl(:) = dvsfc1(:) + Coupling%dtsfci_cpl(:) = dtsfc1(:) + Coupling%dqsfci_cpl(:) = dqsfc1(:) + endif +!-------------------------------------------------------lssav if loop ---------- + if (Model%lssav) then + Diag%dusfc (:) = Diag%dusfc(:) + dusfc1(:)*dtf + Diag%dvsfc (:) = Diag%dvsfc(:) + dvsfc1(:)*dtf + Diag%dtsfc (:) = Diag%dtsfc(:) + dtsfc1(:)*dtf + Diag%dqsfc (:) = Diag%dqsfc(:) + dqsfc1(:)*dtf + Diag%dusfci(:) = dusfc1(:) + Diag%dvsfci(:) = dvsfc1(:) + Diag%dtsfci(:) = dtsfc1(:) + Diag%dqsfci(:) = dqsfc1(:) +! if (lprnt) then +! write(0,*)' dusfc=',dusfc(ipr),' dusfc1=',dusfc1(ipr),' dtf=', +! & dtf,' kdt=',kdt,' lat=',lat +! endif + + if (Model%ldiag3d) then + if (Model%lsidea) then + Diag%dt3dt(:,:,3) = Diag%dt3dt(:,:,3) + dtdt(:,:)*dtf + else + do k = 1, levs + do i = 1, im + tem = dtdt(i,k) - (Radtend%htrlw(i,k)+Radtend%htrsw(i,k)*xmu(i)) + Diag%dt3dt(i,k,3) = Diag%dt3dt(i,k,3) + tem*dtf + enddo + enddo + endif + Diag%du3dt(:,:,1) = Diag%du3dt(:,:,1) + dudt(:,:) * dtf + Diag%du3dt(:,:,2) = Diag%du3dt(:,:,2) - dudt(:,:) * dtf + Diag%dv3dt(:,:,1) = Diag%dv3dt(:,:,1) + dvdt(:,:) * dtf + Diag%dv3dt(:,:,2) = Diag%dv3dt(:,:,2) - dvdt(:,:) * dtf +! update dqdt_v to include moisture tendency due to vertical diffusion +! if (lgocart) then +! do k = 1, levs +! do i = 1, im +! dqdt_v(i,k) = dqdt(i,k,1) * dtf +! enddo +! enddo +! endif + do k = 1, levs + do i = 1, im + tem = dqdt(i,k,1) * dtf + Diag%dq3dt(i,k,1) = Diag%dq3dt(i,k,1) + tem + enddo + enddo + if (Model%ntoz > 0) then + Diag%dq3dt(:,:,5) = Diag%dq3dt(:,:,5) + dqdt(i,k,Model%ntoz) * dtf + endif + endif + + endif ! end if_lssav +!-------------------------------------------------------lssav if loop ---------- +! +! Orographic gravity wave drag parameterization +! --------------------------------------------- + + if (Model%nmtvr == 14) then ! current operational - as of 2014 + oc(:) = Sfcprop%hprime(:,2) + oa4(:,1) = Sfcprop%hprime(:,3) + oa4(:,2) = Sfcprop%hprime(:,4) + oa4(:,3) = Sfcprop%hprime(:,5) + oa4(:,4) = Sfcprop%hprime(:,6) + clx(:,1) = Sfcprop%hprime(:,7) + clx(:,2) = Sfcprop%hprime(:,8) + clx(:,3) = Sfcprop%hprime(:,9) + clx(:,4) = Sfcprop%hprime(:,10) + theta(:) = Sfcprop%hprime(:,11) + gamma(:) = Sfcprop%hprime(:,12) + sigma(:) = Sfcprop%hprime(:,13) + elvmax(:) = Sfcprop%hprime(:,14) + elseif (Model%nmtvr == 10) then + oc(:) = Sfcprop%hprime(:,2) + oa4(:,1) = Sfcprop%hprime(:,3) + oa4(:,2) = Sfcprop%hprime(:,4) + oa4(:,3) = Sfcprop%hprime(:,5) + oa4(:,4) = Sfcprop%hprime(:,6) + clx(:,1) = Sfcprop%hprime(:,7) + clx(:,2) = Sfcprop%hprime(:,8) + clx(:,3) = Sfcprop%hprime(:,9) + clx(:,4) = Sfcprop%hprime(:,10) + elseif (Model%nmtvr == 6) then + oc(:) = Sfcprop%hprime(:,2) + oa4(:,1) = Sfcprop%hprime(:,3) + oa4(:,2) = Sfcprop%hprime(:,4) + oa4(:,3) = Sfcprop%hprime(:,5) + oa4(:,4) = Sfcprop%hprime(:,6) + clx(:,1) = 0.0 + clx(:,2) = 0.0 + clx(:,3) = 0.0 + clx(:,4) = 0.0 + else + oc = 0 ; oa4 = 0 ; clx = 0 ; theta = 0 ; gamma = 0 ; sigma = 0 + elvmax = 0 + + endif ! end if_nmtvr + +! write(0,*)' before gwd clstp=',clstp,' kdt=',kdt,' lat=',lat + call gwdps(im, ix, im, levs, dvdt, dudt, dtdt, & + Statein%ugrs, Statein%vgrs, Statein%tgrs, & + Statein%qgrs, kpbl, Statein%prsi, del, & + Statein%prsl, Statein%prslk, Statein%phii, & + Statein%phil, dtp, kdt, & + Sfcprop%hprime(1,1), oc, oa4, clx, theta, & + sigma, gamma, elvmax, dusfcg, dvsfcg, & + con_g, con_cp, con_rd, con_rv, Model%lonr, & + Model%nmtvr, Model%cdmbgwd, me, lprnt,ipr) + +! if (lprnt) print *,' dudtg=',dudt(ipr,:) + + if (Model%lssav) then + Diag%dugwd(:) = Diag%dugwd(:) + dusfcg(:)*dtf + Diag%dvgwd(:) = Diag%dvgwd(:) + dvsfcg(:)*dtf + +! if (lprnt) print *,' dugwd=',dugwd(ipr),' dusfcg=',dusfcg(ipr) +! if (lprnt) print *,' dvgwd=',dvgwd(ipr),' dvsfcg=',dvsfcg(ipr) + + if (Model%ldiag3d) then + Diag%du3dt(:,:,2) = Diag%du3dt(:,:,2) + dudt(:,:) * dtf + Diag%dv3dt(:,:,2) = Diag%dv3dt(:,:,2) + dvdt(:,:) * dtf + Diag%dt3dt(:,:,2) = Diag%dt3dt(:,:,2) + dtdt(:,:) * dtf + endif + endif + +! Rayleigh damping near the model top + if( .not. Model%lsidea .and. Model%ral_ts > 0.0) then + call rayleigh_damp(im, ix, im, levs, dvdt, dudt, dtdt, & + Statein%ugrs, Statein%vgrs, dtp, con_cp, & + Model%levr, Statein%pgr, Statein%prsl, & + Model%prslrd0, Model%ral_ts) + endif + +! if (lprnt) then +! write(0,*)' tgrs1=',(tgrs(ipr,ik),k=1,10) +! write(0,*)' dtdt=',(dtdt(ipr,ik),k=1,10) +! endif + + Stateout%gt0(:,:) = Statein%tgrs(:,:) + dtdt(:,:) * dtp + Stateout%gu0(:,:) = Statein%ugrs(:,:) + dudt(:,:) * dtp + Stateout%gv0(:,:) = Statein%vgrs(:,:) + dvdt(:,:) * dtp + Stateout%gq0(:,:,:) = Statein%qgrs(:,:,:) + dqdt(:,:,:) * dtp + +! if (lprnt) then +! write(7000,*)' ugrs=',ugrs(ipr,:) +! &,' lat=',lat,' kdt=',kdt,' me=',me +! write(7000,*)' dudt*dtp=',dudt(ipr,:)*dtp +! write(7000,*)' vgrs=',vgrs(ipr,:) +! write(7000,*)' dvdt*dtp ',dvdt(ipr,:)*dtp +! endif +! if(lprnt) write(1000+me,*)' gq0w=',gq0(ipr,:,ntcw) +! if(lprnt) write(0,*)' gq0i=',gq0(ipr,:,ntiw) + + if (Model%lsidea) then ! idea convective adjustment + call ideaca_up(Statein%prsi,Stateout%gt0,ix,im,levs+1) + endif + +! --- ... ozone physics + + if ((Model%ntoz > 0) .and. (ntrac >= Model%ntoz)) then + if (oz_coeff > 4) then + call ozphys_2015 (ix, im, levs, levozp, dtp, & + Stateout%gq0(1,1,Model%ntoz), & + Stateout%gq0(1,1,Model%ntoz), & + Stateout%gt0, oz_pres, Statein%prsl, & + Tbd%ozpl, oz_coeff, del, Model%ldiag3d, & + dq3dt_loc(1,1,6), me) + if (Model%ldiag3d) then + Diag%dq3dt(:,:,6) = dq3dt_loc(:,:,6) + Diag%dq3dt(:,:,7) = dq3dt_loc(:,:,7) + Diag%dq3dt(:,:,8) = dq3dt_loc(:,:,8) + Diag%dq3dt(:,:,9) = dq3dt_loc(:,:,9) + endif + else + call ozphys (ix, im, levs, levozp, dtp, & + Stateout%gq0(1,1,Model%ntoz), & + Stateout%gq0(1,1,Model%ntoz), & + Stateout%gt0, oz_pres, Statein%prsl, & + Tbd%ozpl, oz_coeff, del, Model%ldiag3d, & + dq3dt_loc(1,1,6), me) + if (Model%ldiag3d) then + Diag%dq3dt(:,:,6) = dq3dt_loc(:,:,6) + Diag%dq3dt(:,:,7) = dq3dt_loc(:,:,7) + Diag%dq3dt(:,:,8) = dq3dt_loc(:,:,8) + Diag%dq3dt(:,:,9) = dq3dt_loc(:,:,9) + endif + endif + endif + + if (Model%h2o_phys) then + call h2ophys (ix, im, levs, levh2o, dtp, Stateout%gq0(1,1,1), & + Stateout%gq0(1,1,1), h2o_pres, Statein%prsl, & + Tbd%h2opl, h2o_coeff, Model%ldiag3d, & + dq3dt_loc(1,1,1), me) + endif + +! --- ... to side-step the ozone physics + +! if (ntrac >= 2) then +! do k = 1, levs +! gq0(k,ntoz) = qgrs(k,ntoz) +! enddo +! endif + +! if (lprnt) then +! write(0,*) ' levs=',levs,' jcap=',jcap,' dtp',dtp & +! &, ' slmsk=',slmsk(ilon,ilat),' kdt=',kdt +! print *,' rann=',rann,' ncld=',ncld,' iq=',iq,' lat=',lat +! print *,' pgr=',pgr +! print *,' del=',del(ipr,:) +! print *,' prsl=',prsl(ipr,:) +! print *,' prslk=',prslk(ipr,:) +! print *,' rann=',rann(ipr,1) +! write(0,*)' gt0=',gt0(ipr,:) & +! &, ' kdt=',kdt,' xlon=',xlon(ipr),' xlat=',xlat(ipr) +! print *,' dtdt=',dtdt(ipr,:) +! print *,' gu0=',gu0(ipr,:) +! print *,' gv0=',gv0(ipr,:) +! write(0,*) ' gt0=',(gt0(ipr,k),k=1,levs),' kdt=',kdt +! write(0,*)' gq0=',(gq0(ipr,k,1),k=1,levs),' lat=',lat +! write(0,*)' gq0i2=',(gq0(ipr,k,ntiw),k=1,levs),' lat=',lat +! write(0,*)' gq1=',(gq0(ipr,k,ntcw),k=1,levs) +! print *,' vvel=',vvel +! endif +! if (lprnt) write(7000,*)' bef convection gu0=',gu0(ipr,:) +! &,' lat=',lat,' kdt=',kdt,' me=',me +! if (lprnt) write(7000,*)' bef convection gv0=',gv0(ipr,:) + + if (Model%ldiag3d) then + dtdt(:,:) = Stateout%gt0(:,:) + dudt(:,:) = Stateout%gu0(:,:) + dvdt(:,:) = Stateout%gv0(:,:) + elseif (Model%cnvgwd) then + dtdt(:,:) = Stateout%gt0(:,:) + endif ! end if_ldiag3d/cnvgwd + + if (Model%ldiag3d .or. Model%lgocart) then + dqdt(:,:,1) = Stateout%gq0(:,:,1) + endif ! end if_ldiag3d/lgocart + +#ifdef GFS_HYDRO + call get_phi(im, ix, levs, ntrac, Stateout%gt0, Stateout%gq0, & + Model%thermodyn_id, Model%sfcpress_id, & + Model%gen_coord_hybrid Statein%prsi, Statein%prsik, & + Statein%prsl, Statein%prslk, Statein%phii, Statein%phil) +#else +!GFDL Adjust the height hydrostatically in a way consistent with FV3 discretization + call get_phi_fv3 (ix, levs, ntrac, Stateout%gt0, Stateout%gq0, & + del_gz, Statein%phii, Statein%phil) +#endif + +! if (lprnt) then +! print *,' phii2=',phii(ipr,k=1,levs) +! print *,' phil2=',phil(ipr,:) +! endif + + clw(:,:,1) = 0.0 + clw(:,:,2) = -999.9 + if ((Model%imfdeepcnv >= 0) .or. (Model%imfshalcnv > 0)) then + cnvc(:,:) = 0.0 + cnvw(:,:) = 0.0 + endif + +! write(0,*)' before cnv clstp=',clstp,' kdt=',kdt,' lat=',lat + +! --- ... for convective tracer transport (while using ras) + + if (Model%ras .or. Model%cscnv) then + if (tottracer > 0) then + if (Model%ntoz > 0) then + clw(:,:,3) = Stateout%gq0(:,:,Model%ntoz) + if (tracers > 0) then + do n=1,tracers + clw(:,:,3+n) = Stateout%gq0(:,:,n+trc_shft) + enddo + endif + else + do n=1,tracers + clw(:,:,2+n) = Stateout%gq0(:,:,n+trc_shft) + enddo + endif + endif + endif ! end if_ras or cfscnv + + ktop(:) = 1 + kbot(:) = levs + +! --- ... calling condensation/precipitation processes +! -------------------------------------------- + + if (Model%ntcw > 0) then + do k=1,levs + do i=1,im + tem = rhbbot - (rhbbot-rhbtop) * (1.0-Statein%prslk(i,k)) + tem = rhc_max * work1(i) + tem * work2(i) + rhc(i,k) = max(0.0, min(1.0,tem)) + enddo + enddo + if (Model%ncld == 2) then + clw(:,:,1) = Stateout%gq0(:,:,Model%ntiw) ! ice + clw(:,:,2) = Stateout%gq0(:,:,Model%ntcw) ! water + else + if (Model%num_p3d == 4) then ! zhao-carr microphysics + psautco_l(:) = Model%psautco(1)*work1(:) + Model%psautco(2)*work2(:) + prautco_l(:) = Model%prautco(1)*work1(:) + Model%prautco(2)*work2(:) + clw(:,:,1) = Stateout%gq0(:,:,Model%ntcw) + endif ! end if_num_p3d + endif ! end if (ncld == 2) + else ! if_ntcw + psautco_l(:) = Model%psautco(1)*work1(:) + Model%psautco(2)*work2(:) + prautco_l(:) = Model%prautco(1)*work1(:) + Model%prautco(2)*work2(:) + rhc(:,:) = 1.0 + endif ! end if_ntcw +! +! Call SHOC if do_shoc is true and shocaftcnv is false +! + if (Model%do_shoc .and. .not. Model%shocaftcnv) then + if (Model%ncld == 2) then + skip_macro = Model%do_shoc + clw(:,:,1) = Stateout%gq0(:,:,Model%ntiw) ! ice + clw(:,:,2) = Stateout%gq0(:,:,Model%ntcw) ! water + ncpl(:,:) = Stateout%gq0(:,:,Model%ntlnc) + ncpi(:,:) = Stateout%gq0(:,:,Model%ntinc) + elseif (Model%num_p3d == 4) then + do k=1,levs + do i=1,im + qpl(i,k) = 0.0 + qpi(i,k) = 0.0 + if (abs(Stateout%gq0(i,k,Model%ntcw)) < epsq) then + Stateout%gq0(i,k,Model%ntcw) = 0.0 + endif + tem = Stateout%gq0(i,k,Model%ntcw) & + & * max(0.0, MIN(1.0, (TCR-Stateout%gt0(i,k))*TCRF)) + clw(i,k,1) = tem ! ice + clw(i,k,2) = Stateout%gq0(i,k,Model%ntcw) - tem ! water + enddo + enddo + endif + +! dtshoc = 60.0 +! dtshoc = 120.0 +! dtshoc = dtp +! nshocm = (dtp/dtshoc) + 0.001 +! dtshoc = dtp / nshocm +! do nshoc=1,nshocm +! if (lprnt) write(1000+me,*)' before shoc tke=',clw(ipr,:,ntk), +! &' kdt=',kdt,' lat=',lat,'xlon=',xlon(ipr),' xlat=',xlat(ipr) + +! phy_f3d(1,1,ntot3d-2) - shoc determined sgs clouds +! phy_f3d(1,1,ntot3d-1) - shoc determined diffusion coefficients +! phy_f3d(1,1,ntot3d ) - shoc determined w'theta' +! +! dqdt(1:im,:,1) = gq0(1:im,:,1) +! dqdt(1:im,:,2) = gq0(1:im,:,ntiw) +! dqdt(1:im,:,3) = gq0(1:im,:,ntcw) +!GFDL lat has no meaning inside of shoc - changed to "1" +!GFDL call shoc(ix, im, 1, levs, levs+1, dtp, me, lat, + call shoc (ix, im, 1, levs, levs+1, dtp, me, 1, Statein%prsl(1,1), & + Statein%phii(1,1), Statein%phil(1,1), Stateout%gu0(1,1), & + Stateout%gv0(1,1), Statein%vvl(1,1), Stateout%gt0(1,1), & + Stateout%gq0(1,1,1), clw(1,1,1), clw(1,1,2), qpi, qpl, & + rhc, Model%sup, Tbd%phy_f3d(1,1,Model%ntot3d-2), & + clw(1,1,ntk), hflx, evap, prnum, & + Tbd%phy_f3d(1,1,Model%ntot3d-1), & + Tbd%phy_f3d(1,1,Model%ntot3d), lprnt, ipr, ncpl, ncpi, kdt) + +! if (lprnt) write(0,*)' aftshoccld=',phy_f3d(ipr,:,ntot3d-2)*100 +! if (lprnt) write(0,*)' aftshocice=',clw(ipr,:,1) +! if (lprnt) write(0,*)' aftshocwat=',clw(ipr,:,1) +! write(1000+me,*)' at latitude = ',lat +! rain1 = 0.0 +! call moist_bud(im,im,ix,levs,me,kdt,con_g,dtp,del,rain1 +! &, dqdt(1,1,1), dqdt(1,1,2), dqdt(1,1,3) +! &, gq0(1,1,1),clw(1,1,2),clw(1,1,1),'shoc ') + + if ((Model%ntlnc > 0) .and. (Model%ntinc > 0) .and. (Model%ncld >= 2)) then + Stateout%gq0(:,:,Model%ntlnc) = ncpl(:,:) + Stateout%gq0(:,:,Model%ntinc) = ncpi(:,:) + endif +! do k=1,levs +! do i=1,im +! sgs_cld(i,k) = sgs_cld(i,k) + shoc_cld(i,k) +! enddo +! enddo +! if (lprnt) write(0,*)' gt03=',gt0(ipr,1:10) +! if (lprnt) write(0,*)' tke=',clw(ipr,1:10,ntk) + +! if (lprnt) write(1000+me,*)' after shoc tke=',clw(1,:,ntk), +! &' kdt=',kdt +! enddo +! +! do k=1,levs +! write(1000+me,*)' maxcld=',maxval(sgs_cld(1:im,k)), +! write(1000+me,*)' maxtkh=',maxval(phy_f3d(1:im,k,ntot3d-1)), +! &' k=',k,' kdt=',kdt,' lat=',lat +! enddo + +! write(0,*)' aft shoc gt0=',gt0(1,:),' lat=',lat +! write(0,*)' aft shoc gq0=',gq0(1,:,1),' lat=',lat +! write(0,*)' aft shoc gu0=',gu0(1,:),' lat=',lat +! + endif ! if(do_shoc) + +! --- ... calling convective parameterization +! + if (.not. Model%ras .and. .not. Model%cscnv) then + + if (Model%imfdeepcnv == 1) then ! no random cloud top + call sascnvn (im, ix, levs, Model%jcap, dtp, del, & + Statein%prsl, Statein%pgr, Statein%phil, clw(:,:,1:2), & + Stateout%gq0, Stateout%gt0, Stateout%gu0, & + Stateout%gv0, cld1d, rain1, kbot, ktop, kcnv, & + islmsk, Statein%vvl, Model%ncld, ud_mf, dd_mf, & + dt_mf, cnvw, cnvc) + elseif (Model%imfdeepcnv == 2) then + call mfdeepcnv (im, ix, levs, dtp, del, Statein%prsl, & + Statein%pgr, Statein%phil, clw(:,:,1:2), Stateout%gq0, & + Stateout%gt0, Stateout%gu0, Stateout%gv0, & + cld1d, rain1, kbot, ktop, kcnv, islmsk, & + garea, Statein%vvl, Model%ncld, ud_mf, dd_mf, & + dt_mf, cnvw, cnvc) +! if (lprnt) print *,' rain1=',rain1(ipr) + elseif (Model%imfdeepcnv == 0) then ! random cloud top + call sascnv (im, ix, levs, Model%jcap, dtp, del, & + Statein%prsl, Statein%pgr, Statein%phil, clw(:,:,1:2), & + Stateout%gq0, Stateout%gt0, Stateout%gu0, & + Stateout%gv0, cld1d, rain1, kbot, ktop, kcnv, & + islmsk, Statein%vvl, Tbd%rann, Model%ncld, & + ud_mf, dd_mf, dt_mf, cnvw, cnvc) +! if (lprnt) print *,' rain1=',rain1(ipr),' rann=',rann(ipr,1) + endif + else ! ras or cscnv + if (Model%cscnv) then ! Chikira-Sugiyama convection scheme (via CSU) + otspt(:,:) = .true. + otspt(1:3,:) = .false. + if (Model%ntke > 0) then + otspt(Model%ntke-trc_shft+4,1) = .false. + endif + if (Model%ncld == 2) then + otspt(Model%ntlnc-trc_shft+4,1) = .false. + otspt(Model%ntinc-trc_shft+4,1) = .false. + endif + + fscav(:) = 0.0 + fswtr(:) = 0.0 +! write(0,*)' bef cs_cconv phii=',phii(ipr,:) +! &,' sizefsc=',size(fscav) +! write(0,*)' bef cs_cconv otspt=',otspt,' kdt=',kdt,' me=',me + dqdt(:,:,1) = Stateout%gq0(:,:,1) + dqdt(:,:,2) = max(0.0,clw(:,:,2)) + dqdt(:,:,3) = max(0.0,clw(:,:,1)) +! if (lprnt) write(0,*)' gq0bfcs=',gq0(ipr,1:35,1) +! if (lprnt) write(0,*)' gq0bfcs3=',gq0(ipr,1:35,3) +! if (lprnt) write(0,*)' gq0bfcs4=',gq0(ipr,1:35,4) + + do_awdd = ((Model%do_aw) .and. (Model%cs_parm(6) > 0.0)) +! if (lprnt) write(0,*)' do_awdd=',do_awdd +!GFDL again lat replaced with "1" +!GFDL & otspt, lat, kdt , & + call cs_convr (ix, im, levs, tottracer+3, Model%nctp, otspt, 1, & + kdt, Stateout%gt0, Stateout%gq0(1,1,1:1), rain1, & + clw, Statein%phil, Statein%phii, Statein%prsl, & + Statein%prsi, dtp, dtf, ud_mf, dd_mf, dt_mf, & + Stateout%gu0, Stateout%gv0, fscav, fswtr, & + Tbd%phy_fctd, me, wcbmax, Model%cs_parm(3), & + Model%cs_parm(4), sigmai, sigmatot, vverti, & + Model%do_aw, do_awdd, lprnt, ipr, QLCN, QICN, & + w_upi, cf_upi, CNV_MFD, CNV_PRC3, CNV_DQLDT, & + CLCN, CNV_FICE, CNV_NDROP, CNV_NICE, Model%ncld) + +! if (lprnt) write(0,*)' gq0afcs=',gq0(ipr,1:35,1) +! if (lprnt) write(0,*)' gq0afcs3=',gq0(ipr,1:35,3) +! if (lprnt) write(0,*)' gq0afcs4=',gq0(ipr,1:35,4) +! write(1000+me,*)' at latitude = ',lat +! call moist_bud(im,im,ix,levs,me,kdt,con_g,dtp,del,rain1 +! &, dqdt(1,1,1), dqdt(1,1,2), dqdt(1,1,3) +! &, gq0(1,1,1),clw(1,1,2),clw(1,1,1),' cs_conv') + + rain1(:) = rain1(:) * (dtp*0.001) + if (Model%do_aw) then + do k=1,levs + kk = min(k+1,levs) ! assuming no cloud top reaches the model top + do i = 1,im !DD + sigmafrac(i,k) = 0.5 * (sigmatot(i,k)+sigmatot(i,kk)) + enddo + enddo + endif + +! if (lprnt) then +! write(0,*)' gt01=',gt0(ipr,:),' kdt=',kdt +! write(0,*)' gq01=',gq0(ipr,:,1),' kdt=',kdt +! write(0,*)' clw1=',clw(ipr,:,1),' kdt=',kdt +! write(0,*)' clw2=',clw(ipr,:,1),' kdt=',kdt +! write(0,*)' aft cs rain1=',rain1(ipr)*86400 +! write(0,*)' aft cs rain1=',rain1(ipr) +! endif + + else ! ras version 2 + + if ((Model%ccwf(1) >= 0.0) .or. (Model%ccwf(2) >= 0)) then + ccwfac(:) = Model%ccwf(1)*work1(:) + Model%ccwf(2)*work2(:) + dlqfac(:) = Model%dlqf(1)*work1(:) + Model%dlqf(2)*work2(:) + lmh (:) = levs + else + ccwfac(:) = -999.0 + dlqfac(:) = 0.0 + lmh (:) = levs + endif +! if (lprnt) write(0,*) ' calling ras for kdt=',kdt,' me=',me & +! &, ' lprnt=',lprnt,' ccwfac=',ccwfac(ipr) + +! do k=1,levs +! do i=1,im +! dqdt(i,k,1) = gq0(i,k,1) +! dqdt(i,k,2) = max(0.0,clw(i,k,2)) +! dqdt(i,k,3) = max(0.0,clw(i,k,1)) +! enddo +! enddo +! if (lat == 64 .and. kdt == 1) write(0,*)' qliq=',clw(1,:,1) +! if (lat == 64 .and. kdt == 1) write(0,*)' qice=',clw(1,:,2) + + revap = .true. +! if (ncld ==2) revap = .false. + call rascnv (im, ix, levs, dtp, dtf, Tbd%rann, Stateout%gt0, & + Stateout%gq0, Stateout%gu0, Stateout%gv0, clw, & + tottracer, fscav, Statein%prsi, Statein%prsl, & + Statein%prsik, Statein%prslk, Statein%phil, & + Statein%phii, kpbl, cd, rain1, kbot, ktop, kcnv, & + Tbd%phy_f2d(1,Model%num_p2d), Model%flipv, pa2mb, & + me, garea, lmh, ccwfac, Model%nrcm, rhc, ud_mf, & + dd_mf, dt_mf, dlqfac, lprnt, ipr, kdt, revap, QLCN, & + QICN, w_upi, cf_upi, CNV_MFD, CNV_PRC3, CNV_DQLDT, & + CLCN, CNV_FICE, CNV_NDROP, CNV_NICE, Model%ncld ) + endif + +! write(1000+me,*)' at latitude = ',lat +! tx1 = 1000.0 +! call moist_bud(im,im,ix,levs,me,kdt,con_g,tx1,del,rain1 +! &, dqdt(1,1,1), dqdt(1,1,2), dqdt(1,1,3) +! &, gq0(1,1,1),clw(1,1,2),clw(1,1,1),' ras_conv') +! if(lprnt) write(0,*)' after ras rain1=',rain1(ipr) +! &,' cnv_prc3sum=',sum(cnv_prc3(ipr,1:levs)) +! if (lprnt) write(0,*)' gt04=',gt0(ipr,1:10) +! if (lprnt) write(0,*)' gq04=',gq0(ipr,:,1) + + cld1d = 0 + + if (Model%ldiag3d .or. Model%lgocart) then + Coupling%upd_mfi(:,:) = 0. + Coupling%dwn_mfi(:,:) = 0. + Coupling%det_mfi(:,:) = 0. + endif + if (Model%lgocart) then + Coupling%dqdti(:,:) = 0. + Coupling%cnvqci(:,:) = 0. + endif + + if (Model%lgocart) then + Coupling%upd_mfi(:,:) = Coupling%upd_mfi(:,:) + ud_mf(:,:) * frain + Coupling%dwn_mfi(:,:) = Coupling%dwn_mfi(:,:) + dd_mf(:,:) * frain + Coupling%det_mfi(:,:) = Coupling%det_mfi(:,:) + dt_mf(:,:) * frain + Coupling%cnvqci (:,:) = Coupling%cnvqci (:,:) + (clw(:,:,1)+clw(:,:,2) - & + Stateout%gq0(:,:,Model%ntcw)) * frain + endif ! if (lgocart) + +! --- ... update the tracers due to convective transport + + if (tottracer > 0) then + if (Model%ntoz > 0) then ! for ozone + Stateout%gq0(:,:,Model%ntoz) = clw(:,:,3) + + if (tracers > 0) then ! for other tracers + do n=1,tracers + Stateout%gq0(:,:,n+trc_shft) = clw(:,:,3+n) + enddo + endif + else + do n=1,tracers + Stateout%gq0(:,:,n+trc_shft) = clw(:,:,2+n) + enddo + endif + endif + endif ! end if_not_ras + +! if (lprnt) then +! write(0,*)' aftcnvgt0=',gt0(ipr,:),' kdt=',kdt,' lat=',lat +! write(0,*)' aftcnvgq0=',(gq0(ipr,k,1),k=1,levs),' lat=',lat +! write(0,*)' gq0i2=',(gq0(ipr,k,ntiw),k=1,levs),' lat=',lat +! write(0,*)' aftcnvgq1=',(gq0(ipr,k,ntcw),k=1,levs) +! endif +! + do i = 1, im + Diag%rainc(:) = frain * rain1(:) + enddo +! + if (Model%lssav) then + Diag%cldwrk (:) = Diag%cldwrk (:) + cld1d(:) * dtf + Diag%cnvprcp(:) = Diag%cnvprcp(:) + Diag%rainc(:) + + if (Model%ldiag3d) then + Diag%dt3dt(:,:,4) = Diag%dt3dt(:,:,4) + (Stateout%gt0(:,:)-dtdt(:,:)) * frain + Diag%dq3dt(:,:,2) = Diag%dq3dt(:,:,2) + (Stateout%gq0(:,:,1)-dqdt(:,:,1)) * frain + Diag%du3dt(:,:,3) = Diag%du3dt(:,:,3) + (Stateout%gu0(:,:)-dudt(:,:)) * frain + Diag%dv3dt(:,:,3) = Diag%dv3dt(:,:,3) + (Stateout%gv0(:,:)-dvdt(:,:)) * frain + + Diag%upd_mf(:,:) = Diag%upd_mf(:,:) + ud_mf(:,:) * (con_g*frain) + Diag%dwn_mf(:,:) = Diag%dwn_mf(:,:) + dd_mf(:,:) * (con_g*frain) + Diag%det_mf(:,:) = Diag%det_mf(:,:) + dt_mf(:,:) * (con_g*frain) + endif ! if (ldiag3d) + + endif ! end if_lssav +! +! update dqdt_v to include moisture tendency due to deep convection + if (Model%lgocart) then + Coupling%dqdti (:,:) = (Stateout%gq0(:,:,1) - dqdt(:,:,1)) * frain + Coupling%upd_mfi(:,:) = Coupling%upd_mfi(:,:) + ud_mf(:,:) * frain + Coupling%dwn_mfi(:,:) = Coupling%dwn_mfi(:,:) + dd_mf(:,:) * frain + Coupling%det_mfi(:,:) = Coupling%det_mfi(:,:) + dt_mf(:,:) * frain + Coupling%cnvqci (:,:) = Coupling%cnvqci (:,:) + (clw(:,:,1)+clw(:,:,2))*frain + endif ! if (lgocart) +! + if ((Model%npdf3d == 3) .and. (Model%num_p3d == 4)) then + num2 = Model%num_p3d + 2 + num3 = num2 + 1 + Tbd%phy_f3d(:,:,num2) = cnvw(:,:) + Tbd%phy_f3d(:,:,num3) = cnvc(:,:) + elseif ((Model%npdf3d == 0) .and. (Model%ncnvcld3d == 1)) then + num2 = Model%num_p3d + 1 + Tbd%phy_f3d(:,:,num2) = cnvw(:,:) + endif + +! if (lprnt) write(7000,*)' bef cnvgwd gu0=',gu0(ipr,:) +! &,' lat=',lat,' kdt=',kdt,' me=',me +! if (lprnt) write(7000,*)' bef cnvgwd gv0=',gv0(ipr,:) +! +!----------------Convective gravity wave drag parameterization starting -------- + + if (Model%cnvgwd) then ! call convective gravity wave drag + +! --- ... calculate maximum convective heating rate +! cuhr = temperature change due to deep convection + + cumabs(:) = 0.0 + work3 (:) = 0.0 + do k = 1, levs + do i = 1, im + if (k >= kbot(i) .and. k <= ktop(i)) then + cumabs(i) = cumabs(i) + (Stateout%gt0(i,k)-dtdt(i,k)) * del(i,k) + work3(i) = work3(i) + del(i,k) + endif + enddo + enddo + do i=1,im + if (work3(i) > 0.0) cumabs(i) = cumabs(i) / (dtp*work3(i)) + enddo + +! do i = 1, im +! do k = kbot(i), ktop(i) +! do k1 = kbot(i), k +! cumchr(i,k) = cuhr(i,k1) + cumchr(i,k) +! enddo +! cumchr(i,k) = cumchr(i,k) / cumabs(i) +! enddo +! enddo + +! --- ... begin check print ****************************************** + +! if (lprnt) then +! if (kbot(ipr) <= ktop(ipr)) then +! write(*,*) 'kbot <= ktop for (lat,lon) = ', & +! & xlon(ipr)*57.29578,xlat(ipr)*57.29578 +! write(*,*) 'kcnv kbot ktop dlength ',kcnv(ipr), & +! & kbot(ipr),ktop(ipr),dlength(ipr) +! write(*,9000) kdt +!9000 format(/,3x,'k',5x,'cuhr(k)',4x,'cumchr(k)',5x, & +! & 'at kdt = ',i4,/) + +! do k = ktop(ipr), kbot(ipr),-1 +! write(*,9010) k,(86400.*cuhr(ipr,k)),(100.*cumchr(ipr,k)) +!9010 format(2x,i2,2x,f8.2,5x,f6.0) +! enddo +! endif + +! if (fhour >= fhourpr) then +! print *,' before gwdc in gbphys start print' +! write(*,*) 'fhour ix im levs = ',fhour,ix,im,levs +! print *,'dtp dtf = ',dtp,dtf + +! write(*,9100) +!9100 format(//,14x,'pressure levels',// & +! & ' ilev',7x,'prsi',8x,'prsl',8x,'delp',/) + +! k = levs + 1 +! write(*,9110) k,(10.*prsi(ipr,k)) +!9110 format(i4,2x,f10.3) + +! do k = levs, 1, -1 +! write(*,9120) k,(10.*prsl(ipr,k)),(10.*del(ipr,k)) +! write(*,9110) k,(10.*prsi(ipr,k)) +! enddo +!9120 format(i4,12x,2(2x,f10.3)) + +! write(*,9130) +!9130 format(//,10x,'before gwdc in gbphys',//,' ilev',6x, & +! & 'ugrs',9x,'gu0',8x,'vgrs',9x,'gv0',8x, & +! & 'tgrs',9x,'gt0',8x,'gt0b',8x,'dudt',8x,'dvdt',/) + +! do k = levs, 1, -1 +! write(*,9140) k,ugrs(ipr,k),gu0(ipr,k), & +! & vgrs(ipr,k),gv0(ipr,k), & +! & tgrs(ipr,k),gt0(ipr,k),dtdt(ipr,k), & +! & dudt(ipr,k),dvdt(ipr,k) +! enddo +!9140 format(i4,9(2x,f10.3)) + +! print *,' before gwdc in gbphys end print' +! endif +! endif ! end if_lprnt + +! --- ... end check print ******************************************** + +!GFDL replacing lat with "1" +! call gwdc(im, ix, im, levs, lat, gu0, gv0, gt0, gq0, dtp, & + call gwdc (im, ix, im, levs, 1, Statein%ugrs, Statein%vgrs, & + Statein%tgrs, Statein%qgrs, dtp, Statein%prsl, & + Statein%prsi, del, cumabs, ktop, kbot, kcnv, cldf, & + con_g, con_cp, con_rd, con_fvirt, con_pi, dlength, & + lprnt, ipr, Model%fhour, gwdcu, gwdcv, dusfcg, dvsfcg) + +! if (lprnt) then +! if (fhour >= fhourpr) then +! print *,' after gwdc in gbphys start print' + +! write(*,9131) +!9131 format(//,10x,'after gwdc in gbphys',//,' ilev',6x, & +! & 'ugrs',9x,'gu0',8x,'vgrs',9x,'gv0',8x, & +! & 'tgrs',9x,'gt0',8x,'gt0b',7x,'gwdcu',7x,'gwdcv',/) + +! do k = levs, 1, -1 +! write(*,9141) k,ugrs(ipr,k),gu0(ipr,k), & +! & vgrs(ipr,k),gv0(ipr,k), & +! & tgrs(ipr,k),gt0(ipr,k),dtdt(ipr,k), & +! & gwdcu(ipr,k),gwdcv(ipr,k) +! enddo +!9141 format(i4,9(2x,f10.3)) + +! print *,' after gwdc in gbphys end print' +! endif +! endif + +! --- ... write out cloud top stress and wind tendencies + + if (Model%lssav) then + Diag%dugwd(:) = Diag%dugwd(:) + dusfcg(:)*dtf + Diag%dvgwd(:) = Diag%dvgwd(:) + dvsfcg(:)*dtf + + if (Model%ldiag3d) then + Diag%du3dt(:,:,4) = Diag%du3dt(:,:,4) + gwdcu(:,:) * dtf + Diag%dv3dt(:,:,4) = Diag%dv3dt(:,:,4) + gwdcv(:,:) * dtf + endif + endif ! end if_lssav + +! --- ... update the wind components with gwdc tendencies + + do k = 1, levs + do i = 1, im + eng0 = 0.5*(Stateout%gu0(i,k)*Stateout%gu0(i,k)+Stateout%gv0(i,k)*Stateout%gv0(i,k)) + Stateout%gu0(i,k) = Stateout%gu0(i,k) + gwdcu(i,k) * dtp + Stateout%gv0(i,k) = Stateout%gv0(i,k) + gwdcv(i,k) * dtp + eng1 = 0.5*(Stateout%gu0(i,k)*Stateout%gu0(i,k)+Stateout%gv0(i,k)*Stateout%gv0(i,k)) + Stateout%gt0(i,k) = Stateout%gt0(i,k) + (eng0-eng1)/(dtp*con_cp) + enddo +! if (lprnt) write(7000,*)' gu0=',gu0(ipr,k),' gwdcu=', +! &gwdcu(ipr,k), ' gv0=', gv0(ipr,k),' gwdcv=',gwdcv(ipr,k) +! &,' k=',k + enddo + +! if (lprnt) then +! if (fhour >= fhourpr) then +! print *,' after tendency gwdc in gbphys start print' + +! write(*,9132) +!9132 format(//,10x,'after tendency gwdc in gbphys',//,' ilev',6x,& +! & 'ugrs',9x,'gu0',8x,'vgrs',9x,'gv0',8x, & +! & 'tgrs',9x,'gt0',8x,'gt0b',7x,'gwdcu',7x,'gwdcv',/) + +! do k = levs, 1, -1 +! write(*,9142) k,ugrs(ipr,k),gu0(ipr,k),vgrs(ipr,k), & +! & gv0(ipr,k),tgrs(ipr,k),gt0(ipr,k),dtdt(ipr,k), & +! & gwdcu(ipr,k),gwdcv(ipr,k) +! enddo +!9142 format(i4,9(2x,f10.3)) + +! print *,' after tendency gwdc in gbphys end print' +! endif +! endif + + endif ! end if_cnvgwd (convective gravity wave drag) + +! if (lprnt) write(7000,*)' aft cnvgwd gu0=',gu0(ipr,:) +! if (lprnt) write(7000,*)' aft cnvgwd gv0=',gv0(ipr,:) +! &,' lat=',lat,' kdt=',kdt,' me=',me +!----------------Convective gravity wave drag parameterization over -------- + + if (Model%ldiag3d) then + dtdt(:,:) = Stateout%gt0(:,:) + endif + if (Model%ldiag3d .or. Model%lgocart) then + dqdt(:,:,1) = Stateout%gq0(:,:,1) + endif + +! write(0,*)' before do_shoc shal clstp=',clstp,' kdt=',kdt, +! & ' lat=',lat +! if (lprnt) then +! write(0,*)' prsl=',prsl(ipr,:) +! write(0,*) ' del=',del(ipr,:) +! write(0,*) ' befshalgt0=',gt0(ipr,:),' kdt=',kdt +! write(0,*) ' befshalgq0=',gt0(ipr,:),' kdt=',kdt +! write(0,*) ' befshalgq0=',gq0(ipr,:,1),' kdt=',kdt +! write(0,*) ' befshalgqw=',gq0(ipr,:,3),' kdt=',kdt +! endif + + if (.not. Model%do_shoc) then + + if (Model%shal_cnv) then ! Shallow convection parameterizations +! -------------------------------------- + if (Model%imfshalcnv == 1) then ! opr option now at 2014 + !----------------------- + call shalcnv (im, ix, levs, Model%jcap, dtp, del, Statein%prsl, & + Statein%pgr, Statein%phil, clw, Stateout%gq0, & + Stateout%gt0, Stateout%gu0, Stateout%gv0, rain1, & + kbot, ktop, kcnv, islmsk, Statein%vvl, Model%ncld,& + Diag%hpbl, hflx, evap, ud_mf, dt_mf, cnvw, cnvc) + + raincs(:) = frain * rain1(:) + Diag%rainc(:) = Diag%rainc(:) + raincs(:) + if (Model%lssav) then + Diag%cnvprcp(:) = Diag%cnvprcp(:) + raincs(:) + endif + if ((Model%shcnvcw) .and. (Model%num_p3d == 4) .and. (Model%npdf3d == 3)) then + Tbd%phy_f3d(:,:,num2) = cnvw(:,:) + Tbd%phy_f3d(:,:,num3) = cnvc(:,:) + elseif ((Model%npdf3d == 0) .and. (Model%ncnvcld3d == 1)) then + num2 = Model%num_p3d + 1 + Tbd%phy_f3d(:,:,num2) = cnvw(:,:) + endif + + elseif (Model%imfshalcnv == 2) then + call mfshalcnv (im, ix, levs, dtp, del, Statein%prsl, & + Statein%pgr, Statein%phil, clw, Stateout%gq0, & + Stateout%gt0, Stateout%gu0, Stateout%gv0, & + rain1, kbot, ktop, kcnv, islmsk, garea, & + Statein%vvl, Model%ncld, DIag%hpbl, ud_mf, & + dt_mf, cnvw, cnvc) + + raincs(:) = frain * rain1(:) + Diag%rainc(:) = DIag%rainc(:) + raincs(:) + if (Model%lssav) then + Diag%cnvprcp(:) = Diag%cnvprcp(:) + raincs(:) + endif + if ((Model%shcnvcw) .and. (Model%num_p3d == 4) .and. (Model%npdf3d == 3)) then + Tbd%phy_f3d(:,:,num2) = cnvw(:,:) + Tbd%phy_f3d(:,:,num3) = cnvc(:,:) + elseif ((Model%npdf3d == 0) .and. (Model%ncnvcld3d == 1)) then + num2 = Model%num_p3d + 1 + Tbd%phy_f3d(:,:,num2) = cnvw(:,:) + endif + + elseif (Model%imfshalcnv == 0) then ! modified Tiedtke Shallow convecton + !----------------------------------- + levshc(:) = 0 + do k = 2, levs + do i = 1, im + dpshc = 0.3 * Statein%prsi(i,1) + if (Statein%prsi(i,1)-Statein%prsi(i,k) <= dpshc) levshc(i) = k + enddo + enddo + levshcm = 1 + do i = 1, im + levshcm = max(levshcm, levshc(i)) + enddo + +! if (lprnt) print *,' levshcm=',levshcm,' gt0sh=',gt0(ipr,:) +! &, ' lat=',lat + + if (Model%mstrat) then ! As in CFSv2 + call shalcv (im, ix, levshcm, dtp, del, Statein%prsi, & + Statein%prsl, Statein%prslk,kcnv, Stateout%gq0, & + Stateout%gt0, levshc, Statein%phil, kinver, & + ctei_r, ctei_rml, lprnt, ipr) + else + call shalcvt3 (im, ix, levshcm, dtp, del, Statein%prsi, & + Statein%prsl, Statein%prslk, kcnv, & + Stateout%gq0, Stateout%gt0) + endif +! if (lprnt) print *,' levshcm=',levshcm,' gt0sha=',gt0(ipr,:) + + endif ! end if_imfshalcnv + endif ! end if_shal_cnv + + if (Model%lssav) then +! update dqdt_v to include moisture tendency due to shallow convection + if (Model%lgocart) then + do k = 1, levs + do i = 1, im + tem = (Stateout%gq0(i,k,1)-dqdt(i,k,1)) * frain + Coupling%dqdti(i,k) = Coupling%dqdti(i,k) + tem + enddo + enddo + endif + if (Model%ldiag3d) then + Diag%dt3dt(:,:,5) = Diag%dt3dt(:,:,5) + (Stateout%gt0(:,:)-dtdt(:,:)) * frain + Diag%dq3dt(:,:,3) = Diag%dq3dt(:,:,3) + (Stateout%gq0(:,:,1)-dqdt(:,:,1)) * frain + endif + endif ! end if_lssav +! + do k = 1, levs + do i = 1, im + if (clw(i,k,2) <= -999.0) clw(i,k,2) = 0.0 + enddo + enddo + +! if (lprnt) then +! write(0,*)' prsl=',prsl(ipr,:) +! write(0,*) ' del=',del(ipr,:) +! write(0,*) ' befshgt0=',gt0(ipr,:) +! write(0,*) ' befshgq0=',gq0(ipr,:,1) +! endif + + elseif (Model%shocaftcnv) then ! if do_shoc is true and shocaftcnv is true call shoc + if (Model%ncld == 2) then + skip_macro = Model%do_shoc + ncpl(:,:) = Stateout%gq0(:,:,Model%ntlnc) + ncpi(:,:) = Stateout%gq0(:,:,Model%ntinc) + +! else +! if (clw(1,1,2) < -999.0) then ! if clw is not partitioned to ice and water +! do k=1,levs +! do i=1,im +! tem = gq0(i,k,ntcw) & +! & * max(0.0, MIN(1.0, (TCR-gt0(i,k))*TCRF)) +! clw(i,k,1) = tem ! ice +! clw(i,k,2) = gq0(i,k,ntcw) - tem ! water +! enddo +! enddo +! endif ! Anning ncld ==2 + endif + qpl(:,:) = 0.0 + qpi(:,:) = 0.0 +! dtshoc = 60.0 +! nshocm = (dtp/dtshoc) + 0.001 +! dtshoc = dtp / nshocm +! do nshoc=1,nshocm +! call shoc(im, 1, levs, levs+1, dtp, me, lat, & +!! call shoc(im, 1, levs, levs+1, dtshoc, me, lat, & +! & prsl(1:im,:), phii (1:im,:), phil(1:im,:),& +! & gu0(1:im,:),gv0(1:im,:), vvl(1:im,:), gt0(1:im,:), & +! & gq0(1:im,:,1), & +! & clw(1:im,:,1), clw(1:im,:,2), qpi, qpl, sgs_cld(1:im,:)& +! &, gq0(1:im,:,ntke), & +! & phy_f3d(1:im,:,ntot3d-1), phy_f3d(1:im,:,ntot3d), & +! & lprnt, ipr, & +! & con_cp, con_g, con_hvap, con_hfus, con_hvap+con_hfus, & +! & con_rv, con_rd, con_pi, con_fvirt) + +!GFDL replace lat with "1: +! call shoc(ix, im, 1, levs, levs+1, dtshoc, me, lat, & + call shoc (ix, im, 1, levs, levs+1, dtp, me, 1, Statein%prsl(1,1), & + Statein%phii(1,1), Statein%phil(1,1), Stateout%gu0(1,1), & + Stateout%gv0(1,1), Statein%vvl(1,1), Stateout%gt0(1,1), & + Stateout%gq0(1,1,1), clw(1,1,1), clw(1,1,2), qpi, qpl,rhc, & + Model%sup, Tbd%phy_f3d(1,1,Model%ntot3d-2), & + Stateout%gq0(1,1,Model%ntke), hflx, evap, prnum, & + Tbd%phy_f3d(1,1,Model%ntot3d-1), Tbd%phy_f3d(1,1,Model%ntot3d),& + lprnt, ipr, ncpl, ncpi, kdt) + + if ((Model%ntlnc > 0) .and. (Model%ntinc > 0) .and. (Model%ncld >= 2)) then + Stateout%gq0(:,:,Model%ntlnc) = ncpl(:,:) + Stateout%gq0(:,:,Model%ntinc) = ncpi(:,:) + endif + +! +! do k=1,levs +! write(1000+me,*)' maxtkh=',maxval(phy_f3d(1:im,k,ntot3d-1)), & +! ' k=',k,' kdt=',kdt,' lat=',lat +! enddo + +! write(0,*)' aft shoc gt0=',gt0(1,:),' lat=',lat +! write(0,*)' aft shoc gq0=',gq0(1,:,1),' lat=',lat +! write(0,*)' aft shoc gu0=',gu0(1,:),' lat=',lat +! + endif ! if( .not. do_shoc) +! +! if (lprnt) then +! write(0,*)' prsl=',prsl(ipr,:) +! write(0,*) ' del=',del(ipr,:) +! write(0,*) ' aftshgt0=',gt0(ipr,:) +! write(0,*) ' aftshgq0=',gq0(ipr,:,1) +! endif + + if (Model%ntcw > 0) then + +! for microphysics + if (Model%ncld == 2) then ! morrison microphysics + Stateout%gq0(:,:,Model%ntiw) = clw(:,:,1) ! ice + Stateout%gq0(:,:,Model%ntcw) = clw(:,:,2) ! water + elseif (Model%num_p3d == 4) then ! if_num_p3d + Stateout%gq0(:,:,Model%ntcw) = clw(:,:,1) + clw(:,:,2) + endif ! end if_num_p3d + + else ! if_ntcw + + clw(:,:,1) = clw(:,:,1) + clw(:,:,2) + + + endif ! end if_ntcw + +! Legacy routine which determines convectve clouds - should be removed at some point + + call cnvc90 (Model%clstp, im, ix, Diag%rainc, kbot, ktop, levs, Statein%prsi, & + Tbd%acv, Tbd%acvb, Tbd%acvt, Cldprop%cv, Cldprop%cvb, Cldprop%cvt) + + if (Model%moist_adj) then ! moist convective adjustment +! --------------------------- +! +! To call moist convective adjustment +! +! if (lprnt) then +! print *,' prsl=',prsl(ipr,:) +! print *,' del=',del(ipr,:) +! print *,' gt0b=',gt0(ipr,:) +! print *,' gq0b=',gq0(ipr,:,1) +! endif + + call mstcnv (im, ix, levs, dtp, Stateout%gt0, Stateout%gq0, & + Statein%prsl,del, Statein%prslk, rain1, & + Stateout%gq0(1,1,Model%ntcw), rhc, lprnt, ipr) + +! if (lprnt) then +! print *,' rain1=',rain1(ipr),' rainc=',rainc(ipr) +! print *,' gt0a=',gt0(ipr,:) +! print *,' gq0a=',gq0(ipr,:,1) +! endif + Diag%rainc(:) = Diag%rainc(:) + frain * rain1(:) + if(Model%lssav) then + Diag%cnvprcp(:) = Diag%cnvprcp(:) + rain1(:) * frain + +! update dqdt_v to include moisture tendency due to surface processes +! dqdt_v : instaneous moisture tendency (kg/kg/sec) +! if (lgocart) then +! do k=1,levs +! do i=1,im +! tem = (gq0(i,k,1)-dqdt(i,k,1)) * frain +! dqdt_v(i,k) = dqdt_v(i,k) + tem +! dqdt_v(i,k) = dqdt_v(i,k) / dtf +! enddo +! enddo +! endif + if (Model%ldiag3d) then + Diag%dt3dt(:,:,4) = Diag%dt3dt(:,:,4) + (Stateout%gt0(:,:) -dtdt(:,:) ) * frain + Diag%dq3dt(:,:,2) = Diag%dq3dt(:,:,2) + (Stateout%gq0(:,:,1)-dqdt(:,:,1)) * frain + endif + endif + endif ! moist convective adjustment over +! + if (Model%ldiag3d .or. Model%do_aw) then + dtdt(:,:) = Stateout%gt0(:,:) + dqdt(:,:,1) = Stateout%gq0(:,:,1) + do n=Model%ntcw,Model%ntcw+Model%ncld-1 + dqdt(:,:,n) = Stateout%gq0(:,:,n) + enddo + endif + +! dqdt_v : instaneous moisture tendency (kg/kg/sec) + if (Model%lgocart) then + Coupling%dqdti(:,:) = Coupling%dqdti(:,:) / dtf + endif +! +! grid-scale condensation/precipitations and microphysics parameterization +! ------------------------------------------------------------------------ + + if (Model%ncld == 0) then ! no cloud microphysics + + call lrgscl (ix, im, levs, dtp, Stateout%gt0, Stateout%gq0, & + Statein%prsl, del, Statein%prslk, rain1, clw) + + elseif (Model%ncld == 1) then ! microphysics with single cloud condensate + + if (Model%num_p3d == 4) then ! call zhao/carr/sundqvist microphysics + + if (Model%npdf3d /= 3) then ! without pdf clouds + +! if (lprnt) then +! write(0,*)' prsl=',prsl(ipr,:) +! write(0,*) ' del=',del(ipr,:) +! write(0,*) ' beflsgt0=',gt0(ipr,:),' kdt=',kdt +! write(0,*) ' beflsgq0=',gq0(ipr,:,1),' kdt=',kdt +! write(0,*) ' beflsgw0=',gq0(ipr,:,3),' kdt=',kdt +! endif + ! ------------------ + if (Model%do_shoc) then + call precpd_shoc (im, ix, levs, dtp, del, Statein%prsl, & + Stateout%gq0(1,1,1), Stateout%gq0(1,1,Model%ntcw), & + Stateout%gt0, rain1, Diag%sr, rainp, rhc, & + psautco_l, prautco_l, Model%evpco, Model%wminco, & + Tbd%phy_f3d(1,1,Model%ntot3d-2), lprnt, ipr) + else + +! call gscond (im, ix, levs, dtp, dtf, Statein%prsl, Statein%pgr, & + call gscond_run (im, ix, levs, dtp, dtf, Statein%prsl, Statein%pgr,& +! Stateout%gq0(1,1,1), Stateout%gq0(1,1,Model%ntcw), & +! Stateout%gt0, Tbd%phy_f3d(1,1,1), Tbd%phy_f3d(1,1,2), & +! Tbd%phy_f2d(1,1), Tbd%phy_f3d(1,1,3), & +! Tbd%phy_f3d(1,1,4), Tbd%phy_f2d(1,2), rhc,lprnt, ipr) + Stateout%gq0(:,:,1), Stateout%gq0(:,:,Model%ntcw), & + Stateout%gt0, Tbd%phy_f3d(:,:,1), Tbd%phy_f3d(:,:,2), & + Tbd%phy_f2d(:,1), Tbd%phy_f3d(:,:,3), & + Tbd%phy_f3d(:,:,4), Tbd%phy_f2d(:,2), rhc,lprnt, ipr) + +! call precpd (im, ix, levs, dtp, del, Statein%prsl, & + call precpd_run (im, ix, levs, dtp, del, Statein%prsl, & +! Stateout%gq0(1,1,1), Stateout%gq0(1,1,Model%ntcw), & + Stateout%gq0(:,:,1), Stateout%gq0(:,:,Model%ntcw), & + Stateout%gt0, rain1, Diag%sr, rainp, rhc, psautco_l, & + prautco_l, Model%evpco, Model%wminco, lprnt, ipr) + endif +! if (lprnt) then +! write(0,*)' prsl=',prsl(ipr,:) +! write(0,*) ' del=',del(ipr,:) +! write(0,*) ' aftlsgt0=',gt0(ipr,:),' kdt=',kdt +! write(0,*) ' aftlsgq0=',gq0(ipr,:,1),' kdt=',kdt +! write(0,*) ' aftlsgw0=',gq0(ipr,:,3),' kdt=',kdt +! write(0,*)' aft precpd rain1=',rain1(1:3),' lat=',lat +! endif + else ! with pdf clouds + ! --------------- + call gscondp (im, ix, levs, dtp, dtf, Statein%prsl, & + Statein%pgr, Stateout%gq0(1,1,1), & + Stateout%gq0(1,1,Model%ntcw), Stateout%gt0, & + Tbd%phy_f3d(1,1,1), Tbd%phy_f3d(1,1,2), & + Tbd%phy_f2d(1,1), Tbd%phy_f3d(1,1,3), & + Tbd%phy_f3d(1,1,4), Tbd%phy_f2d(1,2), rhc, & + Tbd%phy_f3d(1,1,Model%num_p3d+1), Model%sup, & + lprnt, ipr, kdt) + + call precpdp (im, ix, levs, dtp, del, Statein%prsl, & + Statein%pgr, Stateout%gq0(1,1,1), & + Stateout%gq0(1,1,Model%ntcw), Stateout%gt0, & + rain1, Diag%sr, rainp, rhc, & + Tbd%phy_f3d(1,1,Model%num_p3d+1), psautco_l, & + prautco_l, Model%evpco, Model%wminco, lprnt, ipr) + endif ! end of grid-scale precip/microphysics options + endif ! end if_num_p3d + +! if (lprnt) write(0,*) ' rain1=',rain1(ipr),' rainc=',rainc(ipr),' lat=',lat + + elseif (Model%ncld == 2) then ! MGB double-moment microphysics +! Acheng used clw here for other code to run smoothly and minimum change +! to make the code work. However, the nc and clw should be treated +! in other procceses too. August 28/2015; Hope that can be done next +! year. I believe this will make the physical interaction more reasonable +! Anning 12/5/2015 changed ntcw hold liquid only + if (Model%do_shoc) then + if (Model%fprcp == 0) then + clw(:,:,1) = Stateout%gq0(:,:,Model%ntiw) ! ice + clw(:,:,2) = Stateout%gq0(:,:,Model%ntcw) ! water + qrn(:,:) = 0. + qsnw(:,:) = 0. + ncpr(:,:) = 0. + ncps(:,:) = 0. + Tbd%phy_f3d(:,:,1) = Tbd%phy_f3d(:,:,Model%ntot3d-2) ! clouds from shoc + else + clw(:,:,1) = Stateout%gq0(:,:,Model%ntiw) ! ice + clw(:,:,2) = Stateout%gq0(:,:,Model%ntcw) ! water + qrn(:,:) = Stateout%gq0(:,:,Model%ntrw) + qsnw(:,:) = Stateout%gq0(:,:,Model%ntsw) + ncpr(:,:) = Stateout%gq0(:,:,Model%ntrnc) + ncps(:,:) = Stateout%gq0(:,:,Model%ntsnc) + Tbd%phy_f3d(:,:,1) = Tbd%phy_f3d(:,:,Model%ntot3d-2) ! clouds from shoc + end if + elseif ((Model%imfdeepcnv >= 0) .or. (Model%imfshalcnv > 0)) then + if (Model%fprcp == 0) then + clw(:,:,1) = Stateout%gq0(:,:,Model%ntiw) ! ice + clw(:,:,2) = Stateout%gq0(:,:,Model%ntcw) ! water + Tbd%phy_f3d(:,:,1) = max(0.0, min(1.0,Tbd%phy_f3d(:,:,1)+cnvc(:,:))) + ! clouds from t-dt and cnvc + qrn(:,:) = 0. + qsnw(:,:) = 0. + ncpr(:,:) = 0. + ncps(:,:) = 0. + else + clw(:,:,1) = Stateout%gq0(:,:,Model%ntiw) ! ice + clw(:,:,2) = Stateout%gq0(:,:,Model%ntcw) ! water + Tbd%phy_f3d(:,:,1) = max(0.0, min(1.0,Tbd%phy_f3d(:,:,1)+cnvc(:,:))) + ! clouds from t-dt and cnvc + qrn(:,:) = Stateout%gq0(:,:,Model%ntrw) + qsnw(:,:) = Stateout%gq0(:,:,Model%ntsw) + ncpr(:,:) = Stateout%gq0(:,:,Model%ntrnc) + ncps(:,:) = Stateout%gq0(:,:,Model%ntsnc) + endif + else + ! clouds from t-dt and cnvc + if (Model%fprcp == 0 ) then + clw(:,:,1) = Stateout%gq0(:,:,Model%ntiw) ! ice + clw(:,:,2) = Stateout%gq0(:,:,Model%ntcw) ! water + qrn(:,:) = 0. + qsnw(:,:) = 0. + ncpr(:,:) = 0. + ncps(:,:) = 0. + Tbd%phy_f3d(:,:,1) = min(1.0, Tbd%phy_f3d(:,:,1)+cnvc(:,:)) + else + clw(:,:,1) = Stateout%gq0(:,:,Model%ntiw) ! ice + clw(:,:,2) = Stateout%gq0(:,:,Model%ntcw) ! water + qrn(:,:) = Stateout%gq0(:,:,Model%ntrw) + qsnw(:,:) = Stateout%gq0(:,:,Model%ntsw) + ncpr(:,:) = Stateout%gq0(:,:,Model%ntrnc) + ncps(:,:) = Stateout%gq0(:,:,Model%ntsnc) + Tbd%phy_f3d(:,:,1) = min(1.0, Tbd%phy_f3d(:,:,1)+cnvc(:,:)) + endif + endif +! notice clw ix instead of im +! call m_micro_driver(im,ix,levs,flipv,del,dtp,prsl,prsi, +! & prslk,prsik,pgr,vvl,clw(1,1,2), QLCN, clw(1,1,1),QICN, +! if (lprnt) write(0,*)' cnv_mfdbef=',cnv_mfd(ipr,:),' flipv=',flipv +! if(lprnt) write(0,*) ' befgq0=',gq0(ipr,:,1),' kdt=',kdt +! if (lprnt) write(0,*)' clw1bef=',clw(ipr,:,1),' kdt=',kdt +! if (lprnt) write(0,*)' clw2bef=',clw(ipr,:,2),' kdt=',kdt +! if (lprnt) write(0,*)' cloudsb=',phy_f3d(ipr,:,1)*100,' kdt=',kdt +! txa(:,:) = gq0(:,:,1) + call m_micro_driver (im, ix, levs, Model%flipv, dtp, Statein%prsl, & + Statein%prsi, Statein%prslk, Statein%prsik, & + Statein%vvl, clw(1,1,2), QLCN, clw(1,1,1), QICN, & + Radtend%htrlw, Radtend%htrsw, w_upi, cf_upi, & + FRLAND, Diag%HPBL, CNV_MFD, CNV_PRC3, CNV_DQLDT, & + CLCN, Stateout%gu0, Stateout%gv0, Diag%dusfc, & + Diag%dvsfc, dusfc1, dvsfc1, dusfc1, dvsfc1, & + CNV_FICE, CNV_NDROP, CNV_NICE, Stateout%gq0(1,1,1), & + Stateout%gq0(1,1,Model%ntcw), & + Stateout%gq0(1,1,Model%ntiw), Stateout%gt0, rain1, & + Diag%sr, Stateout%gq0(1,1,Model%ntlnc), & + Stateout%gq0(1,1,Model%ntinc), Model%fprcp, qrn, & + qsnw, ncpr, ncps, Tbd%phy_f3d(1,1,1), kbot, & + Model%aero_in, skip_macro, cn_prc, cn_snr, lprnt, & + ipr, kdt, Grid%xlat, Grid%xlon) + +! write(1000+me,*)' at latitude = ',lat +! tx1 = 1000.0 +! call moist_bud(im,ix,ix,levs,me,kdt,con_g,tx1,del,rain1 +! &, txa, clw(1,1,2), clw(1,1,1) +! &, gq0(1,1,1),gq0(1,1,ntcw),gq0(1,1,ntcw+1),' m_micro ') + +! if (lprnt) write(0,*) ' rain1=',rain1(ipr)*86400.0, +! &' rainc=',rainc(ipr)*86400.0 +! &,' cn_prc=',cn_prc(ipr),' cn_snr=',cn_snr(ipr) +! if (lprnt) write(0,*) ' aftlsgq0=',gq0(ipr,:,1),' kdt=',kdt +! if (lprnt) write(0,*)' clw1aft=',gq0(ipr,:,ntiw),' kdt=',kdt +! if (lprnt) write(0,*)' cloudsm=',phy_f3d(ipr,:,1)*100,' kdt=',kdt +! if (lprnt) write(0,*)' clw2aft=',gq0(ipr,:,ntcw),' kdt=',kdt + + if (Model%fprcp == 1) then + Stateout%gq0(:,:,Model%ntrw) = qrn(:,:) + Stateout%gq0(:,:,Model%ntsw) = qsnw(:,:) + Stateout%gq0(:,:,Model%ntrnc) = ncpr(:,:) + Stateout%gq0(:,:,Model%ntsnc) = ncps(:,:) + endif + endif ! end if_ncld +! if (lprnt) write(0,*)' rain1 after ls=',rain1(ipr) +! + if (Model%do_aw) then +! Arakawa-Wu adjustment of large-scale microphysics tendencies: +! reduce by factor of (1-sigma) +! these are microphysics increments. We want to keep (1-sigma) of the increment, +! we will remove sigma*increment from final values +! fsigma = 0. ! don't apply any AW correction, in addition comment next line +! fsigma = sigmafrac + +! adjust sfc rainrate for conservation +! vertically integrate reduction of water increments, reduce precip by that amount + + temrain1(:) = 0.0 + do k = 1,levs + do i = 1,im + tem1 = sigmafrac(i,k) + Stateout%gt0(i,k) = Stateout%gt0(i,k) - tem1 * (Stateout%gt0(i,k)-dtdt(i,k)) + tem2 = tem1 * (Stateout%gq0(i,k,1)-dqdt(i,k,1)) + Stateout%gq0(i,k,1) = Stateout%gq0(i,k,1) - tem2 + temrain1(i) = temrain1(i) - (Statein%prsi(i,k)-Statein%prsi(i,k+1)) & + * tem2 * onebg + enddo + enddo + do n=Model%ntcw,Model%ntcw+Model%ncld-1 + do k = 1,levs + do i = 1,im + tem1 = sigmafrac(i,k) * (Stateout%gq0(i,k,n)-dqdt(i,k,n)) + Stateout%gq0(i,k,n) = Stateout%gq0(i,k,n) - tem1 + temrain1(i) = temrain1(i) - (Statein%prsi(i,k)-Statein%prsi(i,k+1)) & + * tem1 * onebg + enddo + enddo + enddo +! write(1000+me,*)' rain1=',rain1(4),' temrain1=',temrain1(i)*0.001 + rain1(:) = max(rain1(:) - temrain1(:)*0.001, 0.0_kind_phys) + endif + + Diag%rain(:) = Diag%rainc(:) + frain * rain1(:) + + if (Model%cal_pre) then ! hchuang: add dominant precipitation type algorithm + i = min(3,Model%num_p3d) + call calpreciptype (kdt, Model%nrcm, im, ix, levs, levs+1, & + Tbd%rann, Grid%xlat, Grid%xlon, Stateout%gt0, & + Stateout%gq0, Statein%prsl, Statein%prsi, & + Diag%rain, Statein%phii, Model%num_p3d, & + Sfcprop%tsfc, Diag%sr, Tbd%phy_f3d(1,1,i), & ! input + domr, domzr, domip, doms) ! output +! +! if (lprnt) print*,'debug calpreciptype: DOMR,DOMZR,DOMIP,DOMS ' +! &,DOMR(ipr),DOMZR(ipr),DOMIP(ipr),DOMS(ipr) +! do i=1,im +! if (abs(xlon(i)*57.29578-114.0) .lt. 0.2 .and. +! & abs(xlat(i)*57.29578-40.0) .lt. 0.2) +! & print*,'debug calpreciptype: DOMR,DOMZR,DOMIP,DOMS ', +! & DOMR(i),DOMZR(i),DOMIP(i),DOMS(i) +! end do +! HCHUANG: use new precipitation type to decide snow flag for LSM snow accumulation + + do i=1,im + if(doms(i) > 0.0 .or. domip(i) > 0.0) then + Sfcprop%srflag(i) = 1. + else + Sfcprop%srflag(i) = 0. + end if + enddo + endif + + if (Model%lssav) then + Diag%totprcp(:) = Diag%totprcp(:) + Diag%rain(:) + + if (Model%ldiag3d) then + Diag%dt3dt(:,:,6) = Diag%dt3dt(:,:,6) + (Stateout%gt0(:,:)-dtdt(:,:)) * frain + Diag%dq3dt(:,:,4) = Diag%dq3dt(:,:,4) + (Stateout%gq0(:,:,1)-dqdt(:,:,1)) * frain + endif + endif + +! --- ... estimate t850 for rain-snow decision + + t850(:) = Stateout%gt0(:,1) + + do k = 1, levs-1 + do i = 1, im + if (Statein%prsl(i,k) > p850 .and. Statein%prsl(i,k+1) <= p850) then + t850(i) = Stateout%gt0(i,k) - (Statein%prsl(i,k)-p850) / & + (Statein%prsl(i,k)-Statein%prsl(i,k+1)) * & + (Stateout%gt0(i,k)-Stateout%gt0(i,k+1)) + endif + enddo + enddo + +! --- ... lu: snow-rain detection is performed in land/sice module + + if (Model%cal_pre) then ! hchuang: new precip type algorithm defines srflag + Sfcprop%tprcp(:) = max(0.0, Diag%rain(:)) ! clu: rain -> tprcp + else + do i = 1, im + Sfcprop%tprcp(i) = max(0.0, Diag%rain(i) )! clu: rain -> tprcp + Sfcprop%srflag(i) = 0. ! clu: default srflag as 'rain' (i.e. 0) + if (t850(i) <= 273.16) then + Sfcprop%srflag(i) = 1. ! clu: set srflag to 'snow' (i.e. 1) + endif + enddo + endif + +! --- ... coupling insertion + + if (Model%cplflx .or. Model%do_sppt) then + do i = 1, im + if (t850(i) > 273.16) then + Coupling%rain_cpl(i) = Coupling%rain_cpl(i) + Diag%rain(i) + else + Coupling%snow_cpl(i) = Coupling%snow_cpl(i) + Diag%rain(i) + endif + enddo + endif + +! --- ... end coupling insertion + +!!! update surface diagnosis fields at the end of phys package +!!! this change allows gocart to use filtered wind fields +!!! + if (Model%lgocart) then + call sfc_diag (im, Statein%pgr, Stateout%gu0, Stateout%gv0, & + Stateout%gt0, Stateout%gq0, Sfcprop%tsfc, qss, & + Sfcprop%f10m, Diag%u10m, Diag%v10m, Sfcprop%t2m, & + Sfcprop%q2m, work3, evap, Sfcprop%ffmm, & + Sfcprop%ffhh, fm10, fh2) + + if (Model%lssav) then + Diag%tmpmax (:) = max(Diag%tmpmax (:),Sfcprop%t2m(:)) + Diag%tmpmin (:) = min(Diag%tmpmin (:),Sfcprop%t2m(:)) + Diag%spfhmax(:) = max(Diag%spfhmax(:),Sfcprop%q2m(:)) + Diag%spfhmin(:) = min(Diag%spfhmin(:),Sfcprop%q2m(:)) + endif + endif + +! --- ... total runoff is composed of drainage into water table and +! runoff at the surface and is accumulated in unit of meters + if (Model%lssav) then + tem = dtf * 0.001 + Diag%runoff(:) = Diag%runoff(:) + (drain(:)+runof(:)) * tem + Diag%srunoff(:) = Diag%srunoff(:) + runof(:) * tem + endif + +! --- ... xw: return updated ice thickness & concentration to global array + do i = 1, im + if (islmsk(i) == 2) then + Sfcprop%hice(i) = zice(i) + Sfcprop%fice(i) = cice(i) + Sfcprop%tisfc(i) = tice(i) + else + Sfcprop%hice(i) = 0.0 + Sfcprop%fice(i) = 0.0 + Sfcprop%tisfc(i) = Sfcprop%tsfc(i) + endif + enddo + +! --- ... return updated smsoil and stsoil to global arrays + Sfcprop%smc(:,:) = smsoil(:,:) + Sfcprop%stc(:,:) = stsoil(:,:) + Sfcprop%slc(:,:) = slsoil(:,:) + +! --- ... calculate column precipitable water "pwat" + Diag%pwat(:) = 0.0 + tem = dtf * 0.03456 / 86400.0 + do k = 1, levs + work1(:) = 0.0 + if (Model%ncld > 0) then + do ic = Model%ntcw, Model%ntcw+Model%ncld-1 + work1(:) = work1(:) + Stateout%gq0(:,k,ic) + enddo + endif + Diag%pwat(:) = Diag%pwat(:) + del(:,k)*(Stateout%gq0(:,k,1)+work1(:)) +! if (lprnt .and. i == ipr) write(0,*)' gq0=', +! &gq0(i,k,1),' qgrs=',qgrs(i,k,1),' work2=',work2(i),' k=',k + enddo + Diag%pwat(:) = Diag%pwat(:) * onebg + +! write(1000+me,*)' pwat=',pwat(i),'i=',i,', +! &' rain=',rain(i)*1000.0,' dqsfc1=',dqsfc1(i)*tem,' kdt=',kdt +! &,' e-p=',dqsfc1(i)*tem-rain(i)*1000.0 +! if (lprnt) write(0,*)' pwat=',pwat(ipr),', +! &' rain=',rain(ipr)*1000.0,' dqsfc1=',dqsfc1(ipr)*tem,' kdt=',kdt +! &,' e-p=',dqsfc1(ipr)*tem-rain(ipr)*1000.0 + +! +! if (lprnt .and. rain(ipr) > 5) call mpi_quit(5678) +! if (lat == 45) write(1000+me,*)' pwat=',pwat(1),' kdt=',kdt +! if (lprnt) then +! write(7000,*) ' endgu0=',gu0(ipr,:),' kdt=',kdt +! write(7000,*) ' endgv0=',gv0(ipr,:),' kdt=',kdt,' nnp=',nnp +! write(0,*) ' endgt0=',gt0(ipr,:),' kdt=',kdt +! write(0,*) ' endgq0=',gq0(ipr,:,1),' kdt=',kdt,' lat=',lat +! write(0,*) ' endgw0=',gq0(ipr,:,3),' kdt=',kdt,' lat=',lat +! endif + + if (Model%do_sppt) then + !--- radiation heating rate + Tbd%dtdtr(:,:) = Tbd%dtdtr(:,:) + dtdtc(:,:)*dtf + !--- change in total precip + Tbd%dtotprcp (:) = Diag%rain (:) - Tbd%dtotprcp(:) + !--- change in convective precip + Tbd%dcnvprcp (:) = Diag%rainc (:) - Tbd%dcnvprcp(:) + do i = 1, im + if (t850(i) > 273.16) then + !--- change in change in rain precip + Tbd%drain_cpl(i) = Diag%rain(i) - Tbd%drain_cpl(i) + else + !--- change in change in snow precip + Tbd%dsnow_cpl(i) = Diag%rain(i) - Tbd%dsnow_cpl(i) + endif + enddo + endif + + deallocate (clw) + if (Model%do_shoc) then + deallocate (qpl, qpi, ncpl, ncpi) + endif + if (allocated(cnvc)) deallocate(cnvc) + if (allocated(cnvw)) deallocate(cnvw) + +! deallocate (fscav, fswtr) +! +! if (lprnt) write(0,*)' end of gbphys maxu=', +! &maxval(gu0(1:im,1:levs)),' minu=',minval(gu0(1:im,1:levs)) +! &,' maxv=',maxval(gv0(1:im,1:levs)),' minv=', +! & minval(gv0(1:im,1:levs)),' kdt=',kdt,' lat=',lat,' nnp=',nnp +! if (lprnt) write(0,*)' end of gbphys gv0=',gv0(:,120:128) +! if (lprnt) write(0,*)' end of gbphys at kdt=',kdt, +! &' rain=',rain(ipr),' rainc=',rainc(ipr) +! if (lprnt) call mpi_quit(7) +! if (kdt > 2 ) call mpi_quit(70) + if (Model%ncld == 2) then ! For MGB double moment microphysics + + deallocate (qlcn, qicn, w_upi, cf_upi, CNV_MFD, CNV_PRC3, & + CNV_DQLDT, clcn, cnv_fice, cnv_ndrop, cnv_nice) + deallocate (qrn, qsnw, ncpr, ncps) + endif + + return +!................................... + end subroutine GFS_physics_driver +!----------------------------------- + + + subroutine moist_bud(im,ix,ix2,levs,me,kdt,grav,dtp,delp,rain, & + qv0,ql0,qi0,qv1,ql1,qi1,comp) +! nov 2016 - S. Moorthi - routine to compute local moisture budget + use machine, only : kind_phys + implicit none + character*10 :: comp + integer :: im,ix,ix2,levs,me,kdt + real (kind=kind_phys) :: grav, rain(im), dtp + real (kind=kind_phys), dimension(ix,levs) :: qv0,ql0,qi0,delp + real (kind=kind_phys), dimension(ix2,levs) :: qv1,ql1,qi1 + REAL (kind=kind_phys), dimension(im) :: sumq, sumqv, sumql, sumqi + integer :: i, k +! + sumqv(:) = 0.0 + sumql(:) = 0.0 + sumqi(:) = 0.0 + sumq (:) = 0.0 + do i=1,im + sumqv(:) = sumqv(:) + (qv1(:,k) - qv0(:,k)) * delp(:,k) + sumql(:) = sumql(:) + (ql1(:,k) - ql0(:,k)) * delp(:,k) + sumqi(:) = sumqi(:) + (qi1(:,k) - qi0(:,k)) * delp(:,k) + enddo + sumqv(:) = - sumqv(:) * (1.0/grav) + sumql(:) = - sumql(:) * (1.0/grav) + sumqi(:) = - sumqi(:) * (1.0/grav) + sumq (:) = sumqv(:) + sumql(:) + sumqi(:) + do i=1,im + write(1000+me,*)' in moist_bud:',' i=',i,' sumq=',sumq(i), & + ' sumqv=',sumqv(i),' sumql=',sumql(i),' sumqi=',sumqi(i), & + ' rain=',rain(i)*dtp,' kdt=',kdt,' component=',comp, & + ' qv:=',qv1(i,1),qv0(i,1),' ql=',ql1(i,1),ql0(i,1), & + ' qi=',qi1(i,1), qi0(i,1) +! if(sumq(i) > 100) then +! write(1000+me,*)' i=',i,' sumq=',sumq(i) +! write(1000+me,*)' qv1=',(qv1(i,k),k=1,levs) +! write(1000+me,*)' qv0=',(qv0(i,k),k=1,levs) +! write(1000+me,*)' ql1=',(ql1(i,k),k=1,levs) +! write(1000+me,*)' ql0=',(ql0(i,k),k=1,levs) +! write(1000+me,*)' qi1=',(qi1(i,k),k=1,levs) +! write(1000+me,*)' qi0=',(qi0(i,k),k=1,levs) +! endif + enddo + return + + end subroutine moist_bud +!> @} + +end module module_physics_driver diff --git a/GFS_layer/GFS_physics_driver.F90.study b/GFS_layer/GFS_physics_driver.F90.study new file mode 100644 index 000000000..68e0a6e1d --- /dev/null +++ b/GFS_layer/GFS_physics_driver.F90.study @@ -0,0 +1,2866 @@ +module module_physics_driver + + use machine, only: kind_phys + use physcons, only: con_cp, con_fvirt, con_g, con_rd, & + con_rv, con_hvap, con_hfus, & + con_rerth, con_pi, rhc_max, dxmin,& + dxinv, pa2mb, rlapse + use cs_conv, only: cs_convr + use ozne_def, only: levozp, oz_coeff, oz_pres + use h2o_def, only: levh2o, h2o_coeff, h2o_pres + use gfs_fv3_needs, only: get_prs_fv3, get_phi_fv3 + use module_nst_water_prop, only: get_dtzm_2d + use GFS_typedefs, only: GFS_statein_type, GFS_stateout_type, & + GFS_sfcprop_type, GFS_coupling_type, & + GFS_control_type, GFS_grid_type, & + GFS_tbd_type, GFS_cldprop_type, & + GFS_radtend_type, GFS_diag_type + + use zhaocarr_gscond, only: gscond_init, gscond_run + use zhaocarr_precpd, only: precpd_init, precpd_run + implicit none + + + !--- CONSTANT PARAMETERS + real(kind=kind_phys), parameter :: hocp = con_hvap/con_cp + real(kind=kind_phys), parameter :: qmin = 1.0e-10 + real(kind=kind_phys), parameter :: p850 = 85000.0 + real(kind=kind_phys), parameter :: epsq = 1.e-20 + real(kind=kind_phys), parameter :: hsub = con_hvap+con_hfus + real(kind=kind_phys), parameter :: czmin = 0.0001 ! cos(89.994) + real(kind=kind_phys), parameter :: onebg = 1.0/con_g + real(kind=kind_phys), parameter :: albdf = 0.06 + real(kind=kind_phys) tf, tcr, tcrf + parameter (tf=258.16, tcr=273.16, tcrf=1.0/(tcr-tf)) + + +!> GFS Physics Implementation Layer +!> @brief Layer that invokes individual GFS physics routines +!> @{ +!at tune step===========================================================! +! description: ! +! ! +! usage: ! +! ! +! call gbphys ! +! ! +! --- interface variables ! +! type(GFS_control_type), intent(in) :: Model ! +! type(GFS_statein_type), intent(inout) :: Statein ! +! type(GFS_stateout_type), intent(inout) :: Stateout ! +! type(GFS_sfcprop_type), intent(inout) :: Sfcprop ! +! type(GFS_coupling_type), intent(inout) :: Coupling ! +! type(GFS_grid_type), intent(in) :: Grid ! +! type(GFS_tbd_type), intent(inout :: Tbd ! +! type(GFS_cldprop_type), intent(inout) :: Cldprop ! +! type(GFS_radtend_type), intent(inout) :: Radtend ! +! type(GFS_diag_type), intent(inout) :: Diag ! +! ! +! subprograms called: ! +! ! +! get_prs, dcyc2t2_pre_rad (testing), dcyc2t3, sfc_diff, ! +! sfc_ocean,sfc_drv, sfc_land, sfc_sice, sfc_diag, moninp1, ! +! moninp, moninq1, moninq, gwdps, ozphys, get_phi, ! +! sascnv, sascnvn, rascnv, cs_convr, gwdc, shalcvt3,shalcv,! +! shalcnv, cnvc90, lrgscl, gsmdrive, gscond, precpd, ! +! progt2. ! +! ! +! ! +! program history log: ! +! 19xx - ncep mrf/gfs ! +! 2002 - s. moorthi modify and restructure and add Ferrier ! +! microphysics as an option ! +! 200x - h. juang modify (what?) ! +! nov 2004 - x. wu modify sea-ice model ! +! may 2005 - s. moorthi modify and restructure ! +! 2005 - s. lu modify to include noah lsm ! +! oct 2006 - h. wei modify lsm options to include both ! +! noah and osu lsms. ! +! 2006 - s. moorthi added a. johansson's convective gravity ! +! wave parameterization code ! +! 2007 - s. moorthi added j. han's modified pbl/sas options ! +! dec 2007 - xu li modified the operational version for ! +! nst model ! +! 2008 - s. moorthi applied xu li's nst model to new gfs ! +! mar 2008 - y.-t. hou added sunshine duration var (suntim) as ! +! an input/output argument. ! +! 2008 - jun wang added spfhmax/spfhmin as input/output. ! +! apr 2008 - y.-t. hou added lw sfc emissivity var (sfcemis), ! +! define the lw sfc dn/up fluxes in two forms: atmos! +! and ground. also changed sw sfc net flux direction! +! (positive) from ground -> atmos to the direction ! +! of atmos -> ground. recode the program and add ! +! program documentation block. +! 2008/ - s. moorthi and y.t. hou upgraded the code to more ! +! 2009 modern form and changed all the inputs to MKS units.! +! feb 2009 - s. moorthi upgraded to add Hochun's gocart changes ! +! jul 2009 - s. moorthi added rqtk for sela's semi-lagrangian ! +! aug 2009 - s. moorthi added j. han and h. pan updated shallow ! +! convection package ! +! sep 2009 - s. moorthi updated for the mcica (rrtm3) radiation ! +! dec 2010 - sarah lu lgocart added to input arg; ! +! compute dqdt_v if inline gocart is on ! +! feb 2011 - sarah lu add the option to update surface diag ! +! fields (t2m,q2m,u10m,v10m) at the end ! +! Jun 2011 - s. moorthi and Xu Li - updated the nst model ! +! ! +! sep 2011 - sarah lu correct dqdt_v calculations ! +! apr 2012 - henry juang add idea ! +! sep 2012 - s. moorthi merge with operational version ! +! Mar 2013 - Jun Wang set idea heating rate to tmp tendency ! +! May 2013 - Jun Wang tmp updated after idea phys ! +! Jun 2013 - s. moorthi corrected a bug in 3d diagnostics for T ! +! Aug 2013 - s. moorthi updating J. Whitekar's changes related ! +! to stochastic physics perturnbation ! +! Oct 2013 - Xingren Wu add dusfci/dvsfci ! +! Mar 2014 - Xingren Wu add "_cpl" for coupling ! +! Mar 2014 - Xingren Wu add "nir/vis beam and nir/vis diff" ! +! Apr 2014 - Xingren Wu add "NET LW/SW including nir/vis" ! +! Jan 2014 - Jun Wang merge Moorthi's gwdc change and H.Juang ! +! and F. Yang's energy conversion from GWD! +! jan 2014 - y-t hou revised sw sfc spectral component fluxes! +! for coupled mdl, added estimation of ocean albedo ! +! without ice contamination. ! +! Jun 2014 - Xingren Wu update net SW fluxes over the ocean ! +! (no ice contamination) ! +! Jul 2014 - Xingren Wu add Sea/Land/Ice Mask - slmsk_cpl ! +! Jul 2014 - s. moorthi merge with standalone gfs and cleanup ! +! Aug 2014 - s. moorthi add tracer fixer ! +! Sep 2014 - Sarah Lu disable the option to compute tracer ! +! scavenging in GFS phys (set fscav=0.) ! +! Dec 2014 - Jun Wang add cnvqc_v for gocart ! + +! ==================== defination of variables ==================== ! +! --- 2014 - D. Dazlich Added Chikira-Sugiyama (CS) convection ! +! as an option in opr GFS. ! +! Apr 2015 S. Moorthi Added CS scheme to NEMS/GSM ! +! Jun 2015 S. Moorthi Added SHOC to NEMS/GSM ! +! Aug 2015 - Xu Li change nst_fcst to be nstf_name ! +! and introduce depth mean SST ! +! Sep 2015 - Xingren Wu remove oro_cpl & slmsk_cpl ! +! Sep 2015 - Xingren Wu add sfc_cice ! +! Sep 2015 - Xingren Wu connect CICE output to sfc_cice ! +! Jan 2016 - P. Tripp NUOPC/GSM merge ! +! Mar 2016 - J. Han - add ncnvcld3d integer ! +! for convective cloudiness enhancement ! +! Mar 2016 - J. Han - change newsas & sashal to imfdeepcnv ! +! & imfshalcnv, respectively ! +! Mar 2016 F. Yang add pgr to rayleigh damping call ! +! Mar 2016 S. Moorthi add ral_ts ! +! Mar 2016 Ann Cheng add morrison 2m microphysics (gsfc) ! +! May 2016 S. Moorthi cleanup 2m microphysics implementation ! +! Jun 2016 X. Li change all nst_fld as inout ! +! jul 2016 S. Moorthi fix some bugs in shoc/2m microphysics ! +! au-nv2016a S. Moorthi CS with AW and connect with shoc/2m ! +! Dec 2016 Anning C. Add prognostic rain and snow with 2M ! +! +! ==================== end of description ===================== +! ==================== definition of variables ==================== ! + +!> @details This subroutine is the suite driver for the GFS atmospheric physics and surface. +!! It is responsible for calculating and applying tendencies of the atmospheric state +!! variables due to the atmospheric physics and due to the surface layer scheme. In addition, +!! this routine applies radiative heating rates that were calculated during the +!! antecedent call to the radiation scheme. Code within this subroutine is executed on the +!! physics sub-timestep. The sub-timestep loop is executed in the subroutine gloopb. +!! +!! \section general General Algorithm +!! -# Prepare input variables for calling individual parameterizations. +!! -# Using a two-iteration loop, calculate the state variable tendencies for the surface layer. +!! -# Calculate the state variable tendencies due to the PBL (vertical diffusion) scheme. +!! -# Calculate the state variable tendencies due to orographic gravity wave drag and Rayleigh damping. +!! -# Apply tendencies to the state variables calculated so far: +!! - for temperature: radiation, surface, PBL, oro. GWD, Rayleigh damping +!! - for momentum: surface, PBL, oro. GWD, Rayleigh damping +!! - for water vapor: surface, PBL +!! -# Calculate and apply the tendency of ozone. +!! -# Prepare input variables for physics routines that update the state variables within their subroutines. +!! -# If SHOC is active and is supposed to be called before convection, call it and update the state variables within. +!! -# Calculate and apply the state variable tendencies (within the subroutine) due to deep convection. +!! -# Calculate the state variable tendencies due to convective gravity wave drag and apply them afterwards. +!! -# Calculate and apply the state variable tendencies (within the subroutine) due to shallow convection. +!! -# If SHOC is active and is supposed to be called after convection, call it and update the state variables within. +!! -# Prepare for microphysics call by calculating preliminary variables. +!! -# If necessary, call the moist convective adjustment subroutine and update the state temperature and moisture variable within. +!! -# Calculate and apply the state variable tendencies (within the subroutine) due to microphysics. +!! -# Determine the precipitation type and update land surface properties if necessary. +!! -# Fill the output variables from the local variables as necessary and deallocate allocatable arrays. +!! \section detailed Detailed Algorithm +!! ## Prepare input variables for calling individual parameterizations. +!! Before calling any parameterizations, there is a section at the beginning of the subroutine for +!! preparing input arguments to the various schemes based on general input to the driver and initializing +!! variables used throughout the driver. +!! - General initialization: +!! - set a flag for running in debug mode and the horizontal index of the column to print +!! - calculate the pressure at layer centers, the exner function at layer centers and interfaces, +!! geopotential at layer centers and interfaces, and the layer-centered pressure difference +!! - calculate the ratio of dynamics time step to physics time step for applying tendencies +!! - initialize local tendency arrays to zero +!! - Radiation: +!! - adjust radiative fluxes and heating rates to the shorter physics time step (from the longer radiation time step), +!! unless idealized physics is true (lsidea) where radiative heating rates are set to 0 +!! - compute diagnostics from the radiation scheme needed for other schemes (e.g., downward longwave flux absorbed by the surface) +!! - accumulate the upward and downward longwave fluxes at the surface +!! - Surface: +!! - set NOAH and OSU scheme variables from gbphys input arguments and initialize local soil moisture variables +!! - set local sea ice variables from gbphys arguments +!! - set up A/O/I coupling variables from gbphys arguments +!! - PBL: +!! - set the number of tracers that are diffused vertically +!! - SHOC: +!! - determine the index of TKE (ntk) in the convectively transported tracer array (clw) +!! - allocate precipitation mixing ratio cloud droplet number concentration arrays +!! - Deep Convection: +!! - determine which tracers in the tracer input array undergo convective transport (valid only for the RAS and Chikira-Sugiyama schemes) and allocate a local convective transported tracer array (clw) +!! - apply an adjustment to the tracers from the dynamics +!! - calculate horizontal grid-related parameters needed for some parameterizations +!! - calculate the maxiumum cloud base updraft speed for the Chikira-Sugiyama scheme +!! - allocate array for cloud water and cloud cover (for non-RAS and non-Chikira-Sugiyama deep convective schemes) +!! - Shallow Convection: +!! - when using the Tiedtke shallow convection scheme with the stratus modifications, find the lowest +!! model level where a temperature inversion exists in the absence of CTEI +!! - Microphysics: +!! - for the Morrison (MGB) scheme, calculate 'FRLAND' if the grid point is over land +!! - allocate arrays associated with the Morrison scheme +!! - assign the local critical relative humidity variables from the gbphys arguments +!! - Gravity Wave Drag: +!! - calculate the deep convective cloud fraction at cloud top for the convective GWD scheme +!! . +!! ## Using a two-iteration loop, calculate the state variable tendencies for the surface layer. +!! - Each iteration of the loop calls the following: +!! - 'sfc_diff' to calculate surface exchange coefficients and near-surface wind +!! - surface energy balances routines are called regardless of surface type; the surface type is checked within each to determine whether the routine is "active" +!! - for the surface energy balance over the ocean, call 'sfc_nst' if NSST is on, otherwise, call 'sfc_ocean' +!! - for the surface energy balance over the land, call 'sfc_drv' for the NOAH model and 'sfc_land' for the OSU model +!! - for the surface energy balance over sea ice, call sfc_sice; if A/O/I coupling, call sfc_cice +!! - The initial iteration has flag_guess = F unless wind < 2 m/s; flag_iter = T +!! - After the initial iteration, flag_guess = F and flag_iter = F (unless wind < 2 m/s and over a land surface or an ocean surface with NSST on) +!! - The following actions are performed after the iteration to calculate surface energy balance: +!! - set surface output variables from their local values +!! - call 'sfc_diag' to calculate state variable values at 2 and 10 m as appropriate from near-surface model levels and the surface exchange coefficients +!! - if A/O/I coupling, set coupling variables from local variables and calculate the open water albedo +!! - finally, accumulate surface-related diagnostics and calculate the max/min values of T and q at 2 m height. +!! . +!! ## Calculate the state variable tendencies due to the PBL (vertical diffusion) scheme. +!! - Call the vertical diffusion scheme (PBL) based on the following logical flags: do_shoc, hybedmf, old_monin, mstrat +!! - the PBL scheme is expected to return tendencies of the state variables +!! - If A/O/I coupling and the surface is sea ice, overwrite some surface-related variables to their states before PBL was called +!! - For diagnostics, do the following: +!! - accumulate surface state variable tendencies and set the instantaneous values for output +!! - accumulate the temperature tendency due to the PBL scheme in dt3dt(:,:,3), subtracting out the radiative heating rate if necessary +!! - accumulate the u, v tendencies due to the PBL in du3dt(:,:,1:2) and dv3dt(:,:,1:2) +!! - accumulate the water vapor tendency due to the PBL in dq3dt(:,:,1) +!! - accumulate the ozone tendency in dq3dt(:,:,5) +!! . +!! ## Calculate the state variable tendencies due to orographic gravity wave drag and Rayleigh damping. +!! - Based on the variable nmtvr, unpack orographic gravity wave varibles from the hprime array +!! - Call 'gwdps' to calculate tendencies of u, v, T, and surface stress +!! - Accumulate gravity wave drag surface stresses. +!! - Accumulate change in u, v, and T due to oro. gravity wave drag in du3dt(:,:,2), dv3dt(:,:,2), and dt3dt(:,:,2) +!! - Call 'rayleigh_damp' to calculate tendencies to u, v, and T due to Rayleigh friction +!! . +!! ## Apply tendencies to the state variables calculated so far. +!! ## Calculate and apply the tendency of ozone. +!! - Call the convective adjustment scheme for IDEA +!! - Call 'ozphys_2015' or 'ozphys' depending on the value of pl_coeff, updating the ozone tracer within and outputing the tendency of ozone in dq3dt(:,:,6) +!! - Call 'h20phys' if necessary ("adaptation of NRL H20 phys for stratosphere and mesophere") +!! . +!! ## Prepare input variables for physics routines that update the state variables within their subroutines. +!! - If diagnostics is active, save the updated values of the state variables in 'dudt', 'dvdt', 'dTdt', and 'dqdt(:,:,1)' +!! - Call 'get_phi' to calculate geopotential from p, q, T +!! - Initialize the cloud water and ice portions of the convectively transported tracer array (clw) and (if the deep convective scheme is not RAS or Chikira-Sugiyama) the convective cloud water and cloud cover. +!! - If the dep convective scheme is RAS or Chikira-Sugiyama, fill the 'clw' array with tracers to be transported by convection +!! - Initialize 'ktop' and 'kbot' (to be modified by all convective schemes except Chikira-Sugiyama) +!! - Prepare for microphysics call (if cloud condensate is in the input tracer array): +!! - all schemes: calculate critical relative humidity +!! - Morrison et al. scheme (occasionally denoted MGB) (when ncld==2): set clw(:,:,1) to cloud ice and clw(:,:,2) to cloud liquid water +!! - Ferrier scheme (num_p3d==3): set the cloud water variable and separate hydrometeors into cloud ice, cloud water, and rain; set clw(:,:,1) to cloud ice and clw(:,:,2) to cloud liquid water +!! - Zhao-Carr scheme (num_p3d==4): calculate autoconversion coefficients from input constants and grid info; set set clw(:,:,1) to cloud liquid water +!! - otherwise: set autoconversion parameters like in Zhao-Carr and set critical relative humidity to 1 +!! . +!! ## If SHOC is active and is supposed to be called before convection, call it and update the state variables within. +!! - Prior to calling SHOC, prepare some microphysics variables: +!! - if Morrison et al. scheme: set 'skip_macro', fill clw(:,:,1,2) with cloud ice, liquid from the tracer array, and fill cloud droplet number concentration arrays from the input tracer array +!! - if Zhao-Carr scheme: initialize precip. mixing ratios to 0, fill clw(:,:,1,2) with cloud ice, liquid from the tracer array (as a function of temperature) +!! - Call 'shoc' (modifies state variables within the subroutine) +!! - Afterward, set updated cloud number concentrations in the tracer array from the updated 'ncpl' and 'ncpi' +!! . +!! ## Calculate and apply the state variable tendencies (within the subroutine) due to deep convection. +!! - Call deep convective scheme according to the parameter 'imfdeepcnv', 'ras', and 'cscnv'. +!! - if imfdeepcnv == 0, 1, or 2, no special processing is needed +!! - if the Chikira-Sugiyama scheme (cscnv), convert rain rate to accumulated rain (rain1) +!! - if RAS, initialize 'ccwfac', 'dlqfac', 'lmh', and revap before the call to 'rascnv' +!! - Zero out 'cld1d' (cloud work function calculated in non-RAS, non-Chikira-Sugiyama schemes) +!! - If 'lgocart', accumulate convective mass fluxes and convective cloud water +!! - Update tracers in the tracer array (gq0) due to convective transport (RAS, CS only) from the 'clw' array +!! - Calculate accumulated surface convective precip. for this physics time step (rainc) +!! - If necessary, accumulate cloud work function, convective precipitation, and convective mass fluxes; accumulate dt3dt(:,:,4), dq3dt(:,:,2), du3dt(:,:,3), dv3dt(:,:,3) as change in state variables due to deep convection +!! - If 'lgocart', repeat the accumulation of convective mass fluxes and convective cloud water; save convective tendency for water vapor in 'dqdt_v' +!! - If PDF-based clouds are active and Zhao-Carr microphysics, save convective cloud cover and water in 'phy_f3d' array +!! - otherwise, if non-PDF-based clouds and the "convective cloudiness enhancement" is active, save convective cloud water in 'phy_f3d' array +!! . +!! ## Calculate the state variable tendencies due to convective gravity wave drag and apply them afterwards. +!! - Calculate the average deep convective heating rate in the column to pass into 'gwdc' +!! - Call 'gwdc' to calculate tendencies of u, v due to convective GWD +!! - For diagnostics, accumulate the vertically-integrated change in u, v due to conv. GWD; accumulate change in u, v, due to conv. GWD in du3dt(:,:,4) and dv3dt(:,:,4) +!! - Calculate updated values of u, v, T using conv. GWD tendencies +!! . +!! ## Calculate and apply the state variable tendencies (within the subroutine) due to shallow convection. +!! - If diagnostics are active, set 'dtdt' and 'dqdt' to updated values of T and q before shallow convection +!! - If SHOC is not active, do the following: +!! - for the mass-flux shallow convection scheme (imfdeepcnv == 1), call 'shalcnv' +!! - for the scale- and aerosol-aware scheme (imfshalcnv == 2), call 'mfshalcnv' +!! - for either of the first two schemes, perform the following after the call: +!! - if Zhao-Carr microphysics with PDF-based clouds, save convective cloud water an cover in 'phy_f3d' +!! - if non-PDF-based clouds and convective cloudiness enhancement is active, save convective cloud water in 'phy_f3d' +!! - calculate shallow convective precip. and add it to convective precip; accumulate convective precip. +!! - for the Tiedtke scheme (imfshalcnv == 0), find the top level where shallow convection must stratosphere +!! - if using Moorthi's approach to stratus, call 'shalcv' +!! - otherwise, call 'shalcvt3' +!! - for diagnostics, accumulate the change in water vapor due to shallow convection and save in dqdt_v if 'lgocart'; +!! - save the change in T and q due to shallow convection in dt3dt(:,:,5) and dq3dt(:,:,3); reset dtdt and dqdt to the updated values of T, q after shallow Convection +!! - if 'clw' is not partitioned into ice/water, set 'clw(ice)' to zero +!! - If SHOC is active (and shocaftcnv) +!! - if Morrison et al. scheme: set 'skip_macro' and fill cloud droplet number concentration arrays from the input tracer array +!! - initialize precip. mixing ratios to 0 +!! - call 'shoc' (modifies state variables within the subroutine) +!! - afterward, set updated cloud number concentrations in the tracer array from the updated 'ncpl' and 'ncpi' +!! . +!! ## Prepare for microphysics call by calculating preliminary variables. +!! - For Morrison et al. microphysics, set cloud water and ice arrays to the convecitvely transported values +!! - For Ferrier microphysics, combine convectively transported cloud water and ice with column rain and save in cloud water array +!! - calculate and save ice fraction and rain fraction in phy_f3d(1),(2) +!! - For Zhao-Carr, combine convectively transported cloud water and ice into the cloud water array +!! - Otherwise, combine convectively transported cloud water and ice into the convectively transported cloud water +!! - Call 'cnvc90'; a "legacy routine which determines convective clouds"; outputs 'acv','acvb','acvt','cv','cvb','cvt' +!! . +!! ## If necessary, call the moist convective adjustment subroutine and update the state temperature and moisture variable within. +!! - Updates T, q, 'rain1', cloud water array +!! - Accumulate convective precip +!! - For diagnostics, accumulate the change in T, q due to moist convective adjustment; reset 'dtdt' and 'dqdt' to updated T, q before call to microphysics +!! . +!! ## Calculate and apply the state variable tendencies (within the subroutine) due to microphysics. +!! - If 'lgocart', calculate instantaneous moisture tendency in dqdt_v +!! - If no cloud microphysics (ncld == 0), call 'lrgscl' to update T, q and output large scale precipitation and cloud water +!! - Otherwise, a more advanced microphysics scheme is called (which scheme depends on values of 'num_p3d','do_shoc',and 'ncld') +!! - Ferrier scheme (num_p3d == 3): +!! - calculate droplet number concentration and minimum large ice fraction +!! - call 'gsmdrive' (modifies T, q, cloud water, 'f_ice', 'f_rain', 'f_rimef', 'rain1') +!! - Zhao-Carr-Sundqvist scheme (num_p3d == 4): +!! - if non-PDF-based clouds: +!! - if 'do_shoc', call 'precpd_shoc' (precpd modified for SHOC) +!! - else, call 'gscond' (grid-scale condensation/evaporation); updates water vapor, cloud water, temperature +!! - call 'precpd'; updates water vapor, cloud water, temperature and outputs precip., snow ratio, and rain water path +!! - for PDF-based clouds: +!! - call 'gscondp' followed by 'precpdp' (similar arguments to gscond, precpd above) +!! - Morrison et al. scheme (ncld = 2): +!! - if 'do_shoc', set clw(1),(2) from updated values; set phy_f3d(:,:,1) from phy_f3d(:,:,ntot3d-2) +!! - else, set clw(1),(2) from updated values; set phy_f3d(:,:,1) to cloud cover from previous time step + convective cloud water from convective scheme +!! - call 'm_micro_driver'; updates water vapor, temperature, droplet number concentrations, cloud cover +!! - Combine large scale and convective precip. +!! - For diagnostics, accumulate total surface precipitation and accumulate change in T and q due to microphysics in dt3dt(:,:,6) and dq3dt(:,:,4) +!! . +!! ## Determine the precipitation type and update land surface properties if necessary. +!! - If 'cal_pre', diagnose the surface precipitation type +!! - call 'calpreciptype'; set snow flag to 1 if snow or sleet, 0 otherwise +!! - For rain/snow decision, calculate temperature at 850 hPa (\f$T_{850}\f$) +!! - If not 'cal_pre', set snow flag to 1 if \f$T_{850}\f$ is below freezing +!! - For coupling, accumulate rain if \f$T_{850}\f$ is above freezing, otherwise accumulate snow +!! - If using the OSU land model, accumulate surface snow depth if \f$T_{850}\f$ is below freezing and not over an ocean surface +!! - call 'progt2' (canopy and soil moisture?) and set the soil liquid water equal to soil total water +!! - if 'lgocart', call 'sfc_diag' to update near-surface state variables (this "allows gocart to use filtered wind fields") +!! - If necessary (lssav), update the 2m max/min values of T and q +!! - If necessary (lssav), accumulate total runoff and surface runoff. +!! . +!! ## Fill the output variables from the local variables as necessary and deallocate allocatable arrays. +!! - Set global sea ice thickness and concentration as well as the temperature of the sea ice +!! - Set global soil moisture variables +!! - Calculate precipitable water and water vapor mass change due to all physics for the column +!! - Deallocate arrays for SHOC scheme, deep convective scheme, and Morrison et al. microphysics + + + public GFS_physics_driver + + CONTAINS +!******************************************************************************************* + + subroutine GFS_physics_driver & + (Model, Statein, Stateout, Sfcprop, Coupling, & + Grid, Tbd, Cldprop, Radtend, Diag) + + implicit none +! +! --- interface variables + type(GFS_control_type), intent(in) :: Model + type(GFS_statein_type), intent(inout) :: Statein + type(GFS_stateout_type), intent(inout) :: Stateout + type(GFS_sfcprop_type), intent(inout) :: Sfcprop + type(GFS_coupling_type), intent(inout) :: Coupling + type(GFS_grid_type), intent(in) :: Grid + type(GFS_tbd_type), intent(inout) :: Tbd + type(GFS_cldprop_type), intent(inout) :: Cldprop + type(GFS_radtend_type), intent(inout) :: Radtend + type(GFS_diag_type), intent(inout) :: Diag +! +! --- local variables + + !--- INTEGER VARIABLES + integer :: me, lprint, ipr, ix, im, levs, ntrac, nvdiff, kdt + integer :: i, kk, ic, k, n, k1, iter, levshcm, tracers, & + trc_shft, tottracer, num2, num3, nshocm, nshoc, ntk + + integer, dimension(size(Grid%xlon,1)) :: & + kbot, ktop, kcnv, soiltyp, vegtype, kpbl, slopetyp, kinver, & + lmh, levshc, islmsk, & + !--- coupling inputs for physics + islmsk_cice + + !--- LOGICAL VARIABLES + logical :: lprnt, revap, do_awdd + + logical, dimension(size(Grid%xlon,1)) :: & + flag_iter, flag_guess, invrsn, skip_macro, & + !--- coupling inputs for physics + flag_cice + + logical, dimension(Model%ntrac-Model%ncld+2,2) :: & + otspt + + !--- REAL VARIABLES + real(kind=kind_phys) :: & + dtf, dtp, rhbbot, rhbtop, rhpbl, frain, tem, tem1, tem2, & + xcosz_loc, zsea1, zsea2, eng0, eng1, dpshc, & + !--- experimental for shoc sub-stepping + dtshoc + + real(kind=kind_phys), dimension(size(Grid%xlon,1)) :: & + ccwfac, garea, dlength, cumabs, cice, zice, tice, gflx, & + rain1, raincs, snowmt, cd, cdq, qss, dusfcg, dvsfcg, dusfc1, & + dvsfc1, dtsfc1, dqsfc1, rb, drain, cld1d, evap, hflx, & + stress, t850, ep1d, gamt, gamq, sigmaf, oc, theta, gamma, & + sigma, elvmax, wind, work1, work2, runof, xmu, fm10, fh2, & + tsurf, tx1, tx2, ctei_r, evbs, evcw, trans, sbsno, snowc, & + frland, adjsfcdsw, adjsfcnsw, adjsfcdlw, adjsfculw, & + adjnirbmu, adjnirdfu, adjvisbmu, adjvisdfu, adjnirbmd, & + adjnirdfd, adjvisbmd, adjvisdfd, gabsbdlw, xcosz, tseal, & + snohf, dlqfac, work3, ctei_rml, cldf, domr, domzr, domip, & + doms, psautco_l, prautco_l, ocalnirbm_cpl, ocalnirdf_cpl, & + ocalvisbm_cpl, ocalvisdf_cpl, dtzm, temrain1, fscav, fswtr, & + !--- coupling inputs for physics + dtsfc_cice, dqsfc_cice, dusfc_cice, dvsfc_cice, ulwsfc_cice, & + tisfc_cice, tsea_cice, hice_cice, fice_cice, & + !--- for CS-convection + wcbmax + + real(kind=kind_phys), dimension(size(Grid%xlon,1),4) :: & + oa4, clx + + real(kind=kind_phys), dimension(size(Grid%xlon,1),Model%lsoil) :: & + smsoil, stsoil, slsoil + + real(kind=kind_phys), dimension(size(Grid%xlon,1),Model%levs) :: & + del, rhc, dtdt, dudt, dvdt, gwdcu, gwdcv, dtdtc, rainp, & + ud_mf, dd_mf, dt_mf, prnum, dkt, sigmatot, sigmafrac + + !--- GFDL modification for FV3 + real(kind=kind_phys), dimension(size(Grid%xlon,1),Model%levs+1) ::& + del_gz + + real(kind=kind_phys), dimension(size(Grid%xlon,1),Model%levs,Model%ntrac) :: & + dqdt + + real(kind=kind_phys), dimension(size(Grid%xlon,1),Model%levs,Model%nctp) :: & + sigmai, vverti + + real(kind=kind_phys), dimension(size(Grid%xlon,1),Model%levs,oz_coeff+5) :: & + dq3dt_loc + + !--- ALLOCATABLE ELEMENTS + !--- in clw, the first two varaibles are cloud water and ice. + !--- from third to ntrac are convective transportable tracers, + !--- third being the ozone, when ntrac=3 (valid only with ras) + !--- Anning Cheng 9/21/2016 leave a hook here for diagnosed snow, + !--- rain, and their number + real(kind=kind_phys), allocatable :: & + clw(:,:,:), qpl(:,:), qpi(:,:), ncpl(:,:), ncpi(:,:), & + qrn(:,:), qsnw(:,:), ncpr(:,:), ncps(:,:), cnvc(:,:), & + cnvw(:,:) + !--- for 2 M microphysics + real(kind=kind_phys), allocatable, dimension(:) :: & + cn_prc, cn_snr + real(kind=kind_phys), allocatable, dimension(:,:) :: & + qlcn, qicn, w_upi, cf_upi, CNV_MFD, CNV_PRC3, CNV_DQLDT, & + CLCN, CNV_FICE, CNV_NDROP, CNV_NICE + +! +! +!===> ... begin here + + me = Model%me + ix = size(Grid%xlon,1) + im = size(Grid%xlon,1) + levs = Model%levs + ntrac = Model%ntrac + dtf = Model%dtf + dtp = Model%dtp + kdt = Model%kdt + lprnt = Model%lprnt + nvdiff = ntrac ! vertical diffusion of all tracers! + ipr = min(im,10) + +!zhang: Morrison_MP_pre + do i = 1, im + if(nint(Sfcprop%slmsk(i)) == 1) then + frland(i) = 1.0 + else + frland(i) = 0. + endif + enddo +! +! --- ... figure out number of extra tracers +! +!zhang: GFS_physics_pre + tottracer = 0 ! no convective transport of tracers + if (Model%trans_trac .or. Model%cscnv) then + if (Model%ntcw > 0) then + if (Model%ntoz < Model%ntcw) then + trc_shft = Model%ntcw + Model%ncld - 1 + else + trc_shft = Model%ntoz + endif + elseif (Model%ntoz > 0) then + trc_shft = Model%ntoz + else + trc_shft = 1 + endif + + tracers = Model%ntrac - trc_shft + tottracer = tracers + if (Model%ntoz > 0) tottracer = tottracer + 1 ! ozone is added separately + endif +!zhang: shoc_pre + if (Model%ntke > 0) ntk = Model%ntke - trc_shft + 3 + +! if (lprnt) write(0,*)' trans_trac=',trans_trac,' tottracer=', & +! write(0,*)' trans_trac=',trans_trac,' tottracer=', & +! & tottracer,' trc_shft=',trc_shft,' kdt=',kdt +! &, ntrac-ncld+2,' clstp=',clstp,' kdt=',kdt +! &,' ntk=',ntk,' lat=',lat + + skip_macro = .false. + +!zhang: GFS_physics_pre + allocate ( clw(ix,levs,tottracer+2) ) + if (Model%imfdeepcnv >= 0 .or. Model%imfshalcnv > 0) then + allocate (cnvc(ix,levs), cnvw(ix,levs)) + endif +! +! --- set initial quantities for stochastic physics deltas +!zhang:sppt_pre + if (Model%do_sppt) then + Tbd%dtdtr = 0.0 + Tbd%dtotprcp (:) = Diag%rain (:) + Tbd%dcnvprcp (:) = Diag%rainc (:) + Tbd%drain_cpl (:) = Coupling%rain_cpl (:) + Tbd%dsnow_cpl (:) = Coupling%snow_cpl (:) + endif + +!zhang: do_shoc=false + if (Model%do_shoc) then + allocate (qpl(im,levs), qpi(im,levs), ncpl(im,levs), ncpi(im,levs)) + do k=1,levs + do i=1,im + ncpl(i,k) = 0.0 + ncpi(i,k) = 0.0 + enddo + enddo + endif + +!zhang:ncld=1; not used in GFS OP + if (Model%ncld == 2) then ! For MGB double moment microphysics + allocate (qlcn(im,levs), qicn(im,levs), w_upi(im,levs), & + cf_upi(im,levs), CNV_MFD(im,levs), CNV_PRC3(im,levs), & + CNV_DQLDT(im,levs), clcn(im,levs), cnv_fice(im,levs), & + cnv_ndrop(im,levs), cnv_nice(im,levs)) + allocate (cn_prc(im), cn_snr(im)) + allocate (qrn(im,levs), qsnw(im,levs), ncpr(im,levs), ncps(im,levs)) + else + allocate (qlcn(1,1), qicn(1,1), w_upi(1,1), cf_upi(1,1), & + CNV_MFD(1,1), CNV_PRC3(1,1), CNV_DQLDT(1,1), & + clcn(1,1), cnv_fice(1,1), cnv_ndrop(1,1), cnv_nice(1,1)) + endif + +!zhang: where is it defined? +#ifdef GFS_HYDRO + call get_prs(im, ix, levs, ntrac, Statein%tgrs, Statein%qgrs, & + Model%thermodyn_id, Model%sfcpress_id, & + Model%gen_coord_hybrid, Statein%prsi, Statein%prsik, & + Statein%prsl, Statein%prslk, Statein%phii, Statein%phil, del) +#else +!GFDL Adjust the geopotential height hydrostatically in a way consistent with FV3 discretization + call get_prs_fv3 (ix, levs, ntrac, Statein%phii, Statein%prsi, & + Statein%tgrs, Statein%qgrs, del, del_gz) +#endif +! + +!zhang: zhao_carr_pre + rhbbot = Model%crtrh(1) + rhpbl = Model%crtrh(2) + rhbtop = Model%crtrh(3) +! +! --- ... frain=factor for centered difference scheme correction of rain amount. + + frain = dtf / dtp + + do i = 1, im + sigmaf(i) = max( Sfcprop%vfrac(i),0.01 ) + islmsk(i) = nint(Sfcprop%slmsk(i)) + + if (islmsk(i) == 2) then + if (Model%isot == 1) then + soiltyp(i) = 16 + else + soiltyp(i) = 9 + endif + if (Model%ivegsrc == 1) then + vegtype(i) = 15 + elseif(Model%ivegsrc == 2) then + vegtype(i) = 13 + endif + slopetyp(i) = 9 + else + soiltyp(i) = int( Sfcprop%stype(i)+0.5 ) + vegtype(i) = int( Sfcprop%vtype(i)+0.5 ) + slopetyp(i) = int( Sfcprop%slope(i)+0.5 ) !! clu: slope -> slopetyp + endif +! --- ... xw: transfer ice thickness & concentration from global to local variables + zice(i) = Sfcprop%hice(i) + cice(i) = Sfcprop%fice(i) + tice(i) = Sfcprop%tisfc(i) +! +!GFDL work1(i) = (log(coslat(i) / (nlons(i)*latr)) - dxmin) * dxinv +! work1(i) = (log(Grid%dx(i)) - dxmin) * dxinv + work1(i) = (log(Grid%area(i)) - dxmin) * dxinv + work1(i) = max(0.0, min(1.0,work1(i))) + work2(i) = 1.0 - work1(i) + Diag%psurf(i) = Statein%pgr(i) + work3(i) = Statein%prsik(i,1) / Statein%prslk(i,1) +!GFDL tem1 = con_rerth * (con_pi+con_pi)*coslat(i)/nlons(i) +!GFDL tem2 = con_rerth * con_pi / latr +!GFDL garea(i) = tem1 * tem2 + tem1 = Grid%dx(i) + tem2 = Grid%dx(i) + garea(i) = Grid%area(i) + dlength(i) = sqrt( tem1*tem1+tem2*tem2 ) + cldf(i) = Model%cgwf(1)*work1(i) + Model%cgwf(2)*work2(i) + wcbmax(i) = Model%cs_parm(1)*work1(i) + Model%cs_parm(2)*work2(i) + enddo +! +!zhang:cplflx=.false. + if (Model%cplflx) then + do i = 1, im + islmsk_cice(i) = nint(Coupling%slimskin_cpl(i)) + flag_cice(i) = (islmsk_cice(i) == 4) + + ulwsfc_cice(i) = Coupling%ulwsfcin_cpl(i) + dusfc_cice(i) = Coupling%dusfcin_cpl(i) + dvsfc_cice(i) = Coupling%dvsfcin_cpl(i) + dtsfc_cice(i) = Coupling%dtsfcin_cpl(i) + dqsfc_cice(i) = Coupling%dqsfcin_cpl(i) + tisfc_cice(i) = Sfcprop%tisfc(i) + tsea_cice(i) = Sfcprop%tsfc(i) + fice_cice(i) = Sfcprop%fice(i) + hice_cice(i) = Sfcprop%hice(i) + enddo + endif + +! --- ... transfer soil moisture and temperature from global to local variables +!zhang sfc_drv_pre, sfc_ice_pre + smsoil(:,:) = Sfcprop%smc(:,:) + stsoil(:,:) = Sfcprop%stc(:,:) + slsoil(:,:) = Sfcprop%slc(:,:) !! clu: slc -> slsoil + +!zhang: GFS_physics_pre + dudt(:,:) = 0. + dvdt(:,:) = 0. + dtdt(:,:) = 0. + dtdtc(:,:) = 0. + dqdt(:,:,:) = 0. + +! --- ... initialize dtdt with heating rate from dcyc2 + +! --- ... adjust mean radiation fluxes and heating rates to fit for +! faster model time steps. +! sw: using cos of zenith angle as scaling factor +! lw: using surface air skin temperature as scaling factor + +!zhang: pre_rad=.false. + if (Model%pre_rad) then + call dcyc2t3_pre_rad & +! --- inputs: + ( Model%solhr, Model%slag, Model%sdec, Model%cdec, Grid%sinlat, & + Grid%coslat, Grid%xlon, Radtend%coszen, Sfcprop%tsfc, & + Statein%tgrs(1,1), Statein%tgrs(1,1), Coupling%sfcdsw, & + Coupling%sfcnsw, Coupling%sfcdlw, Radtend%htrsw, Radtend%htrlw,& + Coupling%nirbmui, Coupling%nirdfui, Coupling%visbmui, & + Coupling%visdfui, Coupling%nirbmdi, Coupling%nirdfdi, & + Coupling%visbmdi, Coupling%visdfdi, ix, im, levs, & +! --- input/output: + dtdt, & +! --- outputs: + adjsfcdsw, adjsfcnsw, adjsfcdlw, adjsfculw, xmu, xcosz, & + adjnirbmu, adjnirdfu, adjvisbmu, adjvisdfu, & + adjnirbmd, adjnirdfd, adjvisbmd, adjvisdfd & + ) + + else +!zhang: dcyc2t3_run in dcyc2.f + call dcyc2t3 & +! --- inputs: + ( Model%solhr, Model%slag, Model%sdec, Model%cdec, Grid%sinlat, & + Grid%coslat, Grid%xlon, Radtend%coszen, Sfcprop%tsfc, & + Statein%tgrs(1,1), Radtend%tsflw, Radtend%semis, & + Coupling%sfcdsw, Coupling%sfcnsw, Coupling%sfcdlw, & + Radtend%htrsw, Radtend%swhc, Radtend%htrlw, Radtend%lwhc, & + Coupling%nirbmui, Coupling%nirdfui, Coupling%visbmui, & + Coupling%visdfui, Coupling%nirbmdi, Coupling%nirdfdi, & + Coupling%visbmdi, Coupling%visdfdi, ix, im, levs, & +! --- input/output: + dtdt, dtdtc, & +! --- outputs: + adjsfcdsw, adjsfcnsw, adjsfcdlw, adjsfculw, xmu, xcosz, & + adjnirbmu, adjnirdfu, adjvisbmu, adjvisdfu, & + adjnirbmd, adjnirdfd, adjvisbmd, adjvisdfd & + ) + +! +! save temp change due to radiation - need for sttp stochastic physics +!--------------------------------------------------------------------- + endif +! +!zhang: lsidea=.false. ! idea convective adjustment + if (Model%lsidea) then !idea jw + dtdt(:,:) = 0. + endif + +! --- convert lw fluxes for land/ocean/sea-ice models +! note: for sw: adjsfcdsw and adjsfcnsw are zenith angle adjusted downward/net fluxes. +! for lw: adjsfcdlw is (sfc temp adjusted) downward fluxe with no emiss effect. +! adjsfculw is (sfc temp adjusted) upward fluxe including emiss effect. +! one needs to be aware that that the absorbed downward lw flux (used by land/ocean +! models as downward flux) is not the same as adjsfcdlw but a value reduced by +! the factor of emissivity. however, the net effects are the same when seeing +! it either above the surface interface or below. +! +! - flux above the interface used by atmosphere model: +! down: adjsfcdlw; up: adjsfculw = sfcemis*sigma*T**4 + (1-sfcemis)*adjsfcdlw +! net = up - down = sfcemis * (sigma*T**4 - adjsfcdlw) +! - flux below the interface used by lnd/oc/ice models: +! down: sfcemis*adjsfcdlw; up: sfcemis*sigma*T**4 +! net = up - down = sfcemis * (sigma*T**4 - adjsfcdlw) + +! --- ... define the downward lw flux absorbed by ground + + gabsbdlw(:) = Radtend%semis(:) * adjsfcdlw(:) +!zhang: false in GFS_typedefs, true in GFS_driver + if (Model%lssav) then ! --- ... accumulate/save output variables + +! --- ... sunshine duration time is defined as the length of time (in mdl output +! interval) that solar radiation falling on a plane perpendicular to the +! direction of the sun >= 120 w/m2 + + do i = 1, im + if ( xcosz(i) >= czmin ) then ! zenth angle > 89.994 deg + tem1 = adjsfcdsw(i) / xcosz(i) + if ( tem1 >= 120.0 ) then + Diag%suntim(i) = Diag%suntim(i) + dtf + endif + endif + enddo + +! --- ... sfc lw fluxes used by atmospheric model are saved for output + + if (Model%cplflx) then + do i = 1, im + if (flag_cice(i)) adjsfculw(i) = ulwsfc_cice(i) + enddo + endif + Diag%dlwsfc(:) = Diag%dlwsfc(:) + adjsfcdlw(:)*dtf + Diag%ulwsfc(:) = Diag%ulwsfc(:) + adjsfculw(:)*dtf + Diag%psmean(:) = Diag%psmean(:) + Statein%pgr(:)*dtf ! mean surface pressure + + if (Model%ldiag3d) then + if (Model%lsidea) then + Diag%dt3dt(:,:,1) = Diag%dt3dt(:,:,1) + Radtend%lwhd(:,:,1)*dtf + Diag%dt3dt(:,:,2) = Diag%dt3dt(:,:,2) + Radtend%lwhd(:,:,2)*dtf + Diag%dt3dt(:,:,3) = Diag%dt3dt(:,:,3) + Radtend%lwhd(:,:,3)*dtf + Diag%dt3dt(:,:,4) = Diag%dt3dt(:,:,4) + Radtend%lwhd(:,:,4)*dtf + Diag%dt3dt(:,:,5) = Diag%dt3dt(:,:,5) + Radtend%lwhd(:,:,5)*dtf + Diag%dt3dt(:,:,6) = Diag%dt3dt(:,:,6) + Radtend%lwhd(:,:,6)*dtf + else + do k = 1, levs + Diag%dt3dt(:,k,1) = Diag%dt3dt(:,k,1) + Radtend%htrlw(:,k)*dtf + Diag%dt3dt(:,k,2) = Diag%dt3dt(:,k,2) + Radtend%htrsw(:,k)*dtf*xmu(:) + enddo + endif + endif + endif ! end if_lssav_block +!zhang: GFS_physics_pre + kcnv(:) = 0 +!zhang: GFS_PBL_generic_pre + kinver(:) = levs + +!zhang:old_phys (non-OP) + invrsn(:) = .false. + tx1(:) = 0.0 + tx2(:) = 10.0 + ctei_r(:) = 10.0 + +! Only used for old shallow convection with mstrat=.true. + + if (((Model%imfshalcnv == 0 .and. Model%shal_cnv) .or. Model%old_monin) & + .and. Model%mstrat) then + ctei_rml(:) = Model%ctei_rm(1)*work1(:) + Model%ctei_rm(2)*work2(:) + do k = 1, levs/2 + do i = 1, im + if (Statein%prsi(i,1)-Statein%prsi(i,k+1) < 0.35*Statein%prsi(i,1) & + .and. (.not. invrsn(i))) then + tem = (Statein%tgrs(i,k+1)-Statein%tgrs(i,k)) / (Statein%prsl(i,k)-Statein%prsl(i,k+1)) + + if (((tem > 0.00010) .and. (tx1(i) < 0.0)) .or. & + ((tem-abs(tx1(i)) > 0.0) .and. (tx2(i) < 0.0))) then + invrsn(i) = .true. + + if (Statein%qgrs(i,k,1) > Statein%qgrs(i,k+1,1)) then + tem1 = Statein%tgrs(i,k+1) + hocp*max(Statein%qgrs(i,k+1,1),qmin) + tem2 = Statein%tgrs(i,k) + hocp*max(Statein%qgrs(i,k,1),qmin) + + tem1 = tem1 / Statein%prslk(i,k+1) - tem2 / Statein%prslk(i,k) + +! --- ... (cp/l)(deltathetae)/(deltatwater) > ctei_rm -> conditon for CTEI + ctei_r(i) = (1.0/hocp)*tem1/(Statein%qgrs(i,k+1,1)-Statein%qgrs(i,k,1) & + + Statein%qgrs(i,k+1,Model%ntcw)-Statein%qgrs(i,k,Model%ntcw)) + else + ctei_r(i) = 10 + endif + + if ( ctei_rml(i) > ctei_r(i) ) then + kinver(i) = k + else + kinver(i) = levs + endif + endif + + tx2(i) = tx1(i) + tx1(i) = tem + endif + enddo + enddo + endif + +! --- ... lu: initialize flag_guess, flag_iter, tsurf + + tsurf(:) = Sfcprop%tsfc(:) + flag_guess(:) = .false. + flag_iter(:) = .true. + drain(:) = 0.0 + ep1d(:) = 0.0 + runof(:) = 0.0 + hflx(:) = 0.0 + evap(:) = 0.0 + evbs(:) = 0.0 + evcw(:) = 0.0 + trans(:) = 0.0 + sbsno(:) = 0.0 + snowc(:) = 0.0 + snohf(:) = 0.0 + Diag%zlvl(:) = Statein%phil(:,1) * onebg + Diag%smcwlt2(:) = 0.0 + Diag%smcref2(:) = 0.0 + +! --- ... lu: iter-loop over (sfc_diff,sfc_drv,sfc_ocean,sfc_sice) + + do iter = 1, 2 + +! --- ... surface exchange coefficients +! +! if (lprnt) write(0,*)' tsea=',tsea(ipr),' tsurf=',tsurf(ipr),iter + + call sfc_diff (im,Statein%pgr, Statein%ugrs, Statein%vgrs, & + Statein%tgrs, Statein%qgrs, Diag%zlvl, & + Sfcprop%snowd, Sfcprop%tsfc, Sfcprop%zorl, cd, & + cdq, rb, Statein%prsl(1,1), work3, islmsk, stress, & + Sfcprop%ffmm, Sfcprop%ffhh, Sfcprop%uustar, & + wind, Tbd%phy_f2d(1,Model%num_p2d), fm10, fh2, & + sigmaf, vegtype, Sfcprop%shdmax, Model%ivegsrc, & + tsurf, flag_iter, Model%redrag) + +! --- ... lu: update flag_guess + + do i = 1, im + if (iter == 1 .and. wind(i) < 2.0) then + flag_guess(i) = .true. + endif + enddo + + if (Model%nstf_name(1) > 0) then + + do i = 1, im + if ( islmsk(i) == 0 ) then + tem = (Sfcprop%oro(i)-Sfcprop%oro_uf(i)) * rlapse + tseal(i) = Sfcprop%tsfc(i) + tem + tsurf(i) = tsurf(i) + tem + endif + enddo + + call sfc_nst (im, Model%lsoil, Statein%pgr, Statein%ugrs, & + Statein%vgrs, Statein%tgrs, Statein%qgrs, & + Sfcprop%tref, cd, cdq, Statein%prsl(1,1), work3, & + islmsk, Grid%xlon, Grid%sinlat, stress, & + Radtend%semis, gabsbdlw, adjsfcnsw, Sfcprop%tprcp, & + dtf, kdt, Model%solhr, xcosz, & + Tbd%phy_f2d(1,Model%num_p2d), flag_iter, & + flag_guess, Model%nstf_name, lprnt, ipr, & +! --- Input/output + tseal, tsurf, Sfcprop%xt, Sfcprop%xs, Sfcprop%xu, & + Sfcprop%xv, Sfcprop%xz, Sfcprop%zm, Sfcprop%xtts, & + Sfcprop%xzts, Sfcprop%dt_cool, Sfcprop%z_c, & + Sfcprop%c_0, Sfcprop%c_d, Sfcprop%w_0, Sfcprop%w_d,& + Sfcprop%d_conv, Sfcprop%ifd, Sfcprop%qrain, & +! --- outputs: + qss, gflx, Diag%cmm, Diag%chh, evap, hflx, ep1d) + +! if (lprnt) print *,' tseaz2=',tseal(ipr),' tref=',tref(ipr), +! & ' dt_cool=',dt_cool(ipr),' dt_warm=',2.0*xt(ipr)/xz(ipr), +! & ' kdt=',kdt + + do i = 1, im + if ( islmsk(i) == 0 ) then + tsurf(i) = tsurf(i) - (Sfcprop%oro(i)-Sfcprop%oro_uf(i)) * rlapse + endif + enddo + +! --- ... run nsst model ... --- + + if (Model%nstf_name(1) > 1) then + zsea1 = 0.001*real(Model%nstf_name(4)) + zsea2 = 0.001*real(Model%nstf_name(5)) + call get_dtzm_2d (Sfcprop%xt, Sfcprop%xz, Sfcprop%dt_cool, & + Sfcprop%z_c, Sfcprop%slmsk, zsea1, zsea2, & + im, 1, dtzm) + do i = 1, im + if ( islmsk(i) == 0 ) then + Sfcprop%tsfc(i) = max(271.2,Sfcprop%tref(i) + dtzm(i)) - & + (Sfcprop%oro(i)-Sfcprop%oro_uf(i))*rlapse + endif + enddo + endif + +! if (lprnt) print *,' tseaz2=',tsea(ipr),' tref=',tref(ipr), & +! & ' dt_cool=',dt_cool(ipr),' dt_warm=',dt_warm(ipr),' kdt=',kdt + + else + +! --- ... surface energy balance over ocean + + call sfc_ocean & +! --- inputs: + (im, Statein%pgr, Statein%ugrs, Statein%vgrs, Statein%tgrs, & + Statein%qgrs, Sfcprop%tsfc, cd, cdq, Statein%prsl(1,1), & + work3, islmsk, Tbd%phy_f2d(1,Model%num_p2d), flag_iter, & +! --- outputs: + qss, Diag%cmm, Diag%chh, gflx, evap, hflx, ep1d) + + endif ! if ( nstf_name(1) > 0 ) then + +! if (lprnt) write(0,*)' sfalb=',sfalb(ipr),' ipr=',ipr & +! &, ' weasd=',weasd(ipr),' snwdph=',snwdph(ipr) & +! &, ' tprcp=',tprcp(ipr),' kdt=',kdt,' iter=',iter & +! &,' tseabefland=',tsea(ipr) + +! --- ... surface energy balance over land +! + if (Model%lsm == 1) then ! noah lsm call + +! if (lprnt) write(0,*)' tsead=',tsea(ipr),' tsurf=',tsurf(ipr),iter +! &,' pgr=',pgr(ipr),' sfcemis=',sfcemis(ipr) + + call sfc_drv & +! --- inputs: + (im, Model%lsoil, Statein%pgr, Statein%ugrs, Statein%vgrs, & + Statein%tgrs, Statein%qgrs, soiltyp, vegtype, sigmaf, & + Radtend%semis, gabsbdlw, adjsfcdsw, adjsfcnsw, dtf, & + Sfcprop%tg3, cd, cdq, Statein%prsl(1,1), work3, DIag%zlvl, & + islmsk, Tbd%phy_f2d(1,Model%num_p2d), slopetyp, & + Sfcprop%shdmin, Sfcprop%shdmax, Sfcprop%snoalb, & + Radtend%sfalb, flag_iter, flag_guess, Model%isot, & + Model%ivegsrc, & +! --- in/outs: + Sfcprop%weasd, Sfcprop%snowd, Sfcprop%tsfc, Sfcprop%tprcp, & + Sfcprop%srflag, smsoil, stsoil, slsoil, Sfcprop%canopy, & + trans, tsurf, Sfcprop%zorl, & +! --- outputs: + Sfcprop%sncovr, qss, gflx, drain, evap, hflx, ep1d, runof, & + Diag%cmm, Diag%chh, evbs, evcw, sbsno, snowc, Diag%soilm, & + snohf, Diag%smcwlt2, Diag%smcref2, Diag%wet1) + +! if (lprnt) write(0,*)' tseae=',tsea(ipr),' tsurf=',tsurf(ipr),iter +! &,' phy_f2d=',phy_f2d(ipr,num_p2d) + + endif + +! if (lprnt) write(0,*)' tseabeficemodel =',tsea(ipr),' me=',me & +! &, ' kdt=',kdt + +! --- ... surface energy balance over seaice + + if (Model%cplflx) then + do i = 1, im + if (flag_cice(i)) then + islmsk (i) = islmsk_cice(i) + endif + enddo + endif + + call sfc_sice & +! --- inputs: + (im, Model%lsoil, Statein%pgr, Statein%ugrs, Statein%vgrs, & + Statein%tgrs, Statein%qgrs, dtf, Radtend%semis, gabsbdlw, & + adjsfcnsw, adjsfcdsw, Sfcprop%srflag, cd, cdq, & + Statein%prsl(1,1), work3, islmsk, & + Tbd%phy_f2d(1,Model%num_p2d), flag_iter, Model%mom4ice, & + Model%lsm, lprnt, ipr, & +! --- input/outputs: + zice, cice, tice, Sfcprop%weasd, Sfcprop%tsfc, & + Sfcprop%tprcp, stsoil, ep1d, & +! --- outputs: + Sfcprop%snowd, qss, snowmt, gflx, Diag%cmm, Diag%chh, evap, & + hflx) + + if (Model%cplflx) then + do i = 1, im + if (flag_cice(i)) then + islmsk(i) = nint(Sfcprop%slmsk(i)) + endif + enddo + + call sfc_cice & +! --- inputs: + (im, Statein%ugrs, Statein%vgrs, Statein%tgrs, Statein%qgrs, & + cd, cdq, Statein%prsl(1,1), work3, islmsk_cice, & + Tbd%phy_f2d(1,Model%num_p2d),flag_iter, dqsfc_cice, & + dtsfc_cice, & +! --- outputs: + qss, Diag%cmm, Diag%chh, evap, hflx) + endif + +! --- ... lu: update flag_iter and flag_guess + + do i = 1, im + flag_iter(i) = .false. + flag_guess(i) = .false. + + if (iter == 1 .and. wind(i) < 2.0) then + if ((islmsk(i) == 1) .or. ((islmsk(i) == 0) .and. & + (Model%nstf_name(1) > 0))) then + flag_iter(i) = .true. + endif + endif + +! if(islmsk(i) == 1 .and. iter == 1) then +! if (wind(i) < 2.0) flag_iter(i) = .true. +! elseif (islmsk(i) == 0 .and. iter == 1 & +! & .and. nstf_name(1) > 0) then +! if (wind(i) < 2.0) flag_iter(i) = .true. +! endif + enddo + + enddo ! end iter_loop +!zhang: GFS_surface_generic_post (for instantaneous diagnostics) + Diag%epi(:) = ep1d(:) +!zhang:dcyc2t3_post + Diag%dlwsfci(:) = adjsfcdlw(:) + Diag%ulwsfci(:) = adjsfculw(:) + Diag%uswsfci(:) = adjsfcdsw(:) - adjsfcnsw(:) + Diag%dswsfci(:) = adjsfcdsw(:) +!zhang: GFS_surface_generic_post (for instantaneous diagnostics) + Diag%gfluxi(:) = gflx(:) +!zhang: GFS_diagnostics_pre, see GFS_diagnostics.F + Diag%t1(:) = Statein%tgrs(:,1) + Diag%q1(:) = Statein%qgrs(:,1,1) + Diag%u1(:) = Statein%ugrs(:,1) + Diag%v1(:) = Statein%vgrs(:,1) + +! --- ... update near surface fields +!zhang: sfc_diag_run + call sfc_diag (im, Statein%pgr, Statein%ugrs, Statein%vgrs, & + Statein%tgrs, Statein%qgrs, Sfcprop%tsfc, qss, & + Sfcprop%f10m, Diag%u10m, Diag%v10m, & + Sfcprop%t2m, Sfcprop%q2m, work3, evap, & + Sfcprop%ffmm, Sfcprop%ffhh, fm10, fh2) +!zhang: only used in rascnv + Tbd%phy_f2d(:,Model%num_p2d) = 0.0 + + if (Model%cplflx) then + Coupling%dlwsfci_cpl (:) = adjsfcdlw(:) + Coupling%dswsfci_cpl (:) = adjsfcdsw(:) + Coupling%dlwsfc_cpl (:) = Coupling%dlwsfc_cpl(:) + adjsfcdlw(:)*dtf + Coupling%dswsfc_cpl (:) = Coupling%dswsfc_cpl(:) + adjsfcdsw(:)*dtf + Coupling%dnirbmi_cpl (:) = adjnirbmd(:) + Coupling%dnirdfi_cpl (:) = adjnirdfd(:) + Coupling%dvisbmi_cpl (:) = adjvisbmd(:) + Coupling%dvisdfi_cpl (:) = adjvisdfd(:) + Coupling%dnirbm_cpl (:) = Coupling%dnirbm_cpl(:) + adjnirbmd(:)*dtf + Coupling%dnirdf_cpl (:) = Coupling%dnirdf_cpl(:) + adjnirdfd(:)*dtf + Coupling%dvisbm_cpl (:) = Coupling%dvisbm_cpl(:) + adjvisbmd(:)*dtf + Coupling%dvisdf_cpl (:) = Coupling%dvisdf_cpl(:) + adjvisdfd(:)*dtf + Coupling%nlwsfci_cpl (:) = adjsfcdlw(:) - adjsfculw(:) + Coupling%nlwsfc_cpl (:) = Coupling%nlwsfc_cpl(:) + Coupling%nlwsfci_cpl(:)*dtf + Coupling%t2mi_cpl (:) = Sfcprop%t2m(:) + Coupling%q2mi_cpl (:) = Sfcprop%q2m(:) + Coupling%u10mi_cpl (:) = Diag%u10m(:) + Coupling%v10mi_cpl (:) = Diag%v10m(:) + Coupling%tsfci_cpl (:) = Sfcprop%tsfc(:) + Coupling%psurfi_cpl (:) = Statein%pgr(:) + +! --- estimate mean albedo for ocean point without ice cover and apply +! them to net SW heat fluxes + + do i = 1, im + if (islmsk(i) /= 1) then ! not a land point +! --- compute open water albedo + xcosz_loc = max( 0.0, min( 1.0, xcosz(i) )) + ocalnirdf_cpl(i) = 0.06 + ocalnirbm_cpl(i) = max(albdf, 0.026/(xcosz_loc**1.7+0.065) & + & + 0.15 * (xcosz_loc-0.1) * (xcosz_loc-0.5) & + & * (xcosz_loc-1.0)) + ocalvisdf_cpl(i) = 0.06 + ocalvisbm_cpl(i) = ocalnirbm_cpl(i) + + Coupling%nnirbmi_cpl(i) = adjnirbmd(i)-adjnirbmd(i)*ocalnirbm_cpl(i) + Coupling%nnirdfi_cpl(i) = adjnirdfd(i)-adjnirdfd(i)*ocalnirdf_cpl(i) + Coupling%nvisbmi_cpl(i) = adjvisbmd(i)-adjvisbmd(i)*ocalvisbm_cpl(i) + Coupling%nvisdfi_cpl(i) = adjvisdfd(i)-adjvisdfd(i)*ocalvisdf_cpl(i) + else + Coupling%nnirbmi_cpl(i) = adjnirbmd(i) - adjnirbmu(i) + Coupling%nnirdfi_cpl(i) = adjnirdfd(i) - adjnirdfu(i) + Coupling%nvisbmi_cpl(i) = adjvisbmd(i) - adjvisbmu(i) + Coupling%nvisdfi_cpl(i) = adjvisdfd(i) - adjvisdfu(i) + endif + Coupling%nswsfci_cpl(i) = Coupling%nnirbmi_cpl(i) + Coupling%nnirdfi_cpl(i) + & + Coupling%nvisbmi_cpl(i) + Coupling%nvisdfi_cpl(i) + Coupling%nswsfc_cpl(i) = Coupling%nswsfc_cpl(i) + Coupling%nswsfci_cpl(i)*dtf + Coupling%nnirbm_cpl(i) = Coupling%nnirbm_cpl(i) + Coupling%nnirbmi_cpl(i)*dtf + Coupling%nnirdf_cpl(i) = Coupling%nnirdf_cpl(i) + Coupling%nnirdfi_cpl(i)*dtf + Coupling%nvisbm_cpl(i) = Coupling%nvisbm_cpl(i) + Coupling%nvisbmi_cpl(i)*dtf + Coupling%nvisdf_cpl(i) = Coupling%nvisdf_cpl(i) + Coupling%nvisdfi_cpl(i)*dtf + enddo + endif + + if (Model%lssav) then + Diag%gflux(:) = Diag%gflux(:) + gflx(:) * dtf + Diag%evbsa(:) = Diag%evbsa(:) + evbs(:) * dtf + Diag%evcwa(:) = Diag%evcwa(:) + evcw(:) * dtf + Diag%transa(:) = Diag%transa(:) + trans(:) * dtf + Diag%sbsnoa(:) = Diag%sbsnoa(:) + sbsno(:) * dtf + Diag%snowca(:) = Diag%snowca(:) + snowc(:) * dtf + Diag%snohfa(:) = Diag%snohfa(:) + snohf(:) * dtf + Diag%ep(:) = Diag%ep(:) + ep1d(:) * dtf + + Diag%tmpmax(:) = max(Diag%tmpmax(:),Sfcprop%t2m(:)) + Diag%tmpmin(:) = min(Diag%tmpmin(:),Sfcprop%t2m(:)) + + Diag%spfhmax(:) = max(Diag%spfhmax(:),Sfcprop%q2m(:)) + Diag%spfhmin(:) = min(Diag%spfhmin(:),Sfcprop%q2m(:)) + endif + +!!!!!!!!!!!!!!!!!Commented by Moorthi on July 18, 2012 !!!!!!!!!!!!!!!!!!! +! do i = 1, im +! --- ... compute coefficient of evaporation in evapc +! +! if (evapc(i) > 1.0e0) evapc(i) = 1.0e0 +! --- ... over snow cover or ice or sea, coef of evap =1.0e0 +! if (weasd(i) > 0.0 .or. slmsk(i) /= 1.0) evapc(i) = 1.0e0 +! enddo +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +! --- ... Boundary Layer and Free atmospheic turbulence parameterization + +! if (lprnt) write(0,*)' tsea3=',tsea(ipr),' slmsk=',slmsk(ipr) & +! &, ' kdt=',kdt,' evap=',evap(ipr) +! if (lprnt) write(0,*)' dtdtb=',(dtdt(ipr,k),k=1,15) + +! do i = 1, im +! if (islmsk(i) == 0) then +! oro_land(i) = 0.0 +! else +! oro_land(i) = oro(i) +! endif +! enddo + +! write(0,*)' before monin clstp=',clstp,' kdt=',kdt,' lat=',lat + + if (Model%do_shoc) then + call moninshoc(ix, im, levs, ntrac, Model%ntcw, dvdt, dudt, dtdt, dqdt, & + Statein%ugrs, Statein%vgrs, Statein%tgrs, Statein%qgrs, & + Tbd%phy_f3d(1,1,Model%ntot3d-1), prnum, Model%ntke, & + Statein%prsik(1,1), rb, Sfcprop%zorl, Diag%u10m, & + Diag%v10m, Sfcprop%ffmm, Sfcprop%ffhh, Sfcprop%tsfc, hflx,& + evap, stress, wind, kpbl, Statein%prsi, del, Statein%prsl,& + Statein%prslk, Statein%phii, Statein%phil, dtp, dusfc1, & + dvsfc1, dtsfc1, dqsfc1, dkt, Diag%hpbl, kinver, & + Model%xkzm_m, Model%xkzm_h, Model%xkzm_s, lprnt, ipr, me) + else + if (Model%hybedmf) then + call moninedmf(ix, im, levs, nvdiff, Model%ntcw, dvdt, dudt, dtdt, dqdt,& + Statein%ugrs, Statein%vgrs, Statein%tgrs, Statein%qgrs, & + Radtend%htrsw, Radtend%htrlw, xmu, Statein%prsik(1,1), & + rb, Sfcprop%zorl, Diag%u10m, Diag%v10m, Sfcprop%ffmm, & + Sfcprop%ffhh, Sfcprop%tsfc, qss, hflx, evap, stress, & + wind, kpbl, Statein%prsi, del, Statein%prsl, & + Statein%prslk, Statein%phii, Statein%phil, dtp, & + Model%dspheat, dusfc1, dvsfc1, dtsfc1, dqsfc1, Diag%hpbl,& + gamt, gamq, dkt, kinver, Model%xkzm_m, Model%xkzm_h, & + Model%xkzm_s, lprnt, ipr) +! if (lprnt) write(0,*)' dtdtm=',(dtdt(ipr,k),k=1,15) +! if (lprnt) write(0,*)' dqdtm=',(dqdt(ipr,k,1),k=1,15) + elseif (.not. Model%old_monin) then + call moninq(ix, im, levs, nvdiff, Model%ntcw, dvdt, dudt, dtdt, dqdt, & + Statein%ugrs, Statein%vgrs, Statein%tgrs, Statein%qgrs, & + Radtend%htrsw, Radtend%htrlw, xmu, Statein%prsik(1,1), rb,& + Sfcprop%ffmm, Sfcprop%ffhh, Sfcprop%tsfc, qss, hflx, evap,& + stress, wind, kpbl, Statein%prsi, del, Statein%prsl, & + Statein%prslk, Statein%phii, Statein%phil, dtp, & + Model%dspheat, dusfc1, dvsfc1, dtsfc1, dqsfc1, Diag%hpbl, & + gamt, gamq, dkt, kinver, Model%xkzm_m, Model%xkzm_h, & + Model%xkzm_s, lprnt, ipr) + else + if (Model%mstrat) then + call moninp1(ix, im, levs, nvdiff, dvdt, dudt, dtdt, dqdt, & + Statein%ugrs, Statein%vgrs, Statein%tgrs, Statein%qgrs,& + Statein%prsik(1,1), rb, Sfcprop%ffmm, Sfcprop%ffhh, & + Sfcprop%tsfc, qss, hflx, evap, stress, wind, kpbl, & + Statein%prsi, del, Statein%prsl, Statein%prslk, & + Statein%phii, Statein%phil, dtp, dusfc1, dvsfc1, & + dtsfc1, dqsfc1, Diag%hpbl, gamt, gamq, dkt, kinver, & + Model%xkzm_m, Model%xkzm_h) + else + call moninp(ix, im, levs, nvdiff, dvdt, dudt, dtdt, dqdt, & + Statein%ugrs, Statein%vgrs, Statein%tgrs, Statein%qgrs, & + Statein%prsik(1,1), rb, Sfcprop%ffmm, Sfcprop%ffhh, & + Sfcprop%tsfc, qss, hflx, evap, stress, wind, kpbl, & + Statein%prsi, del, Statein%prsl, Statein%phii, & + Statein%phil, dtp, dusfc1, dvsfc1, dtsfc1, dqsfc1, & + Diag%hpbl, gamt, gamq, dkt, Model%xkzm_m, Model%xkzm_h) + endif + + endif ! end if_hybedmf + endif ! end if_do_shoc + + if (Model%cplflx) then + do i = 1, im + if (flag_cice(i)) then + cice(i) = fice_cice(i) + Sfcprop%tsfc(i) = tsea_cice(i) + dusfc1(i) = dusfc_cice(i) + dvsfc1(i) = dvsfc_cice(i) + dqsfc1(i) = dqsfc_cice(i) + dtsfc1(i) = dtsfc_cice(i) + endif + enddo + endif + +! if (lprnt) then +! write(0,*) ' dusfc1=',dusfc1(ipr),' kdt=',kdt,' lat=',lat +! write(0,*)' dtsfc1=',dtsfc1(ipr) +! write(0,*)' dqsfc1=',dqsfc1(ipr) +! write(0,*)' dtdtc=',(dtdt(ipr,k),k=1,15) +! write(0,*)' dqdtc=',(dqdt(ipr,k,1),k=1,15) +! print *,' dudtm=',dudt(ipr,:) +! endif + +! --- ... coupling insertion + + if (Model%cplflx) then + Coupling%dusfc_cpl (:) = Coupling%dusfc_cpl(:) + dusfc1(:)*dtf + Coupling%dvsfc_cpl (:) = Coupling%dvsfc_cpl(:) + dvsfc1(:)*dtf + Coupling%dtsfc_cpl (:) = Coupling%dtsfc_cpl(:) + dtsfc1(:)*dtf + Coupling%dqsfc_cpl (:) = Coupling%dqsfc_cpl(:) + dqsfc1(:)*dtf + Coupling%dusfci_cpl(:) = dusfc1(:) + Coupling%dvsfci_cpl(:) = dvsfc1(:) + Coupling%dtsfci_cpl(:) = dtsfc1(:) + Coupling%dqsfci_cpl(:) = dqsfc1(:) + endif +!-------------------------------------------------------lssav if loop ---------- + if (Model%lssav) then + Diag%dusfc (:) = Diag%dusfc(:) + dusfc1(:)*dtf + Diag%dvsfc (:) = Diag%dvsfc(:) + dvsfc1(:)*dtf + Diag%dtsfc (:) = Diag%dtsfc(:) + dtsfc1(:)*dtf + Diag%dqsfc (:) = Diag%dqsfc(:) + dqsfc1(:)*dtf + Diag%dusfci(:) = dusfc1(:) + Diag%dvsfci(:) = dvsfc1(:) + Diag%dtsfci(:) = dtsfc1(:) + Diag%dqsfci(:) = dqsfc1(:) +! if (lprnt) then +! write(0,*)' dusfc=',dusfc(ipr),' dusfc1=',dusfc1(ipr),' dtf=', +! & dtf,' kdt=',kdt,' lat=',lat +! endif + + if (Model%ldiag3d) then + if (Model%lsidea) then + Diag%dt3dt(:,:,3) = Diag%dt3dt(:,:,3) + dtdt(:,:)*dtf + else + do k = 1, levs + do i = 1, im + tem = dtdt(i,k) - (Radtend%htrlw(i,k)+Radtend%htrsw(i,k)*xmu(i)) + Diag%dt3dt(i,k,3) = Diag%dt3dt(i,k,3) + tem*dtf + enddo + enddo + endif + Diag%du3dt(:,:,1) = Diag%du3dt(:,:,1) + dudt(:,:) * dtf + Diag%du3dt(:,:,2) = Diag%du3dt(:,:,2) - dudt(:,:) * dtf + Diag%dv3dt(:,:,1) = Diag%dv3dt(:,:,1) + dvdt(:,:) * dtf + Diag%dv3dt(:,:,2) = Diag%dv3dt(:,:,2) - dvdt(:,:) * dtf +! update dqdt_v to include moisture tendency due to vertical diffusion +! if (lgocart) then +! do k = 1, levs +! do i = 1, im +! dqdt_v(i,k) = dqdt(i,k,1) * dtf +! enddo +! enddo +! endif + do k = 1, levs + do i = 1, im + tem = dqdt(i,k,1) * dtf + Diag%dq3dt(i,k,1) = Diag%dq3dt(i,k,1) + tem + enddo + enddo + if (Model%ntoz > 0) then + Diag%dq3dt(:,:,5) = Diag%dq3dt(:,:,5) + dqdt(i,k,Model%ntoz) * dtf + endif + endif + + endif ! end if_lssav +!-------------------------------------------------------lssav if loop ---------- +! +! Orographic gravity wave drag parameterization +! --------------------------------------------- +!zhang:gwdps_pre + if (Model%nmtvr == 14) then ! current operational - as of 2014 + oc(:) = Sfcprop%hprime(:,2) + oa4(:,1) = Sfcprop%hprime(:,3) + oa4(:,2) = Sfcprop%hprime(:,4) + oa4(:,3) = Sfcprop%hprime(:,5) + oa4(:,4) = Sfcprop%hprime(:,6) + clx(:,1) = Sfcprop%hprime(:,7) + clx(:,2) = Sfcprop%hprime(:,8) + clx(:,3) = Sfcprop%hprime(:,9) + clx(:,4) = Sfcprop%hprime(:,10) + theta(:) = Sfcprop%hprime(:,11) + gamma(:) = Sfcprop%hprime(:,12) + sigma(:) = Sfcprop%hprime(:,13) + elvmax(:) = Sfcprop%hprime(:,14) + elseif (Model%nmtvr == 10) then + oc(:) = Sfcprop%hprime(:,2) + oa4(:,1) = Sfcprop%hprime(:,3) + oa4(:,2) = Sfcprop%hprime(:,4) + oa4(:,3) = Sfcprop%hprime(:,5) + oa4(:,4) = Sfcprop%hprime(:,6) + clx(:,1) = Sfcprop%hprime(:,7) + clx(:,2) = Sfcprop%hprime(:,8) + clx(:,3) = Sfcprop%hprime(:,9) + clx(:,4) = Sfcprop%hprime(:,10) + elseif (Model%nmtvr == 6) then + oc(:) = Sfcprop%hprime(:,2) + oa4(:,1) = Sfcprop%hprime(:,3) + oa4(:,2) = Sfcprop%hprime(:,4) + oa4(:,3) = Sfcprop%hprime(:,5) + oa4(:,4) = Sfcprop%hprime(:,6) + clx(:,1) = 0.0 + clx(:,2) = 0.0 + clx(:,3) = 0.0 + clx(:,4) = 0.0 + else + oc = 0 ; oa4 = 0 ; clx = 0 ; theta = 0 ; gamma = 0 ; sigma = 0 + elvmax = 0 + + endif ! end if_nmtvr + +! write(0,*)' before gwd clstp=',clstp,' kdt=',kdt,' lat=',lat + call gwdps(im, ix, im, levs, dvdt, dudt, dtdt, & + Statein%ugrs, Statein%vgrs, Statein%tgrs, & + Statein%qgrs, kpbl, Statein%prsi, del, & + Statein%prsl, Statein%prslk, Statein%phii, & + Statein%phil, dtp, kdt, & + Sfcprop%hprime(1,1), oc, oa4, clx, theta, & + sigma, gamma, elvmax, dusfcg, dvsfcg, & + con_g, con_cp, con_rd, con_rv, Model%lonr, & + Model%nmtvr, Model%cdmbgwd, me, lprnt,ipr) + +! if (lprnt) print *,' dudtg=',dudt(ipr,:) + + if (Model%lssav) then + Diag%dugwd(:) = Diag%dugwd(:) + dusfcg(:)*dtf + Diag%dvgwd(:) = Diag%dvgwd(:) + dvsfcg(:)*dtf + +! if (lprnt) print *,' dugwd=',dugwd(ipr),' dusfcg=',dusfcg(ipr) +! if (lprnt) print *,' dvgwd=',dvgwd(ipr),' dvsfcg=',dvsfcg(ipr) + + if (Model%ldiag3d) then + Diag%du3dt(:,:,2) = Diag%du3dt(:,:,2) + dudt(:,:) * dtf + Diag%dv3dt(:,:,2) = Diag%dv3dt(:,:,2) + dvdt(:,:) * dtf + Diag%dt3dt(:,:,2) = Diag%dt3dt(:,:,2) + dtdt(:,:) * dtf + endif + endif + +! Rayleigh damping near the model top +!zhang: in NEMS ral_ts=10., in comfv3 =0.0 + if( .not. Model%lsidea .and. Model%ral_ts > 0.0) then + call rayleigh_damp(im, ix, im, levs, dvdt, dudt, dtdt, & + Statein%ugrs, Statein%vgrs, dtp, con_cp, & + Model%levr, Statein%pgr, Statein%prsl, & + Model%prslrd0, Model%ral_ts) + endif + +! if (lprnt) then +! write(0,*)' tgrs1=',(tgrs(ipr,ik),k=1,10) +! write(0,*)' dtdt=',(dtdt(ipr,ik),k=1,10) +! endif + +!zhang: GFS_physics_update_state + Stateout%gt0(:,:) = Statein%tgrs(:,:) + dtdt(:,:) * dtp + Stateout%gu0(:,:) = Statein%ugrs(:,:) + dudt(:,:) * dtp + Stateout%gv0(:,:) = Statein%vgrs(:,:) + dvdt(:,:) * dtp + Stateout%gq0(:,:,:) = Statein%qgrs(:,:,:) + dqdt(:,:,:) * dtp + +! if (lprnt) then +! write(7000,*)' ugrs=',ugrs(ipr,:) +! &,' lat=',lat,' kdt=',kdt,' me=',me +! write(7000,*)' dudt*dtp=',dudt(ipr,:)*dtp +! write(7000,*)' vgrs=',vgrs(ipr,:) +! write(7000,*)' dvdt*dtp ',dvdt(ipr,:)*dtp +! endif +! if(lprnt) write(1000+me,*)' gq0w=',gq0(ipr,:,ntcw) +! if(lprnt) write(0,*)' gq0i=',gq0(ipr,:,ntiw) + + if (Model%lsidea) then ! idea convective adjustment + call ideaca_up(Statein%prsi,Stateout%gt0,ix,im,levs+1) + endif + +! --- ... ozone physics + + if ((Model%ntoz > 0) .and. (ntrac >= Model%ntoz)) then + if (oz_coeff > 4) then + call ozphys_2015 (ix, im, levs, levozp, dtp, & + Stateout%gq0(1,1,Model%ntoz), & + Stateout%gq0(1,1,Model%ntoz), & + Stateout%gt0, oz_pres, Statein%prsl, & + Tbd%ozpl, oz_coeff, del, Model%ldiag3d, & + dq3dt_loc(1,1,6), me) + if (Model%ldiag3d) then + Diag%dq3dt(:,:,6) = dq3dt_loc(:,:,6) + Diag%dq3dt(:,:,7) = dq3dt_loc(:,:,7) + Diag%dq3dt(:,:,8) = dq3dt_loc(:,:,8) + Diag%dq3dt(:,:,9) = dq3dt_loc(:,:,9) + endif + else + call ozphys (ix, im, levs, levozp, dtp, & + Stateout%gq0(1,1,Model%ntoz), & + Stateout%gq0(1,1,Model%ntoz), & + Stateout%gt0, oz_pres, Statein%prsl, & + Tbd%ozpl, oz_coeff, del, Model%ldiag3d, & + dq3dt_loc(1,1,6), me) + if (Model%ldiag3d) then + Diag%dq3dt(:,:,6) = dq3dt_loc(:,:,6) + Diag%dq3dt(:,:,7) = dq3dt_loc(:,:,7) + Diag%dq3dt(:,:,8) = dq3dt_loc(:,:,8) + Diag%dq3dt(:,:,9) = dq3dt_loc(:,:,9) + endif + endif + endif + + if (Model%h2o_phys) then + call h2ophys (ix, im, levs, levh2o, dtp, Stateout%gq0(1,1,1), & + Stateout%gq0(1,1,1), h2o_pres, Statein%prsl, & + Tbd%h2opl, h2o_coeff, Model%ldiag3d, & + dq3dt_loc(1,1,1), me) + endif + +! --- ... to side-step the ozone physics + +! if (ntrac >= 2) then +! do k = 1, levs +! gq0(k,ntoz) = qgrs(k,ntoz) +! enddo +! endif + +! if (lprnt) then +! write(0,*) ' levs=',levs,' jcap=',jcap,' dtp',dtp & +! &, ' slmsk=',slmsk(ilon,ilat),' kdt=',kdt +! print *,' rann=',rann,' ncld=',ncld,' iq=',iq,' lat=',lat +! print *,' pgr=',pgr +! print *,' del=',del(ipr,:) +! print *,' prsl=',prsl(ipr,:) +! print *,' prslk=',prslk(ipr,:) +! print *,' rann=',rann(ipr,1) +! write(0,*)' gt0=',gt0(ipr,:) & +! &, ' kdt=',kdt,' xlon=',xlon(ipr),' xlat=',xlat(ipr) +! print *,' dtdt=',dtdt(ipr,:) +! print *,' gu0=',gu0(ipr,:) +! print *,' gv0=',gv0(ipr,:) +! write(0,*) ' gt0=',(gt0(ipr,k),k=1,levs),' kdt=',kdt +! write(0,*)' gq0=',(gq0(ipr,k,1),k=1,levs),' lat=',lat +! write(0,*)' gq0i2=',(gq0(ipr,k,ntiw),k=1,levs),' lat=',lat +! write(0,*)' gq1=',(gq0(ipr,k,ntcw),k=1,levs) +! print *,' vvel=',vvel +! endif +! if (lprnt) write(7000,*)' bef convection gu0=',gu0(ipr,:) +! &,' lat=',lat,' kdt=',kdt,' me=',me +! if (lprnt) write(7000,*)' bef convection gv0=',gv0(ipr,:) + + if (Model%ldiag3d) then + dtdt(:,:) = Stateout%gt0(:,:) + dudt(:,:) = Stateout%gu0(:,:) + dvdt(:,:) = Stateout%gv0(:,:) + elseif (Model%cnvgwd) then + dtdt(:,:) = Stateout%gt0(:,:) + endif ! end if_ldiag3d/cnvgwd + + if (Model%ldiag3d .or. Model%lgocart) then + dqdt(:,:,1) = Stateout%gq0(:,:,1) + endif ! end if_ldiag3d/lgocart + +#ifdef GFS_HYDRO + call get_phi(im, ix, levs, ntrac, Stateout%gt0, Stateout%gq0, & + Model%thermodyn_id, Model%sfcpress_id, & + Model%gen_coord_hybrid Statein%prsi, Statein%prsik, & + Statein%prsl, Statein%prslk, Statein%phii, Statein%phil) +#else +!GFDL Adjust the height hydrostatically in a way consistent with FV3 discretization + call get_phi_fv3 (ix, levs, ntrac, Stateout%gt0, Stateout%gq0, & + del_gz, Statein%phii, Statein%phil) +#endif + +! if (lprnt) then +! print *,' phii2=',phii(ipr,k=1,levs) +! print *,' phil2=',phil(ipr,:) +! endif + +!zhang:zhao-carr_pre + clw(:,:,1) = 0.0 + clw(:,:,2) = -999.9 +!zhang: CPS_pre + if ((Model%imfdeepcnv >= 0) .or. (Model%imfshalcnv > 0)) then + cnvc(:,:) = 0.0 + cnvw(:,:) = 0.0 + endif + +! write(0,*)' before cnv clstp=',clstp,' kdt=',kdt,' lat=',lat + +! --- ... for convective tracer transport (while using ras) + + if (Model%ras .or. Model%cscnv) then + if (tottracer > 0) then + if (Model%ntoz > 0) then + clw(:,:,3) = Stateout%gq0(:,:,Model%ntoz) + if (tracers > 0) then + do n=1,tracers + clw(:,:,3+n) = Stateout%gq0(:,:,n+trc_shft) + enddo + endif + else + do n=1,tracers + clw(:,:,2+n) = Stateout%gq0(:,:,n+trc_shft) + enddo + endif + endif + endif ! end if_ras or cfscnv + +!zhang: CPS_PRE + ktop(:) = 1 + kbot(:) = levs + +! --- ... calling condensation/precipitation processes +! -------------------------------------------- +!zhang:ntcw=3 + if (Model%ntcw > 0) then +!zhang: GFS,rhc used in shoc and zhao-carr,mstadj + do k=1,levs + do i=1,im + tem = rhbbot - (rhbbot-rhbtop) * (1.0-Statein%prslk(i,k)) + tem = rhc_max * work1(i) + tem * work2(i) + rhc(i,k) = max(0.0, min(1.0,tem)) + enddo + enddo +!zhang:ncld=1 + if (Model%ncld == 2) then + clw(:,:,1) = Stateout%gq0(:,:,Model%ntiw) ! ice + clw(:,:,2) = Stateout%gq0(:,:,Model%ntcw) ! water + else +!zhang: GFS_suite_interstitial , clw used in both zhao-carr and SASAS deep/shal + if (Model%num_p3d == 4) then ! zhao-carr microphysics + psautco_l(:) = Model%psautco(1)*work1(:) + Model%psautco(2)*work2(:) + prautco_l(:) = Model%prautco(1)*work1(:) + Model%prautco(2)*work2(:) + clw(:,:,1) = Stateout%gq0(:,:,Model%ntcw) + endif ! end if_num_p3d + endif ! end if (ncld == 2) + else ! if_ntcw + psautco_l(:) = Model%psautco(1)*work1(:) + Model%psautco(2)*work2(:) + prautco_l(:) = Model%prautco(1)*work1(:) + Model%prautco(2)*work2(:) + rhc(:,:) = 1.0 + endif ! end if_ntcw +! +! Call SHOC if do_shoc is true and shocaftcnv is false +! + if (Model%do_shoc .and. .not. Model%shocaftcnv) then + if (Model%ncld == 2) then + skip_macro = Model%do_shoc + clw(:,:,1) = Stateout%gq0(:,:,Model%ntiw) ! ice + clw(:,:,2) = Stateout%gq0(:,:,Model%ntcw) ! water + ncpl(:,:) = Stateout%gq0(:,:,Model%ntlnc) + ncpi(:,:) = Stateout%gq0(:,:,Model%ntinc) + elseif (Model%num_p3d == 4) then + do k=1,levs + do i=1,im + qpl(i,k) = 0.0 + qpi(i,k) = 0.0 + if (abs(Stateout%gq0(i,k,Model%ntcw)) < epsq) then + Stateout%gq0(i,k,Model%ntcw) = 0.0 + endif + tem = Stateout%gq0(i,k,Model%ntcw) & + & * max(0.0, MIN(1.0, (TCR-Stateout%gt0(i,k))*TCRF)) + clw(i,k,1) = tem ! ice + clw(i,k,2) = Stateout%gq0(i,k,Model%ntcw) - tem ! water + enddo + enddo + endif + +! dtshoc = 60.0 +! dtshoc = 120.0 +! dtshoc = dtp +! nshocm = (dtp/dtshoc) + 0.001 +! dtshoc = dtp / nshocm +! do nshoc=1,nshocm +! if (lprnt) write(1000+me,*)' before shoc tke=',clw(ipr,:,ntk), +! &' kdt=',kdt,' lat=',lat,'xlon=',xlon(ipr),' xlat=',xlat(ipr) + +! phy_f3d(1,1,ntot3d-2) - shoc determined sgs clouds +! phy_f3d(1,1,ntot3d-1) - shoc determined diffusion coefficients +! phy_f3d(1,1,ntot3d ) - shoc determined w'theta' +! +! dqdt(1:im,:,1) = gq0(1:im,:,1) +! dqdt(1:im,:,2) = gq0(1:im,:,ntiw) +! dqdt(1:im,:,3) = gq0(1:im,:,ntcw) +!GFDL lat has no meaning inside of shoc - changed to "1" +!GFDL call shoc(ix, im, 1, levs, levs+1, dtp, me, lat, + call shoc (ix, im, 1, levs, levs+1, dtp, me, 1, Statein%prsl(1,1), & + Statein%phii(1,1), Statein%phil(1,1), Stateout%gu0(1,1), & + Stateout%gv0(1,1), Statein%vvl(1,1), Stateout%gt0(1,1), & + Stateout%gq0(1,1,1), clw(1,1,1), clw(1,1,2), qpi, qpl, & + rhc, Model%sup, Tbd%phy_f3d(1,1,Model%ntot3d-2), & + clw(1,1,ntk), hflx, evap, prnum, & + Tbd%phy_f3d(1,1,Model%ntot3d-1), & + Tbd%phy_f3d(1,1,Model%ntot3d), lprnt, ipr, ncpl, ncpi, kdt) + +! if (lprnt) write(0,*)' aftshoccld=',phy_f3d(ipr,:,ntot3d-2)*100 +! if (lprnt) write(0,*)' aftshocice=',clw(ipr,:,1) +! if (lprnt) write(0,*)' aftshocwat=',clw(ipr,:,1) +! write(1000+me,*)' at latitude = ',lat +! rain1 = 0.0 +! call moist_bud(im,im,ix,levs,me,kdt,con_g,dtp,del,rain1 +! &, dqdt(1,1,1), dqdt(1,1,2), dqdt(1,1,3) +! &, gq0(1,1,1),clw(1,1,2),clw(1,1,1),'shoc ') + + if ((Model%ntlnc > 0) .and. (Model%ntinc > 0) .and. (Model%ncld >= 2)) then + Stateout%gq0(:,:,Model%ntlnc) = ncpl(:,:) + Stateout%gq0(:,:,Model%ntinc) = ncpi(:,:) + endif +! do k=1,levs +! do i=1,im +! sgs_cld(i,k) = sgs_cld(i,k) + shoc_cld(i,k) +! enddo +! enddo +! if (lprnt) write(0,*)' gt03=',gt0(ipr,1:10) +! if (lprnt) write(0,*)' tke=',clw(ipr,1:10,ntk) + +! if (lprnt) write(1000+me,*)' after shoc tke=',clw(1,:,ntk), +! &' kdt=',kdt +! enddo +! +! do k=1,levs +! write(1000+me,*)' maxcld=',maxval(sgs_cld(1:im,k)), +! write(1000+me,*)' maxtkh=',maxval(phy_f3d(1:im,k,ntot3d-1)), +! &' k=',k,' kdt=',kdt,' lat=',lat +! enddo + +! write(0,*)' aft shoc gt0=',gt0(1,:),' lat=',lat +! write(0,*)' aft shoc gq0=',gq0(1,:,1),' lat=',lat +! write(0,*)' aft shoc gu0=',gu0(1,:),' lat=',lat +! + endif ! if(do_shoc) + +! --- ... calling convective parameterization +! + if (.not. Model%ras .and. .not. Model%cscnv) then + + if (Model%imfdeepcnv == 1) then ! no random cloud top + call sascnvn (im, ix, levs, Model%jcap, dtp, del, & + Statein%prsl, Statein%pgr, Statein%phil, clw(:,:,1:2), & + Stateout%gq0, Stateout%gt0, Stateout%gu0, & + Stateout%gv0, cld1d, rain1, kbot, ktop, kcnv, & + islmsk, Statein%vvl, Model%ncld, ud_mf, dd_mf, & + dt_mf, cnvw, cnvc) + elseif (Model%imfdeepcnv == 2) then + call mfdeepcnv (im, ix, levs, dtp, del, Statein%prsl, & + Statein%pgr, Statein%phil, clw(:,:,1:2), Stateout%gq0, & + Stateout%gt0, Stateout%gu0, Stateout%gv0, & + cld1d, rain1, kbot, ktop, kcnv, islmsk, & + garea, Statein%vvl, Model%ncld, ud_mf, dd_mf, & + dt_mf, cnvw, cnvc) +! if (lprnt) print *,' rain1=',rain1(ipr) + elseif (Model%imfdeepcnv == 0) then ! random cloud top + call sascnv (im, ix, levs, Model%jcap, dtp, del, & + Statein%prsl, Statein%pgr, Statein%phil, clw(:,:,1:2), & + Stateout%gq0, Stateout%gt0, Stateout%gu0, & + Stateout%gv0, cld1d, rain1, kbot, ktop, kcnv, & + islmsk, Statein%vvl, Tbd%rann, Model%ncld, & + ud_mf, dd_mf, dt_mf, cnvw, cnvc) +! if (lprnt) print *,' rain1=',rain1(ipr),' rann=',rann(ipr,1) + endif + else ! ras or cscnv + if (Model%cscnv) then ! Chikira-Sugiyama convection scheme (via CSU) + otspt(:,:) = .true. + otspt(1:3,:) = .false. + if (Model%ntke > 0) then + otspt(Model%ntke-trc_shft+4,1) = .false. + endif + if (Model%ncld == 2) then + otspt(Model%ntlnc-trc_shft+4,1) = .false. + otspt(Model%ntinc-trc_shft+4,1) = .false. + endif + + fscav(:) = 0.0 + fswtr(:) = 0.0 +! write(0,*)' bef cs_cconv phii=',phii(ipr,:) +! &,' sizefsc=',size(fscav) +! write(0,*)' bef cs_cconv otspt=',otspt,' kdt=',kdt,' me=',me + dqdt(:,:,1) = Stateout%gq0(:,:,1) + dqdt(:,:,2) = max(0.0,clw(:,:,2)) + dqdt(:,:,3) = max(0.0,clw(:,:,1)) +! if (lprnt) write(0,*)' gq0bfcs=',gq0(ipr,1:35,1) +! if (lprnt) write(0,*)' gq0bfcs3=',gq0(ipr,1:35,3) +! if (lprnt) write(0,*)' gq0bfcs4=',gq0(ipr,1:35,4) + + do_awdd = ((Model%do_aw) .and. (Model%cs_parm(6) > 0.0)) +! if (lprnt) write(0,*)' do_awdd=',do_awdd +!GFDL again lat replaced with "1" +!GFDL & otspt, lat, kdt , & + call cs_convr (ix, im, levs, tottracer+3, Model%nctp, otspt, 1, & + kdt, Stateout%gt0, Stateout%gq0(1,1,1:1), rain1, & + clw, Statein%phil, Statein%phii, Statein%prsl, & + Statein%prsi, dtp, dtf, ud_mf, dd_mf, dt_mf, & + Stateout%gu0, Stateout%gv0, fscav, fswtr, & + Tbd%phy_fctd, me, wcbmax, Model%cs_parm(3), & + Model%cs_parm(4), sigmai, sigmatot, vverti, & + Model%do_aw, do_awdd, lprnt, ipr, QLCN, QICN, & + w_upi, cf_upi, CNV_MFD, CNV_PRC3, CNV_DQLDT, & + CLCN, CNV_FICE, CNV_NDROP, CNV_NICE, Model%ncld) + +! if (lprnt) write(0,*)' gq0afcs=',gq0(ipr,1:35,1) +! if (lprnt) write(0,*)' gq0afcs3=',gq0(ipr,1:35,3) +! if (lprnt) write(0,*)' gq0afcs4=',gq0(ipr,1:35,4) +! write(1000+me,*)' at latitude = ',lat +! call moist_bud(im,im,ix,levs,me,kdt,con_g,dtp,del,rain1 +! &, dqdt(1,1,1), dqdt(1,1,2), dqdt(1,1,3) +! &, gq0(1,1,1),clw(1,1,2),clw(1,1,1),' cs_conv') + + rain1(:) = rain1(:) * (dtp*0.001) + if (Model%do_aw) then + do k=1,levs + kk = min(k+1,levs) ! assuming no cloud top reaches the model top + do i = 1,im !DD + sigmafrac(i,k) = 0.5 * (sigmatot(i,k)+sigmatot(i,kk)) + enddo + enddo + endif + +! if (lprnt) then +! write(0,*)' gt01=',gt0(ipr,:),' kdt=',kdt +! write(0,*)' gq01=',gq0(ipr,:,1),' kdt=',kdt +! write(0,*)' clw1=',clw(ipr,:,1),' kdt=',kdt +! write(0,*)' clw2=',clw(ipr,:,1),' kdt=',kdt +! write(0,*)' aft cs rain1=',rain1(ipr)*86400 +! write(0,*)' aft cs rain1=',rain1(ipr) +! endif + + else ! ras version 2 + + if ((Model%ccwf(1) >= 0.0) .or. (Model%ccwf(2) >= 0)) then + ccwfac(:) = Model%ccwf(1)*work1(:) + Model%ccwf(2)*work2(:) + dlqfac(:) = Model%dlqf(1)*work1(:) + Model%dlqf(2)*work2(:) + lmh (:) = levs + else + ccwfac(:) = -999.0 + dlqfac(:) = 0.0 + lmh (:) = levs + endif +! if (lprnt) write(0,*) ' calling ras for kdt=',kdt,' me=',me & +! &, ' lprnt=',lprnt,' ccwfac=',ccwfac(ipr) + +! do k=1,levs +! do i=1,im +! dqdt(i,k,1) = gq0(i,k,1) +! dqdt(i,k,2) = max(0.0,clw(i,k,2)) +! dqdt(i,k,3) = max(0.0,clw(i,k,1)) +! enddo +! enddo +! if (lat == 64 .and. kdt == 1) write(0,*)' qliq=',clw(1,:,1) +! if (lat == 64 .and. kdt == 1) write(0,*)' qice=',clw(1,:,2) + + revap = .true. +! if (ncld ==2) revap = .false. + call rascnv (im, ix, levs, dtp, dtf, Tbd%rann, Stateout%gt0, & + Stateout%gq0, Stateout%gu0, Stateout%gv0, clw, & + tottracer, fscav, Statein%prsi, Statein%prsl, & + Statein%prsik, Statein%prslk, Statein%phil, & + Statein%phii, kpbl, cd, rain1, kbot, ktop, kcnv, & + Tbd%phy_f2d(1,Model%num_p2d), Model%flipv, pa2mb, & + me, garea, lmh, ccwfac, Model%nrcm, rhc, ud_mf, & + dd_mf, dt_mf, dlqfac, lprnt, ipr, kdt, revap, QLCN, & + QICN, w_upi, cf_upi, CNV_MFD, CNV_PRC3, CNV_DQLDT, & + CLCN, CNV_FICE, CNV_NDROP, CNV_NICE, Model%ncld ) + endif + +! write(1000+me,*)' at latitude = ',lat +! tx1 = 1000.0 +! call moist_bud(im,im,ix,levs,me,kdt,con_g,tx1,del,rain1 +! &, dqdt(1,1,1), dqdt(1,1,2), dqdt(1,1,3) +! &, gq0(1,1,1),clw(1,1,2),clw(1,1,1),' ras_conv') +! if(lprnt) write(0,*)' after ras rain1=',rain1(ipr) +! &,' cnv_prc3sum=',sum(cnv_prc3(ipr,1:levs)) +! if (lprnt) write(0,*)' gt04=',gt0(ipr,1:10) +! if (lprnt) write(0,*)' gq04=',gq0(ipr,:,1) + + cld1d = 0 + + if (Model%ldiag3d .or. Model%lgocart) then + Coupling%upd_mfi(:,:) = 0. + Coupling%dwn_mfi(:,:) = 0. + Coupling%det_mfi(:,:) = 0. + endif + if (Model%lgocart) then + Coupling%dqdti(:,:) = 0. + Coupling%cnvqci(:,:) = 0. + endif + + if (Model%lgocart) then + Coupling%upd_mfi(:,:) = Coupling%upd_mfi(:,:) + ud_mf(:,:) * frain + Coupling%dwn_mfi(:,:) = Coupling%dwn_mfi(:,:) + dd_mf(:,:) * frain + Coupling%det_mfi(:,:) = Coupling%det_mfi(:,:) + dt_mf(:,:) * frain + Coupling%cnvqci (:,:) = Coupling%cnvqci (:,:) + (clw(:,:,1)+clw(:,:,2) - & + Stateout%gq0(:,:,Model%ntcw)) * frain + endif ! if (lgocart) + +! --- ... update the tracers due to convective transport + + if (tottracer > 0) then + if (Model%ntoz > 0) then ! for ozone + Stateout%gq0(:,:,Model%ntoz) = clw(:,:,3) + + if (tracers > 0) then ! for other tracers + do n=1,tracers + Stateout%gq0(:,:,n+trc_shft) = clw(:,:,3+n) + enddo + endif + else + do n=1,tracers + Stateout%gq0(:,:,n+trc_shft) = clw(:,:,2+n) + enddo + endif + endif + endif ! end if_not_ras + +! if (lprnt) then +! write(0,*)' aftcnvgt0=',gt0(ipr,:),' kdt=',kdt,' lat=',lat +! write(0,*)' aftcnvgq0=',(gq0(ipr,k,1),k=1,levs),' lat=',lat +! write(0,*)' gq0i2=',(gq0(ipr,k,ntiw),k=1,levs),' lat=',lat +! write(0,*)' aftcnvgq1=',(gq0(ipr,k,ntcw),k=1,levs) +! endif +! +!zhang: sasas shal_pre + do i = 1, im + Diag%rainc(:) = frain * rain1(:) + enddo +! + if (Model%lssav) then + Diag%cldwrk (:) = Diag%cldwrk (:) + cld1d(:) * dtf + Diag%cnvprcp(:) = Diag%cnvprcp(:) + Diag%rainc(:) + + if (Model%ldiag3d) then + Diag%dt3dt(:,:,4) = Diag%dt3dt(:,:,4) + (Stateout%gt0(:,:)-dtdt(:,:)) * frain + Diag%dq3dt(:,:,2) = Diag%dq3dt(:,:,2) + (Stateout%gq0(:,:,1)-dqdt(:,:,1)) * frain + Diag%du3dt(:,:,3) = Diag%du3dt(:,:,3) + (Stateout%gu0(:,:)-dudt(:,:)) * frain + Diag%dv3dt(:,:,3) = Diag%dv3dt(:,:,3) + (Stateout%gv0(:,:)-dvdt(:,:)) * frain + + Diag%upd_mf(:,:) = Diag%upd_mf(:,:) + ud_mf(:,:) * (con_g*frain) + Diag%dwn_mf(:,:) = Diag%dwn_mf(:,:) + dd_mf(:,:) * (con_g*frain) + Diag%det_mf(:,:) = Diag%det_mf(:,:) + dt_mf(:,:) * (con_g*frain) + endif ! if (ldiag3d) + + endif ! end if_lssav +! +! update dqdt_v to include moisture tendency due to deep convection + if (Model%lgocart) then + Coupling%dqdti (:,:) = (Stateout%gq0(:,:,1) - dqdt(:,:,1)) * frain + Coupling%upd_mfi(:,:) = Coupling%upd_mfi(:,:) + ud_mf(:,:) * frain + Coupling%dwn_mfi(:,:) = Coupling%dwn_mfi(:,:) + dd_mf(:,:) * frain + Coupling%det_mfi(:,:) = Coupling%det_mfi(:,:) + dt_mf(:,:) * frain + Coupling%cnvqci (:,:) = Coupling%cnvqci (:,:) + (clw(:,:,1)+clw(:,:,2))*frain + endif ! if (lgocart) +! +!zhang: for pdf cld and zhao + if ((Model%npdf3d == 3) .and. (Model%num_p3d == 4)) then + num2 = Model%num_p3d + 2 + num3 = num2 + 1 + Tbd%phy_f3d(:,:,num2) = cnvw(:,:) + Tbd%phy_f3d(:,:,num3) = cnvc(:,:) +!zhang:zhao-car,num_p3d=4,GFS_DCNV_generic_post + elseif ((Model%npdf3d == 0) .and. (Model%ncnvcld3d == 1)) then + num2 = Model%num_p3d + 1 + Tbd%phy_f3d(:,:,num2) = cnvw(:,:) + endif + +! if (lprnt) write(7000,*)' bef cnvgwd gu0=',gu0(ipr,:) +! &,' lat=',lat,' kdt=',kdt,' me=',me +! if (lprnt) write(7000,*)' bef cnvgwd gv0=',gv0(ipr,:) +! +!----------------Convective gravity wave drag parameterization starting -------- +!zhang:gwdc_pre + if (Model%cnvgwd) then ! call convective gravity wave drag + +! --- ... calculate maximum convective heating rate +! cuhr = temperature change due to deep convection + + cumabs(:) = 0.0 + work3 (:) = 0.0 + do k = 1, levs + do i = 1, im + if (k >= kbot(i) .and. k <= ktop(i)) then + cumabs(i) = cumabs(i) + (Stateout%gt0(i,k)-dtdt(i,k)) * del(i,k) + work3(i) = work3(i) + del(i,k) + endif + enddo + enddo + do i=1,im + if (work3(i) > 0.0) cumabs(i) = cumabs(i) / (dtp*work3(i)) + enddo + +! do i = 1, im +! do k = kbot(i), ktop(i) +! do k1 = kbot(i), k +! cumchr(i,k) = cuhr(i,k1) + cumchr(i,k) +! enddo +! cumchr(i,k) = cumchr(i,k) / cumabs(i) +! enddo +! enddo + +! --- ... begin check print ****************************************** + +! if (lprnt) then +! if (kbot(ipr) <= ktop(ipr)) then +! write(*,*) 'kbot <= ktop for (lat,lon) = ', & +! & xlon(ipr)*57.29578,xlat(ipr)*57.29578 +! write(*,*) 'kcnv kbot ktop dlength ',kcnv(ipr), & +! & kbot(ipr),ktop(ipr),dlength(ipr) +! write(*,9000) kdt +!9000 format(/,3x,'k',5x,'cuhr(k)',4x,'cumchr(k)',5x, & +! & 'at kdt = ',i4,/) + +! do k = ktop(ipr), kbot(ipr),-1 +! write(*,9010) k,(86400.*cuhr(ipr,k)),(100.*cumchr(ipr,k)) +!9010 format(2x,i2,2x,f8.2,5x,f6.0) +! enddo +! endif + +! if (fhour >= fhourpr) then +! print *,' before gwdc in gbphys start print' +! write(*,*) 'fhour ix im levs = ',fhour,ix,im,levs +! print *,'dtp dtf = ',dtp,dtf + +! write(*,9100) +!9100 format(//,14x,'pressure levels',// & +! & ' ilev',7x,'prsi',8x,'prsl',8x,'delp',/) + +! k = levs + 1 +! write(*,9110) k,(10.*prsi(ipr,k)) +!9110 format(i4,2x,f10.3) + +! do k = levs, 1, -1 +! write(*,9120) k,(10.*prsl(ipr,k)),(10.*del(ipr,k)) +! write(*,9110) k,(10.*prsi(ipr,k)) +! enddo +!9120 format(i4,12x,2(2x,f10.3)) + +! write(*,9130) +!9130 format(//,10x,'before gwdc in gbphys',//,' ilev',6x, & +! & 'ugrs',9x,'gu0',8x,'vgrs',9x,'gv0',8x, & +! & 'tgrs',9x,'gt0',8x,'gt0b',8x,'dudt',8x,'dvdt',/) + +! do k = levs, 1, -1 +! write(*,9140) k,ugrs(ipr,k),gu0(ipr,k), & +! & vgrs(ipr,k),gv0(ipr,k), & +! & tgrs(ipr,k),gt0(ipr,k),dtdt(ipr,k), & +! & dudt(ipr,k),dvdt(ipr,k) +! enddo +!9140 format(i4,9(2x,f10.3)) + +! print *,' before gwdc in gbphys end print' +! endif +! endif ! end if_lprnt + +! --- ... end check print ******************************************** + +!GFDL replacing lat with "1" +! call gwdc(im, ix, im, levs, lat, gu0, gv0, gt0, gq0, dtp, & +!zhang:gwdc_run + call gwdc (im, ix, im, levs, 1, Statein%ugrs, Statein%vgrs, & + Statein%tgrs, Statein%qgrs, dtp, Statein%prsl, & + Statein%prsi, del, cumabs, ktop, kbot, kcnv, cldf, & + con_g, con_cp, con_rd, con_fvirt, con_pi, dlength, & + lprnt, ipr, Model%fhour, gwdcu, gwdcv, dusfcg, dvsfcg) + +! if (lprnt) then +! if (fhour >= fhourpr) then +! print *,' after gwdc in gbphys start print' + +! write(*,9131) +!9131 format(//,10x,'after gwdc in gbphys',//,' ilev',6x, & +! & 'ugrs',9x,'gu0',8x,'vgrs',9x,'gv0',8x, & +! & 'tgrs',9x,'gt0',8x,'gt0b',7x,'gwdcu',7x,'gwdcv',/) + +! do k = levs, 1, -1 +! write(*,9141) k,ugrs(ipr,k),gu0(ipr,k), & +! & vgrs(ipr,k),gv0(ipr,k), & +! & tgrs(ipr,k),gt0(ipr,k),dtdt(ipr,k), & +! & gwdcu(ipr,k),gwdcv(ipr,k) +! enddo +!9141 format(i4,9(2x,f10.3)) + +! print *,' after gwdc in gbphys end print' +! endif +! endif + +! --- ... write out cloud top stress and wind tendencies + + if (Model%lssav) then + Diag%dugwd(:) = Diag%dugwd(:) + dusfcg(:)*dtf + Diag%dvgwd(:) = Diag%dvgwd(:) + dvsfcg(:)*dtf + + if (Model%ldiag3d) then + Diag%du3dt(:,:,4) = Diag%du3dt(:,:,4) + gwdcu(:,:) * dtf + Diag%dv3dt(:,:,4) = Diag%dv3dt(:,:,4) + gwdcv(:,:) * dtf + endif + endif ! end if_lssav + +! --- ... update the wind components with gwdc tendencies + + do k = 1, levs + do i = 1, im + eng0 = 0.5*(Stateout%gu0(i,k)*Stateout%gu0(i,k)+Stateout%gv0(i,k)*Stateout%gv0(i,k)) + Stateout%gu0(i,k) = Stateout%gu0(i,k) + gwdcu(i,k) * dtp + Stateout%gv0(i,k) = Stateout%gv0(i,k) + gwdcv(i,k) * dtp + eng1 = 0.5*(Stateout%gu0(i,k)*Stateout%gu0(i,k)+Stateout%gv0(i,k)*Stateout%gv0(i,k)) + Stateout%gt0(i,k) = Stateout%gt0(i,k) + (eng0-eng1)/(dtp*con_cp) + enddo +! if (lprnt) write(7000,*)' gu0=',gu0(ipr,k),' gwdcu=', +! &gwdcu(ipr,k), ' gv0=', gv0(ipr,k),' gwdcv=',gwdcv(ipr,k) +! &,' k=',k + enddo + +! if (lprnt) then +! if (fhour >= fhourpr) then +! print *,' after tendency gwdc in gbphys start print' + +! write(*,9132) +!9132 format(//,10x,'after tendency gwdc in gbphys',//,' ilev',6x,& +! & 'ugrs',9x,'gu0',8x,'vgrs',9x,'gv0',8x, & +! & 'tgrs',9x,'gt0',8x,'gt0b',7x,'gwdcu',7x,'gwdcv',/) + +! do k = levs, 1, -1 +! write(*,9142) k,ugrs(ipr,k),gu0(ipr,k),vgrs(ipr,k), & +! & gv0(ipr,k),tgrs(ipr,k),gt0(ipr,k),dtdt(ipr,k), & +! & gwdcu(ipr,k),gwdcv(ipr,k) +! enddo +!9142 format(i4,9(2x,f10.3)) + +! print *,' after tendency gwdc in gbphys end print' +! endif +! endif + + endif ! end if_cnvgwd (convective gravity wave drag) + +! if (lprnt) write(7000,*)' aft cnvgwd gu0=',gu0(ipr,:) +! if (lprnt) write(7000,*)' aft cnvgwd gv0=',gv0(ipr,:) +! &,' lat=',lat,' kdt=',kdt,' me=',me +!----------------Convective gravity wave drag parameterization over -------- + +!zhang: GFS_SCNV_generic_pre + if (Model%ldiag3d) then + dtdt(:,:) = Stateout%gt0(:,:) + endif + if (Model%ldiag3d .or. Model%lgocart) then + dqdt(:,:,1) = Stateout%gq0(:,:,1) + endif + +! write(0,*)' before do_shoc shal clstp=',clstp,' kdt=',kdt, +! & ' lat=',lat +! if (lprnt) then +! write(0,*)' prsl=',prsl(ipr,:) +! write(0,*) ' del=',del(ipr,:) +! write(0,*) ' befshalgt0=',gt0(ipr,:),' kdt=',kdt +! write(0,*) ' befshalgq0=',gt0(ipr,:),' kdt=',kdt +! write(0,*) ' befshalgq0=',gq0(ipr,:,1),' kdt=',kdt +! write(0,*) ' befshalgqw=',gq0(ipr,:,3),' kdt=',kdt +! endif + + if (.not. Model%do_shoc) then + + if (Model%shal_cnv) then ! Shallow convection parameterizations +! -------------------------------------- + if (Model%imfshalcnv == 1) then ! opr option now at 2014 + !----------------------- + call shalcnv (im, ix, levs, Model%jcap, dtp, del, Statein%prsl, & + Statein%pgr, Statein%phil, clw, Stateout%gq0, & + Stateout%gt0, Stateout%gu0, Stateout%gv0, rain1, & + kbot, ktop, kcnv, islmsk, Statein%vvl, Model%ncld,& + Diag%hpbl, hflx, evap, ud_mf, dt_mf, cnvw, cnvc) + + raincs(:) = frain * rain1(:) + Diag%rainc(:) = Diag%rainc(:) + raincs(:) + if (Model%lssav) then + Diag%cnvprcp(:) = Diag%cnvprcp(:) + raincs(:) + endif + if ((Model%shcnvcw) .and. (Model%num_p3d == 4) .and. (Model%npdf3d == 3)) then + Tbd%phy_f3d(:,:,num2) = cnvw(:,:) + Tbd%phy_f3d(:,:,num3) = cnvc(:,:) + elseif ((Model%npdf3d == 0) .and. (Model%ncnvcld3d == 1)) then + num2 = Model%num_p3d + 1 + Tbd%phy_f3d(:,:,num2) = cnvw(:,:) + endif + + elseif (Model%imfshalcnv == 2) then + call mfshalcnv (im, ix, levs, dtp, del, Statein%prsl, & + Statein%pgr, Statein%phil, clw, Stateout%gq0, & + Stateout%gt0, Stateout%gu0, Stateout%gv0, & + rain1, kbot, ktop, kcnv, islmsk, garea, & + Statein%vvl, Model%ncld, DIag%hpbl, ud_mf, & + dt_mf, cnvw, cnvc) + + raincs(:) = frain * rain1(:) + Diag%rainc(:) = DIag%rainc(:) + raincs(:) + if (Model%lssav) then + Diag%cnvprcp(:) = Diag%cnvprcp(:) + raincs(:) + endif + if ((Model%shcnvcw) .and. (Model%num_p3d == 4) .and. (Model%npdf3d == 3)) then + Tbd%phy_f3d(:,:,num2) = cnvw(:,:) + Tbd%phy_f3d(:,:,num3) = cnvc(:,:) + elseif ((Model%npdf3d == 0) .and. (Model%ncnvcld3d == 1)) then + num2 = Model%num_p3d + 1 + Tbd%phy_f3d(:,:,num2) = cnvw(:,:) + endif + + elseif (Model%imfshalcnv == 0) then ! modified Tiedtke Shallow convecton + !----------------------------------- + levshc(:) = 0 + do k = 2, levs + do i = 1, im + dpshc = 0.3 * Statein%prsi(i,1) + if (Statein%prsi(i,1)-Statein%prsi(i,k) <= dpshc) levshc(i) = k + enddo + enddo + levshcm = 1 + do i = 1, im + levshcm = max(levshcm, levshc(i)) + enddo + +! if (lprnt) print *,' levshcm=',levshcm,' gt0sh=',gt0(ipr,:) +! &, ' lat=',lat + + if (Model%mstrat) then ! As in CFSv2 + call shalcv (im, ix, levshcm, dtp, del, Statein%prsi, & + Statein%prsl, Statein%prslk,kcnv, Stateout%gq0, & + Stateout%gt0, levshc, Statein%phil, kinver, & + ctei_r, ctei_rml, lprnt, ipr) + else + call shalcvt3 (im, ix, levshcm, dtp, del, Statein%prsi, & + Statein%prsl, Statein%prslk, kcnv, & + Stateout%gq0, Stateout%gt0) + endif +! if (lprnt) print *,' levshcm=',levshcm,' gt0sha=',gt0(ipr,:) + + endif ! end if_imfshalcnv + endif ! end if_shal_cnv + + if (Model%lssav) then +! update dqdt_v to include moisture tendency due to shallow convection + if (Model%lgocart) then + do k = 1, levs + do i = 1, im + tem = (Stateout%gq0(i,k,1)-dqdt(i,k,1)) * frain + Coupling%dqdti(i,k) = Coupling%dqdti(i,k) + tem + enddo + enddo + endif +!zhang: GFS_diagnostics + if (Model%ldiag3d) then + Diag%dt3dt(:,:,5) = Diag%dt3dt(:,:,5) + (Stateout%gt0(:,:)-dtdt(:,:)) * frain + Diag%dq3dt(:,:,3) = Diag%dq3dt(:,:,3) + (Stateout%gq0(:,:,1)-dqdt(:,:,1)) * frain + endif + endif ! end if_lssav +! +!zhang: GFS_suite_interstitial + do k = 1, levs + do i = 1, im + if (clw(i,k,2) <= -999.0) clw(i,k,2) = 0.0 + enddo + enddo + +! if (lprnt) then +! write(0,*)' prsl=',prsl(ipr,:) +! write(0,*) ' del=',del(ipr,:) +! write(0,*) ' befshgt0=',gt0(ipr,:) +! write(0,*) ' befshgq0=',gq0(ipr,:,1) +! endif + + elseif (Model%shocaftcnv) then ! if do_shoc is true and shocaftcnv is true call shoc + if (Model%ncld == 2) then + skip_macro = Model%do_shoc + ncpl(:,:) = Stateout%gq0(:,:,Model%ntlnc) + ncpi(:,:) = Stateout%gq0(:,:,Model%ntinc) + +! else +! if (clw(1,1,2) < -999.0) then ! if clw is not partitioned to ice and water +! do k=1,levs +! do i=1,im +! tem = gq0(i,k,ntcw) & +! & * max(0.0, MIN(1.0, (TCR-gt0(i,k))*TCRF)) +! clw(i,k,1) = tem ! ice +! clw(i,k,2) = gq0(i,k,ntcw) - tem ! water +! enddo +! enddo +! endif ! Anning ncld ==2 + endif + qpl(:,:) = 0.0 + qpi(:,:) = 0.0 +! dtshoc = 60.0 +! nshocm = (dtp/dtshoc) + 0.001 +! dtshoc = dtp / nshocm +! do nshoc=1,nshocm +! call shoc(im, 1, levs, levs+1, dtp, me, lat, & +!! call shoc(im, 1, levs, levs+1, dtshoc, me, lat, & +! & prsl(1:im,:), phii (1:im,:), phil(1:im,:),& +! & gu0(1:im,:),gv0(1:im,:), vvl(1:im,:), gt0(1:im,:), & +! & gq0(1:im,:,1), & +! & clw(1:im,:,1), clw(1:im,:,2), qpi, qpl, sgs_cld(1:im,:)& +! &, gq0(1:im,:,ntke), & +! & phy_f3d(1:im,:,ntot3d-1), phy_f3d(1:im,:,ntot3d), & +! & lprnt, ipr, & +! & con_cp, con_g, con_hvap, con_hfus, con_hvap+con_hfus, & +! & con_rv, con_rd, con_pi, con_fvirt) + +!GFDL replace lat with "1: +! call shoc(ix, im, 1, levs, levs+1, dtshoc, me, lat, & + call shoc (ix, im, 1, levs, levs+1, dtp, me, 1, Statein%prsl(1,1), & + Statein%phii(1,1), Statein%phil(1,1), Stateout%gu0(1,1), & + Stateout%gv0(1,1), Statein%vvl(1,1), Stateout%gt0(1,1), & + Stateout%gq0(1,1,1), clw(1,1,1), clw(1,1,2), qpi, qpl,rhc, & + Model%sup, Tbd%phy_f3d(1,1,Model%ntot3d-2), & + Stateout%gq0(1,1,Model%ntke), hflx, evap, prnum, & + Tbd%phy_f3d(1,1,Model%ntot3d-1), Tbd%phy_f3d(1,1,Model%ntot3d),& + lprnt, ipr, ncpl, ncpi, kdt) + + if ((Model%ntlnc > 0) .and. (Model%ntinc > 0) .and. (Model%ncld >= 2)) then + Stateout%gq0(:,:,Model%ntlnc) = ncpl(:,:) + Stateout%gq0(:,:,Model%ntinc) = ncpi(:,:) + endif + +! +! do k=1,levs +! write(1000+me,*)' maxtkh=',maxval(phy_f3d(1:im,k,ntot3d-1)), & +! ' k=',k,' kdt=',kdt,' lat=',lat +! enddo + +! write(0,*)' aft shoc gt0=',gt0(1,:),' lat=',lat +! write(0,*)' aft shoc gq0=',gq0(1,:,1),' lat=',lat +! write(0,*)' aft shoc gu0=',gu0(1,:),' lat=',lat +! + endif ! if( .not. do_shoc) +! +! if (lprnt) then +! write(0,*)' prsl=',prsl(ipr,:) +! write(0,*) ' del=',del(ipr,:) +! write(0,*) ' aftshgt0=',gt0(ipr,:) +! write(0,*) ' aftshgq0=',gq0(ipr,:,1) +! endif + + if (Model%ntcw > 0) then + +! for microphysics + if (Model%ncld == 2) then ! morrison microphysics + Stateout%gq0(:,:,Model%ntiw) = clw(:,:,1) ! ice + Stateout%gq0(:,:,Model%ntcw) = clw(:,:,2) ! water + elseif (Model%num_p3d == 4) then ! if_num_p3d +!zhang:zhao-carr_pre + Stateout%gq0(:,:,Model%ntcw) = clw(:,:,1) + clw(:,:,2) + endif ! end if_num_p3d + + else ! if_ntcw + + clw(:,:,1) = clw(:,:,1) + clw(:,:,2) + + + endif ! end if_ntcw + +! Legacy routine which determines convectve clouds - should be removed at some point +!zhang: cnvc90_run, need to be CCPP_compliant + call cnvc90 (Model%clstp, im, ix, Diag%rainc, kbot, ktop, levs, Statein%prsi, & + Tbd%acv, Tbd%acvb, Tbd%acvt, Cldprop%cv, Cldprop%cvb, Cldprop%cvt) + + if (Model%moist_adj) then ! moist convective adjustment +! --------------------------- +! +! To call moist convective adjustment +! +! if (lprnt) then +! print *,' prsl=',prsl(ipr,:) +! print *,' del=',del(ipr,:) +! print *,' gt0b=',gt0(ipr,:) +! print *,' gq0b=',gq0(ipr,:,1) +! endif + + call mstcnv (im, ix, levs, dtp, Stateout%gt0, Stateout%gq0, & + Statein%prsl,del, Statein%prslk, rain1, & + Stateout%gq0(1,1,Model%ntcw), rhc, lprnt, ipr) + +! if (lprnt) then +! print *,' rain1=',rain1(ipr),' rainc=',rainc(ipr) +! print *,' gt0a=',gt0(ipr,:) +! print *,' gq0a=',gq0(ipr,:,1) +! endif + Diag%rainc(:) = Diag%rainc(:) + frain * rain1(:) + if(Model%lssav) then + Diag%cnvprcp(:) = Diag%cnvprcp(:) + rain1(:) * frain + +! update dqdt_v to include moisture tendency due to surface processes +! dqdt_v : instaneous moisture tendency (kg/kg/sec) +! if (lgocart) then +! do k=1,levs +! do i=1,im +! tem = (gq0(i,k,1)-dqdt(i,k,1)) * frain +! dqdt_v(i,k) = dqdt_v(i,k) + tem +! dqdt_v(i,k) = dqdt_v(i,k) / dtf +! enddo +! enddo +! endif + if (Model%ldiag3d) then + Diag%dt3dt(:,:,4) = Diag%dt3dt(:,:,4) + (Stateout%gt0(:,:) -dtdt(:,:) ) * frain + Diag%dq3dt(:,:,2) = Diag%dq3dt(:,:,2) + (Stateout%gq0(:,:,1)-dqdt(:,:,1)) * frain + endif + endif + endif ! moist convective adjustment over +! + if (Model%ldiag3d .or. Model%do_aw) then + dtdt(:,:) = Stateout%gt0(:,:) + dqdt(:,:,1) = Stateout%gq0(:,:,1) + do n=Model%ntcw,Model%ntcw+Model%ncld-1 + dqdt(:,:,n) = Stateout%gq0(:,:,n) + enddo + endif + +! dqdt_v : instaneous moisture tendency (kg/kg/sec) + if (Model%lgocart) then + Coupling%dqdti(:,:) = Coupling%dqdti(:,:) / dtf + endif +! +! grid-scale condensation/precipitations and microphysics parameterization +! ------------------------------------------------------------------------ + + if (Model%ncld == 0) then ! no cloud microphysics + + call lrgscl (ix, im, levs, dtp, Stateout%gt0, Stateout%gq0, & + Statein%prsl, del, Statein%prslk, rain1, clw) +!zhang + elseif (Model%ncld == 1) then ! microphysics with single cloud condensate + + if (Model%num_p3d == 4) then ! call zhao/carr/sundqvist microphysics + + if (Model%npdf3d /= 3) then ! without pdf clouds + +! if (lprnt) then +! write(0,*)' prsl=',prsl(ipr,:) +! write(0,*) ' del=',del(ipr,:) +! write(0,*) ' beflsgt0=',gt0(ipr,:),' kdt=',kdt +! write(0,*) ' beflsgq0=',gq0(ipr,:,1),' kdt=',kdt +! write(0,*) ' beflsgw0=',gq0(ipr,:,3),' kdt=',kdt +! endif + ! ------------------ + if (Model%do_shoc) then + call precpd_shoc (im, ix, levs, dtp, del, Statein%prsl, & + Stateout%gq0(1,1,1), Stateout%gq0(1,1,Model%ntcw), & + Stateout%gt0, rain1, Diag%sr, rainp, rhc, & + psautco_l, prautco_l, Model%evpco, Model%wminco, & + Tbd%phy_f3d(1,1,Model%ntot3d-2), lprnt, ipr) + else + +! call gscond (im, ix, levs, dtp, dtf, Statein%prsl, Statein%pgr, & + call gscond_run (im, ix, levs, dtp, dtf, Statein%prsl, Statein%pgr,& +! Stateout%gq0(1,1,1), Stateout%gq0(1,1,Model%ntcw), & +! Stateout%gt0, Tbd%phy_f3d(1,1,1), Tbd%phy_f3d(1,1,2), & +! Tbd%phy_f2d(1,1), Tbd%phy_f3d(1,1,3), & +! Tbd%phy_f3d(1,1,4), Tbd%phy_f2d(1,2), rhc,lprnt, ipr) + Stateout%gq0(:,:,1), Stateout%gq0(:,:,Model%ntcw), & + Stateout%gt0, Tbd%phy_f3d(:,:,1), Tbd%phy_f3d(:,:,2), & + Tbd%phy_f2d(:,1), Tbd%phy_f3d(:,:,3), & + Tbd%phy_f3d(:,:,4), Tbd%phy_f2d(:,2), rhc,lprnt, ipr) + +! call precpd (im, ix, levs, dtp, del, Statein%prsl, & + call precpd_run (im, ix, levs, dtp, del, Statein%prsl, & +! Stateout%gq0(1,1,1), Stateout%gq0(1,1,Model%ntcw), & + Stateout%gq0(:,:,1), Stateout%gq0(:,:,Model%ntcw), & + Stateout%gt0, rain1, Diag%sr, rainp, rhc, psautco_l, & + prautco_l, Model%evpco, Model%wminco, lprnt, ipr) + endif +! if (lprnt) then +! write(0,*)' prsl=',prsl(ipr,:) +! write(0,*) ' del=',del(ipr,:) +! write(0,*) ' aftlsgt0=',gt0(ipr,:),' kdt=',kdt +! write(0,*) ' aftlsgq0=',gq0(ipr,:,1),' kdt=',kdt +! write(0,*) ' aftlsgw0=',gq0(ipr,:,3),' kdt=',kdt +! write(0,*)' aft precpd rain1=',rain1(1:3),' lat=',lat +! endif + else ! with pdf clouds + ! --------------- + call gscondp (im, ix, levs, dtp, dtf, Statein%prsl, & + Statein%pgr, Stateout%gq0(1,1,1), & + Stateout%gq0(1,1,Model%ntcw), Stateout%gt0, & + Tbd%phy_f3d(1,1,1), Tbd%phy_f3d(1,1,2), & + Tbd%phy_f2d(1,1), Tbd%phy_f3d(1,1,3), & + Tbd%phy_f3d(1,1,4), Tbd%phy_f2d(1,2), rhc, & + Tbd%phy_f3d(1,1,Model%num_p3d+1), Model%sup, & + lprnt, ipr, kdt) + + call precpdp (im, ix, levs, dtp, del, Statein%prsl, & + Statein%pgr, Stateout%gq0(1,1,1), & + Stateout%gq0(1,1,Model%ntcw), Stateout%gt0, & + rain1, Diag%sr, rainp, rhc, & + Tbd%phy_f3d(1,1,Model%num_p3d+1), psautco_l, & + prautco_l, Model%evpco, Model%wminco, lprnt, ipr) + endif ! end of grid-scale precip/microphysics options + endif ! end if_num_p3d + +! if (lprnt) write(0,*) ' rain1=',rain1(ipr),' rainc=',rainc(ipr),' lat=',lat + + elseif (Model%ncld == 2) then ! MGB double-moment microphysics +! Acheng used clw here for other code to run smoothly and minimum change +! to make the code work. However, the nc and clw should be treated +! in other procceses too. August 28/2015; Hope that can be done next +! year. I believe this will make the physical interaction more reasonable +! Anning 12/5/2015 changed ntcw hold liquid only + if (Model%do_shoc) then + if (Model%fprcp == 0) then + clw(:,:,1) = Stateout%gq0(:,:,Model%ntiw) ! ice + clw(:,:,2) = Stateout%gq0(:,:,Model%ntcw) ! water + qrn(:,:) = 0. + qsnw(:,:) = 0. + ncpr(:,:) = 0. + ncps(:,:) = 0. + Tbd%phy_f3d(:,:,1) = Tbd%phy_f3d(:,:,Model%ntot3d-2) ! clouds from shoc + else + clw(:,:,1) = Stateout%gq0(:,:,Model%ntiw) ! ice + clw(:,:,2) = Stateout%gq0(:,:,Model%ntcw) ! water + qrn(:,:) = Stateout%gq0(:,:,Model%ntrw) + qsnw(:,:) = Stateout%gq0(:,:,Model%ntsw) + ncpr(:,:) = Stateout%gq0(:,:,Model%ntrnc) + ncps(:,:) = Stateout%gq0(:,:,Model%ntsnc) + Tbd%phy_f3d(:,:,1) = Tbd%phy_f3d(:,:,Model%ntot3d-2) ! clouds from shoc + end if + elseif ((Model%imfdeepcnv >= 0) .or. (Model%imfshalcnv > 0)) then + if (Model%fprcp == 0) then + clw(:,:,1) = Stateout%gq0(:,:,Model%ntiw) ! ice + clw(:,:,2) = Stateout%gq0(:,:,Model%ntcw) ! water + Tbd%phy_f3d(:,:,1) = max(0.0, min(1.0,Tbd%phy_f3d(:,:,1)+cnvc(:,:))) + ! clouds from t-dt and cnvc + qrn(:,:) = 0. + qsnw(:,:) = 0. + ncpr(:,:) = 0. + ncps(:,:) = 0. + else + clw(:,:,1) = Stateout%gq0(:,:,Model%ntiw) ! ice + clw(:,:,2) = Stateout%gq0(:,:,Model%ntcw) ! water + Tbd%phy_f3d(:,:,1) = max(0.0, min(1.0,Tbd%phy_f3d(:,:,1)+cnvc(:,:))) + ! clouds from t-dt and cnvc + qrn(:,:) = Stateout%gq0(:,:,Model%ntrw) + qsnw(:,:) = Stateout%gq0(:,:,Model%ntsw) + ncpr(:,:) = Stateout%gq0(:,:,Model%ntrnc) + ncps(:,:) = Stateout%gq0(:,:,Model%ntsnc) + endif + else + ! clouds from t-dt and cnvc + if (Model%fprcp == 0 ) then + clw(:,:,1) = Stateout%gq0(:,:,Model%ntiw) ! ice + clw(:,:,2) = Stateout%gq0(:,:,Model%ntcw) ! water + qrn(:,:) = 0. + qsnw(:,:) = 0. + ncpr(:,:) = 0. + ncps(:,:) = 0. + Tbd%phy_f3d(:,:,1) = min(1.0, Tbd%phy_f3d(:,:,1)+cnvc(:,:)) + else + clw(:,:,1) = Stateout%gq0(:,:,Model%ntiw) ! ice + clw(:,:,2) = Stateout%gq0(:,:,Model%ntcw) ! water + qrn(:,:) = Stateout%gq0(:,:,Model%ntrw) + qsnw(:,:) = Stateout%gq0(:,:,Model%ntsw) + ncpr(:,:) = Stateout%gq0(:,:,Model%ntrnc) + ncps(:,:) = Stateout%gq0(:,:,Model%ntsnc) + Tbd%phy_f3d(:,:,1) = min(1.0, Tbd%phy_f3d(:,:,1)+cnvc(:,:)) + endif + endif +! notice clw ix instead of im +! call m_micro_driver(im,ix,levs,flipv,del,dtp,prsl,prsi, +! & prslk,prsik,pgr,vvl,clw(1,1,2), QLCN, clw(1,1,1),QICN, +! if (lprnt) write(0,*)' cnv_mfdbef=',cnv_mfd(ipr,:),' flipv=',flipv +! if(lprnt) write(0,*) ' befgq0=',gq0(ipr,:,1),' kdt=',kdt +! if (lprnt) write(0,*)' clw1bef=',clw(ipr,:,1),' kdt=',kdt +! if (lprnt) write(0,*)' clw2bef=',clw(ipr,:,2),' kdt=',kdt +! if (lprnt) write(0,*)' cloudsb=',phy_f3d(ipr,:,1)*100,' kdt=',kdt +! txa(:,:) = gq0(:,:,1) + call m_micro_driver (im, ix, levs, Model%flipv, dtp, Statein%prsl, & + Statein%prsi, Statein%prslk, Statein%prsik, & + Statein%vvl, clw(1,1,2), QLCN, clw(1,1,1), QICN, & + Radtend%htrlw, Radtend%htrsw, w_upi, cf_upi, & + FRLAND, Diag%HPBL, CNV_MFD, CNV_PRC3, CNV_DQLDT, & + CLCN, Stateout%gu0, Stateout%gv0, Diag%dusfc, & + Diag%dvsfc, dusfc1, dvsfc1, dusfc1, dvsfc1, & + CNV_FICE, CNV_NDROP, CNV_NICE, Stateout%gq0(1,1,1), & + Stateout%gq0(1,1,Model%ntcw), & + Stateout%gq0(1,1,Model%ntiw), Stateout%gt0, rain1, & + Diag%sr, Stateout%gq0(1,1,Model%ntlnc), & + Stateout%gq0(1,1,Model%ntinc), Model%fprcp, qrn, & + qsnw, ncpr, ncps, Tbd%phy_f3d(1,1,1), kbot, & + Model%aero_in, skip_macro, cn_prc, cn_snr, lprnt, & + ipr, kdt, Grid%xlat, Grid%xlon) + +! write(1000+me,*)' at latitude = ',lat +! tx1 = 1000.0 +! call moist_bud(im,ix,ix,levs,me,kdt,con_g,tx1,del,rain1 +! &, txa, clw(1,1,2), clw(1,1,1) +! &, gq0(1,1,1),gq0(1,1,ntcw),gq0(1,1,ntcw+1),' m_micro ') + +! if (lprnt) write(0,*) ' rain1=',rain1(ipr)*86400.0, +! &' rainc=',rainc(ipr)*86400.0 +! &,' cn_prc=',cn_prc(ipr),' cn_snr=',cn_snr(ipr) +! if (lprnt) write(0,*) ' aftlsgq0=',gq0(ipr,:,1),' kdt=',kdt +! if (lprnt) write(0,*)' clw1aft=',gq0(ipr,:,ntiw),' kdt=',kdt +! if (lprnt) write(0,*)' cloudsm=',phy_f3d(ipr,:,1)*100,' kdt=',kdt +! if (lprnt) write(0,*)' clw2aft=',gq0(ipr,:,ntcw),' kdt=',kdt + + if (Model%fprcp == 1) then + Stateout%gq0(:,:,Model%ntrw) = qrn(:,:) + Stateout%gq0(:,:,Model%ntsw) = qsnw(:,:) + Stateout%gq0(:,:,Model%ntrnc) = ncpr(:,:) + Stateout%gq0(:,:,Model%ntsnc) = ncps(:,:) + endif + endif ! end if_ncld +! if (lprnt) write(0,*)' rain1 after ls=',rain1(ipr) +! + if (Model%do_aw) then +! Arakawa-Wu adjustment of large-scale microphysics tendencies: +! reduce by factor of (1-sigma) +! these are microphysics increments. We want to keep (1-sigma) of the increment, +! we will remove sigma*increment from final values +! fsigma = 0. ! don't apply any AW correction, in addition comment next line +! fsigma = sigmafrac + +! adjust sfc rainrate for conservation +! vertically integrate reduction of water increments, reduce precip by that amount + + temrain1(:) = 0.0 + do k = 1,levs + do i = 1,im + tem1 = sigmafrac(i,k) + Stateout%gt0(i,k) = Stateout%gt0(i,k) - tem1 * (Stateout%gt0(i,k)-dtdt(i,k)) + tem2 = tem1 * (Stateout%gq0(i,k,1)-dqdt(i,k,1)) + Stateout%gq0(i,k,1) = Stateout%gq0(i,k,1) - tem2 + temrain1(i) = temrain1(i) - (Statein%prsi(i,k)-Statein%prsi(i,k+1)) & + * tem2 * onebg + enddo + enddo + do n=Model%ntcw,Model%ntcw+Model%ncld-1 + do k = 1,levs + do i = 1,im + tem1 = sigmafrac(i,k) * (Stateout%gq0(i,k,n)-dqdt(i,k,n)) + Stateout%gq0(i,k,n) = Stateout%gq0(i,k,n) - tem1 + temrain1(i) = temrain1(i) - (Statein%prsi(i,k)-Statein%prsi(i,k+1)) & + * tem1 * onebg + enddo + enddo + enddo +! write(1000+me,*)' rain1=',rain1(4),' temrain1=',temrain1(i)*0.001 + rain1(:) = max(rain1(:) - temrain1(:)*0.001, 0.0_kind_phys) + endif + + Diag%rain(:) = Diag%rainc(:) + frain * rain1(:) + + if (Model%cal_pre) then ! hchuang: add dominant precipitation type algorithm + i = min(3,Model%num_p3d) + call calpreciptype (kdt, Model%nrcm, im, ix, levs, levs+1, & + Tbd%rann, Grid%xlat, Grid%xlon, Stateout%gt0, & + Stateout%gq0, Statein%prsl, Statein%prsi, & + Diag%rain, Statein%phii, Model%num_p3d, & + Sfcprop%tsfc, Diag%sr, Tbd%phy_f3d(1,1,i), & ! input + domr, domzr, domip, doms) ! output +! +! if (lprnt) print*,'debug calpreciptype: DOMR,DOMZR,DOMIP,DOMS ' +! &,DOMR(ipr),DOMZR(ipr),DOMIP(ipr),DOMS(ipr) +! do i=1,im +! if (abs(xlon(i)*57.29578-114.0) .lt. 0.2 .and. +! & abs(xlat(i)*57.29578-40.0) .lt. 0.2) +! & print*,'debug calpreciptype: DOMR,DOMZR,DOMIP,DOMS ', +! & DOMR(i),DOMZR(i),DOMIP(i),DOMS(i) +! end do +! HCHUANG: use new precipitation type to decide snow flag for LSM snow accumulation + + do i=1,im + if(doms(i) > 0.0 .or. domip(i) > 0.0) then + Sfcprop%srflag(i) = 1. + else + Sfcprop%srflag(i) = 0. + end if + enddo + endif + + if (Model%lssav) then + Diag%totprcp(:) = Diag%totprcp(:) + Diag%rain(:) + + if (Model%ldiag3d) then + Diag%dt3dt(:,:,6) = Diag%dt3dt(:,:,6) + (Stateout%gt0(:,:)-dtdt(:,:)) * frain + Diag%dq3dt(:,:,4) = Diag%dq3dt(:,:,4) + (Stateout%gq0(:,:,1)-dqdt(:,:,1)) * frain + endif + endif + +! --- ... estimate t850 for rain-snow decision + + t850(:) = Stateout%gt0(:,1) + + do k = 1, levs-1 + do i = 1, im + if (Statein%prsl(i,k) > p850 .and. Statein%prsl(i,k+1) <= p850) then + t850(i) = Stateout%gt0(i,k) - (Statein%prsl(i,k)-p850) / & + (Statein%prsl(i,k)-Statein%prsl(i,k+1)) * & + (Stateout%gt0(i,k)-Stateout%gt0(i,k+1)) + endif + enddo + enddo + +! --- ... lu: snow-rain detection is performed in land/sice module + + if (Model%cal_pre) then ! hchuang: new precip type algorithm defines srflag + Sfcprop%tprcp(:) = max(0.0, Diag%rain(:)) ! clu: rain -> tprcp + else + do i = 1, im + Sfcprop%tprcp(i) = max(0.0, Diag%rain(i) )! clu: rain -> tprcp + Sfcprop%srflag(i) = 0. ! clu: default srflag as 'rain' (i.e. 0) + if (t850(i) <= 273.16) then + Sfcprop%srflag(i) = 1. ! clu: set srflag to 'snow' (i.e. 1) + endif + enddo + endif + +! --- ... coupling insertion + + if (Model%cplflx .or. Model%do_sppt) then + do i = 1, im + if (t850(i) > 273.16) then + Coupling%rain_cpl(i) = Coupling%rain_cpl(i) + Diag%rain(i) + else + Coupling%snow_cpl(i) = Coupling%snow_cpl(i) + Diag%rain(i) + endif + enddo + endif + +! --- ... end coupling insertion + +!!! update surface diagnosis fields at the end of phys package +!!! this change allows gocart to use filtered wind fields +!!! + if (Model%lgocart) then + call sfc_diag (im, Statein%pgr, Stateout%gu0, Stateout%gv0, & + Stateout%gt0, Stateout%gq0, Sfcprop%tsfc, qss, & + Sfcprop%f10m, Diag%u10m, Diag%v10m, Sfcprop%t2m, & + Sfcprop%q2m, work3, evap, Sfcprop%ffmm, & + Sfcprop%ffhh, fm10, fh2) + + if (Model%lssav) then + Diag%tmpmax (:) = max(Diag%tmpmax (:),Sfcprop%t2m(:)) + Diag%tmpmin (:) = min(Diag%tmpmin (:),Sfcprop%t2m(:)) + Diag%spfhmax(:) = max(Diag%spfhmax(:),Sfcprop%q2m(:)) + Diag%spfhmin(:) = min(Diag%spfhmin(:),Sfcprop%q2m(:)) + endif + endif + +! --- ... total runoff is composed of drainage into water table and +! runoff at the surface and is accumulated in unit of meters + if (Model%lssav) then + tem = dtf * 0.001 + Diag%runoff(:) = Diag%runoff(:) + (drain(:)+runof(:)) * tem + Diag%srunoff(:) = Diag%srunoff(:) + runof(:) * tem + endif + +! --- ... xw: return updated ice thickness & concentration to global array + do i = 1, im + if (islmsk(i) == 2) then + Sfcprop%hice(i) = zice(i) + Sfcprop%fice(i) = cice(i) + Sfcprop%tisfc(i) = tice(i) + else + Sfcprop%hice(i) = 0.0 + Sfcprop%fice(i) = 0.0 + Sfcprop%tisfc(i) = Sfcprop%tsfc(i) + endif + enddo + +! --- ... return updated smsoil and stsoil to global arrays + Sfcprop%smc(:,:) = smsoil(:,:) + Sfcprop%stc(:,:) = stsoil(:,:) + Sfcprop%slc(:,:) = slsoil(:,:) + +! --- ... calculate column precipitable water "pwat" + Diag%pwat(:) = 0.0 + tem = dtf * 0.03456 / 86400.0 + do k = 1, levs + work1(:) = 0.0 + if (Model%ncld > 0) then + do ic = Model%ntcw, Model%ntcw+Model%ncld-1 + work1(:) = work1(:) + Stateout%gq0(:,k,ic) + enddo + endif + Diag%pwat(:) = Diag%pwat(:) + del(:,k)*(Stateout%gq0(:,k,1)+work1(:)) +! if (lprnt .and. i == ipr) write(0,*)' gq0=', +! &gq0(i,k,1),' qgrs=',qgrs(i,k,1),' work2=',work2(i),' k=',k + enddo + Diag%pwat(:) = Diag%pwat(:) * onebg + +! write(1000+me,*)' pwat=',pwat(i),'i=',i,', +! &' rain=',rain(i)*1000.0,' dqsfc1=',dqsfc1(i)*tem,' kdt=',kdt +! &,' e-p=',dqsfc1(i)*tem-rain(i)*1000.0 +! if (lprnt) write(0,*)' pwat=',pwat(ipr),', +! &' rain=',rain(ipr)*1000.0,' dqsfc1=',dqsfc1(ipr)*tem,' kdt=',kdt +! &,' e-p=',dqsfc1(ipr)*tem-rain(ipr)*1000.0 + +! +! if (lprnt .and. rain(ipr) > 5) call mpi_quit(5678) +! if (lat == 45) write(1000+me,*)' pwat=',pwat(1),' kdt=',kdt +! if (lprnt) then +! write(7000,*) ' endgu0=',gu0(ipr,:),' kdt=',kdt +! write(7000,*) ' endgv0=',gv0(ipr,:),' kdt=',kdt,' nnp=',nnp +! write(0,*) ' endgt0=',gt0(ipr,:),' kdt=',kdt +! write(0,*) ' endgq0=',gq0(ipr,:,1),' kdt=',kdt,' lat=',lat +! write(0,*) ' endgw0=',gq0(ipr,:,3),' kdt=',kdt,' lat=',lat +! endif + + if (Model%do_sppt) then + !--- radiation heating rate + Tbd%dtdtr(:,:) = Tbd%dtdtr(:,:) + dtdtc(:,:)*dtf + !--- change in total precip + Tbd%dtotprcp (:) = Diag%rain (:) - Tbd%dtotprcp(:) + !--- change in convective precip + Tbd%dcnvprcp (:) = Diag%rainc (:) - Tbd%dcnvprcp(:) + do i = 1, im + if (t850(i) > 273.16) then + !--- change in change in rain precip + Tbd%drain_cpl(i) = Diag%rain(i) - Tbd%drain_cpl(i) + else + !--- change in change in snow precip + Tbd%dsnow_cpl(i) = Diag%rain(i) - Tbd%dsnow_cpl(i) + endif + enddo + endif + + deallocate (clw) + if (Model%do_shoc) then + deallocate (qpl, qpi, ncpl, ncpi) + endif + if (allocated(cnvc)) deallocate(cnvc) + if (allocated(cnvw)) deallocate(cnvw) + +! deallocate (fscav, fswtr) +! +! if (lprnt) write(0,*)' end of gbphys maxu=', +! &maxval(gu0(1:im,1:levs)),' minu=',minval(gu0(1:im,1:levs)) +! &,' maxv=',maxval(gv0(1:im,1:levs)),' minv=', +! & minval(gv0(1:im,1:levs)),' kdt=',kdt,' lat=',lat,' nnp=',nnp +! if (lprnt) write(0,*)' end of gbphys gv0=',gv0(:,120:128) +! if (lprnt) write(0,*)' end of gbphys at kdt=',kdt, +! &' rain=',rain(ipr),' rainc=',rainc(ipr) +! if (lprnt) call mpi_quit(7) +! if (kdt > 2 ) call mpi_quit(70) + if (Model%ncld == 2) then ! For MGB double moment microphysics + + deallocate (qlcn, qicn, w_upi, cf_upi, CNV_MFD, CNV_PRC3, & + CNV_DQLDT, clcn, cnv_fice, cnv_ndrop, cnv_nice) + deallocate (qrn, qsnw, ncpr, ncps) + endif + + return +!................................... + end subroutine GFS_physics_driver +!----------------------------------- + + + subroutine moist_bud(im,ix,ix2,levs,me,kdt,grav,dtp,delp,rain, & + qv0,ql0,qi0,qv1,ql1,qi1,comp) +! nov 2016 - S. Moorthi - routine to compute local moisture budget + use machine, only : kind_phys + implicit none + character*10 :: comp + integer :: im,ix,ix2,levs,me,kdt + real (kind=kind_phys) :: grav, rain(im), dtp + real (kind=kind_phys), dimension(ix,levs) :: qv0,ql0,qi0,delp + real (kind=kind_phys), dimension(ix2,levs) :: qv1,ql1,qi1 + REAL (kind=kind_phys), dimension(im) :: sumq, sumqv, sumql, sumqi + integer :: i, k +! + sumqv(:) = 0.0 + sumql(:) = 0.0 + sumqi(:) = 0.0 + sumq (:) = 0.0 + do i=1,im + sumqv(:) = sumqv(:) + (qv1(:,k) - qv0(:,k)) * delp(:,k) + sumql(:) = sumql(:) + (ql1(:,k) - ql0(:,k)) * delp(:,k) + sumqi(:) = sumqi(:) + (qi1(:,k) - qi0(:,k)) * delp(:,k) + enddo + sumqv(:) = - sumqv(:) * (1.0/grav) + sumql(:) = - sumql(:) * (1.0/grav) + sumqi(:) = - sumqi(:) * (1.0/grav) + sumq (:) = sumqv(:) + sumql(:) + sumqi(:) + do i=1,im + write(1000+me,*)' in moist_bud:',' i=',i,' sumq=',sumq(i), & + ' sumqv=',sumqv(i),' sumql=',sumql(i),' sumqi=',sumqi(i), & + ' rain=',rain(i)*dtp,' kdt=',kdt,' component=',comp, & + ' qv:=',qv1(i,1),qv0(i,1),' ql=',ql1(i,1),ql0(i,1), & + ' qi=',qi1(i,1), qi0(i,1) +! if(sumq(i) > 100) then +! write(1000+me,*)' i=',i,' sumq=',sumq(i) +! write(1000+me,*)' qv1=',(qv1(i,k),k=1,levs) +! write(1000+me,*)' qv0=',(qv0(i,k),k=1,levs) +! write(1000+me,*)' ql1=',(ql1(i,k),k=1,levs) +! write(1000+me,*)' ql0=',(ql0(i,k),k=1,levs) +! write(1000+me,*)' qi1=',(qi1(i,k),k=1,levs) +! write(1000+me,*)' qi0=',(qi0(i,k),k=1,levs) +! endif + enddo + return + + end subroutine moist_bud +!> @} + +end module module_physics_driver diff --git a/physics/calpreciptype.f90 b/physics/calpreciptype.f90 index 7260b974d..e0f038bc5 100644 --- a/physics/calpreciptype.f90 +++ b/physics/calpreciptype.f90 @@ -1,4 +1,42 @@ - subroutine calpreciptype(kdt,nrcm,im,ix,lm,lp1,randomno, & +!> \file calpreciptype.f90 +!! This file contains the subroutine that calculates dominant precipitation type. It is +!! adopted from post but was made into a column to used by GFS model. + + module calpreciptype + contains + +!>\section arg_table_calpreciptype_init Argument Table + subroutine calpreciptype_init + end subroutine calpreciptype_init + +!!\section arg_table_calpreciptype_run Argument Table +!!| local var name | longname |description | units | rank | type | kind | intent | optional | +!!|----------------|------------------------------------------------|----------------------------------------------------------|---------|------|---------|-----------|--------|----------| +!!| kdt | index_of_time_step | current time step index | index | 0 | integer | | in | F | +!!| nrcm | array_dimension | second dimension of random number array | index | 0 | integer | | in | F | +!!| im | horizontal_loop_extent | horizontal loop extent, start at 1 | index | 0 | integer | | in | F | +!!| ix | horizontal_dimension | horizontal dimension | index | 0 | integer | | in | F | +!!| lm | vertical_dimension | vertical layer dimension | index | 0 | integer | | in | F | +!!| lp1 | vertical_interface_dimension | vertical interface dimension | index | 0 | integer | | in | F | +!!| randomno | random_number_array | random number array | none | 2 | real | | in | F | +!!| xlat | latitude | latitude | 1 | 1 | real | | in | F | +!!| xlon | longitude | longitude | 1 | 1 | real | | in | F | +!!| gt0 | air_temperature | layer mean air temperature | K | 2 | real | kind_phys | in | F | +!!| gq0 | water_vapor_specific_humidity | water vapor specific humidity | kg kg-1 | 2 | real | kind_phys | in | F | +!!| prsl | air_pressure | layer mean pressure | Pa | 2 | real | kind_phys | in | F | +!!| prsi | air_pressure_at_interface | pressure at layer interface | Pa | 2 | real | kind_phys | in | F | +!!| prec | total_rainfall_amount | instantaneous total precipitation at surface | m | 1 | real | kind_phys | in | F | +!!| phii | geopotential_at_interface | geopotential at model layer interfaces | m2 s-2 | 2 | real | kind_phys | in | F | +!!| n3dfercld | num_p3d=4 ?? | number of 3D arrays needed for microphysics | count | 0 | integer | | in | F | +!!| tskin | surface_skin_temperature | surface skin temperature | K | 1 | real | kind_phys | in | F | +!!| sr | ratio_of_snowfall_to_rainfall | ratio of snowfall to rainfall | frac | 1 | real | kind_phys | in | F | +!!| phy_f3d | air_temperature_at_previous_time_step | air temperature at previous time step | K | 2 | real | kind_phys | in | F | +!!| domr | dominant_rain_type | dominant rain type | none | 1 | real | kind_phys | out | F | +!!| domzr | dominant_freezing_rain_type | dominant freezing rain type | none | 1 | real | kind_phys | out | F | +!!| domip | dominant_sleet_type | dominant sleet type | none | 1 | real | kind_phys | out | F | +!!| doms | dominant_snow_type | dominant snow type | none | 1 | real | kind_phys | out | F | +! subroutine calpreciptype(kdt,nrcm,im,ix,lm,lp1,randomno, & + subroutine calpreciptype_run(kdt,nrcm,im,ix,lm,lp1,randomno, & xlat,xlon, & gt0,gq0,prsl,prsi,prec, & !input phii,n3dfercld,tskin,sr,phy_f3d, & !input @@ -121,7 +159,11 @@ subroutine calpreciptype(kdt,nrcm,im,ix,lm,lp1,randomno, & !------------------------------------------------------------------------------- ! ! instantaneous precipitation type. - +!> -# Call calwxt(), to compute precipitation type using a decision tree approach +!! that uses variables such as integrated wet bulb temperature below freezing and +!! lowest layer temperature. See Baldwin and Contorno preprint from 13th weather +!! analysis and forcasting conference for more details (or Baldwin et al, 10th NWP +!! conference preprint) call calwxt(lm,lp1,t,q,pmid,pint,con_fvirt,con_rog,con_epsq,zint,iwx,twet) snow(1) = mod(iwx,2) sleet(1) = mod(iwx,4)/2 @@ -162,6 +204,7 @@ subroutine calpreciptype(kdt,nrcm,im,ix,lm,lp1,randomno, & ! & mod(ifhr*60+ifmin,44641)+4357 ranl = randomno(i,1:2) +!> -# Call calwxt_bourg() using Bourgouin algorithm call calwxt_bourg(lm,lp1,ranl,con_g,t,q,pmid,pint,zint(1),iwx) ! @@ -172,6 +215,7 @@ subroutine calpreciptype(kdt,nrcm,im,ix,lm,lp1,randomno, & ! ! revised ncep algorithm ! +!> -# Call calwxt_revised(), revised NCEP algorithm call calwxt_revised(lm,lp1,t,q,pmid,pint, & con_fvirt,con_rog,con_epsq,zint,twet,iwx) ! @@ -195,6 +239,8 @@ subroutine calpreciptype(kdt,nrcm,im,ix,lm,lp1,randomno, & rain(5) = 0 endif ! +! -# Call calwxt_dominant(),which takes the precip type solution from different +!! algorithms and sums them up to give a dominant type. call calwxt_dominant(nalg,rain(1),freezr(1),sleet(1), & snow(1),domr(i),domzr(i),domip(i),doms(i)) @@ -496,7 +542,7 @@ subroutine calwxt_ramer(lm,lp1,t,q,pmid,rh,td,pint,ptyp) real rhmax,twmax,ptop,dpdrh,twtop,rhtop,wgt1,wgt2, & rhavg,dtavg,dpk,ptw,pbot ! real b,qtmp,rate,qc - real,external :: xmytw +!zhang real,external :: xmytw ! ! initialize. icefrac = -9999. @@ -741,13 +787,16 @@ subroutine calwxt_ramer(lm,lp1,t,q,pmid,rh,td,pint,ptyp) ! ! !-------------------------------------------------------------------------- - function xmytw(t,td,p) +!zhang + real function xmytw(t,td,p) +! function xmytw(t,td,p) ! implicit none ! integer*4 cflag, l real f, c0, c1, c2, k, kd, kw, ew, t, td, p, ed, fp, s, & - & de, xmytw + & de +! & de, xmytw data f, c0, c1, c2 /0.0006355, 26.66082, 0.0091379024, 6106.3960/ ! xmytw = (t+td) / 2 @@ -1410,3 +1459,10 @@ subroutine calwxt_dominant(nalg,rain,freezr,sleet,snow, & ! return end + +!> \section arg_table_calpreciptype_finalize Argument table +!! + subroutine calpreciptype_finalize + end subroutine calpreciptype_finalize + + end module calpreciptype diff --git a/physics/calpreciptype.f90.save b/physics/calpreciptype.f90.save new file mode 100644 index 000000000..7260b974d --- /dev/null +++ b/physics/calpreciptype.f90.save @@ -0,0 +1,1412 @@ + subroutine calpreciptype(kdt,nrcm,im,ix,lm,lp1,randomno, & + xlat,xlon, & + gt0,gq0,prsl,prsi,prec, & !input + phii,n3dfercld,tskin,sr,phy_f3d, & !input + domr,domzr,domip,doms) !output + +!$$$ subprogram documentation block +! . . . +! subprogram: calpreciptype compute dominant precip type +! prgrmmr: chuang org: w/np2 date: 2008-05-28 +! +! +! abstract: +! this routine computes precipitation type. +! . it is adopted from post but was made into a column to used by gfs model +! +! -------------------------------------------------------------------- + use funcphys, only : fpvs,ftdp,fpkap,ftlcl,stma,fthe + use physcons +!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + implicit none +! + real, parameter :: pthresh = 0.0, oneog = 1.0/con_g + integer,parameter :: nalg = 5 +! +! declare variables. +! + integer,intent(in) :: kdt,nrcm,im,ix,lm,lp1,n3dfercld + real,intent(in) :: xlat(im),xlon(im) + real,intent(in) :: randomno(ix,nrcm) + real(kind=kind_phys),dimension(im), intent(in) :: prec,sr,tskin + real(kind=kind_phys),dimension(ix,lm), intent(in) :: gt0,gq0,prsl,phy_f3d + real(kind=kind_phys),dimension(ix,lp1),intent(in) :: prsi,phii + real(kind=kind_phys),dimension(im), intent(out) :: domr,domzr,domip,doms + + integer, dimension(nalg) :: sleet,rain,freezr,snow + real(kind=kind_phys),dimension(lm) :: t,q,pmid,f_rimef + real(kind=kind_phys),dimension(lp1) :: pint,zint + real(kind=kind_phys), allocatable :: twet(:),rh(:),td(:) +! + integer i,iwx,isno,iip,izr,irain,k,k1 + real(kind=kind_phys) es,qc,pv,tdpd,pr,tr,pk,tlcl,thelcl,qwet, & + time_vert,time_ncep,time_ramer,time_bourg,time_revised,& + time_dominant,btim,timef,ranl(2) + +! +! computes wet bulb here since two algorithms use it +! lp1=lm+1 +! convert geopotential to height +! do l=1,lp1 +! zint(l)=zint(l)/con_g +! end do +! don't forget to flip 3d arrays around because gfs counts from bottom up + + allocate ( twet(lm),rh(lm),td(lm) ) + +! print*,'debug calpreciptype: ', im,lm,lp1,nrcm + +! time_vert = 0. +! time_ncep = 0. +! time_ramer = 0. +! time_bourg = 0. +! time_revised = 0. + + do i=1,im + if (prec(i) > pthresh) then + do k=1,lm + k1 = lm-k+1 + t(k1) = gt0(i,k) + q(k1) = gq0(i,k) + pmid(k1) = prsl(i,k) ! pressure in pascals + f_rimef(k1) = phy_f3d(i,k) +! +! compute wet bulb temperature +! + pv = pmid(k1)*q(k1)/(con_eps-con_epsm1*q(k1)) + td(k1) = ftdp(pv) + tdpd = t(k1)-td(k1) +! if (pmid(k1) >= 50000.) then ! only compute twet below 500mb to save time + if (tdpd > 0.) then + pr = pmid(k1) + tr = t(k1) + pk = fpkap(pr) + tlcl = ftlcl(tr,tdpd) + thelcl = fthe(tlcl,pk*tlcl/tr) + call stma(thelcl,pk,twet(k1),qwet) + else + twet(k1) = t(k1) + endif +! endif + es = min(fpvs(t(k1)), pmid(k1)) + qc = con_eps*es / (pmid(k1)+con_epsm1*es) + rh(k1) = max(con_epsq,q(k1)) / qc + + k1 = lp1-k+1 + pint(k1) = prsi(i,k) + zint(k1) = phii(i,k) * oneog + + enddo + pint(1) = prsi(i,lp1) + zint(1) = phii(i,lp1) * oneog + +!------------------------------------------------------------------------------- +! if(kdt>15.and.kdt<20) time_vert = time_vert + (timef() - btim) +! debug print statement +! if (abs(xlon(i)*57.29578-114.0) .lt. 0.2 .and. & +! abs(xlat(i)*57.29578-40.0) .lt. 0.2)then +! print*,'debug in calpreciptype: i,im,lm,lp1,xlon,xlat,prec,tskin,sr,nrcm,randomno,n3dfercld ', & +! i,im,lm,lp1,xlon(i)*57.29578,xlat(i)*57.29578,prec(i),tskin(i),sr(i), & +! nrcm,randomno(i,1:nrcm),n3dfercld +! do l=1,lm +! print*,'debug in calpreciptype: l,t,q,p,pint,z,twet', & +! l,t(l),q(l), & +! pmid(l),pint(l),zint(l),twet(l) +! end do +! print*,'debug in calpreciptype: lp1,pint,z ', lp1,pint(lp1),zint(lp1) +! end if +! end debug print statement +! call wetbulb(lm,con_rocp,con_epsq,t,q,pmid,twet) +! if(kdt>10.and.kdt<20)btim = timef() +!------------------------------------------------------------------------------- +! +! instantaneous precipitation type. + + call calwxt(lm,lp1,t,q,pmid,pint,con_fvirt,con_rog,con_epsq,zint,iwx,twet) + snow(1) = mod(iwx,2) + sleet(1) = mod(iwx,4)/2 + freezr(1) = mod(iwx,8)/4 + rain(1) = iwx/8 + +! dominant precipitation type + +!gsm if dominant precip type is requested, 4 more algorithms +!gsm will be called. the tallies are then summed in calwxt_dominant + +! ramer algorithm +! allocate ( rh(lm),td(lm) ) +! do l=1,lm +!hc: use rh and td consistent with gfs ice physics +! es=fpvs(t(l)) +! es=min(es,pmid(l)) +! qc=con_eps*es/(pmid(l)+con_epsm1*es) +! rh(l)=max(con_epsq,q(l))/qc +! pv = pmid(l)*q(l)/(con_eps-con_epsm1*q(l)) +! td(l)=ftdp(pv) +! end do +! if(kdt>10.and.kdt<20)btim = timef() + +! write(0,*)' i=',i,' lm=',lm,' lp1=',lp1,' t=',t(1),q(1),pmid(1) & +! &,' pint=',pint(1),' prec=',prec(i),' pthresh=',pthresh + + call calwxt_ramer(lm,lp1,t,q,pmid,rh,td,pint,iwx) + +! + snow(2) = mod(iwx,2) + sleet(2) = mod(iwx,4)/2 + freezr(2) = mod(iwx,8)/4 + rain(2) = iwx/8 + +! bourgouin algorithm +! iseed=44641*(int(sdat(1)-1)*24*31+int(sdat(2))*24+ihrst)+ & +! & mod(ifhr*60+ifmin,44641)+4357 + + ranl = randomno(i,1:2) + call calwxt_bourg(lm,lp1,ranl,con_g,t,q,pmid,pint,zint(1),iwx) + +! + snow(3) = mod(iwx,2) + sleet(3) = mod(iwx,4)/2 + freezr(3) = mod(iwx,8)/4 + rain(3) = iwx/8 +! +! revised ncep algorithm +! + call calwxt_revised(lm,lp1,t,q,pmid,pint, & + con_fvirt,con_rog,con_epsq,zint,twet,iwx) +! + snow(4) = mod(iwx,2) + sleet(4) = mod(iwx,4)/2 + freezr(4) = mod(iwx,8)/4 + rain(4) = iwx/8 +! +! explicit algorithm (under 18 not admitted without parent or guardian) + + if(n3dfercld == 3) then ! ferrier's scheme + call calwxt_explicit(lm,tskin(i),sr(i),f_rimef,iwx) + snow(5) = mod(iwx,2) + sleet(5) = mod(iwx,4)/2 + freezr(5) = mod(iwx,8)/4 + rain(5) = iwx/8 + else + snow(5) = 0 + sleet(5) = 0 + freezr(5) = 0 + rain(5) = 0 + endif +! + call calwxt_dominant(nalg,rain(1),freezr(1),sleet(1), & + snow(1),domr(i),domzr(i),domip(i),doms(i)) + + else ! prec < pthresh + domr(i) = 0. + domzr(i) = 0. + domip(i) = 0. + doms(i) = 0. + end if + enddo ! end loop for i + + deallocate (twet,rh,td) + return + end +! +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +! + subroutine calwxt(lm,lp1,t,q,pmid,pint, & + d608,rog,epsq,zint,iwx,twet) +! +! file: calwxt.f +! written: 11 november 1993, michael baldwin +! revisions: +! 30 sept 1994-setup new decision tree (m baldwin) +! 12 june 1998-conversion to 2-d (t black) +! 01-10-25 h chuang - modified to process hybrid model output +! 02-01-15 mike baldwin - wrf version +! +! +! routine to compute precipitation type using a decision tree +! approach that uses variables such as integrated wet bulb temp +! below freezing and lowest layer temperature +! +! see baldwin and contorno preprint from 13th weather analysis +! and forecasting conference for more details +! (or baldwin et al, 10th nwp conference preprint) +! +!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + implicit none +! +! input: +! t,q,pmid,htm,lmh,zint +! + integer,intent(in) :: lm,lp1 + real,dimension(lm),intent(in) :: t,q,pmid,twet + real,dimension(lp1),intent(in) :: zint,pint + integer,intent(out) :: iwx + real,intent(in) :: d608,rog,epsq + + +! output: +! iwx - instantaneous weather type. +! acts like a 4 bit binary +! 1111 = rain/freezing rain/ice pellets/snow +! where the one's digit is for snow +! the two's digit is for ice pellets +! the four's digit is for freezing rain +! and the eight's digit is for rain +! +! internal: +! +! real, allocatable :: twet(:) + real, parameter :: d00=0.0 + integer karr,licee + real tcold,twarm + +! subroutines called: +! wetbulb +! +! +! initialize weather type array to zero (ie, off). +! we do this since we want iwx to represent the +! instantaneous weather type on return. +! +! +! allocate local storage +! + + integer l,lice,iwrml,ifrzl + real psfck,tdchk,a,tdkl,tdpre,tlmhk,twrmk,areas8,areap4, & + surfw,surfc,dzkl,area1,pintk1,pintk2,pm150,pkl,tkl,qkl + +! allocate ( twet(lm) ) +! + iwx = 0 +! +! find coldest and warmest temps in saturated layer between +! 70 mb above ground and 500 mb +! also find highest saturated layer in that range +! +!meb + psfck = pint(lm+1) +!meb + tdchk = 2.0 + 760 tcold = t(lm) + twarm = t(lm) + licee = lm +! + do l=1,lm + qkl = q(l) + qkl = max(epsq,qkl) + tkl = t(l) + pkl = pmid(l) +! +! skip past this if the layer is not between 70 mb above ground and 500 mb +! + if (pkl < 50000.0 .or. pkl > psfck-7000.0) cycle + a = log(qkl*pkl/(6.1078*(0.378*qkl+0.622))) + tdkl = (237.3*a) / (17.269-a) + 273.15 + tdpre = tkl - tdkl + if (tdpre < tdchk .and. tkl < tcold) tcold = tkl + if (tdpre < tdchk .and. tkl > twarm) twarm = tkl + if (tdpre < tdchk .and. l < licee) licee = l + enddo +! +! if no sat layer at dew point dep=tdchk, increase tdchk +! and start again (but don't make tdchk > 6) +! + if (tcold == t(lm) .and. tdchk < 6.0) then + tdchk = tdchk + 2.0 + goto 760 + endif +! +! lowest layer t +! + karr = 0 + tlmhk = t(lm) +! +! decision tree time +! + if (tcold > 269.15) then + if (tlmhk <= 273.15) then + +! turn on the flag for freezing rain = 4 if its not on already +! izr=mod(iwx(i,j),8)/4 +! if (izr.lt.1) iwx(i,j)=iwx(i,j)+4 + + iwx = iwx + 4 + goto 850 + else +! turn on the flag for rain = 8 +! if its not on already +! irain=iwx(i,j)/8 +! if (irain.lt.1) iwx(i,j)=iwx(i,j)+8 + + iwx = iwx + 8 + goto 850 + endif + endif + karr = 1 + 850 continue +! +! compute wet bulb only at points that need it +! +! call wetbulb(lm,t,q,pmid,karr,twet) +! call wetfrzlvl(twet,zwet) +! + if (karr > 0) then + lice=licee +!meb + psfck = pint(lm+1) +!meb + tlmhk = t(lm) + twrmk = twarm +! +! twet area variables calculate only what is needed +! from ground to 150 mb above surface from ground to tcold layer +! and from ground to 1st layer where wet bulb t < 0.0 +! +! pintk1 is the pressure at the bottom of the layer +! pintk2 is the pressure at the top of the layer +! +! areap4 is the area of twet above -4 c below highest sat lyr +! + areas8 = d00 + areap4 = d00 + surfw = d00 + surfc = d00 +! + do l=lm,lice,-1 + area1 = (twet(l)-269.15) * (zint(l)-zint(l+1)) + if (twet(l) >= 269.15) areap4 = areap4 + area1 + enddo +! + if (areap4 < 3000.0) then +! turn on the flag for snow = 1 +! if its not on already +! isno=mod(iwx(i,j),2) +! if (isno.lt.1) iwx(i,j)=iwx(i,j)+1 + + iwx = iwx + 1 + return + endif +! +! areas8 is the net area of twet w.r.t. freezing in lowest 150mb +! + pintk1 = psfck + pm150 = psfck - 15000. +! + do l=lm,1,-1 + pintk2 = pint(l) + if (pintk1 >= pm150) then + dzkl = zint(l)-zint(l+1) +! sum partial layer if in 150 mb agl layer + if (pintk2 < pm150) & + dzkl = t(l)*(q(l)*d608+1.0)*rog*log(pintk1/pm150) + area1 = (twet(l)-273.15)*dzkl + areas8 = areas8 + area1 + endif + pintk1 = pintk2 + enddo +! +! surfw is the area of twet above freezing between the ground +! and the first layer above ground below freezing +! surfc is the area of twet below freezing between the ground +! and the warmest sat layer +! + ifrzl = 0 + iwrml = 0 +! + do l=lm,1,-1 + if (ifrzl == 0 .and. t(l) < 273.15) ifrzl = 1 + if (iwrml == 0 .and. t(l) >= twrmk) iwrml = 1 +! + if (iwrml == 0 .or. ifrzl == 0) then +! if(pmid(l) < 50000.)print*,'need twet above 500mb' + dzkl = zint(l)-zint(l+1) + area1 = (twet(l)-273.15)*dzkl + if(ifrzl == 0 .and. twet(l) >= 273.15) surfw = surfw + area1 + if(iwrml == 0 .and. twet(l) <= 273.15) surfc = surfc + area1 + endif + enddo + if(surfc < -3000.0 .or. (areas8 < -3000.0 .and. surfw < 50.0)) then +! turn on the flag for ice pellets = 2 if its not on already +! iip=mod(iwx(i,j),4)/2 +! if (iip.lt.1) iwx(i,j)=iwx(i,j)+2 + iwx = iwx + 2 +! + elseif(tlmhk < 273.15) then +! turn on the flag for freezing rain = 4 if its not on already +! izr=mod(iwx(k),8)/4 +! if (izr.lt.1) iwx(k)=iwx(k)+4 + iwx = iwx + 4 + else +! turn on the flag for rain = 8 if its not on already +! irain=iwx(k)/8 +! if (irain.lt.1) iwx(k)=iwx(k)+8 + iwx = iwx + 8 + endif + endif +!--------------------------------------------------------- +! deallocate (twet) + + return + end +! +! +!ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc +! +! dophase is a subroutine written and provided by jim ramer at noaa/fsl +! +! ramer, j, 1993: an empirical technique for diagnosing precipitation +! type from model output. preprints, 5th conf. on aviation +! weather systems, vienna, va, amer. meteor. soc., 227-230. +! +! code adapted for wrf post 24 august 2005 g manikin +!ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc +! + subroutine calwxt_ramer(lm,lp1,t,q,pmid,rh,td,pint,ptyp) + +! subroutine dophase(pq, ! input pressure sounding mb +! + t, ! input temperature sounding k +! + pmid, ! input pressure +! + pint, ! input interface pressure +! + q, ! input spec humidityfraction +! + lmh, ! input number of levels in sounding +! + ptyp) ! output(2) phase 2=rain, 3=frzg, 4=solid, +! 6=ip jc 9/16/99 +! use params_mod +! use ctlblk_mod +!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + implicit none +! + real,parameter :: twice=266.55,rhprcp=0.80,deltag=1.02, & + & emelt=0.045,rlim=0.04,slim=0.85 + real,parameter :: twmelt=273.15,tz=273.15,efac=1.0 ! specify in params now +! + integer*4 i, k1, lll, k2, toodry +! + real xxx ,mye, icefrac + integer, intent(in) :: lm,lp1 + real,dimension(lm), intent(in) :: t,q,pmid,rh,td + real,dimension(lp1),intent(in) :: pint + integer, intent(out) :: ptyp +! + real,dimension(lm) :: tq,pq,rhq,twq +! + integer j,l,lev,ii + real rhmax,twmax,ptop,dpdrh,twtop,rhtop,wgt1,wgt2, & + rhavg,dtavg,dpk,ptw,pbot +! real b,qtmp,rate,qc + real,external :: xmytw +! +! initialize. + icefrac = -9999. +! + + ptyp = 0 + do l = 1,lm + lev = lp1 - l +! p(l)=pmid(l) +! qc=pq0/p(l) * exp(a2*(t(l)-a3)/(t(l)-a4)) +!gsm forcing q (qtmp) to be positive to deal with negative q values +! causing problems later in this subroutine +! qtmp=max(h1m12,q(l)) +! rhqtmp(lev)=qtmp/qc + rhq(lev) = rh(l) + pq(lev) = pmid(l) * 0.01 + tq(lev) = t(l) + enddo + + +! +!cc rate restriction removed by john cortinas 3/16/99 +! +! construct wet-bulb sounding, locate generating level. + twmax = -999.0 + rhmax = 0.0 + k1 = 0 ! top of precip generating layer + k2 = 0 ! layer of maximum rh +! + if (rhq(1) < rhprcp) then + toodry = 1 + else + toodry = 0 + end if +! + pbot = pq(1) +! nq=lm + do l = 1, lm +! xxx = tdofesat(esat(tq(l))*rhq(l)) +! xxx = td(l) !hc: use td consistent with gfs ice physics + xxx = td(lp1-l) !hc: use td consistent with gfs ice physics + if (xxx < -500.) return + twq(l) = xmytw(tq(l),xxx,pq(l)) + twmax = max(twq(l),twmax) + if (pq(l) >= 400.0) then + if (rhq(l) > rhmax) then + rhmax = rhq(l) + k2 = l + end if +! + if (l /= 1) then + if (rhq(l) >= rhprcp .or. toodry == 0) then + if (toodry /= 0) then + dpdrh = log(pq(l)/pq(l-1)) / (rhq(l)-rhq(l-1)) + pbot = exp(log(pq(l))+(rhprcp-rhq(l))*dpdrh) +! + ptw = pq(l) + toodry = 0 + else if (rhq(l)>= rhprcp) then + ptw = pq(l) + else + toodry = 1 + dpdrh = log(pq(l)/pq(l-1)) / (rhq(l)-rhq(l-1)) + ptw = exp(log(pq(l))+(rhprcp-rhq(l))*dpdrh) + +!lin dpdrh = (pq(i)-pq(i-1))/(rhq(i)-rhq(i-1)) +!lin ptw = pq(i)+(rhprcp-rhq(i))*dpdrh +! + end if +! + if (pbot/ptw >= deltag) then +!lin if (pbot-ptw.lt.deltag) goto 2003 + k1 = l + ptop = ptw + end if + end if + end if + end if + enddo +! +! gross checks for liquid and solid precip which dont require generating level. +! + if (twq(1) >= 273.15+2.0) then + ptyp = 8 ! liquid + icefrac = 0.0 + return + end if +! + if (twmax <= twice) then + icefrac = 1.0 + ptyp = 1 ! solid + return + end if +! +! check to see if we had no success with locating a generating level. +! + if (k1 == 0) return +! + if (ptop == pq(k1)) then + twtop = twq(k1) + rhtop = rhq(k1) + k2 = k1 + k1 = k1 - 1 + else + k2 = k1 + k1 = k1 - 1 + wgt1 = log(ptop/pq(k2)) / log(pq(k1)/pq(k2)) + wgt2 = 1.0 - wgt1 + twtop = twq(k1) * wgt1 + twq(k2) * wgt2 + rhtop = rhq(k1) * wgt1 + rhq(k2) * wgt2 + end if +! +! calculate temp and wet-bulb ranges below precip generating level. + do l = 1, k1 + twmax = max(twq(l),twmax) + enddo +! +! gross check for solid precip, initialize ice fraction. +! if (i.eq.1.and.j.eq.1) write (*,*) 'twmax=',twmax,twice,'twtop=',twtop + + if (twtop <= twice) then + icefrac = 1.0 + if (twmax <= twmelt) then ! gross check for solid precip. + ptyp = 1 ! solid precip + return + end if + lll = 0 + else + icefrac = 0.0 + lll = 1 + end if +! +! loop downward through sounding from highest precip generating level. + 30 continue +! + if (icefrac >= 1.0) then ! starting as all ice + if (twq(k1) < twmelt) go to 40 ! cannot commence melting + if (twq(k1) == twtop) go to 40 ! both equal twmelt, nothing h + wgt1 = (twmelt-twq(k1)) / (twtop-twq(k1)) + rhavg = rhq(k1) + wgt1 * (rhtop-rhq(k1)) * 0.5 + dtavg = (twmelt-twq(k1)) * 0.5 + dpk = wgt1 * log(pq(k1)/ptop) !lin dpk=wgt1*(pq(k1)-ptop) +! mye=emelt*(1.0-(1.0-rhavg)*efac) + mye = emelt * rhavg ** efac + icefrac = icefrac + dpk * dtavg / mye + else if (icefrac <= 0.0) then ! starting as all liquid + lll = 1 +! goto 1020 + if (twq(k1) > twice) go to 40 ! cannot commence freezing + if (twq(k1) == twtop) then + wgt1 = 0.5 + else + wgt1 = (twice-twq(k1)) / (twtop-twq(k1)) + end if + rhavg = rhq(k1) + wgt1 * (rhtop-rhq(k1)) * 0.5 + dtavg = twmelt - (twq(k1)+twice) * 0.5 + dpk = wgt1 * log(pq(k1)/ptop) !lin dpk=wgt1*(pq(k1)-ptop) +! mye = emelt*(1.0-(1.0-rhavg)*efac) + mye = emelt * rhavg ** efac + icefrac = icefrac + dpk * dtavg / mye + else if ((twq(k1) <= twmelt).and.(twq(k1) < twmelt)) then ! mix + rhavg = (rhq(k1)+rhtop) * 0.5 + dtavg = twmelt - (twq(k1)+twtop) * 0.5 + dpk = log(pq(k1)/ptop) !lin dpk=pq(k1)-ptop +! mye = emelt*(1.0-(1.0-rhavg)*efac) + mye = emelt * rhavg ** efac + icefrac = icefrac + dpk * dtavg / mye + else ! mix where tw curve crosses twmelt in layer + if (twq(k1) == twtop) go to 40 ! both equal twmelt, nothing h + wgt1 = (twmelt-twq(k1)) / (twtop-twq(k1)) + wgt2 = 1.0 - wgt1 + rhavg = rhtop + wgt2 * (rhq(k1)-rhtop) * 0.5 + dtavg = (twmelt-twtop) * 0.5 + dpk = wgt2 * log(pq(k1)/ptop) !lin dpk=wgt2*(pq(k1)-ptop) +! mye = emelt*(1.0-(1.0-rhavg)*efac) + mye = emelt * rhavg ** efac + icefrac = icefrac + dpk * dtavg / mye + icefrac = min(1.0,max(icefrac,0.0)) + if (icefrac <= 0.0) then +! goto 1020 + if (twq(k1) > twice) go to 40 ! cannot commence freezin + wgt1 = (twice-twq(k1)) / (twtop-twq(k1)) + dtavg = twmelt - (twq(k1)+twice) * 0.5 + else + dtavg = (twmelt-twq(k1)) * 0.5 + end if + rhavg = rhq(k1) + wgt1 * (rhtop-rhq(k1)) * 0.5 + dpk = wgt1 * log(pq(k1)/ptop) !lin dpk=wgt1*(pq(k1)-ptop) +! mye = emelt*(1.0-(1.0-rhavg)*efac) + mye = emelt * rhavg ** efac + icefrac = icefrac + dpk * dtavg / mye + end if +! + icefrac = min(1.0,max(icefrac,0.0)) + +! if (i.eq.1.and.j.eq.1) write (*,*) 'new icefrac:', icefrac, icefrac +! +! get next level down if there is one, loop back. + 40 continue + if (k1 > 1) then + twtop = twq(k1) + ptop = pq(k1) + rhtop = rhq(k1) + k1 = k1 - 1 + go to 30 + end if +! +! determine precip type based on snow fraction and surface wet-bulb. +! + if (icefrac >= slim) then + if (lll /= 0) then + ptyp = 2 ! ice pellets jc 9/16/99 + else + ptyp = 1 ! snow + end if + else if (icefrac <= rlim) then + if (twq(1).lt.tz) then + ptyp = 4 ! freezing precip + else + ptyp = 8 ! rain + end if + else + if (twq(1) < tz) then +!gsm not sure what to do when 'mix' is predicted; in previous +!gsm versions of this code for which i had to have an answer, +!gsm i chose sleet. here, though, since we have 4 other +!gsm algorithms to provide an answer, i will not declare a +!gsm type from the ramer in this situation and allow the +!gsm other algorithms to make the call. + + ptyp = 0 ! don't know +! ptyp = 5 ! mix + else +! ptyp = 5 ! mix + ptyp = 0 ! don't know + end if + end if + + return +! + end +! +! +!-------------------------------------------------------------------------- + function xmytw(t,td,p) +! + implicit none +! + integer*4 cflag, l + real f, c0, c1, c2, k, kd, kw, ew, t, td, p, ed, fp, s, & + & de, xmytw + data f, c0, c1, c2 /0.0006355, 26.66082, 0.0091379024, 6106.3960/ +! + xmytw = (t+td) / 2 + if (td >= t) return +! + if (t < 100.0) then + k = t + 273.15 + kd = td + 273.15 + if (kd >= k) return + cflag = 1 + else + k = t + kd = td + cflag = 0 + end if +! + ed = c0 - c1 * kd - c2 / kd + if (ed < -14.0 .or. ed > 7.0) return + ed = exp(ed) + ew = c0 - c1 * k - c2 / k + if (ew < -14.0 .or. ew > 7.0) return + ew = exp(ew) + fp = p * f + s = (ew-ed) / (k-kd) + kw = (k*fp+kd*s) / (fp+s) +! + do l = 1, 5 + ew = c0 - c1 * kw - c2 / kw + if (ew < -14.0 .or. ew > 7.0) return + ew = exp(ew) + de = fp * (k-kw) + ed - ew + if (abs(de/ew) < 1e-5) exit + s = ew * (c1-c2/(kw*kw)) - fp + kw = kw - de / s + enddo +! +! print *, 'kw ', kw + if (cflag /= 0) then + xmytw = kw - 273.15 + else + xmytw = kw + end if +! + return + end +! +! +!$$$ subprogram documentation block +! +! subprogram: calwxt_bourg calculate precipitation type (bourgouin) +! prgmmr: baldwin org: np22 date: 1999-07-06 +! +! abstract: this routine computes precipitation type +! using a decision tree approach that uses the so-called +! "energy method" of bourgouin of aes (canada) 1992 +! +! program history log: +! 1999-07-06 m baldwin +! 1999-09-20 m baldwin make more consistent with bourgouin (1992) +! 2005-08-24 g manikin added to wrf post +! 2007-06-19 m iredell mersenne twister, best practices +! 2008-03-03 g manikin added checks to prevent stratospheric warming +! episodes from being seen as "warm" layers +! impacting precip type +! +! usage: call calwxt_bourg(im,jm,jsta_2l,jend_2u,jsta,jend,lm,lp1, & +! & iseed,g, & +! & t,q,pmid,pint,lmh,zint,ptype) +! input argument list: +! im integer i dimension +! jm integer j dimension +! jsta_2l integer j dimension start point (including haloes) +! jend_2u integer j dimension end point (including haloes) +! jsta integer j dimension start point (excluding haloes) +! jend integer j dimension end point (excluding haloes) +! lm integer k dimension +! lp1 integer k dimension plus 1 +! iseed integer random number seed +! g real gravity (m/s**2) +! pthresh real precipitation threshold (m) +! t real(im,jsta_2l:jend_2u,lm) mid layer temp (k) +! q real(im,jsta_2l:jend_2u,lm) specific humidity (kg/kg) +! pmid real(im,jsta_2l:jend_2u,lm) mid layer pressure (pa) +! pint real(im,jsta_2l:jend_2u,lp1) interface pressure (pa) +! lmh real(im,jsta_2l:jend_2u) max number of layers +! zint real(im,jsta_2l:jend_2u,lp1) interface height (m) +! output argument list: +! ptype real(im,jm) instantaneous weather type () +! acts like a 4 bit binary +! 1111 = rain/freezing rain/ice pellets/snow +! where the one's digit is for snow +! the two's digit is for ice pellets +! the four's digit is for freezing rain +! and the eight's digit is for rain +! in other words... +! ptype=1 snow +! ptype=2 ice pellets/mix with ice pellets +! ptype=4 freezing rain/mix with freezing rain +! ptype=8 rain +! +! modules used: +! mersenne_twister pseudo-random number generator +! +! subprograms called: +! random_number pseudo-random number generator +! +! attributes: +! language: fortran 90 +! +! remarks: vertical order of arrays must be layer 1 = top +! and layer lmh = bottom +! +!$$$ + subroutine calwxt_bourg(lm,lp1,rn,g,t,q,pmid,pint,zint,ptype) + implicit none +! +! input: + integer,intent(in) :: lm,lp1 + real,intent(in) :: g,rn(2) + real,intent(in), dimension(lm) :: t, q, pmid + real,intent(in), dimension(lp1) :: pint, zint +! +! output: + integer, intent(out) :: ptype +! + integer ifrzl,iwrml,l,lhiwrm + real pintk1,areane,tlmhk,areape,pintk2,surfw,area1,dzkl,psfck,r1,r2 +! +! initialize weather type array to zero (ie, off). +! we do this since we want ptype to represent the +! instantaneous weather type on return. +! + ptype = 0 + psfck = pint(lm+1) + +! find the depth of the warm layer based at the surface +! this will be the cut off point between computing +! the surface based warm air and the warm air aloft +! +! lowest layer t +! + tlmhk = t(lm) + iwrml = lm + 1 + if (tlmhk >= 273.15) then + do l = lm, 2, -1 + if (t(l) >= 273.15 .and. t(l-1) < 273.15 .and. & + & iwrml == lm+1) iwrml = l + end do + end if +! +! now find the highest above freezing level +! + lhiwrm = lm + 1 + do l = lm, 1, -1 +! gsm added 250 mb check to prevent stratospheric warming situations +! from counting as warm layers aloft + if (t(l) >= 273.15 .and. pmid(l) > 25000.) lhiwrm = l + end do + +! energy variables +! surfw is the positive energy between the ground +! and the first sub-freezing layer above ground +! areane is the negative energy between the ground +! and the highest layer above ground +! that is above freezing +! areape is the positive energy "aloft" +! which is the warm energy not based at the ground +! (the total warm energy = surfw + areape) +! +! pintk1 is the pressure at the bottom of the layer +! pintk2 is the pressure at the top of the layer +! dzkl is the thickness of the layer +! ifrzl is a flag that tells us if we have hit +! a below freezing layer +! + pintk1 = psfck + ifrzl = 0 + areane = 0.0 + areape = 0.0 + surfw = 0.0 + + do l = lm, 1, -1 + if (ifrzl == 0 .and. t(l) <= 273.15) ifrzl = 1 + pintk2 = pint(l) + dzkl = zint(l)-zint(l+1) + if (t(l) >= 273.15 .and. pmid(l) > 25000.) then + area1 = log(t(l)/273.15) * g * dzkl + if (l < iwrml) then + areape = areape + area1 + else + surfw = surfw + area1 + endif + elseif (l > lhiwrm) then + area1 = log(t(l)/273.15) * g * dzkl + areane = areane + abs(area1) + endif + pintk1 = pintk2 + enddo + +! +! decision tree time +! + if (areape < 2.0) then ! very little or no positive energy aloft, check for + ! positive energy just above the surface to determine rain vs. snow + if (surfw < 5.6) then ! not enough positive energy just above the surface snow = 1 + ptype = 1 + else if (surfw > 13.2) then ! enough positive energy just above the surface rain = 8 + ptype = 8 + else ! transition zone, assume equally likely rain/snow + ! picking a random number, if <=0.5 snow + r1 = rn(1) + if (r1 <= 0.5) then ! snow = 1 + ptype = 1 + else ! rain = 8 + ptype = 8 + end if + end if +! + else ! some positive energy aloft, check for enough negative energy + ! to freeze and make ice pellets to determine ip vs. zr + + if (areane > 66.0+0.66*areape) then +! enough negative area to make ip, +! now need to check if there is enough positive energy +! just above the surface to melt ip to make rain + if (surfw < 5.6) then ! not enough energy at the surface to melt ip ice pellets = 2 + ptype = 2 + elseif (surfw > 13.2) then ! enough energy at the surface to melt ip rain = 8 + ptype = 8 + else ! transition zone, assume equally likely ip/rain picking a random number, if <=0.5 ip + r1 = rn(1) + if (r1 <= 0.5) then ! ice pellets = 2 + ptype = 2 + else ! rain = 8 + ptype = 8 + end if + end if + elseif (areane < 46.0+0.66*areape) then +! not enough negative energy to refreeze, check surface temp to determine rain vs. zr + if (tlmhk < 273.15) then ! freezing rain = 4 + ptype = 4 + else ! rain = 8 + ptype = 8 + end if + else +! transition zone, assume equally likely ip/zr picking a random number, if <=0.5 ip + r1 = rn(1) + if (r1 <= 0.5) then +! still need to check positive energy just above the surface to melt ip vs. rain + if (surfw < 5.6) then ! ice pellets = 2 + ptype = 2 + else if (surfw > 13.2) then ! rain = 8 + ptype = 8 + else +! transition zone, assume equally likely ip/rain picking a random number, if <=0.5 ip + r2 = rn(2) + if (r2 <= 0.5) then ! ice pellets = 2 + ptype = 2 + else ! rain = 8 + ptype = 8 + end if + end if + else +! not enough negative energy to refreeze, check surface temp to determine rain vs. zr + if (tlmhk < 273.15) then ! freezing rain = 4 + ptype = 4 + else ! rain = 8 + ptype = 8 + end if + end if + end if + end if +! + return + end +! +! + subroutine calwxt_revised(lm,lp1,t,q,pmid,pint, & + d608,rog,epsq,zint,twet,iwx) +! +! file: calwxt.f +! written: 11 november 1993, michael baldwin +! revisions: +! 30 sept 1994-setup new decision tree (m baldwin) +! 12 june 1998-conversion to 2-d (t black) +! 01-10-25 h chuang - modified to process hybrid model output +! 02-01-15 mike baldwin - wrf version +! 05-07-07 binbin zhou - add prec for rsm +! 05-08-24 geoff manikin - modified the area requirements +! to make an alternate algorithm +! +! +! routine to compute precipitation type using a decision tree +! approach that uses variables such as integrated wet bulb temp +! below freezing and lowest layer temperature +! +! see baldwin and contorno preprint from 13th weather analysis +! and forecasting conference for more details +! (or baldwin et al, 10th nwp conference preprint) +! +! since the original version of the algorithm has a high bias +! for freezing rain and sleet, the goal is to balance that bias +! with a version more likely to predict snow +! +! use params_mod +! use ctlblk_mod +!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + implicit none +! +! list of variables needed +! parameters: +! d608,rog,h1,d00 +!hc parameter(d608=0.608,rog=287.04/9.8,h1=1.0,d00=0.0) +! +! input: +! t,q,pmid,htm,lmh,zint + + integer,intent(in) :: lm,lp1 + real,dimension(lm),intent(in) :: t,q,pmid,twet + real,dimension(lp1),intent(in) :: pint,zint + real,intent(in) :: d608,rog,epsq +! output: +! iwx - instantaneous weather type. +! acts like a 4 bit binary +! 1111 = rain/freezing rain/ice pellets/snow +! where the one's digit is for snow +! the two's digit is for ice pellets +! the four's digit is for freezing rain +! and the eight's digit is for rain + integer, intent(out) :: iwx +! internal: +! + real, parameter :: d00=0.0 + integer karr,licee + real tcold,twarm +! + integer l,lmhk,lice,iwrml,ifrzl + real psfck,tdchk,a,tdkl,tdpre,tlmhk,twrmk,areas8,areap4,area1, & + surfw,surfc,dzkl,pintk1,pintk2,pm150,qkl,tkl,pkl,area0,areap0 + +! subroutines called: +! wetbulb +! +! +! initialize weather type array to zero (ie, off). +! we do this since we want iwx to represent the +! instantaneous weather type on return. +! +! +! allocate local storage +! +! + iwx = 0 + lmhk=lm +! +! find coldest and warmest temps in saturated layer between +! 70 mb above ground and 500 mb +! also find highest saturated layer in that range +! +!meb + psfck = pint(lp1) +!meb + tdchk = 2.0 + 760 tcold = t(lmhk) + twarm = t(lmhk) + licee = lmhk +! + do l=1,lmhk + qkl = q(l) + qkl = max(epsq,qkl) + tkl = t(l) + pkl = pmid(l) +! +! skip past this if the layer is not between 70 mb above ground +! and 500 mb +! + if (pkl < 50000.0 .or. pkl > psfck-7000.0) cycle + a = log(qkl*pkl/(6.1078*(0.378*qkl+0.622))) + tdkl = (237.3*a)/(17.269-a)+273.15 + tdpre = tkl-tdkl + if (tdpre < tdchk .and. tkl < tcold) tcold = tkl + if (tdpre < tdchk .and. tkl > twarm) twarm = tkl + if (tdpre < tdchk .and. l < licee) licee = l + enddo +! +! if no sat layer at dew point dep=tdchk, increase tdchk +! and start again (but don't make tdchk > 6) +! + if (tcold == t(lmhk) .and. tdchk < 6.0) then + tdchk = tdchk + 2.0 + goto 760 + endif +! +! lowest layer t +! + karr = 0 + lmhk = lm + tlmhk = t(lmhk) +! +! decision tree time +! + if (tcold > 269.15) then + if (tlmhk <= 273.15) then +! turn on the flag for freezing rain = 4 if its not on already +! izr=mod(iwx,8)/4 +! if (izr.lt.1) iwx=iwx+4 + iwx = iwx + 4 + goto 850 + else +! turn on the flag for rain = 8 if its not on already +! irain=iwx/8 +! if (irain.lt.1) iwx=iwx+8 + iwx = iwx + 8 + goto 850 + endif + endif + karr = 1 + 850 continue +! + if (karr > 0)then + lmhk = lm + lice = licee +!meb + psfck = pint(lp1) +!meb + tlmhk = t(lmhk) + twrmk = twarm +! +! twet area variables +! calculate only what is needed +! from ground to 150 mb above surface +! from ground to tcold layer +! and from ground to 1st layer where wet bulb t < 0.0 +! +! pintk1 is the pressure at the bottom of the layer +! pintk2 is the pressure at the top of the layer +! +! areap4 is the area of twet above -4 c below highest sat lyr +! areap0 is the area of twet above 0 c below highest sat lyr +! + areas8 = d00 + areap4 = d00 + areap0 = d00 + surfw = d00 + surfc = d00 + +! + do l=lmhk,lice,-1 + dzkl = zint(l)-zint(l+1) + area1 = (twet(l)-269.15)*dzkl + area0 = (twet(l)-273.15)*dzkl + if (twet(l) >= 269.15) areap4 = areap4 + area1 + if (twet(l) >= 273.15) areap0 = areap0 + area0 + enddo +! +! if (areap4.lt.3000.0) then turn on the flag for snow = 1 if its not on already +! isno=mod(iwx,2) +! if (isno.lt.1) iwx=iwx+1 +! iwx=iwx+1 +! go to 1900 +! endif + if (areap0 < 350.0) then ! turn on the flag for snow = 1 + iwx = iwx + 1 + return + endif +! +! areas8 is the net area of twet w.r.t. freezing in lowest 150mb +! + pintk1 = psfck + pm150 = psfck - 15000. +! + do l=lmhk,1,-1 + pintk2 = pint(l) + if(pintk1 >= pm150) then + dzkl = zint(l)-zint(l+1) +! +! sum partial layer if in 150 mb agl layer +! + if(pintk2 < pm150) dzkl = t(l)*(q(l)*d608+1.0)*rog* & + log(pintk1/pm150) + area1 = (twet(l)-273.15)*dzkl + areas8 = areas8 + area1 + endif + pintk1=pintk2 + enddo +! +! surfw is the area of twet above freezing between the ground +! and the first layer above ground below freezing +! surfc is the area of twet below freezing between the ground +! and the warmest sat layer +! + ifrzl = 0 + iwrml = 0 +! + do l=lmhk,1,-1 + if (ifrzl == 0 .and. t(l) < 273.15) ifrzl = 1 + if (iwrml == 0 .and. t(l) >= twrmk) iwrml = 1 +! + if (iwrml == 0 .or. ifrzl == 0) then +! if(pmid(l) .lt. 50000.)print*,'twet needed above 500mb' + dzkl = zint(l)-zint(l+1) + area1 = (twet(l)-273.15)*dzkl + if(ifrzl == 0 .and. twet(l) >= 273.15) surfw = surfw + area1 + if(iwrml == 0 .and. twet(l) <= 273.15) surfc = surfc + area1 + endif + enddo + if (surfc < -3000.0 .or. & + & (areas8 < -3000.0 .and. surfw < 50.0)) then +! turn on the flag for ice pellets = 2 if its not on already +! iip=mod(iwx,4)/2 +! if (iip.lt.1) iwx=iwx+2 + iwx = iwx + 2 + return + endif +! + if (tlmhk < 273.15) then +! turn on the flag for freezing rain = 4 if its not on already +! izr=mod(iwx(k),8)/4 +! if (izr.lt.1) iwx(k)=iwx(k)+4 + iwx = iwx + 4 + else +! turn on the flag for rain = 8 if its not on already +! irain=iwx(k)/8 +! if (irain.lt.1) iwx(k)=iwx(k)+8 + iwx = iwx + 8 + endif +! print *, 'revised check ', iwx(500,800) + endif + + return + end +! +! + subroutine calwxt_explicit(lm,tskin,sr,f_rimef,iwx) +! +! file: calwxt.f +! written: 24 august 2005, g manikin and b ferrier +! +! routine to compute precipitation type using explicit fields +! from the model microphysics + +!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + implicit none +! +! list of variables needed +! parameters: +! +! input: + integer, intent(in) :: lm + real,intent(in) :: tskin, sr + real,intent(in) :: f_rimef(lm) + integer,intent(out) :: iwx + real snow +! real psfc +! +! allocate local storage +! + iwx = 0 + +!gsm the rsm is currently incompatible with this routine +!gsm according to b ferrier, there may be a way to write +!gsm a version of this algorithm to work with the rsm +!gsm microphysics, but it doesn't exist at this time + +! a snow ratio less than 0.5 eliminates snow and sleet +! use the skin temperature to distinguish rain from freezing rain +! note that 2-m temperature may be a better choice if the model +! has a cold bias for skin temperature +! + if (sr < 0.5) then +! surface (skin) potential temperature and temperature. +! psfc=pmid(lm) +! tskin=ths*(psfc/p1000)**capa + + if (tskin < 273.15) then ! freezing rain = 4 + iwx = iwx + 4 + else ! rain = 8 + iwx = iwx + 8 + endif + else +! +! distinguish snow from sleet with the rime factor +! + if(f_rimef(lm) >= 10) then ! sleet = 2 + iwx = iwx + 2 + else + snow = 1 + iwx = iwx + 1 + endif + endif + end +! +! + subroutine calwxt_dominant(nalg,rain,freezr,sleet,snow, & + & domr,domzr,domip,doms) +! +! written: 24 august 2005, g manikin +! +! this routine takes the precip type solutions from different +! algorithms and sums them up to give a dominant type +! +!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + implicit none +! +! input: + integer,intent(in) :: nalg + real,intent(out) :: doms,domr,domzr,domip + integer,dimension(nalg),intent(in) :: rain,snow,sleet,freezr + integer l + real totsn,totip,totr,totzr +!-------------------------------------------------------------------------- +! print* , 'into dominant' + domr = 0. + doms = 0. + domzr = 0. + domip = 0. +! + totsn = 0 + totip = 0 + totr = 0 + totzr = 0 +! loop over the number of different algorithms that are used + do l = 1, nalg + if (rain(l) > 0) then + totr = totr + 1 + elseif (snow(l) > 0) then + totsn = totsn + 1 + elseif (sleet(l) > 0) then + totip = totip + 1 + elseif (freezr(l) > 0) then + totzr = totzr + 1 + endif + enddo + +! ties are broken to favor the most dangerous form of precip +! freezing rain > snow > sleet > rain + if (totsn > totip) then + if (totsn > totzr) then + if (totsn >= totr) then + doms = 1 + else + domr = 1 + endif + elseif (totzr >= totr) then + domzr = 1 + else + domr = 1 + endif + else if (totip > totzr) then + if (totip >= totr) then + domip = 1 + else + domr = 1 + endif + else if (totzr >= totr) then + domzr = 1 + else + domr = 1 + endif +! + return + end diff --git a/physics/precpd.f b/physics/precpd.f index 83e8d442c..1a976b041 100644 --- a/physics/precpd.f +++ b/physics/precpd.f @@ -35,7 +35,7 @@ end subroutine precpd_init !!| cwm | cloud_condensed_water_specific_humidity | cloud condensed water specific humidity | kg kg-1 | 2 | real | kind_phys| inout | F | !!| t | air_temperature | layer mean air temperature | K | 2 | real | kind_phys| inout | F | !!| rn | rainfall_amount | large scale rainfall amount | m | 1 | real | kind_phys| out | F | -!!| sr | ratio_of_snowfall_to_rainfall | ratio of snowfall to large-scale rainfall | 1 | 1 | real | kind_phys| out | F | +!!| sr | ratio_of_snowfall_to_rainfall | ratio of snowfall to large-scale rainfall | frac | 1 | real | kind_phys| out | F | !!| rainp | rain_water_path | rainwater path | kg m-3 | 2 | real | kind_phys| out | F | !!| u00k | relative_humidity_threshold_for_large_scale_condensation | relative humidity threshold for large-scale condensation | 1 | 0 | real | kind_phys| in | F | !!| psautco | coefficient_from_cloud_ice_to_snow | conversion coefficient from cloud ice to snow | 1 | 0 | real | kind_phys| in | F | From 9d997badde5bd3e14c988838925a0b5771bb701d Mon Sep 17 00:00:00 2001 From: "Man.Zhang" Date: Thu, 26 Oct 2017 02:45:52 +0000 Subject: [PATCH 09/25] add precpd instertitial code 1570-1572 --- GFS_layer/GFS_physics_driver.F90 | 20 ++++++++------------ physics/precpd.f | 20 +++++++++++++++----- 2 files changed, 23 insertions(+), 17 deletions(-) diff --git a/GFS_layer/GFS_physics_driver.F90 b/GFS_layer/GFS_physics_driver.F90 index cd19304fb..4f79b6e49 100644 --- a/GFS_layer/GFS_physics_driver.F90 +++ b/GFS_layer/GFS_physics_driver.F90 @@ -596,6 +596,7 @@ subroutine GFS_physics_driver & Statein%tgrs, Statein%qgrs, del, del_gz) #endif ! +!zhang: calrhc_run rhbbot = Model%crtrh(1) rhpbl = Model%crtrh(2) rhbtop = Model%crtrh(3) @@ -1561,6 +1562,7 @@ subroutine GFS_physics_driver & if (Model%ntcw > 0) then do k=1,levs do i=1,im +!zhang: gscond, precpd interstitial calrhc_run tem = rhbbot - (rhbbot-rhbtop) * (1.0-Statein%prslk(i,k)) tem = rhc_max * work1(i) + tem * work2(i) rhc(i,k) = max(0.0, min(1.0,tem)) @@ -1571,8 +1573,9 @@ subroutine GFS_physics_driver & clw(:,:,2) = Stateout%gq0(:,:,Model%ntcw) ! water else if (Model%num_p3d == 4) then ! zhao-carr microphysics - psautco_l(:) = Model%psautco(1)*work1(:) + Model%psautco(2)*work2(:) - prautco_l(:) = Model%prautco(1)*work1(:) + Model%prautco(2)*work2(:) +!zhang: precpd interstitial +! psautco_l(:) = Model%psautco(1)*work1(:) + Model%psautco(2)*work2(:) +! prautco_l(:) = Model%prautco(1)*work1(:) + Model%prautco(2)*work2(:) clw(:,:,1) = Stateout%gq0(:,:,Model%ntcw) endif ! end if_num_p3d endif ! end if (ncld == 2) @@ -2375,24 +2378,17 @@ subroutine GFS_physics_driver & psautco_l, prautco_l, Model%evpco, Model%wminco, & Tbd%phy_f3d(1,1,Model%ntot3d-2), lprnt, ipr) else - -! call gscond (im, ix, levs, dtp, dtf, Statein%prsl, Statein%pgr, & call gscond_run (im, ix, levs, dtp, dtf, Statein%prsl, Statein%pgr,& -! Stateout%gq0(1,1,1), Stateout%gq0(1,1,Model%ntcw), & -! Stateout%gt0, Tbd%phy_f3d(1,1,1), Tbd%phy_f3d(1,1,2), & -! Tbd%phy_f2d(1,1), Tbd%phy_f3d(1,1,3), & -! Tbd%phy_f3d(1,1,4), Tbd%phy_f2d(1,2), rhc,lprnt, ipr) Stateout%gq0(:,:,1), Stateout%gq0(:,:,Model%ntcw), & Stateout%gt0, Tbd%phy_f3d(:,:,1), Tbd%phy_f3d(:,:,2), & Tbd%phy_f2d(:,1), Tbd%phy_f3d(:,:,3), & Tbd%phy_f3d(:,:,4), Tbd%phy_f2d(:,2), rhc,lprnt, ipr) -! call precpd (im, ix, levs, dtp, del, Statein%prsl, & call precpd_run (im, ix, levs, dtp, del, Statein%prsl, & -! Stateout%gq0(1,1,1), Stateout%gq0(1,1,Model%ntcw), & Stateout%gq0(:,:,1), Stateout%gq0(:,:,Model%ntcw), & - Stateout%gt0, rain1, Diag%sr, rainp, rhc, psautco_l, & - prautco_l, Model%evpco, Model%wminco, lprnt, ipr) + Stateout%gt0, rain1, Diag%sr, rainp, rhc, & + Model%psautco, Model%prautco, Model%evpco, & + Model%wminco, work1, lprnt, ipr) endif ! if (lprnt) then ! write(0,*)' prsl=',prsl(ipr,:) diff --git a/physics/precpd.f b/physics/precpd.f index 1a976b041..4c9ad6fc2 100644 --- a/physics/precpd.f +++ b/physics/precpd.f @@ -42,6 +42,7 @@ end subroutine precpd_init !!| prautco | coefficient_from_cloud_water_to_rain | conversion coefficient from cloud water to rain | 1 | 0 | real | kind_phys| in | F | !!| evpco | coefficient_for_evaporation_of_rainfall | coefficient for evaporation of rainfall | 1 | 0 | real | kind_phys| in | F | !!| wminco | cloud_condensed_water_conversion_threshold | conversion coefficient from cloud liquid and ice to precipitation | 1 | 0 | real | kind_phys| in | F | +!!| wk1 | coefficient_for_grid | grid coefficient calculated | frac | 1 | real | kind_phys| in | F | !!| lprnt | flag_print | flag for printing diagnostics to output | flag | 0 | logical | | in | F | !!| jpr | horizontal_index_of_printed_column | horizontal index of printed column | index | 0 | integer | | in | F | !! @@ -88,7 +89,8 @@ end subroutine precpd_init !! @{ subroutine precpd_run (im,ix,km,dt,del,prsl,q,cwm,t,rn,sr & &, rainp,u00k,psautco,prautco,evpco,wminco & - &, lprnt,jpr) + &, wk1,lprnt,jpr) +!zhang &, lprnt,jpr) ! ! ****************************************************************** @@ -161,8 +163,10 @@ subroutine precpd_run (im,ix,km,dt,del,prsl,q,cwm,t,rn,sr & &, del(ix,km), prsl(ix,km) & &, rn(im), sr(im) & &, dt & - &, rainp(im,km), rnp(im), & - & psautco(im), prautco(im), evpco, wminco(2) + &, rainp(im,km), rnp(im) & + &, psautco(2), prautco(2), evpco, wminco(2) & + &, psautco_l(im), prautco_l(im), wk1(im) & + &, wk2(im) ! ! real (kind=kind_phys) err(im), ers(im), precrl(im) & @@ -193,6 +197,12 @@ subroutine precpd_run (im,ix,km,dt,del,prsl,q,cwm,t,rn,sr & &, praut, fi, qc, amaxrq, rqkll integer i, k, ihpr, n ! +!-------------- GFS psautco/prautco interstitial ---------------- + do i=1, im + wk2(i) = 1.0-wk1(i) + psautco_l(i) = psautco(1)*wk1(i) + psautco(2)*wk2(i) + prautco_l(i) = prautco(1)*wk1(i) + prautco(2)*wk2(i) + enddo !-----------------------preliminaries --------------------------------- ! ! do k=1,km @@ -462,7 +472,7 @@ subroutine precpd_run (im,ix,km,dt,del,prsl,q,cwm,t,rn,sr & if (iwl(n) == 1) then ! ice phase amaxcm = max(cons_0, cwmk - wmini(i,k)) expf = dt * exp(0.025*tmt0(n)) - psaut = min(cwmk, psautco(i)*expf*amaxcm) + psaut = min(cwmk, psautco_l(i)*expf*amaxcm) ww(n) = ww(n) - psaut cwmk = max(cons_0, ww(n)) ! cwmk = max(cons_0, ww(n)-wmini(i,k)) @@ -491,7 +501,7 @@ subroutine precpd_run (im,ix,km,dt,del,prsl,q,cwm,t,rn,sr & tem2 = amaxcm * cmr * tem / max(ccr(n),cons_p01) tem2 = min(cons_50, tem2*tem2) ! praut = c00 * tem * amaxcm * (1.0-exp(-tem2)) - praut = (prautco(i)*dt) * tem * amaxcm + praut = (prautco_l(i)*dt) * tem * amaxcm & * (1.0-exp(-tem2)) praut = min(praut, cwmk) ww(n) = ww(n) - praut From a71b90c7d29ce9388b6ad644b2b4b96ec7138e3e Mon Sep 17 00:00:00 2001 From: "Man.Zhang" Date: Thu, 26 Oct 2017 22:27:32 +0000 Subject: [PATCH 10/25] fix rhc longname in zhao-carr --- physics/gscond.f | 2 +- physics/precpd.f | 4 ++-- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/physics/gscond.f b/physics/gscond.f index f9470d28f..c9c8b0a39 100644 --- a/physics/gscond.f +++ b/physics/gscond.f @@ -82,7 +82,7 @@ end subroutine gscond_init !!| tp1 | air_temperature_at_previous_time_step | air temperature at previous time step | K | 2 | real | kind_phys | inout | F | !!| qp1 | water_vapor_specific_humidity_at_previous_time_step | water vapor specific humidity at previous time step | kg kg-1 | 2 | real | kind_phys | inout | F | !!| psp1 | surface_air_pressure_at_previous_time_step | surface air surface pressure at previous time step | Pa | 1 | real | kind_phys | inout | F | -!!| u | relative_humidity_threshold_for_large_scale_condensation | relative humidity threshold for large-scale condensation | 1 | 0 | real | kind_phys | in | F | +!!| u | critical_relative_humidity | critical relative humidity | 1 | 2 | real | kind_phys | in | F | !!| lprnt | flag_print | flag for printing diagnostics to output | flag | 0 | logical | | in | F | !!| ipr | horizontal_index_of_printed_column | horizontal index of printed column | index | 0 | integer | | in | F | !! diff --git a/physics/precpd.f b/physics/precpd.f index 4c9ad6fc2..6fa1b2a7a 100644 --- a/physics/precpd.f +++ b/physics/precpd.f @@ -37,12 +37,12 @@ end subroutine precpd_init !!| rn | rainfall_amount | large scale rainfall amount | m | 1 | real | kind_phys| out | F | !!| sr | ratio_of_snowfall_to_rainfall | ratio of snowfall to large-scale rainfall | frac | 1 | real | kind_phys| out | F | !!| rainp | rain_water_path | rainwater path | kg m-3 | 2 | real | kind_phys| out | F | -!!| u00k | relative_humidity_threshold_for_large_scale_condensation | relative humidity threshold for large-scale condensation | 1 | 0 | real | kind_phys| in | F | +!!| u00k | critical_relative_humidity | critical relative humidity | 1 | 2 | real | kind_phys| in | F | !!| psautco | coefficient_from_cloud_ice_to_snow | conversion coefficient from cloud ice to snow | 1 | 0 | real | kind_phys| in | F | !!| prautco | coefficient_from_cloud_water_to_rain | conversion coefficient from cloud water to rain | 1 | 0 | real | kind_phys| in | F | !!| evpco | coefficient_for_evaporation_of_rainfall | coefficient for evaporation of rainfall | 1 | 0 | real | kind_phys| in | F | !!| wminco | cloud_condensed_water_conversion_threshold | conversion coefficient from cloud liquid and ice to precipitation | 1 | 0 | real | kind_phys| in | F | -!!| wk1 | coefficient_for_grid | grid coefficient calculated | frac | 1 | real | kind_phys| in | F | +!!| wk1 | coefficient_for_grid | grid coefficient | frac | 1 | real | kind_phys| in | F | !!| lprnt | flag_print | flag for printing diagnostics to output | flag | 0 | logical | | in | F | !!| jpr | horizontal_index_of_printed_column | horizontal index of printed column | index | 0 | integer | | in | F | !! From 770c6fa684c8da76f1d63cd2962ce8bf18d26119 Mon Sep 17 00:00:00 2001 From: "Man.Zhang" Date: Fri, 27 Oct 2017 17:58:43 +0000 Subject: [PATCH 11/25] add physics/GFS_calpreciptype.f90, and some modification of Z-C --- GFS_layer/GFS_physics_driver.F90 | 89 +- makefile | 2 +- makefile.orig | 189 ++++ physics/GFS_calpreciptype.f90 | 1510 ++++++++++++++++++++++++++++++ physics/gscond.f | 4 +- physics/precpd.f | 4 +- 6 files changed, 1752 insertions(+), 46 deletions(-) create mode 100644 makefile.orig create mode 100644 physics/GFS_calpreciptype.f90 diff --git a/GFS_layer/GFS_physics_driver.F90 b/GFS_layer/GFS_physics_driver.F90 index 4f79b6e49..b0f7eb8ca 100644 --- a/GFS_layer/GFS_physics_driver.F90 +++ b/GFS_layer/GFS_physics_driver.F90 @@ -16,9 +16,9 @@ module module_physics_driver GFS_tbd_type, GFS_cldprop_type, & GFS_radtend_type, GFS_diag_type - use zhaocarr_gscond, only: gscond_run - use zhaocarr_precpd, only: precpd_run - use calpreciptype, only: calpreciptype_run + use GFS_zhaocarr_gscond, only: gscond_run + use GFS_zhaocarr_precpd, only: precpd_run + use GFS_calpreciptype, only: GFS_calpreciptype_run implicit none @@ -2569,17 +2569,24 @@ subroutine GFS_physics_driver & endif Diag%rain(:) = Diag%rainc(:) + frain * rain1(:) - - if (Model%cal_pre) then ! hchuang: add dominant precipitation type algorithm - i = min(3,Model%num_p3d) -! call calpreciptype (kdt, Model%nrcm, im, ix, levs, levs+1, & - call calpreciptype_run (kdt, Model%nrcm, im, ix, levs, levs+1, & - Tbd%rann, Grid%xlat, Grid%xlon, Stateout%gt0, & + + call GFS_calpreciptype_run (kdt, Model%nrcm, im, ix, levs, levs+1, & + Tbd%rann, Model%cal_pre, Stateout%gt0, & Stateout%gq0, Statein%prsl, Statein%prsi, & Diag%rain, Statein%phii, Model%num_p3d, & -! Sfcprop%tsfc, Diag%sr, Tbd%phy_f3d(1,1,i), & ! input - Sfcprop%tsfc, Diag%sr, Tbd%phy_f3d(:,:,i), & ! input - domr, domzr, domip, doms) ! output + Sfcprop%tsfc, Diag%sr, Tbd%phy_f3d(:,:,i), & ! input + domr, domzr, domip, doms, Sfcprop%srflag, & ! output + Sfcprop%tprcp) + + +! if (Model%cal_pre) then ! hchuang: add dominant precipitation type algorithm +! i = min(3,Model%num_p3d) +! call calpreciptype_run (kdt, Model%nrcm, im, ix, levs, levs+1, & +! Tbd%rann, Grid%xlat, Grid%xlon, Stateout%gt0, & +! Stateout%gq0, Statein%prsl, Statein%prsi, & +! Diag%rain, Statein%phii, Model%num_p3d, & +! Sfcprop%tsfc, Diag%sr, Tbd%phy_f3d(:,:,i), & ! input +! domr, domzr, domip, doms) ! output ! ! if (lprnt) print*,'debug calpreciptype: DOMR,DOMZR,DOMIP,DOMS ' ! &,DOMR(ipr),DOMZR(ipr),DOMIP(ipr),DOMS(ipr) @@ -2591,14 +2598,14 @@ subroutine GFS_physics_driver & ! end do ! HCHUANG: use new precipitation type to decide snow flag for LSM snow accumulation - do i=1,im - if(doms(i) > 0.0 .or. domip(i) > 0.0) then - Sfcprop%srflag(i) = 1. - else - Sfcprop%srflag(i) = 0. - end if - enddo - endif +! do i=1,im +! if(doms(i) > 0.0 .or. domip(i) > 0.0) then +! Sfcprop%srflag(i) = 1. +! else +! Sfcprop%srflag(i) = 0. +! end if +! enddo +! endif if (Model%lssav) then Diag%totprcp(:) = Diag%totprcp(:) + Diag%rain(:) @@ -2611,31 +2618,31 @@ subroutine GFS_physics_driver & ! --- ... estimate t850 for rain-snow decision - t850(:) = Stateout%gt0(:,1) +! t850(:) = Stateout%gt0(:,1) - do k = 1, levs-1 - do i = 1, im - if (Statein%prsl(i,k) > p850 .and. Statein%prsl(i,k+1) <= p850) then - t850(i) = Stateout%gt0(i,k) - (Statein%prsl(i,k)-p850) / & - (Statein%prsl(i,k)-Statein%prsl(i,k+1)) * & - (Stateout%gt0(i,k)-Stateout%gt0(i,k+1)) - endif - enddo - enddo +! do k = 1, levs-1 +! do i = 1, im +! if (Statein%prsl(i,k) > p850 .and. Statein%prsl(i,k+1) <= p850) then +! t850(i) = Stateout%gt0(i,k) - (Statein%prsl(i,k)-p850) / & +! (Statein%prsl(i,k)-Statein%prsl(i,k+1)) * & +! (Stateout%gt0(i,k)-Stateout%gt0(i,k+1)) +! endif +! enddo +! enddo ! --- ... lu: snow-rain detection is performed in land/sice module - if (Model%cal_pre) then ! hchuang: new precip type algorithm defines srflag - Sfcprop%tprcp(:) = max(0.0, Diag%rain(:)) ! clu: rain -> tprcp - else - do i = 1, im - Sfcprop%tprcp(i) = max(0.0, Diag%rain(i) )! clu: rain -> tprcp - Sfcprop%srflag(i) = 0. ! clu: default srflag as 'rain' (i.e. 0) - if (t850(i) <= 273.16) then - Sfcprop%srflag(i) = 1. ! clu: set srflag to 'snow' (i.e. 1) - endif - enddo - endif +! if (Model%cal_pre) then ! hchuang: new precip type algorithm defines srflag +! Sfcprop%tprcp(:) = max(0.0, Diag%rain(:)) ! clu: rain -> tprcp +! else +! do i = 1, im +! Sfcprop%tprcp(i) = max(0.0, Diag%rain(i) )! clu: rain -> tprcp +! Sfcprop%srflag(i) = 0. ! clu: default srflag as 'rain' (i.e. 0) +! if (t850(i) <= 273.16) then +! Sfcprop%srflag(i) = 1. ! clu: set srflag to 'snow' (i.e. 1) +! endif +! enddo +! endif ! --- ... coupling insertion diff --git a/makefile b/makefile index 95c891e1b..60430a268 100644 --- a/makefile +++ b/makefile @@ -114,7 +114,7 @@ SRCS_f = \ ./physics/tridi2t3.f SRCS_f90 = \ - ./physics/calpreciptype.f90 \ + ./physics/GFS_calpreciptype.f90 \ ./physics/cs_conv.f90 \ ./physics/funcphys.f90 \ ./physics/gcm_shoc.f90 \ diff --git a/makefile.orig b/makefile.orig new file mode 100644 index 000000000..95c891e1b --- /dev/null +++ b/makefile.orig @@ -0,0 +1,189 @@ +SHELL = /bin/sh + +inside_nems := $(wildcard ../../../conf/configure.nems) +ifneq ($(strip $(inside_nems)),) + include ../../../conf/configure.nems +else + exist_configure_fv3 := $(wildcard ../conf/configure.fv3) + ifneq ($(strip $(exist_configure_fv3)),) + include ../conf/configure.fv3 + else + $(error "../conf/configure.fv3 file is missing. Run ./configure") + endif + $(info ) + $(info Build standalone FV3 gfsphysics ...) + $(info ) +endif + +LIBRARY = libgfsphys.a + +FFLAGS += -I../fms -I../fms/include + +CPPDEFS = -DNEW_TAUCTMAX -DSMALL_PE -DNEMS_GSM + +SRCS_f = \ + ./physics/cnvc90.f \ + ./physics/co2hc.f \ + ./physics/date_def.f \ + ./physics/dcyc2.f \ + ./physics/dcyc2.pre.rad.f \ + ./physics/efield.f \ + ./physics/get_prs.f \ + ./physics/gfs_phy_tracer_config.f \ + ./physics/gocart_tracer_config_stub.f \ + ./physics/gscond.f \ + ./physics/gscondp.f \ + ./physics/gwdc.f \ + ./physics/gwdps.f \ + ./physics/h2o_def.f \ + ./physics/h2oc.f \ + ./physics/h2ohdc.f \ + ./physics/h2ophys.f \ + ./physics/ideaca.f \ + ./physics/idea_co2.f \ + ./physics/idea_composition.f \ + ./physics/idea_dissipation.f \ + ./physics/idea_h2o.f \ + ./physics/idea_ion.f \ + ./physics/idea_o2_o3.f \ + ./physics/idea_phys.f \ + ./physics/idea_solar_heating.f \ + ./physics/idea_tracer.f \ + ./physics/iounitdef.f \ + ./physics/lrgsclr.f \ + ./physics/mersenne_twister.f \ + ./physics/mfdeepcnv.f \ + ./physics/mfpbl.f \ + ./physics/mfshalcnv.f \ + ./physics/module_bfmicrophysics.f \ + ./physics/moninedmf.f \ + ./physics/moninp.f \ + ./physics/moninp1.f \ + ./physics/moninq.f \ + ./physics/moninq1.f \ + ./physics/moninshoc.f \ + ./physics/mstadb.f \ + ./physics/mstadbtn.f \ + ./physics/mstadbtn2.f \ + ./physics/mstcnv.f \ + ./physics/namelist_soilveg.f \ + ./physics/ozne_def.f \ + ./physics/ozphys.f \ + ./physics/ozphys_2015.f \ + ./physics/physparam.f \ + ./physics/precpd.f \ + ./physics/precpd_shoc.f \ + ./physics/precpdp.f \ + ./physics/precpd_shoc.f \ + ./physics/progt2.f \ + ./physics/progtm_module.f \ + ./physics/rad_initialize.f \ + ./physics/radiation_aerosols.f \ + ./physics/radiation_astronomy.f \ + ./physics/radiation_clouds.f \ + ./physics/radiation_gases.f \ + ./physics/radiation_surface.f \ + ./physics/radlw_datatb.f \ + ./physics/radlw_main.f \ + ./physics/radlw_param.f \ + ./physics/radsw_datatb.f \ + ./physics/radsw_main.f \ + ./physics/radsw_param.f \ + ./physics/rascnvv2.f \ + ./physics/rayleigh_damp.f \ + ./physics/rayleigh_damp_mesopause.f \ + ./physics/sascnv.f \ + ./physics/sascnvn.f \ + ./physics/set_soilveg.f \ + ./physics/sfc_cice.f \ + ./physics/sfc_diag.f \ + ./physics/sfc_diff.f \ + ./physics/sfc_drv.f \ + ./physics/sfc_land.f \ + ./physics/sfc_nst.f \ + ./physics/sfc_ocean.f \ + ./physics/sfc_sice.f \ + ./physics/sfcsub.f \ + ./physics/sflx.f \ + ./physics/shalcnv.f \ + ./physics/shalcv.f \ + ./physics/shalcv_1lyr.f \ + ./physics/shalcv_fixdp.f \ + ./physics/shalcv_opr.f \ + ./physics/tracer_const_h.f \ + ./physics/tridi2t3.f + +SRCS_f90 = \ + ./physics/calpreciptype.f90 \ + ./physics/cs_conv.f90 \ + ./physics/funcphys.f90 \ + ./physics/gcm_shoc.f90 \ + ./physics/gcycle.f90 \ + ./physics/get_prs_fv3.f90 \ + ./physics/h2ointerp.f90 \ + ./physics/m_micro_driver.f90 \ + ./physics/module_nst_model.f90 \ + ./physics/module_nst_parameters.f90 \ + ./physics/module_nst_water_prop.f90 \ + ./physics/ozinterp.f90 \ + ./physics/physcons.f90 \ + ./physics/wam_f107_kp_mod.f90 + +SRCS_F = ./physics/aer_cloud.F \ + ./physics/cldmacro.F \ + ./physics/cldwat2m_micro.F \ + ./physics/machine.F \ + ./physics/num_parthds.F \ + ./physics/wv_saturation.F + +SRCS_F90 = \ + ./physics/GFDL_parse_tracers.F90 \ + ./GFS_layer/GFS_abstraction_layer.F90 \ + ./GFS_layer/GFS_diagnostics.F90 \ + ./GFS_layer/GFS_driver.F90 \ + ./GFS_layer/GFS_physics_driver.F90 \ + ./GFS_layer/GFS_radiation_driver.F90 \ + ./GFS_layer/GFS_restart.F90 \ + ./GFS_layer/GFS_typedefs.F90 \ + ./IPD_layer/IPD_driver.F90 \ + ./IPD_layer/IPD_typedefs.F90 + +SRCS_c = + +DEPEND_FILES = $(SRCS_f) $(SRCS_f90) $(SRCS_F) $(SRCS_F90) + +OBJS_f = $(SRCS_f:.f=.o) +OBJS_f90 = $(SRCS_f90:.f90=.o) +OBJS_F = $(SRCS_F:.F=.o) +OBJS_F90 = $(SRCS_F90:.F90=.o) +OBJS_c = $(SRCS_c:.c=.o) + +OBJS = $(OBJS_f) $(OBJS_f90) $(OBJS_F) $(OBJS_F90) $(OBJS_c) + +all default: depend $(LIBRARY) + +$(LIBRARY): $(OBJS) + $(AR) $(ARFLAGS) $@ $? + +# this is the place to override default (implicit) compilation rules +# and create specific (explicit) rules + +./radiation_aerosols.o : ./gfsphys/radiation_aerosols.f + $(FC) $(FFLAGS) $(OTHER_FFLAGS) -xCORE-AVX-I -c $< -o $@ + +.PHONY: clean +clean: + @echo "Cleaning gfsphysics ... " + @echo + $(RM) -f $(LIBRARY) *__genmod.f90 *.o */*.o *.mod *.lst *.i depend + +MKDEPENDS = ../mkDepends.pl +include ../conf/make.rules + +include ./depend + +# do not include 'depend' file if the target contains string 'clean' +ifneq (clean,$(findstring clean,$(MAKECMDGOALS))) + -include depend +endif + diff --git a/physics/GFS_calpreciptype.f90 b/physics/GFS_calpreciptype.f90 new file mode 100644 index 000000000..25b4de424 --- /dev/null +++ b/physics/GFS_calpreciptype.f90 @@ -0,0 +1,1510 @@ +!> \file GFS_calpreciptype.F90 +!! This file contains the subroutine that calculates dominant precipitation type (calpreciptype) +!! and its post. It is adopted from post but was made into a column to used by GFS model. + + module GFS_calpreciptype + contains + +!>\section arg_table_calpreciptype_init Argument Table + subroutine GFS_calpreciptype_init + end subroutine GFS_calpreciptype_init + +!!\section arg_table_calpreciptype_run Argument Table +!!| local var name | longname |description | units | rank | type | kind | intent | optional | +!!|----------------|------------------------------------------------|----------------------------------------------------------|---------|------|---------|-----------|--------|----------| +!!| kdt | index_of_time_step | current time step index | index | 0 | integer | | in | F | +!!| nrcm | array_dimension_of_random_number | second dimension of random number array | count | 0 | integer | | in | F | +!!| im | horizontal_loop_extent | horizontal loop extent, start at 1 | index | 0 | integer | | in | F | +!!| ix | horizontal_dimension | horizontal dimension | index | 0 | integer | | in | F | +!!| lm | vertical_dimension | vertical layer dimension | index | 0 | integer | | in | F | +!!| lp1 | vertical_interface_dimension | vertical interface dimension | index | 0 | integer | | in | F | +!!| randomno | random_number_array | random number array | none | 2 | real | | in | F | +!!| cal_pre | flag_for_precipitation_type_algorithm | flag controls precip type algorithm | flag | 0 | logical | | in | F | +!!| gt0 | air_temperature | layer mean air temperature | K | 2 | real | kind_phys | in | F | +!!| gq0 | water_vapor_specific_humidity | water vapor specific humidity | kg kg-1 | 2 | real | kind_phys | in | F | +!!| prsl | air_pressure | layer mean pressure | Pa | 2 | real | kind_phys | in | F | +!!| prsi | air_pressure_at_interface | pressure at layer interface | Pa | 2 | real | kind_phys | in | F | +!!| prec | total_rainfall_amount | instantaneous total precipitation at surface | m | 1 | real | kind_phys | in | F | +!!| phii | geopotential_at_interface | geopotential at model layer interfaces | m2 s-2 | 2 | real | kind_phys | in | F | +!!| n3dfercld | array_dimension_of_microphysics | number of 3D arrays needed for microphysics | count | 0 | integer | | in | F | +!!| tskin | surface_skin_temperature | surface skin temperature | K | 1 | real | kind_phys | in | F | +!!| sr | ratio_of_snowfall_to_rainfall | ratio of snowfall to rainfall | frac | 1 | real | kind_phys | in | F | +!!| phy_f3d | air_temperature_at_previous_time_step | air temperature at previous time step | K | 2 | real | kind_phys | in | F | +!!| domr | dominant_rain_type | dominant rain type | none | 1 | real | kind_phys | out | F | +!!| domzr | dominant_freezing_rain_type | dominant freezing rain type | none | 1 | real | kind_phys | out | F | +!!| domip | dominant_sleet_type | dominant sleet type | none | 1 | real | kind_phys | out | F | +!!| doms | dominant_snow_type | dominant snow type | none | 1 | real | kind_phys | out | F | +!!| srflag | preciptation_type_flag | snow(1)/rain(0) flag for precipitation | 1 | 1 | real | kind_phys | out | F | +!!| tprcp | precipitation_amount_in_one_dynamics_time_step | precipitation amount in one dynamics time step | m | 1 | real | kind_phys | out | F | + subroutine GFS_calpreciptype_run(kdt,nrcm,im,ix,lm,lp1,randomno, & + cal_pre, & + gt0,gq0,prsl,prsi,prec, & !input + phii,n3dfercld,tskin,sr,phy_f3d, & !input + domr,domzr,domip,doms,srflag,tprcp) !output + +!$$$ subprogram documentation block +! . . . +! subprogram: calpreciptype compute dominant precip type +! prgrmmr: chuang org: w/np2 date: 2008-05-28 +! +! +! abstract: +! this routine computes precipitation type. +! . it is adopted from post but was made into a column to used by gfs model +! +! -------------------------------------------------------------------- + use funcphys, only : fpvs,ftdp,fpkap,ftlcl,stma,fthe + use physcons +!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + implicit none +! + real, parameter :: pthresh = 0.0, oneog = 1.0/con_g + integer,parameter :: nalg = 5 +! +! declare variables. +! + integer,intent(in) :: kdt,nrcm,im,ix,lm,lp1,n3dfercld + logical :: cal_pre + real,intent(in) :: randomno(ix,nrcm) + real(kind=kind_phys),dimension(im), intent(in) :: prec,sr,tskin + real(kind=kind_phys),dimension(ix,lm), intent(in) :: gt0,gq0,prsl,phy_f3d + real(kind=kind_phys),dimension(ix,lp1),intent(in) :: prsi,phii + real(kind=kind_phys),dimension(im), intent(out) :: domr,domzr,domip,doms + real(kind=kind_phys),dimension(im), intent(out) :: srflag,tprcp + real(kind=kind_phys),dimension(im) :: t850 + real(kind=kind_phys), parameter :: p850 = 85000.0 + + integer, dimension(nalg) :: sleet,rain,freezr,snow + real(kind=kind_phys),dimension(lm) :: t,q,pmid,f_rimef + real(kind=kind_phys),dimension(lp1) :: pint,zint + real(kind=kind_phys), allocatable :: twet(:),rh(:),td(:) +! + integer i,iwx,isno,iip,izr,irain,k,k1 + real(kind=kind_phys) es,qc,pv,tdpd,pr,tr,pk,tlcl,thelcl,qwet, & + time_vert,time_ncep,time_ramer,time_bourg,time_revised,& + time_dominant,btim,timef,ranl(2) + +! +! computes wet bulb here since two algorithms use it +! lp1=lm+1 +! convert geopotential to height +! do l=1,lp1 +! zint(l)=zint(l)/con_g +! end do +! don't forget to flip 3d arrays around because gfs counts from bottom up + +!--- original GFS calpreciptype_pre interstitial------------------- + if (cal_pre) then !hchuang: add dominant precipitation type algorithm + i = min(3,n3dfercld) + +!--- original subroutine calpreiptype start ----------------- + allocate ( twet(lm),rh(lm),td(lm) ) + +! print*,'debug calpreciptype: ', im,lm,lp1,nrcm + +! time_vert = 0. +! time_ncep = 0. +! time_ramer = 0. +! time_bourg = 0. +! time_revised = 0. + + do i=1,im + if (prec(i) > pthresh) then + do k=1,lm + k1 = lm-k+1 + t(k1) = gt0(i,k) + q(k1) = gq0(i,k) + pmid(k1) = prsl(i,k) ! pressure in pascals + f_rimef(k1) = phy_f3d(i,k) +! +! compute wet bulb temperature +! + pv = pmid(k1)*q(k1)/(con_eps-con_epsm1*q(k1)) + td(k1) = ftdp(pv) + tdpd = t(k1)-td(k1) +! if (pmid(k1) >= 50000.) then ! only compute twet below 500mb to save time + if (tdpd > 0.) then + pr = pmid(k1) + tr = t(k1) + pk = fpkap(pr) + tlcl = ftlcl(tr,tdpd) + thelcl = fthe(tlcl,pk*tlcl/tr) + call stma(thelcl,pk,twet(k1),qwet) + else + twet(k1) = t(k1) + endif +! endif + es = min(fpvs(t(k1)), pmid(k1)) + qc = con_eps*es / (pmid(k1)+con_epsm1*es) + rh(k1) = max(con_epsq,q(k1)) / qc + + k1 = lp1-k+1 + pint(k1) = prsi(i,k) + zint(k1) = phii(i,k) * oneog + + enddo + pint(1) = prsi(i,lp1) + zint(1) = phii(i,lp1) * oneog + +!------------------------------------------------------------------------------- +! if(kdt>15.and.kdt<20) time_vert = time_vert + (timef() - btim) +! debug print statement +! if (abs(xlon(i)*57.29578-114.0) .lt. 0.2 .and. & +! abs(xlat(i)*57.29578-40.0) .lt. 0.2)then +! print*,'debug in calpreciptype: i,im,lm,lp1,xlon,xlat,prec,tskin,sr,nrcm,randomno,n3dfercld ', & +! i,im,lm,lp1,xlon(i)*57.29578,xlat(i)*57.29578,prec(i),tskin(i),sr(i), & +! nrcm,randomno(i,1:nrcm),n3dfercld +! do l=1,lm +! print*,'debug in calpreciptype: l,t,q,p,pint,z,twet', & +! l,t(l),q(l), & +! pmid(l),pint(l),zint(l),twet(l) +! end do +! print*,'debug in calpreciptype: lp1,pint,z ', lp1,pint(lp1),zint(lp1) +! end if +! end debug print statement +! call wetbulb(lm,con_rocp,con_epsq,t,q,pmid,twet) +! if(kdt>10.and.kdt<20)btim = timef() +!------------------------------------------------------------------------------- +! +! instantaneous precipitation type. + + call calwxt(lm,lp1,t,q,pmid,pint,con_fvirt,con_rog,con_epsq,zint,iwx,twet) + snow(1) = mod(iwx,2) + sleet(1) = mod(iwx,4)/2 + freezr(1) = mod(iwx,8)/4 + rain(1) = iwx/8 + +! dominant precipitation type + +!gsm if dominant precip type is requested, 4 more algorithms +!gsm will be called. the tallies are then summed in calwxt_dominant + +! ramer algorithm +! allocate ( rh(lm),td(lm) ) +! do l=1,lm +!hc: use rh and td consistent with gfs ice physics +! es=fpvs(t(l)) +! es=min(es,pmid(l)) +! qc=con_eps*es/(pmid(l)+con_epsm1*es) +! rh(l)=max(con_epsq,q(l))/qc +! pv = pmid(l)*q(l)/(con_eps-con_epsm1*q(l)) +! td(l)=ftdp(pv) +! end do +! if(kdt>10.and.kdt<20)btim = timef() + +! write(0,*)' i=',i,' lm=',lm,' lp1=',lp1,' t=',t(1),q(1),pmid(1) & +! &,' pint=',pint(1),' prec=',prec(i),' pthresh=',pthresh + + call calwxt_ramer(lm,lp1,t,q,pmid,rh,td,pint,iwx) + +! + snow(2) = mod(iwx,2) + sleet(2) = mod(iwx,4)/2 + freezr(2) = mod(iwx,8)/4 + rain(2) = iwx/8 + +! bourgouin algorithm +! iseed=44641*(int(sdat(1)-1)*24*31+int(sdat(2))*24+ihrst)+ & +! & mod(ifhr*60+ifmin,44641)+4357 + + ranl = randomno(i,1:2) + call calwxt_bourg(lm,lp1,ranl,con_g,t,q,pmid,pint,zint(1),iwx) + +! + snow(3) = mod(iwx,2) + sleet(3) = mod(iwx,4)/2 + freezr(3) = mod(iwx,8)/4 + rain(3) = iwx/8 +! +! revised ncep algorithm +! + call calwxt_revised(lm,lp1,t,q,pmid,pint, & + con_fvirt,con_rog,con_epsq,zint,twet,iwx) +! + snow(4) = mod(iwx,2) + sleet(4) = mod(iwx,4)/2 + freezr(4) = mod(iwx,8)/4 + rain(4) = iwx/8 +! +! explicit algorithm (under 18 not admitted without parent or guardian) + + if(n3dfercld == 3) then ! ferrier's scheme + call calwxt_explicit(lm,tskin(i),sr(i),f_rimef,iwx) + snow(5) = mod(iwx,2) + sleet(5) = mod(iwx,4)/2 + freezr(5) = mod(iwx,8)/4 + rain(5) = iwx/8 + else + snow(5) = 0 + sleet(5) = 0 + freezr(5) = 0 + rain(5) = 0 + endif +! + call calwxt_dominant(nalg,rain(1),freezr(1),sleet(1), & + snow(1),domr(i),domzr(i),domip(i),doms(i)) + + else ! prec < pthresh + domr(i) = 0. + domzr(i) = 0. + domip(i) = 0. + doms(i) = 0. + end if + enddo ! end loop for i + + deallocate (twet,rh,td) + +!!--- below is the original calpreciptype_post + do i=1,im + if(doms(i) > 0.0 .or. domip(i) > 0.0) then + srflag(i)=1. + else + srflag(i)=0. + end if + enddo + + endif ! cal_pre + +! --- ... estimate t850 for rain-snow decision + + !t850(:) = Stateout%gt0(:,1) + t850(:) = gt0(:,1) + + do k = 1, lm-1 + do i = 1, im + if (prsl(i,k) > p850 .and. prsl(i,k+1) <= p850) then + t850(i) = gt0(i,k) - (prsl(i,k)-p850) / & + (prsl(i,k) - prsl(i,k+1)) * & + (gt0(i,k) - gt0(i,k+1)) + endif + enddo + enddo + +! --- ... lu: snow-rain detection is performed in land/sice module + + if (cal_pre) then ! hchuang: new precip type algorithm defines srflag + tprcp(:) = max(0.0, prec(:)) ! clu: rain -> tprcp + + else + do i = 1, im + tprcp(i) = max(0.0,prec(i)) ! clu: rain -> tprcp + srflag(i) = 0. ! clu: default srflag as 'rain' (i.e. 0) + if (t850(i) <= 273.16) then + srflag(i) = 1. ! clu: set srflag to 'snow' (i.e. 1) + endif + enddo + endif + + return + end +! +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +! + subroutine calwxt(lm,lp1,t,q,pmid,pint, & + d608,rog,epsq,zint,iwx,twet) +! +! file: calwxt.f +! written: 11 november 1993, michael baldwin +! revisions: +! 30 sept 1994-setup new decision tree (m baldwin) +! 12 june 1998-conversion to 2-d (t black) +! 01-10-25 h chuang - modified to process hybrid model output +! 02-01-15 mike baldwin - wrf version +! +! +! routine to compute precipitation type using a decision tree +! approach that uses variables such as integrated wet bulb temp +! below freezing and lowest layer temperature +! +! see baldwin and contorno preprint from 13th weather analysis +! and forecasting conference for more details +! (or baldwin et al, 10th nwp conference preprint) +! +!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + implicit none +! +! input: +! t,q,pmid,htm,lmh,zint +! + integer,intent(in) :: lm,lp1 + real,dimension(lm),intent(in) :: t,q,pmid,twet + real,dimension(lp1),intent(in) :: zint,pint + integer,intent(out) :: iwx + real,intent(in) :: d608,rog,epsq + + +! output: +! iwx - instantaneous weather type. +! acts like a 4 bit binary +! 1111 = rain/freezing rain/ice pellets/snow +! where the one's digit is for snow +! the two's digit is for ice pellets +! the four's digit is for freezing rain +! and the eight's digit is for rain +! +! internal: +! +! real, allocatable :: twet(:) + real, parameter :: d00=0.0 + integer karr,licee + real tcold,twarm + +! subroutines called: +! wetbulb +! +! +! initialize weather type array to zero (ie, off). +! we do this since we want iwx to represent the +! instantaneous weather type on return. +! +! +! allocate local storage +! + + integer l,lice,iwrml,ifrzl + real psfck,tdchk,a,tdkl,tdpre,tlmhk,twrmk,areas8,areap4, & + surfw,surfc,dzkl,area1,pintk1,pintk2,pm150,pkl,tkl,qkl + +! allocate ( twet(lm) ) +! + iwx = 0 +! +! find coldest and warmest temps in saturated layer between +! 70 mb above ground and 500 mb +! also find highest saturated layer in that range +! +!meb + psfck = pint(lm+1) +!meb + tdchk = 2.0 + 760 tcold = t(lm) + twarm = t(lm) + licee = lm +! + do l=1,lm + qkl = q(l) + qkl = max(epsq,qkl) + tkl = t(l) + pkl = pmid(l) +! +! skip past this if the layer is not between 70 mb above ground and 500 mb +! + if (pkl < 50000.0 .or. pkl > psfck-7000.0) cycle + a = log(qkl*pkl/(6.1078*(0.378*qkl+0.622))) + tdkl = (237.3*a) / (17.269-a) + 273.15 + tdpre = tkl - tdkl + if (tdpre < tdchk .and. tkl < tcold) tcold = tkl + if (tdpre < tdchk .and. tkl > twarm) twarm = tkl + if (tdpre < tdchk .and. l < licee) licee = l + enddo +! +! if no sat layer at dew point dep=tdchk, increase tdchk +! and start again (but don't make tdchk > 6) +! + if (tcold == t(lm) .and. tdchk < 6.0) then + tdchk = tdchk + 2.0 + goto 760 + endif +! +! lowest layer t +! + karr = 0 + tlmhk = t(lm) +! +! decision tree time +! + if (tcold > 269.15) then + if (tlmhk <= 273.15) then + +! turn on the flag for freezing rain = 4 if its not on already +! izr=mod(iwx(i,j),8)/4 +! if (izr.lt.1) iwx(i,j)=iwx(i,j)+4 + + iwx = iwx + 4 + goto 850 + else +! turn on the flag for rain = 8 +! if its not on already +! irain=iwx(i,j)/8 +! if (irain.lt.1) iwx(i,j)=iwx(i,j)+8 + + iwx = iwx + 8 + goto 850 + endif + endif + karr = 1 + 850 continue +! +! compute wet bulb only at points that need it +! +! call wetbulb(lm,t,q,pmid,karr,twet) +! call wetfrzlvl(twet,zwet) +! + if (karr > 0) then + lice=licee +!meb + psfck = pint(lm+1) +!meb + tlmhk = t(lm) + twrmk = twarm +! +! twet area variables calculate only what is needed +! from ground to 150 mb above surface from ground to tcold layer +! and from ground to 1st layer where wet bulb t < 0.0 +! +! pintk1 is the pressure at the bottom of the layer +! pintk2 is the pressure at the top of the layer +! +! areap4 is the area of twet above -4 c below highest sat lyr +! + areas8 = d00 + areap4 = d00 + surfw = d00 + surfc = d00 +! + do l=lm,lice,-1 + area1 = (twet(l)-269.15) * (zint(l)-zint(l+1)) + if (twet(l) >= 269.15) areap4 = areap4 + area1 + enddo +! + if (areap4 < 3000.0) then +! turn on the flag for snow = 1 +! if its not on already +! isno=mod(iwx(i,j),2) +! if (isno.lt.1) iwx(i,j)=iwx(i,j)+1 + + iwx = iwx + 1 + return + endif +! +! areas8 is the net area of twet w.r.t. freezing in lowest 150mb +! + pintk1 = psfck + pm150 = psfck - 15000. +! + do l=lm,1,-1 + pintk2 = pint(l) + if (pintk1 >= pm150) then + dzkl = zint(l)-zint(l+1) +! sum partial layer if in 150 mb agl layer + if (pintk2 < pm150) & + dzkl = t(l)*(q(l)*d608+1.0)*rog*log(pintk1/pm150) + area1 = (twet(l)-273.15)*dzkl + areas8 = areas8 + area1 + endif + pintk1 = pintk2 + enddo +! +! surfw is the area of twet above freezing between the ground +! and the first layer above ground below freezing +! surfc is the area of twet below freezing between the ground +! and the warmest sat layer +! + ifrzl = 0 + iwrml = 0 +! + do l=lm,1,-1 + if (ifrzl == 0 .and. t(l) < 273.15) ifrzl = 1 + if (iwrml == 0 .and. t(l) >= twrmk) iwrml = 1 +! + if (iwrml == 0 .or. ifrzl == 0) then +! if(pmid(l) < 50000.)print*,'need twet above 500mb' + dzkl = zint(l)-zint(l+1) + area1 = (twet(l)-273.15)*dzkl + if(ifrzl == 0 .and. twet(l) >= 273.15) surfw = surfw + area1 + if(iwrml == 0 .and. twet(l) <= 273.15) surfc = surfc + area1 + endif + enddo + if(surfc < -3000.0 .or. (areas8 < -3000.0 .and. surfw < 50.0)) then +! turn on the flag for ice pellets = 2 if its not on already +! iip=mod(iwx(i,j),4)/2 +! if (iip.lt.1) iwx(i,j)=iwx(i,j)+2 + iwx = iwx + 2 +! + elseif(tlmhk < 273.15) then +! turn on the flag for freezing rain = 4 if its not on already +! izr=mod(iwx(k),8)/4 +! if (izr.lt.1) iwx(k)=iwx(k)+4 + iwx = iwx + 4 + else +! turn on the flag for rain = 8 if its not on already +! irain=iwx(k)/8 +! if (irain.lt.1) iwx(k)=iwx(k)+8 + iwx = iwx + 8 + endif + endif +!--------------------------------------------------------- +! deallocate (twet) + + return + end +! +! +!ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc +! +! dophase is a subroutine written and provided by jim ramer at noaa/fsl +! +! ramer, j, 1993: an empirical technique for diagnosing precipitation +! type from model output. preprints, 5th conf. on aviation +! weather systems, vienna, va, amer. meteor. soc., 227-230. +! +! code adapted for wrf post 24 august 2005 g manikin +!ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc +! + subroutine calwxt_ramer(lm,lp1,t,q,pmid,rh,td,pint,ptyp) + +! subroutine dophase(pq, ! input pressure sounding mb +! + t, ! input temperature sounding k +! + pmid, ! input pressure +! + pint, ! input interface pressure +! + q, ! input spec humidityfraction +! + lmh, ! input number of levels in sounding +! + ptyp) ! output(2) phase 2=rain, 3=frzg, 4=solid, +! 6=ip jc 9/16/99 +! use params_mod +! use ctlblk_mod +!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + implicit none +! + real,parameter :: twice=266.55,rhprcp=0.80,deltag=1.02, & + & emelt=0.045,rlim=0.04,slim=0.85 + real,parameter :: twmelt=273.15,tz=273.15,efac=1.0 ! specify in params now +! + integer*4 i, k1, lll, k2, toodry +! + real xxx ,mye, icefrac + integer, intent(in) :: lm,lp1 + real,dimension(lm), intent(in) :: t,q,pmid,rh,td + real,dimension(lp1),intent(in) :: pint + integer, intent(out) :: ptyp +! + real,dimension(lm) :: tq,pq,rhq,twq +! + integer j,l,lev,ii + real rhmax,twmax,ptop,dpdrh,twtop,rhtop,wgt1,wgt2, & + rhavg,dtavg,dpk,ptw,pbot +! real b,qtmp,rate,qc +!zhang real,external :: xmytw +! +! initialize. + icefrac = -9999. +! + + ptyp = 0 + do l = 1,lm + lev = lp1 - l +! p(l)=pmid(l) +! qc=pq0/p(l) * exp(a2*(t(l)-a3)/(t(l)-a4)) +!gsm forcing q (qtmp) to be positive to deal with negative q values +! causing problems later in this subroutine +! qtmp=max(h1m12,q(l)) +! rhqtmp(lev)=qtmp/qc + rhq(lev) = rh(l) + pq(lev) = pmid(l) * 0.01 + tq(lev) = t(l) + enddo + + +! +!cc rate restriction removed by john cortinas 3/16/99 +! +! construct wet-bulb sounding, locate generating level. + twmax = -999.0 + rhmax = 0.0 + k1 = 0 ! top of precip generating layer + k2 = 0 ! layer of maximum rh +! + if (rhq(1) < rhprcp) then + toodry = 1 + else + toodry = 0 + end if +! + pbot = pq(1) +! nq=lm + do l = 1, lm +! xxx = tdofesat(esat(tq(l))*rhq(l)) +! xxx = td(l) !hc: use td consistent with gfs ice physics + xxx = td(lp1-l) !hc: use td consistent with gfs ice physics + if (xxx < -500.) return + twq(l) = xmytw(tq(l),xxx,pq(l)) + twmax = max(twq(l),twmax) + if (pq(l) >= 400.0) then + if (rhq(l) > rhmax) then + rhmax = rhq(l) + k2 = l + end if +! + if (l /= 1) then + if (rhq(l) >= rhprcp .or. toodry == 0) then + if (toodry /= 0) then + dpdrh = log(pq(l)/pq(l-1)) / (rhq(l)-rhq(l-1)) + pbot = exp(log(pq(l))+(rhprcp-rhq(l))*dpdrh) +! + ptw = pq(l) + toodry = 0 + else if (rhq(l)>= rhprcp) then + ptw = pq(l) + else + toodry = 1 + dpdrh = log(pq(l)/pq(l-1)) / (rhq(l)-rhq(l-1)) + ptw = exp(log(pq(l))+(rhprcp-rhq(l))*dpdrh) + +!lin dpdrh = (pq(i)-pq(i-1))/(rhq(i)-rhq(i-1)) +!lin ptw = pq(i)+(rhprcp-rhq(i))*dpdrh +! + end if +! + if (pbot/ptw >= deltag) then +!lin if (pbot-ptw.lt.deltag) goto 2003 + k1 = l + ptop = ptw + end if + end if + end if + end if + enddo +! +! gross checks for liquid and solid precip which dont require generating level. +! + if (twq(1) >= 273.15+2.0) then + ptyp = 8 ! liquid + icefrac = 0.0 + return + end if +! + if (twmax <= twice) then + icefrac = 1.0 + ptyp = 1 ! solid + return + end if +! +! check to see if we had no success with locating a generating level. +! + if (k1 == 0) return +! + if (ptop == pq(k1)) then + twtop = twq(k1) + rhtop = rhq(k1) + k2 = k1 + k1 = k1 - 1 + else + k2 = k1 + k1 = k1 - 1 + wgt1 = log(ptop/pq(k2)) / log(pq(k1)/pq(k2)) + wgt2 = 1.0 - wgt1 + twtop = twq(k1) * wgt1 + twq(k2) * wgt2 + rhtop = rhq(k1) * wgt1 + rhq(k2) * wgt2 + end if +! +! calculate temp and wet-bulb ranges below precip generating level. + do l = 1, k1 + twmax = max(twq(l),twmax) + enddo +! +! gross check for solid precip, initialize ice fraction. +! if (i.eq.1.and.j.eq.1) write (*,*) 'twmax=',twmax,twice,'twtop=',twtop + + if (twtop <= twice) then + icefrac = 1.0 + if (twmax <= twmelt) then ! gross check for solid precip. + ptyp = 1 ! solid precip + return + end if + lll = 0 + else + icefrac = 0.0 + lll = 1 + end if +! +! loop downward through sounding from highest precip generating level. + 30 continue +! + if (icefrac >= 1.0) then ! starting as all ice + if (twq(k1) < twmelt) go to 40 ! cannot commence melting + if (twq(k1) == twtop) go to 40 ! both equal twmelt, nothing h + wgt1 = (twmelt-twq(k1)) / (twtop-twq(k1)) + rhavg = rhq(k1) + wgt1 * (rhtop-rhq(k1)) * 0.5 + dtavg = (twmelt-twq(k1)) * 0.5 + dpk = wgt1 * log(pq(k1)/ptop) !lin dpk=wgt1*(pq(k1)-ptop) +! mye=emelt*(1.0-(1.0-rhavg)*efac) + mye = emelt * rhavg ** efac + icefrac = icefrac + dpk * dtavg / mye + else if (icefrac <= 0.0) then ! starting as all liquid + lll = 1 +! goto 1020 + if (twq(k1) > twice) go to 40 ! cannot commence freezing + if (twq(k1) == twtop) then + wgt1 = 0.5 + else + wgt1 = (twice-twq(k1)) / (twtop-twq(k1)) + end if + rhavg = rhq(k1) + wgt1 * (rhtop-rhq(k1)) * 0.5 + dtavg = twmelt - (twq(k1)+twice) * 0.5 + dpk = wgt1 * log(pq(k1)/ptop) !lin dpk=wgt1*(pq(k1)-ptop) +! mye = emelt*(1.0-(1.0-rhavg)*efac) + mye = emelt * rhavg ** efac + icefrac = icefrac + dpk * dtavg / mye + else if ((twq(k1) <= twmelt).and.(twq(k1) < twmelt)) then ! mix + rhavg = (rhq(k1)+rhtop) * 0.5 + dtavg = twmelt - (twq(k1)+twtop) * 0.5 + dpk = log(pq(k1)/ptop) !lin dpk=pq(k1)-ptop +! mye = emelt*(1.0-(1.0-rhavg)*efac) + mye = emelt * rhavg ** efac + icefrac = icefrac + dpk * dtavg / mye + else ! mix where tw curve crosses twmelt in layer + if (twq(k1) == twtop) go to 40 ! both equal twmelt, nothing h + wgt1 = (twmelt-twq(k1)) / (twtop-twq(k1)) + wgt2 = 1.0 - wgt1 + rhavg = rhtop + wgt2 * (rhq(k1)-rhtop) * 0.5 + dtavg = (twmelt-twtop) * 0.5 + dpk = wgt2 * log(pq(k1)/ptop) !lin dpk=wgt2*(pq(k1)-ptop) +! mye = emelt*(1.0-(1.0-rhavg)*efac) + mye = emelt * rhavg ** efac + icefrac = icefrac + dpk * dtavg / mye + icefrac = min(1.0,max(icefrac,0.0)) + if (icefrac <= 0.0) then +! goto 1020 + if (twq(k1) > twice) go to 40 ! cannot commence freezin + wgt1 = (twice-twq(k1)) / (twtop-twq(k1)) + dtavg = twmelt - (twq(k1)+twice) * 0.5 + else + dtavg = (twmelt-twq(k1)) * 0.5 + end if + rhavg = rhq(k1) + wgt1 * (rhtop-rhq(k1)) * 0.5 + dpk = wgt1 * log(pq(k1)/ptop) !lin dpk=wgt1*(pq(k1)-ptop) +! mye = emelt*(1.0-(1.0-rhavg)*efac) + mye = emelt * rhavg ** efac + icefrac = icefrac + dpk * dtavg / mye + end if +! + icefrac = min(1.0,max(icefrac,0.0)) + +! if (i.eq.1.and.j.eq.1) write (*,*) 'new icefrac:', icefrac, icefrac +! +! get next level down if there is one, loop back. + 40 continue + if (k1 > 1) then + twtop = twq(k1) + ptop = pq(k1) + rhtop = rhq(k1) + k1 = k1 - 1 + go to 30 + end if +! +! determine precip type based on snow fraction and surface wet-bulb. +! + if (icefrac >= slim) then + if (lll /= 0) then + ptyp = 2 ! ice pellets jc 9/16/99 + else + ptyp = 1 ! snow + end if + else if (icefrac <= rlim) then + if (twq(1).lt.tz) then + ptyp = 4 ! freezing precip + else + ptyp = 8 ! rain + end if + else + if (twq(1) < tz) then +!gsm not sure what to do when 'mix' is predicted; in previous +!gsm versions of this code for which i had to have an answer, +!gsm i chose sleet. here, though, since we have 4 other +!gsm algorithms to provide an answer, i will not declare a +!gsm type from the ramer in this situation and allow the +!gsm other algorithms to make the call. + + ptyp = 0 ! don't know +! ptyp = 5 ! mix + else +! ptyp = 5 ! mix + ptyp = 0 ! don't know + end if + end if + + return +! + end +! +! +!-------------------------------------------------------------------------- +!zhang + real function xmytw(t,td,p) +! function xmytw(t,td,p) +! + implicit none +! + integer*4 cflag, l + real f, c0, c1, c2, k, kd, kw, ew, t, td, p, ed, fp, s, & + & de +! & de, xmytw + data f, c0, c1, c2 /0.0006355, 26.66082, 0.0091379024, 6106.3960/ +! + xmytw = (t+td) / 2 + if (td >= t) return +! + if (t < 100.0) then + k = t + 273.15 + kd = td + 273.15 + if (kd >= k) return + cflag = 1 + else + k = t + kd = td + cflag = 0 + end if +! + ed = c0 - c1 * kd - c2 / kd + if (ed < -14.0 .or. ed > 7.0) return + ed = exp(ed) + ew = c0 - c1 * k - c2 / k + if (ew < -14.0 .or. ew > 7.0) return + ew = exp(ew) + fp = p * f + s = (ew-ed) / (k-kd) + kw = (k*fp+kd*s) / (fp+s) +! + do l = 1, 5 + ew = c0 - c1 * kw - c2 / kw + if (ew < -14.0 .or. ew > 7.0) return + ew = exp(ew) + de = fp * (k-kw) + ed - ew + if (abs(de/ew) < 1e-5) exit + s = ew * (c1-c2/(kw*kw)) - fp + kw = kw - de / s + enddo +! +! print *, 'kw ', kw + if (cflag /= 0) then + xmytw = kw - 273.15 + else + xmytw = kw + end if +! + return + end +! +! +!$$$ subprogram documentation block +! +! subprogram: calwxt_bourg calculate precipitation type (bourgouin) +! prgmmr: baldwin org: np22 date: 1999-07-06 +! +! abstract: this routine computes precipitation type +! using a decision tree approach that uses the so-called +! "energy method" of bourgouin of aes (canada) 1992 +! +! program history log: +! 1999-07-06 m baldwin +! 1999-09-20 m baldwin make more consistent with bourgouin (1992) +! 2005-08-24 g manikin added to wrf post +! 2007-06-19 m iredell mersenne twister, best practices +! 2008-03-03 g manikin added checks to prevent stratospheric warming +! episodes from being seen as "warm" layers +! impacting precip type +! +! usage: call calwxt_bourg(im,jm,jsta_2l,jend_2u,jsta,jend,lm,lp1, & +! & iseed,g, & +! & t,q,pmid,pint,lmh,zint,ptype) +! input argument list: +! im integer i dimension +! jm integer j dimension +! jsta_2l integer j dimension start point (including haloes) +! jend_2u integer j dimension end point (including haloes) +! jsta integer j dimension start point (excluding haloes) +! jend integer j dimension end point (excluding haloes) +! lm integer k dimension +! lp1 integer k dimension plus 1 +! iseed integer random number seed +! g real gravity (m/s**2) +! pthresh real precipitation threshold (m) +! t real(im,jsta_2l:jend_2u,lm) mid layer temp (k) +! q real(im,jsta_2l:jend_2u,lm) specific humidity (kg/kg) +! pmid real(im,jsta_2l:jend_2u,lm) mid layer pressure (pa) +! pint real(im,jsta_2l:jend_2u,lp1) interface pressure (pa) +! lmh real(im,jsta_2l:jend_2u) max number of layers +! zint real(im,jsta_2l:jend_2u,lp1) interface height (m) +! output argument list: +! ptype real(im,jm) instantaneous weather type () +! acts like a 4 bit binary +! 1111 = rain/freezing rain/ice pellets/snow +! where the one's digit is for snow +! the two's digit is for ice pellets +! the four's digit is for freezing rain +! and the eight's digit is for rain +! in other words... +! ptype=1 snow +! ptype=2 ice pellets/mix with ice pellets +! ptype=4 freezing rain/mix with freezing rain +! ptype=8 rain +! +! modules used: +! mersenne_twister pseudo-random number generator +! +! subprograms called: +! random_number pseudo-random number generator +! +! attributes: +! language: fortran 90 +! +! remarks: vertical order of arrays must be layer 1 = top +! and layer lmh = bottom +! +!$$$ + subroutine calwxt_bourg(lm,lp1,rn,g,t,q,pmid,pint,zint,ptype) + implicit none +! +! input: + integer,intent(in) :: lm,lp1 + real,intent(in) :: g,rn(2) + real,intent(in), dimension(lm) :: t, q, pmid + real,intent(in), dimension(lp1) :: pint, zint +! +! output: + integer, intent(out) :: ptype +! + integer ifrzl,iwrml,l,lhiwrm + real pintk1,areane,tlmhk,areape,pintk2,surfw,area1,dzkl,psfck,r1,r2 +! +! initialize weather type array to zero (ie, off). +! we do this since we want ptype to represent the +! instantaneous weather type on return. +! + ptype = 0 + psfck = pint(lm+1) + +! find the depth of the warm layer based at the surface +! this will be the cut off point between computing +! the surface based warm air and the warm air aloft +! +! lowest layer t +! + tlmhk = t(lm) + iwrml = lm + 1 + if (tlmhk >= 273.15) then + do l = lm, 2, -1 + if (t(l) >= 273.15 .and. t(l-1) < 273.15 .and. & + & iwrml == lm+1) iwrml = l + end do + end if +! +! now find the highest above freezing level +! + lhiwrm = lm + 1 + do l = lm, 1, -1 +! gsm added 250 mb check to prevent stratospheric warming situations +! from counting as warm layers aloft + if (t(l) >= 273.15 .and. pmid(l) > 25000.) lhiwrm = l + end do + +! energy variables +! surfw is the positive energy between the ground +! and the first sub-freezing layer above ground +! areane is the negative energy between the ground +! and the highest layer above ground +! that is above freezing +! areape is the positive energy "aloft" +! which is the warm energy not based at the ground +! (the total warm energy = surfw + areape) +! +! pintk1 is the pressure at the bottom of the layer +! pintk2 is the pressure at the top of the layer +! dzkl is the thickness of the layer +! ifrzl is a flag that tells us if we have hit +! a below freezing layer +! + pintk1 = psfck + ifrzl = 0 + areane = 0.0 + areape = 0.0 + surfw = 0.0 + + do l = lm, 1, -1 + if (ifrzl == 0 .and. t(l) <= 273.15) ifrzl = 1 + pintk2 = pint(l) + dzkl = zint(l)-zint(l+1) + if (t(l) >= 273.15 .and. pmid(l) > 25000.) then + area1 = log(t(l)/273.15) * g * dzkl + if (l < iwrml) then + areape = areape + area1 + else + surfw = surfw + area1 + endif + elseif (l > lhiwrm) then + area1 = log(t(l)/273.15) * g * dzkl + areane = areane + abs(area1) + endif + pintk1 = pintk2 + enddo + +! +! decision tree time +! + if (areape < 2.0) then ! very little or no positive energy aloft, check for + ! positive energy just above the surface to determine rain vs. snow + if (surfw < 5.6) then ! not enough positive energy just above the surface snow = 1 + ptype = 1 + else if (surfw > 13.2) then ! enough positive energy just above the surface rain = 8 + ptype = 8 + else ! transition zone, assume equally likely rain/snow + ! picking a random number, if <=0.5 snow + r1 = rn(1) + if (r1 <= 0.5) then ! snow = 1 + ptype = 1 + else ! rain = 8 + ptype = 8 + end if + end if +! + else ! some positive energy aloft, check for enough negative energy + ! to freeze and make ice pellets to determine ip vs. zr + + if (areane > 66.0+0.66*areape) then +! enough negative area to make ip, +! now need to check if there is enough positive energy +! just above the surface to melt ip to make rain + if (surfw < 5.6) then ! not enough energy at the surface to melt ip ice pellets = 2 + ptype = 2 + elseif (surfw > 13.2) then ! enough energy at the surface to melt ip rain = 8 + ptype = 8 + else ! transition zone, assume equally likely ip/rain picking a random number, if <=0.5 ip + r1 = rn(1) + if (r1 <= 0.5) then ! ice pellets = 2 + ptype = 2 + else ! rain = 8 + ptype = 8 + end if + end if + elseif (areane < 46.0+0.66*areape) then +! not enough negative energy to refreeze, check surface temp to determine rain vs. zr + if (tlmhk < 273.15) then ! freezing rain = 4 + ptype = 4 + else ! rain = 8 + ptype = 8 + end if + else +! transition zone, assume equally likely ip/zr picking a random number, if <=0.5 ip + r1 = rn(1) + if (r1 <= 0.5) then +! still need to check positive energy just above the surface to melt ip vs. rain + if (surfw < 5.6) then ! ice pellets = 2 + ptype = 2 + else if (surfw > 13.2) then ! rain = 8 + ptype = 8 + else +! transition zone, assume equally likely ip/rain picking a random number, if <=0.5 ip + r2 = rn(2) + if (r2 <= 0.5) then ! ice pellets = 2 + ptype = 2 + else ! rain = 8 + ptype = 8 + end if + end if + else +! not enough negative energy to refreeze, check surface temp to determine rain vs. zr + if (tlmhk < 273.15) then ! freezing rain = 4 + ptype = 4 + else ! rain = 8 + ptype = 8 + end if + end if + end if + end if +! + return + end +! +! + subroutine calwxt_revised(lm,lp1,t,q,pmid,pint, & + d608,rog,epsq,zint,twet,iwx) +! +! file: calwxt.f +! written: 11 november 1993, michael baldwin +! revisions: +! 30 sept 1994-setup new decision tree (m baldwin) +! 12 june 1998-conversion to 2-d (t black) +! 01-10-25 h chuang - modified to process hybrid model output +! 02-01-15 mike baldwin - wrf version +! 05-07-07 binbin zhou - add prec for rsm +! 05-08-24 geoff manikin - modified the area requirements +! to make an alternate algorithm +! +! +! routine to compute precipitation type using a decision tree +! approach that uses variables such as integrated wet bulb temp +! below freezing and lowest layer temperature +! +! see baldwin and contorno preprint from 13th weather analysis +! and forecasting conference for more details +! (or baldwin et al, 10th nwp conference preprint) +! +! since the original version of the algorithm has a high bias +! for freezing rain and sleet, the goal is to balance that bias +! with a version more likely to predict snow +! +! use params_mod +! use ctlblk_mod +!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + implicit none +! +! list of variables needed +! parameters: +! d608,rog,h1,d00 +!hc parameter(d608=0.608,rog=287.04/9.8,h1=1.0,d00=0.0) +! +! input: +! t,q,pmid,htm,lmh,zint + + integer,intent(in) :: lm,lp1 + real,dimension(lm),intent(in) :: t,q,pmid,twet + real,dimension(lp1),intent(in) :: pint,zint + real,intent(in) :: d608,rog,epsq +! output: +! iwx - instantaneous weather type. +! acts like a 4 bit binary +! 1111 = rain/freezing rain/ice pellets/snow +! where the one's digit is for snow +! the two's digit is for ice pellets +! the four's digit is for freezing rain +! and the eight's digit is for rain + integer, intent(out) :: iwx +! internal: +! + real, parameter :: d00=0.0 + integer karr,licee + real tcold,twarm +! + integer l,lmhk,lice,iwrml,ifrzl + real psfck,tdchk,a,tdkl,tdpre,tlmhk,twrmk,areas8,areap4,area1, & + surfw,surfc,dzkl,pintk1,pintk2,pm150,qkl,tkl,pkl,area0,areap0 + +! subroutines called: +! wetbulb +! +! +! initialize weather type array to zero (ie, off). +! we do this since we want iwx to represent the +! instantaneous weather type on return. +! +! +! allocate local storage +! +! + iwx = 0 + lmhk=lm +! +! find coldest and warmest temps in saturated layer between +! 70 mb above ground and 500 mb +! also find highest saturated layer in that range +! +!meb + psfck = pint(lp1) +!meb + tdchk = 2.0 + 760 tcold = t(lmhk) + twarm = t(lmhk) + licee = lmhk +! + do l=1,lmhk + qkl = q(l) + qkl = max(epsq,qkl) + tkl = t(l) + pkl = pmid(l) +! +! skip past this if the layer is not between 70 mb above ground +! and 500 mb +! + if (pkl < 50000.0 .or. pkl > psfck-7000.0) cycle + a = log(qkl*pkl/(6.1078*(0.378*qkl+0.622))) + tdkl = (237.3*a)/(17.269-a)+273.15 + tdpre = tkl-tdkl + if (tdpre < tdchk .and. tkl < tcold) tcold = tkl + if (tdpre < tdchk .and. tkl > twarm) twarm = tkl + if (tdpre < tdchk .and. l < licee) licee = l + enddo +! +! if no sat layer at dew point dep=tdchk, increase tdchk +! and start again (but don't make tdchk > 6) +! + if (tcold == t(lmhk) .and. tdchk < 6.0) then + tdchk = tdchk + 2.0 + goto 760 + endif +! +! lowest layer t +! + karr = 0 + lmhk = lm + tlmhk = t(lmhk) +! +! decision tree time +! + if (tcold > 269.15) then + if (tlmhk <= 273.15) then +! turn on the flag for freezing rain = 4 if its not on already +! izr=mod(iwx,8)/4 +! if (izr.lt.1) iwx=iwx+4 + iwx = iwx + 4 + goto 850 + else +! turn on the flag for rain = 8 if its not on already +! irain=iwx/8 +! if (irain.lt.1) iwx=iwx+8 + iwx = iwx + 8 + goto 850 + endif + endif + karr = 1 + 850 continue +! + if (karr > 0)then + lmhk = lm + lice = licee +!meb + psfck = pint(lp1) +!meb + tlmhk = t(lmhk) + twrmk = twarm +! +! twet area variables +! calculate only what is needed +! from ground to 150 mb above surface +! from ground to tcold layer +! and from ground to 1st layer where wet bulb t < 0.0 +! +! pintk1 is the pressure at the bottom of the layer +! pintk2 is the pressure at the top of the layer +! +! areap4 is the area of twet above -4 c below highest sat lyr +! areap0 is the area of twet above 0 c below highest sat lyr +! + areas8 = d00 + areap4 = d00 + areap0 = d00 + surfw = d00 + surfc = d00 + +! + do l=lmhk,lice,-1 + dzkl = zint(l)-zint(l+1) + area1 = (twet(l)-269.15)*dzkl + area0 = (twet(l)-273.15)*dzkl + if (twet(l) >= 269.15) areap4 = areap4 + area1 + if (twet(l) >= 273.15) areap0 = areap0 + area0 + enddo +! +! if (areap4.lt.3000.0) then turn on the flag for snow = 1 if its not on already +! isno=mod(iwx,2) +! if (isno.lt.1) iwx=iwx+1 +! iwx=iwx+1 +! go to 1900 +! endif + if (areap0 < 350.0) then ! turn on the flag for snow = 1 + iwx = iwx + 1 + return + endif +! +! areas8 is the net area of twet w.r.t. freezing in lowest 150mb +! + pintk1 = psfck + pm150 = psfck - 15000. +! + do l=lmhk,1,-1 + pintk2 = pint(l) + if(pintk1 >= pm150) then + dzkl = zint(l)-zint(l+1) +! +! sum partial layer if in 150 mb agl layer +! + if(pintk2 < pm150) dzkl = t(l)*(q(l)*d608+1.0)*rog* & + log(pintk1/pm150) + area1 = (twet(l)-273.15)*dzkl + areas8 = areas8 + area1 + endif + pintk1=pintk2 + enddo +! +! surfw is the area of twet above freezing between the ground +! and the first layer above ground below freezing +! surfc is the area of twet below freezing between the ground +! and the warmest sat layer +! + ifrzl = 0 + iwrml = 0 +! + do l=lmhk,1,-1 + if (ifrzl == 0 .and. t(l) < 273.15) ifrzl = 1 + if (iwrml == 0 .and. t(l) >= twrmk) iwrml = 1 +! + if (iwrml == 0 .or. ifrzl == 0) then +! if(pmid(l) .lt. 50000.)print*,'twet needed above 500mb' + dzkl = zint(l)-zint(l+1) + area1 = (twet(l)-273.15)*dzkl + if(ifrzl == 0 .and. twet(l) >= 273.15) surfw = surfw + area1 + if(iwrml == 0 .and. twet(l) <= 273.15) surfc = surfc + area1 + endif + enddo + if (surfc < -3000.0 .or. & + & (areas8 < -3000.0 .and. surfw < 50.0)) then +! turn on the flag for ice pellets = 2 if its not on already +! iip=mod(iwx,4)/2 +! if (iip.lt.1) iwx=iwx+2 + iwx = iwx + 2 + return + endif +! + if (tlmhk < 273.15) then +! turn on the flag for freezing rain = 4 if its not on already +! izr=mod(iwx(k),8)/4 +! if (izr.lt.1) iwx(k)=iwx(k)+4 + iwx = iwx + 4 + else +! turn on the flag for rain = 8 if its not on already +! irain=iwx(k)/8 +! if (irain.lt.1) iwx(k)=iwx(k)+8 + iwx = iwx + 8 + endif +! print *, 'revised check ', iwx(500,800) + endif + + return + end +! +! + subroutine calwxt_explicit(lm,tskin,sr,f_rimef,iwx) +! +! file: calwxt.f +! written: 24 august 2005, g manikin and b ferrier +! +! routine to compute precipitation type using explicit fields +! from the model microphysics + +!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + implicit none +! +! list of variables needed +! parameters: +! +! input: + integer, intent(in) :: lm + real,intent(in) :: tskin, sr + real,intent(in) :: f_rimef(lm) + integer,intent(out) :: iwx + real snow +! real psfc +! +! allocate local storage +! + iwx = 0 + +!gsm the rsm is currently incompatible with this routine +!gsm according to b ferrier, there may be a way to write +!gsm a version of this algorithm to work with the rsm +!gsm microphysics, but it doesn't exist at this time + +! a snow ratio less than 0.5 eliminates snow and sleet +! use the skin temperature to distinguish rain from freezing rain +! note that 2-m temperature may be a better choice if the model +! has a cold bias for skin temperature +! + if (sr < 0.5) then +! surface (skin) potential temperature and temperature. +! psfc=pmid(lm) +! tskin=ths*(psfc/p1000)**capa + + if (tskin < 273.15) then ! freezing rain = 4 + iwx = iwx + 4 + else ! rain = 8 + iwx = iwx + 8 + endif + else +! +! distinguish snow from sleet with the rime factor +! + if(f_rimef(lm) >= 10) then ! sleet = 2 + iwx = iwx + 2 + else + snow = 1 + iwx = iwx + 1 + endif + endif + end +! +! + subroutine calwxt_dominant(nalg,rain,freezr,sleet,snow, & + & domr,domzr,domip,doms) +! +! written: 24 august 2005, g manikin +! +! this routine takes the precip type solutions from different +! algorithms and sums them up to give a dominant type +! +!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + implicit none +! +! input: + integer,intent(in) :: nalg + real,intent(out) :: doms,domr,domzr,domip + integer,dimension(nalg),intent(in) :: rain,snow,sleet,freezr + integer l + real totsn,totip,totr,totzr +!-------------------------------------------------------------------------- +! print* , 'into dominant' + domr = 0. + doms = 0. + domzr = 0. + domip = 0. +! + totsn = 0 + totip = 0 + totr = 0 + totzr = 0 +! loop over the number of different algorithms that are used + do l = 1, nalg + if (rain(l) > 0) then + totr = totr + 1 + elseif (snow(l) > 0) then + totsn = totsn + 1 + elseif (sleet(l) > 0) then + totip = totip + 1 + elseif (freezr(l) > 0) then + totzr = totzr + 1 + endif + enddo + +! ties are broken to favor the most dangerous form of precip +! freezing rain > snow > sleet > rain + if (totsn > totip) then + if (totsn > totzr) then + if (totsn >= totr) then + doms = 1 + else + domr = 1 + endif + elseif (totzr >= totr) then + domzr = 1 + else + domr = 1 + endif + else if (totip > totzr) then + if (totip >= totr) then + domip = 1 + else + domr = 1 + endif + else if (totzr >= totr) then + domzr = 1 + else + domr = 1 + endif +! + return + end + +!> \section arg_table_calpreciptype_finalize Argument table +!! + subroutine GFS_calpreciptype_finalize + end subroutine GFS_calpreciptype_finalize + + end module GFS_calpreciptype diff --git a/physics/gscond.f b/physics/gscond.f index c9c8b0a39..a97db7732 100644 --- a/physics/gscond.f +++ b/physics/gscond.f @@ -3,7 +3,7 @@ !! condensation and evaporation for use in the Zhao and Carr (1997) !! \cite zhao_and_carr_1997 scheme. - module zhaocarr_gscond + module GFS_zhaocarr_gscond contains !> \defgroup Zhao-Carr Zhao-Carr Microphysics @@ -542,4 +542,4 @@ end subroutine gscond_finalize !> @} !! @} - end module zhaocarr_gscond + end module GFS_zhaocarr_gscond diff --git a/physics/precpd.f b/physics/precpd.f index 6fa1b2a7a..a8e92af57 100644 --- a/physics/precpd.f +++ b/physics/precpd.f @@ -2,7 +2,7 @@ !! This file contains the subroutine that calculates precipitation !! processes from suspended cloud water/ice - module zhaocarr_precpd + module GFS_zhaocarr_precpd contains !> \ingroup Zhao-Carr @@ -749,4 +749,4 @@ end subroutine precpd_finalize !> @} - end module zhaocarr_precpd + end module GFS_zhaocarr_precpd From fe43cc782bd07125d739509797bf351a1c20d64c Mon Sep 17 00:00:00 2001 From: "Man.Zhang" Date: Mon, 30 Oct 2017 17:10:52 +0000 Subject: [PATCH 12/25] add Z-C interstitial on L2275 --- GFS_layer/GFS_physics_driver.F90 | 5 +++-- physics/gscond.f | 30 ++++++++++++++++++++---------- physics/precpd.f | 2 +- 3 files changed, 24 insertions(+), 13 deletions(-) diff --git a/GFS_layer/GFS_physics_driver.F90 b/GFS_layer/GFS_physics_driver.F90 index b0f7eb8ca..6e45f6af1 100644 --- a/GFS_layer/GFS_physics_driver.F90 +++ b/GFS_layer/GFS_physics_driver.F90 @@ -2278,7 +2278,7 @@ subroutine GFS_physics_driver & Stateout%gq0(:,:,Model%ntiw) = clw(:,:,1) ! ice Stateout%gq0(:,:,Model%ntcw) = clw(:,:,2) ! water elseif (Model%num_p3d == 4) then ! if_num_p3d - Stateout%gq0(:,:,Model%ntcw) = clw(:,:,1) + clw(:,:,2) +!zhao-carr interstitial Stateout%gq0(:,:,Model%ntcw) = clw(:,:,1) + clw(:,:,2) endif ! end if_num_p3d else ! if_ntcw @@ -2379,7 +2379,8 @@ subroutine GFS_physics_driver & Tbd%phy_f3d(1,1,Model%ntot3d-2), lprnt, ipr) else call gscond_run (im, ix, levs, dtp, dtf, Statein%prsl, Statein%pgr,& - Stateout%gq0(:,:,1), Stateout%gq0(:,:,Model%ntcw), & + Stateout%gq0(:,:,1), clw(:,:,1), clw(:,:,2), & + Stateout%gq0(:,:,Model%ntcw), & Stateout%gt0, Tbd%phy_f3d(:,:,1), Tbd%phy_f3d(:,:,2), & Tbd%phy_f2d(:,1), Tbd%phy_f3d(:,:,3), & Tbd%phy_f3d(:,:,4), Tbd%phy_f2d(:,2), rhc,lprnt, ipr) diff --git a/physics/gscond.f b/physics/gscond.f index a97db7732..29d6fcf11 100644 --- a/physics/gscond.f +++ b/physics/gscond.f @@ -66,15 +66,17 @@ end subroutine gscond_init !!\section arg_table_gscond_run Argument Table !!| local var name | longname |description | units | rank | type | kind | intent | optional | !!|----------------|----------------------------------------------------------|----------------------------------------------------------|---------|------|---------|-----------|--------|----------| -!!| im | horizontal_loop_extent | horizontal loop extent, start at 1 | index | 0 | integer | | in | F | -!!| ix | horizontal_dimension | horizontal dimension | index | 0 | integer | | in | F | -!!| km | vertical_dimension | vertical layer dimension | index | 0 | integer | | in | F | -!!| dt | time_step_for_physics | physics time step | s | 0 | real | kind_phys | in | F | -!!| dtf | time_step_for_dynamics | dynamics time step | s | 0 | real | kind_phys | in | F | -!!| prsl | air_pressure | layer mean air pressure | Pa | 2 | real | kind_phys | in | F | -!!| ps | surface_air_pressure | surface pressure | Pa | 1 | real | kind_phys | in | F | +!!| im | horizontal_loop_extent | horizontal loop extent, start at 1 | index | 0 | integer | | in | F | +!!| ix | horizontal_dimension | horizontal dimension | index | 0 | integer | | in | F | +!!| km | vertical_dimension | vertical layer dimension | index | 0 | integer | | in | F | +!!| dt | time_step_for_physics | physics time step | s | 0 | real | kind_phys | in | F | +!!| dtf | time_step_for_dynamics | dynamics time step | s | 0 | real | kind_phys | in | F | +!!| prsl | air_pressure | layer mean air pressure | Pa | 2 | real | kind_phys | in | F | +!!| ps | surface_air_pressure | surface pressure | Pa | 1 | real | kind_phys | in | F | !!| q | water_vapor_specific_humidity | water vapor specific humidity | kg kg-1 | 2 | real | kind_phys | inout | F | -!!| cwm | cloud_condensed_water_specific_humidity | cloud condensed water specific humidity | kg kg-1 | 2 | real | kind_phys | inout | F | +!!| clw1 | cloud_ice_specific_humidity | cloud ice specific humidity | kg kg-1 | 2 | real | kind_phys | in | F | +!!| clw2 | cloud_liquid_water_specific_humidity | cloud water specific humidity | kg kg-1 | 2 | real | kind_phys | in | F | +!!| cwm | cloud_condensed_water_specific_humidity | cloud condensed water specific humidity | kg kg-1 | 2 | real | kind_phys | out | F | !!| t | air_temperature | layer mean air temperature | K | 2 | real | kind_phys | inout | F | !!| tp | air_temperature_at_two_time_step_back | air temperature at two time step back | K | 2 | real | kind_phys | inout | F | !!| qp | water_vapor_specific_humidity_at_two_time_step_back | water vapor specific humidity at two time step back | kg kg-1 | 2 | real | kind_phys | inout | F | @@ -91,7 +93,8 @@ end subroutine gscond_init !! - \f$E_{c}\f$: evaporation rate of cloud (\f$s^{-1}\f$) !> \section Zhao-Carr_cond_detailed Detailed Algorithm !> @{ - subroutine gscond_run (im,ix,km,dt,dtf,prsl,ps,q,cwm,t & + subroutine gscond_run (im,ix,km,dt,dtf,prsl,ps,q,clw1,clw2 & + &, cwm, t & &, tp, qp, psp, tp1, qp1, psp1, u, lprnt, ipr) @@ -132,7 +135,8 @@ subroutine gscond_run (im,ix,km,dt,dtf,prsl,ps,q,cwm,t & real(kind=kind_phys), parameter :: cons_0=0.0, cons_m15=-15.0 ! integer im, ix, km, ipr - real (kind=kind_phys) q(ix,km), t(ix,km), cwm(ix,km) & + real (kind=kind_phys) q(ix,km), t(ix,km), cwm(ix,km) & + &, clw1(ix,km), clw2(ix,km) & &, prsl(ix,km), ps(im), dt, dtf & &, tp(ix,km), qp(ix,km), psp(im) & &, tp1(ix,km), qp1(ix,km), psp1(im) @@ -150,6 +154,12 @@ subroutine gscond_run (im,ix,km,dt,dtf,prsl,ps,q,cwm,t & integer iw(im,km), i, k, iwik logical lprnt ! +!-----------------GFS interstitial in driver ---------------------------- + do i = 1,im + do k= 1,km + cwm(i,k) = clw1(i,k)+clw2(i,k) + enddo + enddo !-----------------prepare constants for later uses----------------- ! el2orc = hvap*hvap / (rv*cp) diff --git a/physics/precpd.f b/physics/precpd.f index a8e92af57..057fa4706 100644 --- a/physics/precpd.f +++ b/physics/precpd.f @@ -90,7 +90,6 @@ end subroutine precpd_init subroutine precpd_run (im,ix,km,dt,del,prsl,q,cwm,t,rn,sr & &, rainp,u00k,psautco,prautco,evpco,wminco & &, wk1,lprnt,jpr) -!zhang &, lprnt,jpr) ! ! ****************************************************************** @@ -197,6 +196,7 @@ subroutine precpd_run (im,ix,km,dt,del,prsl,q,cwm,t,rn,sr & &, praut, fi, qc, amaxrq, rqkll integer i, k, ihpr, n ! + !-------------- GFS psautco/prautco interstitial ---------------- do i=1, im wk2(i) = 1.0-wk1(i) From efc25d5f2a0a3fd5fa8c34274e4be94567140d6d Mon Sep 17 00:00:00 2001 From: "Man.Zhang" Date: Thu, 2 Nov 2017 16:54:54 +0000 Subject: [PATCH 13/25] minor fixes in tables of z-c and calpreciptype folling Grant's suggestion --- physics/GFS_calpreciptype.f90 | 2 +- physics/gscond.f | 2 +- physics/precpd.f | 4 ++-- 3 files changed, 4 insertions(+), 4 deletions(-) diff --git a/physics/GFS_calpreciptype.f90 b/physics/GFS_calpreciptype.f90 index 25b4de424..cf80a73e9 100644 --- a/physics/GFS_calpreciptype.f90 +++ b/physics/GFS_calpreciptype.f90 @@ -20,7 +20,7 @@ end subroutine GFS_calpreciptype_init !!| lp1 | vertical_interface_dimension | vertical interface dimension | index | 0 | integer | | in | F | !!| randomno | random_number_array | random number array | none | 2 | real | | in | F | !!| cal_pre | flag_for_precipitation_type_algorithm | flag controls precip type algorithm | flag | 0 | logical | | in | F | -!!| gt0 | air_temperature | layer mean air temperature | K | 2 | real | kind_phys | in | F | +!!| gt0 | air_temperature_updated_by_physics | layer mean air temperature | K | 2 | real | kind_phys | in | F | !!| gq0 | water_vapor_specific_humidity | water vapor specific humidity | kg kg-1 | 2 | real | kind_phys | in | F | !!| prsl | air_pressure | layer mean pressure | Pa | 2 | real | kind_phys | in | F | !!| prsi | air_pressure_at_interface | pressure at layer interface | Pa | 2 | real | kind_phys | in | F | diff --git a/physics/gscond.f b/physics/gscond.f index 29d6fcf11..2750659ac 100644 --- a/physics/gscond.f +++ b/physics/gscond.f @@ -77,7 +77,7 @@ end subroutine gscond_init !!| clw1 | cloud_ice_specific_humidity | cloud ice specific humidity | kg kg-1 | 2 | real | kind_phys | in | F | !!| clw2 | cloud_liquid_water_specific_humidity | cloud water specific humidity | kg kg-1 | 2 | real | kind_phys | in | F | !!| cwm | cloud_condensed_water_specific_humidity | cloud condensed water specific humidity | kg kg-1 | 2 | real | kind_phys | out | F | -!!| t | air_temperature | layer mean air temperature | K | 2 | real | kind_phys | inout | F | +!!| t | air_temperature_updated_by_physics | layer mean air temperature | K | 2 | real | kind_phys | inout | F | !!| tp | air_temperature_at_two_time_step_back | air temperature at two time step back | K | 2 | real | kind_phys | inout | F | !!| qp | water_vapor_specific_humidity_at_two_time_step_back | water vapor specific humidity at two time step back | kg kg-1 | 2 | real | kind_phys | inout | F | !!| psp | surface_air_pressure_at_two_time_step_back | surface air pressure at two time step back | Pa | 1 | real | kind_phys | inout | F | diff --git a/physics/precpd.f b/physics/precpd.f index 057fa4706..1221918ed 100644 --- a/physics/precpd.f +++ b/physics/precpd.f @@ -33,8 +33,8 @@ end subroutine precpd_init !!| prsl | air_pressure | layer mean pressure | Pa | 2 | real | kind_phys| in | F | !!| q | water_vapor_specific_humidity | water vapor specific humidity | kg kg-1 | 2 | real | kind_phys| inout | F | !!| cwm | cloud_condensed_water_specific_humidity | cloud condensed water specific humidity | kg kg-1 | 2 | real | kind_phys| inout | F | -!!| t | air_temperature | layer mean air temperature | K | 2 | real | kind_phys| inout | F | -!!| rn | rainfall_amount | large scale rainfall amount | m | 1 | real | kind_phys| out | F | +!!| t | air_temperature_updated_by_physics | layer mean air temperature | K | 2 | real | kind_phys| inout | F | +!!| rn | instantaneous_rainfall_amount | large scale rainfall amount | m | 1 | real | kind_phys| out | F | !!| sr | ratio_of_snowfall_to_rainfall | ratio of snowfall to large-scale rainfall | frac | 1 | real | kind_phys| out | F | !!| rainp | rain_water_path | rainwater path | kg m-3 | 2 | real | kind_phys| out | F | !!| u00k | critical_relative_humidity | critical relative humidity | 1 | 2 | real | kind_phys| in | F | From e4b6ed24156de420807168eb1960b4cf965b332c Mon Sep 17 00:00:00 2001 From: "Man.Zhang" Date: Thu, 2 Nov 2017 19:40:19 +0000 Subject: [PATCH 14/25] to change srflag longname --- physics/GFS_calpreciptype.f90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/physics/GFS_calpreciptype.f90 b/physics/GFS_calpreciptype.f90 index cf80a73e9..417d4de8f 100644 --- a/physics/GFS_calpreciptype.f90 +++ b/physics/GFS_calpreciptype.f90 @@ -34,7 +34,7 @@ end subroutine GFS_calpreciptype_init !!| domzr | dominant_freezing_rain_type | dominant freezing rain type | none | 1 | real | kind_phys | out | F | !!| domip | dominant_sleet_type | dominant sleet type | none | 1 | real | kind_phys | out | F | !!| doms | dominant_snow_type | dominant snow type | none | 1 | real | kind_phys | out | F | -!!| srflag | preciptation_type_flag | snow(1)/rain(0) flag for precipitation | 1 | 1 | real | kind_phys | out | F | +!!| srflag | flag_for_preciptation_type | snow(1)/rain(0) flag for precipitation | 1 | 1 | real | kind_phys | out | F | !!| tprcp | precipitation_amount_in_one_dynamics_time_step | precipitation amount in one dynamics time step | m | 1 | real | kind_phys | out | F | subroutine GFS_calpreciptype_run(kdt,nrcm,im,ix,lm,lp1,randomno, & cal_pre, & From b94e3f16897dfcf557210e190de119c001a55c81 Mon Sep 17 00:00:00 2001 From: "Grant.Firl" Date: Mon, 6 Nov 2017 21:19:53 -0700 Subject: [PATCH 15/25] fixed a couple of typos --- physics/GFS_calpreciptype.f90 | 144 +++++++++++++++++----------------- 1 file changed, 73 insertions(+), 71 deletions(-) diff --git a/physics/GFS_calpreciptype.f90 b/physics/GFS_calpreciptype.f90 index 417d4de8f..860090dfd 100644 --- a/physics/GFS_calpreciptype.f90 +++ b/physics/GFS_calpreciptype.f90 @@ -5,11 +5,12 @@ module GFS_calpreciptype contains -!>\section arg_table_calpreciptype_init Argument Table +!>\section arg_table_GFS_calpreciptype_init Argument Table +!! subroutine GFS_calpreciptype_init end subroutine GFS_calpreciptype_init -!!\section arg_table_calpreciptype_run Argument Table +!!\section arg_table_GFS_calpreciptype_run Argument Table !!| local var name | longname |description | units | rank | type | kind | intent | optional | !!|----------------|------------------------------------------------|----------------------------------------------------------|---------|------|---------|-----------|--------|----------| !!| kdt | index_of_time_step | current time step index | index | 0 | integer | | in | F | @@ -22,7 +23,7 @@ end subroutine GFS_calpreciptype_init !!| cal_pre | flag_for_precipitation_type_algorithm | flag controls precip type algorithm | flag | 0 | logical | | in | F | !!| gt0 | air_temperature_updated_by_physics | layer mean air temperature | K | 2 | real | kind_phys | in | F | !!| gq0 | water_vapor_specific_humidity | water vapor specific humidity | kg kg-1 | 2 | real | kind_phys | in | F | -!!| prsl | air_pressure | layer mean pressure | Pa | 2 | real | kind_phys | in | F | +!!| prsl | air_pressure | layer mean pressure | Pa | 2 | real | kind_phys | in | F | !!| prsi | air_pressure_at_interface | pressure at layer interface | Pa | 2 | real | kind_phys | in | F | !!| prec | total_rainfall_amount | instantaneous total precipitation at surface | m | 1 | real | kind_phys | in | F | !!| phii | geopotential_at_interface | geopotential at model layer interfaces | m2 s-2 | 2 | real | kind_phys | in | F | @@ -34,8 +35,9 @@ end subroutine GFS_calpreciptype_init !!| domzr | dominant_freezing_rain_type | dominant freezing rain type | none | 1 | real | kind_phys | out | F | !!| domip | dominant_sleet_type | dominant sleet type | none | 1 | real | kind_phys | out | F | !!| doms | dominant_snow_type | dominant snow type | none | 1 | real | kind_phys | out | F | -!!| srflag | flag_for_preciptation_type | snow(1)/rain(0) flag for precipitation | 1 | 1 | real | kind_phys | out | F | +!!| srflag | flag_for_precipitation_type | snow(1)/rain(0) flag for precipitation | 1 | 1 | real | kind_phys | out | F | !!| tprcp | precipitation_amount_in_one_dynamics_time_step | precipitation amount in one dynamics time step | m | 1 | real | kind_phys | out | F | +!! subroutine GFS_calpreciptype_run(kdt,nrcm,im,ix,lm,lp1,randomno, & cal_pre, & gt0,gq0,prsl,prsi,prec, & !input @@ -43,15 +45,15 @@ subroutine GFS_calpreciptype_run(kdt,nrcm,im,ix,lm,lp1,randomno, & domr,domzr,domip,doms,srflag,tprcp) !output !$$$ subprogram documentation block -! . . . +! . . . ! subprogram: calpreciptype compute dominant precip type ! prgrmmr: chuang org: w/np2 date: 2008-05-28 -! -! +! +! ! abstract: ! this routine computes precipitation type. -! . it is adopted from post but was made into a column to used by gfs model -! +! . it is adopted from post but was made into a column to used by gfs model +! ! -------------------------------------------------------------------- use funcphys, only : fpvs,ftdp,fpkap,ftlcl,stma,fthe use physcons @@ -60,9 +62,9 @@ subroutine GFS_calpreciptype_run(kdt,nrcm,im,ix,lm,lp1,randomno, & ! real, parameter :: pthresh = 0.0, oneog = 1.0/con_g integer,parameter :: nalg = 5 -! +! ! declare variables. -! +! integer,intent(in) :: kdt,nrcm,im,ix,lm,lp1,n3dfercld logical :: cal_pre real,intent(in) :: randomno(ix,nrcm) @@ -73,7 +75,7 @@ subroutine GFS_calpreciptype_run(kdt,nrcm,im,ix,lm,lp1,randomno, & real(kind=kind_phys),dimension(im), intent(out) :: srflag,tprcp real(kind=kind_phys),dimension(im) :: t850 real(kind=kind_phys), parameter :: p850 = 85000.0 - + integer, dimension(nalg) :: sleet,rain,freezr,snow real(kind=kind_phys),dimension(lm) :: t,q,pmid,f_rimef real(kind=kind_phys),dimension(lp1) :: pint,zint @@ -84,14 +86,14 @@ subroutine GFS_calpreciptype_run(kdt,nrcm,im,ix,lm,lp1,randomno, & time_vert,time_ncep,time_ramer,time_bourg,time_revised,& time_dominant,btim,timef,ranl(2) -! +! ! computes wet bulb here since two algorithms use it ! lp1=lm+1 ! convert geopotential to height ! do l=1,lp1 ! zint(l)=zint(l)/con_g ! end do -! don't forget to flip 3d arrays around because gfs counts from bottom up +! don't forget to flip 3d arrays around because gfs counts from bottom up !--- original GFS calpreciptype_pre interstitial------------------- if (cal_pre) then !hchuang: add dominant precipitation type algorithm @@ -115,7 +117,7 @@ subroutine GFS_calpreciptype_run(kdt,nrcm,im,ix,lm,lp1,randomno, & t(k1) = gt0(i,k) q(k1) = gq0(i,k) pmid(k1) = prsl(i,k) ! pressure in pascals - f_rimef(k1) = phy_f3d(i,k) + f_rimef(k1) = phy_f3d(i,k) ! ! compute wet bulb temperature ! @@ -133,11 +135,11 @@ subroutine GFS_calpreciptype_run(kdt,nrcm,im,ix,lm,lp1,randomno, & else twet(k1) = t(k1) endif -! endif +! endif es = min(fpvs(t(k1)), pmid(k1)) qc = con_eps*es / (pmid(k1)+con_epsm1*es) rh(k1) = max(con_epsq,q(k1)) / qc - + k1 = lp1-k+1 pint(k1) = prsi(i,k) zint(k1) = phii(i,k) * oneog @@ -145,7 +147,7 @@ subroutine GFS_calpreciptype_run(kdt,nrcm,im,ix,lm,lp1,randomno, & enddo pint(1) = prsi(i,lp1) zint(1) = phii(i,lp1) * oneog - + !------------------------------------------------------------------------------- ! if(kdt>15.and.kdt<20) time_vert = time_vert + (timef() - btim) ! debug print statement @@ -160,10 +162,10 @@ subroutine GFS_calpreciptype_run(kdt,nrcm,im,ix,lm,lp1,randomno, & ! pmid(l),pint(l),zint(l),twet(l) ! end do ! print*,'debug in calpreciptype: lp1,pint,z ', lp1,pint(lp1),zint(lp1) -! end if -! end debug print statement -! call wetbulb(lm,con_rocp,con_epsq,t,q,pmid,twet) -! if(kdt>10.and.kdt<20)btim = timef() +! end if +! end debug print statement +! call wetbulb(lm,con_rocp,con_epsq,t,q,pmid,twet) +! if(kdt>10.and.kdt<20)btim = timef() !------------------------------------------------------------------------------- ! ! instantaneous precipitation type. @@ -189,7 +191,7 @@ subroutine GFS_calpreciptype_run(kdt,nrcm,im,ix,lm,lp1,randomno, & ! rh(l)=max(con_epsq,q(l))/qc ! pv = pmid(l)*q(l)/(con_eps-con_epsm1*q(l)) ! td(l)=ftdp(pv) -! end do +! end do ! if(kdt>10.and.kdt<20)btim = timef() ! write(0,*)' i=',i,' lm=',lm,' lp1=',lp1,' t=',t(1),q(1),pmid(1) & @@ -227,7 +229,7 @@ subroutine GFS_calpreciptype_run(kdt,nrcm,im,ix,lm,lp1,randomno, & rain(4) = iwx/8 ! ! explicit algorithm (under 18 not admitted without parent or guardian) - + if(n3dfercld == 3) then ! ferrier's scheme call calwxt_explicit(lm,tskin(i),sr(i),f_rimef,iwx) snow(5) = mod(iwx,2) @@ -240,7 +242,7 @@ subroutine GFS_calpreciptype_run(kdt,nrcm,im,ix,lm,lp1,randomno, & freezr(5) = 0 rain(5) = 0 endif -! +! call calwxt_dominant(nalg,rain(1),freezr(1),sleet(1), & snow(1),domr(i),domzr(i),domip(i),doms(i)) @@ -252,7 +254,7 @@ subroutine GFS_calpreciptype_run(kdt,nrcm,im,ix,lm,lp1,randomno, & end if enddo ! end loop for i - deallocate (twet,rh,td) + deallocate (twet,rh,td) !!--- below is the original calpreciptype_post do i=1,im @@ -288,7 +290,7 @@ subroutine GFS_calpreciptype_run(kdt,nrcm,im,ix,lm,lp1,randomno, & else do i = 1, im tprcp(i) = max(0.0,prec(i)) ! clu: rain -> tprcp - srflag(i) = 0. ! clu: default srflag as 'rain' (i.e. 0) + srflag(i) = 0. ! clu: default srflag as 'rain' (i.e. 0) if (t850(i) <= 273.16) then srflag(i) = 1. ! clu: set srflag to 'snow' (i.e. 1) endif @@ -302,7 +304,7 @@ subroutine GFS_calpreciptype_run(kdt,nrcm,im,ix,lm,lp1,randomno, & ! subroutine calwxt(lm,lp1,t,q,pmid,pint, & d608,rog,epsq,zint,iwx,twet) -! +! ! file: calwxt.f ! written: 11 november 1993, michael baldwin ! revisions: @@ -310,7 +312,7 @@ subroutine calwxt(lm,lp1,t,q,pmid,pint, & ! 12 june 1998-conversion to 2-d (t black) ! 01-10-25 h chuang - modified to process hybrid model output ! 02-01-15 mike baldwin - wrf version -! +! ! ! routine to compute precipitation type using a decision tree ! approach that uses variables such as integrated wet bulb temp @@ -319,7 +321,7 @@ subroutine calwxt(lm,lp1,t,q,pmid,pint, & ! see baldwin and contorno preprint from 13th weather analysis ! and forecasting conference for more details ! (or baldwin et al, 10th nwp conference preprint) -! +! !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - implicit none ! @@ -345,18 +347,18 @@ subroutine calwxt(lm,lp1,t,q,pmid,pint, & ! internal: ! ! real, allocatable :: twet(:) - real, parameter :: d00=0.0 + real, parameter :: d00=0.0 integer karr,licee real tcold,twarm ! subroutines called: ! wetbulb -! +! ! ! initialize weather type array to zero (ie, off). ! we do this since we want iwx to represent the ! instantaneous weather type on return. -! +! ! ! allocate local storage ! @@ -455,7 +457,7 @@ subroutine calwxt(lm,lp1,t,q,pmid,pint, & ! pintk1 is the pressure at the bottom of the layer ! pintk2 is the pressure at the top of the layer ! -! areap4 is the area of twet above -4 c below highest sat lyr +! areap4 is the area of twet above -4 c below highest sat lyr ! areas8 = d00 areap4 = d00 @@ -562,13 +564,13 @@ subroutine calwxt_ramer(lm,lp1,t,q,pmid,rh,td,pint,ptyp) ! + ptyp) ! output(2) phase 2=rain, 3=frzg, 4=solid, ! 6=ip jc 9/16/99 ! use params_mod -! use ctlblk_mod +! use ctlblk_mod !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - implicit none ! real,parameter :: twice=266.55,rhprcp=0.80,deltag=1.02, & & emelt=0.045,rlim=0.04,slim=0.85 - real,parameter :: twmelt=273.15,tz=273.15,efac=1.0 ! specify in params now + real,parameter :: twmelt=273.15,tz=273.15,efac=1.0 ! specify in params now ! integer*4 i, k1, lll, k2, toodry ! @@ -597,7 +599,7 @@ subroutine calwxt_ramer(lm,lp1,t,q,pmid,rh,td,pint,ptyp) ! qc=pq0/p(l) * exp(a2*(t(l)-a3)/(t(l)-a4)) !gsm forcing q (qtmp) to be positive to deal with negative q values ! causing problems later in this subroutine -! qtmp=max(h1m12,q(l)) +! qtmp=max(h1m12,q(l)) ! rhqtmp(lev)=qtmp/qc rhq(lev) = rh(l) pq(lev) = pmid(l) * 0.01 @@ -751,7 +753,7 @@ subroutine calwxt_ramer(lm,lp1,t,q,pmid,rh,td,pint,ptyp) dpk = log(pq(k1)/ptop) !lin dpk=pq(k1)-ptop ! mye = emelt*(1.0-(1.0-rhavg)*efac) mye = emelt * rhavg ** efac - icefrac = icefrac + dpk * dtavg / mye + icefrac = icefrac + dpk * dtavg / mye else ! mix where tw curve crosses twmelt in layer if (twq(k1) == twtop) go to 40 ! both equal twmelt, nothing h wgt1 = (twmelt-twq(k1)) / (twtop-twq(k1)) @@ -762,7 +764,7 @@ subroutine calwxt_ramer(lm,lp1,t,q,pmid,rh,td,pint,ptyp) ! mye = emelt*(1.0-(1.0-rhavg)*efac) mye = emelt * rhavg ** efac icefrac = icefrac + dpk * dtavg / mye - icefrac = min(1.0,max(icefrac,0.0)) + icefrac = min(1.0,max(icefrac,0.0)) if (icefrac <= 0.0) then ! goto 1020 if (twq(k1) > twice) go to 40 ! cannot commence freezin @@ -814,12 +816,12 @@ subroutine calwxt_ramer(lm,lp1,t,q,pmid,rh,td,pint,ptyp) !gsm algorithms to provide an answer, i will not declare a !gsm type from the ramer in this situation and allow the !gsm other algorithms to make the call. - - ptyp = 0 ! don't know + + ptyp = 0 ! don't know ! ptyp = 5 ! mix else ! ptyp = 5 ! mix - ptyp = 0 ! don't know + ptyp = 0 ! don't know end if end if @@ -970,7 +972,7 @@ subroutine calwxt_bourg(lm,lp1,rn,g,t,q,pmid,pint,zint,ptype) ! initialize weather type array to zero (ie, off). ! we do this since we want ptype to represent the ! instantaneous weather type on return. -! +! ptype = 0 psfck = pint(lm+1) @@ -994,7 +996,7 @@ subroutine calwxt_bourg(lm,lp1,rn,g,t,q,pmid,pint,zint,ptype) lhiwrm = lm + 1 do l = lm, 1, -1 ! gsm added 250 mb check to prevent stratospheric warming situations -! from counting as warm layers aloft +! from counting as warm layers aloft if (t(l) >= 273.15 .and. pmid(l) > 25000.) lhiwrm = l end do @@ -1018,7 +1020,7 @@ subroutine calwxt_bourg(lm,lp1,rn,g,t,q,pmid,pint,zint,ptype) ifrzl = 0 areane = 0.0 areape = 0.0 - surfw = 0.0 + surfw = 0.0 do l = lm, 1, -1 if (ifrzl == 0 .and. t(l) <= 273.15) ifrzl = 1 @@ -1037,7 +1039,7 @@ subroutine calwxt_bourg(lm,lp1,rn,g,t,q,pmid,pint,zint,ptype) endif pintk1 = pintk2 enddo - + ! ! decision tree time ! @@ -1118,7 +1120,7 @@ subroutine calwxt_bourg(lm,lp1,rn,g,t,q,pmid,pint,zint,ptype) ! subroutine calwxt_revised(lm,lp1,t,q,pmid,pint, & d608,rog,epsq,zint,twet,iwx) -! +! ! file: calwxt.f ! written: 11 november 1993, michael baldwin ! revisions: @@ -1128,8 +1130,8 @@ subroutine calwxt_revised(lm,lp1,t,q,pmid,pint, & ! 02-01-15 mike baldwin - wrf version ! 05-07-07 binbin zhou - add prec for rsm ! 05-08-24 geoff manikin - modified the area requirements -! to make an alternate algorithm -! +! to make an alternate algorithm +! ! ! routine to compute precipitation type using a decision tree ! approach that uses variables such as integrated wet bulb temp @@ -1158,7 +1160,7 @@ subroutine calwxt_revised(lm,lp1,t,q,pmid,pint, & integer,intent(in) :: lm,lp1 real,dimension(lm),intent(in) :: t,q,pmid,twet - real,dimension(lp1),intent(in) :: pint,zint + real,dimension(lp1),intent(in) :: pint,zint real,intent(in) :: d608,rog,epsq ! output: ! iwx - instantaneous weather type. @@ -1171,7 +1173,7 @@ subroutine calwxt_revised(lm,lp1,t,q,pmid,pint, & integer, intent(out) :: iwx ! internal: ! - real, parameter :: d00=0.0 + real, parameter :: d00=0.0 integer karr,licee real tcold,twarm ! @@ -1181,12 +1183,12 @@ subroutine calwxt_revised(lm,lp1,t,q,pmid,pint, & ! subroutines called: ! wetbulb -! +! ! ! initialize weather type array to zero (ie, off). ! we do this since we want iwx to represent the ! instantaneous weather type on return. -! +! ! ! allocate local storage ! @@ -1276,7 +1278,7 @@ subroutine calwxt_revised(lm,lp1,t,q,pmid,pint, & ! pintk1 is the pressure at the bottom of the layer ! pintk2 is the pressure at the top of the layer ! -! areap4 is the area of twet above -4 c below highest sat lyr +! areap4 is the area of twet above -4 c below highest sat lyr ! areap0 is the area of twet above 0 c below highest sat lyr ! areas8 = d00 @@ -1284,7 +1286,7 @@ subroutine calwxt_revised(lm,lp1,t,q,pmid,pint, & areap0 = d00 surfw = d00 surfc = d00 - + ! do l=lmhk,lice,-1 dzkl = zint(l)-zint(l+1) @@ -1373,9 +1375,9 @@ subroutine calwxt_revised(lm,lp1,t,q,pmid,pint, & ! ! subroutine calwxt_explicit(lm,tskin,sr,f_rimef,iwx) -! +! ! file: calwxt.f -! written: 24 august 2005, g manikin and b ferrier +! written: 24 august 2005, g manikin and b ferrier ! ! routine to compute precipitation type using explicit fields ! from the model microphysics @@ -1407,11 +1409,11 @@ subroutine calwxt_explicit(lm,tskin,sr,f_rimef,iwx) ! use the skin temperature to distinguish rain from freezing rain ! note that 2-m temperature may be a better choice if the model ! has a cold bias for skin temperature -! +! if (sr < 0.5) then ! surface (skin) potential temperature and temperature. ! psfc=pmid(lm) -! tskin=ths*(psfc/p1000)**capa +! tskin=ths*(psfc/p1000)**capa if (tskin < 273.15) then ! freezing rain = 4 iwx = iwx + 4 @@ -1419,14 +1421,14 @@ subroutine calwxt_explicit(lm,tskin,sr,f_rimef,iwx) iwx = iwx + 8 endif else -! +! ! distinguish snow from sleet with the rime factor -! +! if(f_rimef(lm) >= 10) then ! sleet = 2 iwx = iwx + 2 else snow = 1 - iwx = iwx + 1 + iwx = iwx + 1 endif endif end @@ -1435,8 +1437,8 @@ subroutine calwxt_explicit(lm,tskin,sr,f_rimef,iwx) subroutine calwxt_dominant(nalg,rain,freezr,sleet,snow, & & domr,domzr,domip,doms) ! -! written: 24 august 2005, g manikin -! +! written: 24 august 2005, g manikin +! ! this routine takes the precip type solutions from different ! algorithms and sums them up to give a dominant type ! @@ -1459,7 +1461,7 @@ subroutine calwxt_dominant(nalg,rain,freezr,sleet,snow, & totsn = 0 totip = 0 totr = 0 - totzr = 0 + totzr = 0 ! loop over the number of different algorithms that are used do l = 1, nalg if (rain(l) > 0) then @@ -1474,19 +1476,19 @@ subroutine calwxt_dominant(nalg,rain,freezr,sleet,snow, & enddo ! ties are broken to favor the most dangerous form of precip -! freezing rain > snow > sleet > rain +! freezing rain > snow > sleet > rain if (totsn > totip) then if (totsn > totzr) then if (totsn >= totr) then doms = 1 else - domr = 1 + domr = 1 endif elseif (totzr >= totr) then domzr = 1 else domr = 1 - endif + endif else if (totip > totzr) then if (totip >= totr) then domip = 1 @@ -1502,9 +1504,9 @@ subroutine calwxt_dominant(nalg,rain,freezr,sleet,snow, & return end -!> \section arg_table_calpreciptype_finalize Argument table +!> \section arg_table_GFS_calpreciptype_finalize Argument table !! subroutine GFS_calpreciptype_finalize end subroutine GFS_calpreciptype_finalize - - end module GFS_calpreciptype + + end module GFS_calpreciptype From 0e33eb029f554f9f28d0d7029b5e1ee860394d39 Mon Sep 17 00:00:00 2001 From: "Man.Zhang" Date: Mon, 13 Nov 2017 21:14:28 +0000 Subject: [PATCH 16/25] add GFS_MP_generic_post --- GFS_layer/GFS_physics_driver.F90 | 46 +++++++----- makefile | 1 + physics/GFS_MP_generic_post.f90 | 117 +++++++++++++++++++++++++++++++ physics/GFS_calpreciptype.f90 | 8 ++- physics/docs/ccpp_dox | 4 ++ 5 files changed, 154 insertions(+), 22 deletions(-) create mode 100644 physics/GFS_MP_generic_post.f90 diff --git a/GFS_layer/GFS_physics_driver.F90 b/GFS_layer/GFS_physics_driver.F90 index 6e45f6af1..85d5471eb 100644 --- a/GFS_layer/GFS_physics_driver.F90 +++ b/GFS_layer/GFS_physics_driver.F90 @@ -19,6 +19,7 @@ module module_physics_driver use GFS_zhaocarr_gscond, only: gscond_run use GFS_zhaocarr_precpd, only: precpd_run use GFS_calpreciptype, only: GFS_calpreciptype_run + use GFS_MP_generic_post, only: GFS_MP_generic_post_run implicit none @@ -2579,6 +2580,13 @@ subroutine GFS_physics_driver & domr, domzr, domip, doms, Sfcprop%srflag, & ! output Sfcprop%tprcp) + call GFS_MP_generic_post_run (im, ix, levs, dtf, del, & + Model%lssav, Model%ldiag3d, Diag%rain,frain, & + Model%ntcw, Model%ncld, & + Stateout%gq0(:,:,Model%ntcw), & + Stateout%gt0, Stateout%gq0(:,:,1), & + dtdt,dqdt(:,:,1),Diag%totprcp, Diag%dt3dt(:,:,6),& + Diag%dq3dt(:,:,6), Diag%pwat ) ! if (Model%cal_pre) then ! hchuang: add dominant precipitation type algorithm ! i = min(3,Model%num_p3d) @@ -2608,14 +2616,14 @@ subroutine GFS_physics_driver & ! enddo ! endif - if (Model%lssav) then - Diag%totprcp(:) = Diag%totprcp(:) + Diag%rain(:) +! if (Model%lssav) then +! Diag%totprcp(:) = Diag%totprcp(:) + Diag%rain(:) - if (Model%ldiag3d) then - Diag%dt3dt(:,:,6) = Diag%dt3dt(:,:,6) + (Stateout%gt0(:,:)-dtdt(:,:)) * frain - Diag%dq3dt(:,:,4) = Diag%dq3dt(:,:,4) + (Stateout%gq0(:,:,1)-dqdt(:,:,1)) * frain - endif - endif +! if (Model%ldiag3d) then +! Diag%dt3dt(:,:,6) = Diag%dt3dt(:,:,6) + (Stateout%gt0(:,:)-dtdt(:,:)) * frain +! Diag%dq3dt(:,:,4) = Diag%dq3dt(:,:,4) + (Stateout%gq0(:,:,1)-dqdt(:,:,1)) * frain +! endif +! endif ! --- ... estimate t850 for rain-snow decision @@ -2704,20 +2712,20 @@ subroutine GFS_physics_driver & Sfcprop%slc(:,:) = slsoil(:,:) ! --- ... calculate column precipitable water "pwat" - Diag%pwat(:) = 0.0 - tem = dtf * 0.03456 / 86400.0 - do k = 1, levs - work1(:) = 0.0 - if (Model%ncld > 0) then - do ic = Model%ntcw, Model%ntcw+Model%ncld-1 - work1(:) = work1(:) + Stateout%gq0(:,k,ic) - enddo - endif - Diag%pwat(:) = Diag%pwat(:) + del(:,k)*(Stateout%gq0(:,k,1)+work1(:)) +! Diag%pwat(:) = 0.0 +! tem = dtf * 0.03456 / 86400.0 +! do k = 1, levs +! work1(:) = 0.0 +! if (Model%ncld > 0) then +! do ic = Model%ntcw, Model%ntcw+Model%ncld-1 +! work1(:) = work1(:) + Stateout%gq0(:,k,ic) +! enddo +! endif +! Diag%pwat(:) = Diag%pwat(:) + del(:,k)*(Stateout%gq0(:,k,1)+work1(:)) ! if (lprnt .and. i == ipr) write(0,*)' gq0=', ! &gq0(i,k,1),' qgrs=',qgrs(i,k,1),' work2=',work2(i),' k=',k - enddo - Diag%pwat(:) = Diag%pwat(:) * onebg +! enddo +! Diag%pwat(:) = Diag%pwat(:) * onebg ! write(1000+me,*)' pwat=',pwat(i),'i=',i,', ! &' rain=',rain(i)*1000.0,' dqsfc1=',dqsfc1(i)*tem,' kdt=',kdt diff --git a/makefile b/makefile index 60430a268..2f45caed8 100644 --- a/makefile +++ b/makefile @@ -115,6 +115,7 @@ SRCS_f = \ SRCS_f90 = \ ./physics/GFS_calpreciptype.f90 \ + ./physics/GFS_MP_generic_post.f90 \ ./physics/cs_conv.f90 \ ./physics/funcphys.f90 \ ./physics/gcm_shoc.f90 \ diff --git a/physics/GFS_MP_generic_post.f90 b/physics/GFS_MP_generic_post.f90 new file mode 100644 index 000000000..338a9862f --- /dev/null +++ b/physics/GFS_MP_generic_post.f90 @@ -0,0 +1,117 @@ +!> \file GFS_MP_generic_post.f90 +!! This file contains the subroutines that calculates physics/diagnotics variables +!! after calling microphysics scheme: +!! - totprcp: precipitation rate at surface +!! - dt3dt(:,:,6): large scale condensate heating rate at model layers +!! - dq3dt(:,:,4): large scale condensate moistening rate at model layers +!! - pwat: column integrated precipitable water + + module GFS_MP_generic_post + contains + +!> \defgroup GFS_MP_generic_post GFS MP generic post +!! @{ +!!\section arg_table_GFS_MP_generic_post_init Argument Table +!! + subroutine GFS_MP_generic_post_init + end subroutine GFS_MP_generic_post_init + + +!!\section arg_table_GFS_MP_generic_post_run Argument Table +!!| local var name | longname |description | units | rank | type | kind | intent | optional | +!!|----------------|--------------------------------------------------------|----------------------------------------------------------|-------------|------|---------|-----------|--------|----------| +!!| im | horizontal_loop_extent | horizontal loop extent, start at 1 | index | 0 | integer | | in | F | +!!| ix | horizontal_dimension | horizontal dimension | index | 0 | integer | | in | F | +!!| levs | vertical_dimension | vertical layer dimension | index | 0 | integer | | in | F | +!!| dtf | time_step_for_dynamics | dynamics time step | s | 0 | real | kind_phys | in | F | +!!| del | air_pressure_difference_between_midlayers | air pressure difference between midlayers | Pa | 2 | real | kind_phys | in | F | +!!| lssav | logical_flag_for_physics_diagnostics | logical flag for model physics diagnostics | flag | 0 | logical | | in | F | +!!| ldiag3d | logical_flag_for_3D_diagnostics | logical flag for 3D diagnostics | flag | 0 | logical | | in | F | +!!| rain | total_rainfall_at_surface | instantaneous total precipitation at surface (APCP) | m | 1 | real | kind_phys | in | F | +!!| frain | factor_for_centered_difference_scheme | dtf/dtp; factor for centered difference scheme correction| none | 0 | real | kind_phys | in | F | +!!| ntcw | index_for_liquid_cloud_condensate | cloud condensate index in tracer array(3) | index | 0 | integer | | in | F | +!!| ncld | choice_of_cloud_scheme | choice of cloud scheme(1 for Z-C) | none | 0 | integer | | in | F | +!!| cwm | cloud_condensed_water_specific_humidity | cloud condensed water specific humidity | kg kg-1 | 2 | real | kind_phys | in | F | +!!| t | air_temperature_updated_by_physics | layer mean air temperature | K | 2 | real | kind_phys | in | F | +!!| q | water_vapor_specific_humidity | water vapor specific humidity | kg kg-1 | 2 | real | kind_phys | in | F | +!!| dtdt | tendency_of_air_temperature_due_to_model_physics | updated tendency of the temperature | K s-1 | 2 | real | kind_phys | in | F | +!!| dqdt1 | tendency_of_specific_humidity_due_to_model_physics | updated tendency of the specific humidity | kg kg-1 s-1 | 2 | real | kind_phys | in | F | +!!| totprcp | precipitation_rate_at_surface | precipitation rate at surface | kg m-2 s-1 | 1 | real | kind_phys | inout | F | +!!| dt3dt6 | large_scale_condensate_heating_rate_at_model_layers | large scale condensate heating rate at model layers | K s-1 | 2 | real | kind_phys | inout | F | +!!| dq3dt4 | large_scale_condensate_moistening_rate_at_model_layers | large scale condensate moistening rate at model layers | kg kg-1 s-1 | 2 | real | kind_phys | inout | F | +!!| pwat | column_precipitable_water | column integrated precipitable water | kg m-2 | 1 | real | kind_phys | out | F | +!! + subroutine GFS_MP_generic_post_run(im, ix, levs,dtf,del, & + lssav,ldiag3d,rain,frain,ntcw,ncld,cwm, & !input + t,q,dtdt,dqdt1, & + totprcp, dt3dt6,dq3dt4,pwat ) ! output + +! + use machine, only: kind_phys + use physcons, only: con_g + + implicit none +! +! declare variables. +! + integer,intent(in) :: im, ix, levs, ntcw, ncld + integer :: ic,i,k + logical :: lssav, ldiag3d + real(kind=kind_phys) :: frain, dtf, tem + real(kind=kind_phys),dimension(im) :: work1 + real(kind=kind_phys),dimension(im), intent(in) :: rain + real(kind=kind_phys),dimension(ix,levs), intent(in) :: t,q, & + cwm, del, dtdt, dqdt1 + real(kind=kind_phys),dimension(im), intent(inout) :: totprcp + real(kind=kind_phys),dimension(im), intent(out) :: pwat + real(kind=kind_phys),dimension(ix,levs), intent(inout) :: & + dt3dt6,dq3dt4 +! CONSTANT PARAMETERS + real(kind=kind_phys), parameter :: onebg = 1.0/con_g + + if (lssav) then + do i = 1, im + totprcp(i) = totprcp(i) + rain(i) + enddo + + if (ldiag3d) then + do i = 1, im + do k = 1,levs + dt3dt6(i,k) = dt3dt6(i,k) + (t(i,k)-dtdt(i,k)) * frain + dq3dt4(i,k) = dq3dt4(i,k) + (q(i,k)-dqdt1(i,k)) * frain + enddo + enddo + endif + endif + +! --- ... calculate column precipitable water "pwat" + tem = dtf * 0.03456 / 86400.0 + do i = 1, im + pwat(i) = 0.0 + !tem = dtf * 0.03456 / 86400.0 + + do k = 1, levs + work1(i) = 0.0 + !if (ncld > 0) then + !do ic = ntcw, ntcw+ncld-1 + ! work1(i) = work1(i) + Stateout%gq0(i,k,ic) + work1(i) = work1(i) + cwm(i,k) + !enddo + !endif + pwat(i) = pwat(i) + del(i,k)*(q(i,k)+work1(i)) + enddo + pwat(i) = pwat(i) * onebg + + enddo + + !deallocate (clw) + + end subroutine GFS_MP_generic_post_run + +!!\setction arg_table_GFS_MP_generic_post_finalize Argument Table +!! + subroutine GFS_MP_generic_post_finalize + end subroutine GFS_MP_generic_post_finalize +!! @} + end module GFS_MP_generic_post + diff --git a/physics/GFS_calpreciptype.f90 b/physics/GFS_calpreciptype.f90 index 417d4de8f..87e53314a 100644 --- a/physics/GFS_calpreciptype.f90 +++ b/physics/GFS_calpreciptype.f90 @@ -5,11 +5,12 @@ module GFS_calpreciptype contains -!>\section arg_table_calpreciptype_init Argument Table +!>\section arg_table_GFS_calpreciptype_init Argument Table +!! subroutine GFS_calpreciptype_init end subroutine GFS_calpreciptype_init -!!\section arg_table_calpreciptype_run Argument Table +!!\section arg_table_GFS_calpreciptype_run Argument Table !!| local var name | longname |description | units | rank | type | kind | intent | optional | !!|----------------|------------------------------------------------|----------------------------------------------------------|---------|------|---------|-----------|--------|----------| !!| kdt | index_of_time_step | current time step index | index | 0 | integer | | in | F | @@ -36,6 +37,7 @@ end subroutine GFS_calpreciptype_init !!| doms | dominant_snow_type | dominant snow type | none | 1 | real | kind_phys | out | F | !!| srflag | flag_for_preciptation_type | snow(1)/rain(0) flag for precipitation | 1 | 1 | real | kind_phys | out | F | !!| tprcp | precipitation_amount_in_one_dynamics_time_step | precipitation amount in one dynamics time step | m | 1 | real | kind_phys | out | F | +!! subroutine GFS_calpreciptype_run(kdt,nrcm,im,ix,lm,lp1,randomno, & cal_pre, & gt0,gq0,prsl,prsi,prec, & !input @@ -1502,7 +1504,7 @@ subroutine calwxt_dominant(nalg,rain,freezr,sleet,snow, & return end -!> \section arg_table_calpreciptype_finalize Argument table +!> \section arg_table_GFS_calpreciptype_finalize Argument table !! subroutine GFS_calpreciptype_finalize end subroutine GFS_calpreciptype_finalize diff --git a/physics/docs/ccpp_dox b/physics/docs/ccpp_dox index a512aa0ab..79b20172c 100644 --- a/physics/docs/ccpp_dox +++ b/physics/docs/ccpp_dox @@ -30,6 +30,7 @@ OPTIMIZE_OUTPUT_JAVA = NO OPTIMIZE_FOR_FORTRAN = YES OPTIMIZE_OUTPUT_VHDL = NO EXTENSION_MAPPING = .f=FortranFixed \ + .f90=FortranFree \ .f=FortranFree MARKDOWN_SUPPORT = YES AUTOLINK_SUPPORT = YES @@ -122,6 +123,9 @@ INPUT = txt/mainpage.txt \ ### Microphysics ../precpd.f \ ../gscond.f \ +### MP_generic + ../GFS_MP_generic_post.f90 \ + ../GFS_calpreciptype.f90 \ ### Land Surface ../sfc_drv.f \ ../sfc_diff.f \ From a05f762b91d1f84703dfb08bc4949839d47707f3 Mon Sep 17 00:00:00 2001 From: "Man.Zhang" Date: Mon, 13 Nov 2017 23:30:23 +0000 Subject: [PATCH 17/25] fix a bug in table of GFS_calpreciptype.f90 --- physics/GFS_calpreciptype.f90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/physics/GFS_calpreciptype.f90 b/physics/GFS_calpreciptype.f90 index 860090dfd..c451c0b4d 100644 --- a/physics/GFS_calpreciptype.f90 +++ b/physics/GFS_calpreciptype.f90 @@ -35,7 +35,7 @@ end subroutine GFS_calpreciptype_init !!| domzr | dominant_freezing_rain_type | dominant freezing rain type | none | 1 | real | kind_phys | out | F | !!| domip | dominant_sleet_type | dominant sleet type | none | 1 | real | kind_phys | out | F | !!| doms | dominant_snow_type | dominant snow type | none | 1 | real | kind_phys | out | F | -!!| srflag | flag_for_precipitation_type | snow(1)/rain(0) flag for precipitation | 1 | 1 | real | kind_phys | out | F | +!!| srflag | flag_for_precipitation_type | snow(1)/rain(0) flag for precipitation | 1 | 1 | real | kind_phys | out | F | !!| tprcp | precipitation_amount_in_one_dynamics_time_step | precipitation amount in one dynamics time step | m | 1 | real | kind_phys | out | F | !! subroutine GFS_calpreciptype_run(kdt,nrcm,im,ix,lm,lp1,randomno, & From 837adcc74c13d116a617f24e59d968829faabca6 Mon Sep 17 00:00:00 2001 From: "Man.Zhang" Date: Mon, 13 Nov 2017 23:42:52 +0000 Subject: [PATCH 18/25] fix longname bug --- physics/GFS_MP_generic_post.f90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/physics/GFS_MP_generic_post.f90 b/physics/GFS_MP_generic_post.f90 index 338a9862f..b91698113 100644 --- a/physics/GFS_MP_generic_post.f90 +++ b/physics/GFS_MP_generic_post.f90 @@ -34,8 +34,8 @@ end subroutine GFS_MP_generic_post_init !!| cwm | cloud_condensed_water_specific_humidity | cloud condensed water specific humidity | kg kg-1 | 2 | real | kind_phys | in | F | !!| t | air_temperature_updated_by_physics | layer mean air temperature | K | 2 | real | kind_phys | in | F | !!| q | water_vapor_specific_humidity | water vapor specific humidity | kg kg-1 | 2 | real | kind_phys | in | F | -!!| dtdt | tendency_of_air_temperature_due_to_model_physics | updated tendency of the temperature | K s-1 | 2 | real | kind_phys | in | F | -!!| dqdt1 | tendency_of_specific_humidity_due_to_model_physics | updated tendency of the specific humidity | kg kg-1 s-1 | 2 | real | kind_phys | in | F | +!!| dtdt | air_temperature_before_microphysics_scheme | air temperature saved before micophysics scheme | K | 2 | real | kind_phys | in | F | +!!| dqdt1 | specific_humidity_before_microphysics_scheme | specific humidity saved before microphysics schme | kg kg-1 | 2 | real | kind_phys | in | F | !!| totprcp | precipitation_rate_at_surface | precipitation rate at surface | kg m-2 s-1 | 1 | real | kind_phys | inout | F | !!| dt3dt6 | large_scale_condensate_heating_rate_at_model_layers | large scale condensate heating rate at model layers | K s-1 | 2 | real | kind_phys | inout | F | !!| dq3dt4 | large_scale_condensate_moistening_rate_at_model_layers | large scale condensate moistening rate at model layers | kg kg-1 s-1 | 2 | real | kind_phys | inout | F | From c02e53a962616afea88d9ac50526c928bf26d84c Mon Sep 17 00:00:00 2001 From: "Man.Zhang" Date: Wed, 15 Nov 2017 09:49:16 -0700 Subject: [PATCH 19/25] metadata conflicts fixed and add GFS_MP_generic_pre.f90. pass B4B --- GFS_layer/GFS_physics_driver.F90 | 24 ++++++---- makefile | 1 + physics/GFS_MP_generic_post.f90 | 8 ++-- physics/GFS_MP_generic_pre.f90 | 82 ++++++++++++++++++++++++++++++++ 4 files changed, 103 insertions(+), 12 deletions(-) create mode 100644 physics/GFS_MP_generic_pre.f90 diff --git a/GFS_layer/GFS_physics_driver.F90 b/GFS_layer/GFS_physics_driver.F90 index 85d5471eb..ec41b4eac 100644 --- a/GFS_layer/GFS_physics_driver.F90 +++ b/GFS_layer/GFS_physics_driver.F90 @@ -20,6 +20,7 @@ module module_physics_driver use GFS_zhaocarr_precpd, only: precpd_run use GFS_calpreciptype, only: GFS_calpreciptype_run use GFS_MP_generic_post, only: GFS_MP_generic_post_run + use GFS_MP_generic_pre, only: GFS_MP_generic_pre_run implicit none @@ -2279,7 +2280,8 @@ subroutine GFS_physics_driver & Stateout%gq0(:,:,Model%ntiw) = clw(:,:,1) ! ice Stateout%gq0(:,:,Model%ntcw) = clw(:,:,2) ! water elseif (Model%num_p3d == 4) then ! if_num_p3d -!zhao-carr interstitial Stateout%gq0(:,:,Model%ntcw) = clw(:,:,1) + clw(:,:,2) +! 2275 zhang: Z-C_pre +! Stateout%gq0(:,:,Model%ntcw) = clw(:,:,1) + clw(:,:,2) endif ! end if_num_p3d else ! if_ntcw @@ -2337,13 +2339,19 @@ subroutine GFS_physics_driver & endif endif ! moist convective adjustment over ! - if (Model%ldiag3d .or. Model%do_aw) then - dtdt(:,:) = Stateout%gt0(:,:) - dqdt(:,:,1) = Stateout%gq0(:,:,1) - do n=Model%ntcw,Model%ntcw+Model%ncld-1 - dqdt(:,:,n) = Stateout%gq0(:,:,n) - enddo - endif +!zhang +! if (Model%ldiag3d .or. Model%do_aw) then +! dtdt(:,:) = Stateout%gt0(:,:) +! dqdt(:,:,1) = Stateout%gq0(:,:,1) +! do n=Model%ntcw,Model%ntcw+Model%ncld-1 +! dqdt(:,:,n) = Stateout%gq0(:,:,n) +! enddo +! endif + call GFS_MP_generic_pre_run (im, ix,levs,clw(:,:,1),clw(:,:,2), & + Model%ldiag3d, Model%ntcw, Model%ncld, & + Model%num_p3d, Stateout%gt0,Stateout%gq0(:,:,1), & + dtdt,dqdt(:,:,1),dqdt(:,:,2) ) + ! dqdt_v : instaneous moisture tendency (kg/kg/sec) if (Model%lgocart) then diff --git a/makefile b/makefile index 2f45caed8..06d445cf2 100644 --- a/makefile +++ b/makefile @@ -116,6 +116,7 @@ SRCS_f = \ SRCS_f90 = \ ./physics/GFS_calpreciptype.f90 \ ./physics/GFS_MP_generic_post.f90 \ + ./physics/GFS_MP_generic_pre.f90 \ ./physics/cs_conv.f90 \ ./physics/funcphys.f90 \ ./physics/gcm_shoc.f90 \ diff --git a/physics/GFS_MP_generic_post.f90 b/physics/GFS_MP_generic_post.f90 index b91698113..a9225866b 100644 --- a/physics/GFS_MP_generic_post.f90 +++ b/physics/GFS_MP_generic_post.f90 @@ -25,12 +25,12 @@ end subroutine GFS_MP_generic_post_init !!| levs | vertical_dimension | vertical layer dimension | index | 0 | integer | | in | F | !!| dtf | time_step_for_dynamics | dynamics time step | s | 0 | real | kind_phys | in | F | !!| del | air_pressure_difference_between_midlayers | air pressure difference between midlayers | Pa | 2 | real | kind_phys | in | F | -!!| lssav | logical_flag_for_physics_diagnostics | logical flag for model physics diagnostics | flag | 0 | logical | | in | F | -!!| ldiag3d | logical_flag_for_3D_diagnostics | logical flag for 3D diagnostics | flag | 0 | logical | | in | F | -!!| rain | total_rainfall_at_surface | instantaneous total precipitation at surface (APCP) | m | 1 | real | kind_phys | in | F | +!!| lssav | flag_diagnostics | logical flag for model physics diagnostics | flag | 0 | logical | | in | F | +!!| ldiag3d | flag_diagnostics_3D | logical flag for 3D diagnostics | flag | 0 | logical | | in | F | +!!| rain | total_rainfall_amount | instantaneous total precipitation at surface (APCP) | m | 1 | real | kind_phys | in | F | !!| frain | factor_for_centered_difference_scheme | dtf/dtp; factor for centered difference scheme correction| none | 0 | real | kind_phys | in | F | !!| ntcw | index_for_liquid_cloud_condensate | cloud condensate index in tracer array(3) | index | 0 | integer | | in | F | -!!| ncld | choice_of_cloud_scheme | choice of cloud scheme(1 for Z-C) | none | 0 | integer | | in | F | +!!| ncld | number_of_hydrometeors | number_of_hydrometeors(1 for Z-C) | none | 0 | integer | | in | F | !!| cwm | cloud_condensed_water_specific_humidity | cloud condensed water specific humidity | kg kg-1 | 2 | real | kind_phys | in | F | !!| t | air_temperature_updated_by_physics | layer mean air temperature | K | 2 | real | kind_phys | in | F | !!| q | water_vapor_specific_humidity | water vapor specific humidity | kg kg-1 | 2 | real | kind_phys | in | F | diff --git a/physics/GFS_MP_generic_pre.f90 b/physics/GFS_MP_generic_pre.f90 new file mode 100644 index 000000000..fbd7c7796 --- /dev/null +++ b/physics/GFS_MP_generic_pre.f90 @@ -0,0 +1,82 @@ +!> \file GFS_MP_generic_pre.f90 +!! This file contains the subroutines that calculates physics/diagnotics variables +!! before calling microphysics scheme: + + module GFS_MP_generic_pre + contains + +!> \defgroup GFS_MP_generic_pre GFS MP generic pre +!! @{ +!!\section arg_table_GFS_MP_generic_pre_init Argument Table +!! + subroutine GFS_MP_generic_pre_init + end subroutine GFS_MP_generic_pre_init + + +!!\section arg_table_GFS_MP_generic_pre_run Argument Table +!!| local var name | longname |description | units | rank | type | kind | intent | optional | +!!|----------------|--------------------------------------------------------|----------------------------------------------------------|-------------|------|---------|-----------|--------|----------| +!!| im | horizontal_loop_extent | horizontal loop extent, start at 1 | index | 0 | integer | | in | F | +!!| ix | horizontal_dimension | horizontal dimension | index | 0 | integer | | in | F | +!!| levs | vertical_dimension | vertical layer dimension | index | 0 | integer | | in | F | +!!| clw1 | cloud_ice_specific_humidity | cloud ice specific humidity | kg kg-1 | 2 | real | kind_phys | in | F | +!!| clw2 | cloud_liquid_water_specific_humidity | cloud water specific humidity | kg kg-1 | 2 | real | kind_phys | in | F | +!!| ldiag3d | flag_diagnostics_3D | logical flag for 3D diagnostics | flag | 0 | logical | | in | F | +!!| ntcw | index_for_liquid_cloud_condensate | cloud condensate index in tracer array(3) | none | 0 | integer | | in | F | +!!| ncld | number_of_hydrometeors | number of hydrometeors(1 for Z-C) | none | 0 | integer | | in | F | +!!| num_p3d | array_dimension_of_microphysics | number of 3D arrays needed for microphysics | none | 0 | integer | | in | F | +!!| t | air_temperature_updated_by_physics | layer mean air temperature | K | 2 | real | kind_phys | in | F | +!!| q | water_vapor_specific_humidity_updated_by_physics | water vapor specific humidity | kg kg-1 | 2 | real | kind_phys | in | F | +!!| dtdt | ??? change meaning in _pre and _post | | K | 2 | real | kind_phys | out | F | +!!| dqdt1 | ??? change meaning | | kg kg-1 | 2 | real | kind_phys | out | F | +!!| dqdt2 | cloud_condensed_water_specific_humidity | cloud condensed water specific humidity | kg kg-1 | 2 | real | kind_phys | out | F | +!! + subroutine GFS_MP_generic_pre_run(im, ix, levs, clw1, clw2, & + ldiag3d, ntcw, ncld, num_p3d, t, q, & !input + dtdt,dqdt1, dqdt2) !output + +! + use machine, only: kind_phys + use physcons, only: con_g + + implicit none +! +! declare variables. +! + integer,intent(in) :: im, ix, levs, ntcw, ncld , num_p3d + integer :: n,i,k + logical :: ldiag3d + real(kind=kind_phys),dimension(ix,levs), intent(in) :: t,q, & + clw1,clw2 + real(kind=kind_phys),dimension(ix,levs), intent(out) :: dtdt, & + dqdt1, dqdt2 + + if (ldiag3d) then + do i = 1, im + do k = 1, levs + dtdt(i,k) = t(i,k) + dqdt1(i,k) = q(i,k) + enddo + end do + !in FV3GFS v0 OP: ntcw=2, ncld=1, num_p3d=4, ntrac=3 + do n=ntcw,ntcw+ncld-1 + if (n == ntcw .and. num_p3d == 4 ) then + do i = 1, im + do k = 1, levs + dqdt2(i,k) = clw1(i,k)+clw2(i,k) ! + enddo + enddo + endif + enddo + endif + + + end subroutine GFS_MP_generic_pre_run + +!!\setction arg_table_GFS_MP_generic_pre_finalize Argument Table +!! + subroutine GFS_MP_generic_pre_finalize + end subroutine GFS_MP_generic_pre_finalize +!! @} + end module GFS_MP_generic_pre + From 01bd32e50fc6070194ced38353c330c4965d80fe Mon Sep 17 00:00:00 2001 From: "Man.Zhang" Date: Wed, 15 Nov 2017 12:11:17 -0700 Subject: [PATCH 20/25] add interstitial code for rain before calpreciptype --- GFS_layer/GFS_physics_driver.F90 | 8 ++-- physics/GFS_calpreciptype.f90 | 71 ++++++++++++++++++-------------- 2 files changed, 44 insertions(+), 35 deletions(-) diff --git a/GFS_layer/GFS_physics_driver.F90 b/GFS_layer/GFS_physics_driver.F90 index ec41b4eac..b1918a5b5 100644 --- a/GFS_layer/GFS_physics_driver.F90 +++ b/GFS_layer/GFS_physics_driver.F90 @@ -2578,14 +2578,14 @@ subroutine GFS_physics_driver & rain1(:) = max(rain1(:) - temrain1(:)*0.001, 0.0_kind_phys) endif - Diag%rain(:) = Diag%rainc(:) + frain * rain1(:) +! Diag%rain(:) = Diag%rainc(:) + frain * rain1(:) call GFS_calpreciptype_run (kdt, Model%nrcm, im, ix, levs, levs+1, & Tbd%rann, Model%cal_pre, Stateout%gt0, & Stateout%gq0, Statein%prsl, Statein%prsi, & - Diag%rain, Statein%phii, Model%num_p3d, & - Sfcprop%tsfc, Diag%sr, Tbd%phy_f3d(:,:,i), & ! input - domr, domzr, domip, doms, Sfcprop%srflag, & ! output + Diag%rainc,frain,rain1, Statein%phii, Model%num_p3d, & + Sfcprop%tsfc, Diag%sr, Tbd%phy_f3d(:,:,3), & ! input !zhang:Tbd%phy_f3d(:,:,3) comes from gscond_run + Diag%rain, domr, domzr, domip, doms, Sfcprop%srflag, & ! output Sfcprop%tprcp) call GFS_MP_generic_post_run (im, ix, levs, dtf, del, & diff --git a/physics/GFS_calpreciptype.f90 b/physics/GFS_calpreciptype.f90 index c451c0b4d..4db829a6c 100644 --- a/physics/GFS_calpreciptype.f90 +++ b/physics/GFS_calpreciptype.f90 @@ -12,37 +12,40 @@ end subroutine GFS_calpreciptype_init !!\section arg_table_GFS_calpreciptype_run Argument Table !!| local var name | longname |description | units | rank | type | kind | intent | optional | -!!|----------------|------------------------------------------------|----------------------------------------------------------|---------|------|---------|-----------|--------|----------| -!!| kdt | index_of_time_step | current time step index | index | 0 | integer | | in | F | -!!| nrcm | array_dimension_of_random_number | second dimension of random number array | count | 0 | integer | | in | F | -!!| im | horizontal_loop_extent | horizontal loop extent, start at 1 | index | 0 | integer | | in | F | -!!| ix | horizontal_dimension | horizontal dimension | index | 0 | integer | | in | F | -!!| lm | vertical_dimension | vertical layer dimension | index | 0 | integer | | in | F | -!!| lp1 | vertical_interface_dimension | vertical interface dimension | index | 0 | integer | | in | F | -!!| randomno | random_number_array | random number array | none | 2 | real | | in | F | -!!| cal_pre | flag_for_precipitation_type_algorithm | flag controls precip type algorithm | flag | 0 | logical | | in | F | -!!| gt0 | air_temperature_updated_by_physics | layer mean air temperature | K | 2 | real | kind_phys | in | F | -!!| gq0 | water_vapor_specific_humidity | water vapor specific humidity | kg kg-1 | 2 | real | kind_phys | in | F | -!!| prsl | air_pressure | layer mean pressure | Pa | 2 | real | kind_phys | in | F | -!!| prsi | air_pressure_at_interface | pressure at layer interface | Pa | 2 | real | kind_phys | in | F | -!!| prec | total_rainfall_amount | instantaneous total precipitation at surface | m | 1 | real | kind_phys | in | F | -!!| phii | geopotential_at_interface | geopotential at model layer interfaces | m2 s-2 | 2 | real | kind_phys | in | F | -!!| n3dfercld | array_dimension_of_microphysics | number of 3D arrays needed for microphysics | count | 0 | integer | | in | F | -!!| tskin | surface_skin_temperature | surface skin temperature | K | 1 | real | kind_phys | in | F | -!!| sr | ratio_of_snowfall_to_rainfall | ratio of snowfall to rainfall | frac | 1 | real | kind_phys | in | F | -!!| phy_f3d | air_temperature_at_previous_time_step | air temperature at previous time step | K | 2 | real | kind_phys | in | F | -!!| domr | dominant_rain_type | dominant rain type | none | 1 | real | kind_phys | out | F | -!!| domzr | dominant_freezing_rain_type | dominant freezing rain type | none | 1 | real | kind_phys | out | F | -!!| domip | dominant_sleet_type | dominant sleet type | none | 1 | real | kind_phys | out | F | -!!| doms | dominant_snow_type | dominant snow type | none | 1 | real | kind_phys | out | F | -!!| srflag | flag_for_precipitation_type | snow(1)/rain(0) flag for precipitation | 1 | 1 | real | kind_phys | out | F | -!!| tprcp | precipitation_amount_in_one_dynamics_time_step | precipitation amount in one dynamics time step | m | 1 | real | kind_phys | out | F | +!!|----------------|---------------------------------------------------|----------------------------------------------------------|---------|------|---------|-----------|--------|----------| +!!| kdt | index_of_time_step | current time step index | index | 0 | integer | | in | F | +!!| nrcm | array_dimension_of_random_number | second dimension of random number array | count | 0 | integer | | in | F | +!!| im | horizontal_loop_extent | horizontal loop extent, start at 1 | index | 0 | integer | | in | F | +!!| ix | horizontal_dimension | horizontal dimension | index | 0 | integer | | in | F | +!!| lm | vertical_dimension | vertical layer dimension | index | 0 | integer | | in | F | +!!| lp1 | vertical_interface_dimension | vertical interface dimension | index | 0 | integer | | in | F | +!!| randomno | random_number_array | random number array | none | 2 | real | | in | F | +!!| cal_pre | flag_for_precipitation_type_algorithm | flag controls precip type algorithm | flag | 0 | logical | | in | F | +!!| gt0 | air_temperature_updated_by_physics | layer mean air temperature | K | 2 | real | kind_phys | in | F | +!!| gq0 | water_vapor_specific_humidity | water vapor specific humidity | kg kg-1 | 2 | real | kind_phys | in | F | +!!| prsl | air_pressure | layer mean pressure | Pa | 2 | real | kind_phys | in | F | +!!| prsi | air_pressure_at_interface | pressure at layer interface | Pa | 2 | real | kind_phys | in | F | +!!| rainc | instantaneous_rainfall_amount_due_to_convetive | instantaneous rainfall amount due to convective scheme | m | 1 | real | kind_phys | in | F | +!!| frain | factor_for_centered_difference_scheme | dtf/dtp | none | 0 | real | kind_phys | in | F | +!!| rain1 | instantaneous_rainfall_amount_due_to_microphysics | instantaneous rainfall amount due to microphysics scheme | m | 1 | real | kind_phys | in | F | +!!| phii | geopotential_at_interface | geopotential at model layer interfaces | m2 s-2 | 2 | real | kind_phys | in | F | +!!| n3dfercld | array_dimension_of_microphysics | number of 3D arrays needed for microphysics | count | 0 | integer | | in | F | +!!| tskin | surface_skin_temperature | surface skin temperature | K | 1 | real | kind_phys | in | F | +!!| sr | ratio_of_snowfall_to_rainfall | ratio of snowfall to rainfall | frac | 1 | real | kind_phys | in | F | +!!| phy_f3d | air_temperature_at_previous_time_step | air temperature at previous time step | K | 2 | real | kind_phys | in | F | +!!| prec | total_rainfall_amount | instantaneous total rainfall amount | m | 1 | real | kind_phys | out | F | +!!| domr | dominant_rain_type | dominant rain type | none | 1 | real | kind_phys | out | F | +!!| domzr | dominant_freezing_rain_type | dominant freezing rain type | none | 1 | real | kind_phys | out | F | +!!| domip | dominant_sleet_type | dominant sleet type | none | 1 | real | kind_phys | out | F | +!!| doms | dominant_snow_type | dominant snow type | none | 1 | real | kind_phys | out | F | +!!| srflag | flag_for_precipitation_type | snow(1)/rain(0) flag for precipitation | 1 | 1 | real | kind_phys | out | F | +!!| tprcp | precipitation_amount_in_one_dynamics_time_step | precipitation amount in one dynamics time step | m | 1 | real | kind_phys | out | F | !! subroutine GFS_calpreciptype_run(kdt,nrcm,im,ix,lm,lp1,randomno, & cal_pre, & - gt0,gq0,prsl,prsi,prec, & !input + gt0,gq0,prsl,prsi, rainc,frain,rain1, & phii,n3dfercld,tskin,sr,phy_f3d, & !input - domr,domzr,domip,doms,srflag,tprcp) !output + prec, domr,domzr,domip,doms,srflag,tprcp) !output !$$$ subprogram documentation block ! . . . @@ -68,11 +71,13 @@ subroutine GFS_calpreciptype_run(kdt,nrcm,im,ix,lm,lp1,randomno, & integer,intent(in) :: kdt,nrcm,im,ix,lm,lp1,n3dfercld logical :: cal_pre real,intent(in) :: randomno(ix,nrcm) - real(kind=kind_phys),dimension(im), intent(in) :: prec,sr,tskin + real(kind=kind_phys),dimension(im), intent(in) :: sr,tskin, & + rainc,rain1 real(kind=kind_phys),dimension(ix,lm), intent(in) :: gt0,gq0,prsl,phy_f3d real(kind=kind_phys),dimension(ix,lp1),intent(in) :: prsi,phii real(kind=kind_phys),dimension(im), intent(out) :: domr,domzr,domip,doms - real(kind=kind_phys),dimension(im), intent(out) :: srflag,tprcp + real(kind=kind_phys),dimension(im), intent(out) :: srflag,tprcp, & + prec real(kind=kind_phys),dimension(im) :: t850 real(kind=kind_phys), parameter :: p850 = 85000.0 @@ -82,7 +87,7 @@ subroutine GFS_calpreciptype_run(kdt,nrcm,im,ix,lm,lp1,randomno, & real(kind=kind_phys), allocatable :: twet(:),rh(:),td(:) ! integer i,iwx,isno,iip,izr,irain,k,k1 - real(kind=kind_phys) es,qc,pv,tdpd,pr,tr,pk,tlcl,thelcl,qwet, & + real(kind=kind_phys) es,qc,pv,tdpd,pr,tr,pk,tlcl,thelcl,qwet,frain, & time_vert,time_ncep,time_ramer,time_bourg,time_revised,& time_dominant,btim,timef,ranl(2) @@ -96,8 +101,12 @@ subroutine GFS_calpreciptype_run(kdt,nrcm,im,ix,lm,lp1,randomno, & ! don't forget to flip 3d arrays around because gfs counts from bottom up !--- original GFS calpreciptype_pre interstitial------------------- + do i = 1, im + prec(i) = rainc(i) + frain * rain1(i) + enddo + if (cal_pre) then !hchuang: add dominant precipitation type algorithm - i = min(3,n3dfercld) + !nn = min(3,n3dfercld) !zhang: i= 3 for Z-C !--- original subroutine calpreiptype start ----------------- allocate ( twet(lm),rh(lm),td(lm) ) From d81c5253999e863536906043f4acf2be21df5cd4 Mon Sep 17 00:00:00 2001 From: "Man.Zhang" Date: Tue, 21 Nov 2017 14:28:37 -0700 Subject: [PATCH 21/25] add GFS_zhao_carr_pre.f90 --- GFS_layer/GFS_physics_driver.F90 | 9 ++++-- makefile | 1 + physics/GFS_MP_generic_pre.f90 | 10 +++--- physics/GFS_zhao_carr_pre.f90 | 54 ++++++++++++++++++++++++++++++++ 4 files changed, 66 insertions(+), 8 deletions(-) create mode 100644 physics/GFS_zhao_carr_pre.f90 diff --git a/GFS_layer/GFS_physics_driver.F90 b/GFS_layer/GFS_physics_driver.F90 index b1918a5b5..085c8bd9c 100644 --- a/GFS_layer/GFS_physics_driver.F90 +++ b/GFS_layer/GFS_physics_driver.F90 @@ -21,6 +21,7 @@ module module_physics_driver use GFS_calpreciptype, only: GFS_calpreciptype_run use GFS_MP_generic_post, only: GFS_MP_generic_post_run use GFS_MP_generic_pre, only: GFS_MP_generic_pre_run + use GFS_zhao_carr_pre, only: GFS_zhao_carr_pre_run implicit none @@ -1578,7 +1579,9 @@ subroutine GFS_physics_driver & !zhang: precpd interstitial ! psautco_l(:) = Model%psautco(1)*work1(:) + Model%psautco(2)*work2(:) ! prautco_l(:) = Model%prautco(1)*work1(:) + Model%prautco(2)*work2(:) - clw(:,:,1) = Stateout%gq0(:,:,Model%ntcw) +!zhang: zhao_carr_pre +! clw(:,:,1) = Stateout%gq0(:,:,Model%ntcw) + call GFS_zhao_carr_pre_run (im,ix, levs,Stateout%gq0(:,:,Model%ntcw),clw(:,:,1)) endif ! end if_num_p3d endif ! end if (ncld == 2) else ! if_ntcw @@ -2348,9 +2351,9 @@ subroutine GFS_physics_driver & ! enddo ! endif call GFS_MP_generic_pre_run (im, ix,levs,clw(:,:,1),clw(:,:,2), & - Model%ldiag3d, Model%ntcw, Model%ncld, & + Model%ldiag3d, Model%ntcw, Model%ncld, & Model%num_p3d, Stateout%gt0,Stateout%gq0(:,:,1), & - dtdt,dqdt(:,:,1),dqdt(:,:,2) ) + dtdt,dqdt(:,:,1),dqdt(:,:,3) ) ! dqdt_v : instaneous moisture tendency (kg/kg/sec) diff --git a/makefile b/makefile index 06d445cf2..5448f4956 100644 --- a/makefile +++ b/makefile @@ -117,6 +117,7 @@ SRCS_f90 = \ ./physics/GFS_calpreciptype.f90 \ ./physics/GFS_MP_generic_post.f90 \ ./physics/GFS_MP_generic_pre.f90 \ + ./physics/GFS_zhao_carr_pre.f90 \ ./physics/cs_conv.f90 \ ./physics/funcphys.f90 \ ./physics/gcm_shoc.f90 \ diff --git a/physics/GFS_MP_generic_pre.f90 b/physics/GFS_MP_generic_pre.f90 index fbd7c7796..de8a661e9 100644 --- a/physics/GFS_MP_generic_pre.f90 +++ b/physics/GFS_MP_generic_pre.f90 @@ -29,11 +29,11 @@ end subroutine GFS_MP_generic_pre_init !!| q | water_vapor_specific_humidity_updated_by_physics | water vapor specific humidity | kg kg-1 | 2 | real | kind_phys | in | F | !!| dtdt | ??? change meaning in _pre and _post | | K | 2 | real | kind_phys | out | F | !!| dqdt1 | ??? change meaning | | kg kg-1 | 2 | real | kind_phys | out | F | -!!| dqdt2 | cloud_condensed_water_specific_humidity | cloud condensed water specific humidity | kg kg-1 | 2 | real | kind_phys | out | F | +!!| dqdt3 | cloud_condensed_water_specific_humidity | cloud condensed water specific humidity | kg kg-1 | 2 | real | kind_phys | out | F | !! subroutine GFS_MP_generic_pre_run(im, ix, levs, clw1, clw2, & ldiag3d, ntcw, ncld, num_p3d, t, q, & !input - dtdt,dqdt1, dqdt2) !output + dtdt,dqdt1, dqdt3) !output ! use machine, only: kind_phys @@ -49,7 +49,7 @@ subroutine GFS_MP_generic_pre_run(im, ix, levs, clw1, clw2, & real(kind=kind_phys),dimension(ix,levs), intent(in) :: t,q, & clw1,clw2 real(kind=kind_phys),dimension(ix,levs), intent(out) :: dtdt, & - dqdt1, dqdt2 + dqdt1, dqdt3 if (ldiag3d) then do i = 1, im @@ -58,12 +58,12 @@ subroutine GFS_MP_generic_pre_run(im, ix, levs, clw1, clw2, & dqdt1(i,k) = q(i,k) enddo end do - !in FV3GFS v0 OP: ntcw=2, ncld=1, num_p3d=4, ntrac=3 + !in FV3GFS v0 OP: ntcw=3, ncld=1, num_p3d=4, ntrac=3 do n=ntcw,ntcw+ncld-1 if (n == ntcw .and. num_p3d == 4 ) then do i = 1, im do k = 1, levs - dqdt2(i,k) = clw1(i,k)+clw2(i,k) ! + dqdt3(i,k) = clw1(i,k)+clw2(i,k) ! enddo enddo endif diff --git a/physics/GFS_zhao_carr_pre.f90 b/physics/GFS_zhao_carr_pre.f90 new file mode 100644 index 000000000..4972a8305 --- /dev/null +++ b/physics/GFS_zhao_carr_pre.f90 @@ -0,0 +1,54 @@ +!> \file GFS_zhao_carr_pre.f90 +!! This file contains the subroutines that calculates physics/diagnotics variables +!! before calling microphysics scheme: + + module GFS_zhao_carr_pre + contains + +!> \defgroup GFS_zhao_carr_pre GFS Zhao-Carr Scheme pre +!! @{ +!!\section arg_table_GFS_zhao_carr_pre_init Argument Table +!! + subroutine GFS_zhao_carr_pre_init + end subroutine GFS_zhao_carr_pre_init + + +!!\section arg_table_GFS_zhao_carr_pre_run Argument Table +!!| local var name | longname |description | units | rank | type | kind | intent | optional | +!!|----------------|--------------------------------------------------------|----------------------------------------------------------|-------------|------|---------|-----------|--------|----------| +!!| im | horizontal_loop_extent | horizontal loop extent, start at 1 | index | 0 | integer | | in | F | +!!| ix | horizontal_dimension | horizontal dimension | index | 0 | integer | | in | F | +!!| levs | vertical_dimension | vertical layer dimension | index | 0 | integer | | in | F | +!!| cwm | cloud_condensed_water_specific_humidity | cloud condensed water specific humidity | kg kg-1 | 2 | real | kind_phys | in | F | +!!| clw1 | cloud_ice_specific_humidity | cloud ice specific humidity | kg kg-1 | 2 | real | kind_phys | out | F | +!! + subroutine GFS_zhao_carr_pre_run (im, ix, levs, cwm, clw1 ) + +! + use machine, only: kind_phys + + implicit none +! +! declare variables. +! + integer,intent(in) :: im, ix, levs + integer :: i,k + real(kind=kind_phys),dimension(ix,levs), intent(in) :: cwm + real(kind=kind_phys),dimension(ix,levs), intent(out) :: clw1 + + do i = 1, im + do k = 1, levs + clw1(i,k) = cwm(i,k) !Stateout%gq0(:,:,Model%ntcw) + enddo + enddo + + + end subroutine GFS_zhao_carr_pre_run + +!!\setction arg_table_GFS_zhao_carr_pre_finalize Argument Table +!! + subroutine GFS_zhao_carr_pre_finalize + end subroutine GFS_zhao_carr_pre_finalize +!! @} + end module GFS_zhao_carr_pre + From be0c1ea94566ccd3e38c07074fdee69d9144536b Mon Sep 17 00:00:00 2001 From: "Man.Zhang" Date: Thu, 7 Dec 2017 08:49:19 -0700 Subject: [PATCH 22/25] fixed some format as Dom indicated. --- physics/GFS_calpreciptype.f90 | 2 +- physics/GFS_zhao_carr_pre.f90 | 2 +- physics/gscond.f | 2 +- physics/precpd.f | 2 +- 4 files changed, 4 insertions(+), 4 deletions(-) diff --git a/physics/GFS_calpreciptype.f90 b/physics/GFS_calpreciptype.f90 index 4db829a6c..beab6c561 100644 --- a/physics/GFS_calpreciptype.f90 +++ b/physics/GFS_calpreciptype.f90 @@ -1511,7 +1511,7 @@ subroutine calwxt_dominant(nalg,rain,freezr,sleet,snow, & endif ! return - end + end subroutine GFS_calpreciptype_run !> \section arg_table_GFS_calpreciptype_finalize Argument table !! diff --git a/physics/GFS_zhao_carr_pre.f90 b/physics/GFS_zhao_carr_pre.f90 index 4972a8305..938a354da 100644 --- a/physics/GFS_zhao_carr_pre.f90 +++ b/physics/GFS_zhao_carr_pre.f90 @@ -45,7 +45,7 @@ subroutine GFS_zhao_carr_pre_run (im, ix, levs, cwm, clw1 ) end subroutine GFS_zhao_carr_pre_run -!!\setction arg_table_GFS_zhao_carr_pre_finalize Argument Table +!!\section arg_table_GFS_zhao_carr_pre_finalize Argument Table !! subroutine GFS_zhao_carr_pre_finalize end subroutine GFS_zhao_carr_pre_finalize diff --git a/physics/gscond.f b/physics/gscond.f index 2750659ac..a71f42140 100644 --- a/physics/gscond.f +++ b/physics/gscond.f @@ -537,7 +537,7 @@ subroutine gscond_run (im,ix,km,dt,dtf,prsl,ps,q,clw1,clw2 & endif !----------------------------------------------------------------------- return - end + end subroutine gscond_run !> @} !> \ingroup condense diff --git a/physics/precpd.f b/physics/precpd.f index 1221918ed..bae7ae3e0 100644 --- a/physics/precpd.f +++ b/physics/precpd.f @@ -736,7 +736,7 @@ subroutine precpd_run (im,ix,km,dt,del,prsl,q,cwm,t,rn,sr & enddo ! return - end + end subroutine precpd_run !> @} !> \ingroup precip From 3fc2e1658a8a9338db7f107916cb9a89f236a54e Mon Sep 17 00:00:00 2001 From: llpcarson Date: Fri, 15 Dec 2017 17:56:35 +0000 Subject: [PATCH 23/25] Remove a few extraneous files --- GFS_layer/GFS_physics_driver.F90.save | 2829 ----------------------- GFS_layer/GFS_physics_driver.F90.study | 2866 ------------------------ makefile.orig | 189 -- physics/calpreciptype.f90.save | 1412 ------------ 4 files changed, 7296 deletions(-) delete mode 100644 GFS_layer/GFS_physics_driver.F90.save delete mode 100644 GFS_layer/GFS_physics_driver.F90.study delete mode 100644 makefile.orig delete mode 100644 physics/calpreciptype.f90.save diff --git a/GFS_layer/GFS_physics_driver.F90.save b/GFS_layer/GFS_physics_driver.F90.save deleted file mode 100644 index e2802ab4e..000000000 --- a/GFS_layer/GFS_physics_driver.F90.save +++ /dev/null @@ -1,2829 +0,0 @@ -module module_physics_driver - - use machine, only: kind_phys - use physcons, only: con_cp, con_fvirt, con_g, con_rd, & - con_rv, con_hvap, con_hfus, & - con_rerth, con_pi, rhc_max, dxmin,& - dxinv, pa2mb, rlapse - use cs_conv, only: cs_convr - use ozne_def, only: levozp, oz_coeff, oz_pres - use h2o_def, only: levh2o, h2o_coeff, h2o_pres - use gfs_fv3_needs, only: get_prs_fv3, get_phi_fv3 - use module_nst_water_prop, only: get_dtzm_2d - use GFS_typedefs, only: GFS_statein_type, GFS_stateout_type, & - GFS_sfcprop_type, GFS_coupling_type, & - GFS_control_type, GFS_grid_type, & - GFS_tbd_type, GFS_cldprop_type, & - GFS_radtend_type, GFS_diag_type - - use zhaocarr_gscond, only: gscond_init, gscond_run - use zhaocarr_precpd, only: precpd_init, precpd_run - implicit none - - - !--- CONSTANT PARAMETERS - real(kind=kind_phys), parameter :: hocp = con_hvap/con_cp - real(kind=kind_phys), parameter :: qmin = 1.0e-10 - real(kind=kind_phys), parameter :: p850 = 85000.0 - real(kind=kind_phys), parameter :: epsq = 1.e-20 - real(kind=kind_phys), parameter :: hsub = con_hvap+con_hfus - real(kind=kind_phys), parameter :: czmin = 0.0001 ! cos(89.994) - real(kind=kind_phys), parameter :: onebg = 1.0/con_g - real(kind=kind_phys), parameter :: albdf = 0.06 - real(kind=kind_phys) tf, tcr, tcrf - parameter (tf=258.16, tcr=273.16, tcrf=1.0/(tcr-tf)) - - -!> GFS Physics Implementation Layer -!> @brief Layer that invokes individual GFS physics routines -!> @{ -!at tune step===========================================================! -! description: ! -! ! -! usage: ! -! ! -! call gbphys ! -! ! -! --- interface variables ! -! type(GFS_control_type), intent(in) :: Model ! -! type(GFS_statein_type), intent(inout) :: Statein ! -! type(GFS_stateout_type), intent(inout) :: Stateout ! -! type(GFS_sfcprop_type), intent(inout) :: Sfcprop ! -! type(GFS_coupling_type), intent(inout) :: Coupling ! -! type(GFS_grid_type), intent(in) :: Grid ! -! type(GFS_tbd_type), intent(inout :: Tbd ! -! type(GFS_cldprop_type), intent(inout) :: Cldprop ! -! type(GFS_radtend_type), intent(inout) :: Radtend ! -! type(GFS_diag_type), intent(inout) :: Diag ! -! ! -! subprograms called: ! -! ! -! get_prs, dcyc2t2_pre_rad (testing), dcyc2t3, sfc_diff, ! -! sfc_ocean,sfc_drv, sfc_land, sfc_sice, sfc_diag, moninp1, ! -! moninp, moninq1, moninq, gwdps, ozphys, get_phi, ! -! sascnv, sascnvn, rascnv, cs_convr, gwdc, shalcvt3,shalcv,! -! shalcnv, cnvc90, lrgscl, gsmdrive, gscond, precpd, ! -! progt2. ! -! ! -! ! -! program history log: ! -! 19xx - ncep mrf/gfs ! -! 2002 - s. moorthi modify and restructure and add Ferrier ! -! microphysics as an option ! -! 200x - h. juang modify (what?) ! -! nov 2004 - x. wu modify sea-ice model ! -! may 2005 - s. moorthi modify and restructure ! -! 2005 - s. lu modify to include noah lsm ! -! oct 2006 - h. wei modify lsm options to include both ! -! noah and osu lsms. ! -! 2006 - s. moorthi added a. johansson's convective gravity ! -! wave parameterization code ! -! 2007 - s. moorthi added j. han's modified pbl/sas options ! -! dec 2007 - xu li modified the operational version for ! -! nst model ! -! 2008 - s. moorthi applied xu li's nst model to new gfs ! -! mar 2008 - y.-t. hou added sunshine duration var (suntim) as ! -! an input/output argument. ! -! 2008 - jun wang added spfhmax/spfhmin as input/output. ! -! apr 2008 - y.-t. hou added lw sfc emissivity var (sfcemis), ! -! define the lw sfc dn/up fluxes in two forms: atmos! -! and ground. also changed sw sfc net flux direction! -! (positive) from ground -> atmos to the direction ! -! of atmos -> ground. recode the program and add ! -! program documentation block. -! 2008/ - s. moorthi and y.t. hou upgraded the code to more ! -! 2009 modern form and changed all the inputs to MKS units.! -! feb 2009 - s. moorthi upgraded to add Hochun's gocart changes ! -! jul 2009 - s. moorthi added rqtk for sela's semi-lagrangian ! -! aug 2009 - s. moorthi added j. han and h. pan updated shallow ! -! convection package ! -! sep 2009 - s. moorthi updated for the mcica (rrtm3) radiation ! -! dec 2010 - sarah lu lgocart added to input arg; ! -! compute dqdt_v if inline gocart is on ! -! feb 2011 - sarah lu add the option to update surface diag ! -! fields (t2m,q2m,u10m,v10m) at the end ! -! Jun 2011 - s. moorthi and Xu Li - updated the nst model ! -! ! -! sep 2011 - sarah lu correct dqdt_v calculations ! -! apr 2012 - henry juang add idea ! -! sep 2012 - s. moorthi merge with operational version ! -! Mar 2013 - Jun Wang set idea heating rate to tmp tendency ! -! May 2013 - Jun Wang tmp updated after idea phys ! -! Jun 2013 - s. moorthi corrected a bug in 3d diagnostics for T ! -! Aug 2013 - s. moorthi updating J. Whitekar's changes related ! -! to stochastic physics perturnbation ! -! Oct 2013 - Xingren Wu add dusfci/dvsfci ! -! Mar 2014 - Xingren Wu add "_cpl" for coupling ! -! Mar 2014 - Xingren Wu add "nir/vis beam and nir/vis diff" ! -! Apr 2014 - Xingren Wu add "NET LW/SW including nir/vis" ! -! Jan 2014 - Jun Wang merge Moorthi's gwdc change and H.Juang ! -! and F. Yang's energy conversion from GWD! -! jan 2014 - y-t hou revised sw sfc spectral component fluxes! -! for coupled mdl, added estimation of ocean albedo ! -! without ice contamination. ! -! Jun 2014 - Xingren Wu update net SW fluxes over the ocean ! -! (no ice contamination) ! -! Jul 2014 - Xingren Wu add Sea/Land/Ice Mask - slmsk_cpl ! -! Jul 2014 - s. moorthi merge with standalone gfs and cleanup ! -! Aug 2014 - s. moorthi add tracer fixer ! -! Sep 2014 - Sarah Lu disable the option to compute tracer ! -! scavenging in GFS phys (set fscav=0.) ! -! Dec 2014 - Jun Wang add cnvqc_v for gocart ! - -! ==================== defination of variables ==================== ! -! --- 2014 - D. Dazlich Added Chikira-Sugiyama (CS) convection ! -! as an option in opr GFS. ! -! Apr 2015 S. Moorthi Added CS scheme to NEMS/GSM ! -! Jun 2015 S. Moorthi Added SHOC to NEMS/GSM ! -! Aug 2015 - Xu Li change nst_fcst to be nstf_name ! -! and introduce depth mean SST ! -! Sep 2015 - Xingren Wu remove oro_cpl & slmsk_cpl ! -! Sep 2015 - Xingren Wu add sfc_cice ! -! Sep 2015 - Xingren Wu connect CICE output to sfc_cice ! -! Jan 2016 - P. Tripp NUOPC/GSM merge ! -! Mar 2016 - J. Han - add ncnvcld3d integer ! -! for convective cloudiness enhancement ! -! Mar 2016 - J. Han - change newsas & sashal to imfdeepcnv ! -! & imfshalcnv, respectively ! -! Mar 2016 F. Yang add pgr to rayleigh damping call ! -! Mar 2016 S. Moorthi add ral_ts ! -! Mar 2016 Ann Cheng add morrison 2m microphysics (gsfc) ! -! May 2016 S. Moorthi cleanup 2m microphysics implementation ! -! Jun 2016 X. Li change all nst_fld as inout ! -! jul 2016 S. Moorthi fix some bugs in shoc/2m microphysics ! -! au-nv2016a S. Moorthi CS with AW and connect with shoc/2m ! -! Dec 2016 Anning C. Add prognostic rain and snow with 2M ! -! -! ==================== end of description ===================== -! ==================== definition of variables ==================== ! - -!> @details This subroutine is the suite driver for the GFS atmospheric physics and surface. -!! It is responsible for calculating and applying tendencies of the atmospheric state -!! variables due to the atmospheric physics and due to the surface layer scheme. In addition, -!! this routine applies radiative heating rates that were calculated during the -!! antecedent call to the radiation scheme. Code within this subroutine is executed on the -!! physics sub-timestep. The sub-timestep loop is executed in the subroutine gloopb. -!! -!! \section general General Algorithm -!! -# Prepare input variables for calling individual parameterizations. -!! -# Using a two-iteration loop, calculate the state variable tendencies for the surface layer. -!! -# Calculate the state variable tendencies due to the PBL (vertical diffusion) scheme. -!! -# Calculate the state variable tendencies due to orographic gravity wave drag and Rayleigh damping. -!! -# Apply tendencies to the state variables calculated so far: -!! - for temperature: radiation, surface, PBL, oro. GWD, Rayleigh damping -!! - for momentum: surface, PBL, oro. GWD, Rayleigh damping -!! - for water vapor: surface, PBL -!! -# Calculate and apply the tendency of ozone. -!! -# Prepare input variables for physics routines that update the state variables within their subroutines. -!! -# If SHOC is active and is supposed to be called before convection, call it and update the state variables within. -!! -# Calculate and apply the state variable tendencies (within the subroutine) due to deep convection. -!! -# Calculate the state variable tendencies due to convective gravity wave drag and apply them afterwards. -!! -# Calculate and apply the state variable tendencies (within the subroutine) due to shallow convection. -!! -# If SHOC is active and is supposed to be called after convection, call it and update the state variables within. -!! -# Prepare for microphysics call by calculating preliminary variables. -!! -# If necessary, call the moist convective adjustment subroutine and update the state temperature and moisture variable within. -!! -# Calculate and apply the state variable tendencies (within the subroutine) due to microphysics. -!! -# Determine the precipitation type and update land surface properties if necessary. -!! -# Fill the output variables from the local variables as necessary and deallocate allocatable arrays. -!! \section detailed Detailed Algorithm -!! ## Prepare input variables for calling individual parameterizations. -!! Before calling any parameterizations, there is a section at the beginning of the subroutine for -!! preparing input arguments to the various schemes based on general input to the driver and initializing -!! variables used throughout the driver. -!! - General initialization: -!! - set a flag for running in debug mode and the horizontal index of the column to print -!! - calculate the pressure at layer centers, the exner function at layer centers and interfaces, -!! geopotential at layer centers and interfaces, and the layer-centered pressure difference -!! - calculate the ratio of dynamics time step to physics time step for applying tendencies -!! - initialize local tendency arrays to zero -!! - Radiation: -!! - adjust radiative fluxes and heating rates to the shorter physics time step (from the longer radiation time step), -!! unless idealized physics is true (lsidea) where radiative heating rates are set to 0 -!! - compute diagnostics from the radiation scheme needed for other schemes (e.g., downward longwave flux absorbed by the surface) -!! - accumulate the upward and downward longwave fluxes at the surface -!! - Surface: -!! - set NOAH and OSU scheme variables from gbphys input arguments and initialize local soil moisture variables -!! - set local sea ice variables from gbphys arguments -!! - set up A/O/I coupling variables from gbphys arguments -!! - PBL: -!! - set the number of tracers that are diffused vertically -!! - SHOC: -!! - determine the index of TKE (ntk) in the convectively transported tracer array (clw) -!! - allocate precipitation mixing ratio cloud droplet number concentration arrays -!! - Deep Convection: -!! - determine which tracers in the tracer input array undergo convective transport (valid only for the RAS and Chikira-Sugiyama schemes) and allocate a local convective transported tracer array (clw) -!! - apply an adjustment to the tracers from the dynamics -!! - calculate horizontal grid-related parameters needed for some parameterizations -!! - calculate the maxiumum cloud base updraft speed for the Chikira-Sugiyama scheme -!! - allocate array for cloud water and cloud cover (for non-RAS and non-Chikira-Sugiyama deep convective schemes) -!! - Shallow Convection: -!! - when using the Tiedtke shallow convection scheme with the stratus modifications, find the lowest -!! model level where a temperature inversion exists in the absence of CTEI -!! - Microphysics: -!! - for the Morrison (MGB) scheme, calculate 'FRLAND' if the grid point is over land -!! - allocate arrays associated with the Morrison scheme -!! - assign the local critical relative humidity variables from the gbphys arguments -!! - Gravity Wave Drag: -!! - calculate the deep convective cloud fraction at cloud top for the convective GWD scheme -!! . -!! ## Using a two-iteration loop, calculate the state variable tendencies for the surface layer. -!! - Each iteration of the loop calls the following: -!! - 'sfc_diff' to calculate surface exchange coefficients and near-surface wind -!! - surface energy balances routines are called regardless of surface type; the surface type is checked within each to determine whether the routine is "active" -!! - for the surface energy balance over the ocean, call 'sfc_nst' if NSST is on, otherwise, call 'sfc_ocean' -!! - for the surface energy balance over the land, call 'sfc_drv' for the NOAH model and 'sfc_land' for the OSU model -!! - for the surface energy balance over sea ice, call sfc_sice; if A/O/I coupling, call sfc_cice -!! - The initial iteration has flag_guess = F unless wind < 2 m/s; flag_iter = T -!! - After the initial iteration, flag_guess = F and flag_iter = F (unless wind < 2 m/s and over a land surface or an ocean surface with NSST on) -!! - The following actions are performed after the iteration to calculate surface energy balance: -!! - set surface output variables from their local values -!! - call 'sfc_diag' to calculate state variable values at 2 and 10 m as appropriate from near-surface model levels and the surface exchange coefficients -!! - if A/O/I coupling, set coupling variables from local variables and calculate the open water albedo -!! - finally, accumulate surface-related diagnostics and calculate the max/min values of T and q at 2 m height. -!! . -!! ## Calculate the state variable tendencies due to the PBL (vertical diffusion) scheme. -!! - Call the vertical diffusion scheme (PBL) based on the following logical flags: do_shoc, hybedmf, old_monin, mstrat -!! - the PBL scheme is expected to return tendencies of the state variables -!! - If A/O/I coupling and the surface is sea ice, overwrite some surface-related variables to their states before PBL was called -!! - For diagnostics, do the following: -!! - accumulate surface state variable tendencies and set the instantaneous values for output -!! - accumulate the temperature tendency due to the PBL scheme in dt3dt(:,:,3), subtracting out the radiative heating rate if necessary -!! - accumulate the u, v tendencies due to the PBL in du3dt(:,:,1:2) and dv3dt(:,:,1:2) -!! - accumulate the water vapor tendency due to the PBL in dq3dt(:,:,1) -!! - accumulate the ozone tendency in dq3dt(:,:,5) -!! . -!! ## Calculate the state variable tendencies due to orographic gravity wave drag and Rayleigh damping. -!! - Based on the variable nmtvr, unpack orographic gravity wave varibles from the hprime array -!! - Call 'gwdps' to calculate tendencies of u, v, T, and surface stress -!! - Accumulate gravity wave drag surface stresses. -!! - Accumulate change in u, v, and T due to oro. gravity wave drag in du3dt(:,:,2), dv3dt(:,:,2), and dt3dt(:,:,2) -!! - Call 'rayleigh_damp' to calculate tendencies to u, v, and T due to Rayleigh friction -!! . -!! ## Apply tendencies to the state variables calculated so far. -!! ## Calculate and apply the tendency of ozone. -!! - Call the convective adjustment scheme for IDEA -!! - Call 'ozphys_2015' or 'ozphys' depending on the value of pl_coeff, updating the ozone tracer within and outputing the tendency of ozone in dq3dt(:,:,6) -!! - Call 'h20phys' if necessary ("adaptation of NRL H20 phys for stratosphere and mesophere") -!! . -!! ## Prepare input variables for physics routines that update the state variables within their subroutines. -!! - If diagnostics is active, save the updated values of the state variables in 'dudt', 'dvdt', 'dTdt', and 'dqdt(:,:,1)' -!! - Call 'get_phi' to calculate geopotential from p, q, T -!! - Initialize the cloud water and ice portions of the convectively transported tracer array (clw) and (if the deep convective scheme is not RAS or Chikira-Sugiyama) the convective cloud water and cloud cover. -!! - If the dep convective scheme is RAS or Chikira-Sugiyama, fill the 'clw' array with tracers to be transported by convection -!! - Initialize 'ktop' and 'kbot' (to be modified by all convective schemes except Chikira-Sugiyama) -!! - Prepare for microphysics call (if cloud condensate is in the input tracer array): -!! - all schemes: calculate critical relative humidity -!! - Morrison et al. scheme (occasionally denoted MGB) (when ncld==2): set clw(:,:,1) to cloud ice and clw(:,:,2) to cloud liquid water -!! - Ferrier scheme (num_p3d==3): set the cloud water variable and separate hydrometeors into cloud ice, cloud water, and rain; set clw(:,:,1) to cloud ice and clw(:,:,2) to cloud liquid water -!! - Zhao-Carr scheme (num_p3d==4): calculate autoconversion coefficients from input constants and grid info; set set clw(:,:,1) to cloud liquid water -!! - otherwise: set autoconversion parameters like in Zhao-Carr and set critical relative humidity to 1 -!! . -!! ## If SHOC is active and is supposed to be called before convection, call it and update the state variables within. -!! - Prior to calling SHOC, prepare some microphysics variables: -!! - if Morrison et al. scheme: set 'skip_macro', fill clw(:,:,1,2) with cloud ice, liquid from the tracer array, and fill cloud droplet number concentration arrays from the input tracer array -!! - if Zhao-Carr scheme: initialize precip. mixing ratios to 0, fill clw(:,:,1,2) with cloud ice, liquid from the tracer array (as a function of temperature) -!! - Call 'shoc' (modifies state variables within the subroutine) -!! - Afterward, set updated cloud number concentrations in the tracer array from the updated 'ncpl' and 'ncpi' -!! . -!! ## Calculate and apply the state variable tendencies (within the subroutine) due to deep convection. -!! - Call deep convective scheme according to the parameter 'imfdeepcnv', 'ras', and 'cscnv'. -!! - if imfdeepcnv == 0, 1, or 2, no special processing is needed -!! - if the Chikira-Sugiyama scheme (cscnv), convert rain rate to accumulated rain (rain1) -!! - if RAS, initialize 'ccwfac', 'dlqfac', 'lmh', and revap before the call to 'rascnv' -!! - Zero out 'cld1d' (cloud work function calculated in non-RAS, non-Chikira-Sugiyama schemes) -!! - If 'lgocart', accumulate convective mass fluxes and convective cloud water -!! - Update tracers in the tracer array (gq0) due to convective transport (RAS, CS only) from the 'clw' array -!! - Calculate accumulated surface convective precip. for this physics time step (rainc) -!! - If necessary, accumulate cloud work function, convective precipitation, and convective mass fluxes; accumulate dt3dt(:,:,4), dq3dt(:,:,2), du3dt(:,:,3), dv3dt(:,:,3) as change in state variables due to deep convection -!! - If 'lgocart', repeat the accumulation of convective mass fluxes and convective cloud water; save convective tendency for water vapor in 'dqdt_v' -!! - If PDF-based clouds are active and Zhao-Carr microphysics, save convective cloud cover and water in 'phy_f3d' array -!! - otherwise, if non-PDF-based clouds and the "convective cloudiness enhancement" is active, save convective cloud water in 'phy_f3d' array -!! . -!! ## Calculate the state variable tendencies due to convective gravity wave drag and apply them afterwards. -!! - Calculate the average deep convective heating rate in the column to pass into 'gwdc' -!! - Call 'gwdc' to calculate tendencies of u, v due to convective GWD -!! - For diagnostics, accumulate the vertically-integrated change in u, v due to conv. GWD; accumulate change in u, v, due to conv. GWD in du3dt(:,:,4) and dv3dt(:,:,4) -!! - Calculate updated values of u, v, T using conv. GWD tendencies -!! . -!! ## Calculate and apply the state variable tendencies (within the subroutine) due to shallow convection. -!! - If diagnostics are active, set 'dtdt' and 'dqdt' to updated values of T and q before shallow convection -!! - If SHOC is not active, do the following: -!! - for the mass-flux shallow convection scheme (imfdeepcnv == 1), call 'shalcnv' -!! - for the scale- and aerosol-aware scheme (imfshalcnv == 2), call 'mfshalcnv' -!! - for either of the first two schemes, perform the following after the call: -!! - if Zhao-Carr microphysics with PDF-based clouds, save convective cloud water an cover in 'phy_f3d' -!! - if non-PDF-based clouds and convective cloudiness enhancement is active, save convective cloud water in 'phy_f3d' -!! - calculate shallow convective precip. and add it to convective precip; accumulate convective precip. -!! - for the Tiedtke scheme (imfshalcnv == 0), find the top level where shallow convection must stratosphere -!! - if using Moorthi's approach to stratus, call 'shalcv' -!! - otherwise, call 'shalcvt3' -!! - for diagnostics, accumulate the change in water vapor due to shallow convection and save in dqdt_v if 'lgocart'; -!! - save the change in T and q due to shallow convection in dt3dt(:,:,5) and dq3dt(:,:,3); reset dtdt and dqdt to the updated values of T, q after shallow Convection -!! - if 'clw' is not partitioned into ice/water, set 'clw(ice)' to zero -!! - If SHOC is active (and shocaftcnv) -!! - if Morrison et al. scheme: set 'skip_macro' and fill cloud droplet number concentration arrays from the input tracer array -!! - initialize precip. mixing ratios to 0 -!! - call 'shoc' (modifies state variables within the subroutine) -!! - afterward, set updated cloud number concentrations in the tracer array from the updated 'ncpl' and 'ncpi' -!! . -!! ## Prepare for microphysics call by calculating preliminary variables. -!! - For Morrison et al. microphysics, set cloud water and ice arrays to the convecitvely transported values -!! - For Ferrier microphysics, combine convectively transported cloud water and ice with column rain and save in cloud water array -!! - calculate and save ice fraction and rain fraction in phy_f3d(1),(2) -!! - For Zhao-Carr, combine convectively transported cloud water and ice into the cloud water array -!! - Otherwise, combine convectively transported cloud water and ice into the convectively transported cloud water -!! - Call 'cnvc90'; a "legacy routine which determines convective clouds"; outputs 'acv','acvb','acvt','cv','cvb','cvt' -!! . -!! ## If necessary, call the moist convective adjustment subroutine and update the state temperature and moisture variable within. -!! - Updates T, q, 'rain1', cloud water array -!! - Accumulate convective precip -!! - For diagnostics, accumulate the change in T, q due to moist convective adjustment; reset 'dtdt' and 'dqdt' to updated T, q before call to microphysics -!! . -!! ## Calculate and apply the state variable tendencies (within the subroutine) due to microphysics. -!! - If 'lgocart', calculate instantaneous moisture tendency in dqdt_v -!! - If no cloud microphysics (ncld == 0), call 'lrgscl' to update T, q and output large scale precipitation and cloud water -!! - Otherwise, a more advanced microphysics scheme is called (which scheme depends on values of 'num_p3d','do_shoc',and 'ncld') -!! - Ferrier scheme (num_p3d == 3): -!! - calculate droplet number concentration and minimum large ice fraction -!! - call 'gsmdrive' (modifies T, q, cloud water, 'f_ice', 'f_rain', 'f_rimef', 'rain1') -!! - Zhao-Carr-Sundqvist scheme (num_p3d == 4): -!! - if non-PDF-based clouds: -!! - if 'do_shoc', call 'precpd_shoc' (precpd modified for SHOC) -!! - else, call 'gscond' (grid-scale condensation/evaporation); updates water vapor, cloud water, temperature -!! - call 'precpd'; updates water vapor, cloud water, temperature and outputs precip., snow ratio, and rain water path -!! - for PDF-based clouds: -!! - call 'gscondp' followed by 'precpdp' (similar arguments to gscond, precpd above) -!! - Morrison et al. scheme (ncld = 2): -!! - if 'do_shoc', set clw(1),(2) from updated values; set phy_f3d(:,:,1) from phy_f3d(:,:,ntot3d-2) -!! - else, set clw(1),(2) from updated values; set phy_f3d(:,:,1) to cloud cover from previous time step + convective cloud water from convective scheme -!! - call 'm_micro_driver'; updates water vapor, temperature, droplet number concentrations, cloud cover -!! - Combine large scale and convective precip. -!! - For diagnostics, accumulate total surface precipitation and accumulate change in T and q due to microphysics in dt3dt(:,:,6) and dq3dt(:,:,4) -!! . -!! ## Determine the precipitation type and update land surface properties if necessary. -!! - If 'cal_pre', diagnose the surface precipitation type -!! - call 'calpreciptype'; set snow flag to 1 if snow or sleet, 0 otherwise -!! - For rain/snow decision, calculate temperature at 850 hPa (\f$T_{850}\f$) -!! - If not 'cal_pre', set snow flag to 1 if \f$T_{850}\f$ is below freezing -!! - For coupling, accumulate rain if \f$T_{850}\f$ is above freezing, otherwise accumulate snow -!! - If using the OSU land model, accumulate surface snow depth if \f$T_{850}\f$ is below freezing and not over an ocean surface -!! - call 'progt2' (canopy and soil moisture?) and set the soil liquid water equal to soil total water -!! - if 'lgocart', call 'sfc_diag' to update near-surface state variables (this "allows gocart to use filtered wind fields") -!! - If necessary (lssav), update the 2m max/min values of T and q -!! - If necessary (lssav), accumulate total runoff and surface runoff. -!! . -!! ## Fill the output variables from the local variables as necessary and deallocate allocatable arrays. -!! - Set global sea ice thickness and concentration as well as the temperature of the sea ice -!! - Set global soil moisture variables -!! - Calculate precipitable water and water vapor mass change due to all physics for the column -!! - Deallocate arrays for SHOC scheme, deep convective scheme, and Morrison et al. microphysics - - - public GFS_physics_driver - - CONTAINS -!******************************************************************************************* - - subroutine GFS_physics_driver & - (Model, Statein, Stateout, Sfcprop, Coupling, & - Grid, Tbd, Cldprop, Radtend, Diag) - - implicit none -! -! --- interface variables - type(GFS_control_type), intent(in) :: Model - type(GFS_statein_type), intent(inout) :: Statein - type(GFS_stateout_type), intent(inout) :: Stateout - type(GFS_sfcprop_type), intent(inout) :: Sfcprop - type(GFS_coupling_type), intent(inout) :: Coupling - type(GFS_grid_type), intent(in) :: Grid - type(GFS_tbd_type), intent(inout) :: Tbd - type(GFS_cldprop_type), intent(inout) :: Cldprop - type(GFS_radtend_type), intent(inout) :: Radtend - type(GFS_diag_type), intent(inout) :: Diag -! -! --- local variables - - !--- INTEGER VARIABLES - integer :: me, lprint, ipr, ix, im, levs, ntrac, nvdiff, kdt - integer :: i, kk, ic, k, n, k1, iter, levshcm, tracers, & - trc_shft, tottracer, num2, num3, nshocm, nshoc, ntk - - integer, dimension(size(Grid%xlon,1)) :: & - kbot, ktop, kcnv, soiltyp, vegtype, kpbl, slopetyp, kinver, & - lmh, levshc, islmsk, & - !--- coupling inputs for physics - islmsk_cice - - !--- LOGICAL VARIABLES - logical :: lprnt, revap, do_awdd - - logical, dimension(size(Grid%xlon,1)) :: & - flag_iter, flag_guess, invrsn, skip_macro, & - !--- coupling inputs for physics - flag_cice - - logical, dimension(Model%ntrac-Model%ncld+2,2) :: & - otspt - - !--- REAL VARIABLES - real(kind=kind_phys) :: & - dtf, dtp, rhbbot, rhbtop, rhpbl, frain, tem, tem1, tem2, & - xcosz_loc, zsea1, zsea2, eng0, eng1, dpshc, & - !--- experimental for shoc sub-stepping - dtshoc - - real(kind=kind_phys), dimension(size(Grid%xlon,1)) :: & - ccwfac, garea, dlength, cumabs, cice, zice, tice, gflx, & - rain1, raincs, snowmt, cd, cdq, qss, dusfcg, dvsfcg, dusfc1, & - dvsfc1, dtsfc1, dqsfc1, rb, drain, cld1d, evap, hflx, & - stress, t850, ep1d, gamt, gamq, sigmaf, oc, theta, gamma, & - sigma, elvmax, wind, work1, work2, runof, xmu, fm10, fh2, & - tsurf, tx1, tx2, ctei_r, evbs, evcw, trans, sbsno, snowc, & - frland, adjsfcdsw, adjsfcnsw, adjsfcdlw, adjsfculw, & - adjnirbmu, adjnirdfu, adjvisbmu, adjvisdfu, adjnirbmd, & - adjnirdfd, adjvisbmd, adjvisdfd, gabsbdlw, xcosz, tseal, & - snohf, dlqfac, work3, ctei_rml, cldf, domr, domzr, domip, & - doms, psautco_l, prautco_l, ocalnirbm_cpl, ocalnirdf_cpl, & - ocalvisbm_cpl, ocalvisdf_cpl, dtzm, temrain1, fscav, fswtr, & - !--- coupling inputs for physics - dtsfc_cice, dqsfc_cice, dusfc_cice, dvsfc_cice, ulwsfc_cice, & - tisfc_cice, tsea_cice, hice_cice, fice_cice, & - !--- for CS-convection - wcbmax - - real(kind=kind_phys), dimension(size(Grid%xlon,1),4) :: & - oa4, clx - - real(kind=kind_phys), dimension(size(Grid%xlon,1),Model%lsoil) :: & - smsoil, stsoil, slsoil - - real(kind=kind_phys), dimension(size(Grid%xlon,1),Model%levs) :: & - del, rhc, dtdt, dudt, dvdt, gwdcu, gwdcv, dtdtc, rainp, & - ud_mf, dd_mf, dt_mf, prnum, dkt, sigmatot, sigmafrac - - !--- GFDL modification for FV3 - real(kind=kind_phys), dimension(size(Grid%xlon,1),Model%levs+1) ::& - del_gz - - real(kind=kind_phys), dimension(size(Grid%xlon,1),Model%levs,Model%ntrac) :: & - dqdt - - real(kind=kind_phys), dimension(size(Grid%xlon,1),Model%levs,Model%nctp) :: & - sigmai, vverti - - real(kind=kind_phys), dimension(size(Grid%xlon,1),Model%levs,oz_coeff+5) :: & - dq3dt_loc - - !--- ALLOCATABLE ELEMENTS - !--- in clw, the first two varaibles are cloud water and ice. - !--- from third to ntrac are convective transportable tracers, - !--- third being the ozone, when ntrac=3 (valid only with ras) - !--- Anning Cheng 9/21/2016 leave a hook here for diagnosed snow, - !--- rain, and their number - real(kind=kind_phys), allocatable :: & - clw(:,:,:), qpl(:,:), qpi(:,:), ncpl(:,:), ncpi(:,:), & - qrn(:,:), qsnw(:,:), ncpr(:,:), ncps(:,:), cnvc(:,:), & - cnvw(:,:) - !--- for 2 M microphysics - real(kind=kind_phys), allocatable, dimension(:) :: & - cn_prc, cn_snr - real(kind=kind_phys), allocatable, dimension(:,:) :: & - qlcn, qicn, w_upi, cf_upi, CNV_MFD, CNV_PRC3, CNV_DQLDT, & - CLCN, CNV_FICE, CNV_NDROP, CNV_NICE - -! -! -!===> ... begin here - - me = Model%me - ix = size(Grid%xlon,1) - im = size(Grid%xlon,1) - levs = Model%levs - ntrac = Model%ntrac - dtf = Model%dtf - dtp = Model%dtp - kdt = Model%kdt - lprnt = Model%lprnt - nvdiff = ntrac ! vertical diffusion of all tracers! - ipr = min(im,10) - - do i = 1, im - if(nint(Sfcprop%slmsk(i)) == 1) then - frland(i) = 1.0 - else - frland(i) = 0. - endif - enddo -! -! --- ... figure out number of extra tracers -! - tottracer = 0 ! no convective transport of tracers - if (Model%trans_trac .or. Model%cscnv) then - if (Model%ntcw > 0) then - if (Model%ntoz < Model%ntcw) then - trc_shft = Model%ntcw + Model%ncld - 1 - else - trc_shft = Model%ntoz - endif - elseif (Model%ntoz > 0) then - trc_shft = Model%ntoz - else - trc_shft = 1 - endif - - tracers = Model%ntrac - trc_shft - tottracer = tracers - if (Model%ntoz > 0) tottracer = tottracer + 1 ! ozone is added separately - endif - if (Model%ntke > 0) ntk = Model%ntke - trc_shft + 3 - -! if (lprnt) write(0,*)' trans_trac=',trans_trac,' tottracer=', & -! write(0,*)' trans_trac=',trans_trac,' tottracer=', & -! & tottracer,' trc_shft=',trc_shft,' kdt=',kdt -! &, ntrac-ncld+2,' clstp=',clstp,' kdt=',kdt -! &,' ntk=',ntk,' lat=',lat - - skip_macro = .false. - - allocate ( clw(ix,levs,tottracer+2) ) - if (Model%imfdeepcnv >= 0 .or. Model%imfshalcnv > 0) then - allocate (cnvc(ix,levs), cnvw(ix,levs)) - endif -! -! --- set initial quantities for stochastic physics deltas - if (Model%do_sppt) then - Tbd%dtdtr = 0.0 - Tbd%dtotprcp (:) = Diag%rain (:) - Tbd%dcnvprcp (:) = Diag%rainc (:) - Tbd%drain_cpl (:) = Coupling%rain_cpl (:) - Tbd%dsnow_cpl (:) = Coupling%snow_cpl (:) - endif - - if (Model%do_shoc) then - allocate (qpl(im,levs), qpi(im,levs), ncpl(im,levs), ncpi(im,levs)) - do k=1,levs - do i=1,im - ncpl(i,k) = 0.0 - ncpi(i,k) = 0.0 - enddo - enddo - endif - - if (Model%ncld == 2) then ! For MGB double moment microphysics - allocate (qlcn(im,levs), qicn(im,levs), w_upi(im,levs), & - cf_upi(im,levs), CNV_MFD(im,levs), CNV_PRC3(im,levs), & - CNV_DQLDT(im,levs), clcn(im,levs), cnv_fice(im,levs), & - cnv_ndrop(im,levs), cnv_nice(im,levs)) - allocate (cn_prc(im), cn_snr(im)) - allocate (qrn(im,levs), qsnw(im,levs), ncpr(im,levs), ncps(im,levs)) - else - allocate (qlcn(1,1), qicn(1,1), w_upi(1,1), cf_upi(1,1), & - CNV_MFD(1,1), CNV_PRC3(1,1), CNV_DQLDT(1,1), & - clcn(1,1), cnv_fice(1,1), cnv_ndrop(1,1), cnv_nice(1,1)) - endif - - -#ifdef GFS_HYDRO - call get_prs(im, ix, levs, ntrac, Statein%tgrs, Statein%qgrs, & - Model%thermodyn_id, Model%sfcpress_id, & - Model%gen_coord_hybrid, Statein%prsi, Statein%prsik, & - Statein%prsl, Statein%prslk, Statein%phii, Statein%phil, del) -#else -!GFDL Adjust the geopotential height hydrostatically in a way consistent with FV3 discretization - call get_prs_fv3 (ix, levs, ntrac, Statein%phii, Statein%prsi, & - Statein%tgrs, Statein%qgrs, del, del_gz) -#endif -! - rhbbot = Model%crtrh(1) - rhpbl = Model%crtrh(2) - rhbtop = Model%crtrh(3) -! -! --- ... frain=factor for centered difference scheme correction of rain amount. - - frain = dtf / dtp - - do i = 1, im - sigmaf(i) = max( Sfcprop%vfrac(i),0.01 ) - islmsk(i) = nint(Sfcprop%slmsk(i)) - - if (islmsk(i) == 2) then - if (Model%isot == 1) then - soiltyp(i) = 16 - else - soiltyp(i) = 9 - endif - if (Model%ivegsrc == 1) then - vegtype(i) = 15 - elseif(Model%ivegsrc == 2) then - vegtype(i) = 13 - endif - slopetyp(i) = 9 - else - soiltyp(i) = int( Sfcprop%stype(i)+0.5 ) - vegtype(i) = int( Sfcprop%vtype(i)+0.5 ) - slopetyp(i) = int( Sfcprop%slope(i)+0.5 ) !! clu: slope -> slopetyp - endif -! --- ... xw: transfer ice thickness & concentration from global to local variables - zice(i) = Sfcprop%hice(i) - cice(i) = Sfcprop%fice(i) - tice(i) = Sfcprop%tisfc(i) -! -!GFDL work1(i) = (log(coslat(i) / (nlons(i)*latr)) - dxmin) * dxinv -! work1(i) = (log(Grid%dx(i)) - dxmin) * dxinv - work1(i) = (log(Grid%area(i)) - dxmin) * dxinv - work1(i) = max(0.0, min(1.0,work1(i))) - work2(i) = 1.0 - work1(i) - Diag%psurf(i) = Statein%pgr(i) - work3(i) = Statein%prsik(i,1) / Statein%prslk(i,1) -!GFDL tem1 = con_rerth * (con_pi+con_pi)*coslat(i)/nlons(i) -!GFDL tem2 = con_rerth * con_pi / latr -!GFDL garea(i) = tem1 * tem2 - tem1 = Grid%dx(i) - tem2 = Grid%dx(i) - garea(i) = Grid%area(i) - dlength(i) = sqrt( tem1*tem1+tem2*tem2 ) - cldf(i) = Model%cgwf(1)*work1(i) + Model%cgwf(2)*work2(i) - wcbmax(i) = Model%cs_parm(1)*work1(i) + Model%cs_parm(2)*work2(i) - enddo -! - if (Model%cplflx) then - do i = 1, im - islmsk_cice(i) = nint(Coupling%slimskin_cpl(i)) - flag_cice(i) = (islmsk_cice(i) == 4) - - ulwsfc_cice(i) = Coupling%ulwsfcin_cpl(i) - dusfc_cice(i) = Coupling%dusfcin_cpl(i) - dvsfc_cice(i) = Coupling%dvsfcin_cpl(i) - dtsfc_cice(i) = Coupling%dtsfcin_cpl(i) - dqsfc_cice(i) = Coupling%dqsfcin_cpl(i) - tisfc_cice(i) = Sfcprop%tisfc(i) - tsea_cice(i) = Sfcprop%tsfc(i) - fice_cice(i) = Sfcprop%fice(i) - hice_cice(i) = Sfcprop%hice(i) - enddo - endif - -! --- ... transfer soil moisture and temperature from global to local variables - smsoil(:,:) = Sfcprop%smc(:,:) - stsoil(:,:) = Sfcprop%stc(:,:) - slsoil(:,:) = Sfcprop%slc(:,:) !! clu: slc -> slsoil - dudt(:,:) = 0. - dvdt(:,:) = 0. - dtdt(:,:) = 0. - dtdtc(:,:) = 0. - dqdt(:,:,:) = 0. - -! --- ... initialize dtdt with heating rate from dcyc2 - -! --- ... adjust mean radiation fluxes and heating rates to fit for -! faster model time steps. -! sw: using cos of zenith angle as scaling factor -! lw: using surface air skin temperature as scaling factor - - if (Model%pre_rad) then - call dcyc2t3_pre_rad & -! --- inputs: - ( Model%solhr, Model%slag, Model%sdec, Model%cdec, Grid%sinlat, & - Grid%coslat, Grid%xlon, Radtend%coszen, Sfcprop%tsfc, & - Statein%tgrs(1,1), Statein%tgrs(1,1), Coupling%sfcdsw, & - Coupling%sfcnsw, Coupling%sfcdlw, Radtend%htrsw, Radtend%htrlw,& - Coupling%nirbmui, Coupling%nirdfui, Coupling%visbmui, & - Coupling%visdfui, Coupling%nirbmdi, Coupling%nirdfdi, & - Coupling%visbmdi, Coupling%visdfdi, ix, im, levs, & -! --- input/output: - dtdt, & -! --- outputs: - adjsfcdsw, adjsfcnsw, adjsfcdlw, adjsfculw, xmu, xcosz, & - adjnirbmu, adjnirdfu, adjvisbmu, adjvisdfu, & - adjnirbmd, adjnirdfd, adjvisbmd, adjvisdfd & - ) - - else - - call dcyc2t3 & -! --- inputs: - ( Model%solhr, Model%slag, Model%sdec, Model%cdec, Grid%sinlat, & - Grid%coslat, Grid%xlon, Radtend%coszen, Sfcprop%tsfc, & - Statein%tgrs(1,1), Radtend%tsflw, Radtend%semis, & - Coupling%sfcdsw, Coupling%sfcnsw, Coupling%sfcdlw, & - Radtend%htrsw, Radtend%swhc, Radtend%htrlw, Radtend%lwhc, & - Coupling%nirbmui, Coupling%nirdfui, Coupling%visbmui, & - Coupling%visdfui, Coupling%nirbmdi, Coupling%nirdfdi, & - Coupling%visbmdi, Coupling%visdfdi, ix, im, levs, & -! --- input/output: - dtdt, dtdtc, & -! --- outputs: - adjsfcdsw, adjsfcnsw, adjsfcdlw, adjsfculw, xmu, xcosz, & - adjnirbmu, adjnirdfu, adjvisbmu, adjvisdfu, & - adjnirbmd, adjnirdfd, adjvisbmd, adjvisdfd & - ) - -! -! save temp change due to radiation - need for sttp stochastic physics -!--------------------------------------------------------------------- - endif -! - if (Model%lsidea) then !idea jw - dtdt(:,:) = 0. - endif - -! --- convert lw fluxes for land/ocean/sea-ice models -! note: for sw: adjsfcdsw and adjsfcnsw are zenith angle adjusted downward/net fluxes. -! for lw: adjsfcdlw is (sfc temp adjusted) downward fluxe with no emiss effect. -! adjsfculw is (sfc temp adjusted) upward fluxe including emiss effect. -! one needs to be aware that that the absorbed downward lw flux (used by land/ocean -! models as downward flux) is not the same as adjsfcdlw but a value reduced by -! the factor of emissivity. however, the net effects are the same when seeing -! it either above the surface interface or below. -! -! - flux above the interface used by atmosphere model: -! down: adjsfcdlw; up: adjsfculw = sfcemis*sigma*T**4 + (1-sfcemis)*adjsfcdlw -! net = up - down = sfcemis * (sigma*T**4 - adjsfcdlw) -! - flux below the interface used by lnd/oc/ice models: -! down: sfcemis*adjsfcdlw; up: sfcemis*sigma*T**4 -! net = up - down = sfcemis * (sigma*T**4 - adjsfcdlw) - -! --- ... define the downward lw flux absorbed by ground - - gabsbdlw(:) = Radtend%semis(:) * adjsfcdlw(:) - - if (Model%lssav) then ! --- ... accumulate/save output variables - -! --- ... sunshine duration time is defined as the length of time (in mdl output -! interval) that solar radiation falling on a plane perpendicular to the -! direction of the sun >= 120 w/m2 - - do i = 1, im - if ( xcosz(i) >= czmin ) then ! zenth angle > 89.994 deg - tem1 = adjsfcdsw(i) / xcosz(i) - if ( tem1 >= 120.0 ) then - Diag%suntim(i) = Diag%suntim(i) + dtf - endif - endif - enddo - -! --- ... sfc lw fluxes used by atmospheric model are saved for output - - if (Model%cplflx) then - do i = 1, im - if (flag_cice(i)) adjsfculw(i) = ulwsfc_cice(i) - enddo - endif - Diag%dlwsfc(:) = Diag%dlwsfc(:) + adjsfcdlw(:)*dtf - Diag%ulwsfc(:) = Diag%ulwsfc(:) + adjsfculw(:)*dtf - Diag%psmean(:) = Diag%psmean(:) + Statein%pgr(:)*dtf ! mean surface pressure - - if (Model%ldiag3d) then - if (Model%lsidea) then - Diag%dt3dt(:,:,1) = Diag%dt3dt(:,:,1) + Radtend%lwhd(:,:,1)*dtf - Diag%dt3dt(:,:,2) = Diag%dt3dt(:,:,2) + Radtend%lwhd(:,:,2)*dtf - Diag%dt3dt(:,:,3) = Diag%dt3dt(:,:,3) + Radtend%lwhd(:,:,3)*dtf - Diag%dt3dt(:,:,4) = Diag%dt3dt(:,:,4) + Radtend%lwhd(:,:,4)*dtf - Diag%dt3dt(:,:,5) = Diag%dt3dt(:,:,5) + Radtend%lwhd(:,:,5)*dtf - Diag%dt3dt(:,:,6) = Diag%dt3dt(:,:,6) + Radtend%lwhd(:,:,6)*dtf - else - do k = 1, levs - Diag%dt3dt(:,k,1) = Diag%dt3dt(:,k,1) + Radtend%htrlw(:,k)*dtf - Diag%dt3dt(:,k,2) = Diag%dt3dt(:,k,2) + Radtend%htrsw(:,k)*dtf*xmu(:) - enddo - endif - endif - endif ! end if_lssav_block - - kcnv(:) = 0 - kinver(:) = levs - invrsn(:) = .false. - tx1(:) = 0.0 - tx2(:) = 10.0 - ctei_r(:) = 10.0 - -! Only used for old shallow convection with mstrat=.true. - - if (((Model%imfshalcnv == 0 .and. Model%shal_cnv) .or. Model%old_monin) & - .and. Model%mstrat) then - ctei_rml(:) = Model%ctei_rm(1)*work1(:) + Model%ctei_rm(2)*work2(:) - do k = 1, levs/2 - do i = 1, im - if (Statein%prsi(i,1)-Statein%prsi(i,k+1) < 0.35*Statein%prsi(i,1) & - .and. (.not. invrsn(i))) then - tem = (Statein%tgrs(i,k+1)-Statein%tgrs(i,k)) / (Statein%prsl(i,k)-Statein%prsl(i,k+1)) - - if (((tem > 0.00010) .and. (tx1(i) < 0.0)) .or. & - ((tem-abs(tx1(i)) > 0.0) .and. (tx2(i) < 0.0))) then - invrsn(i) = .true. - - if (Statein%qgrs(i,k,1) > Statein%qgrs(i,k+1,1)) then - tem1 = Statein%tgrs(i,k+1) + hocp*max(Statein%qgrs(i,k+1,1),qmin) - tem2 = Statein%tgrs(i,k) + hocp*max(Statein%qgrs(i,k,1),qmin) - - tem1 = tem1 / Statein%prslk(i,k+1) - tem2 / Statein%prslk(i,k) - -! --- ... (cp/l)(deltathetae)/(deltatwater) > ctei_rm -> conditon for CTEI - ctei_r(i) = (1.0/hocp)*tem1/(Statein%qgrs(i,k+1,1)-Statein%qgrs(i,k,1) & - + Statein%qgrs(i,k+1,Model%ntcw)-Statein%qgrs(i,k,Model%ntcw)) - else - ctei_r(i) = 10 - endif - - if ( ctei_rml(i) > ctei_r(i) ) then - kinver(i) = k - else - kinver(i) = levs - endif - endif - - tx2(i) = tx1(i) - tx1(i) = tem - endif - enddo - enddo - endif - -! --- ... lu: initialize flag_guess, flag_iter, tsurf - - tsurf(:) = Sfcprop%tsfc(:) - flag_guess(:) = .false. - flag_iter(:) = .true. - drain(:) = 0.0 - ep1d(:) = 0.0 - runof(:) = 0.0 - hflx(:) = 0.0 - evap(:) = 0.0 - evbs(:) = 0.0 - evcw(:) = 0.0 - trans(:) = 0.0 - sbsno(:) = 0.0 - snowc(:) = 0.0 - snohf(:) = 0.0 - Diag%zlvl(:) = Statein%phil(:,1) * onebg - Diag%smcwlt2(:) = 0.0 - Diag%smcref2(:) = 0.0 - -! --- ... lu: iter-loop over (sfc_diff,sfc_drv,sfc_ocean,sfc_sice) - - do iter = 1, 2 - -! --- ... surface exchange coefficients -! -! if (lprnt) write(0,*)' tsea=',tsea(ipr),' tsurf=',tsurf(ipr),iter - - call sfc_diff (im,Statein%pgr, Statein%ugrs, Statein%vgrs, & - Statein%tgrs, Statein%qgrs, Diag%zlvl, & - Sfcprop%snowd, Sfcprop%tsfc, Sfcprop%zorl, cd, & - cdq, rb, Statein%prsl(1,1), work3, islmsk, stress, & - Sfcprop%ffmm, Sfcprop%ffhh, Sfcprop%uustar, & - wind, Tbd%phy_f2d(1,Model%num_p2d), fm10, fh2, & - sigmaf, vegtype, Sfcprop%shdmax, Model%ivegsrc, & - tsurf, flag_iter, Model%redrag) - -! --- ... lu: update flag_guess - - do i = 1, im - if (iter == 1 .and. wind(i) < 2.0) then - flag_guess(i) = .true. - endif - enddo - - if (Model%nstf_name(1) > 0) then - - do i = 1, im - if ( islmsk(i) == 0 ) then - tem = (Sfcprop%oro(i)-Sfcprop%oro_uf(i)) * rlapse - tseal(i) = Sfcprop%tsfc(i) + tem - tsurf(i) = tsurf(i) + tem - endif - enddo - - call sfc_nst (im, Model%lsoil, Statein%pgr, Statein%ugrs, & - Statein%vgrs, Statein%tgrs, Statein%qgrs, & - Sfcprop%tref, cd, cdq, Statein%prsl(1,1), work3, & - islmsk, Grid%xlon, Grid%sinlat, stress, & - Radtend%semis, gabsbdlw, adjsfcnsw, Sfcprop%tprcp, & - dtf, kdt, Model%solhr, xcosz, & - Tbd%phy_f2d(1,Model%num_p2d), flag_iter, & - flag_guess, Model%nstf_name, lprnt, ipr, & -! --- Input/output - tseal, tsurf, Sfcprop%xt, Sfcprop%xs, Sfcprop%xu, & - Sfcprop%xv, Sfcprop%xz, Sfcprop%zm, Sfcprop%xtts, & - Sfcprop%xzts, Sfcprop%dt_cool, Sfcprop%z_c, & - Sfcprop%c_0, Sfcprop%c_d, Sfcprop%w_0, Sfcprop%w_d,& - Sfcprop%d_conv, Sfcprop%ifd, Sfcprop%qrain, & -! --- outputs: - qss, gflx, Diag%cmm, Diag%chh, evap, hflx, ep1d) - -! if (lprnt) print *,' tseaz2=',tseal(ipr),' tref=',tref(ipr), -! & ' dt_cool=',dt_cool(ipr),' dt_warm=',2.0*xt(ipr)/xz(ipr), -! & ' kdt=',kdt - - do i = 1, im - if ( islmsk(i) == 0 ) then - tsurf(i) = tsurf(i) - (Sfcprop%oro(i)-Sfcprop%oro_uf(i)) * rlapse - endif - enddo - -! --- ... run nsst model ... --- - - if (Model%nstf_name(1) > 1) then - zsea1 = 0.001*real(Model%nstf_name(4)) - zsea2 = 0.001*real(Model%nstf_name(5)) - call get_dtzm_2d (Sfcprop%xt, Sfcprop%xz, Sfcprop%dt_cool, & - Sfcprop%z_c, Sfcprop%slmsk, zsea1, zsea2, & - im, 1, dtzm) - do i = 1, im - if ( islmsk(i) == 0 ) then - Sfcprop%tsfc(i) = max(271.2,Sfcprop%tref(i) + dtzm(i)) - & - (Sfcprop%oro(i)-Sfcprop%oro_uf(i))*rlapse - endif - enddo - endif - -! if (lprnt) print *,' tseaz2=',tsea(ipr),' tref=',tref(ipr), & -! & ' dt_cool=',dt_cool(ipr),' dt_warm=',dt_warm(ipr),' kdt=',kdt - - else - -! --- ... surface energy balance over ocean - - call sfc_ocean & -! --- inputs: - (im, Statein%pgr, Statein%ugrs, Statein%vgrs, Statein%tgrs, & - Statein%qgrs, Sfcprop%tsfc, cd, cdq, Statein%prsl(1,1), & - work3, islmsk, Tbd%phy_f2d(1,Model%num_p2d), flag_iter, & -! --- outputs: - qss, Diag%cmm, Diag%chh, gflx, evap, hflx, ep1d) - - endif ! if ( nstf_name(1) > 0 ) then - -! if (lprnt) write(0,*)' sfalb=',sfalb(ipr),' ipr=',ipr & -! &, ' weasd=',weasd(ipr),' snwdph=',snwdph(ipr) & -! &, ' tprcp=',tprcp(ipr),' kdt=',kdt,' iter=',iter & -! &,' tseabefland=',tsea(ipr) - -! --- ... surface energy balance over land -! - if (Model%lsm == 1) then ! noah lsm call - -! if (lprnt) write(0,*)' tsead=',tsea(ipr),' tsurf=',tsurf(ipr),iter -! &,' pgr=',pgr(ipr),' sfcemis=',sfcemis(ipr) - - call sfc_drv & -! --- inputs: - (im, Model%lsoil, Statein%pgr, Statein%ugrs, Statein%vgrs, & - Statein%tgrs, Statein%qgrs, soiltyp, vegtype, sigmaf, & - Radtend%semis, gabsbdlw, adjsfcdsw, adjsfcnsw, dtf, & - Sfcprop%tg3, cd, cdq, Statein%prsl(1,1), work3, DIag%zlvl, & - islmsk, Tbd%phy_f2d(1,Model%num_p2d), slopetyp, & - Sfcprop%shdmin, Sfcprop%shdmax, Sfcprop%snoalb, & - Radtend%sfalb, flag_iter, flag_guess, Model%isot, & - Model%ivegsrc, & -! --- in/outs: - Sfcprop%weasd, Sfcprop%snowd, Sfcprop%tsfc, Sfcprop%tprcp, & - Sfcprop%srflag, smsoil, stsoil, slsoil, Sfcprop%canopy, & - trans, tsurf, Sfcprop%zorl, & -! --- outputs: - Sfcprop%sncovr, qss, gflx, drain, evap, hflx, ep1d, runof, & - Diag%cmm, Diag%chh, evbs, evcw, sbsno, snowc, Diag%soilm, & - snohf, Diag%smcwlt2, Diag%smcref2, Diag%wet1) - -! if (lprnt) write(0,*)' tseae=',tsea(ipr),' tsurf=',tsurf(ipr),iter -! &,' phy_f2d=',phy_f2d(ipr,num_p2d) - - endif - -! if (lprnt) write(0,*)' tseabeficemodel =',tsea(ipr),' me=',me & -! &, ' kdt=',kdt - -! --- ... surface energy balance over seaice - - if (Model%cplflx) then - do i = 1, im - if (flag_cice(i)) then - islmsk (i) = islmsk_cice(i) - endif - enddo - endif - - call sfc_sice & -! --- inputs: - (im, Model%lsoil, Statein%pgr, Statein%ugrs, Statein%vgrs, & - Statein%tgrs, Statein%qgrs, dtf, Radtend%semis, gabsbdlw, & - adjsfcnsw, adjsfcdsw, Sfcprop%srflag, cd, cdq, & - Statein%prsl(1,1), work3, islmsk, & - Tbd%phy_f2d(1,Model%num_p2d), flag_iter, Model%mom4ice, & - Model%lsm, lprnt, ipr, & -! --- input/outputs: - zice, cice, tice, Sfcprop%weasd, Sfcprop%tsfc, & - Sfcprop%tprcp, stsoil, ep1d, & -! --- outputs: - Sfcprop%snowd, qss, snowmt, gflx, Diag%cmm, Diag%chh, evap, & - hflx) - - if (Model%cplflx) then - do i = 1, im - if (flag_cice(i)) then - islmsk(i) = nint(Sfcprop%slmsk(i)) - endif - enddo - - call sfc_cice & -! --- inputs: - (im, Statein%ugrs, Statein%vgrs, Statein%tgrs, Statein%qgrs, & - cd, cdq, Statein%prsl(1,1), work3, islmsk_cice, & - Tbd%phy_f2d(1,Model%num_p2d),flag_iter, dqsfc_cice, & - dtsfc_cice, & -! --- outputs: - qss, Diag%cmm, Diag%chh, evap, hflx) - endif - -! --- ... lu: update flag_iter and flag_guess - - do i = 1, im - flag_iter(i) = .false. - flag_guess(i) = .false. - - if (iter == 1 .and. wind(i) < 2.0) then - if ((islmsk(i) == 1) .or. ((islmsk(i) == 0) .and. & - (Model%nstf_name(1) > 0))) then - flag_iter(i) = .true. - endif - endif - -! if(islmsk(i) == 1 .and. iter == 1) then -! if (wind(i) < 2.0) flag_iter(i) = .true. -! elseif (islmsk(i) == 0 .and. iter == 1 & -! & .and. nstf_name(1) > 0) then -! if (wind(i) < 2.0) flag_iter(i) = .true. -! endif - enddo - - enddo ! end iter_loop - - Diag%epi(:) = ep1d(:) - Diag%dlwsfci(:) = adjsfcdlw(:) - Diag%ulwsfci(:) = adjsfculw(:) - Diag%uswsfci(:) = adjsfcdsw(:) - adjsfcnsw(:) - Diag%dswsfci(:) = adjsfcdsw(:) - Diag%gfluxi(:) = gflx(:) - Diag%t1(:) = Statein%tgrs(:,1) - Diag%q1(:) = Statein%qgrs(:,1,1) - Diag%u1(:) = Statein%ugrs(:,1) - Diag%v1(:) = Statein%vgrs(:,1) - -! --- ... update near surface fields - - call sfc_diag (im, Statein%pgr, Statein%ugrs, Statein%vgrs, & - Statein%tgrs, Statein%qgrs, Sfcprop%tsfc, qss, & - Sfcprop%f10m, Diag%u10m, Diag%v10m, & - Sfcprop%t2m, Sfcprop%q2m, work3, evap, & - Sfcprop%ffmm, Sfcprop%ffhh, fm10, fh2) - - Tbd%phy_f2d(:,Model%num_p2d) = 0.0 - - if (Model%cplflx) then - Coupling%dlwsfci_cpl (:) = adjsfcdlw(:) - Coupling%dswsfci_cpl (:) = adjsfcdsw(:) - Coupling%dlwsfc_cpl (:) = Coupling%dlwsfc_cpl(:) + adjsfcdlw(:)*dtf - Coupling%dswsfc_cpl (:) = Coupling%dswsfc_cpl(:) + adjsfcdsw(:)*dtf - Coupling%dnirbmi_cpl (:) = adjnirbmd(:) - Coupling%dnirdfi_cpl (:) = adjnirdfd(:) - Coupling%dvisbmi_cpl (:) = adjvisbmd(:) - Coupling%dvisdfi_cpl (:) = adjvisdfd(:) - Coupling%dnirbm_cpl (:) = Coupling%dnirbm_cpl(:) + adjnirbmd(:)*dtf - Coupling%dnirdf_cpl (:) = Coupling%dnirdf_cpl(:) + adjnirdfd(:)*dtf - Coupling%dvisbm_cpl (:) = Coupling%dvisbm_cpl(:) + adjvisbmd(:)*dtf - Coupling%dvisdf_cpl (:) = Coupling%dvisdf_cpl(:) + adjvisdfd(:)*dtf - Coupling%nlwsfci_cpl (:) = adjsfcdlw(:) - adjsfculw(:) - Coupling%nlwsfc_cpl (:) = Coupling%nlwsfc_cpl(:) + Coupling%nlwsfci_cpl(:)*dtf - Coupling%t2mi_cpl (:) = Sfcprop%t2m(:) - Coupling%q2mi_cpl (:) = Sfcprop%q2m(:) - Coupling%u10mi_cpl (:) = Diag%u10m(:) - Coupling%v10mi_cpl (:) = Diag%v10m(:) - Coupling%tsfci_cpl (:) = Sfcprop%tsfc(:) - Coupling%psurfi_cpl (:) = Statein%pgr(:) - -! --- estimate mean albedo for ocean point without ice cover and apply -! them to net SW heat fluxes - - do i = 1, im - if (islmsk(i) /= 1) then ! not a land point -! --- compute open water albedo - xcosz_loc = max( 0.0, min( 1.0, xcosz(i) )) - ocalnirdf_cpl(i) = 0.06 - ocalnirbm_cpl(i) = max(albdf, 0.026/(xcosz_loc**1.7+0.065) & - & + 0.15 * (xcosz_loc-0.1) * (xcosz_loc-0.5) & - & * (xcosz_loc-1.0)) - ocalvisdf_cpl(i) = 0.06 - ocalvisbm_cpl(i) = ocalnirbm_cpl(i) - - Coupling%nnirbmi_cpl(i) = adjnirbmd(i)-adjnirbmd(i)*ocalnirbm_cpl(i) - Coupling%nnirdfi_cpl(i) = adjnirdfd(i)-adjnirdfd(i)*ocalnirdf_cpl(i) - Coupling%nvisbmi_cpl(i) = adjvisbmd(i)-adjvisbmd(i)*ocalvisbm_cpl(i) - Coupling%nvisdfi_cpl(i) = adjvisdfd(i)-adjvisdfd(i)*ocalvisdf_cpl(i) - else - Coupling%nnirbmi_cpl(i) = adjnirbmd(i) - adjnirbmu(i) - Coupling%nnirdfi_cpl(i) = adjnirdfd(i) - adjnirdfu(i) - Coupling%nvisbmi_cpl(i) = adjvisbmd(i) - adjvisbmu(i) - Coupling%nvisdfi_cpl(i) = adjvisdfd(i) - adjvisdfu(i) - endif - Coupling%nswsfci_cpl(i) = Coupling%nnirbmi_cpl(i) + Coupling%nnirdfi_cpl(i) + & - Coupling%nvisbmi_cpl(i) + Coupling%nvisdfi_cpl(i) - Coupling%nswsfc_cpl(i) = Coupling%nswsfc_cpl(i) + Coupling%nswsfci_cpl(i)*dtf - Coupling%nnirbm_cpl(i) = Coupling%nnirbm_cpl(i) + Coupling%nnirbmi_cpl(i)*dtf - Coupling%nnirdf_cpl(i) = Coupling%nnirdf_cpl(i) + Coupling%nnirdfi_cpl(i)*dtf - Coupling%nvisbm_cpl(i) = Coupling%nvisbm_cpl(i) + Coupling%nvisbmi_cpl(i)*dtf - Coupling%nvisdf_cpl(i) = Coupling%nvisdf_cpl(i) + Coupling%nvisdfi_cpl(i)*dtf - enddo - endif - - if (Model%lssav) then - Diag%gflux(:) = Diag%gflux(:) + gflx(:) * dtf - Diag%evbsa(:) = Diag%evbsa(:) + evbs(:) * dtf - Diag%evcwa(:) = Diag%evcwa(:) + evcw(:) * dtf - Diag%transa(:) = Diag%transa(:) + trans(:) * dtf - Diag%sbsnoa(:) = Diag%sbsnoa(:) + sbsno(:) * dtf - Diag%snowca(:) = Diag%snowca(:) + snowc(:) * dtf - Diag%snohfa(:) = Diag%snohfa(:) + snohf(:) * dtf - Diag%ep(:) = Diag%ep(:) + ep1d(:) * dtf - - Diag%tmpmax(:) = max(Diag%tmpmax(:),Sfcprop%t2m(:)) - Diag%tmpmin(:) = min(Diag%tmpmin(:),Sfcprop%t2m(:)) - - Diag%spfhmax(:) = max(Diag%spfhmax(:),Sfcprop%q2m(:)) - Diag%spfhmin(:) = min(Diag%spfhmin(:),Sfcprop%q2m(:)) - endif - -!!!!!!!!!!!!!!!!!Commented by Moorthi on July 18, 2012 !!!!!!!!!!!!!!!!!!! -! do i = 1, im -! --- ... compute coefficient of evaporation in evapc -! -! if (evapc(i) > 1.0e0) evapc(i) = 1.0e0 -! --- ... over snow cover or ice or sea, coef of evap =1.0e0 -! if (weasd(i) > 0.0 .or. slmsk(i) /= 1.0) evapc(i) = 1.0e0 -! enddo -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -! --- ... Boundary Layer and Free atmospheic turbulence parameterization - -! if (lprnt) write(0,*)' tsea3=',tsea(ipr),' slmsk=',slmsk(ipr) & -! &, ' kdt=',kdt,' evap=',evap(ipr) -! if (lprnt) write(0,*)' dtdtb=',(dtdt(ipr,k),k=1,15) - -! do i = 1, im -! if (islmsk(i) == 0) then -! oro_land(i) = 0.0 -! else -! oro_land(i) = oro(i) -! endif -! enddo - -! write(0,*)' before monin clstp=',clstp,' kdt=',kdt,' lat=',lat - - if (Model%do_shoc) then - call moninshoc(ix, im, levs, ntrac, Model%ntcw, dvdt, dudt, dtdt, dqdt, & - Statein%ugrs, Statein%vgrs, Statein%tgrs, Statein%qgrs, & - Tbd%phy_f3d(1,1,Model%ntot3d-1), prnum, Model%ntke, & - Statein%prsik(1,1), rb, Sfcprop%zorl, Diag%u10m, & - Diag%v10m, Sfcprop%ffmm, Sfcprop%ffhh, Sfcprop%tsfc, hflx,& - evap, stress, wind, kpbl, Statein%prsi, del, Statein%prsl,& - Statein%prslk, Statein%phii, Statein%phil, dtp, dusfc1, & - dvsfc1, dtsfc1, dqsfc1, dkt, Diag%hpbl, kinver, & - Model%xkzm_m, Model%xkzm_h, Model%xkzm_s, lprnt, ipr, me) - else - if (Model%hybedmf) then - call moninedmf(ix, im, levs, nvdiff, Model%ntcw, dvdt, dudt, dtdt, dqdt,& - Statein%ugrs, Statein%vgrs, Statein%tgrs, Statein%qgrs, & - Radtend%htrsw, Radtend%htrlw, xmu, Statein%prsik(1,1), & - rb, Sfcprop%zorl, Diag%u10m, Diag%v10m, Sfcprop%ffmm, & - Sfcprop%ffhh, Sfcprop%tsfc, qss, hflx, evap, stress, & - wind, kpbl, Statein%prsi, del, Statein%prsl, & - Statein%prslk, Statein%phii, Statein%phil, dtp, & - Model%dspheat, dusfc1, dvsfc1, dtsfc1, dqsfc1, Diag%hpbl,& - gamt, gamq, dkt, kinver, Model%xkzm_m, Model%xkzm_h, & - Model%xkzm_s, lprnt, ipr) -! if (lprnt) write(0,*)' dtdtm=',(dtdt(ipr,k),k=1,15) -! if (lprnt) write(0,*)' dqdtm=',(dqdt(ipr,k,1),k=1,15) - elseif (.not. Model%old_monin) then - call moninq(ix, im, levs, nvdiff, Model%ntcw, dvdt, dudt, dtdt, dqdt, & - Statein%ugrs, Statein%vgrs, Statein%tgrs, Statein%qgrs, & - Radtend%htrsw, Radtend%htrlw, xmu, Statein%prsik(1,1), rb,& - Sfcprop%ffmm, Sfcprop%ffhh, Sfcprop%tsfc, qss, hflx, evap,& - stress, wind, kpbl, Statein%prsi, del, Statein%prsl, & - Statein%prslk, Statein%phii, Statein%phil, dtp, & - Model%dspheat, dusfc1, dvsfc1, dtsfc1, dqsfc1, Diag%hpbl, & - gamt, gamq, dkt, kinver, Model%xkzm_m, Model%xkzm_h, & - Model%xkzm_s, lprnt, ipr) - else - if (Model%mstrat) then - call moninp1(ix, im, levs, nvdiff, dvdt, dudt, dtdt, dqdt, & - Statein%ugrs, Statein%vgrs, Statein%tgrs, Statein%qgrs,& - Statein%prsik(1,1), rb, Sfcprop%ffmm, Sfcprop%ffhh, & - Sfcprop%tsfc, qss, hflx, evap, stress, wind, kpbl, & - Statein%prsi, del, Statein%prsl, Statein%prslk, & - Statein%phii, Statein%phil, dtp, dusfc1, dvsfc1, & - dtsfc1, dqsfc1, Diag%hpbl, gamt, gamq, dkt, kinver, & - Model%xkzm_m, Model%xkzm_h) - else - call moninp(ix, im, levs, nvdiff, dvdt, dudt, dtdt, dqdt, & - Statein%ugrs, Statein%vgrs, Statein%tgrs, Statein%qgrs, & - Statein%prsik(1,1), rb, Sfcprop%ffmm, Sfcprop%ffhh, & - Sfcprop%tsfc, qss, hflx, evap, stress, wind, kpbl, & - Statein%prsi, del, Statein%prsl, Statein%phii, & - Statein%phil, dtp, dusfc1, dvsfc1, dtsfc1, dqsfc1, & - Diag%hpbl, gamt, gamq, dkt, Model%xkzm_m, Model%xkzm_h) - endif - - endif ! end if_hybedmf - endif ! end if_do_shoc - - if (Model%cplflx) then - do i = 1, im - if (flag_cice(i)) then - cice(i) = fice_cice(i) - Sfcprop%tsfc(i) = tsea_cice(i) - dusfc1(i) = dusfc_cice(i) - dvsfc1(i) = dvsfc_cice(i) - dqsfc1(i) = dqsfc_cice(i) - dtsfc1(i) = dtsfc_cice(i) - endif - enddo - endif - -! if (lprnt) then -! write(0,*) ' dusfc1=',dusfc1(ipr),' kdt=',kdt,' lat=',lat -! write(0,*)' dtsfc1=',dtsfc1(ipr) -! write(0,*)' dqsfc1=',dqsfc1(ipr) -! write(0,*)' dtdtc=',(dtdt(ipr,k),k=1,15) -! write(0,*)' dqdtc=',(dqdt(ipr,k,1),k=1,15) -! print *,' dudtm=',dudt(ipr,:) -! endif - -! --- ... coupling insertion - - if (Model%cplflx) then - Coupling%dusfc_cpl (:) = Coupling%dusfc_cpl(:) + dusfc1(:)*dtf - Coupling%dvsfc_cpl (:) = Coupling%dvsfc_cpl(:) + dvsfc1(:)*dtf - Coupling%dtsfc_cpl (:) = Coupling%dtsfc_cpl(:) + dtsfc1(:)*dtf - Coupling%dqsfc_cpl (:) = Coupling%dqsfc_cpl(:) + dqsfc1(:)*dtf - Coupling%dusfci_cpl(:) = dusfc1(:) - Coupling%dvsfci_cpl(:) = dvsfc1(:) - Coupling%dtsfci_cpl(:) = dtsfc1(:) - Coupling%dqsfci_cpl(:) = dqsfc1(:) - endif -!-------------------------------------------------------lssav if loop ---------- - if (Model%lssav) then - Diag%dusfc (:) = Diag%dusfc(:) + dusfc1(:)*dtf - Diag%dvsfc (:) = Diag%dvsfc(:) + dvsfc1(:)*dtf - Diag%dtsfc (:) = Diag%dtsfc(:) + dtsfc1(:)*dtf - Diag%dqsfc (:) = Diag%dqsfc(:) + dqsfc1(:)*dtf - Diag%dusfci(:) = dusfc1(:) - Diag%dvsfci(:) = dvsfc1(:) - Diag%dtsfci(:) = dtsfc1(:) - Diag%dqsfci(:) = dqsfc1(:) -! if (lprnt) then -! write(0,*)' dusfc=',dusfc(ipr),' dusfc1=',dusfc1(ipr),' dtf=', -! & dtf,' kdt=',kdt,' lat=',lat -! endif - - if (Model%ldiag3d) then - if (Model%lsidea) then - Diag%dt3dt(:,:,3) = Diag%dt3dt(:,:,3) + dtdt(:,:)*dtf - else - do k = 1, levs - do i = 1, im - tem = dtdt(i,k) - (Radtend%htrlw(i,k)+Radtend%htrsw(i,k)*xmu(i)) - Diag%dt3dt(i,k,3) = Diag%dt3dt(i,k,3) + tem*dtf - enddo - enddo - endif - Diag%du3dt(:,:,1) = Diag%du3dt(:,:,1) + dudt(:,:) * dtf - Diag%du3dt(:,:,2) = Diag%du3dt(:,:,2) - dudt(:,:) * dtf - Diag%dv3dt(:,:,1) = Diag%dv3dt(:,:,1) + dvdt(:,:) * dtf - Diag%dv3dt(:,:,2) = Diag%dv3dt(:,:,2) - dvdt(:,:) * dtf -! update dqdt_v to include moisture tendency due to vertical diffusion -! if (lgocart) then -! do k = 1, levs -! do i = 1, im -! dqdt_v(i,k) = dqdt(i,k,1) * dtf -! enddo -! enddo -! endif - do k = 1, levs - do i = 1, im - tem = dqdt(i,k,1) * dtf - Diag%dq3dt(i,k,1) = Diag%dq3dt(i,k,1) + tem - enddo - enddo - if (Model%ntoz > 0) then - Diag%dq3dt(:,:,5) = Diag%dq3dt(:,:,5) + dqdt(i,k,Model%ntoz) * dtf - endif - endif - - endif ! end if_lssav -!-------------------------------------------------------lssav if loop ---------- -! -! Orographic gravity wave drag parameterization -! --------------------------------------------- - - if (Model%nmtvr == 14) then ! current operational - as of 2014 - oc(:) = Sfcprop%hprime(:,2) - oa4(:,1) = Sfcprop%hprime(:,3) - oa4(:,2) = Sfcprop%hprime(:,4) - oa4(:,3) = Sfcprop%hprime(:,5) - oa4(:,4) = Sfcprop%hprime(:,6) - clx(:,1) = Sfcprop%hprime(:,7) - clx(:,2) = Sfcprop%hprime(:,8) - clx(:,3) = Sfcprop%hprime(:,9) - clx(:,4) = Sfcprop%hprime(:,10) - theta(:) = Sfcprop%hprime(:,11) - gamma(:) = Sfcprop%hprime(:,12) - sigma(:) = Sfcprop%hprime(:,13) - elvmax(:) = Sfcprop%hprime(:,14) - elseif (Model%nmtvr == 10) then - oc(:) = Sfcprop%hprime(:,2) - oa4(:,1) = Sfcprop%hprime(:,3) - oa4(:,2) = Sfcprop%hprime(:,4) - oa4(:,3) = Sfcprop%hprime(:,5) - oa4(:,4) = Sfcprop%hprime(:,6) - clx(:,1) = Sfcprop%hprime(:,7) - clx(:,2) = Sfcprop%hprime(:,8) - clx(:,3) = Sfcprop%hprime(:,9) - clx(:,4) = Sfcprop%hprime(:,10) - elseif (Model%nmtvr == 6) then - oc(:) = Sfcprop%hprime(:,2) - oa4(:,1) = Sfcprop%hprime(:,3) - oa4(:,2) = Sfcprop%hprime(:,4) - oa4(:,3) = Sfcprop%hprime(:,5) - oa4(:,4) = Sfcprop%hprime(:,6) - clx(:,1) = 0.0 - clx(:,2) = 0.0 - clx(:,3) = 0.0 - clx(:,4) = 0.0 - else - oc = 0 ; oa4 = 0 ; clx = 0 ; theta = 0 ; gamma = 0 ; sigma = 0 - elvmax = 0 - - endif ! end if_nmtvr - -! write(0,*)' before gwd clstp=',clstp,' kdt=',kdt,' lat=',lat - call gwdps(im, ix, im, levs, dvdt, dudt, dtdt, & - Statein%ugrs, Statein%vgrs, Statein%tgrs, & - Statein%qgrs, kpbl, Statein%prsi, del, & - Statein%prsl, Statein%prslk, Statein%phii, & - Statein%phil, dtp, kdt, & - Sfcprop%hprime(1,1), oc, oa4, clx, theta, & - sigma, gamma, elvmax, dusfcg, dvsfcg, & - con_g, con_cp, con_rd, con_rv, Model%lonr, & - Model%nmtvr, Model%cdmbgwd, me, lprnt,ipr) - -! if (lprnt) print *,' dudtg=',dudt(ipr,:) - - if (Model%lssav) then - Diag%dugwd(:) = Diag%dugwd(:) + dusfcg(:)*dtf - Diag%dvgwd(:) = Diag%dvgwd(:) + dvsfcg(:)*dtf - -! if (lprnt) print *,' dugwd=',dugwd(ipr),' dusfcg=',dusfcg(ipr) -! if (lprnt) print *,' dvgwd=',dvgwd(ipr),' dvsfcg=',dvsfcg(ipr) - - if (Model%ldiag3d) then - Diag%du3dt(:,:,2) = Diag%du3dt(:,:,2) + dudt(:,:) * dtf - Diag%dv3dt(:,:,2) = Diag%dv3dt(:,:,2) + dvdt(:,:) * dtf - Diag%dt3dt(:,:,2) = Diag%dt3dt(:,:,2) + dtdt(:,:) * dtf - endif - endif - -! Rayleigh damping near the model top - if( .not. Model%lsidea .and. Model%ral_ts > 0.0) then - call rayleigh_damp(im, ix, im, levs, dvdt, dudt, dtdt, & - Statein%ugrs, Statein%vgrs, dtp, con_cp, & - Model%levr, Statein%pgr, Statein%prsl, & - Model%prslrd0, Model%ral_ts) - endif - -! if (lprnt) then -! write(0,*)' tgrs1=',(tgrs(ipr,ik),k=1,10) -! write(0,*)' dtdt=',(dtdt(ipr,ik),k=1,10) -! endif - - Stateout%gt0(:,:) = Statein%tgrs(:,:) + dtdt(:,:) * dtp - Stateout%gu0(:,:) = Statein%ugrs(:,:) + dudt(:,:) * dtp - Stateout%gv0(:,:) = Statein%vgrs(:,:) + dvdt(:,:) * dtp - Stateout%gq0(:,:,:) = Statein%qgrs(:,:,:) + dqdt(:,:,:) * dtp - -! if (lprnt) then -! write(7000,*)' ugrs=',ugrs(ipr,:) -! &,' lat=',lat,' kdt=',kdt,' me=',me -! write(7000,*)' dudt*dtp=',dudt(ipr,:)*dtp -! write(7000,*)' vgrs=',vgrs(ipr,:) -! write(7000,*)' dvdt*dtp ',dvdt(ipr,:)*dtp -! endif -! if(lprnt) write(1000+me,*)' gq0w=',gq0(ipr,:,ntcw) -! if(lprnt) write(0,*)' gq0i=',gq0(ipr,:,ntiw) - - if (Model%lsidea) then ! idea convective adjustment - call ideaca_up(Statein%prsi,Stateout%gt0,ix,im,levs+1) - endif - -! --- ... ozone physics - - if ((Model%ntoz > 0) .and. (ntrac >= Model%ntoz)) then - if (oz_coeff > 4) then - call ozphys_2015 (ix, im, levs, levozp, dtp, & - Stateout%gq0(1,1,Model%ntoz), & - Stateout%gq0(1,1,Model%ntoz), & - Stateout%gt0, oz_pres, Statein%prsl, & - Tbd%ozpl, oz_coeff, del, Model%ldiag3d, & - dq3dt_loc(1,1,6), me) - if (Model%ldiag3d) then - Diag%dq3dt(:,:,6) = dq3dt_loc(:,:,6) - Diag%dq3dt(:,:,7) = dq3dt_loc(:,:,7) - Diag%dq3dt(:,:,8) = dq3dt_loc(:,:,8) - Diag%dq3dt(:,:,9) = dq3dt_loc(:,:,9) - endif - else - call ozphys (ix, im, levs, levozp, dtp, & - Stateout%gq0(1,1,Model%ntoz), & - Stateout%gq0(1,1,Model%ntoz), & - Stateout%gt0, oz_pres, Statein%prsl, & - Tbd%ozpl, oz_coeff, del, Model%ldiag3d, & - dq3dt_loc(1,1,6), me) - if (Model%ldiag3d) then - Diag%dq3dt(:,:,6) = dq3dt_loc(:,:,6) - Diag%dq3dt(:,:,7) = dq3dt_loc(:,:,7) - Diag%dq3dt(:,:,8) = dq3dt_loc(:,:,8) - Diag%dq3dt(:,:,9) = dq3dt_loc(:,:,9) - endif - endif - endif - - if (Model%h2o_phys) then - call h2ophys (ix, im, levs, levh2o, dtp, Stateout%gq0(1,1,1), & - Stateout%gq0(1,1,1), h2o_pres, Statein%prsl, & - Tbd%h2opl, h2o_coeff, Model%ldiag3d, & - dq3dt_loc(1,1,1), me) - endif - -! --- ... to side-step the ozone physics - -! if (ntrac >= 2) then -! do k = 1, levs -! gq0(k,ntoz) = qgrs(k,ntoz) -! enddo -! endif - -! if (lprnt) then -! write(0,*) ' levs=',levs,' jcap=',jcap,' dtp',dtp & -! &, ' slmsk=',slmsk(ilon,ilat),' kdt=',kdt -! print *,' rann=',rann,' ncld=',ncld,' iq=',iq,' lat=',lat -! print *,' pgr=',pgr -! print *,' del=',del(ipr,:) -! print *,' prsl=',prsl(ipr,:) -! print *,' prslk=',prslk(ipr,:) -! print *,' rann=',rann(ipr,1) -! write(0,*)' gt0=',gt0(ipr,:) & -! &, ' kdt=',kdt,' xlon=',xlon(ipr),' xlat=',xlat(ipr) -! print *,' dtdt=',dtdt(ipr,:) -! print *,' gu0=',gu0(ipr,:) -! print *,' gv0=',gv0(ipr,:) -! write(0,*) ' gt0=',(gt0(ipr,k),k=1,levs),' kdt=',kdt -! write(0,*)' gq0=',(gq0(ipr,k,1),k=1,levs),' lat=',lat -! write(0,*)' gq0i2=',(gq0(ipr,k,ntiw),k=1,levs),' lat=',lat -! write(0,*)' gq1=',(gq0(ipr,k,ntcw),k=1,levs) -! print *,' vvel=',vvel -! endif -! if (lprnt) write(7000,*)' bef convection gu0=',gu0(ipr,:) -! &,' lat=',lat,' kdt=',kdt,' me=',me -! if (lprnt) write(7000,*)' bef convection gv0=',gv0(ipr,:) - - if (Model%ldiag3d) then - dtdt(:,:) = Stateout%gt0(:,:) - dudt(:,:) = Stateout%gu0(:,:) - dvdt(:,:) = Stateout%gv0(:,:) - elseif (Model%cnvgwd) then - dtdt(:,:) = Stateout%gt0(:,:) - endif ! end if_ldiag3d/cnvgwd - - if (Model%ldiag3d .or. Model%lgocart) then - dqdt(:,:,1) = Stateout%gq0(:,:,1) - endif ! end if_ldiag3d/lgocart - -#ifdef GFS_HYDRO - call get_phi(im, ix, levs, ntrac, Stateout%gt0, Stateout%gq0, & - Model%thermodyn_id, Model%sfcpress_id, & - Model%gen_coord_hybrid Statein%prsi, Statein%prsik, & - Statein%prsl, Statein%prslk, Statein%phii, Statein%phil) -#else -!GFDL Adjust the height hydrostatically in a way consistent with FV3 discretization - call get_phi_fv3 (ix, levs, ntrac, Stateout%gt0, Stateout%gq0, & - del_gz, Statein%phii, Statein%phil) -#endif - -! if (lprnt) then -! print *,' phii2=',phii(ipr,k=1,levs) -! print *,' phil2=',phil(ipr,:) -! endif - - clw(:,:,1) = 0.0 - clw(:,:,2) = -999.9 - if ((Model%imfdeepcnv >= 0) .or. (Model%imfshalcnv > 0)) then - cnvc(:,:) = 0.0 - cnvw(:,:) = 0.0 - endif - -! write(0,*)' before cnv clstp=',clstp,' kdt=',kdt,' lat=',lat - -! --- ... for convective tracer transport (while using ras) - - if (Model%ras .or. Model%cscnv) then - if (tottracer > 0) then - if (Model%ntoz > 0) then - clw(:,:,3) = Stateout%gq0(:,:,Model%ntoz) - if (tracers > 0) then - do n=1,tracers - clw(:,:,3+n) = Stateout%gq0(:,:,n+trc_shft) - enddo - endif - else - do n=1,tracers - clw(:,:,2+n) = Stateout%gq0(:,:,n+trc_shft) - enddo - endif - endif - endif ! end if_ras or cfscnv - - ktop(:) = 1 - kbot(:) = levs - -! --- ... calling condensation/precipitation processes -! -------------------------------------------- - - if (Model%ntcw > 0) then - do k=1,levs - do i=1,im - tem = rhbbot - (rhbbot-rhbtop) * (1.0-Statein%prslk(i,k)) - tem = rhc_max * work1(i) + tem * work2(i) - rhc(i,k) = max(0.0, min(1.0,tem)) - enddo - enddo - if (Model%ncld == 2) then - clw(:,:,1) = Stateout%gq0(:,:,Model%ntiw) ! ice - clw(:,:,2) = Stateout%gq0(:,:,Model%ntcw) ! water - else - if (Model%num_p3d == 4) then ! zhao-carr microphysics - psautco_l(:) = Model%psautco(1)*work1(:) + Model%psautco(2)*work2(:) - prautco_l(:) = Model%prautco(1)*work1(:) + Model%prautco(2)*work2(:) - clw(:,:,1) = Stateout%gq0(:,:,Model%ntcw) - endif ! end if_num_p3d - endif ! end if (ncld == 2) - else ! if_ntcw - psautco_l(:) = Model%psautco(1)*work1(:) + Model%psautco(2)*work2(:) - prautco_l(:) = Model%prautco(1)*work1(:) + Model%prautco(2)*work2(:) - rhc(:,:) = 1.0 - endif ! end if_ntcw -! -! Call SHOC if do_shoc is true and shocaftcnv is false -! - if (Model%do_shoc .and. .not. Model%shocaftcnv) then - if (Model%ncld == 2) then - skip_macro = Model%do_shoc - clw(:,:,1) = Stateout%gq0(:,:,Model%ntiw) ! ice - clw(:,:,2) = Stateout%gq0(:,:,Model%ntcw) ! water - ncpl(:,:) = Stateout%gq0(:,:,Model%ntlnc) - ncpi(:,:) = Stateout%gq0(:,:,Model%ntinc) - elseif (Model%num_p3d == 4) then - do k=1,levs - do i=1,im - qpl(i,k) = 0.0 - qpi(i,k) = 0.0 - if (abs(Stateout%gq0(i,k,Model%ntcw)) < epsq) then - Stateout%gq0(i,k,Model%ntcw) = 0.0 - endif - tem = Stateout%gq0(i,k,Model%ntcw) & - & * max(0.0, MIN(1.0, (TCR-Stateout%gt0(i,k))*TCRF)) - clw(i,k,1) = tem ! ice - clw(i,k,2) = Stateout%gq0(i,k,Model%ntcw) - tem ! water - enddo - enddo - endif - -! dtshoc = 60.0 -! dtshoc = 120.0 -! dtshoc = dtp -! nshocm = (dtp/dtshoc) + 0.001 -! dtshoc = dtp / nshocm -! do nshoc=1,nshocm -! if (lprnt) write(1000+me,*)' before shoc tke=',clw(ipr,:,ntk), -! &' kdt=',kdt,' lat=',lat,'xlon=',xlon(ipr),' xlat=',xlat(ipr) - -! phy_f3d(1,1,ntot3d-2) - shoc determined sgs clouds -! phy_f3d(1,1,ntot3d-1) - shoc determined diffusion coefficients -! phy_f3d(1,1,ntot3d ) - shoc determined w'theta' -! -! dqdt(1:im,:,1) = gq0(1:im,:,1) -! dqdt(1:im,:,2) = gq0(1:im,:,ntiw) -! dqdt(1:im,:,3) = gq0(1:im,:,ntcw) -!GFDL lat has no meaning inside of shoc - changed to "1" -!GFDL call shoc(ix, im, 1, levs, levs+1, dtp, me, lat, - call shoc (ix, im, 1, levs, levs+1, dtp, me, 1, Statein%prsl(1,1), & - Statein%phii(1,1), Statein%phil(1,1), Stateout%gu0(1,1), & - Stateout%gv0(1,1), Statein%vvl(1,1), Stateout%gt0(1,1), & - Stateout%gq0(1,1,1), clw(1,1,1), clw(1,1,2), qpi, qpl, & - rhc, Model%sup, Tbd%phy_f3d(1,1,Model%ntot3d-2), & - clw(1,1,ntk), hflx, evap, prnum, & - Tbd%phy_f3d(1,1,Model%ntot3d-1), & - Tbd%phy_f3d(1,1,Model%ntot3d), lprnt, ipr, ncpl, ncpi, kdt) - -! if (lprnt) write(0,*)' aftshoccld=',phy_f3d(ipr,:,ntot3d-2)*100 -! if (lprnt) write(0,*)' aftshocice=',clw(ipr,:,1) -! if (lprnt) write(0,*)' aftshocwat=',clw(ipr,:,1) -! write(1000+me,*)' at latitude = ',lat -! rain1 = 0.0 -! call moist_bud(im,im,ix,levs,me,kdt,con_g,dtp,del,rain1 -! &, dqdt(1,1,1), dqdt(1,1,2), dqdt(1,1,3) -! &, gq0(1,1,1),clw(1,1,2),clw(1,1,1),'shoc ') - - if ((Model%ntlnc > 0) .and. (Model%ntinc > 0) .and. (Model%ncld >= 2)) then - Stateout%gq0(:,:,Model%ntlnc) = ncpl(:,:) - Stateout%gq0(:,:,Model%ntinc) = ncpi(:,:) - endif -! do k=1,levs -! do i=1,im -! sgs_cld(i,k) = sgs_cld(i,k) + shoc_cld(i,k) -! enddo -! enddo -! if (lprnt) write(0,*)' gt03=',gt0(ipr,1:10) -! if (lprnt) write(0,*)' tke=',clw(ipr,1:10,ntk) - -! if (lprnt) write(1000+me,*)' after shoc tke=',clw(1,:,ntk), -! &' kdt=',kdt -! enddo -! -! do k=1,levs -! write(1000+me,*)' maxcld=',maxval(sgs_cld(1:im,k)), -! write(1000+me,*)' maxtkh=',maxval(phy_f3d(1:im,k,ntot3d-1)), -! &' k=',k,' kdt=',kdt,' lat=',lat -! enddo - -! write(0,*)' aft shoc gt0=',gt0(1,:),' lat=',lat -! write(0,*)' aft shoc gq0=',gq0(1,:,1),' lat=',lat -! write(0,*)' aft shoc gu0=',gu0(1,:),' lat=',lat -! - endif ! if(do_shoc) - -! --- ... calling convective parameterization -! - if (.not. Model%ras .and. .not. Model%cscnv) then - - if (Model%imfdeepcnv == 1) then ! no random cloud top - call sascnvn (im, ix, levs, Model%jcap, dtp, del, & - Statein%prsl, Statein%pgr, Statein%phil, clw(:,:,1:2), & - Stateout%gq0, Stateout%gt0, Stateout%gu0, & - Stateout%gv0, cld1d, rain1, kbot, ktop, kcnv, & - islmsk, Statein%vvl, Model%ncld, ud_mf, dd_mf, & - dt_mf, cnvw, cnvc) - elseif (Model%imfdeepcnv == 2) then - call mfdeepcnv (im, ix, levs, dtp, del, Statein%prsl, & - Statein%pgr, Statein%phil, clw(:,:,1:2), Stateout%gq0, & - Stateout%gt0, Stateout%gu0, Stateout%gv0, & - cld1d, rain1, kbot, ktop, kcnv, islmsk, & - garea, Statein%vvl, Model%ncld, ud_mf, dd_mf, & - dt_mf, cnvw, cnvc) -! if (lprnt) print *,' rain1=',rain1(ipr) - elseif (Model%imfdeepcnv == 0) then ! random cloud top - call sascnv (im, ix, levs, Model%jcap, dtp, del, & - Statein%prsl, Statein%pgr, Statein%phil, clw(:,:,1:2), & - Stateout%gq0, Stateout%gt0, Stateout%gu0, & - Stateout%gv0, cld1d, rain1, kbot, ktop, kcnv, & - islmsk, Statein%vvl, Tbd%rann, Model%ncld, & - ud_mf, dd_mf, dt_mf, cnvw, cnvc) -! if (lprnt) print *,' rain1=',rain1(ipr),' rann=',rann(ipr,1) - endif - else ! ras or cscnv - if (Model%cscnv) then ! Chikira-Sugiyama convection scheme (via CSU) - otspt(:,:) = .true. - otspt(1:3,:) = .false. - if (Model%ntke > 0) then - otspt(Model%ntke-trc_shft+4,1) = .false. - endif - if (Model%ncld == 2) then - otspt(Model%ntlnc-trc_shft+4,1) = .false. - otspt(Model%ntinc-trc_shft+4,1) = .false. - endif - - fscav(:) = 0.0 - fswtr(:) = 0.0 -! write(0,*)' bef cs_cconv phii=',phii(ipr,:) -! &,' sizefsc=',size(fscav) -! write(0,*)' bef cs_cconv otspt=',otspt,' kdt=',kdt,' me=',me - dqdt(:,:,1) = Stateout%gq0(:,:,1) - dqdt(:,:,2) = max(0.0,clw(:,:,2)) - dqdt(:,:,3) = max(0.0,clw(:,:,1)) -! if (lprnt) write(0,*)' gq0bfcs=',gq0(ipr,1:35,1) -! if (lprnt) write(0,*)' gq0bfcs3=',gq0(ipr,1:35,3) -! if (lprnt) write(0,*)' gq0bfcs4=',gq0(ipr,1:35,4) - - do_awdd = ((Model%do_aw) .and. (Model%cs_parm(6) > 0.0)) -! if (lprnt) write(0,*)' do_awdd=',do_awdd -!GFDL again lat replaced with "1" -!GFDL & otspt, lat, kdt , & - call cs_convr (ix, im, levs, tottracer+3, Model%nctp, otspt, 1, & - kdt, Stateout%gt0, Stateout%gq0(1,1,1:1), rain1, & - clw, Statein%phil, Statein%phii, Statein%prsl, & - Statein%prsi, dtp, dtf, ud_mf, dd_mf, dt_mf, & - Stateout%gu0, Stateout%gv0, fscav, fswtr, & - Tbd%phy_fctd, me, wcbmax, Model%cs_parm(3), & - Model%cs_parm(4), sigmai, sigmatot, vverti, & - Model%do_aw, do_awdd, lprnt, ipr, QLCN, QICN, & - w_upi, cf_upi, CNV_MFD, CNV_PRC3, CNV_DQLDT, & - CLCN, CNV_FICE, CNV_NDROP, CNV_NICE, Model%ncld) - -! if (lprnt) write(0,*)' gq0afcs=',gq0(ipr,1:35,1) -! if (lprnt) write(0,*)' gq0afcs3=',gq0(ipr,1:35,3) -! if (lprnt) write(0,*)' gq0afcs4=',gq0(ipr,1:35,4) -! write(1000+me,*)' at latitude = ',lat -! call moist_bud(im,im,ix,levs,me,kdt,con_g,dtp,del,rain1 -! &, dqdt(1,1,1), dqdt(1,1,2), dqdt(1,1,3) -! &, gq0(1,1,1),clw(1,1,2),clw(1,1,1),' cs_conv') - - rain1(:) = rain1(:) * (dtp*0.001) - if (Model%do_aw) then - do k=1,levs - kk = min(k+1,levs) ! assuming no cloud top reaches the model top - do i = 1,im !DD - sigmafrac(i,k) = 0.5 * (sigmatot(i,k)+sigmatot(i,kk)) - enddo - enddo - endif - -! if (lprnt) then -! write(0,*)' gt01=',gt0(ipr,:),' kdt=',kdt -! write(0,*)' gq01=',gq0(ipr,:,1),' kdt=',kdt -! write(0,*)' clw1=',clw(ipr,:,1),' kdt=',kdt -! write(0,*)' clw2=',clw(ipr,:,1),' kdt=',kdt -! write(0,*)' aft cs rain1=',rain1(ipr)*86400 -! write(0,*)' aft cs rain1=',rain1(ipr) -! endif - - else ! ras version 2 - - if ((Model%ccwf(1) >= 0.0) .or. (Model%ccwf(2) >= 0)) then - ccwfac(:) = Model%ccwf(1)*work1(:) + Model%ccwf(2)*work2(:) - dlqfac(:) = Model%dlqf(1)*work1(:) + Model%dlqf(2)*work2(:) - lmh (:) = levs - else - ccwfac(:) = -999.0 - dlqfac(:) = 0.0 - lmh (:) = levs - endif -! if (lprnt) write(0,*) ' calling ras for kdt=',kdt,' me=',me & -! &, ' lprnt=',lprnt,' ccwfac=',ccwfac(ipr) - -! do k=1,levs -! do i=1,im -! dqdt(i,k,1) = gq0(i,k,1) -! dqdt(i,k,2) = max(0.0,clw(i,k,2)) -! dqdt(i,k,3) = max(0.0,clw(i,k,1)) -! enddo -! enddo -! if (lat == 64 .and. kdt == 1) write(0,*)' qliq=',clw(1,:,1) -! if (lat == 64 .and. kdt == 1) write(0,*)' qice=',clw(1,:,2) - - revap = .true. -! if (ncld ==2) revap = .false. - call rascnv (im, ix, levs, dtp, dtf, Tbd%rann, Stateout%gt0, & - Stateout%gq0, Stateout%gu0, Stateout%gv0, clw, & - tottracer, fscav, Statein%prsi, Statein%prsl, & - Statein%prsik, Statein%prslk, Statein%phil, & - Statein%phii, kpbl, cd, rain1, kbot, ktop, kcnv, & - Tbd%phy_f2d(1,Model%num_p2d), Model%flipv, pa2mb, & - me, garea, lmh, ccwfac, Model%nrcm, rhc, ud_mf, & - dd_mf, dt_mf, dlqfac, lprnt, ipr, kdt, revap, QLCN, & - QICN, w_upi, cf_upi, CNV_MFD, CNV_PRC3, CNV_DQLDT, & - CLCN, CNV_FICE, CNV_NDROP, CNV_NICE, Model%ncld ) - endif - -! write(1000+me,*)' at latitude = ',lat -! tx1 = 1000.0 -! call moist_bud(im,im,ix,levs,me,kdt,con_g,tx1,del,rain1 -! &, dqdt(1,1,1), dqdt(1,1,2), dqdt(1,1,3) -! &, gq0(1,1,1),clw(1,1,2),clw(1,1,1),' ras_conv') -! if(lprnt) write(0,*)' after ras rain1=',rain1(ipr) -! &,' cnv_prc3sum=',sum(cnv_prc3(ipr,1:levs)) -! if (lprnt) write(0,*)' gt04=',gt0(ipr,1:10) -! if (lprnt) write(0,*)' gq04=',gq0(ipr,:,1) - - cld1d = 0 - - if (Model%ldiag3d .or. Model%lgocart) then - Coupling%upd_mfi(:,:) = 0. - Coupling%dwn_mfi(:,:) = 0. - Coupling%det_mfi(:,:) = 0. - endif - if (Model%lgocart) then - Coupling%dqdti(:,:) = 0. - Coupling%cnvqci(:,:) = 0. - endif - - if (Model%lgocart) then - Coupling%upd_mfi(:,:) = Coupling%upd_mfi(:,:) + ud_mf(:,:) * frain - Coupling%dwn_mfi(:,:) = Coupling%dwn_mfi(:,:) + dd_mf(:,:) * frain - Coupling%det_mfi(:,:) = Coupling%det_mfi(:,:) + dt_mf(:,:) * frain - Coupling%cnvqci (:,:) = Coupling%cnvqci (:,:) + (clw(:,:,1)+clw(:,:,2) - & - Stateout%gq0(:,:,Model%ntcw)) * frain - endif ! if (lgocart) - -! --- ... update the tracers due to convective transport - - if (tottracer > 0) then - if (Model%ntoz > 0) then ! for ozone - Stateout%gq0(:,:,Model%ntoz) = clw(:,:,3) - - if (tracers > 0) then ! for other tracers - do n=1,tracers - Stateout%gq0(:,:,n+trc_shft) = clw(:,:,3+n) - enddo - endif - else - do n=1,tracers - Stateout%gq0(:,:,n+trc_shft) = clw(:,:,2+n) - enddo - endif - endif - endif ! end if_not_ras - -! if (lprnt) then -! write(0,*)' aftcnvgt0=',gt0(ipr,:),' kdt=',kdt,' lat=',lat -! write(0,*)' aftcnvgq0=',(gq0(ipr,k,1),k=1,levs),' lat=',lat -! write(0,*)' gq0i2=',(gq0(ipr,k,ntiw),k=1,levs),' lat=',lat -! write(0,*)' aftcnvgq1=',(gq0(ipr,k,ntcw),k=1,levs) -! endif -! - do i = 1, im - Diag%rainc(:) = frain * rain1(:) - enddo -! - if (Model%lssav) then - Diag%cldwrk (:) = Diag%cldwrk (:) + cld1d(:) * dtf - Diag%cnvprcp(:) = Diag%cnvprcp(:) + Diag%rainc(:) - - if (Model%ldiag3d) then - Diag%dt3dt(:,:,4) = Diag%dt3dt(:,:,4) + (Stateout%gt0(:,:)-dtdt(:,:)) * frain - Diag%dq3dt(:,:,2) = Diag%dq3dt(:,:,2) + (Stateout%gq0(:,:,1)-dqdt(:,:,1)) * frain - Diag%du3dt(:,:,3) = Diag%du3dt(:,:,3) + (Stateout%gu0(:,:)-dudt(:,:)) * frain - Diag%dv3dt(:,:,3) = Diag%dv3dt(:,:,3) + (Stateout%gv0(:,:)-dvdt(:,:)) * frain - - Diag%upd_mf(:,:) = Diag%upd_mf(:,:) + ud_mf(:,:) * (con_g*frain) - Diag%dwn_mf(:,:) = Diag%dwn_mf(:,:) + dd_mf(:,:) * (con_g*frain) - Diag%det_mf(:,:) = Diag%det_mf(:,:) + dt_mf(:,:) * (con_g*frain) - endif ! if (ldiag3d) - - endif ! end if_lssav -! -! update dqdt_v to include moisture tendency due to deep convection - if (Model%lgocart) then - Coupling%dqdti (:,:) = (Stateout%gq0(:,:,1) - dqdt(:,:,1)) * frain - Coupling%upd_mfi(:,:) = Coupling%upd_mfi(:,:) + ud_mf(:,:) * frain - Coupling%dwn_mfi(:,:) = Coupling%dwn_mfi(:,:) + dd_mf(:,:) * frain - Coupling%det_mfi(:,:) = Coupling%det_mfi(:,:) + dt_mf(:,:) * frain - Coupling%cnvqci (:,:) = Coupling%cnvqci (:,:) + (clw(:,:,1)+clw(:,:,2))*frain - endif ! if (lgocart) -! - if ((Model%npdf3d == 3) .and. (Model%num_p3d == 4)) then - num2 = Model%num_p3d + 2 - num3 = num2 + 1 - Tbd%phy_f3d(:,:,num2) = cnvw(:,:) - Tbd%phy_f3d(:,:,num3) = cnvc(:,:) - elseif ((Model%npdf3d == 0) .and. (Model%ncnvcld3d == 1)) then - num2 = Model%num_p3d + 1 - Tbd%phy_f3d(:,:,num2) = cnvw(:,:) - endif - -! if (lprnt) write(7000,*)' bef cnvgwd gu0=',gu0(ipr,:) -! &,' lat=',lat,' kdt=',kdt,' me=',me -! if (lprnt) write(7000,*)' bef cnvgwd gv0=',gv0(ipr,:) -! -!----------------Convective gravity wave drag parameterization starting -------- - - if (Model%cnvgwd) then ! call convective gravity wave drag - -! --- ... calculate maximum convective heating rate -! cuhr = temperature change due to deep convection - - cumabs(:) = 0.0 - work3 (:) = 0.0 - do k = 1, levs - do i = 1, im - if (k >= kbot(i) .and. k <= ktop(i)) then - cumabs(i) = cumabs(i) + (Stateout%gt0(i,k)-dtdt(i,k)) * del(i,k) - work3(i) = work3(i) + del(i,k) - endif - enddo - enddo - do i=1,im - if (work3(i) > 0.0) cumabs(i) = cumabs(i) / (dtp*work3(i)) - enddo - -! do i = 1, im -! do k = kbot(i), ktop(i) -! do k1 = kbot(i), k -! cumchr(i,k) = cuhr(i,k1) + cumchr(i,k) -! enddo -! cumchr(i,k) = cumchr(i,k) / cumabs(i) -! enddo -! enddo - -! --- ... begin check print ****************************************** - -! if (lprnt) then -! if (kbot(ipr) <= ktop(ipr)) then -! write(*,*) 'kbot <= ktop for (lat,lon) = ', & -! & xlon(ipr)*57.29578,xlat(ipr)*57.29578 -! write(*,*) 'kcnv kbot ktop dlength ',kcnv(ipr), & -! & kbot(ipr),ktop(ipr),dlength(ipr) -! write(*,9000) kdt -!9000 format(/,3x,'k',5x,'cuhr(k)',4x,'cumchr(k)',5x, & -! & 'at kdt = ',i4,/) - -! do k = ktop(ipr), kbot(ipr),-1 -! write(*,9010) k,(86400.*cuhr(ipr,k)),(100.*cumchr(ipr,k)) -!9010 format(2x,i2,2x,f8.2,5x,f6.0) -! enddo -! endif - -! if (fhour >= fhourpr) then -! print *,' before gwdc in gbphys start print' -! write(*,*) 'fhour ix im levs = ',fhour,ix,im,levs -! print *,'dtp dtf = ',dtp,dtf - -! write(*,9100) -!9100 format(//,14x,'pressure levels',// & -! & ' ilev',7x,'prsi',8x,'prsl',8x,'delp',/) - -! k = levs + 1 -! write(*,9110) k,(10.*prsi(ipr,k)) -!9110 format(i4,2x,f10.3) - -! do k = levs, 1, -1 -! write(*,9120) k,(10.*prsl(ipr,k)),(10.*del(ipr,k)) -! write(*,9110) k,(10.*prsi(ipr,k)) -! enddo -!9120 format(i4,12x,2(2x,f10.3)) - -! write(*,9130) -!9130 format(//,10x,'before gwdc in gbphys',//,' ilev',6x, & -! & 'ugrs',9x,'gu0',8x,'vgrs',9x,'gv0',8x, & -! & 'tgrs',9x,'gt0',8x,'gt0b',8x,'dudt',8x,'dvdt',/) - -! do k = levs, 1, -1 -! write(*,9140) k,ugrs(ipr,k),gu0(ipr,k), & -! & vgrs(ipr,k),gv0(ipr,k), & -! & tgrs(ipr,k),gt0(ipr,k),dtdt(ipr,k), & -! & dudt(ipr,k),dvdt(ipr,k) -! enddo -!9140 format(i4,9(2x,f10.3)) - -! print *,' before gwdc in gbphys end print' -! endif -! endif ! end if_lprnt - -! --- ... end check print ******************************************** - -!GFDL replacing lat with "1" -! call gwdc(im, ix, im, levs, lat, gu0, gv0, gt0, gq0, dtp, & - call gwdc (im, ix, im, levs, 1, Statein%ugrs, Statein%vgrs, & - Statein%tgrs, Statein%qgrs, dtp, Statein%prsl, & - Statein%prsi, del, cumabs, ktop, kbot, kcnv, cldf, & - con_g, con_cp, con_rd, con_fvirt, con_pi, dlength, & - lprnt, ipr, Model%fhour, gwdcu, gwdcv, dusfcg, dvsfcg) - -! if (lprnt) then -! if (fhour >= fhourpr) then -! print *,' after gwdc in gbphys start print' - -! write(*,9131) -!9131 format(//,10x,'after gwdc in gbphys',//,' ilev',6x, & -! & 'ugrs',9x,'gu0',8x,'vgrs',9x,'gv0',8x, & -! & 'tgrs',9x,'gt0',8x,'gt0b',7x,'gwdcu',7x,'gwdcv',/) - -! do k = levs, 1, -1 -! write(*,9141) k,ugrs(ipr,k),gu0(ipr,k), & -! & vgrs(ipr,k),gv0(ipr,k), & -! & tgrs(ipr,k),gt0(ipr,k),dtdt(ipr,k), & -! & gwdcu(ipr,k),gwdcv(ipr,k) -! enddo -!9141 format(i4,9(2x,f10.3)) - -! print *,' after gwdc in gbphys end print' -! endif -! endif - -! --- ... write out cloud top stress and wind tendencies - - if (Model%lssav) then - Diag%dugwd(:) = Diag%dugwd(:) + dusfcg(:)*dtf - Diag%dvgwd(:) = Diag%dvgwd(:) + dvsfcg(:)*dtf - - if (Model%ldiag3d) then - Diag%du3dt(:,:,4) = Diag%du3dt(:,:,4) + gwdcu(:,:) * dtf - Diag%dv3dt(:,:,4) = Diag%dv3dt(:,:,4) + gwdcv(:,:) * dtf - endif - endif ! end if_lssav - -! --- ... update the wind components with gwdc tendencies - - do k = 1, levs - do i = 1, im - eng0 = 0.5*(Stateout%gu0(i,k)*Stateout%gu0(i,k)+Stateout%gv0(i,k)*Stateout%gv0(i,k)) - Stateout%gu0(i,k) = Stateout%gu0(i,k) + gwdcu(i,k) * dtp - Stateout%gv0(i,k) = Stateout%gv0(i,k) + gwdcv(i,k) * dtp - eng1 = 0.5*(Stateout%gu0(i,k)*Stateout%gu0(i,k)+Stateout%gv0(i,k)*Stateout%gv0(i,k)) - Stateout%gt0(i,k) = Stateout%gt0(i,k) + (eng0-eng1)/(dtp*con_cp) - enddo -! if (lprnt) write(7000,*)' gu0=',gu0(ipr,k),' gwdcu=', -! &gwdcu(ipr,k), ' gv0=', gv0(ipr,k),' gwdcv=',gwdcv(ipr,k) -! &,' k=',k - enddo - -! if (lprnt) then -! if (fhour >= fhourpr) then -! print *,' after tendency gwdc in gbphys start print' - -! write(*,9132) -!9132 format(//,10x,'after tendency gwdc in gbphys',//,' ilev',6x,& -! & 'ugrs',9x,'gu0',8x,'vgrs',9x,'gv0',8x, & -! & 'tgrs',9x,'gt0',8x,'gt0b',7x,'gwdcu',7x,'gwdcv',/) - -! do k = levs, 1, -1 -! write(*,9142) k,ugrs(ipr,k),gu0(ipr,k),vgrs(ipr,k), & -! & gv0(ipr,k),tgrs(ipr,k),gt0(ipr,k),dtdt(ipr,k), & -! & gwdcu(ipr,k),gwdcv(ipr,k) -! enddo -!9142 format(i4,9(2x,f10.3)) - -! print *,' after tendency gwdc in gbphys end print' -! endif -! endif - - endif ! end if_cnvgwd (convective gravity wave drag) - -! if (lprnt) write(7000,*)' aft cnvgwd gu0=',gu0(ipr,:) -! if (lprnt) write(7000,*)' aft cnvgwd gv0=',gv0(ipr,:) -! &,' lat=',lat,' kdt=',kdt,' me=',me -!----------------Convective gravity wave drag parameterization over -------- - - if (Model%ldiag3d) then - dtdt(:,:) = Stateout%gt0(:,:) - endif - if (Model%ldiag3d .or. Model%lgocart) then - dqdt(:,:,1) = Stateout%gq0(:,:,1) - endif - -! write(0,*)' before do_shoc shal clstp=',clstp,' kdt=',kdt, -! & ' lat=',lat -! if (lprnt) then -! write(0,*)' prsl=',prsl(ipr,:) -! write(0,*) ' del=',del(ipr,:) -! write(0,*) ' befshalgt0=',gt0(ipr,:),' kdt=',kdt -! write(0,*) ' befshalgq0=',gt0(ipr,:),' kdt=',kdt -! write(0,*) ' befshalgq0=',gq0(ipr,:,1),' kdt=',kdt -! write(0,*) ' befshalgqw=',gq0(ipr,:,3),' kdt=',kdt -! endif - - if (.not. Model%do_shoc) then - - if (Model%shal_cnv) then ! Shallow convection parameterizations -! -------------------------------------- - if (Model%imfshalcnv == 1) then ! opr option now at 2014 - !----------------------- - call shalcnv (im, ix, levs, Model%jcap, dtp, del, Statein%prsl, & - Statein%pgr, Statein%phil, clw, Stateout%gq0, & - Stateout%gt0, Stateout%gu0, Stateout%gv0, rain1, & - kbot, ktop, kcnv, islmsk, Statein%vvl, Model%ncld,& - Diag%hpbl, hflx, evap, ud_mf, dt_mf, cnvw, cnvc) - - raincs(:) = frain * rain1(:) - Diag%rainc(:) = Diag%rainc(:) + raincs(:) - if (Model%lssav) then - Diag%cnvprcp(:) = Diag%cnvprcp(:) + raincs(:) - endif - if ((Model%shcnvcw) .and. (Model%num_p3d == 4) .and. (Model%npdf3d == 3)) then - Tbd%phy_f3d(:,:,num2) = cnvw(:,:) - Tbd%phy_f3d(:,:,num3) = cnvc(:,:) - elseif ((Model%npdf3d == 0) .and. (Model%ncnvcld3d == 1)) then - num2 = Model%num_p3d + 1 - Tbd%phy_f3d(:,:,num2) = cnvw(:,:) - endif - - elseif (Model%imfshalcnv == 2) then - call mfshalcnv (im, ix, levs, dtp, del, Statein%prsl, & - Statein%pgr, Statein%phil, clw, Stateout%gq0, & - Stateout%gt0, Stateout%gu0, Stateout%gv0, & - rain1, kbot, ktop, kcnv, islmsk, garea, & - Statein%vvl, Model%ncld, DIag%hpbl, ud_mf, & - dt_mf, cnvw, cnvc) - - raincs(:) = frain * rain1(:) - Diag%rainc(:) = DIag%rainc(:) + raincs(:) - if (Model%lssav) then - Diag%cnvprcp(:) = Diag%cnvprcp(:) + raincs(:) - endif - if ((Model%shcnvcw) .and. (Model%num_p3d == 4) .and. (Model%npdf3d == 3)) then - Tbd%phy_f3d(:,:,num2) = cnvw(:,:) - Tbd%phy_f3d(:,:,num3) = cnvc(:,:) - elseif ((Model%npdf3d == 0) .and. (Model%ncnvcld3d == 1)) then - num2 = Model%num_p3d + 1 - Tbd%phy_f3d(:,:,num2) = cnvw(:,:) - endif - - elseif (Model%imfshalcnv == 0) then ! modified Tiedtke Shallow convecton - !----------------------------------- - levshc(:) = 0 - do k = 2, levs - do i = 1, im - dpshc = 0.3 * Statein%prsi(i,1) - if (Statein%prsi(i,1)-Statein%prsi(i,k) <= dpshc) levshc(i) = k - enddo - enddo - levshcm = 1 - do i = 1, im - levshcm = max(levshcm, levshc(i)) - enddo - -! if (lprnt) print *,' levshcm=',levshcm,' gt0sh=',gt0(ipr,:) -! &, ' lat=',lat - - if (Model%mstrat) then ! As in CFSv2 - call shalcv (im, ix, levshcm, dtp, del, Statein%prsi, & - Statein%prsl, Statein%prslk,kcnv, Stateout%gq0, & - Stateout%gt0, levshc, Statein%phil, kinver, & - ctei_r, ctei_rml, lprnt, ipr) - else - call shalcvt3 (im, ix, levshcm, dtp, del, Statein%prsi, & - Statein%prsl, Statein%prslk, kcnv, & - Stateout%gq0, Stateout%gt0) - endif -! if (lprnt) print *,' levshcm=',levshcm,' gt0sha=',gt0(ipr,:) - - endif ! end if_imfshalcnv - endif ! end if_shal_cnv - - if (Model%lssav) then -! update dqdt_v to include moisture tendency due to shallow convection - if (Model%lgocart) then - do k = 1, levs - do i = 1, im - tem = (Stateout%gq0(i,k,1)-dqdt(i,k,1)) * frain - Coupling%dqdti(i,k) = Coupling%dqdti(i,k) + tem - enddo - enddo - endif - if (Model%ldiag3d) then - Diag%dt3dt(:,:,5) = Diag%dt3dt(:,:,5) + (Stateout%gt0(:,:)-dtdt(:,:)) * frain - Diag%dq3dt(:,:,3) = Diag%dq3dt(:,:,3) + (Stateout%gq0(:,:,1)-dqdt(:,:,1)) * frain - endif - endif ! end if_lssav -! - do k = 1, levs - do i = 1, im - if (clw(i,k,2) <= -999.0) clw(i,k,2) = 0.0 - enddo - enddo - -! if (lprnt) then -! write(0,*)' prsl=',prsl(ipr,:) -! write(0,*) ' del=',del(ipr,:) -! write(0,*) ' befshgt0=',gt0(ipr,:) -! write(0,*) ' befshgq0=',gq0(ipr,:,1) -! endif - - elseif (Model%shocaftcnv) then ! if do_shoc is true and shocaftcnv is true call shoc - if (Model%ncld == 2) then - skip_macro = Model%do_shoc - ncpl(:,:) = Stateout%gq0(:,:,Model%ntlnc) - ncpi(:,:) = Stateout%gq0(:,:,Model%ntinc) - -! else -! if (clw(1,1,2) < -999.0) then ! if clw is not partitioned to ice and water -! do k=1,levs -! do i=1,im -! tem = gq0(i,k,ntcw) & -! & * max(0.0, MIN(1.0, (TCR-gt0(i,k))*TCRF)) -! clw(i,k,1) = tem ! ice -! clw(i,k,2) = gq0(i,k,ntcw) - tem ! water -! enddo -! enddo -! endif ! Anning ncld ==2 - endif - qpl(:,:) = 0.0 - qpi(:,:) = 0.0 -! dtshoc = 60.0 -! nshocm = (dtp/dtshoc) + 0.001 -! dtshoc = dtp / nshocm -! do nshoc=1,nshocm -! call shoc(im, 1, levs, levs+1, dtp, me, lat, & -!! call shoc(im, 1, levs, levs+1, dtshoc, me, lat, & -! & prsl(1:im,:), phii (1:im,:), phil(1:im,:),& -! & gu0(1:im,:),gv0(1:im,:), vvl(1:im,:), gt0(1:im,:), & -! & gq0(1:im,:,1), & -! & clw(1:im,:,1), clw(1:im,:,2), qpi, qpl, sgs_cld(1:im,:)& -! &, gq0(1:im,:,ntke), & -! & phy_f3d(1:im,:,ntot3d-1), phy_f3d(1:im,:,ntot3d), & -! & lprnt, ipr, & -! & con_cp, con_g, con_hvap, con_hfus, con_hvap+con_hfus, & -! & con_rv, con_rd, con_pi, con_fvirt) - -!GFDL replace lat with "1: -! call shoc(ix, im, 1, levs, levs+1, dtshoc, me, lat, & - call shoc (ix, im, 1, levs, levs+1, dtp, me, 1, Statein%prsl(1,1), & - Statein%phii(1,1), Statein%phil(1,1), Stateout%gu0(1,1), & - Stateout%gv0(1,1), Statein%vvl(1,1), Stateout%gt0(1,1), & - Stateout%gq0(1,1,1), clw(1,1,1), clw(1,1,2), qpi, qpl,rhc, & - Model%sup, Tbd%phy_f3d(1,1,Model%ntot3d-2), & - Stateout%gq0(1,1,Model%ntke), hflx, evap, prnum, & - Tbd%phy_f3d(1,1,Model%ntot3d-1), Tbd%phy_f3d(1,1,Model%ntot3d),& - lprnt, ipr, ncpl, ncpi, kdt) - - if ((Model%ntlnc > 0) .and. (Model%ntinc > 0) .and. (Model%ncld >= 2)) then - Stateout%gq0(:,:,Model%ntlnc) = ncpl(:,:) - Stateout%gq0(:,:,Model%ntinc) = ncpi(:,:) - endif - -! -! do k=1,levs -! write(1000+me,*)' maxtkh=',maxval(phy_f3d(1:im,k,ntot3d-1)), & -! ' k=',k,' kdt=',kdt,' lat=',lat -! enddo - -! write(0,*)' aft shoc gt0=',gt0(1,:),' lat=',lat -! write(0,*)' aft shoc gq0=',gq0(1,:,1),' lat=',lat -! write(0,*)' aft shoc gu0=',gu0(1,:),' lat=',lat -! - endif ! if( .not. do_shoc) -! -! if (lprnt) then -! write(0,*)' prsl=',prsl(ipr,:) -! write(0,*) ' del=',del(ipr,:) -! write(0,*) ' aftshgt0=',gt0(ipr,:) -! write(0,*) ' aftshgq0=',gq0(ipr,:,1) -! endif - - if (Model%ntcw > 0) then - -! for microphysics - if (Model%ncld == 2) then ! morrison microphysics - Stateout%gq0(:,:,Model%ntiw) = clw(:,:,1) ! ice - Stateout%gq0(:,:,Model%ntcw) = clw(:,:,2) ! water - elseif (Model%num_p3d == 4) then ! if_num_p3d - Stateout%gq0(:,:,Model%ntcw) = clw(:,:,1) + clw(:,:,2) - endif ! end if_num_p3d - - else ! if_ntcw - - clw(:,:,1) = clw(:,:,1) + clw(:,:,2) - - - endif ! end if_ntcw - -! Legacy routine which determines convectve clouds - should be removed at some point - - call cnvc90 (Model%clstp, im, ix, Diag%rainc, kbot, ktop, levs, Statein%prsi, & - Tbd%acv, Tbd%acvb, Tbd%acvt, Cldprop%cv, Cldprop%cvb, Cldprop%cvt) - - if (Model%moist_adj) then ! moist convective adjustment -! --------------------------- -! -! To call moist convective adjustment -! -! if (lprnt) then -! print *,' prsl=',prsl(ipr,:) -! print *,' del=',del(ipr,:) -! print *,' gt0b=',gt0(ipr,:) -! print *,' gq0b=',gq0(ipr,:,1) -! endif - - call mstcnv (im, ix, levs, dtp, Stateout%gt0, Stateout%gq0, & - Statein%prsl,del, Statein%prslk, rain1, & - Stateout%gq0(1,1,Model%ntcw), rhc, lprnt, ipr) - -! if (lprnt) then -! print *,' rain1=',rain1(ipr),' rainc=',rainc(ipr) -! print *,' gt0a=',gt0(ipr,:) -! print *,' gq0a=',gq0(ipr,:,1) -! endif - Diag%rainc(:) = Diag%rainc(:) + frain * rain1(:) - if(Model%lssav) then - Diag%cnvprcp(:) = Diag%cnvprcp(:) + rain1(:) * frain - -! update dqdt_v to include moisture tendency due to surface processes -! dqdt_v : instaneous moisture tendency (kg/kg/sec) -! if (lgocart) then -! do k=1,levs -! do i=1,im -! tem = (gq0(i,k,1)-dqdt(i,k,1)) * frain -! dqdt_v(i,k) = dqdt_v(i,k) + tem -! dqdt_v(i,k) = dqdt_v(i,k) / dtf -! enddo -! enddo -! endif - if (Model%ldiag3d) then - Diag%dt3dt(:,:,4) = Diag%dt3dt(:,:,4) + (Stateout%gt0(:,:) -dtdt(:,:) ) * frain - Diag%dq3dt(:,:,2) = Diag%dq3dt(:,:,2) + (Stateout%gq0(:,:,1)-dqdt(:,:,1)) * frain - endif - endif - endif ! moist convective adjustment over -! - if (Model%ldiag3d .or. Model%do_aw) then - dtdt(:,:) = Stateout%gt0(:,:) - dqdt(:,:,1) = Stateout%gq0(:,:,1) - do n=Model%ntcw,Model%ntcw+Model%ncld-1 - dqdt(:,:,n) = Stateout%gq0(:,:,n) - enddo - endif - -! dqdt_v : instaneous moisture tendency (kg/kg/sec) - if (Model%lgocart) then - Coupling%dqdti(:,:) = Coupling%dqdti(:,:) / dtf - endif -! -! grid-scale condensation/precipitations and microphysics parameterization -! ------------------------------------------------------------------------ - - if (Model%ncld == 0) then ! no cloud microphysics - - call lrgscl (ix, im, levs, dtp, Stateout%gt0, Stateout%gq0, & - Statein%prsl, del, Statein%prslk, rain1, clw) - - elseif (Model%ncld == 1) then ! microphysics with single cloud condensate - - if (Model%num_p3d == 4) then ! call zhao/carr/sundqvist microphysics - - if (Model%npdf3d /= 3) then ! without pdf clouds - -! if (lprnt) then -! write(0,*)' prsl=',prsl(ipr,:) -! write(0,*) ' del=',del(ipr,:) -! write(0,*) ' beflsgt0=',gt0(ipr,:),' kdt=',kdt -! write(0,*) ' beflsgq0=',gq0(ipr,:,1),' kdt=',kdt -! write(0,*) ' beflsgw0=',gq0(ipr,:,3),' kdt=',kdt -! endif - ! ------------------ - if (Model%do_shoc) then - call precpd_shoc (im, ix, levs, dtp, del, Statein%prsl, & - Stateout%gq0(1,1,1), Stateout%gq0(1,1,Model%ntcw), & - Stateout%gt0, rain1, Diag%sr, rainp, rhc, & - psautco_l, prautco_l, Model%evpco, Model%wminco, & - Tbd%phy_f3d(1,1,Model%ntot3d-2), lprnt, ipr) - else - -! call gscond (im, ix, levs, dtp, dtf, Statein%prsl, Statein%pgr, & - call gscond_run (im, ix, levs, dtp, dtf, Statein%prsl, Statein%pgr,& -! Stateout%gq0(1,1,1), Stateout%gq0(1,1,Model%ntcw), & -! Stateout%gt0, Tbd%phy_f3d(1,1,1), Tbd%phy_f3d(1,1,2), & -! Tbd%phy_f2d(1,1), Tbd%phy_f3d(1,1,3), & -! Tbd%phy_f3d(1,1,4), Tbd%phy_f2d(1,2), rhc,lprnt, ipr) - Stateout%gq0(:,:,1), Stateout%gq0(:,:,Model%ntcw), & - Stateout%gt0, Tbd%phy_f3d(:,:,1), Tbd%phy_f3d(:,:,2), & - Tbd%phy_f2d(:,1), Tbd%phy_f3d(:,:,3), & - Tbd%phy_f3d(:,:,4), Tbd%phy_f2d(:,2), rhc,lprnt, ipr) - -! call precpd (im, ix, levs, dtp, del, Statein%prsl, & - call precpd_run (im, ix, levs, dtp, del, Statein%prsl, & -! Stateout%gq0(1,1,1), Stateout%gq0(1,1,Model%ntcw), & - Stateout%gq0(:,:,1), Stateout%gq0(:,:,Model%ntcw), & - Stateout%gt0, rain1, Diag%sr, rainp, rhc, psautco_l, & - prautco_l, Model%evpco, Model%wminco, lprnt, ipr) - endif -! if (lprnt) then -! write(0,*)' prsl=',prsl(ipr,:) -! write(0,*) ' del=',del(ipr,:) -! write(0,*) ' aftlsgt0=',gt0(ipr,:),' kdt=',kdt -! write(0,*) ' aftlsgq0=',gq0(ipr,:,1),' kdt=',kdt -! write(0,*) ' aftlsgw0=',gq0(ipr,:,3),' kdt=',kdt -! write(0,*)' aft precpd rain1=',rain1(1:3),' lat=',lat -! endif - else ! with pdf clouds - ! --------------- - call gscondp (im, ix, levs, dtp, dtf, Statein%prsl, & - Statein%pgr, Stateout%gq0(1,1,1), & - Stateout%gq0(1,1,Model%ntcw), Stateout%gt0, & - Tbd%phy_f3d(1,1,1), Tbd%phy_f3d(1,1,2), & - Tbd%phy_f2d(1,1), Tbd%phy_f3d(1,1,3), & - Tbd%phy_f3d(1,1,4), Tbd%phy_f2d(1,2), rhc, & - Tbd%phy_f3d(1,1,Model%num_p3d+1), Model%sup, & - lprnt, ipr, kdt) - - call precpdp (im, ix, levs, dtp, del, Statein%prsl, & - Statein%pgr, Stateout%gq0(1,1,1), & - Stateout%gq0(1,1,Model%ntcw), Stateout%gt0, & - rain1, Diag%sr, rainp, rhc, & - Tbd%phy_f3d(1,1,Model%num_p3d+1), psautco_l, & - prautco_l, Model%evpco, Model%wminco, lprnt, ipr) - endif ! end of grid-scale precip/microphysics options - endif ! end if_num_p3d - -! if (lprnt) write(0,*) ' rain1=',rain1(ipr),' rainc=',rainc(ipr),' lat=',lat - - elseif (Model%ncld == 2) then ! MGB double-moment microphysics -! Acheng used clw here for other code to run smoothly and minimum change -! to make the code work. However, the nc and clw should be treated -! in other procceses too. August 28/2015; Hope that can be done next -! year. I believe this will make the physical interaction more reasonable -! Anning 12/5/2015 changed ntcw hold liquid only - if (Model%do_shoc) then - if (Model%fprcp == 0) then - clw(:,:,1) = Stateout%gq0(:,:,Model%ntiw) ! ice - clw(:,:,2) = Stateout%gq0(:,:,Model%ntcw) ! water - qrn(:,:) = 0. - qsnw(:,:) = 0. - ncpr(:,:) = 0. - ncps(:,:) = 0. - Tbd%phy_f3d(:,:,1) = Tbd%phy_f3d(:,:,Model%ntot3d-2) ! clouds from shoc - else - clw(:,:,1) = Stateout%gq0(:,:,Model%ntiw) ! ice - clw(:,:,2) = Stateout%gq0(:,:,Model%ntcw) ! water - qrn(:,:) = Stateout%gq0(:,:,Model%ntrw) - qsnw(:,:) = Stateout%gq0(:,:,Model%ntsw) - ncpr(:,:) = Stateout%gq0(:,:,Model%ntrnc) - ncps(:,:) = Stateout%gq0(:,:,Model%ntsnc) - Tbd%phy_f3d(:,:,1) = Tbd%phy_f3d(:,:,Model%ntot3d-2) ! clouds from shoc - end if - elseif ((Model%imfdeepcnv >= 0) .or. (Model%imfshalcnv > 0)) then - if (Model%fprcp == 0) then - clw(:,:,1) = Stateout%gq0(:,:,Model%ntiw) ! ice - clw(:,:,2) = Stateout%gq0(:,:,Model%ntcw) ! water - Tbd%phy_f3d(:,:,1) = max(0.0, min(1.0,Tbd%phy_f3d(:,:,1)+cnvc(:,:))) - ! clouds from t-dt and cnvc - qrn(:,:) = 0. - qsnw(:,:) = 0. - ncpr(:,:) = 0. - ncps(:,:) = 0. - else - clw(:,:,1) = Stateout%gq0(:,:,Model%ntiw) ! ice - clw(:,:,2) = Stateout%gq0(:,:,Model%ntcw) ! water - Tbd%phy_f3d(:,:,1) = max(0.0, min(1.0,Tbd%phy_f3d(:,:,1)+cnvc(:,:))) - ! clouds from t-dt and cnvc - qrn(:,:) = Stateout%gq0(:,:,Model%ntrw) - qsnw(:,:) = Stateout%gq0(:,:,Model%ntsw) - ncpr(:,:) = Stateout%gq0(:,:,Model%ntrnc) - ncps(:,:) = Stateout%gq0(:,:,Model%ntsnc) - endif - else - ! clouds from t-dt and cnvc - if (Model%fprcp == 0 ) then - clw(:,:,1) = Stateout%gq0(:,:,Model%ntiw) ! ice - clw(:,:,2) = Stateout%gq0(:,:,Model%ntcw) ! water - qrn(:,:) = 0. - qsnw(:,:) = 0. - ncpr(:,:) = 0. - ncps(:,:) = 0. - Tbd%phy_f3d(:,:,1) = min(1.0, Tbd%phy_f3d(:,:,1)+cnvc(:,:)) - else - clw(:,:,1) = Stateout%gq0(:,:,Model%ntiw) ! ice - clw(:,:,2) = Stateout%gq0(:,:,Model%ntcw) ! water - qrn(:,:) = Stateout%gq0(:,:,Model%ntrw) - qsnw(:,:) = Stateout%gq0(:,:,Model%ntsw) - ncpr(:,:) = Stateout%gq0(:,:,Model%ntrnc) - ncps(:,:) = Stateout%gq0(:,:,Model%ntsnc) - Tbd%phy_f3d(:,:,1) = min(1.0, Tbd%phy_f3d(:,:,1)+cnvc(:,:)) - endif - endif -! notice clw ix instead of im -! call m_micro_driver(im,ix,levs,flipv,del,dtp,prsl,prsi, -! & prslk,prsik,pgr,vvl,clw(1,1,2), QLCN, clw(1,1,1),QICN, -! if (lprnt) write(0,*)' cnv_mfdbef=',cnv_mfd(ipr,:),' flipv=',flipv -! if(lprnt) write(0,*) ' befgq0=',gq0(ipr,:,1),' kdt=',kdt -! if (lprnt) write(0,*)' clw1bef=',clw(ipr,:,1),' kdt=',kdt -! if (lprnt) write(0,*)' clw2bef=',clw(ipr,:,2),' kdt=',kdt -! if (lprnt) write(0,*)' cloudsb=',phy_f3d(ipr,:,1)*100,' kdt=',kdt -! txa(:,:) = gq0(:,:,1) - call m_micro_driver (im, ix, levs, Model%flipv, dtp, Statein%prsl, & - Statein%prsi, Statein%prslk, Statein%prsik, & - Statein%vvl, clw(1,1,2), QLCN, clw(1,1,1), QICN, & - Radtend%htrlw, Radtend%htrsw, w_upi, cf_upi, & - FRLAND, Diag%HPBL, CNV_MFD, CNV_PRC3, CNV_DQLDT, & - CLCN, Stateout%gu0, Stateout%gv0, Diag%dusfc, & - Diag%dvsfc, dusfc1, dvsfc1, dusfc1, dvsfc1, & - CNV_FICE, CNV_NDROP, CNV_NICE, Stateout%gq0(1,1,1), & - Stateout%gq0(1,1,Model%ntcw), & - Stateout%gq0(1,1,Model%ntiw), Stateout%gt0, rain1, & - Diag%sr, Stateout%gq0(1,1,Model%ntlnc), & - Stateout%gq0(1,1,Model%ntinc), Model%fprcp, qrn, & - qsnw, ncpr, ncps, Tbd%phy_f3d(1,1,1), kbot, & - Model%aero_in, skip_macro, cn_prc, cn_snr, lprnt, & - ipr, kdt, Grid%xlat, Grid%xlon) - -! write(1000+me,*)' at latitude = ',lat -! tx1 = 1000.0 -! call moist_bud(im,ix,ix,levs,me,kdt,con_g,tx1,del,rain1 -! &, txa, clw(1,1,2), clw(1,1,1) -! &, gq0(1,1,1),gq0(1,1,ntcw),gq0(1,1,ntcw+1),' m_micro ') - -! if (lprnt) write(0,*) ' rain1=',rain1(ipr)*86400.0, -! &' rainc=',rainc(ipr)*86400.0 -! &,' cn_prc=',cn_prc(ipr),' cn_snr=',cn_snr(ipr) -! if (lprnt) write(0,*) ' aftlsgq0=',gq0(ipr,:,1),' kdt=',kdt -! if (lprnt) write(0,*)' clw1aft=',gq0(ipr,:,ntiw),' kdt=',kdt -! if (lprnt) write(0,*)' cloudsm=',phy_f3d(ipr,:,1)*100,' kdt=',kdt -! if (lprnt) write(0,*)' clw2aft=',gq0(ipr,:,ntcw),' kdt=',kdt - - if (Model%fprcp == 1) then - Stateout%gq0(:,:,Model%ntrw) = qrn(:,:) - Stateout%gq0(:,:,Model%ntsw) = qsnw(:,:) - Stateout%gq0(:,:,Model%ntrnc) = ncpr(:,:) - Stateout%gq0(:,:,Model%ntsnc) = ncps(:,:) - endif - endif ! end if_ncld -! if (lprnt) write(0,*)' rain1 after ls=',rain1(ipr) -! - if (Model%do_aw) then -! Arakawa-Wu adjustment of large-scale microphysics tendencies: -! reduce by factor of (1-sigma) -! these are microphysics increments. We want to keep (1-sigma) of the increment, -! we will remove sigma*increment from final values -! fsigma = 0. ! don't apply any AW correction, in addition comment next line -! fsigma = sigmafrac - -! adjust sfc rainrate for conservation -! vertically integrate reduction of water increments, reduce precip by that amount - - temrain1(:) = 0.0 - do k = 1,levs - do i = 1,im - tem1 = sigmafrac(i,k) - Stateout%gt0(i,k) = Stateout%gt0(i,k) - tem1 * (Stateout%gt0(i,k)-dtdt(i,k)) - tem2 = tem1 * (Stateout%gq0(i,k,1)-dqdt(i,k,1)) - Stateout%gq0(i,k,1) = Stateout%gq0(i,k,1) - tem2 - temrain1(i) = temrain1(i) - (Statein%prsi(i,k)-Statein%prsi(i,k+1)) & - * tem2 * onebg - enddo - enddo - do n=Model%ntcw,Model%ntcw+Model%ncld-1 - do k = 1,levs - do i = 1,im - tem1 = sigmafrac(i,k) * (Stateout%gq0(i,k,n)-dqdt(i,k,n)) - Stateout%gq0(i,k,n) = Stateout%gq0(i,k,n) - tem1 - temrain1(i) = temrain1(i) - (Statein%prsi(i,k)-Statein%prsi(i,k+1)) & - * tem1 * onebg - enddo - enddo - enddo -! write(1000+me,*)' rain1=',rain1(4),' temrain1=',temrain1(i)*0.001 - rain1(:) = max(rain1(:) - temrain1(:)*0.001, 0.0_kind_phys) - endif - - Diag%rain(:) = Diag%rainc(:) + frain * rain1(:) - - if (Model%cal_pre) then ! hchuang: add dominant precipitation type algorithm - i = min(3,Model%num_p3d) - call calpreciptype (kdt, Model%nrcm, im, ix, levs, levs+1, & - Tbd%rann, Grid%xlat, Grid%xlon, Stateout%gt0, & - Stateout%gq0, Statein%prsl, Statein%prsi, & - Diag%rain, Statein%phii, Model%num_p3d, & - Sfcprop%tsfc, Diag%sr, Tbd%phy_f3d(1,1,i), & ! input - domr, domzr, domip, doms) ! output -! -! if (lprnt) print*,'debug calpreciptype: DOMR,DOMZR,DOMIP,DOMS ' -! &,DOMR(ipr),DOMZR(ipr),DOMIP(ipr),DOMS(ipr) -! do i=1,im -! if (abs(xlon(i)*57.29578-114.0) .lt. 0.2 .and. -! & abs(xlat(i)*57.29578-40.0) .lt. 0.2) -! & print*,'debug calpreciptype: DOMR,DOMZR,DOMIP,DOMS ', -! & DOMR(i),DOMZR(i),DOMIP(i),DOMS(i) -! end do -! HCHUANG: use new precipitation type to decide snow flag for LSM snow accumulation - - do i=1,im - if(doms(i) > 0.0 .or. domip(i) > 0.0) then - Sfcprop%srflag(i) = 1. - else - Sfcprop%srflag(i) = 0. - end if - enddo - endif - - if (Model%lssav) then - Diag%totprcp(:) = Diag%totprcp(:) + Diag%rain(:) - - if (Model%ldiag3d) then - Diag%dt3dt(:,:,6) = Diag%dt3dt(:,:,6) + (Stateout%gt0(:,:)-dtdt(:,:)) * frain - Diag%dq3dt(:,:,4) = Diag%dq3dt(:,:,4) + (Stateout%gq0(:,:,1)-dqdt(:,:,1)) * frain - endif - endif - -! --- ... estimate t850 for rain-snow decision - - t850(:) = Stateout%gt0(:,1) - - do k = 1, levs-1 - do i = 1, im - if (Statein%prsl(i,k) > p850 .and. Statein%prsl(i,k+1) <= p850) then - t850(i) = Stateout%gt0(i,k) - (Statein%prsl(i,k)-p850) / & - (Statein%prsl(i,k)-Statein%prsl(i,k+1)) * & - (Stateout%gt0(i,k)-Stateout%gt0(i,k+1)) - endif - enddo - enddo - -! --- ... lu: snow-rain detection is performed in land/sice module - - if (Model%cal_pre) then ! hchuang: new precip type algorithm defines srflag - Sfcprop%tprcp(:) = max(0.0, Diag%rain(:)) ! clu: rain -> tprcp - else - do i = 1, im - Sfcprop%tprcp(i) = max(0.0, Diag%rain(i) )! clu: rain -> tprcp - Sfcprop%srflag(i) = 0. ! clu: default srflag as 'rain' (i.e. 0) - if (t850(i) <= 273.16) then - Sfcprop%srflag(i) = 1. ! clu: set srflag to 'snow' (i.e. 1) - endif - enddo - endif - -! --- ... coupling insertion - - if (Model%cplflx .or. Model%do_sppt) then - do i = 1, im - if (t850(i) > 273.16) then - Coupling%rain_cpl(i) = Coupling%rain_cpl(i) + Diag%rain(i) - else - Coupling%snow_cpl(i) = Coupling%snow_cpl(i) + Diag%rain(i) - endif - enddo - endif - -! --- ... end coupling insertion - -!!! update surface diagnosis fields at the end of phys package -!!! this change allows gocart to use filtered wind fields -!!! - if (Model%lgocart) then - call sfc_diag (im, Statein%pgr, Stateout%gu0, Stateout%gv0, & - Stateout%gt0, Stateout%gq0, Sfcprop%tsfc, qss, & - Sfcprop%f10m, Diag%u10m, Diag%v10m, Sfcprop%t2m, & - Sfcprop%q2m, work3, evap, Sfcprop%ffmm, & - Sfcprop%ffhh, fm10, fh2) - - if (Model%lssav) then - Diag%tmpmax (:) = max(Diag%tmpmax (:),Sfcprop%t2m(:)) - Diag%tmpmin (:) = min(Diag%tmpmin (:),Sfcprop%t2m(:)) - Diag%spfhmax(:) = max(Diag%spfhmax(:),Sfcprop%q2m(:)) - Diag%spfhmin(:) = min(Diag%spfhmin(:),Sfcprop%q2m(:)) - endif - endif - -! --- ... total runoff is composed of drainage into water table and -! runoff at the surface and is accumulated in unit of meters - if (Model%lssav) then - tem = dtf * 0.001 - Diag%runoff(:) = Diag%runoff(:) + (drain(:)+runof(:)) * tem - Diag%srunoff(:) = Diag%srunoff(:) + runof(:) * tem - endif - -! --- ... xw: return updated ice thickness & concentration to global array - do i = 1, im - if (islmsk(i) == 2) then - Sfcprop%hice(i) = zice(i) - Sfcprop%fice(i) = cice(i) - Sfcprop%tisfc(i) = tice(i) - else - Sfcprop%hice(i) = 0.0 - Sfcprop%fice(i) = 0.0 - Sfcprop%tisfc(i) = Sfcprop%tsfc(i) - endif - enddo - -! --- ... return updated smsoil and stsoil to global arrays - Sfcprop%smc(:,:) = smsoil(:,:) - Sfcprop%stc(:,:) = stsoil(:,:) - Sfcprop%slc(:,:) = slsoil(:,:) - -! --- ... calculate column precipitable water "pwat" - Diag%pwat(:) = 0.0 - tem = dtf * 0.03456 / 86400.0 - do k = 1, levs - work1(:) = 0.0 - if (Model%ncld > 0) then - do ic = Model%ntcw, Model%ntcw+Model%ncld-1 - work1(:) = work1(:) + Stateout%gq0(:,k,ic) - enddo - endif - Diag%pwat(:) = Diag%pwat(:) + del(:,k)*(Stateout%gq0(:,k,1)+work1(:)) -! if (lprnt .and. i == ipr) write(0,*)' gq0=', -! &gq0(i,k,1),' qgrs=',qgrs(i,k,1),' work2=',work2(i),' k=',k - enddo - Diag%pwat(:) = Diag%pwat(:) * onebg - -! write(1000+me,*)' pwat=',pwat(i),'i=',i,', -! &' rain=',rain(i)*1000.0,' dqsfc1=',dqsfc1(i)*tem,' kdt=',kdt -! &,' e-p=',dqsfc1(i)*tem-rain(i)*1000.0 -! if (lprnt) write(0,*)' pwat=',pwat(ipr),', -! &' rain=',rain(ipr)*1000.0,' dqsfc1=',dqsfc1(ipr)*tem,' kdt=',kdt -! &,' e-p=',dqsfc1(ipr)*tem-rain(ipr)*1000.0 - -! -! if (lprnt .and. rain(ipr) > 5) call mpi_quit(5678) -! if (lat == 45) write(1000+me,*)' pwat=',pwat(1),' kdt=',kdt -! if (lprnt) then -! write(7000,*) ' endgu0=',gu0(ipr,:),' kdt=',kdt -! write(7000,*) ' endgv0=',gv0(ipr,:),' kdt=',kdt,' nnp=',nnp -! write(0,*) ' endgt0=',gt0(ipr,:),' kdt=',kdt -! write(0,*) ' endgq0=',gq0(ipr,:,1),' kdt=',kdt,' lat=',lat -! write(0,*) ' endgw0=',gq0(ipr,:,3),' kdt=',kdt,' lat=',lat -! endif - - if (Model%do_sppt) then - !--- radiation heating rate - Tbd%dtdtr(:,:) = Tbd%dtdtr(:,:) + dtdtc(:,:)*dtf - !--- change in total precip - Tbd%dtotprcp (:) = Diag%rain (:) - Tbd%dtotprcp(:) - !--- change in convective precip - Tbd%dcnvprcp (:) = Diag%rainc (:) - Tbd%dcnvprcp(:) - do i = 1, im - if (t850(i) > 273.16) then - !--- change in change in rain precip - Tbd%drain_cpl(i) = Diag%rain(i) - Tbd%drain_cpl(i) - else - !--- change in change in snow precip - Tbd%dsnow_cpl(i) = Diag%rain(i) - Tbd%dsnow_cpl(i) - endif - enddo - endif - - deallocate (clw) - if (Model%do_shoc) then - deallocate (qpl, qpi, ncpl, ncpi) - endif - if (allocated(cnvc)) deallocate(cnvc) - if (allocated(cnvw)) deallocate(cnvw) - -! deallocate (fscav, fswtr) -! -! if (lprnt) write(0,*)' end of gbphys maxu=', -! &maxval(gu0(1:im,1:levs)),' minu=',minval(gu0(1:im,1:levs)) -! &,' maxv=',maxval(gv0(1:im,1:levs)),' minv=', -! & minval(gv0(1:im,1:levs)),' kdt=',kdt,' lat=',lat,' nnp=',nnp -! if (lprnt) write(0,*)' end of gbphys gv0=',gv0(:,120:128) -! if (lprnt) write(0,*)' end of gbphys at kdt=',kdt, -! &' rain=',rain(ipr),' rainc=',rainc(ipr) -! if (lprnt) call mpi_quit(7) -! if (kdt > 2 ) call mpi_quit(70) - if (Model%ncld == 2) then ! For MGB double moment microphysics - - deallocate (qlcn, qicn, w_upi, cf_upi, CNV_MFD, CNV_PRC3, & - CNV_DQLDT, clcn, cnv_fice, cnv_ndrop, cnv_nice) - deallocate (qrn, qsnw, ncpr, ncps) - endif - - return -!................................... - end subroutine GFS_physics_driver -!----------------------------------- - - - subroutine moist_bud(im,ix,ix2,levs,me,kdt,grav,dtp,delp,rain, & - qv0,ql0,qi0,qv1,ql1,qi1,comp) -! nov 2016 - S. Moorthi - routine to compute local moisture budget - use machine, only : kind_phys - implicit none - character*10 :: comp - integer :: im,ix,ix2,levs,me,kdt - real (kind=kind_phys) :: grav, rain(im), dtp - real (kind=kind_phys), dimension(ix,levs) :: qv0,ql0,qi0,delp - real (kind=kind_phys), dimension(ix2,levs) :: qv1,ql1,qi1 - REAL (kind=kind_phys), dimension(im) :: sumq, sumqv, sumql, sumqi - integer :: i, k -! - sumqv(:) = 0.0 - sumql(:) = 0.0 - sumqi(:) = 0.0 - sumq (:) = 0.0 - do i=1,im - sumqv(:) = sumqv(:) + (qv1(:,k) - qv0(:,k)) * delp(:,k) - sumql(:) = sumql(:) + (ql1(:,k) - ql0(:,k)) * delp(:,k) - sumqi(:) = sumqi(:) + (qi1(:,k) - qi0(:,k)) * delp(:,k) - enddo - sumqv(:) = - sumqv(:) * (1.0/grav) - sumql(:) = - sumql(:) * (1.0/grav) - sumqi(:) = - sumqi(:) * (1.0/grav) - sumq (:) = sumqv(:) + sumql(:) + sumqi(:) - do i=1,im - write(1000+me,*)' in moist_bud:',' i=',i,' sumq=',sumq(i), & - ' sumqv=',sumqv(i),' sumql=',sumql(i),' sumqi=',sumqi(i), & - ' rain=',rain(i)*dtp,' kdt=',kdt,' component=',comp, & - ' qv:=',qv1(i,1),qv0(i,1),' ql=',ql1(i,1),ql0(i,1), & - ' qi=',qi1(i,1), qi0(i,1) -! if(sumq(i) > 100) then -! write(1000+me,*)' i=',i,' sumq=',sumq(i) -! write(1000+me,*)' qv1=',(qv1(i,k),k=1,levs) -! write(1000+me,*)' qv0=',(qv0(i,k),k=1,levs) -! write(1000+me,*)' ql1=',(ql1(i,k),k=1,levs) -! write(1000+me,*)' ql0=',(ql0(i,k),k=1,levs) -! write(1000+me,*)' qi1=',(qi1(i,k),k=1,levs) -! write(1000+me,*)' qi0=',(qi0(i,k),k=1,levs) -! endif - enddo - return - - end subroutine moist_bud -!> @} - -end module module_physics_driver diff --git a/GFS_layer/GFS_physics_driver.F90.study b/GFS_layer/GFS_physics_driver.F90.study deleted file mode 100644 index 68e0a6e1d..000000000 --- a/GFS_layer/GFS_physics_driver.F90.study +++ /dev/null @@ -1,2866 +0,0 @@ -module module_physics_driver - - use machine, only: kind_phys - use physcons, only: con_cp, con_fvirt, con_g, con_rd, & - con_rv, con_hvap, con_hfus, & - con_rerth, con_pi, rhc_max, dxmin,& - dxinv, pa2mb, rlapse - use cs_conv, only: cs_convr - use ozne_def, only: levozp, oz_coeff, oz_pres - use h2o_def, only: levh2o, h2o_coeff, h2o_pres - use gfs_fv3_needs, only: get_prs_fv3, get_phi_fv3 - use module_nst_water_prop, only: get_dtzm_2d - use GFS_typedefs, only: GFS_statein_type, GFS_stateout_type, & - GFS_sfcprop_type, GFS_coupling_type, & - GFS_control_type, GFS_grid_type, & - GFS_tbd_type, GFS_cldprop_type, & - GFS_radtend_type, GFS_diag_type - - use zhaocarr_gscond, only: gscond_init, gscond_run - use zhaocarr_precpd, only: precpd_init, precpd_run - implicit none - - - !--- CONSTANT PARAMETERS - real(kind=kind_phys), parameter :: hocp = con_hvap/con_cp - real(kind=kind_phys), parameter :: qmin = 1.0e-10 - real(kind=kind_phys), parameter :: p850 = 85000.0 - real(kind=kind_phys), parameter :: epsq = 1.e-20 - real(kind=kind_phys), parameter :: hsub = con_hvap+con_hfus - real(kind=kind_phys), parameter :: czmin = 0.0001 ! cos(89.994) - real(kind=kind_phys), parameter :: onebg = 1.0/con_g - real(kind=kind_phys), parameter :: albdf = 0.06 - real(kind=kind_phys) tf, tcr, tcrf - parameter (tf=258.16, tcr=273.16, tcrf=1.0/(tcr-tf)) - - -!> GFS Physics Implementation Layer -!> @brief Layer that invokes individual GFS physics routines -!> @{ -!at tune step===========================================================! -! description: ! -! ! -! usage: ! -! ! -! call gbphys ! -! ! -! --- interface variables ! -! type(GFS_control_type), intent(in) :: Model ! -! type(GFS_statein_type), intent(inout) :: Statein ! -! type(GFS_stateout_type), intent(inout) :: Stateout ! -! type(GFS_sfcprop_type), intent(inout) :: Sfcprop ! -! type(GFS_coupling_type), intent(inout) :: Coupling ! -! type(GFS_grid_type), intent(in) :: Grid ! -! type(GFS_tbd_type), intent(inout :: Tbd ! -! type(GFS_cldprop_type), intent(inout) :: Cldprop ! -! type(GFS_radtend_type), intent(inout) :: Radtend ! -! type(GFS_diag_type), intent(inout) :: Diag ! -! ! -! subprograms called: ! -! ! -! get_prs, dcyc2t2_pre_rad (testing), dcyc2t3, sfc_diff, ! -! sfc_ocean,sfc_drv, sfc_land, sfc_sice, sfc_diag, moninp1, ! -! moninp, moninq1, moninq, gwdps, ozphys, get_phi, ! -! sascnv, sascnvn, rascnv, cs_convr, gwdc, shalcvt3,shalcv,! -! shalcnv, cnvc90, lrgscl, gsmdrive, gscond, precpd, ! -! progt2. ! -! ! -! ! -! program history log: ! -! 19xx - ncep mrf/gfs ! -! 2002 - s. moorthi modify and restructure and add Ferrier ! -! microphysics as an option ! -! 200x - h. juang modify (what?) ! -! nov 2004 - x. wu modify sea-ice model ! -! may 2005 - s. moorthi modify and restructure ! -! 2005 - s. lu modify to include noah lsm ! -! oct 2006 - h. wei modify lsm options to include both ! -! noah and osu lsms. ! -! 2006 - s. moorthi added a. johansson's convective gravity ! -! wave parameterization code ! -! 2007 - s. moorthi added j. han's modified pbl/sas options ! -! dec 2007 - xu li modified the operational version for ! -! nst model ! -! 2008 - s. moorthi applied xu li's nst model to new gfs ! -! mar 2008 - y.-t. hou added sunshine duration var (suntim) as ! -! an input/output argument. ! -! 2008 - jun wang added spfhmax/spfhmin as input/output. ! -! apr 2008 - y.-t. hou added lw sfc emissivity var (sfcemis), ! -! define the lw sfc dn/up fluxes in two forms: atmos! -! and ground. also changed sw sfc net flux direction! -! (positive) from ground -> atmos to the direction ! -! of atmos -> ground. recode the program and add ! -! program documentation block. -! 2008/ - s. moorthi and y.t. hou upgraded the code to more ! -! 2009 modern form and changed all the inputs to MKS units.! -! feb 2009 - s. moorthi upgraded to add Hochun's gocart changes ! -! jul 2009 - s. moorthi added rqtk for sela's semi-lagrangian ! -! aug 2009 - s. moorthi added j. han and h. pan updated shallow ! -! convection package ! -! sep 2009 - s. moorthi updated for the mcica (rrtm3) radiation ! -! dec 2010 - sarah lu lgocart added to input arg; ! -! compute dqdt_v if inline gocart is on ! -! feb 2011 - sarah lu add the option to update surface diag ! -! fields (t2m,q2m,u10m,v10m) at the end ! -! Jun 2011 - s. moorthi and Xu Li - updated the nst model ! -! ! -! sep 2011 - sarah lu correct dqdt_v calculations ! -! apr 2012 - henry juang add idea ! -! sep 2012 - s. moorthi merge with operational version ! -! Mar 2013 - Jun Wang set idea heating rate to tmp tendency ! -! May 2013 - Jun Wang tmp updated after idea phys ! -! Jun 2013 - s. moorthi corrected a bug in 3d diagnostics for T ! -! Aug 2013 - s. moorthi updating J. Whitekar's changes related ! -! to stochastic physics perturnbation ! -! Oct 2013 - Xingren Wu add dusfci/dvsfci ! -! Mar 2014 - Xingren Wu add "_cpl" for coupling ! -! Mar 2014 - Xingren Wu add "nir/vis beam and nir/vis diff" ! -! Apr 2014 - Xingren Wu add "NET LW/SW including nir/vis" ! -! Jan 2014 - Jun Wang merge Moorthi's gwdc change and H.Juang ! -! and F. Yang's energy conversion from GWD! -! jan 2014 - y-t hou revised sw sfc spectral component fluxes! -! for coupled mdl, added estimation of ocean albedo ! -! without ice contamination. ! -! Jun 2014 - Xingren Wu update net SW fluxes over the ocean ! -! (no ice contamination) ! -! Jul 2014 - Xingren Wu add Sea/Land/Ice Mask - slmsk_cpl ! -! Jul 2014 - s. moorthi merge with standalone gfs and cleanup ! -! Aug 2014 - s. moorthi add tracer fixer ! -! Sep 2014 - Sarah Lu disable the option to compute tracer ! -! scavenging in GFS phys (set fscav=0.) ! -! Dec 2014 - Jun Wang add cnvqc_v for gocart ! - -! ==================== defination of variables ==================== ! -! --- 2014 - D. Dazlich Added Chikira-Sugiyama (CS) convection ! -! as an option in opr GFS. ! -! Apr 2015 S. Moorthi Added CS scheme to NEMS/GSM ! -! Jun 2015 S. Moorthi Added SHOC to NEMS/GSM ! -! Aug 2015 - Xu Li change nst_fcst to be nstf_name ! -! and introduce depth mean SST ! -! Sep 2015 - Xingren Wu remove oro_cpl & slmsk_cpl ! -! Sep 2015 - Xingren Wu add sfc_cice ! -! Sep 2015 - Xingren Wu connect CICE output to sfc_cice ! -! Jan 2016 - P. Tripp NUOPC/GSM merge ! -! Mar 2016 - J. Han - add ncnvcld3d integer ! -! for convective cloudiness enhancement ! -! Mar 2016 - J. Han - change newsas & sashal to imfdeepcnv ! -! & imfshalcnv, respectively ! -! Mar 2016 F. Yang add pgr to rayleigh damping call ! -! Mar 2016 S. Moorthi add ral_ts ! -! Mar 2016 Ann Cheng add morrison 2m microphysics (gsfc) ! -! May 2016 S. Moorthi cleanup 2m microphysics implementation ! -! Jun 2016 X. Li change all nst_fld as inout ! -! jul 2016 S. Moorthi fix some bugs in shoc/2m microphysics ! -! au-nv2016a S. Moorthi CS with AW and connect with shoc/2m ! -! Dec 2016 Anning C. Add prognostic rain and snow with 2M ! -! -! ==================== end of description ===================== -! ==================== definition of variables ==================== ! - -!> @details This subroutine is the suite driver for the GFS atmospheric physics and surface. -!! It is responsible for calculating and applying tendencies of the atmospheric state -!! variables due to the atmospheric physics and due to the surface layer scheme. In addition, -!! this routine applies radiative heating rates that were calculated during the -!! antecedent call to the radiation scheme. Code within this subroutine is executed on the -!! physics sub-timestep. The sub-timestep loop is executed in the subroutine gloopb. -!! -!! \section general General Algorithm -!! -# Prepare input variables for calling individual parameterizations. -!! -# Using a two-iteration loop, calculate the state variable tendencies for the surface layer. -!! -# Calculate the state variable tendencies due to the PBL (vertical diffusion) scheme. -!! -# Calculate the state variable tendencies due to orographic gravity wave drag and Rayleigh damping. -!! -# Apply tendencies to the state variables calculated so far: -!! - for temperature: radiation, surface, PBL, oro. GWD, Rayleigh damping -!! - for momentum: surface, PBL, oro. GWD, Rayleigh damping -!! - for water vapor: surface, PBL -!! -# Calculate and apply the tendency of ozone. -!! -# Prepare input variables for physics routines that update the state variables within their subroutines. -!! -# If SHOC is active and is supposed to be called before convection, call it and update the state variables within. -!! -# Calculate and apply the state variable tendencies (within the subroutine) due to deep convection. -!! -# Calculate the state variable tendencies due to convective gravity wave drag and apply them afterwards. -!! -# Calculate and apply the state variable tendencies (within the subroutine) due to shallow convection. -!! -# If SHOC is active and is supposed to be called after convection, call it and update the state variables within. -!! -# Prepare for microphysics call by calculating preliminary variables. -!! -# If necessary, call the moist convective adjustment subroutine and update the state temperature and moisture variable within. -!! -# Calculate and apply the state variable tendencies (within the subroutine) due to microphysics. -!! -# Determine the precipitation type and update land surface properties if necessary. -!! -# Fill the output variables from the local variables as necessary and deallocate allocatable arrays. -!! \section detailed Detailed Algorithm -!! ## Prepare input variables for calling individual parameterizations. -!! Before calling any parameterizations, there is a section at the beginning of the subroutine for -!! preparing input arguments to the various schemes based on general input to the driver and initializing -!! variables used throughout the driver. -!! - General initialization: -!! - set a flag for running in debug mode and the horizontal index of the column to print -!! - calculate the pressure at layer centers, the exner function at layer centers and interfaces, -!! geopotential at layer centers and interfaces, and the layer-centered pressure difference -!! - calculate the ratio of dynamics time step to physics time step for applying tendencies -!! - initialize local tendency arrays to zero -!! - Radiation: -!! - adjust radiative fluxes and heating rates to the shorter physics time step (from the longer radiation time step), -!! unless idealized physics is true (lsidea) where radiative heating rates are set to 0 -!! - compute diagnostics from the radiation scheme needed for other schemes (e.g., downward longwave flux absorbed by the surface) -!! - accumulate the upward and downward longwave fluxes at the surface -!! - Surface: -!! - set NOAH and OSU scheme variables from gbphys input arguments and initialize local soil moisture variables -!! - set local sea ice variables from gbphys arguments -!! - set up A/O/I coupling variables from gbphys arguments -!! - PBL: -!! - set the number of tracers that are diffused vertically -!! - SHOC: -!! - determine the index of TKE (ntk) in the convectively transported tracer array (clw) -!! - allocate precipitation mixing ratio cloud droplet number concentration arrays -!! - Deep Convection: -!! - determine which tracers in the tracer input array undergo convective transport (valid only for the RAS and Chikira-Sugiyama schemes) and allocate a local convective transported tracer array (clw) -!! - apply an adjustment to the tracers from the dynamics -!! - calculate horizontal grid-related parameters needed for some parameterizations -!! - calculate the maxiumum cloud base updraft speed for the Chikira-Sugiyama scheme -!! - allocate array for cloud water and cloud cover (for non-RAS and non-Chikira-Sugiyama deep convective schemes) -!! - Shallow Convection: -!! - when using the Tiedtke shallow convection scheme with the stratus modifications, find the lowest -!! model level where a temperature inversion exists in the absence of CTEI -!! - Microphysics: -!! - for the Morrison (MGB) scheme, calculate 'FRLAND' if the grid point is over land -!! - allocate arrays associated with the Morrison scheme -!! - assign the local critical relative humidity variables from the gbphys arguments -!! - Gravity Wave Drag: -!! - calculate the deep convective cloud fraction at cloud top for the convective GWD scheme -!! . -!! ## Using a two-iteration loop, calculate the state variable tendencies for the surface layer. -!! - Each iteration of the loop calls the following: -!! - 'sfc_diff' to calculate surface exchange coefficients and near-surface wind -!! - surface energy balances routines are called regardless of surface type; the surface type is checked within each to determine whether the routine is "active" -!! - for the surface energy balance over the ocean, call 'sfc_nst' if NSST is on, otherwise, call 'sfc_ocean' -!! - for the surface energy balance over the land, call 'sfc_drv' for the NOAH model and 'sfc_land' for the OSU model -!! - for the surface energy balance over sea ice, call sfc_sice; if A/O/I coupling, call sfc_cice -!! - The initial iteration has flag_guess = F unless wind < 2 m/s; flag_iter = T -!! - After the initial iteration, flag_guess = F and flag_iter = F (unless wind < 2 m/s and over a land surface or an ocean surface with NSST on) -!! - The following actions are performed after the iteration to calculate surface energy balance: -!! - set surface output variables from their local values -!! - call 'sfc_diag' to calculate state variable values at 2 and 10 m as appropriate from near-surface model levels and the surface exchange coefficients -!! - if A/O/I coupling, set coupling variables from local variables and calculate the open water albedo -!! - finally, accumulate surface-related diagnostics and calculate the max/min values of T and q at 2 m height. -!! . -!! ## Calculate the state variable tendencies due to the PBL (vertical diffusion) scheme. -!! - Call the vertical diffusion scheme (PBL) based on the following logical flags: do_shoc, hybedmf, old_monin, mstrat -!! - the PBL scheme is expected to return tendencies of the state variables -!! - If A/O/I coupling and the surface is sea ice, overwrite some surface-related variables to their states before PBL was called -!! - For diagnostics, do the following: -!! - accumulate surface state variable tendencies and set the instantaneous values for output -!! - accumulate the temperature tendency due to the PBL scheme in dt3dt(:,:,3), subtracting out the radiative heating rate if necessary -!! - accumulate the u, v tendencies due to the PBL in du3dt(:,:,1:2) and dv3dt(:,:,1:2) -!! - accumulate the water vapor tendency due to the PBL in dq3dt(:,:,1) -!! - accumulate the ozone tendency in dq3dt(:,:,5) -!! . -!! ## Calculate the state variable tendencies due to orographic gravity wave drag and Rayleigh damping. -!! - Based on the variable nmtvr, unpack orographic gravity wave varibles from the hprime array -!! - Call 'gwdps' to calculate tendencies of u, v, T, and surface stress -!! - Accumulate gravity wave drag surface stresses. -!! - Accumulate change in u, v, and T due to oro. gravity wave drag in du3dt(:,:,2), dv3dt(:,:,2), and dt3dt(:,:,2) -!! - Call 'rayleigh_damp' to calculate tendencies to u, v, and T due to Rayleigh friction -!! . -!! ## Apply tendencies to the state variables calculated so far. -!! ## Calculate and apply the tendency of ozone. -!! - Call the convective adjustment scheme for IDEA -!! - Call 'ozphys_2015' or 'ozphys' depending on the value of pl_coeff, updating the ozone tracer within and outputing the tendency of ozone in dq3dt(:,:,6) -!! - Call 'h20phys' if necessary ("adaptation of NRL H20 phys for stratosphere and mesophere") -!! . -!! ## Prepare input variables for physics routines that update the state variables within their subroutines. -!! - If diagnostics is active, save the updated values of the state variables in 'dudt', 'dvdt', 'dTdt', and 'dqdt(:,:,1)' -!! - Call 'get_phi' to calculate geopotential from p, q, T -!! - Initialize the cloud water and ice portions of the convectively transported tracer array (clw) and (if the deep convective scheme is not RAS or Chikira-Sugiyama) the convective cloud water and cloud cover. -!! - If the dep convective scheme is RAS or Chikira-Sugiyama, fill the 'clw' array with tracers to be transported by convection -!! - Initialize 'ktop' and 'kbot' (to be modified by all convective schemes except Chikira-Sugiyama) -!! - Prepare for microphysics call (if cloud condensate is in the input tracer array): -!! - all schemes: calculate critical relative humidity -!! - Morrison et al. scheme (occasionally denoted MGB) (when ncld==2): set clw(:,:,1) to cloud ice and clw(:,:,2) to cloud liquid water -!! - Ferrier scheme (num_p3d==3): set the cloud water variable and separate hydrometeors into cloud ice, cloud water, and rain; set clw(:,:,1) to cloud ice and clw(:,:,2) to cloud liquid water -!! - Zhao-Carr scheme (num_p3d==4): calculate autoconversion coefficients from input constants and grid info; set set clw(:,:,1) to cloud liquid water -!! - otherwise: set autoconversion parameters like in Zhao-Carr and set critical relative humidity to 1 -!! . -!! ## If SHOC is active and is supposed to be called before convection, call it and update the state variables within. -!! - Prior to calling SHOC, prepare some microphysics variables: -!! - if Morrison et al. scheme: set 'skip_macro', fill clw(:,:,1,2) with cloud ice, liquid from the tracer array, and fill cloud droplet number concentration arrays from the input tracer array -!! - if Zhao-Carr scheme: initialize precip. mixing ratios to 0, fill clw(:,:,1,2) with cloud ice, liquid from the tracer array (as a function of temperature) -!! - Call 'shoc' (modifies state variables within the subroutine) -!! - Afterward, set updated cloud number concentrations in the tracer array from the updated 'ncpl' and 'ncpi' -!! . -!! ## Calculate and apply the state variable tendencies (within the subroutine) due to deep convection. -!! - Call deep convective scheme according to the parameter 'imfdeepcnv', 'ras', and 'cscnv'. -!! - if imfdeepcnv == 0, 1, or 2, no special processing is needed -!! - if the Chikira-Sugiyama scheme (cscnv), convert rain rate to accumulated rain (rain1) -!! - if RAS, initialize 'ccwfac', 'dlqfac', 'lmh', and revap before the call to 'rascnv' -!! - Zero out 'cld1d' (cloud work function calculated in non-RAS, non-Chikira-Sugiyama schemes) -!! - If 'lgocart', accumulate convective mass fluxes and convective cloud water -!! - Update tracers in the tracer array (gq0) due to convective transport (RAS, CS only) from the 'clw' array -!! - Calculate accumulated surface convective precip. for this physics time step (rainc) -!! - If necessary, accumulate cloud work function, convective precipitation, and convective mass fluxes; accumulate dt3dt(:,:,4), dq3dt(:,:,2), du3dt(:,:,3), dv3dt(:,:,3) as change in state variables due to deep convection -!! - If 'lgocart', repeat the accumulation of convective mass fluxes and convective cloud water; save convective tendency for water vapor in 'dqdt_v' -!! - If PDF-based clouds are active and Zhao-Carr microphysics, save convective cloud cover and water in 'phy_f3d' array -!! - otherwise, if non-PDF-based clouds and the "convective cloudiness enhancement" is active, save convective cloud water in 'phy_f3d' array -!! . -!! ## Calculate the state variable tendencies due to convective gravity wave drag and apply them afterwards. -!! - Calculate the average deep convective heating rate in the column to pass into 'gwdc' -!! - Call 'gwdc' to calculate tendencies of u, v due to convective GWD -!! - For diagnostics, accumulate the vertically-integrated change in u, v due to conv. GWD; accumulate change in u, v, due to conv. GWD in du3dt(:,:,4) and dv3dt(:,:,4) -!! - Calculate updated values of u, v, T using conv. GWD tendencies -!! . -!! ## Calculate and apply the state variable tendencies (within the subroutine) due to shallow convection. -!! - If diagnostics are active, set 'dtdt' and 'dqdt' to updated values of T and q before shallow convection -!! - If SHOC is not active, do the following: -!! - for the mass-flux shallow convection scheme (imfdeepcnv == 1), call 'shalcnv' -!! - for the scale- and aerosol-aware scheme (imfshalcnv == 2), call 'mfshalcnv' -!! - for either of the first two schemes, perform the following after the call: -!! - if Zhao-Carr microphysics with PDF-based clouds, save convective cloud water an cover in 'phy_f3d' -!! - if non-PDF-based clouds and convective cloudiness enhancement is active, save convective cloud water in 'phy_f3d' -!! - calculate shallow convective precip. and add it to convective precip; accumulate convective precip. -!! - for the Tiedtke scheme (imfshalcnv == 0), find the top level where shallow convection must stratosphere -!! - if using Moorthi's approach to stratus, call 'shalcv' -!! - otherwise, call 'shalcvt3' -!! - for diagnostics, accumulate the change in water vapor due to shallow convection and save in dqdt_v if 'lgocart'; -!! - save the change in T and q due to shallow convection in dt3dt(:,:,5) and dq3dt(:,:,3); reset dtdt and dqdt to the updated values of T, q after shallow Convection -!! - if 'clw' is not partitioned into ice/water, set 'clw(ice)' to zero -!! - If SHOC is active (and shocaftcnv) -!! - if Morrison et al. scheme: set 'skip_macro' and fill cloud droplet number concentration arrays from the input tracer array -!! - initialize precip. mixing ratios to 0 -!! - call 'shoc' (modifies state variables within the subroutine) -!! - afterward, set updated cloud number concentrations in the tracer array from the updated 'ncpl' and 'ncpi' -!! . -!! ## Prepare for microphysics call by calculating preliminary variables. -!! - For Morrison et al. microphysics, set cloud water and ice arrays to the convecitvely transported values -!! - For Ferrier microphysics, combine convectively transported cloud water and ice with column rain and save in cloud water array -!! - calculate and save ice fraction and rain fraction in phy_f3d(1),(2) -!! - For Zhao-Carr, combine convectively transported cloud water and ice into the cloud water array -!! - Otherwise, combine convectively transported cloud water and ice into the convectively transported cloud water -!! - Call 'cnvc90'; a "legacy routine which determines convective clouds"; outputs 'acv','acvb','acvt','cv','cvb','cvt' -!! . -!! ## If necessary, call the moist convective adjustment subroutine and update the state temperature and moisture variable within. -!! - Updates T, q, 'rain1', cloud water array -!! - Accumulate convective precip -!! - For diagnostics, accumulate the change in T, q due to moist convective adjustment; reset 'dtdt' and 'dqdt' to updated T, q before call to microphysics -!! . -!! ## Calculate and apply the state variable tendencies (within the subroutine) due to microphysics. -!! - If 'lgocart', calculate instantaneous moisture tendency in dqdt_v -!! - If no cloud microphysics (ncld == 0), call 'lrgscl' to update T, q and output large scale precipitation and cloud water -!! - Otherwise, a more advanced microphysics scheme is called (which scheme depends on values of 'num_p3d','do_shoc',and 'ncld') -!! - Ferrier scheme (num_p3d == 3): -!! - calculate droplet number concentration and minimum large ice fraction -!! - call 'gsmdrive' (modifies T, q, cloud water, 'f_ice', 'f_rain', 'f_rimef', 'rain1') -!! - Zhao-Carr-Sundqvist scheme (num_p3d == 4): -!! - if non-PDF-based clouds: -!! - if 'do_shoc', call 'precpd_shoc' (precpd modified for SHOC) -!! - else, call 'gscond' (grid-scale condensation/evaporation); updates water vapor, cloud water, temperature -!! - call 'precpd'; updates water vapor, cloud water, temperature and outputs precip., snow ratio, and rain water path -!! - for PDF-based clouds: -!! - call 'gscondp' followed by 'precpdp' (similar arguments to gscond, precpd above) -!! - Morrison et al. scheme (ncld = 2): -!! - if 'do_shoc', set clw(1),(2) from updated values; set phy_f3d(:,:,1) from phy_f3d(:,:,ntot3d-2) -!! - else, set clw(1),(2) from updated values; set phy_f3d(:,:,1) to cloud cover from previous time step + convective cloud water from convective scheme -!! - call 'm_micro_driver'; updates water vapor, temperature, droplet number concentrations, cloud cover -!! - Combine large scale and convective precip. -!! - For diagnostics, accumulate total surface precipitation and accumulate change in T and q due to microphysics in dt3dt(:,:,6) and dq3dt(:,:,4) -!! . -!! ## Determine the precipitation type and update land surface properties if necessary. -!! - If 'cal_pre', diagnose the surface precipitation type -!! - call 'calpreciptype'; set snow flag to 1 if snow or sleet, 0 otherwise -!! - For rain/snow decision, calculate temperature at 850 hPa (\f$T_{850}\f$) -!! - If not 'cal_pre', set snow flag to 1 if \f$T_{850}\f$ is below freezing -!! - For coupling, accumulate rain if \f$T_{850}\f$ is above freezing, otherwise accumulate snow -!! - If using the OSU land model, accumulate surface snow depth if \f$T_{850}\f$ is below freezing and not over an ocean surface -!! - call 'progt2' (canopy and soil moisture?) and set the soil liquid water equal to soil total water -!! - if 'lgocart', call 'sfc_diag' to update near-surface state variables (this "allows gocart to use filtered wind fields") -!! - If necessary (lssav), update the 2m max/min values of T and q -!! - If necessary (lssav), accumulate total runoff and surface runoff. -!! . -!! ## Fill the output variables from the local variables as necessary and deallocate allocatable arrays. -!! - Set global sea ice thickness and concentration as well as the temperature of the sea ice -!! - Set global soil moisture variables -!! - Calculate precipitable water and water vapor mass change due to all physics for the column -!! - Deallocate arrays for SHOC scheme, deep convective scheme, and Morrison et al. microphysics - - - public GFS_physics_driver - - CONTAINS -!******************************************************************************************* - - subroutine GFS_physics_driver & - (Model, Statein, Stateout, Sfcprop, Coupling, & - Grid, Tbd, Cldprop, Radtend, Diag) - - implicit none -! -! --- interface variables - type(GFS_control_type), intent(in) :: Model - type(GFS_statein_type), intent(inout) :: Statein - type(GFS_stateout_type), intent(inout) :: Stateout - type(GFS_sfcprop_type), intent(inout) :: Sfcprop - type(GFS_coupling_type), intent(inout) :: Coupling - type(GFS_grid_type), intent(in) :: Grid - type(GFS_tbd_type), intent(inout) :: Tbd - type(GFS_cldprop_type), intent(inout) :: Cldprop - type(GFS_radtend_type), intent(inout) :: Radtend - type(GFS_diag_type), intent(inout) :: Diag -! -! --- local variables - - !--- INTEGER VARIABLES - integer :: me, lprint, ipr, ix, im, levs, ntrac, nvdiff, kdt - integer :: i, kk, ic, k, n, k1, iter, levshcm, tracers, & - trc_shft, tottracer, num2, num3, nshocm, nshoc, ntk - - integer, dimension(size(Grid%xlon,1)) :: & - kbot, ktop, kcnv, soiltyp, vegtype, kpbl, slopetyp, kinver, & - lmh, levshc, islmsk, & - !--- coupling inputs for physics - islmsk_cice - - !--- LOGICAL VARIABLES - logical :: lprnt, revap, do_awdd - - logical, dimension(size(Grid%xlon,1)) :: & - flag_iter, flag_guess, invrsn, skip_macro, & - !--- coupling inputs for physics - flag_cice - - logical, dimension(Model%ntrac-Model%ncld+2,2) :: & - otspt - - !--- REAL VARIABLES - real(kind=kind_phys) :: & - dtf, dtp, rhbbot, rhbtop, rhpbl, frain, tem, tem1, tem2, & - xcosz_loc, zsea1, zsea2, eng0, eng1, dpshc, & - !--- experimental for shoc sub-stepping - dtshoc - - real(kind=kind_phys), dimension(size(Grid%xlon,1)) :: & - ccwfac, garea, dlength, cumabs, cice, zice, tice, gflx, & - rain1, raincs, snowmt, cd, cdq, qss, dusfcg, dvsfcg, dusfc1, & - dvsfc1, dtsfc1, dqsfc1, rb, drain, cld1d, evap, hflx, & - stress, t850, ep1d, gamt, gamq, sigmaf, oc, theta, gamma, & - sigma, elvmax, wind, work1, work2, runof, xmu, fm10, fh2, & - tsurf, tx1, tx2, ctei_r, evbs, evcw, trans, sbsno, snowc, & - frland, adjsfcdsw, adjsfcnsw, adjsfcdlw, adjsfculw, & - adjnirbmu, adjnirdfu, adjvisbmu, adjvisdfu, adjnirbmd, & - adjnirdfd, adjvisbmd, adjvisdfd, gabsbdlw, xcosz, tseal, & - snohf, dlqfac, work3, ctei_rml, cldf, domr, domzr, domip, & - doms, psautco_l, prautco_l, ocalnirbm_cpl, ocalnirdf_cpl, & - ocalvisbm_cpl, ocalvisdf_cpl, dtzm, temrain1, fscav, fswtr, & - !--- coupling inputs for physics - dtsfc_cice, dqsfc_cice, dusfc_cice, dvsfc_cice, ulwsfc_cice, & - tisfc_cice, tsea_cice, hice_cice, fice_cice, & - !--- for CS-convection - wcbmax - - real(kind=kind_phys), dimension(size(Grid%xlon,1),4) :: & - oa4, clx - - real(kind=kind_phys), dimension(size(Grid%xlon,1),Model%lsoil) :: & - smsoil, stsoil, slsoil - - real(kind=kind_phys), dimension(size(Grid%xlon,1),Model%levs) :: & - del, rhc, dtdt, dudt, dvdt, gwdcu, gwdcv, dtdtc, rainp, & - ud_mf, dd_mf, dt_mf, prnum, dkt, sigmatot, sigmafrac - - !--- GFDL modification for FV3 - real(kind=kind_phys), dimension(size(Grid%xlon,1),Model%levs+1) ::& - del_gz - - real(kind=kind_phys), dimension(size(Grid%xlon,1),Model%levs,Model%ntrac) :: & - dqdt - - real(kind=kind_phys), dimension(size(Grid%xlon,1),Model%levs,Model%nctp) :: & - sigmai, vverti - - real(kind=kind_phys), dimension(size(Grid%xlon,1),Model%levs,oz_coeff+5) :: & - dq3dt_loc - - !--- ALLOCATABLE ELEMENTS - !--- in clw, the first two varaibles are cloud water and ice. - !--- from third to ntrac are convective transportable tracers, - !--- third being the ozone, when ntrac=3 (valid only with ras) - !--- Anning Cheng 9/21/2016 leave a hook here for diagnosed snow, - !--- rain, and their number - real(kind=kind_phys), allocatable :: & - clw(:,:,:), qpl(:,:), qpi(:,:), ncpl(:,:), ncpi(:,:), & - qrn(:,:), qsnw(:,:), ncpr(:,:), ncps(:,:), cnvc(:,:), & - cnvw(:,:) - !--- for 2 M microphysics - real(kind=kind_phys), allocatable, dimension(:) :: & - cn_prc, cn_snr - real(kind=kind_phys), allocatable, dimension(:,:) :: & - qlcn, qicn, w_upi, cf_upi, CNV_MFD, CNV_PRC3, CNV_DQLDT, & - CLCN, CNV_FICE, CNV_NDROP, CNV_NICE - -! -! -!===> ... begin here - - me = Model%me - ix = size(Grid%xlon,1) - im = size(Grid%xlon,1) - levs = Model%levs - ntrac = Model%ntrac - dtf = Model%dtf - dtp = Model%dtp - kdt = Model%kdt - lprnt = Model%lprnt - nvdiff = ntrac ! vertical diffusion of all tracers! - ipr = min(im,10) - -!zhang: Morrison_MP_pre - do i = 1, im - if(nint(Sfcprop%slmsk(i)) == 1) then - frland(i) = 1.0 - else - frland(i) = 0. - endif - enddo -! -! --- ... figure out number of extra tracers -! -!zhang: GFS_physics_pre - tottracer = 0 ! no convective transport of tracers - if (Model%trans_trac .or. Model%cscnv) then - if (Model%ntcw > 0) then - if (Model%ntoz < Model%ntcw) then - trc_shft = Model%ntcw + Model%ncld - 1 - else - trc_shft = Model%ntoz - endif - elseif (Model%ntoz > 0) then - trc_shft = Model%ntoz - else - trc_shft = 1 - endif - - tracers = Model%ntrac - trc_shft - tottracer = tracers - if (Model%ntoz > 0) tottracer = tottracer + 1 ! ozone is added separately - endif -!zhang: shoc_pre - if (Model%ntke > 0) ntk = Model%ntke - trc_shft + 3 - -! if (lprnt) write(0,*)' trans_trac=',trans_trac,' tottracer=', & -! write(0,*)' trans_trac=',trans_trac,' tottracer=', & -! & tottracer,' trc_shft=',trc_shft,' kdt=',kdt -! &, ntrac-ncld+2,' clstp=',clstp,' kdt=',kdt -! &,' ntk=',ntk,' lat=',lat - - skip_macro = .false. - -!zhang: GFS_physics_pre - allocate ( clw(ix,levs,tottracer+2) ) - if (Model%imfdeepcnv >= 0 .or. Model%imfshalcnv > 0) then - allocate (cnvc(ix,levs), cnvw(ix,levs)) - endif -! -! --- set initial quantities for stochastic physics deltas -!zhang:sppt_pre - if (Model%do_sppt) then - Tbd%dtdtr = 0.0 - Tbd%dtotprcp (:) = Diag%rain (:) - Tbd%dcnvprcp (:) = Diag%rainc (:) - Tbd%drain_cpl (:) = Coupling%rain_cpl (:) - Tbd%dsnow_cpl (:) = Coupling%snow_cpl (:) - endif - -!zhang: do_shoc=false - if (Model%do_shoc) then - allocate (qpl(im,levs), qpi(im,levs), ncpl(im,levs), ncpi(im,levs)) - do k=1,levs - do i=1,im - ncpl(i,k) = 0.0 - ncpi(i,k) = 0.0 - enddo - enddo - endif - -!zhang:ncld=1; not used in GFS OP - if (Model%ncld == 2) then ! For MGB double moment microphysics - allocate (qlcn(im,levs), qicn(im,levs), w_upi(im,levs), & - cf_upi(im,levs), CNV_MFD(im,levs), CNV_PRC3(im,levs), & - CNV_DQLDT(im,levs), clcn(im,levs), cnv_fice(im,levs), & - cnv_ndrop(im,levs), cnv_nice(im,levs)) - allocate (cn_prc(im), cn_snr(im)) - allocate (qrn(im,levs), qsnw(im,levs), ncpr(im,levs), ncps(im,levs)) - else - allocate (qlcn(1,1), qicn(1,1), w_upi(1,1), cf_upi(1,1), & - CNV_MFD(1,1), CNV_PRC3(1,1), CNV_DQLDT(1,1), & - clcn(1,1), cnv_fice(1,1), cnv_ndrop(1,1), cnv_nice(1,1)) - endif - -!zhang: where is it defined? -#ifdef GFS_HYDRO - call get_prs(im, ix, levs, ntrac, Statein%tgrs, Statein%qgrs, & - Model%thermodyn_id, Model%sfcpress_id, & - Model%gen_coord_hybrid, Statein%prsi, Statein%prsik, & - Statein%prsl, Statein%prslk, Statein%phii, Statein%phil, del) -#else -!GFDL Adjust the geopotential height hydrostatically in a way consistent with FV3 discretization - call get_prs_fv3 (ix, levs, ntrac, Statein%phii, Statein%prsi, & - Statein%tgrs, Statein%qgrs, del, del_gz) -#endif -! - -!zhang: zhao_carr_pre - rhbbot = Model%crtrh(1) - rhpbl = Model%crtrh(2) - rhbtop = Model%crtrh(3) -! -! --- ... frain=factor for centered difference scheme correction of rain amount. - - frain = dtf / dtp - - do i = 1, im - sigmaf(i) = max( Sfcprop%vfrac(i),0.01 ) - islmsk(i) = nint(Sfcprop%slmsk(i)) - - if (islmsk(i) == 2) then - if (Model%isot == 1) then - soiltyp(i) = 16 - else - soiltyp(i) = 9 - endif - if (Model%ivegsrc == 1) then - vegtype(i) = 15 - elseif(Model%ivegsrc == 2) then - vegtype(i) = 13 - endif - slopetyp(i) = 9 - else - soiltyp(i) = int( Sfcprop%stype(i)+0.5 ) - vegtype(i) = int( Sfcprop%vtype(i)+0.5 ) - slopetyp(i) = int( Sfcprop%slope(i)+0.5 ) !! clu: slope -> slopetyp - endif -! --- ... xw: transfer ice thickness & concentration from global to local variables - zice(i) = Sfcprop%hice(i) - cice(i) = Sfcprop%fice(i) - tice(i) = Sfcprop%tisfc(i) -! -!GFDL work1(i) = (log(coslat(i) / (nlons(i)*latr)) - dxmin) * dxinv -! work1(i) = (log(Grid%dx(i)) - dxmin) * dxinv - work1(i) = (log(Grid%area(i)) - dxmin) * dxinv - work1(i) = max(0.0, min(1.0,work1(i))) - work2(i) = 1.0 - work1(i) - Diag%psurf(i) = Statein%pgr(i) - work3(i) = Statein%prsik(i,1) / Statein%prslk(i,1) -!GFDL tem1 = con_rerth * (con_pi+con_pi)*coslat(i)/nlons(i) -!GFDL tem2 = con_rerth * con_pi / latr -!GFDL garea(i) = tem1 * tem2 - tem1 = Grid%dx(i) - tem2 = Grid%dx(i) - garea(i) = Grid%area(i) - dlength(i) = sqrt( tem1*tem1+tem2*tem2 ) - cldf(i) = Model%cgwf(1)*work1(i) + Model%cgwf(2)*work2(i) - wcbmax(i) = Model%cs_parm(1)*work1(i) + Model%cs_parm(2)*work2(i) - enddo -! -!zhang:cplflx=.false. - if (Model%cplflx) then - do i = 1, im - islmsk_cice(i) = nint(Coupling%slimskin_cpl(i)) - flag_cice(i) = (islmsk_cice(i) == 4) - - ulwsfc_cice(i) = Coupling%ulwsfcin_cpl(i) - dusfc_cice(i) = Coupling%dusfcin_cpl(i) - dvsfc_cice(i) = Coupling%dvsfcin_cpl(i) - dtsfc_cice(i) = Coupling%dtsfcin_cpl(i) - dqsfc_cice(i) = Coupling%dqsfcin_cpl(i) - tisfc_cice(i) = Sfcprop%tisfc(i) - tsea_cice(i) = Sfcprop%tsfc(i) - fice_cice(i) = Sfcprop%fice(i) - hice_cice(i) = Sfcprop%hice(i) - enddo - endif - -! --- ... transfer soil moisture and temperature from global to local variables -!zhang sfc_drv_pre, sfc_ice_pre - smsoil(:,:) = Sfcprop%smc(:,:) - stsoil(:,:) = Sfcprop%stc(:,:) - slsoil(:,:) = Sfcprop%slc(:,:) !! clu: slc -> slsoil - -!zhang: GFS_physics_pre - dudt(:,:) = 0. - dvdt(:,:) = 0. - dtdt(:,:) = 0. - dtdtc(:,:) = 0. - dqdt(:,:,:) = 0. - -! --- ... initialize dtdt with heating rate from dcyc2 - -! --- ... adjust mean radiation fluxes and heating rates to fit for -! faster model time steps. -! sw: using cos of zenith angle as scaling factor -! lw: using surface air skin temperature as scaling factor - -!zhang: pre_rad=.false. - if (Model%pre_rad) then - call dcyc2t3_pre_rad & -! --- inputs: - ( Model%solhr, Model%slag, Model%sdec, Model%cdec, Grid%sinlat, & - Grid%coslat, Grid%xlon, Radtend%coszen, Sfcprop%tsfc, & - Statein%tgrs(1,1), Statein%tgrs(1,1), Coupling%sfcdsw, & - Coupling%sfcnsw, Coupling%sfcdlw, Radtend%htrsw, Radtend%htrlw,& - Coupling%nirbmui, Coupling%nirdfui, Coupling%visbmui, & - Coupling%visdfui, Coupling%nirbmdi, Coupling%nirdfdi, & - Coupling%visbmdi, Coupling%visdfdi, ix, im, levs, & -! --- input/output: - dtdt, & -! --- outputs: - adjsfcdsw, adjsfcnsw, adjsfcdlw, adjsfculw, xmu, xcosz, & - adjnirbmu, adjnirdfu, adjvisbmu, adjvisdfu, & - adjnirbmd, adjnirdfd, adjvisbmd, adjvisdfd & - ) - - else -!zhang: dcyc2t3_run in dcyc2.f - call dcyc2t3 & -! --- inputs: - ( Model%solhr, Model%slag, Model%sdec, Model%cdec, Grid%sinlat, & - Grid%coslat, Grid%xlon, Radtend%coszen, Sfcprop%tsfc, & - Statein%tgrs(1,1), Radtend%tsflw, Radtend%semis, & - Coupling%sfcdsw, Coupling%sfcnsw, Coupling%sfcdlw, & - Radtend%htrsw, Radtend%swhc, Radtend%htrlw, Radtend%lwhc, & - Coupling%nirbmui, Coupling%nirdfui, Coupling%visbmui, & - Coupling%visdfui, Coupling%nirbmdi, Coupling%nirdfdi, & - Coupling%visbmdi, Coupling%visdfdi, ix, im, levs, & -! --- input/output: - dtdt, dtdtc, & -! --- outputs: - adjsfcdsw, adjsfcnsw, adjsfcdlw, adjsfculw, xmu, xcosz, & - adjnirbmu, adjnirdfu, adjvisbmu, adjvisdfu, & - adjnirbmd, adjnirdfd, adjvisbmd, adjvisdfd & - ) - -! -! save temp change due to radiation - need for sttp stochastic physics -!--------------------------------------------------------------------- - endif -! -!zhang: lsidea=.false. ! idea convective adjustment - if (Model%lsidea) then !idea jw - dtdt(:,:) = 0. - endif - -! --- convert lw fluxes for land/ocean/sea-ice models -! note: for sw: adjsfcdsw and adjsfcnsw are zenith angle adjusted downward/net fluxes. -! for lw: adjsfcdlw is (sfc temp adjusted) downward fluxe with no emiss effect. -! adjsfculw is (sfc temp adjusted) upward fluxe including emiss effect. -! one needs to be aware that that the absorbed downward lw flux (used by land/ocean -! models as downward flux) is not the same as adjsfcdlw but a value reduced by -! the factor of emissivity. however, the net effects are the same when seeing -! it either above the surface interface or below. -! -! - flux above the interface used by atmosphere model: -! down: adjsfcdlw; up: adjsfculw = sfcemis*sigma*T**4 + (1-sfcemis)*adjsfcdlw -! net = up - down = sfcemis * (sigma*T**4 - adjsfcdlw) -! - flux below the interface used by lnd/oc/ice models: -! down: sfcemis*adjsfcdlw; up: sfcemis*sigma*T**4 -! net = up - down = sfcemis * (sigma*T**4 - adjsfcdlw) - -! --- ... define the downward lw flux absorbed by ground - - gabsbdlw(:) = Radtend%semis(:) * adjsfcdlw(:) -!zhang: false in GFS_typedefs, true in GFS_driver - if (Model%lssav) then ! --- ... accumulate/save output variables - -! --- ... sunshine duration time is defined as the length of time (in mdl output -! interval) that solar radiation falling on a plane perpendicular to the -! direction of the sun >= 120 w/m2 - - do i = 1, im - if ( xcosz(i) >= czmin ) then ! zenth angle > 89.994 deg - tem1 = adjsfcdsw(i) / xcosz(i) - if ( tem1 >= 120.0 ) then - Diag%suntim(i) = Diag%suntim(i) + dtf - endif - endif - enddo - -! --- ... sfc lw fluxes used by atmospheric model are saved for output - - if (Model%cplflx) then - do i = 1, im - if (flag_cice(i)) adjsfculw(i) = ulwsfc_cice(i) - enddo - endif - Diag%dlwsfc(:) = Diag%dlwsfc(:) + adjsfcdlw(:)*dtf - Diag%ulwsfc(:) = Diag%ulwsfc(:) + adjsfculw(:)*dtf - Diag%psmean(:) = Diag%psmean(:) + Statein%pgr(:)*dtf ! mean surface pressure - - if (Model%ldiag3d) then - if (Model%lsidea) then - Diag%dt3dt(:,:,1) = Diag%dt3dt(:,:,1) + Radtend%lwhd(:,:,1)*dtf - Diag%dt3dt(:,:,2) = Diag%dt3dt(:,:,2) + Radtend%lwhd(:,:,2)*dtf - Diag%dt3dt(:,:,3) = Diag%dt3dt(:,:,3) + Radtend%lwhd(:,:,3)*dtf - Diag%dt3dt(:,:,4) = Diag%dt3dt(:,:,4) + Radtend%lwhd(:,:,4)*dtf - Diag%dt3dt(:,:,5) = Diag%dt3dt(:,:,5) + Radtend%lwhd(:,:,5)*dtf - Diag%dt3dt(:,:,6) = Diag%dt3dt(:,:,6) + Radtend%lwhd(:,:,6)*dtf - else - do k = 1, levs - Diag%dt3dt(:,k,1) = Diag%dt3dt(:,k,1) + Radtend%htrlw(:,k)*dtf - Diag%dt3dt(:,k,2) = Diag%dt3dt(:,k,2) + Radtend%htrsw(:,k)*dtf*xmu(:) - enddo - endif - endif - endif ! end if_lssav_block -!zhang: GFS_physics_pre - kcnv(:) = 0 -!zhang: GFS_PBL_generic_pre - kinver(:) = levs - -!zhang:old_phys (non-OP) - invrsn(:) = .false. - tx1(:) = 0.0 - tx2(:) = 10.0 - ctei_r(:) = 10.0 - -! Only used for old shallow convection with mstrat=.true. - - if (((Model%imfshalcnv == 0 .and. Model%shal_cnv) .or. Model%old_monin) & - .and. Model%mstrat) then - ctei_rml(:) = Model%ctei_rm(1)*work1(:) + Model%ctei_rm(2)*work2(:) - do k = 1, levs/2 - do i = 1, im - if (Statein%prsi(i,1)-Statein%prsi(i,k+1) < 0.35*Statein%prsi(i,1) & - .and. (.not. invrsn(i))) then - tem = (Statein%tgrs(i,k+1)-Statein%tgrs(i,k)) / (Statein%prsl(i,k)-Statein%prsl(i,k+1)) - - if (((tem > 0.00010) .and. (tx1(i) < 0.0)) .or. & - ((tem-abs(tx1(i)) > 0.0) .and. (tx2(i) < 0.0))) then - invrsn(i) = .true. - - if (Statein%qgrs(i,k,1) > Statein%qgrs(i,k+1,1)) then - tem1 = Statein%tgrs(i,k+1) + hocp*max(Statein%qgrs(i,k+1,1),qmin) - tem2 = Statein%tgrs(i,k) + hocp*max(Statein%qgrs(i,k,1),qmin) - - tem1 = tem1 / Statein%prslk(i,k+1) - tem2 / Statein%prslk(i,k) - -! --- ... (cp/l)(deltathetae)/(deltatwater) > ctei_rm -> conditon for CTEI - ctei_r(i) = (1.0/hocp)*tem1/(Statein%qgrs(i,k+1,1)-Statein%qgrs(i,k,1) & - + Statein%qgrs(i,k+1,Model%ntcw)-Statein%qgrs(i,k,Model%ntcw)) - else - ctei_r(i) = 10 - endif - - if ( ctei_rml(i) > ctei_r(i) ) then - kinver(i) = k - else - kinver(i) = levs - endif - endif - - tx2(i) = tx1(i) - tx1(i) = tem - endif - enddo - enddo - endif - -! --- ... lu: initialize flag_guess, flag_iter, tsurf - - tsurf(:) = Sfcprop%tsfc(:) - flag_guess(:) = .false. - flag_iter(:) = .true. - drain(:) = 0.0 - ep1d(:) = 0.0 - runof(:) = 0.0 - hflx(:) = 0.0 - evap(:) = 0.0 - evbs(:) = 0.0 - evcw(:) = 0.0 - trans(:) = 0.0 - sbsno(:) = 0.0 - snowc(:) = 0.0 - snohf(:) = 0.0 - Diag%zlvl(:) = Statein%phil(:,1) * onebg - Diag%smcwlt2(:) = 0.0 - Diag%smcref2(:) = 0.0 - -! --- ... lu: iter-loop over (sfc_diff,sfc_drv,sfc_ocean,sfc_sice) - - do iter = 1, 2 - -! --- ... surface exchange coefficients -! -! if (lprnt) write(0,*)' tsea=',tsea(ipr),' tsurf=',tsurf(ipr),iter - - call sfc_diff (im,Statein%pgr, Statein%ugrs, Statein%vgrs, & - Statein%tgrs, Statein%qgrs, Diag%zlvl, & - Sfcprop%snowd, Sfcprop%tsfc, Sfcprop%zorl, cd, & - cdq, rb, Statein%prsl(1,1), work3, islmsk, stress, & - Sfcprop%ffmm, Sfcprop%ffhh, Sfcprop%uustar, & - wind, Tbd%phy_f2d(1,Model%num_p2d), fm10, fh2, & - sigmaf, vegtype, Sfcprop%shdmax, Model%ivegsrc, & - tsurf, flag_iter, Model%redrag) - -! --- ... lu: update flag_guess - - do i = 1, im - if (iter == 1 .and. wind(i) < 2.0) then - flag_guess(i) = .true. - endif - enddo - - if (Model%nstf_name(1) > 0) then - - do i = 1, im - if ( islmsk(i) == 0 ) then - tem = (Sfcprop%oro(i)-Sfcprop%oro_uf(i)) * rlapse - tseal(i) = Sfcprop%tsfc(i) + tem - tsurf(i) = tsurf(i) + tem - endif - enddo - - call sfc_nst (im, Model%lsoil, Statein%pgr, Statein%ugrs, & - Statein%vgrs, Statein%tgrs, Statein%qgrs, & - Sfcprop%tref, cd, cdq, Statein%prsl(1,1), work3, & - islmsk, Grid%xlon, Grid%sinlat, stress, & - Radtend%semis, gabsbdlw, adjsfcnsw, Sfcprop%tprcp, & - dtf, kdt, Model%solhr, xcosz, & - Tbd%phy_f2d(1,Model%num_p2d), flag_iter, & - flag_guess, Model%nstf_name, lprnt, ipr, & -! --- Input/output - tseal, tsurf, Sfcprop%xt, Sfcprop%xs, Sfcprop%xu, & - Sfcprop%xv, Sfcprop%xz, Sfcprop%zm, Sfcprop%xtts, & - Sfcprop%xzts, Sfcprop%dt_cool, Sfcprop%z_c, & - Sfcprop%c_0, Sfcprop%c_d, Sfcprop%w_0, Sfcprop%w_d,& - Sfcprop%d_conv, Sfcprop%ifd, Sfcprop%qrain, & -! --- outputs: - qss, gflx, Diag%cmm, Diag%chh, evap, hflx, ep1d) - -! if (lprnt) print *,' tseaz2=',tseal(ipr),' tref=',tref(ipr), -! & ' dt_cool=',dt_cool(ipr),' dt_warm=',2.0*xt(ipr)/xz(ipr), -! & ' kdt=',kdt - - do i = 1, im - if ( islmsk(i) == 0 ) then - tsurf(i) = tsurf(i) - (Sfcprop%oro(i)-Sfcprop%oro_uf(i)) * rlapse - endif - enddo - -! --- ... run nsst model ... --- - - if (Model%nstf_name(1) > 1) then - zsea1 = 0.001*real(Model%nstf_name(4)) - zsea2 = 0.001*real(Model%nstf_name(5)) - call get_dtzm_2d (Sfcprop%xt, Sfcprop%xz, Sfcprop%dt_cool, & - Sfcprop%z_c, Sfcprop%slmsk, zsea1, zsea2, & - im, 1, dtzm) - do i = 1, im - if ( islmsk(i) == 0 ) then - Sfcprop%tsfc(i) = max(271.2,Sfcprop%tref(i) + dtzm(i)) - & - (Sfcprop%oro(i)-Sfcprop%oro_uf(i))*rlapse - endif - enddo - endif - -! if (lprnt) print *,' tseaz2=',tsea(ipr),' tref=',tref(ipr), & -! & ' dt_cool=',dt_cool(ipr),' dt_warm=',dt_warm(ipr),' kdt=',kdt - - else - -! --- ... surface energy balance over ocean - - call sfc_ocean & -! --- inputs: - (im, Statein%pgr, Statein%ugrs, Statein%vgrs, Statein%tgrs, & - Statein%qgrs, Sfcprop%tsfc, cd, cdq, Statein%prsl(1,1), & - work3, islmsk, Tbd%phy_f2d(1,Model%num_p2d), flag_iter, & -! --- outputs: - qss, Diag%cmm, Diag%chh, gflx, evap, hflx, ep1d) - - endif ! if ( nstf_name(1) > 0 ) then - -! if (lprnt) write(0,*)' sfalb=',sfalb(ipr),' ipr=',ipr & -! &, ' weasd=',weasd(ipr),' snwdph=',snwdph(ipr) & -! &, ' tprcp=',tprcp(ipr),' kdt=',kdt,' iter=',iter & -! &,' tseabefland=',tsea(ipr) - -! --- ... surface energy balance over land -! - if (Model%lsm == 1) then ! noah lsm call - -! if (lprnt) write(0,*)' tsead=',tsea(ipr),' tsurf=',tsurf(ipr),iter -! &,' pgr=',pgr(ipr),' sfcemis=',sfcemis(ipr) - - call sfc_drv & -! --- inputs: - (im, Model%lsoil, Statein%pgr, Statein%ugrs, Statein%vgrs, & - Statein%tgrs, Statein%qgrs, soiltyp, vegtype, sigmaf, & - Radtend%semis, gabsbdlw, adjsfcdsw, adjsfcnsw, dtf, & - Sfcprop%tg3, cd, cdq, Statein%prsl(1,1), work3, DIag%zlvl, & - islmsk, Tbd%phy_f2d(1,Model%num_p2d), slopetyp, & - Sfcprop%shdmin, Sfcprop%shdmax, Sfcprop%snoalb, & - Radtend%sfalb, flag_iter, flag_guess, Model%isot, & - Model%ivegsrc, & -! --- in/outs: - Sfcprop%weasd, Sfcprop%snowd, Sfcprop%tsfc, Sfcprop%tprcp, & - Sfcprop%srflag, smsoil, stsoil, slsoil, Sfcprop%canopy, & - trans, tsurf, Sfcprop%zorl, & -! --- outputs: - Sfcprop%sncovr, qss, gflx, drain, evap, hflx, ep1d, runof, & - Diag%cmm, Diag%chh, evbs, evcw, sbsno, snowc, Diag%soilm, & - snohf, Diag%smcwlt2, Diag%smcref2, Diag%wet1) - -! if (lprnt) write(0,*)' tseae=',tsea(ipr),' tsurf=',tsurf(ipr),iter -! &,' phy_f2d=',phy_f2d(ipr,num_p2d) - - endif - -! if (lprnt) write(0,*)' tseabeficemodel =',tsea(ipr),' me=',me & -! &, ' kdt=',kdt - -! --- ... surface energy balance over seaice - - if (Model%cplflx) then - do i = 1, im - if (flag_cice(i)) then - islmsk (i) = islmsk_cice(i) - endif - enddo - endif - - call sfc_sice & -! --- inputs: - (im, Model%lsoil, Statein%pgr, Statein%ugrs, Statein%vgrs, & - Statein%tgrs, Statein%qgrs, dtf, Radtend%semis, gabsbdlw, & - adjsfcnsw, adjsfcdsw, Sfcprop%srflag, cd, cdq, & - Statein%prsl(1,1), work3, islmsk, & - Tbd%phy_f2d(1,Model%num_p2d), flag_iter, Model%mom4ice, & - Model%lsm, lprnt, ipr, & -! --- input/outputs: - zice, cice, tice, Sfcprop%weasd, Sfcprop%tsfc, & - Sfcprop%tprcp, stsoil, ep1d, & -! --- outputs: - Sfcprop%snowd, qss, snowmt, gflx, Diag%cmm, Diag%chh, evap, & - hflx) - - if (Model%cplflx) then - do i = 1, im - if (flag_cice(i)) then - islmsk(i) = nint(Sfcprop%slmsk(i)) - endif - enddo - - call sfc_cice & -! --- inputs: - (im, Statein%ugrs, Statein%vgrs, Statein%tgrs, Statein%qgrs, & - cd, cdq, Statein%prsl(1,1), work3, islmsk_cice, & - Tbd%phy_f2d(1,Model%num_p2d),flag_iter, dqsfc_cice, & - dtsfc_cice, & -! --- outputs: - qss, Diag%cmm, Diag%chh, evap, hflx) - endif - -! --- ... lu: update flag_iter and flag_guess - - do i = 1, im - flag_iter(i) = .false. - flag_guess(i) = .false. - - if (iter == 1 .and. wind(i) < 2.0) then - if ((islmsk(i) == 1) .or. ((islmsk(i) == 0) .and. & - (Model%nstf_name(1) > 0))) then - flag_iter(i) = .true. - endif - endif - -! if(islmsk(i) == 1 .and. iter == 1) then -! if (wind(i) < 2.0) flag_iter(i) = .true. -! elseif (islmsk(i) == 0 .and. iter == 1 & -! & .and. nstf_name(1) > 0) then -! if (wind(i) < 2.0) flag_iter(i) = .true. -! endif - enddo - - enddo ! end iter_loop -!zhang: GFS_surface_generic_post (for instantaneous diagnostics) - Diag%epi(:) = ep1d(:) -!zhang:dcyc2t3_post - Diag%dlwsfci(:) = adjsfcdlw(:) - Diag%ulwsfci(:) = adjsfculw(:) - Diag%uswsfci(:) = adjsfcdsw(:) - adjsfcnsw(:) - Diag%dswsfci(:) = adjsfcdsw(:) -!zhang: GFS_surface_generic_post (for instantaneous diagnostics) - Diag%gfluxi(:) = gflx(:) -!zhang: GFS_diagnostics_pre, see GFS_diagnostics.F - Diag%t1(:) = Statein%tgrs(:,1) - Diag%q1(:) = Statein%qgrs(:,1,1) - Diag%u1(:) = Statein%ugrs(:,1) - Diag%v1(:) = Statein%vgrs(:,1) - -! --- ... update near surface fields -!zhang: sfc_diag_run - call sfc_diag (im, Statein%pgr, Statein%ugrs, Statein%vgrs, & - Statein%tgrs, Statein%qgrs, Sfcprop%tsfc, qss, & - Sfcprop%f10m, Diag%u10m, Diag%v10m, & - Sfcprop%t2m, Sfcprop%q2m, work3, evap, & - Sfcprop%ffmm, Sfcprop%ffhh, fm10, fh2) -!zhang: only used in rascnv - Tbd%phy_f2d(:,Model%num_p2d) = 0.0 - - if (Model%cplflx) then - Coupling%dlwsfci_cpl (:) = adjsfcdlw(:) - Coupling%dswsfci_cpl (:) = adjsfcdsw(:) - Coupling%dlwsfc_cpl (:) = Coupling%dlwsfc_cpl(:) + adjsfcdlw(:)*dtf - Coupling%dswsfc_cpl (:) = Coupling%dswsfc_cpl(:) + adjsfcdsw(:)*dtf - Coupling%dnirbmi_cpl (:) = adjnirbmd(:) - Coupling%dnirdfi_cpl (:) = adjnirdfd(:) - Coupling%dvisbmi_cpl (:) = adjvisbmd(:) - Coupling%dvisdfi_cpl (:) = adjvisdfd(:) - Coupling%dnirbm_cpl (:) = Coupling%dnirbm_cpl(:) + adjnirbmd(:)*dtf - Coupling%dnirdf_cpl (:) = Coupling%dnirdf_cpl(:) + adjnirdfd(:)*dtf - Coupling%dvisbm_cpl (:) = Coupling%dvisbm_cpl(:) + adjvisbmd(:)*dtf - Coupling%dvisdf_cpl (:) = Coupling%dvisdf_cpl(:) + adjvisdfd(:)*dtf - Coupling%nlwsfci_cpl (:) = adjsfcdlw(:) - adjsfculw(:) - Coupling%nlwsfc_cpl (:) = Coupling%nlwsfc_cpl(:) + Coupling%nlwsfci_cpl(:)*dtf - Coupling%t2mi_cpl (:) = Sfcprop%t2m(:) - Coupling%q2mi_cpl (:) = Sfcprop%q2m(:) - Coupling%u10mi_cpl (:) = Diag%u10m(:) - Coupling%v10mi_cpl (:) = Diag%v10m(:) - Coupling%tsfci_cpl (:) = Sfcprop%tsfc(:) - Coupling%psurfi_cpl (:) = Statein%pgr(:) - -! --- estimate mean albedo for ocean point without ice cover and apply -! them to net SW heat fluxes - - do i = 1, im - if (islmsk(i) /= 1) then ! not a land point -! --- compute open water albedo - xcosz_loc = max( 0.0, min( 1.0, xcosz(i) )) - ocalnirdf_cpl(i) = 0.06 - ocalnirbm_cpl(i) = max(albdf, 0.026/(xcosz_loc**1.7+0.065) & - & + 0.15 * (xcosz_loc-0.1) * (xcosz_loc-0.5) & - & * (xcosz_loc-1.0)) - ocalvisdf_cpl(i) = 0.06 - ocalvisbm_cpl(i) = ocalnirbm_cpl(i) - - Coupling%nnirbmi_cpl(i) = adjnirbmd(i)-adjnirbmd(i)*ocalnirbm_cpl(i) - Coupling%nnirdfi_cpl(i) = adjnirdfd(i)-adjnirdfd(i)*ocalnirdf_cpl(i) - Coupling%nvisbmi_cpl(i) = adjvisbmd(i)-adjvisbmd(i)*ocalvisbm_cpl(i) - Coupling%nvisdfi_cpl(i) = adjvisdfd(i)-adjvisdfd(i)*ocalvisdf_cpl(i) - else - Coupling%nnirbmi_cpl(i) = adjnirbmd(i) - adjnirbmu(i) - Coupling%nnirdfi_cpl(i) = adjnirdfd(i) - adjnirdfu(i) - Coupling%nvisbmi_cpl(i) = adjvisbmd(i) - adjvisbmu(i) - Coupling%nvisdfi_cpl(i) = adjvisdfd(i) - adjvisdfu(i) - endif - Coupling%nswsfci_cpl(i) = Coupling%nnirbmi_cpl(i) + Coupling%nnirdfi_cpl(i) + & - Coupling%nvisbmi_cpl(i) + Coupling%nvisdfi_cpl(i) - Coupling%nswsfc_cpl(i) = Coupling%nswsfc_cpl(i) + Coupling%nswsfci_cpl(i)*dtf - Coupling%nnirbm_cpl(i) = Coupling%nnirbm_cpl(i) + Coupling%nnirbmi_cpl(i)*dtf - Coupling%nnirdf_cpl(i) = Coupling%nnirdf_cpl(i) + Coupling%nnirdfi_cpl(i)*dtf - Coupling%nvisbm_cpl(i) = Coupling%nvisbm_cpl(i) + Coupling%nvisbmi_cpl(i)*dtf - Coupling%nvisdf_cpl(i) = Coupling%nvisdf_cpl(i) + Coupling%nvisdfi_cpl(i)*dtf - enddo - endif - - if (Model%lssav) then - Diag%gflux(:) = Diag%gflux(:) + gflx(:) * dtf - Diag%evbsa(:) = Diag%evbsa(:) + evbs(:) * dtf - Diag%evcwa(:) = Diag%evcwa(:) + evcw(:) * dtf - Diag%transa(:) = Diag%transa(:) + trans(:) * dtf - Diag%sbsnoa(:) = Diag%sbsnoa(:) + sbsno(:) * dtf - Diag%snowca(:) = Diag%snowca(:) + snowc(:) * dtf - Diag%snohfa(:) = Diag%snohfa(:) + snohf(:) * dtf - Diag%ep(:) = Diag%ep(:) + ep1d(:) * dtf - - Diag%tmpmax(:) = max(Diag%tmpmax(:),Sfcprop%t2m(:)) - Diag%tmpmin(:) = min(Diag%tmpmin(:),Sfcprop%t2m(:)) - - Diag%spfhmax(:) = max(Diag%spfhmax(:),Sfcprop%q2m(:)) - Diag%spfhmin(:) = min(Diag%spfhmin(:),Sfcprop%q2m(:)) - endif - -!!!!!!!!!!!!!!!!!Commented by Moorthi on July 18, 2012 !!!!!!!!!!!!!!!!!!! -! do i = 1, im -! --- ... compute coefficient of evaporation in evapc -! -! if (evapc(i) > 1.0e0) evapc(i) = 1.0e0 -! --- ... over snow cover or ice or sea, coef of evap =1.0e0 -! if (weasd(i) > 0.0 .or. slmsk(i) /= 1.0) evapc(i) = 1.0e0 -! enddo -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -! --- ... Boundary Layer and Free atmospheic turbulence parameterization - -! if (lprnt) write(0,*)' tsea3=',tsea(ipr),' slmsk=',slmsk(ipr) & -! &, ' kdt=',kdt,' evap=',evap(ipr) -! if (lprnt) write(0,*)' dtdtb=',(dtdt(ipr,k),k=1,15) - -! do i = 1, im -! if (islmsk(i) == 0) then -! oro_land(i) = 0.0 -! else -! oro_land(i) = oro(i) -! endif -! enddo - -! write(0,*)' before monin clstp=',clstp,' kdt=',kdt,' lat=',lat - - if (Model%do_shoc) then - call moninshoc(ix, im, levs, ntrac, Model%ntcw, dvdt, dudt, dtdt, dqdt, & - Statein%ugrs, Statein%vgrs, Statein%tgrs, Statein%qgrs, & - Tbd%phy_f3d(1,1,Model%ntot3d-1), prnum, Model%ntke, & - Statein%prsik(1,1), rb, Sfcprop%zorl, Diag%u10m, & - Diag%v10m, Sfcprop%ffmm, Sfcprop%ffhh, Sfcprop%tsfc, hflx,& - evap, stress, wind, kpbl, Statein%prsi, del, Statein%prsl,& - Statein%prslk, Statein%phii, Statein%phil, dtp, dusfc1, & - dvsfc1, dtsfc1, dqsfc1, dkt, Diag%hpbl, kinver, & - Model%xkzm_m, Model%xkzm_h, Model%xkzm_s, lprnt, ipr, me) - else - if (Model%hybedmf) then - call moninedmf(ix, im, levs, nvdiff, Model%ntcw, dvdt, dudt, dtdt, dqdt,& - Statein%ugrs, Statein%vgrs, Statein%tgrs, Statein%qgrs, & - Radtend%htrsw, Radtend%htrlw, xmu, Statein%prsik(1,1), & - rb, Sfcprop%zorl, Diag%u10m, Diag%v10m, Sfcprop%ffmm, & - Sfcprop%ffhh, Sfcprop%tsfc, qss, hflx, evap, stress, & - wind, kpbl, Statein%prsi, del, Statein%prsl, & - Statein%prslk, Statein%phii, Statein%phil, dtp, & - Model%dspheat, dusfc1, dvsfc1, dtsfc1, dqsfc1, Diag%hpbl,& - gamt, gamq, dkt, kinver, Model%xkzm_m, Model%xkzm_h, & - Model%xkzm_s, lprnt, ipr) -! if (lprnt) write(0,*)' dtdtm=',(dtdt(ipr,k),k=1,15) -! if (lprnt) write(0,*)' dqdtm=',(dqdt(ipr,k,1),k=1,15) - elseif (.not. Model%old_monin) then - call moninq(ix, im, levs, nvdiff, Model%ntcw, dvdt, dudt, dtdt, dqdt, & - Statein%ugrs, Statein%vgrs, Statein%tgrs, Statein%qgrs, & - Radtend%htrsw, Radtend%htrlw, xmu, Statein%prsik(1,1), rb,& - Sfcprop%ffmm, Sfcprop%ffhh, Sfcprop%tsfc, qss, hflx, evap,& - stress, wind, kpbl, Statein%prsi, del, Statein%prsl, & - Statein%prslk, Statein%phii, Statein%phil, dtp, & - Model%dspheat, dusfc1, dvsfc1, dtsfc1, dqsfc1, Diag%hpbl, & - gamt, gamq, dkt, kinver, Model%xkzm_m, Model%xkzm_h, & - Model%xkzm_s, lprnt, ipr) - else - if (Model%mstrat) then - call moninp1(ix, im, levs, nvdiff, dvdt, dudt, dtdt, dqdt, & - Statein%ugrs, Statein%vgrs, Statein%tgrs, Statein%qgrs,& - Statein%prsik(1,1), rb, Sfcprop%ffmm, Sfcprop%ffhh, & - Sfcprop%tsfc, qss, hflx, evap, stress, wind, kpbl, & - Statein%prsi, del, Statein%prsl, Statein%prslk, & - Statein%phii, Statein%phil, dtp, dusfc1, dvsfc1, & - dtsfc1, dqsfc1, Diag%hpbl, gamt, gamq, dkt, kinver, & - Model%xkzm_m, Model%xkzm_h) - else - call moninp(ix, im, levs, nvdiff, dvdt, dudt, dtdt, dqdt, & - Statein%ugrs, Statein%vgrs, Statein%tgrs, Statein%qgrs, & - Statein%prsik(1,1), rb, Sfcprop%ffmm, Sfcprop%ffhh, & - Sfcprop%tsfc, qss, hflx, evap, stress, wind, kpbl, & - Statein%prsi, del, Statein%prsl, Statein%phii, & - Statein%phil, dtp, dusfc1, dvsfc1, dtsfc1, dqsfc1, & - Diag%hpbl, gamt, gamq, dkt, Model%xkzm_m, Model%xkzm_h) - endif - - endif ! end if_hybedmf - endif ! end if_do_shoc - - if (Model%cplflx) then - do i = 1, im - if (flag_cice(i)) then - cice(i) = fice_cice(i) - Sfcprop%tsfc(i) = tsea_cice(i) - dusfc1(i) = dusfc_cice(i) - dvsfc1(i) = dvsfc_cice(i) - dqsfc1(i) = dqsfc_cice(i) - dtsfc1(i) = dtsfc_cice(i) - endif - enddo - endif - -! if (lprnt) then -! write(0,*) ' dusfc1=',dusfc1(ipr),' kdt=',kdt,' lat=',lat -! write(0,*)' dtsfc1=',dtsfc1(ipr) -! write(0,*)' dqsfc1=',dqsfc1(ipr) -! write(0,*)' dtdtc=',(dtdt(ipr,k),k=1,15) -! write(0,*)' dqdtc=',(dqdt(ipr,k,1),k=1,15) -! print *,' dudtm=',dudt(ipr,:) -! endif - -! --- ... coupling insertion - - if (Model%cplflx) then - Coupling%dusfc_cpl (:) = Coupling%dusfc_cpl(:) + dusfc1(:)*dtf - Coupling%dvsfc_cpl (:) = Coupling%dvsfc_cpl(:) + dvsfc1(:)*dtf - Coupling%dtsfc_cpl (:) = Coupling%dtsfc_cpl(:) + dtsfc1(:)*dtf - Coupling%dqsfc_cpl (:) = Coupling%dqsfc_cpl(:) + dqsfc1(:)*dtf - Coupling%dusfci_cpl(:) = dusfc1(:) - Coupling%dvsfci_cpl(:) = dvsfc1(:) - Coupling%dtsfci_cpl(:) = dtsfc1(:) - Coupling%dqsfci_cpl(:) = dqsfc1(:) - endif -!-------------------------------------------------------lssav if loop ---------- - if (Model%lssav) then - Diag%dusfc (:) = Diag%dusfc(:) + dusfc1(:)*dtf - Diag%dvsfc (:) = Diag%dvsfc(:) + dvsfc1(:)*dtf - Diag%dtsfc (:) = Diag%dtsfc(:) + dtsfc1(:)*dtf - Diag%dqsfc (:) = Diag%dqsfc(:) + dqsfc1(:)*dtf - Diag%dusfci(:) = dusfc1(:) - Diag%dvsfci(:) = dvsfc1(:) - Diag%dtsfci(:) = dtsfc1(:) - Diag%dqsfci(:) = dqsfc1(:) -! if (lprnt) then -! write(0,*)' dusfc=',dusfc(ipr),' dusfc1=',dusfc1(ipr),' dtf=', -! & dtf,' kdt=',kdt,' lat=',lat -! endif - - if (Model%ldiag3d) then - if (Model%lsidea) then - Diag%dt3dt(:,:,3) = Diag%dt3dt(:,:,3) + dtdt(:,:)*dtf - else - do k = 1, levs - do i = 1, im - tem = dtdt(i,k) - (Radtend%htrlw(i,k)+Radtend%htrsw(i,k)*xmu(i)) - Diag%dt3dt(i,k,3) = Diag%dt3dt(i,k,3) + tem*dtf - enddo - enddo - endif - Diag%du3dt(:,:,1) = Diag%du3dt(:,:,1) + dudt(:,:) * dtf - Diag%du3dt(:,:,2) = Diag%du3dt(:,:,2) - dudt(:,:) * dtf - Diag%dv3dt(:,:,1) = Diag%dv3dt(:,:,1) + dvdt(:,:) * dtf - Diag%dv3dt(:,:,2) = Diag%dv3dt(:,:,2) - dvdt(:,:) * dtf -! update dqdt_v to include moisture tendency due to vertical diffusion -! if (lgocart) then -! do k = 1, levs -! do i = 1, im -! dqdt_v(i,k) = dqdt(i,k,1) * dtf -! enddo -! enddo -! endif - do k = 1, levs - do i = 1, im - tem = dqdt(i,k,1) * dtf - Diag%dq3dt(i,k,1) = Diag%dq3dt(i,k,1) + tem - enddo - enddo - if (Model%ntoz > 0) then - Diag%dq3dt(:,:,5) = Diag%dq3dt(:,:,5) + dqdt(i,k,Model%ntoz) * dtf - endif - endif - - endif ! end if_lssav -!-------------------------------------------------------lssav if loop ---------- -! -! Orographic gravity wave drag parameterization -! --------------------------------------------- -!zhang:gwdps_pre - if (Model%nmtvr == 14) then ! current operational - as of 2014 - oc(:) = Sfcprop%hprime(:,2) - oa4(:,1) = Sfcprop%hprime(:,3) - oa4(:,2) = Sfcprop%hprime(:,4) - oa4(:,3) = Sfcprop%hprime(:,5) - oa4(:,4) = Sfcprop%hprime(:,6) - clx(:,1) = Sfcprop%hprime(:,7) - clx(:,2) = Sfcprop%hprime(:,8) - clx(:,3) = Sfcprop%hprime(:,9) - clx(:,4) = Sfcprop%hprime(:,10) - theta(:) = Sfcprop%hprime(:,11) - gamma(:) = Sfcprop%hprime(:,12) - sigma(:) = Sfcprop%hprime(:,13) - elvmax(:) = Sfcprop%hprime(:,14) - elseif (Model%nmtvr == 10) then - oc(:) = Sfcprop%hprime(:,2) - oa4(:,1) = Sfcprop%hprime(:,3) - oa4(:,2) = Sfcprop%hprime(:,4) - oa4(:,3) = Sfcprop%hprime(:,5) - oa4(:,4) = Sfcprop%hprime(:,6) - clx(:,1) = Sfcprop%hprime(:,7) - clx(:,2) = Sfcprop%hprime(:,8) - clx(:,3) = Sfcprop%hprime(:,9) - clx(:,4) = Sfcprop%hprime(:,10) - elseif (Model%nmtvr == 6) then - oc(:) = Sfcprop%hprime(:,2) - oa4(:,1) = Sfcprop%hprime(:,3) - oa4(:,2) = Sfcprop%hprime(:,4) - oa4(:,3) = Sfcprop%hprime(:,5) - oa4(:,4) = Sfcprop%hprime(:,6) - clx(:,1) = 0.0 - clx(:,2) = 0.0 - clx(:,3) = 0.0 - clx(:,4) = 0.0 - else - oc = 0 ; oa4 = 0 ; clx = 0 ; theta = 0 ; gamma = 0 ; sigma = 0 - elvmax = 0 - - endif ! end if_nmtvr - -! write(0,*)' before gwd clstp=',clstp,' kdt=',kdt,' lat=',lat - call gwdps(im, ix, im, levs, dvdt, dudt, dtdt, & - Statein%ugrs, Statein%vgrs, Statein%tgrs, & - Statein%qgrs, kpbl, Statein%prsi, del, & - Statein%prsl, Statein%prslk, Statein%phii, & - Statein%phil, dtp, kdt, & - Sfcprop%hprime(1,1), oc, oa4, clx, theta, & - sigma, gamma, elvmax, dusfcg, dvsfcg, & - con_g, con_cp, con_rd, con_rv, Model%lonr, & - Model%nmtvr, Model%cdmbgwd, me, lprnt,ipr) - -! if (lprnt) print *,' dudtg=',dudt(ipr,:) - - if (Model%lssav) then - Diag%dugwd(:) = Diag%dugwd(:) + dusfcg(:)*dtf - Diag%dvgwd(:) = Diag%dvgwd(:) + dvsfcg(:)*dtf - -! if (lprnt) print *,' dugwd=',dugwd(ipr),' dusfcg=',dusfcg(ipr) -! if (lprnt) print *,' dvgwd=',dvgwd(ipr),' dvsfcg=',dvsfcg(ipr) - - if (Model%ldiag3d) then - Diag%du3dt(:,:,2) = Diag%du3dt(:,:,2) + dudt(:,:) * dtf - Diag%dv3dt(:,:,2) = Diag%dv3dt(:,:,2) + dvdt(:,:) * dtf - Diag%dt3dt(:,:,2) = Diag%dt3dt(:,:,2) + dtdt(:,:) * dtf - endif - endif - -! Rayleigh damping near the model top -!zhang: in NEMS ral_ts=10., in comfv3 =0.0 - if( .not. Model%lsidea .and. Model%ral_ts > 0.0) then - call rayleigh_damp(im, ix, im, levs, dvdt, dudt, dtdt, & - Statein%ugrs, Statein%vgrs, dtp, con_cp, & - Model%levr, Statein%pgr, Statein%prsl, & - Model%prslrd0, Model%ral_ts) - endif - -! if (lprnt) then -! write(0,*)' tgrs1=',(tgrs(ipr,ik),k=1,10) -! write(0,*)' dtdt=',(dtdt(ipr,ik),k=1,10) -! endif - -!zhang: GFS_physics_update_state - Stateout%gt0(:,:) = Statein%tgrs(:,:) + dtdt(:,:) * dtp - Stateout%gu0(:,:) = Statein%ugrs(:,:) + dudt(:,:) * dtp - Stateout%gv0(:,:) = Statein%vgrs(:,:) + dvdt(:,:) * dtp - Stateout%gq0(:,:,:) = Statein%qgrs(:,:,:) + dqdt(:,:,:) * dtp - -! if (lprnt) then -! write(7000,*)' ugrs=',ugrs(ipr,:) -! &,' lat=',lat,' kdt=',kdt,' me=',me -! write(7000,*)' dudt*dtp=',dudt(ipr,:)*dtp -! write(7000,*)' vgrs=',vgrs(ipr,:) -! write(7000,*)' dvdt*dtp ',dvdt(ipr,:)*dtp -! endif -! if(lprnt) write(1000+me,*)' gq0w=',gq0(ipr,:,ntcw) -! if(lprnt) write(0,*)' gq0i=',gq0(ipr,:,ntiw) - - if (Model%lsidea) then ! idea convective adjustment - call ideaca_up(Statein%prsi,Stateout%gt0,ix,im,levs+1) - endif - -! --- ... ozone physics - - if ((Model%ntoz > 0) .and. (ntrac >= Model%ntoz)) then - if (oz_coeff > 4) then - call ozphys_2015 (ix, im, levs, levozp, dtp, & - Stateout%gq0(1,1,Model%ntoz), & - Stateout%gq0(1,1,Model%ntoz), & - Stateout%gt0, oz_pres, Statein%prsl, & - Tbd%ozpl, oz_coeff, del, Model%ldiag3d, & - dq3dt_loc(1,1,6), me) - if (Model%ldiag3d) then - Diag%dq3dt(:,:,6) = dq3dt_loc(:,:,6) - Diag%dq3dt(:,:,7) = dq3dt_loc(:,:,7) - Diag%dq3dt(:,:,8) = dq3dt_loc(:,:,8) - Diag%dq3dt(:,:,9) = dq3dt_loc(:,:,9) - endif - else - call ozphys (ix, im, levs, levozp, dtp, & - Stateout%gq0(1,1,Model%ntoz), & - Stateout%gq0(1,1,Model%ntoz), & - Stateout%gt0, oz_pres, Statein%prsl, & - Tbd%ozpl, oz_coeff, del, Model%ldiag3d, & - dq3dt_loc(1,1,6), me) - if (Model%ldiag3d) then - Diag%dq3dt(:,:,6) = dq3dt_loc(:,:,6) - Diag%dq3dt(:,:,7) = dq3dt_loc(:,:,7) - Diag%dq3dt(:,:,8) = dq3dt_loc(:,:,8) - Diag%dq3dt(:,:,9) = dq3dt_loc(:,:,9) - endif - endif - endif - - if (Model%h2o_phys) then - call h2ophys (ix, im, levs, levh2o, dtp, Stateout%gq0(1,1,1), & - Stateout%gq0(1,1,1), h2o_pres, Statein%prsl, & - Tbd%h2opl, h2o_coeff, Model%ldiag3d, & - dq3dt_loc(1,1,1), me) - endif - -! --- ... to side-step the ozone physics - -! if (ntrac >= 2) then -! do k = 1, levs -! gq0(k,ntoz) = qgrs(k,ntoz) -! enddo -! endif - -! if (lprnt) then -! write(0,*) ' levs=',levs,' jcap=',jcap,' dtp',dtp & -! &, ' slmsk=',slmsk(ilon,ilat),' kdt=',kdt -! print *,' rann=',rann,' ncld=',ncld,' iq=',iq,' lat=',lat -! print *,' pgr=',pgr -! print *,' del=',del(ipr,:) -! print *,' prsl=',prsl(ipr,:) -! print *,' prslk=',prslk(ipr,:) -! print *,' rann=',rann(ipr,1) -! write(0,*)' gt0=',gt0(ipr,:) & -! &, ' kdt=',kdt,' xlon=',xlon(ipr),' xlat=',xlat(ipr) -! print *,' dtdt=',dtdt(ipr,:) -! print *,' gu0=',gu0(ipr,:) -! print *,' gv0=',gv0(ipr,:) -! write(0,*) ' gt0=',(gt0(ipr,k),k=1,levs),' kdt=',kdt -! write(0,*)' gq0=',(gq0(ipr,k,1),k=1,levs),' lat=',lat -! write(0,*)' gq0i2=',(gq0(ipr,k,ntiw),k=1,levs),' lat=',lat -! write(0,*)' gq1=',(gq0(ipr,k,ntcw),k=1,levs) -! print *,' vvel=',vvel -! endif -! if (lprnt) write(7000,*)' bef convection gu0=',gu0(ipr,:) -! &,' lat=',lat,' kdt=',kdt,' me=',me -! if (lprnt) write(7000,*)' bef convection gv0=',gv0(ipr,:) - - if (Model%ldiag3d) then - dtdt(:,:) = Stateout%gt0(:,:) - dudt(:,:) = Stateout%gu0(:,:) - dvdt(:,:) = Stateout%gv0(:,:) - elseif (Model%cnvgwd) then - dtdt(:,:) = Stateout%gt0(:,:) - endif ! end if_ldiag3d/cnvgwd - - if (Model%ldiag3d .or. Model%lgocart) then - dqdt(:,:,1) = Stateout%gq0(:,:,1) - endif ! end if_ldiag3d/lgocart - -#ifdef GFS_HYDRO - call get_phi(im, ix, levs, ntrac, Stateout%gt0, Stateout%gq0, & - Model%thermodyn_id, Model%sfcpress_id, & - Model%gen_coord_hybrid Statein%prsi, Statein%prsik, & - Statein%prsl, Statein%prslk, Statein%phii, Statein%phil) -#else -!GFDL Adjust the height hydrostatically in a way consistent with FV3 discretization - call get_phi_fv3 (ix, levs, ntrac, Stateout%gt0, Stateout%gq0, & - del_gz, Statein%phii, Statein%phil) -#endif - -! if (lprnt) then -! print *,' phii2=',phii(ipr,k=1,levs) -! print *,' phil2=',phil(ipr,:) -! endif - -!zhang:zhao-carr_pre - clw(:,:,1) = 0.0 - clw(:,:,2) = -999.9 -!zhang: CPS_pre - if ((Model%imfdeepcnv >= 0) .or. (Model%imfshalcnv > 0)) then - cnvc(:,:) = 0.0 - cnvw(:,:) = 0.0 - endif - -! write(0,*)' before cnv clstp=',clstp,' kdt=',kdt,' lat=',lat - -! --- ... for convective tracer transport (while using ras) - - if (Model%ras .or. Model%cscnv) then - if (tottracer > 0) then - if (Model%ntoz > 0) then - clw(:,:,3) = Stateout%gq0(:,:,Model%ntoz) - if (tracers > 0) then - do n=1,tracers - clw(:,:,3+n) = Stateout%gq0(:,:,n+trc_shft) - enddo - endif - else - do n=1,tracers - clw(:,:,2+n) = Stateout%gq0(:,:,n+trc_shft) - enddo - endif - endif - endif ! end if_ras or cfscnv - -!zhang: CPS_PRE - ktop(:) = 1 - kbot(:) = levs - -! --- ... calling condensation/precipitation processes -! -------------------------------------------- -!zhang:ntcw=3 - if (Model%ntcw > 0) then -!zhang: GFS,rhc used in shoc and zhao-carr,mstadj - do k=1,levs - do i=1,im - tem = rhbbot - (rhbbot-rhbtop) * (1.0-Statein%prslk(i,k)) - tem = rhc_max * work1(i) + tem * work2(i) - rhc(i,k) = max(0.0, min(1.0,tem)) - enddo - enddo -!zhang:ncld=1 - if (Model%ncld == 2) then - clw(:,:,1) = Stateout%gq0(:,:,Model%ntiw) ! ice - clw(:,:,2) = Stateout%gq0(:,:,Model%ntcw) ! water - else -!zhang: GFS_suite_interstitial , clw used in both zhao-carr and SASAS deep/shal - if (Model%num_p3d == 4) then ! zhao-carr microphysics - psautco_l(:) = Model%psautco(1)*work1(:) + Model%psautco(2)*work2(:) - prautco_l(:) = Model%prautco(1)*work1(:) + Model%prautco(2)*work2(:) - clw(:,:,1) = Stateout%gq0(:,:,Model%ntcw) - endif ! end if_num_p3d - endif ! end if (ncld == 2) - else ! if_ntcw - psautco_l(:) = Model%psautco(1)*work1(:) + Model%psautco(2)*work2(:) - prautco_l(:) = Model%prautco(1)*work1(:) + Model%prautco(2)*work2(:) - rhc(:,:) = 1.0 - endif ! end if_ntcw -! -! Call SHOC if do_shoc is true and shocaftcnv is false -! - if (Model%do_shoc .and. .not. Model%shocaftcnv) then - if (Model%ncld == 2) then - skip_macro = Model%do_shoc - clw(:,:,1) = Stateout%gq0(:,:,Model%ntiw) ! ice - clw(:,:,2) = Stateout%gq0(:,:,Model%ntcw) ! water - ncpl(:,:) = Stateout%gq0(:,:,Model%ntlnc) - ncpi(:,:) = Stateout%gq0(:,:,Model%ntinc) - elseif (Model%num_p3d == 4) then - do k=1,levs - do i=1,im - qpl(i,k) = 0.0 - qpi(i,k) = 0.0 - if (abs(Stateout%gq0(i,k,Model%ntcw)) < epsq) then - Stateout%gq0(i,k,Model%ntcw) = 0.0 - endif - tem = Stateout%gq0(i,k,Model%ntcw) & - & * max(0.0, MIN(1.0, (TCR-Stateout%gt0(i,k))*TCRF)) - clw(i,k,1) = tem ! ice - clw(i,k,2) = Stateout%gq0(i,k,Model%ntcw) - tem ! water - enddo - enddo - endif - -! dtshoc = 60.0 -! dtshoc = 120.0 -! dtshoc = dtp -! nshocm = (dtp/dtshoc) + 0.001 -! dtshoc = dtp / nshocm -! do nshoc=1,nshocm -! if (lprnt) write(1000+me,*)' before shoc tke=',clw(ipr,:,ntk), -! &' kdt=',kdt,' lat=',lat,'xlon=',xlon(ipr),' xlat=',xlat(ipr) - -! phy_f3d(1,1,ntot3d-2) - shoc determined sgs clouds -! phy_f3d(1,1,ntot3d-1) - shoc determined diffusion coefficients -! phy_f3d(1,1,ntot3d ) - shoc determined w'theta' -! -! dqdt(1:im,:,1) = gq0(1:im,:,1) -! dqdt(1:im,:,2) = gq0(1:im,:,ntiw) -! dqdt(1:im,:,3) = gq0(1:im,:,ntcw) -!GFDL lat has no meaning inside of shoc - changed to "1" -!GFDL call shoc(ix, im, 1, levs, levs+1, dtp, me, lat, - call shoc (ix, im, 1, levs, levs+1, dtp, me, 1, Statein%prsl(1,1), & - Statein%phii(1,1), Statein%phil(1,1), Stateout%gu0(1,1), & - Stateout%gv0(1,1), Statein%vvl(1,1), Stateout%gt0(1,1), & - Stateout%gq0(1,1,1), clw(1,1,1), clw(1,1,2), qpi, qpl, & - rhc, Model%sup, Tbd%phy_f3d(1,1,Model%ntot3d-2), & - clw(1,1,ntk), hflx, evap, prnum, & - Tbd%phy_f3d(1,1,Model%ntot3d-1), & - Tbd%phy_f3d(1,1,Model%ntot3d), lprnt, ipr, ncpl, ncpi, kdt) - -! if (lprnt) write(0,*)' aftshoccld=',phy_f3d(ipr,:,ntot3d-2)*100 -! if (lprnt) write(0,*)' aftshocice=',clw(ipr,:,1) -! if (lprnt) write(0,*)' aftshocwat=',clw(ipr,:,1) -! write(1000+me,*)' at latitude = ',lat -! rain1 = 0.0 -! call moist_bud(im,im,ix,levs,me,kdt,con_g,dtp,del,rain1 -! &, dqdt(1,1,1), dqdt(1,1,2), dqdt(1,1,3) -! &, gq0(1,1,1),clw(1,1,2),clw(1,1,1),'shoc ') - - if ((Model%ntlnc > 0) .and. (Model%ntinc > 0) .and. (Model%ncld >= 2)) then - Stateout%gq0(:,:,Model%ntlnc) = ncpl(:,:) - Stateout%gq0(:,:,Model%ntinc) = ncpi(:,:) - endif -! do k=1,levs -! do i=1,im -! sgs_cld(i,k) = sgs_cld(i,k) + shoc_cld(i,k) -! enddo -! enddo -! if (lprnt) write(0,*)' gt03=',gt0(ipr,1:10) -! if (lprnt) write(0,*)' tke=',clw(ipr,1:10,ntk) - -! if (lprnt) write(1000+me,*)' after shoc tke=',clw(1,:,ntk), -! &' kdt=',kdt -! enddo -! -! do k=1,levs -! write(1000+me,*)' maxcld=',maxval(sgs_cld(1:im,k)), -! write(1000+me,*)' maxtkh=',maxval(phy_f3d(1:im,k,ntot3d-1)), -! &' k=',k,' kdt=',kdt,' lat=',lat -! enddo - -! write(0,*)' aft shoc gt0=',gt0(1,:),' lat=',lat -! write(0,*)' aft shoc gq0=',gq0(1,:,1),' lat=',lat -! write(0,*)' aft shoc gu0=',gu0(1,:),' lat=',lat -! - endif ! if(do_shoc) - -! --- ... calling convective parameterization -! - if (.not. Model%ras .and. .not. Model%cscnv) then - - if (Model%imfdeepcnv == 1) then ! no random cloud top - call sascnvn (im, ix, levs, Model%jcap, dtp, del, & - Statein%prsl, Statein%pgr, Statein%phil, clw(:,:,1:2), & - Stateout%gq0, Stateout%gt0, Stateout%gu0, & - Stateout%gv0, cld1d, rain1, kbot, ktop, kcnv, & - islmsk, Statein%vvl, Model%ncld, ud_mf, dd_mf, & - dt_mf, cnvw, cnvc) - elseif (Model%imfdeepcnv == 2) then - call mfdeepcnv (im, ix, levs, dtp, del, Statein%prsl, & - Statein%pgr, Statein%phil, clw(:,:,1:2), Stateout%gq0, & - Stateout%gt0, Stateout%gu0, Stateout%gv0, & - cld1d, rain1, kbot, ktop, kcnv, islmsk, & - garea, Statein%vvl, Model%ncld, ud_mf, dd_mf, & - dt_mf, cnvw, cnvc) -! if (lprnt) print *,' rain1=',rain1(ipr) - elseif (Model%imfdeepcnv == 0) then ! random cloud top - call sascnv (im, ix, levs, Model%jcap, dtp, del, & - Statein%prsl, Statein%pgr, Statein%phil, clw(:,:,1:2), & - Stateout%gq0, Stateout%gt0, Stateout%gu0, & - Stateout%gv0, cld1d, rain1, kbot, ktop, kcnv, & - islmsk, Statein%vvl, Tbd%rann, Model%ncld, & - ud_mf, dd_mf, dt_mf, cnvw, cnvc) -! if (lprnt) print *,' rain1=',rain1(ipr),' rann=',rann(ipr,1) - endif - else ! ras or cscnv - if (Model%cscnv) then ! Chikira-Sugiyama convection scheme (via CSU) - otspt(:,:) = .true. - otspt(1:3,:) = .false. - if (Model%ntke > 0) then - otspt(Model%ntke-trc_shft+4,1) = .false. - endif - if (Model%ncld == 2) then - otspt(Model%ntlnc-trc_shft+4,1) = .false. - otspt(Model%ntinc-trc_shft+4,1) = .false. - endif - - fscav(:) = 0.0 - fswtr(:) = 0.0 -! write(0,*)' bef cs_cconv phii=',phii(ipr,:) -! &,' sizefsc=',size(fscav) -! write(0,*)' bef cs_cconv otspt=',otspt,' kdt=',kdt,' me=',me - dqdt(:,:,1) = Stateout%gq0(:,:,1) - dqdt(:,:,2) = max(0.0,clw(:,:,2)) - dqdt(:,:,3) = max(0.0,clw(:,:,1)) -! if (lprnt) write(0,*)' gq0bfcs=',gq0(ipr,1:35,1) -! if (lprnt) write(0,*)' gq0bfcs3=',gq0(ipr,1:35,3) -! if (lprnt) write(0,*)' gq0bfcs4=',gq0(ipr,1:35,4) - - do_awdd = ((Model%do_aw) .and. (Model%cs_parm(6) > 0.0)) -! if (lprnt) write(0,*)' do_awdd=',do_awdd -!GFDL again lat replaced with "1" -!GFDL & otspt, lat, kdt , & - call cs_convr (ix, im, levs, tottracer+3, Model%nctp, otspt, 1, & - kdt, Stateout%gt0, Stateout%gq0(1,1,1:1), rain1, & - clw, Statein%phil, Statein%phii, Statein%prsl, & - Statein%prsi, dtp, dtf, ud_mf, dd_mf, dt_mf, & - Stateout%gu0, Stateout%gv0, fscav, fswtr, & - Tbd%phy_fctd, me, wcbmax, Model%cs_parm(3), & - Model%cs_parm(4), sigmai, sigmatot, vverti, & - Model%do_aw, do_awdd, lprnt, ipr, QLCN, QICN, & - w_upi, cf_upi, CNV_MFD, CNV_PRC3, CNV_DQLDT, & - CLCN, CNV_FICE, CNV_NDROP, CNV_NICE, Model%ncld) - -! if (lprnt) write(0,*)' gq0afcs=',gq0(ipr,1:35,1) -! if (lprnt) write(0,*)' gq0afcs3=',gq0(ipr,1:35,3) -! if (lprnt) write(0,*)' gq0afcs4=',gq0(ipr,1:35,4) -! write(1000+me,*)' at latitude = ',lat -! call moist_bud(im,im,ix,levs,me,kdt,con_g,dtp,del,rain1 -! &, dqdt(1,1,1), dqdt(1,1,2), dqdt(1,1,3) -! &, gq0(1,1,1),clw(1,1,2),clw(1,1,1),' cs_conv') - - rain1(:) = rain1(:) * (dtp*0.001) - if (Model%do_aw) then - do k=1,levs - kk = min(k+1,levs) ! assuming no cloud top reaches the model top - do i = 1,im !DD - sigmafrac(i,k) = 0.5 * (sigmatot(i,k)+sigmatot(i,kk)) - enddo - enddo - endif - -! if (lprnt) then -! write(0,*)' gt01=',gt0(ipr,:),' kdt=',kdt -! write(0,*)' gq01=',gq0(ipr,:,1),' kdt=',kdt -! write(0,*)' clw1=',clw(ipr,:,1),' kdt=',kdt -! write(0,*)' clw2=',clw(ipr,:,1),' kdt=',kdt -! write(0,*)' aft cs rain1=',rain1(ipr)*86400 -! write(0,*)' aft cs rain1=',rain1(ipr) -! endif - - else ! ras version 2 - - if ((Model%ccwf(1) >= 0.0) .or. (Model%ccwf(2) >= 0)) then - ccwfac(:) = Model%ccwf(1)*work1(:) + Model%ccwf(2)*work2(:) - dlqfac(:) = Model%dlqf(1)*work1(:) + Model%dlqf(2)*work2(:) - lmh (:) = levs - else - ccwfac(:) = -999.0 - dlqfac(:) = 0.0 - lmh (:) = levs - endif -! if (lprnt) write(0,*) ' calling ras for kdt=',kdt,' me=',me & -! &, ' lprnt=',lprnt,' ccwfac=',ccwfac(ipr) - -! do k=1,levs -! do i=1,im -! dqdt(i,k,1) = gq0(i,k,1) -! dqdt(i,k,2) = max(0.0,clw(i,k,2)) -! dqdt(i,k,3) = max(0.0,clw(i,k,1)) -! enddo -! enddo -! if (lat == 64 .and. kdt == 1) write(0,*)' qliq=',clw(1,:,1) -! if (lat == 64 .and. kdt == 1) write(0,*)' qice=',clw(1,:,2) - - revap = .true. -! if (ncld ==2) revap = .false. - call rascnv (im, ix, levs, dtp, dtf, Tbd%rann, Stateout%gt0, & - Stateout%gq0, Stateout%gu0, Stateout%gv0, clw, & - tottracer, fscav, Statein%prsi, Statein%prsl, & - Statein%prsik, Statein%prslk, Statein%phil, & - Statein%phii, kpbl, cd, rain1, kbot, ktop, kcnv, & - Tbd%phy_f2d(1,Model%num_p2d), Model%flipv, pa2mb, & - me, garea, lmh, ccwfac, Model%nrcm, rhc, ud_mf, & - dd_mf, dt_mf, dlqfac, lprnt, ipr, kdt, revap, QLCN, & - QICN, w_upi, cf_upi, CNV_MFD, CNV_PRC3, CNV_DQLDT, & - CLCN, CNV_FICE, CNV_NDROP, CNV_NICE, Model%ncld ) - endif - -! write(1000+me,*)' at latitude = ',lat -! tx1 = 1000.0 -! call moist_bud(im,im,ix,levs,me,kdt,con_g,tx1,del,rain1 -! &, dqdt(1,1,1), dqdt(1,1,2), dqdt(1,1,3) -! &, gq0(1,1,1),clw(1,1,2),clw(1,1,1),' ras_conv') -! if(lprnt) write(0,*)' after ras rain1=',rain1(ipr) -! &,' cnv_prc3sum=',sum(cnv_prc3(ipr,1:levs)) -! if (lprnt) write(0,*)' gt04=',gt0(ipr,1:10) -! if (lprnt) write(0,*)' gq04=',gq0(ipr,:,1) - - cld1d = 0 - - if (Model%ldiag3d .or. Model%lgocart) then - Coupling%upd_mfi(:,:) = 0. - Coupling%dwn_mfi(:,:) = 0. - Coupling%det_mfi(:,:) = 0. - endif - if (Model%lgocart) then - Coupling%dqdti(:,:) = 0. - Coupling%cnvqci(:,:) = 0. - endif - - if (Model%lgocart) then - Coupling%upd_mfi(:,:) = Coupling%upd_mfi(:,:) + ud_mf(:,:) * frain - Coupling%dwn_mfi(:,:) = Coupling%dwn_mfi(:,:) + dd_mf(:,:) * frain - Coupling%det_mfi(:,:) = Coupling%det_mfi(:,:) + dt_mf(:,:) * frain - Coupling%cnvqci (:,:) = Coupling%cnvqci (:,:) + (clw(:,:,1)+clw(:,:,2) - & - Stateout%gq0(:,:,Model%ntcw)) * frain - endif ! if (lgocart) - -! --- ... update the tracers due to convective transport - - if (tottracer > 0) then - if (Model%ntoz > 0) then ! for ozone - Stateout%gq0(:,:,Model%ntoz) = clw(:,:,3) - - if (tracers > 0) then ! for other tracers - do n=1,tracers - Stateout%gq0(:,:,n+trc_shft) = clw(:,:,3+n) - enddo - endif - else - do n=1,tracers - Stateout%gq0(:,:,n+trc_shft) = clw(:,:,2+n) - enddo - endif - endif - endif ! end if_not_ras - -! if (lprnt) then -! write(0,*)' aftcnvgt0=',gt0(ipr,:),' kdt=',kdt,' lat=',lat -! write(0,*)' aftcnvgq0=',(gq0(ipr,k,1),k=1,levs),' lat=',lat -! write(0,*)' gq0i2=',(gq0(ipr,k,ntiw),k=1,levs),' lat=',lat -! write(0,*)' aftcnvgq1=',(gq0(ipr,k,ntcw),k=1,levs) -! endif -! -!zhang: sasas shal_pre - do i = 1, im - Diag%rainc(:) = frain * rain1(:) - enddo -! - if (Model%lssav) then - Diag%cldwrk (:) = Diag%cldwrk (:) + cld1d(:) * dtf - Diag%cnvprcp(:) = Diag%cnvprcp(:) + Diag%rainc(:) - - if (Model%ldiag3d) then - Diag%dt3dt(:,:,4) = Diag%dt3dt(:,:,4) + (Stateout%gt0(:,:)-dtdt(:,:)) * frain - Diag%dq3dt(:,:,2) = Diag%dq3dt(:,:,2) + (Stateout%gq0(:,:,1)-dqdt(:,:,1)) * frain - Diag%du3dt(:,:,3) = Diag%du3dt(:,:,3) + (Stateout%gu0(:,:)-dudt(:,:)) * frain - Diag%dv3dt(:,:,3) = Diag%dv3dt(:,:,3) + (Stateout%gv0(:,:)-dvdt(:,:)) * frain - - Diag%upd_mf(:,:) = Diag%upd_mf(:,:) + ud_mf(:,:) * (con_g*frain) - Diag%dwn_mf(:,:) = Diag%dwn_mf(:,:) + dd_mf(:,:) * (con_g*frain) - Diag%det_mf(:,:) = Diag%det_mf(:,:) + dt_mf(:,:) * (con_g*frain) - endif ! if (ldiag3d) - - endif ! end if_lssav -! -! update dqdt_v to include moisture tendency due to deep convection - if (Model%lgocart) then - Coupling%dqdti (:,:) = (Stateout%gq0(:,:,1) - dqdt(:,:,1)) * frain - Coupling%upd_mfi(:,:) = Coupling%upd_mfi(:,:) + ud_mf(:,:) * frain - Coupling%dwn_mfi(:,:) = Coupling%dwn_mfi(:,:) + dd_mf(:,:) * frain - Coupling%det_mfi(:,:) = Coupling%det_mfi(:,:) + dt_mf(:,:) * frain - Coupling%cnvqci (:,:) = Coupling%cnvqci (:,:) + (clw(:,:,1)+clw(:,:,2))*frain - endif ! if (lgocart) -! -!zhang: for pdf cld and zhao - if ((Model%npdf3d == 3) .and. (Model%num_p3d == 4)) then - num2 = Model%num_p3d + 2 - num3 = num2 + 1 - Tbd%phy_f3d(:,:,num2) = cnvw(:,:) - Tbd%phy_f3d(:,:,num3) = cnvc(:,:) -!zhang:zhao-car,num_p3d=4,GFS_DCNV_generic_post - elseif ((Model%npdf3d == 0) .and. (Model%ncnvcld3d == 1)) then - num2 = Model%num_p3d + 1 - Tbd%phy_f3d(:,:,num2) = cnvw(:,:) - endif - -! if (lprnt) write(7000,*)' bef cnvgwd gu0=',gu0(ipr,:) -! &,' lat=',lat,' kdt=',kdt,' me=',me -! if (lprnt) write(7000,*)' bef cnvgwd gv0=',gv0(ipr,:) -! -!----------------Convective gravity wave drag parameterization starting -------- -!zhang:gwdc_pre - if (Model%cnvgwd) then ! call convective gravity wave drag - -! --- ... calculate maximum convective heating rate -! cuhr = temperature change due to deep convection - - cumabs(:) = 0.0 - work3 (:) = 0.0 - do k = 1, levs - do i = 1, im - if (k >= kbot(i) .and. k <= ktop(i)) then - cumabs(i) = cumabs(i) + (Stateout%gt0(i,k)-dtdt(i,k)) * del(i,k) - work3(i) = work3(i) + del(i,k) - endif - enddo - enddo - do i=1,im - if (work3(i) > 0.0) cumabs(i) = cumabs(i) / (dtp*work3(i)) - enddo - -! do i = 1, im -! do k = kbot(i), ktop(i) -! do k1 = kbot(i), k -! cumchr(i,k) = cuhr(i,k1) + cumchr(i,k) -! enddo -! cumchr(i,k) = cumchr(i,k) / cumabs(i) -! enddo -! enddo - -! --- ... begin check print ****************************************** - -! if (lprnt) then -! if (kbot(ipr) <= ktop(ipr)) then -! write(*,*) 'kbot <= ktop for (lat,lon) = ', & -! & xlon(ipr)*57.29578,xlat(ipr)*57.29578 -! write(*,*) 'kcnv kbot ktop dlength ',kcnv(ipr), & -! & kbot(ipr),ktop(ipr),dlength(ipr) -! write(*,9000) kdt -!9000 format(/,3x,'k',5x,'cuhr(k)',4x,'cumchr(k)',5x, & -! & 'at kdt = ',i4,/) - -! do k = ktop(ipr), kbot(ipr),-1 -! write(*,9010) k,(86400.*cuhr(ipr,k)),(100.*cumchr(ipr,k)) -!9010 format(2x,i2,2x,f8.2,5x,f6.0) -! enddo -! endif - -! if (fhour >= fhourpr) then -! print *,' before gwdc in gbphys start print' -! write(*,*) 'fhour ix im levs = ',fhour,ix,im,levs -! print *,'dtp dtf = ',dtp,dtf - -! write(*,9100) -!9100 format(//,14x,'pressure levels',// & -! & ' ilev',7x,'prsi',8x,'prsl',8x,'delp',/) - -! k = levs + 1 -! write(*,9110) k,(10.*prsi(ipr,k)) -!9110 format(i4,2x,f10.3) - -! do k = levs, 1, -1 -! write(*,9120) k,(10.*prsl(ipr,k)),(10.*del(ipr,k)) -! write(*,9110) k,(10.*prsi(ipr,k)) -! enddo -!9120 format(i4,12x,2(2x,f10.3)) - -! write(*,9130) -!9130 format(//,10x,'before gwdc in gbphys',//,' ilev',6x, & -! & 'ugrs',9x,'gu0',8x,'vgrs',9x,'gv0',8x, & -! & 'tgrs',9x,'gt0',8x,'gt0b',8x,'dudt',8x,'dvdt',/) - -! do k = levs, 1, -1 -! write(*,9140) k,ugrs(ipr,k),gu0(ipr,k), & -! & vgrs(ipr,k),gv0(ipr,k), & -! & tgrs(ipr,k),gt0(ipr,k),dtdt(ipr,k), & -! & dudt(ipr,k),dvdt(ipr,k) -! enddo -!9140 format(i4,9(2x,f10.3)) - -! print *,' before gwdc in gbphys end print' -! endif -! endif ! end if_lprnt - -! --- ... end check print ******************************************** - -!GFDL replacing lat with "1" -! call gwdc(im, ix, im, levs, lat, gu0, gv0, gt0, gq0, dtp, & -!zhang:gwdc_run - call gwdc (im, ix, im, levs, 1, Statein%ugrs, Statein%vgrs, & - Statein%tgrs, Statein%qgrs, dtp, Statein%prsl, & - Statein%prsi, del, cumabs, ktop, kbot, kcnv, cldf, & - con_g, con_cp, con_rd, con_fvirt, con_pi, dlength, & - lprnt, ipr, Model%fhour, gwdcu, gwdcv, dusfcg, dvsfcg) - -! if (lprnt) then -! if (fhour >= fhourpr) then -! print *,' after gwdc in gbphys start print' - -! write(*,9131) -!9131 format(//,10x,'after gwdc in gbphys',//,' ilev',6x, & -! & 'ugrs',9x,'gu0',8x,'vgrs',9x,'gv0',8x, & -! & 'tgrs',9x,'gt0',8x,'gt0b',7x,'gwdcu',7x,'gwdcv',/) - -! do k = levs, 1, -1 -! write(*,9141) k,ugrs(ipr,k),gu0(ipr,k), & -! & vgrs(ipr,k),gv0(ipr,k), & -! & tgrs(ipr,k),gt0(ipr,k),dtdt(ipr,k), & -! & gwdcu(ipr,k),gwdcv(ipr,k) -! enddo -!9141 format(i4,9(2x,f10.3)) - -! print *,' after gwdc in gbphys end print' -! endif -! endif - -! --- ... write out cloud top stress and wind tendencies - - if (Model%lssav) then - Diag%dugwd(:) = Diag%dugwd(:) + dusfcg(:)*dtf - Diag%dvgwd(:) = Diag%dvgwd(:) + dvsfcg(:)*dtf - - if (Model%ldiag3d) then - Diag%du3dt(:,:,4) = Diag%du3dt(:,:,4) + gwdcu(:,:) * dtf - Diag%dv3dt(:,:,4) = Diag%dv3dt(:,:,4) + gwdcv(:,:) * dtf - endif - endif ! end if_lssav - -! --- ... update the wind components with gwdc tendencies - - do k = 1, levs - do i = 1, im - eng0 = 0.5*(Stateout%gu0(i,k)*Stateout%gu0(i,k)+Stateout%gv0(i,k)*Stateout%gv0(i,k)) - Stateout%gu0(i,k) = Stateout%gu0(i,k) + gwdcu(i,k) * dtp - Stateout%gv0(i,k) = Stateout%gv0(i,k) + gwdcv(i,k) * dtp - eng1 = 0.5*(Stateout%gu0(i,k)*Stateout%gu0(i,k)+Stateout%gv0(i,k)*Stateout%gv0(i,k)) - Stateout%gt0(i,k) = Stateout%gt0(i,k) + (eng0-eng1)/(dtp*con_cp) - enddo -! if (lprnt) write(7000,*)' gu0=',gu0(ipr,k),' gwdcu=', -! &gwdcu(ipr,k), ' gv0=', gv0(ipr,k),' gwdcv=',gwdcv(ipr,k) -! &,' k=',k - enddo - -! if (lprnt) then -! if (fhour >= fhourpr) then -! print *,' after tendency gwdc in gbphys start print' - -! write(*,9132) -!9132 format(//,10x,'after tendency gwdc in gbphys',//,' ilev',6x,& -! & 'ugrs',9x,'gu0',8x,'vgrs',9x,'gv0',8x, & -! & 'tgrs',9x,'gt0',8x,'gt0b',7x,'gwdcu',7x,'gwdcv',/) - -! do k = levs, 1, -1 -! write(*,9142) k,ugrs(ipr,k),gu0(ipr,k),vgrs(ipr,k), & -! & gv0(ipr,k),tgrs(ipr,k),gt0(ipr,k),dtdt(ipr,k), & -! & gwdcu(ipr,k),gwdcv(ipr,k) -! enddo -!9142 format(i4,9(2x,f10.3)) - -! print *,' after tendency gwdc in gbphys end print' -! endif -! endif - - endif ! end if_cnvgwd (convective gravity wave drag) - -! if (lprnt) write(7000,*)' aft cnvgwd gu0=',gu0(ipr,:) -! if (lprnt) write(7000,*)' aft cnvgwd gv0=',gv0(ipr,:) -! &,' lat=',lat,' kdt=',kdt,' me=',me -!----------------Convective gravity wave drag parameterization over -------- - -!zhang: GFS_SCNV_generic_pre - if (Model%ldiag3d) then - dtdt(:,:) = Stateout%gt0(:,:) - endif - if (Model%ldiag3d .or. Model%lgocart) then - dqdt(:,:,1) = Stateout%gq0(:,:,1) - endif - -! write(0,*)' before do_shoc shal clstp=',clstp,' kdt=',kdt, -! & ' lat=',lat -! if (lprnt) then -! write(0,*)' prsl=',prsl(ipr,:) -! write(0,*) ' del=',del(ipr,:) -! write(0,*) ' befshalgt0=',gt0(ipr,:),' kdt=',kdt -! write(0,*) ' befshalgq0=',gt0(ipr,:),' kdt=',kdt -! write(0,*) ' befshalgq0=',gq0(ipr,:,1),' kdt=',kdt -! write(0,*) ' befshalgqw=',gq0(ipr,:,3),' kdt=',kdt -! endif - - if (.not. Model%do_shoc) then - - if (Model%shal_cnv) then ! Shallow convection parameterizations -! -------------------------------------- - if (Model%imfshalcnv == 1) then ! opr option now at 2014 - !----------------------- - call shalcnv (im, ix, levs, Model%jcap, dtp, del, Statein%prsl, & - Statein%pgr, Statein%phil, clw, Stateout%gq0, & - Stateout%gt0, Stateout%gu0, Stateout%gv0, rain1, & - kbot, ktop, kcnv, islmsk, Statein%vvl, Model%ncld,& - Diag%hpbl, hflx, evap, ud_mf, dt_mf, cnvw, cnvc) - - raincs(:) = frain * rain1(:) - Diag%rainc(:) = Diag%rainc(:) + raincs(:) - if (Model%lssav) then - Diag%cnvprcp(:) = Diag%cnvprcp(:) + raincs(:) - endif - if ((Model%shcnvcw) .and. (Model%num_p3d == 4) .and. (Model%npdf3d == 3)) then - Tbd%phy_f3d(:,:,num2) = cnvw(:,:) - Tbd%phy_f3d(:,:,num3) = cnvc(:,:) - elseif ((Model%npdf3d == 0) .and. (Model%ncnvcld3d == 1)) then - num2 = Model%num_p3d + 1 - Tbd%phy_f3d(:,:,num2) = cnvw(:,:) - endif - - elseif (Model%imfshalcnv == 2) then - call mfshalcnv (im, ix, levs, dtp, del, Statein%prsl, & - Statein%pgr, Statein%phil, clw, Stateout%gq0, & - Stateout%gt0, Stateout%gu0, Stateout%gv0, & - rain1, kbot, ktop, kcnv, islmsk, garea, & - Statein%vvl, Model%ncld, DIag%hpbl, ud_mf, & - dt_mf, cnvw, cnvc) - - raincs(:) = frain * rain1(:) - Diag%rainc(:) = DIag%rainc(:) + raincs(:) - if (Model%lssav) then - Diag%cnvprcp(:) = Diag%cnvprcp(:) + raincs(:) - endif - if ((Model%shcnvcw) .and. (Model%num_p3d == 4) .and. (Model%npdf3d == 3)) then - Tbd%phy_f3d(:,:,num2) = cnvw(:,:) - Tbd%phy_f3d(:,:,num3) = cnvc(:,:) - elseif ((Model%npdf3d == 0) .and. (Model%ncnvcld3d == 1)) then - num2 = Model%num_p3d + 1 - Tbd%phy_f3d(:,:,num2) = cnvw(:,:) - endif - - elseif (Model%imfshalcnv == 0) then ! modified Tiedtke Shallow convecton - !----------------------------------- - levshc(:) = 0 - do k = 2, levs - do i = 1, im - dpshc = 0.3 * Statein%prsi(i,1) - if (Statein%prsi(i,1)-Statein%prsi(i,k) <= dpshc) levshc(i) = k - enddo - enddo - levshcm = 1 - do i = 1, im - levshcm = max(levshcm, levshc(i)) - enddo - -! if (lprnt) print *,' levshcm=',levshcm,' gt0sh=',gt0(ipr,:) -! &, ' lat=',lat - - if (Model%mstrat) then ! As in CFSv2 - call shalcv (im, ix, levshcm, dtp, del, Statein%prsi, & - Statein%prsl, Statein%prslk,kcnv, Stateout%gq0, & - Stateout%gt0, levshc, Statein%phil, kinver, & - ctei_r, ctei_rml, lprnt, ipr) - else - call shalcvt3 (im, ix, levshcm, dtp, del, Statein%prsi, & - Statein%prsl, Statein%prslk, kcnv, & - Stateout%gq0, Stateout%gt0) - endif -! if (lprnt) print *,' levshcm=',levshcm,' gt0sha=',gt0(ipr,:) - - endif ! end if_imfshalcnv - endif ! end if_shal_cnv - - if (Model%lssav) then -! update dqdt_v to include moisture tendency due to shallow convection - if (Model%lgocart) then - do k = 1, levs - do i = 1, im - tem = (Stateout%gq0(i,k,1)-dqdt(i,k,1)) * frain - Coupling%dqdti(i,k) = Coupling%dqdti(i,k) + tem - enddo - enddo - endif -!zhang: GFS_diagnostics - if (Model%ldiag3d) then - Diag%dt3dt(:,:,5) = Diag%dt3dt(:,:,5) + (Stateout%gt0(:,:)-dtdt(:,:)) * frain - Diag%dq3dt(:,:,3) = Diag%dq3dt(:,:,3) + (Stateout%gq0(:,:,1)-dqdt(:,:,1)) * frain - endif - endif ! end if_lssav -! -!zhang: GFS_suite_interstitial - do k = 1, levs - do i = 1, im - if (clw(i,k,2) <= -999.0) clw(i,k,2) = 0.0 - enddo - enddo - -! if (lprnt) then -! write(0,*)' prsl=',prsl(ipr,:) -! write(0,*) ' del=',del(ipr,:) -! write(0,*) ' befshgt0=',gt0(ipr,:) -! write(0,*) ' befshgq0=',gq0(ipr,:,1) -! endif - - elseif (Model%shocaftcnv) then ! if do_shoc is true and shocaftcnv is true call shoc - if (Model%ncld == 2) then - skip_macro = Model%do_shoc - ncpl(:,:) = Stateout%gq0(:,:,Model%ntlnc) - ncpi(:,:) = Stateout%gq0(:,:,Model%ntinc) - -! else -! if (clw(1,1,2) < -999.0) then ! if clw is not partitioned to ice and water -! do k=1,levs -! do i=1,im -! tem = gq0(i,k,ntcw) & -! & * max(0.0, MIN(1.0, (TCR-gt0(i,k))*TCRF)) -! clw(i,k,1) = tem ! ice -! clw(i,k,2) = gq0(i,k,ntcw) - tem ! water -! enddo -! enddo -! endif ! Anning ncld ==2 - endif - qpl(:,:) = 0.0 - qpi(:,:) = 0.0 -! dtshoc = 60.0 -! nshocm = (dtp/dtshoc) + 0.001 -! dtshoc = dtp / nshocm -! do nshoc=1,nshocm -! call shoc(im, 1, levs, levs+1, dtp, me, lat, & -!! call shoc(im, 1, levs, levs+1, dtshoc, me, lat, & -! & prsl(1:im,:), phii (1:im,:), phil(1:im,:),& -! & gu0(1:im,:),gv0(1:im,:), vvl(1:im,:), gt0(1:im,:), & -! & gq0(1:im,:,1), & -! & clw(1:im,:,1), clw(1:im,:,2), qpi, qpl, sgs_cld(1:im,:)& -! &, gq0(1:im,:,ntke), & -! & phy_f3d(1:im,:,ntot3d-1), phy_f3d(1:im,:,ntot3d), & -! & lprnt, ipr, & -! & con_cp, con_g, con_hvap, con_hfus, con_hvap+con_hfus, & -! & con_rv, con_rd, con_pi, con_fvirt) - -!GFDL replace lat with "1: -! call shoc(ix, im, 1, levs, levs+1, dtshoc, me, lat, & - call shoc (ix, im, 1, levs, levs+1, dtp, me, 1, Statein%prsl(1,1), & - Statein%phii(1,1), Statein%phil(1,1), Stateout%gu0(1,1), & - Stateout%gv0(1,1), Statein%vvl(1,1), Stateout%gt0(1,1), & - Stateout%gq0(1,1,1), clw(1,1,1), clw(1,1,2), qpi, qpl,rhc, & - Model%sup, Tbd%phy_f3d(1,1,Model%ntot3d-2), & - Stateout%gq0(1,1,Model%ntke), hflx, evap, prnum, & - Tbd%phy_f3d(1,1,Model%ntot3d-1), Tbd%phy_f3d(1,1,Model%ntot3d),& - lprnt, ipr, ncpl, ncpi, kdt) - - if ((Model%ntlnc > 0) .and. (Model%ntinc > 0) .and. (Model%ncld >= 2)) then - Stateout%gq0(:,:,Model%ntlnc) = ncpl(:,:) - Stateout%gq0(:,:,Model%ntinc) = ncpi(:,:) - endif - -! -! do k=1,levs -! write(1000+me,*)' maxtkh=',maxval(phy_f3d(1:im,k,ntot3d-1)), & -! ' k=',k,' kdt=',kdt,' lat=',lat -! enddo - -! write(0,*)' aft shoc gt0=',gt0(1,:),' lat=',lat -! write(0,*)' aft shoc gq0=',gq0(1,:,1),' lat=',lat -! write(0,*)' aft shoc gu0=',gu0(1,:),' lat=',lat -! - endif ! if( .not. do_shoc) -! -! if (lprnt) then -! write(0,*)' prsl=',prsl(ipr,:) -! write(0,*) ' del=',del(ipr,:) -! write(0,*) ' aftshgt0=',gt0(ipr,:) -! write(0,*) ' aftshgq0=',gq0(ipr,:,1) -! endif - - if (Model%ntcw > 0) then - -! for microphysics - if (Model%ncld == 2) then ! morrison microphysics - Stateout%gq0(:,:,Model%ntiw) = clw(:,:,1) ! ice - Stateout%gq0(:,:,Model%ntcw) = clw(:,:,2) ! water - elseif (Model%num_p3d == 4) then ! if_num_p3d -!zhang:zhao-carr_pre - Stateout%gq0(:,:,Model%ntcw) = clw(:,:,1) + clw(:,:,2) - endif ! end if_num_p3d - - else ! if_ntcw - - clw(:,:,1) = clw(:,:,1) + clw(:,:,2) - - - endif ! end if_ntcw - -! Legacy routine which determines convectve clouds - should be removed at some point -!zhang: cnvc90_run, need to be CCPP_compliant - call cnvc90 (Model%clstp, im, ix, Diag%rainc, kbot, ktop, levs, Statein%prsi, & - Tbd%acv, Tbd%acvb, Tbd%acvt, Cldprop%cv, Cldprop%cvb, Cldprop%cvt) - - if (Model%moist_adj) then ! moist convective adjustment -! --------------------------- -! -! To call moist convective adjustment -! -! if (lprnt) then -! print *,' prsl=',prsl(ipr,:) -! print *,' del=',del(ipr,:) -! print *,' gt0b=',gt0(ipr,:) -! print *,' gq0b=',gq0(ipr,:,1) -! endif - - call mstcnv (im, ix, levs, dtp, Stateout%gt0, Stateout%gq0, & - Statein%prsl,del, Statein%prslk, rain1, & - Stateout%gq0(1,1,Model%ntcw), rhc, lprnt, ipr) - -! if (lprnt) then -! print *,' rain1=',rain1(ipr),' rainc=',rainc(ipr) -! print *,' gt0a=',gt0(ipr,:) -! print *,' gq0a=',gq0(ipr,:,1) -! endif - Diag%rainc(:) = Diag%rainc(:) + frain * rain1(:) - if(Model%lssav) then - Diag%cnvprcp(:) = Diag%cnvprcp(:) + rain1(:) * frain - -! update dqdt_v to include moisture tendency due to surface processes -! dqdt_v : instaneous moisture tendency (kg/kg/sec) -! if (lgocart) then -! do k=1,levs -! do i=1,im -! tem = (gq0(i,k,1)-dqdt(i,k,1)) * frain -! dqdt_v(i,k) = dqdt_v(i,k) + tem -! dqdt_v(i,k) = dqdt_v(i,k) / dtf -! enddo -! enddo -! endif - if (Model%ldiag3d) then - Diag%dt3dt(:,:,4) = Diag%dt3dt(:,:,4) + (Stateout%gt0(:,:) -dtdt(:,:) ) * frain - Diag%dq3dt(:,:,2) = Diag%dq3dt(:,:,2) + (Stateout%gq0(:,:,1)-dqdt(:,:,1)) * frain - endif - endif - endif ! moist convective adjustment over -! - if (Model%ldiag3d .or. Model%do_aw) then - dtdt(:,:) = Stateout%gt0(:,:) - dqdt(:,:,1) = Stateout%gq0(:,:,1) - do n=Model%ntcw,Model%ntcw+Model%ncld-1 - dqdt(:,:,n) = Stateout%gq0(:,:,n) - enddo - endif - -! dqdt_v : instaneous moisture tendency (kg/kg/sec) - if (Model%lgocart) then - Coupling%dqdti(:,:) = Coupling%dqdti(:,:) / dtf - endif -! -! grid-scale condensation/precipitations and microphysics parameterization -! ------------------------------------------------------------------------ - - if (Model%ncld == 0) then ! no cloud microphysics - - call lrgscl (ix, im, levs, dtp, Stateout%gt0, Stateout%gq0, & - Statein%prsl, del, Statein%prslk, rain1, clw) -!zhang - elseif (Model%ncld == 1) then ! microphysics with single cloud condensate - - if (Model%num_p3d == 4) then ! call zhao/carr/sundqvist microphysics - - if (Model%npdf3d /= 3) then ! without pdf clouds - -! if (lprnt) then -! write(0,*)' prsl=',prsl(ipr,:) -! write(0,*) ' del=',del(ipr,:) -! write(0,*) ' beflsgt0=',gt0(ipr,:),' kdt=',kdt -! write(0,*) ' beflsgq0=',gq0(ipr,:,1),' kdt=',kdt -! write(0,*) ' beflsgw0=',gq0(ipr,:,3),' kdt=',kdt -! endif - ! ------------------ - if (Model%do_shoc) then - call precpd_shoc (im, ix, levs, dtp, del, Statein%prsl, & - Stateout%gq0(1,1,1), Stateout%gq0(1,1,Model%ntcw), & - Stateout%gt0, rain1, Diag%sr, rainp, rhc, & - psautco_l, prautco_l, Model%evpco, Model%wminco, & - Tbd%phy_f3d(1,1,Model%ntot3d-2), lprnt, ipr) - else - -! call gscond (im, ix, levs, dtp, dtf, Statein%prsl, Statein%pgr, & - call gscond_run (im, ix, levs, dtp, dtf, Statein%prsl, Statein%pgr,& -! Stateout%gq0(1,1,1), Stateout%gq0(1,1,Model%ntcw), & -! Stateout%gt0, Tbd%phy_f3d(1,1,1), Tbd%phy_f3d(1,1,2), & -! Tbd%phy_f2d(1,1), Tbd%phy_f3d(1,1,3), & -! Tbd%phy_f3d(1,1,4), Tbd%phy_f2d(1,2), rhc,lprnt, ipr) - Stateout%gq0(:,:,1), Stateout%gq0(:,:,Model%ntcw), & - Stateout%gt0, Tbd%phy_f3d(:,:,1), Tbd%phy_f3d(:,:,2), & - Tbd%phy_f2d(:,1), Tbd%phy_f3d(:,:,3), & - Tbd%phy_f3d(:,:,4), Tbd%phy_f2d(:,2), rhc,lprnt, ipr) - -! call precpd (im, ix, levs, dtp, del, Statein%prsl, & - call precpd_run (im, ix, levs, dtp, del, Statein%prsl, & -! Stateout%gq0(1,1,1), Stateout%gq0(1,1,Model%ntcw), & - Stateout%gq0(:,:,1), Stateout%gq0(:,:,Model%ntcw), & - Stateout%gt0, rain1, Diag%sr, rainp, rhc, psautco_l, & - prautco_l, Model%evpco, Model%wminco, lprnt, ipr) - endif -! if (lprnt) then -! write(0,*)' prsl=',prsl(ipr,:) -! write(0,*) ' del=',del(ipr,:) -! write(0,*) ' aftlsgt0=',gt0(ipr,:),' kdt=',kdt -! write(0,*) ' aftlsgq0=',gq0(ipr,:,1),' kdt=',kdt -! write(0,*) ' aftlsgw0=',gq0(ipr,:,3),' kdt=',kdt -! write(0,*)' aft precpd rain1=',rain1(1:3),' lat=',lat -! endif - else ! with pdf clouds - ! --------------- - call gscondp (im, ix, levs, dtp, dtf, Statein%prsl, & - Statein%pgr, Stateout%gq0(1,1,1), & - Stateout%gq0(1,1,Model%ntcw), Stateout%gt0, & - Tbd%phy_f3d(1,1,1), Tbd%phy_f3d(1,1,2), & - Tbd%phy_f2d(1,1), Tbd%phy_f3d(1,1,3), & - Tbd%phy_f3d(1,1,4), Tbd%phy_f2d(1,2), rhc, & - Tbd%phy_f3d(1,1,Model%num_p3d+1), Model%sup, & - lprnt, ipr, kdt) - - call precpdp (im, ix, levs, dtp, del, Statein%prsl, & - Statein%pgr, Stateout%gq0(1,1,1), & - Stateout%gq0(1,1,Model%ntcw), Stateout%gt0, & - rain1, Diag%sr, rainp, rhc, & - Tbd%phy_f3d(1,1,Model%num_p3d+1), psautco_l, & - prautco_l, Model%evpco, Model%wminco, lprnt, ipr) - endif ! end of grid-scale precip/microphysics options - endif ! end if_num_p3d - -! if (lprnt) write(0,*) ' rain1=',rain1(ipr),' rainc=',rainc(ipr),' lat=',lat - - elseif (Model%ncld == 2) then ! MGB double-moment microphysics -! Acheng used clw here for other code to run smoothly and minimum change -! to make the code work. However, the nc and clw should be treated -! in other procceses too. August 28/2015; Hope that can be done next -! year. I believe this will make the physical interaction more reasonable -! Anning 12/5/2015 changed ntcw hold liquid only - if (Model%do_shoc) then - if (Model%fprcp == 0) then - clw(:,:,1) = Stateout%gq0(:,:,Model%ntiw) ! ice - clw(:,:,2) = Stateout%gq0(:,:,Model%ntcw) ! water - qrn(:,:) = 0. - qsnw(:,:) = 0. - ncpr(:,:) = 0. - ncps(:,:) = 0. - Tbd%phy_f3d(:,:,1) = Tbd%phy_f3d(:,:,Model%ntot3d-2) ! clouds from shoc - else - clw(:,:,1) = Stateout%gq0(:,:,Model%ntiw) ! ice - clw(:,:,2) = Stateout%gq0(:,:,Model%ntcw) ! water - qrn(:,:) = Stateout%gq0(:,:,Model%ntrw) - qsnw(:,:) = Stateout%gq0(:,:,Model%ntsw) - ncpr(:,:) = Stateout%gq0(:,:,Model%ntrnc) - ncps(:,:) = Stateout%gq0(:,:,Model%ntsnc) - Tbd%phy_f3d(:,:,1) = Tbd%phy_f3d(:,:,Model%ntot3d-2) ! clouds from shoc - end if - elseif ((Model%imfdeepcnv >= 0) .or. (Model%imfshalcnv > 0)) then - if (Model%fprcp == 0) then - clw(:,:,1) = Stateout%gq0(:,:,Model%ntiw) ! ice - clw(:,:,2) = Stateout%gq0(:,:,Model%ntcw) ! water - Tbd%phy_f3d(:,:,1) = max(0.0, min(1.0,Tbd%phy_f3d(:,:,1)+cnvc(:,:))) - ! clouds from t-dt and cnvc - qrn(:,:) = 0. - qsnw(:,:) = 0. - ncpr(:,:) = 0. - ncps(:,:) = 0. - else - clw(:,:,1) = Stateout%gq0(:,:,Model%ntiw) ! ice - clw(:,:,2) = Stateout%gq0(:,:,Model%ntcw) ! water - Tbd%phy_f3d(:,:,1) = max(0.0, min(1.0,Tbd%phy_f3d(:,:,1)+cnvc(:,:))) - ! clouds from t-dt and cnvc - qrn(:,:) = Stateout%gq0(:,:,Model%ntrw) - qsnw(:,:) = Stateout%gq0(:,:,Model%ntsw) - ncpr(:,:) = Stateout%gq0(:,:,Model%ntrnc) - ncps(:,:) = Stateout%gq0(:,:,Model%ntsnc) - endif - else - ! clouds from t-dt and cnvc - if (Model%fprcp == 0 ) then - clw(:,:,1) = Stateout%gq0(:,:,Model%ntiw) ! ice - clw(:,:,2) = Stateout%gq0(:,:,Model%ntcw) ! water - qrn(:,:) = 0. - qsnw(:,:) = 0. - ncpr(:,:) = 0. - ncps(:,:) = 0. - Tbd%phy_f3d(:,:,1) = min(1.0, Tbd%phy_f3d(:,:,1)+cnvc(:,:)) - else - clw(:,:,1) = Stateout%gq0(:,:,Model%ntiw) ! ice - clw(:,:,2) = Stateout%gq0(:,:,Model%ntcw) ! water - qrn(:,:) = Stateout%gq0(:,:,Model%ntrw) - qsnw(:,:) = Stateout%gq0(:,:,Model%ntsw) - ncpr(:,:) = Stateout%gq0(:,:,Model%ntrnc) - ncps(:,:) = Stateout%gq0(:,:,Model%ntsnc) - Tbd%phy_f3d(:,:,1) = min(1.0, Tbd%phy_f3d(:,:,1)+cnvc(:,:)) - endif - endif -! notice clw ix instead of im -! call m_micro_driver(im,ix,levs,flipv,del,dtp,prsl,prsi, -! & prslk,prsik,pgr,vvl,clw(1,1,2), QLCN, clw(1,1,1),QICN, -! if (lprnt) write(0,*)' cnv_mfdbef=',cnv_mfd(ipr,:),' flipv=',flipv -! if(lprnt) write(0,*) ' befgq0=',gq0(ipr,:,1),' kdt=',kdt -! if (lprnt) write(0,*)' clw1bef=',clw(ipr,:,1),' kdt=',kdt -! if (lprnt) write(0,*)' clw2bef=',clw(ipr,:,2),' kdt=',kdt -! if (lprnt) write(0,*)' cloudsb=',phy_f3d(ipr,:,1)*100,' kdt=',kdt -! txa(:,:) = gq0(:,:,1) - call m_micro_driver (im, ix, levs, Model%flipv, dtp, Statein%prsl, & - Statein%prsi, Statein%prslk, Statein%prsik, & - Statein%vvl, clw(1,1,2), QLCN, clw(1,1,1), QICN, & - Radtend%htrlw, Radtend%htrsw, w_upi, cf_upi, & - FRLAND, Diag%HPBL, CNV_MFD, CNV_PRC3, CNV_DQLDT, & - CLCN, Stateout%gu0, Stateout%gv0, Diag%dusfc, & - Diag%dvsfc, dusfc1, dvsfc1, dusfc1, dvsfc1, & - CNV_FICE, CNV_NDROP, CNV_NICE, Stateout%gq0(1,1,1), & - Stateout%gq0(1,1,Model%ntcw), & - Stateout%gq0(1,1,Model%ntiw), Stateout%gt0, rain1, & - Diag%sr, Stateout%gq0(1,1,Model%ntlnc), & - Stateout%gq0(1,1,Model%ntinc), Model%fprcp, qrn, & - qsnw, ncpr, ncps, Tbd%phy_f3d(1,1,1), kbot, & - Model%aero_in, skip_macro, cn_prc, cn_snr, lprnt, & - ipr, kdt, Grid%xlat, Grid%xlon) - -! write(1000+me,*)' at latitude = ',lat -! tx1 = 1000.0 -! call moist_bud(im,ix,ix,levs,me,kdt,con_g,tx1,del,rain1 -! &, txa, clw(1,1,2), clw(1,1,1) -! &, gq0(1,1,1),gq0(1,1,ntcw),gq0(1,1,ntcw+1),' m_micro ') - -! if (lprnt) write(0,*) ' rain1=',rain1(ipr)*86400.0, -! &' rainc=',rainc(ipr)*86400.0 -! &,' cn_prc=',cn_prc(ipr),' cn_snr=',cn_snr(ipr) -! if (lprnt) write(0,*) ' aftlsgq0=',gq0(ipr,:,1),' kdt=',kdt -! if (lprnt) write(0,*)' clw1aft=',gq0(ipr,:,ntiw),' kdt=',kdt -! if (lprnt) write(0,*)' cloudsm=',phy_f3d(ipr,:,1)*100,' kdt=',kdt -! if (lprnt) write(0,*)' clw2aft=',gq0(ipr,:,ntcw),' kdt=',kdt - - if (Model%fprcp == 1) then - Stateout%gq0(:,:,Model%ntrw) = qrn(:,:) - Stateout%gq0(:,:,Model%ntsw) = qsnw(:,:) - Stateout%gq0(:,:,Model%ntrnc) = ncpr(:,:) - Stateout%gq0(:,:,Model%ntsnc) = ncps(:,:) - endif - endif ! end if_ncld -! if (lprnt) write(0,*)' rain1 after ls=',rain1(ipr) -! - if (Model%do_aw) then -! Arakawa-Wu adjustment of large-scale microphysics tendencies: -! reduce by factor of (1-sigma) -! these are microphysics increments. We want to keep (1-sigma) of the increment, -! we will remove sigma*increment from final values -! fsigma = 0. ! don't apply any AW correction, in addition comment next line -! fsigma = sigmafrac - -! adjust sfc rainrate for conservation -! vertically integrate reduction of water increments, reduce precip by that amount - - temrain1(:) = 0.0 - do k = 1,levs - do i = 1,im - tem1 = sigmafrac(i,k) - Stateout%gt0(i,k) = Stateout%gt0(i,k) - tem1 * (Stateout%gt0(i,k)-dtdt(i,k)) - tem2 = tem1 * (Stateout%gq0(i,k,1)-dqdt(i,k,1)) - Stateout%gq0(i,k,1) = Stateout%gq0(i,k,1) - tem2 - temrain1(i) = temrain1(i) - (Statein%prsi(i,k)-Statein%prsi(i,k+1)) & - * tem2 * onebg - enddo - enddo - do n=Model%ntcw,Model%ntcw+Model%ncld-1 - do k = 1,levs - do i = 1,im - tem1 = sigmafrac(i,k) * (Stateout%gq0(i,k,n)-dqdt(i,k,n)) - Stateout%gq0(i,k,n) = Stateout%gq0(i,k,n) - tem1 - temrain1(i) = temrain1(i) - (Statein%prsi(i,k)-Statein%prsi(i,k+1)) & - * tem1 * onebg - enddo - enddo - enddo -! write(1000+me,*)' rain1=',rain1(4),' temrain1=',temrain1(i)*0.001 - rain1(:) = max(rain1(:) - temrain1(:)*0.001, 0.0_kind_phys) - endif - - Diag%rain(:) = Diag%rainc(:) + frain * rain1(:) - - if (Model%cal_pre) then ! hchuang: add dominant precipitation type algorithm - i = min(3,Model%num_p3d) - call calpreciptype (kdt, Model%nrcm, im, ix, levs, levs+1, & - Tbd%rann, Grid%xlat, Grid%xlon, Stateout%gt0, & - Stateout%gq0, Statein%prsl, Statein%prsi, & - Diag%rain, Statein%phii, Model%num_p3d, & - Sfcprop%tsfc, Diag%sr, Tbd%phy_f3d(1,1,i), & ! input - domr, domzr, domip, doms) ! output -! -! if (lprnt) print*,'debug calpreciptype: DOMR,DOMZR,DOMIP,DOMS ' -! &,DOMR(ipr),DOMZR(ipr),DOMIP(ipr),DOMS(ipr) -! do i=1,im -! if (abs(xlon(i)*57.29578-114.0) .lt. 0.2 .and. -! & abs(xlat(i)*57.29578-40.0) .lt. 0.2) -! & print*,'debug calpreciptype: DOMR,DOMZR,DOMIP,DOMS ', -! & DOMR(i),DOMZR(i),DOMIP(i),DOMS(i) -! end do -! HCHUANG: use new precipitation type to decide snow flag for LSM snow accumulation - - do i=1,im - if(doms(i) > 0.0 .or. domip(i) > 0.0) then - Sfcprop%srflag(i) = 1. - else - Sfcprop%srflag(i) = 0. - end if - enddo - endif - - if (Model%lssav) then - Diag%totprcp(:) = Diag%totprcp(:) + Diag%rain(:) - - if (Model%ldiag3d) then - Diag%dt3dt(:,:,6) = Diag%dt3dt(:,:,6) + (Stateout%gt0(:,:)-dtdt(:,:)) * frain - Diag%dq3dt(:,:,4) = Diag%dq3dt(:,:,4) + (Stateout%gq0(:,:,1)-dqdt(:,:,1)) * frain - endif - endif - -! --- ... estimate t850 for rain-snow decision - - t850(:) = Stateout%gt0(:,1) - - do k = 1, levs-1 - do i = 1, im - if (Statein%prsl(i,k) > p850 .and. Statein%prsl(i,k+1) <= p850) then - t850(i) = Stateout%gt0(i,k) - (Statein%prsl(i,k)-p850) / & - (Statein%prsl(i,k)-Statein%prsl(i,k+1)) * & - (Stateout%gt0(i,k)-Stateout%gt0(i,k+1)) - endif - enddo - enddo - -! --- ... lu: snow-rain detection is performed in land/sice module - - if (Model%cal_pre) then ! hchuang: new precip type algorithm defines srflag - Sfcprop%tprcp(:) = max(0.0, Diag%rain(:)) ! clu: rain -> tprcp - else - do i = 1, im - Sfcprop%tprcp(i) = max(0.0, Diag%rain(i) )! clu: rain -> tprcp - Sfcprop%srflag(i) = 0. ! clu: default srflag as 'rain' (i.e. 0) - if (t850(i) <= 273.16) then - Sfcprop%srflag(i) = 1. ! clu: set srflag to 'snow' (i.e. 1) - endif - enddo - endif - -! --- ... coupling insertion - - if (Model%cplflx .or. Model%do_sppt) then - do i = 1, im - if (t850(i) > 273.16) then - Coupling%rain_cpl(i) = Coupling%rain_cpl(i) + Diag%rain(i) - else - Coupling%snow_cpl(i) = Coupling%snow_cpl(i) + Diag%rain(i) - endif - enddo - endif - -! --- ... end coupling insertion - -!!! update surface diagnosis fields at the end of phys package -!!! this change allows gocart to use filtered wind fields -!!! - if (Model%lgocart) then - call sfc_diag (im, Statein%pgr, Stateout%gu0, Stateout%gv0, & - Stateout%gt0, Stateout%gq0, Sfcprop%tsfc, qss, & - Sfcprop%f10m, Diag%u10m, Diag%v10m, Sfcprop%t2m, & - Sfcprop%q2m, work3, evap, Sfcprop%ffmm, & - Sfcprop%ffhh, fm10, fh2) - - if (Model%lssav) then - Diag%tmpmax (:) = max(Diag%tmpmax (:),Sfcprop%t2m(:)) - Diag%tmpmin (:) = min(Diag%tmpmin (:),Sfcprop%t2m(:)) - Diag%spfhmax(:) = max(Diag%spfhmax(:),Sfcprop%q2m(:)) - Diag%spfhmin(:) = min(Diag%spfhmin(:),Sfcprop%q2m(:)) - endif - endif - -! --- ... total runoff is composed of drainage into water table and -! runoff at the surface and is accumulated in unit of meters - if (Model%lssav) then - tem = dtf * 0.001 - Diag%runoff(:) = Diag%runoff(:) + (drain(:)+runof(:)) * tem - Diag%srunoff(:) = Diag%srunoff(:) + runof(:) * tem - endif - -! --- ... xw: return updated ice thickness & concentration to global array - do i = 1, im - if (islmsk(i) == 2) then - Sfcprop%hice(i) = zice(i) - Sfcprop%fice(i) = cice(i) - Sfcprop%tisfc(i) = tice(i) - else - Sfcprop%hice(i) = 0.0 - Sfcprop%fice(i) = 0.0 - Sfcprop%tisfc(i) = Sfcprop%tsfc(i) - endif - enddo - -! --- ... return updated smsoil and stsoil to global arrays - Sfcprop%smc(:,:) = smsoil(:,:) - Sfcprop%stc(:,:) = stsoil(:,:) - Sfcprop%slc(:,:) = slsoil(:,:) - -! --- ... calculate column precipitable water "pwat" - Diag%pwat(:) = 0.0 - tem = dtf * 0.03456 / 86400.0 - do k = 1, levs - work1(:) = 0.0 - if (Model%ncld > 0) then - do ic = Model%ntcw, Model%ntcw+Model%ncld-1 - work1(:) = work1(:) + Stateout%gq0(:,k,ic) - enddo - endif - Diag%pwat(:) = Diag%pwat(:) + del(:,k)*(Stateout%gq0(:,k,1)+work1(:)) -! if (lprnt .and. i == ipr) write(0,*)' gq0=', -! &gq0(i,k,1),' qgrs=',qgrs(i,k,1),' work2=',work2(i),' k=',k - enddo - Diag%pwat(:) = Diag%pwat(:) * onebg - -! write(1000+me,*)' pwat=',pwat(i),'i=',i,', -! &' rain=',rain(i)*1000.0,' dqsfc1=',dqsfc1(i)*tem,' kdt=',kdt -! &,' e-p=',dqsfc1(i)*tem-rain(i)*1000.0 -! if (lprnt) write(0,*)' pwat=',pwat(ipr),', -! &' rain=',rain(ipr)*1000.0,' dqsfc1=',dqsfc1(ipr)*tem,' kdt=',kdt -! &,' e-p=',dqsfc1(ipr)*tem-rain(ipr)*1000.0 - -! -! if (lprnt .and. rain(ipr) > 5) call mpi_quit(5678) -! if (lat == 45) write(1000+me,*)' pwat=',pwat(1),' kdt=',kdt -! if (lprnt) then -! write(7000,*) ' endgu0=',gu0(ipr,:),' kdt=',kdt -! write(7000,*) ' endgv0=',gv0(ipr,:),' kdt=',kdt,' nnp=',nnp -! write(0,*) ' endgt0=',gt0(ipr,:),' kdt=',kdt -! write(0,*) ' endgq0=',gq0(ipr,:,1),' kdt=',kdt,' lat=',lat -! write(0,*) ' endgw0=',gq0(ipr,:,3),' kdt=',kdt,' lat=',lat -! endif - - if (Model%do_sppt) then - !--- radiation heating rate - Tbd%dtdtr(:,:) = Tbd%dtdtr(:,:) + dtdtc(:,:)*dtf - !--- change in total precip - Tbd%dtotprcp (:) = Diag%rain (:) - Tbd%dtotprcp(:) - !--- change in convective precip - Tbd%dcnvprcp (:) = Diag%rainc (:) - Tbd%dcnvprcp(:) - do i = 1, im - if (t850(i) > 273.16) then - !--- change in change in rain precip - Tbd%drain_cpl(i) = Diag%rain(i) - Tbd%drain_cpl(i) - else - !--- change in change in snow precip - Tbd%dsnow_cpl(i) = Diag%rain(i) - Tbd%dsnow_cpl(i) - endif - enddo - endif - - deallocate (clw) - if (Model%do_shoc) then - deallocate (qpl, qpi, ncpl, ncpi) - endif - if (allocated(cnvc)) deallocate(cnvc) - if (allocated(cnvw)) deallocate(cnvw) - -! deallocate (fscav, fswtr) -! -! if (lprnt) write(0,*)' end of gbphys maxu=', -! &maxval(gu0(1:im,1:levs)),' minu=',minval(gu0(1:im,1:levs)) -! &,' maxv=',maxval(gv0(1:im,1:levs)),' minv=', -! & minval(gv0(1:im,1:levs)),' kdt=',kdt,' lat=',lat,' nnp=',nnp -! if (lprnt) write(0,*)' end of gbphys gv0=',gv0(:,120:128) -! if (lprnt) write(0,*)' end of gbphys at kdt=',kdt, -! &' rain=',rain(ipr),' rainc=',rainc(ipr) -! if (lprnt) call mpi_quit(7) -! if (kdt > 2 ) call mpi_quit(70) - if (Model%ncld == 2) then ! For MGB double moment microphysics - - deallocate (qlcn, qicn, w_upi, cf_upi, CNV_MFD, CNV_PRC3, & - CNV_DQLDT, clcn, cnv_fice, cnv_ndrop, cnv_nice) - deallocate (qrn, qsnw, ncpr, ncps) - endif - - return -!................................... - end subroutine GFS_physics_driver -!----------------------------------- - - - subroutine moist_bud(im,ix,ix2,levs,me,kdt,grav,dtp,delp,rain, & - qv0,ql0,qi0,qv1,ql1,qi1,comp) -! nov 2016 - S. Moorthi - routine to compute local moisture budget - use machine, only : kind_phys - implicit none - character*10 :: comp - integer :: im,ix,ix2,levs,me,kdt - real (kind=kind_phys) :: grav, rain(im), dtp - real (kind=kind_phys), dimension(ix,levs) :: qv0,ql0,qi0,delp - real (kind=kind_phys), dimension(ix2,levs) :: qv1,ql1,qi1 - REAL (kind=kind_phys), dimension(im) :: sumq, sumqv, sumql, sumqi - integer :: i, k -! - sumqv(:) = 0.0 - sumql(:) = 0.0 - sumqi(:) = 0.0 - sumq (:) = 0.0 - do i=1,im - sumqv(:) = sumqv(:) + (qv1(:,k) - qv0(:,k)) * delp(:,k) - sumql(:) = sumql(:) + (ql1(:,k) - ql0(:,k)) * delp(:,k) - sumqi(:) = sumqi(:) + (qi1(:,k) - qi0(:,k)) * delp(:,k) - enddo - sumqv(:) = - sumqv(:) * (1.0/grav) - sumql(:) = - sumql(:) * (1.0/grav) - sumqi(:) = - sumqi(:) * (1.0/grav) - sumq (:) = sumqv(:) + sumql(:) + sumqi(:) - do i=1,im - write(1000+me,*)' in moist_bud:',' i=',i,' sumq=',sumq(i), & - ' sumqv=',sumqv(i),' sumql=',sumql(i),' sumqi=',sumqi(i), & - ' rain=',rain(i)*dtp,' kdt=',kdt,' component=',comp, & - ' qv:=',qv1(i,1),qv0(i,1),' ql=',ql1(i,1),ql0(i,1), & - ' qi=',qi1(i,1), qi0(i,1) -! if(sumq(i) > 100) then -! write(1000+me,*)' i=',i,' sumq=',sumq(i) -! write(1000+me,*)' qv1=',(qv1(i,k),k=1,levs) -! write(1000+me,*)' qv0=',(qv0(i,k),k=1,levs) -! write(1000+me,*)' ql1=',(ql1(i,k),k=1,levs) -! write(1000+me,*)' ql0=',(ql0(i,k),k=1,levs) -! write(1000+me,*)' qi1=',(qi1(i,k),k=1,levs) -! write(1000+me,*)' qi0=',(qi0(i,k),k=1,levs) -! endif - enddo - return - - end subroutine moist_bud -!> @} - -end module module_physics_driver diff --git a/makefile.orig b/makefile.orig deleted file mode 100644 index 95c891e1b..000000000 --- a/makefile.orig +++ /dev/null @@ -1,189 +0,0 @@ -SHELL = /bin/sh - -inside_nems := $(wildcard ../../../conf/configure.nems) -ifneq ($(strip $(inside_nems)),) - include ../../../conf/configure.nems -else - exist_configure_fv3 := $(wildcard ../conf/configure.fv3) - ifneq ($(strip $(exist_configure_fv3)),) - include ../conf/configure.fv3 - else - $(error "../conf/configure.fv3 file is missing. Run ./configure") - endif - $(info ) - $(info Build standalone FV3 gfsphysics ...) - $(info ) -endif - -LIBRARY = libgfsphys.a - -FFLAGS += -I../fms -I../fms/include - -CPPDEFS = -DNEW_TAUCTMAX -DSMALL_PE -DNEMS_GSM - -SRCS_f = \ - ./physics/cnvc90.f \ - ./physics/co2hc.f \ - ./physics/date_def.f \ - ./physics/dcyc2.f \ - ./physics/dcyc2.pre.rad.f \ - ./physics/efield.f \ - ./physics/get_prs.f \ - ./physics/gfs_phy_tracer_config.f \ - ./physics/gocart_tracer_config_stub.f \ - ./physics/gscond.f \ - ./physics/gscondp.f \ - ./physics/gwdc.f \ - ./physics/gwdps.f \ - ./physics/h2o_def.f \ - ./physics/h2oc.f \ - ./physics/h2ohdc.f \ - ./physics/h2ophys.f \ - ./physics/ideaca.f \ - ./physics/idea_co2.f \ - ./physics/idea_composition.f \ - ./physics/idea_dissipation.f \ - ./physics/idea_h2o.f \ - ./physics/idea_ion.f \ - ./physics/idea_o2_o3.f \ - ./physics/idea_phys.f \ - ./physics/idea_solar_heating.f \ - ./physics/idea_tracer.f \ - ./physics/iounitdef.f \ - ./physics/lrgsclr.f \ - ./physics/mersenne_twister.f \ - ./physics/mfdeepcnv.f \ - ./physics/mfpbl.f \ - ./physics/mfshalcnv.f \ - ./physics/module_bfmicrophysics.f \ - ./physics/moninedmf.f \ - ./physics/moninp.f \ - ./physics/moninp1.f \ - ./physics/moninq.f \ - ./physics/moninq1.f \ - ./physics/moninshoc.f \ - ./physics/mstadb.f \ - ./physics/mstadbtn.f \ - ./physics/mstadbtn2.f \ - ./physics/mstcnv.f \ - ./physics/namelist_soilveg.f \ - ./physics/ozne_def.f \ - ./physics/ozphys.f \ - ./physics/ozphys_2015.f \ - ./physics/physparam.f \ - ./physics/precpd.f \ - ./physics/precpd_shoc.f \ - ./physics/precpdp.f \ - ./physics/precpd_shoc.f \ - ./physics/progt2.f \ - ./physics/progtm_module.f \ - ./physics/rad_initialize.f \ - ./physics/radiation_aerosols.f \ - ./physics/radiation_astronomy.f \ - ./physics/radiation_clouds.f \ - ./physics/radiation_gases.f \ - ./physics/radiation_surface.f \ - ./physics/radlw_datatb.f \ - ./physics/radlw_main.f \ - ./physics/radlw_param.f \ - ./physics/radsw_datatb.f \ - ./physics/radsw_main.f \ - ./physics/radsw_param.f \ - ./physics/rascnvv2.f \ - ./physics/rayleigh_damp.f \ - ./physics/rayleigh_damp_mesopause.f \ - ./physics/sascnv.f \ - ./physics/sascnvn.f \ - ./physics/set_soilveg.f \ - ./physics/sfc_cice.f \ - ./physics/sfc_diag.f \ - ./physics/sfc_diff.f \ - ./physics/sfc_drv.f \ - ./physics/sfc_land.f \ - ./physics/sfc_nst.f \ - ./physics/sfc_ocean.f \ - ./physics/sfc_sice.f \ - ./physics/sfcsub.f \ - ./physics/sflx.f \ - ./physics/shalcnv.f \ - ./physics/shalcv.f \ - ./physics/shalcv_1lyr.f \ - ./physics/shalcv_fixdp.f \ - ./physics/shalcv_opr.f \ - ./physics/tracer_const_h.f \ - ./physics/tridi2t3.f - -SRCS_f90 = \ - ./physics/calpreciptype.f90 \ - ./physics/cs_conv.f90 \ - ./physics/funcphys.f90 \ - ./physics/gcm_shoc.f90 \ - ./physics/gcycle.f90 \ - ./physics/get_prs_fv3.f90 \ - ./physics/h2ointerp.f90 \ - ./physics/m_micro_driver.f90 \ - ./physics/module_nst_model.f90 \ - ./physics/module_nst_parameters.f90 \ - ./physics/module_nst_water_prop.f90 \ - ./physics/ozinterp.f90 \ - ./physics/physcons.f90 \ - ./physics/wam_f107_kp_mod.f90 - -SRCS_F = ./physics/aer_cloud.F \ - ./physics/cldmacro.F \ - ./physics/cldwat2m_micro.F \ - ./physics/machine.F \ - ./physics/num_parthds.F \ - ./physics/wv_saturation.F - -SRCS_F90 = \ - ./physics/GFDL_parse_tracers.F90 \ - ./GFS_layer/GFS_abstraction_layer.F90 \ - ./GFS_layer/GFS_diagnostics.F90 \ - ./GFS_layer/GFS_driver.F90 \ - ./GFS_layer/GFS_physics_driver.F90 \ - ./GFS_layer/GFS_radiation_driver.F90 \ - ./GFS_layer/GFS_restart.F90 \ - ./GFS_layer/GFS_typedefs.F90 \ - ./IPD_layer/IPD_driver.F90 \ - ./IPD_layer/IPD_typedefs.F90 - -SRCS_c = - -DEPEND_FILES = $(SRCS_f) $(SRCS_f90) $(SRCS_F) $(SRCS_F90) - -OBJS_f = $(SRCS_f:.f=.o) -OBJS_f90 = $(SRCS_f90:.f90=.o) -OBJS_F = $(SRCS_F:.F=.o) -OBJS_F90 = $(SRCS_F90:.F90=.o) -OBJS_c = $(SRCS_c:.c=.o) - -OBJS = $(OBJS_f) $(OBJS_f90) $(OBJS_F) $(OBJS_F90) $(OBJS_c) - -all default: depend $(LIBRARY) - -$(LIBRARY): $(OBJS) - $(AR) $(ARFLAGS) $@ $? - -# this is the place to override default (implicit) compilation rules -# and create specific (explicit) rules - -./radiation_aerosols.o : ./gfsphys/radiation_aerosols.f - $(FC) $(FFLAGS) $(OTHER_FFLAGS) -xCORE-AVX-I -c $< -o $@ - -.PHONY: clean -clean: - @echo "Cleaning gfsphysics ... " - @echo - $(RM) -f $(LIBRARY) *__genmod.f90 *.o */*.o *.mod *.lst *.i depend - -MKDEPENDS = ../mkDepends.pl -include ../conf/make.rules - -include ./depend - -# do not include 'depend' file if the target contains string 'clean' -ifneq (clean,$(findstring clean,$(MAKECMDGOALS))) - -include depend -endif - diff --git a/physics/calpreciptype.f90.save b/physics/calpreciptype.f90.save deleted file mode 100644 index 7260b974d..000000000 --- a/physics/calpreciptype.f90.save +++ /dev/null @@ -1,1412 +0,0 @@ - subroutine calpreciptype(kdt,nrcm,im,ix,lm,lp1,randomno, & - xlat,xlon, & - gt0,gq0,prsl,prsi,prec, & !input - phii,n3dfercld,tskin,sr,phy_f3d, & !input - domr,domzr,domip,doms) !output - -!$$$ subprogram documentation block -! . . . -! subprogram: calpreciptype compute dominant precip type -! prgrmmr: chuang org: w/np2 date: 2008-05-28 -! -! -! abstract: -! this routine computes precipitation type. -! . it is adopted from post but was made into a column to used by gfs model -! -! -------------------------------------------------------------------- - use funcphys, only : fpvs,ftdp,fpkap,ftlcl,stma,fthe - use physcons -!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - implicit none -! - real, parameter :: pthresh = 0.0, oneog = 1.0/con_g - integer,parameter :: nalg = 5 -! -! declare variables. -! - integer,intent(in) :: kdt,nrcm,im,ix,lm,lp1,n3dfercld - real,intent(in) :: xlat(im),xlon(im) - real,intent(in) :: randomno(ix,nrcm) - real(kind=kind_phys),dimension(im), intent(in) :: prec,sr,tskin - real(kind=kind_phys),dimension(ix,lm), intent(in) :: gt0,gq0,prsl,phy_f3d - real(kind=kind_phys),dimension(ix,lp1),intent(in) :: prsi,phii - real(kind=kind_phys),dimension(im), intent(out) :: domr,domzr,domip,doms - - integer, dimension(nalg) :: sleet,rain,freezr,snow - real(kind=kind_phys),dimension(lm) :: t,q,pmid,f_rimef - real(kind=kind_phys),dimension(lp1) :: pint,zint - real(kind=kind_phys), allocatable :: twet(:),rh(:),td(:) -! - integer i,iwx,isno,iip,izr,irain,k,k1 - real(kind=kind_phys) es,qc,pv,tdpd,pr,tr,pk,tlcl,thelcl,qwet, & - time_vert,time_ncep,time_ramer,time_bourg,time_revised,& - time_dominant,btim,timef,ranl(2) - -! -! computes wet bulb here since two algorithms use it -! lp1=lm+1 -! convert geopotential to height -! do l=1,lp1 -! zint(l)=zint(l)/con_g -! end do -! don't forget to flip 3d arrays around because gfs counts from bottom up - - allocate ( twet(lm),rh(lm),td(lm) ) - -! print*,'debug calpreciptype: ', im,lm,lp1,nrcm - -! time_vert = 0. -! time_ncep = 0. -! time_ramer = 0. -! time_bourg = 0. -! time_revised = 0. - - do i=1,im - if (prec(i) > pthresh) then - do k=1,lm - k1 = lm-k+1 - t(k1) = gt0(i,k) - q(k1) = gq0(i,k) - pmid(k1) = prsl(i,k) ! pressure in pascals - f_rimef(k1) = phy_f3d(i,k) -! -! compute wet bulb temperature -! - pv = pmid(k1)*q(k1)/(con_eps-con_epsm1*q(k1)) - td(k1) = ftdp(pv) - tdpd = t(k1)-td(k1) -! if (pmid(k1) >= 50000.) then ! only compute twet below 500mb to save time - if (tdpd > 0.) then - pr = pmid(k1) - tr = t(k1) - pk = fpkap(pr) - tlcl = ftlcl(tr,tdpd) - thelcl = fthe(tlcl,pk*tlcl/tr) - call stma(thelcl,pk,twet(k1),qwet) - else - twet(k1) = t(k1) - endif -! endif - es = min(fpvs(t(k1)), pmid(k1)) - qc = con_eps*es / (pmid(k1)+con_epsm1*es) - rh(k1) = max(con_epsq,q(k1)) / qc - - k1 = lp1-k+1 - pint(k1) = prsi(i,k) - zint(k1) = phii(i,k) * oneog - - enddo - pint(1) = prsi(i,lp1) - zint(1) = phii(i,lp1) * oneog - -!------------------------------------------------------------------------------- -! if(kdt>15.and.kdt<20) time_vert = time_vert + (timef() - btim) -! debug print statement -! if (abs(xlon(i)*57.29578-114.0) .lt. 0.2 .and. & -! abs(xlat(i)*57.29578-40.0) .lt. 0.2)then -! print*,'debug in calpreciptype: i,im,lm,lp1,xlon,xlat,prec,tskin,sr,nrcm,randomno,n3dfercld ', & -! i,im,lm,lp1,xlon(i)*57.29578,xlat(i)*57.29578,prec(i),tskin(i),sr(i), & -! nrcm,randomno(i,1:nrcm),n3dfercld -! do l=1,lm -! print*,'debug in calpreciptype: l,t,q,p,pint,z,twet', & -! l,t(l),q(l), & -! pmid(l),pint(l),zint(l),twet(l) -! end do -! print*,'debug in calpreciptype: lp1,pint,z ', lp1,pint(lp1),zint(lp1) -! end if -! end debug print statement -! call wetbulb(lm,con_rocp,con_epsq,t,q,pmid,twet) -! if(kdt>10.and.kdt<20)btim = timef() -!------------------------------------------------------------------------------- -! -! instantaneous precipitation type. - - call calwxt(lm,lp1,t,q,pmid,pint,con_fvirt,con_rog,con_epsq,zint,iwx,twet) - snow(1) = mod(iwx,2) - sleet(1) = mod(iwx,4)/2 - freezr(1) = mod(iwx,8)/4 - rain(1) = iwx/8 - -! dominant precipitation type - -!gsm if dominant precip type is requested, 4 more algorithms -!gsm will be called. the tallies are then summed in calwxt_dominant - -! ramer algorithm -! allocate ( rh(lm),td(lm) ) -! do l=1,lm -!hc: use rh and td consistent with gfs ice physics -! es=fpvs(t(l)) -! es=min(es,pmid(l)) -! qc=con_eps*es/(pmid(l)+con_epsm1*es) -! rh(l)=max(con_epsq,q(l))/qc -! pv = pmid(l)*q(l)/(con_eps-con_epsm1*q(l)) -! td(l)=ftdp(pv) -! end do -! if(kdt>10.and.kdt<20)btim = timef() - -! write(0,*)' i=',i,' lm=',lm,' lp1=',lp1,' t=',t(1),q(1),pmid(1) & -! &,' pint=',pint(1),' prec=',prec(i),' pthresh=',pthresh - - call calwxt_ramer(lm,lp1,t,q,pmid,rh,td,pint,iwx) - -! - snow(2) = mod(iwx,2) - sleet(2) = mod(iwx,4)/2 - freezr(2) = mod(iwx,8)/4 - rain(2) = iwx/8 - -! bourgouin algorithm -! iseed=44641*(int(sdat(1)-1)*24*31+int(sdat(2))*24+ihrst)+ & -! & mod(ifhr*60+ifmin,44641)+4357 - - ranl = randomno(i,1:2) - call calwxt_bourg(lm,lp1,ranl,con_g,t,q,pmid,pint,zint(1),iwx) - -! - snow(3) = mod(iwx,2) - sleet(3) = mod(iwx,4)/2 - freezr(3) = mod(iwx,8)/4 - rain(3) = iwx/8 -! -! revised ncep algorithm -! - call calwxt_revised(lm,lp1,t,q,pmid,pint, & - con_fvirt,con_rog,con_epsq,zint,twet,iwx) -! - snow(4) = mod(iwx,2) - sleet(4) = mod(iwx,4)/2 - freezr(4) = mod(iwx,8)/4 - rain(4) = iwx/8 -! -! explicit algorithm (under 18 not admitted without parent or guardian) - - if(n3dfercld == 3) then ! ferrier's scheme - call calwxt_explicit(lm,tskin(i),sr(i),f_rimef,iwx) - snow(5) = mod(iwx,2) - sleet(5) = mod(iwx,4)/2 - freezr(5) = mod(iwx,8)/4 - rain(5) = iwx/8 - else - snow(5) = 0 - sleet(5) = 0 - freezr(5) = 0 - rain(5) = 0 - endif -! - call calwxt_dominant(nalg,rain(1),freezr(1),sleet(1), & - snow(1),domr(i),domzr(i),domip(i),doms(i)) - - else ! prec < pthresh - domr(i) = 0. - domzr(i) = 0. - domip(i) = 0. - doms(i) = 0. - end if - enddo ! end loop for i - - deallocate (twet,rh,td) - return - end -! -!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& -! - subroutine calwxt(lm,lp1,t,q,pmid,pint, & - d608,rog,epsq,zint,iwx,twet) -! -! file: calwxt.f -! written: 11 november 1993, michael baldwin -! revisions: -! 30 sept 1994-setup new decision tree (m baldwin) -! 12 june 1998-conversion to 2-d (t black) -! 01-10-25 h chuang - modified to process hybrid model output -! 02-01-15 mike baldwin - wrf version -! -! -! routine to compute precipitation type using a decision tree -! approach that uses variables such as integrated wet bulb temp -! below freezing and lowest layer temperature -! -! see baldwin and contorno preprint from 13th weather analysis -! and forecasting conference for more details -! (or baldwin et al, 10th nwp conference preprint) -! -!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - implicit none -! -! input: -! t,q,pmid,htm,lmh,zint -! - integer,intent(in) :: lm,lp1 - real,dimension(lm),intent(in) :: t,q,pmid,twet - real,dimension(lp1),intent(in) :: zint,pint - integer,intent(out) :: iwx - real,intent(in) :: d608,rog,epsq - - -! output: -! iwx - instantaneous weather type. -! acts like a 4 bit binary -! 1111 = rain/freezing rain/ice pellets/snow -! where the one's digit is for snow -! the two's digit is for ice pellets -! the four's digit is for freezing rain -! and the eight's digit is for rain -! -! internal: -! -! real, allocatable :: twet(:) - real, parameter :: d00=0.0 - integer karr,licee - real tcold,twarm - -! subroutines called: -! wetbulb -! -! -! initialize weather type array to zero (ie, off). -! we do this since we want iwx to represent the -! instantaneous weather type on return. -! -! -! allocate local storage -! - - integer l,lice,iwrml,ifrzl - real psfck,tdchk,a,tdkl,tdpre,tlmhk,twrmk,areas8,areap4, & - surfw,surfc,dzkl,area1,pintk1,pintk2,pm150,pkl,tkl,qkl - -! allocate ( twet(lm) ) -! - iwx = 0 -! -! find coldest and warmest temps in saturated layer between -! 70 mb above ground and 500 mb -! also find highest saturated layer in that range -! -!meb - psfck = pint(lm+1) -!meb - tdchk = 2.0 - 760 tcold = t(lm) - twarm = t(lm) - licee = lm -! - do l=1,lm - qkl = q(l) - qkl = max(epsq,qkl) - tkl = t(l) - pkl = pmid(l) -! -! skip past this if the layer is not between 70 mb above ground and 500 mb -! - if (pkl < 50000.0 .or. pkl > psfck-7000.0) cycle - a = log(qkl*pkl/(6.1078*(0.378*qkl+0.622))) - tdkl = (237.3*a) / (17.269-a) + 273.15 - tdpre = tkl - tdkl - if (tdpre < tdchk .and. tkl < tcold) tcold = tkl - if (tdpre < tdchk .and. tkl > twarm) twarm = tkl - if (tdpre < tdchk .and. l < licee) licee = l - enddo -! -! if no sat layer at dew point dep=tdchk, increase tdchk -! and start again (but don't make tdchk > 6) -! - if (tcold == t(lm) .and. tdchk < 6.0) then - tdchk = tdchk + 2.0 - goto 760 - endif -! -! lowest layer t -! - karr = 0 - tlmhk = t(lm) -! -! decision tree time -! - if (tcold > 269.15) then - if (tlmhk <= 273.15) then - -! turn on the flag for freezing rain = 4 if its not on already -! izr=mod(iwx(i,j),8)/4 -! if (izr.lt.1) iwx(i,j)=iwx(i,j)+4 - - iwx = iwx + 4 - goto 850 - else -! turn on the flag for rain = 8 -! if its not on already -! irain=iwx(i,j)/8 -! if (irain.lt.1) iwx(i,j)=iwx(i,j)+8 - - iwx = iwx + 8 - goto 850 - endif - endif - karr = 1 - 850 continue -! -! compute wet bulb only at points that need it -! -! call wetbulb(lm,t,q,pmid,karr,twet) -! call wetfrzlvl(twet,zwet) -! - if (karr > 0) then - lice=licee -!meb - psfck = pint(lm+1) -!meb - tlmhk = t(lm) - twrmk = twarm -! -! twet area variables calculate only what is needed -! from ground to 150 mb above surface from ground to tcold layer -! and from ground to 1st layer where wet bulb t < 0.0 -! -! pintk1 is the pressure at the bottom of the layer -! pintk2 is the pressure at the top of the layer -! -! areap4 is the area of twet above -4 c below highest sat lyr -! - areas8 = d00 - areap4 = d00 - surfw = d00 - surfc = d00 -! - do l=lm,lice,-1 - area1 = (twet(l)-269.15) * (zint(l)-zint(l+1)) - if (twet(l) >= 269.15) areap4 = areap4 + area1 - enddo -! - if (areap4 < 3000.0) then -! turn on the flag for snow = 1 -! if its not on already -! isno=mod(iwx(i,j),2) -! if (isno.lt.1) iwx(i,j)=iwx(i,j)+1 - - iwx = iwx + 1 - return - endif -! -! areas8 is the net area of twet w.r.t. freezing in lowest 150mb -! - pintk1 = psfck - pm150 = psfck - 15000. -! - do l=lm,1,-1 - pintk2 = pint(l) - if (pintk1 >= pm150) then - dzkl = zint(l)-zint(l+1) -! sum partial layer if in 150 mb agl layer - if (pintk2 < pm150) & - dzkl = t(l)*(q(l)*d608+1.0)*rog*log(pintk1/pm150) - area1 = (twet(l)-273.15)*dzkl - areas8 = areas8 + area1 - endif - pintk1 = pintk2 - enddo -! -! surfw is the area of twet above freezing between the ground -! and the first layer above ground below freezing -! surfc is the area of twet below freezing between the ground -! and the warmest sat layer -! - ifrzl = 0 - iwrml = 0 -! - do l=lm,1,-1 - if (ifrzl == 0 .and. t(l) < 273.15) ifrzl = 1 - if (iwrml == 0 .and. t(l) >= twrmk) iwrml = 1 -! - if (iwrml == 0 .or. ifrzl == 0) then -! if(pmid(l) < 50000.)print*,'need twet above 500mb' - dzkl = zint(l)-zint(l+1) - area1 = (twet(l)-273.15)*dzkl - if(ifrzl == 0 .and. twet(l) >= 273.15) surfw = surfw + area1 - if(iwrml == 0 .and. twet(l) <= 273.15) surfc = surfc + area1 - endif - enddo - if(surfc < -3000.0 .or. (areas8 < -3000.0 .and. surfw < 50.0)) then -! turn on the flag for ice pellets = 2 if its not on already -! iip=mod(iwx(i,j),4)/2 -! if (iip.lt.1) iwx(i,j)=iwx(i,j)+2 - iwx = iwx + 2 -! - elseif(tlmhk < 273.15) then -! turn on the flag for freezing rain = 4 if its not on already -! izr=mod(iwx(k),8)/4 -! if (izr.lt.1) iwx(k)=iwx(k)+4 - iwx = iwx + 4 - else -! turn on the flag for rain = 8 if its not on already -! irain=iwx(k)/8 -! if (irain.lt.1) iwx(k)=iwx(k)+8 - iwx = iwx + 8 - endif - endif -!--------------------------------------------------------- -! deallocate (twet) - - return - end -! -! -!ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc -! -! dophase is a subroutine written and provided by jim ramer at noaa/fsl -! -! ramer, j, 1993: an empirical technique for diagnosing precipitation -! type from model output. preprints, 5th conf. on aviation -! weather systems, vienna, va, amer. meteor. soc., 227-230. -! -! code adapted for wrf post 24 august 2005 g manikin -!ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc -! - subroutine calwxt_ramer(lm,lp1,t,q,pmid,rh,td,pint,ptyp) - -! subroutine dophase(pq, ! input pressure sounding mb -! + t, ! input temperature sounding k -! + pmid, ! input pressure -! + pint, ! input interface pressure -! + q, ! input spec humidityfraction -! + lmh, ! input number of levels in sounding -! + ptyp) ! output(2) phase 2=rain, 3=frzg, 4=solid, -! 6=ip jc 9/16/99 -! use params_mod -! use ctlblk_mod -!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - implicit none -! - real,parameter :: twice=266.55,rhprcp=0.80,deltag=1.02, & - & emelt=0.045,rlim=0.04,slim=0.85 - real,parameter :: twmelt=273.15,tz=273.15,efac=1.0 ! specify in params now -! - integer*4 i, k1, lll, k2, toodry -! - real xxx ,mye, icefrac - integer, intent(in) :: lm,lp1 - real,dimension(lm), intent(in) :: t,q,pmid,rh,td - real,dimension(lp1),intent(in) :: pint - integer, intent(out) :: ptyp -! - real,dimension(lm) :: tq,pq,rhq,twq -! - integer j,l,lev,ii - real rhmax,twmax,ptop,dpdrh,twtop,rhtop,wgt1,wgt2, & - rhavg,dtavg,dpk,ptw,pbot -! real b,qtmp,rate,qc - real,external :: xmytw -! -! initialize. - icefrac = -9999. -! - - ptyp = 0 - do l = 1,lm - lev = lp1 - l -! p(l)=pmid(l) -! qc=pq0/p(l) * exp(a2*(t(l)-a3)/(t(l)-a4)) -!gsm forcing q (qtmp) to be positive to deal with negative q values -! causing problems later in this subroutine -! qtmp=max(h1m12,q(l)) -! rhqtmp(lev)=qtmp/qc - rhq(lev) = rh(l) - pq(lev) = pmid(l) * 0.01 - tq(lev) = t(l) - enddo - - -! -!cc rate restriction removed by john cortinas 3/16/99 -! -! construct wet-bulb sounding, locate generating level. - twmax = -999.0 - rhmax = 0.0 - k1 = 0 ! top of precip generating layer - k2 = 0 ! layer of maximum rh -! - if (rhq(1) < rhprcp) then - toodry = 1 - else - toodry = 0 - end if -! - pbot = pq(1) -! nq=lm - do l = 1, lm -! xxx = tdofesat(esat(tq(l))*rhq(l)) -! xxx = td(l) !hc: use td consistent with gfs ice physics - xxx = td(lp1-l) !hc: use td consistent with gfs ice physics - if (xxx < -500.) return - twq(l) = xmytw(tq(l),xxx,pq(l)) - twmax = max(twq(l),twmax) - if (pq(l) >= 400.0) then - if (rhq(l) > rhmax) then - rhmax = rhq(l) - k2 = l - end if -! - if (l /= 1) then - if (rhq(l) >= rhprcp .or. toodry == 0) then - if (toodry /= 0) then - dpdrh = log(pq(l)/pq(l-1)) / (rhq(l)-rhq(l-1)) - pbot = exp(log(pq(l))+(rhprcp-rhq(l))*dpdrh) -! - ptw = pq(l) - toodry = 0 - else if (rhq(l)>= rhprcp) then - ptw = pq(l) - else - toodry = 1 - dpdrh = log(pq(l)/pq(l-1)) / (rhq(l)-rhq(l-1)) - ptw = exp(log(pq(l))+(rhprcp-rhq(l))*dpdrh) - -!lin dpdrh = (pq(i)-pq(i-1))/(rhq(i)-rhq(i-1)) -!lin ptw = pq(i)+(rhprcp-rhq(i))*dpdrh -! - end if -! - if (pbot/ptw >= deltag) then -!lin if (pbot-ptw.lt.deltag) goto 2003 - k1 = l - ptop = ptw - end if - end if - end if - end if - enddo -! -! gross checks for liquid and solid precip which dont require generating level. -! - if (twq(1) >= 273.15+2.0) then - ptyp = 8 ! liquid - icefrac = 0.0 - return - end if -! - if (twmax <= twice) then - icefrac = 1.0 - ptyp = 1 ! solid - return - end if -! -! check to see if we had no success with locating a generating level. -! - if (k1 == 0) return -! - if (ptop == pq(k1)) then - twtop = twq(k1) - rhtop = rhq(k1) - k2 = k1 - k1 = k1 - 1 - else - k2 = k1 - k1 = k1 - 1 - wgt1 = log(ptop/pq(k2)) / log(pq(k1)/pq(k2)) - wgt2 = 1.0 - wgt1 - twtop = twq(k1) * wgt1 + twq(k2) * wgt2 - rhtop = rhq(k1) * wgt1 + rhq(k2) * wgt2 - end if -! -! calculate temp and wet-bulb ranges below precip generating level. - do l = 1, k1 - twmax = max(twq(l),twmax) - enddo -! -! gross check for solid precip, initialize ice fraction. -! if (i.eq.1.and.j.eq.1) write (*,*) 'twmax=',twmax,twice,'twtop=',twtop - - if (twtop <= twice) then - icefrac = 1.0 - if (twmax <= twmelt) then ! gross check for solid precip. - ptyp = 1 ! solid precip - return - end if - lll = 0 - else - icefrac = 0.0 - lll = 1 - end if -! -! loop downward through sounding from highest precip generating level. - 30 continue -! - if (icefrac >= 1.0) then ! starting as all ice - if (twq(k1) < twmelt) go to 40 ! cannot commence melting - if (twq(k1) == twtop) go to 40 ! both equal twmelt, nothing h - wgt1 = (twmelt-twq(k1)) / (twtop-twq(k1)) - rhavg = rhq(k1) + wgt1 * (rhtop-rhq(k1)) * 0.5 - dtavg = (twmelt-twq(k1)) * 0.5 - dpk = wgt1 * log(pq(k1)/ptop) !lin dpk=wgt1*(pq(k1)-ptop) -! mye=emelt*(1.0-(1.0-rhavg)*efac) - mye = emelt * rhavg ** efac - icefrac = icefrac + dpk * dtavg / mye - else if (icefrac <= 0.0) then ! starting as all liquid - lll = 1 -! goto 1020 - if (twq(k1) > twice) go to 40 ! cannot commence freezing - if (twq(k1) == twtop) then - wgt1 = 0.5 - else - wgt1 = (twice-twq(k1)) / (twtop-twq(k1)) - end if - rhavg = rhq(k1) + wgt1 * (rhtop-rhq(k1)) * 0.5 - dtavg = twmelt - (twq(k1)+twice) * 0.5 - dpk = wgt1 * log(pq(k1)/ptop) !lin dpk=wgt1*(pq(k1)-ptop) -! mye = emelt*(1.0-(1.0-rhavg)*efac) - mye = emelt * rhavg ** efac - icefrac = icefrac + dpk * dtavg / mye - else if ((twq(k1) <= twmelt).and.(twq(k1) < twmelt)) then ! mix - rhavg = (rhq(k1)+rhtop) * 0.5 - dtavg = twmelt - (twq(k1)+twtop) * 0.5 - dpk = log(pq(k1)/ptop) !lin dpk=pq(k1)-ptop -! mye = emelt*(1.0-(1.0-rhavg)*efac) - mye = emelt * rhavg ** efac - icefrac = icefrac + dpk * dtavg / mye - else ! mix where tw curve crosses twmelt in layer - if (twq(k1) == twtop) go to 40 ! both equal twmelt, nothing h - wgt1 = (twmelt-twq(k1)) / (twtop-twq(k1)) - wgt2 = 1.0 - wgt1 - rhavg = rhtop + wgt2 * (rhq(k1)-rhtop) * 0.5 - dtavg = (twmelt-twtop) * 0.5 - dpk = wgt2 * log(pq(k1)/ptop) !lin dpk=wgt2*(pq(k1)-ptop) -! mye = emelt*(1.0-(1.0-rhavg)*efac) - mye = emelt * rhavg ** efac - icefrac = icefrac + dpk * dtavg / mye - icefrac = min(1.0,max(icefrac,0.0)) - if (icefrac <= 0.0) then -! goto 1020 - if (twq(k1) > twice) go to 40 ! cannot commence freezin - wgt1 = (twice-twq(k1)) / (twtop-twq(k1)) - dtavg = twmelt - (twq(k1)+twice) * 0.5 - else - dtavg = (twmelt-twq(k1)) * 0.5 - end if - rhavg = rhq(k1) + wgt1 * (rhtop-rhq(k1)) * 0.5 - dpk = wgt1 * log(pq(k1)/ptop) !lin dpk=wgt1*(pq(k1)-ptop) -! mye = emelt*(1.0-(1.0-rhavg)*efac) - mye = emelt * rhavg ** efac - icefrac = icefrac + dpk * dtavg / mye - end if -! - icefrac = min(1.0,max(icefrac,0.0)) - -! if (i.eq.1.and.j.eq.1) write (*,*) 'new icefrac:', icefrac, icefrac -! -! get next level down if there is one, loop back. - 40 continue - if (k1 > 1) then - twtop = twq(k1) - ptop = pq(k1) - rhtop = rhq(k1) - k1 = k1 - 1 - go to 30 - end if -! -! determine precip type based on snow fraction and surface wet-bulb. -! - if (icefrac >= slim) then - if (lll /= 0) then - ptyp = 2 ! ice pellets jc 9/16/99 - else - ptyp = 1 ! snow - end if - else if (icefrac <= rlim) then - if (twq(1).lt.tz) then - ptyp = 4 ! freezing precip - else - ptyp = 8 ! rain - end if - else - if (twq(1) < tz) then -!gsm not sure what to do when 'mix' is predicted; in previous -!gsm versions of this code for which i had to have an answer, -!gsm i chose sleet. here, though, since we have 4 other -!gsm algorithms to provide an answer, i will not declare a -!gsm type from the ramer in this situation and allow the -!gsm other algorithms to make the call. - - ptyp = 0 ! don't know -! ptyp = 5 ! mix - else -! ptyp = 5 ! mix - ptyp = 0 ! don't know - end if - end if - - return -! - end -! -! -!-------------------------------------------------------------------------- - function xmytw(t,td,p) -! - implicit none -! - integer*4 cflag, l - real f, c0, c1, c2, k, kd, kw, ew, t, td, p, ed, fp, s, & - & de, xmytw - data f, c0, c1, c2 /0.0006355, 26.66082, 0.0091379024, 6106.3960/ -! - xmytw = (t+td) / 2 - if (td >= t) return -! - if (t < 100.0) then - k = t + 273.15 - kd = td + 273.15 - if (kd >= k) return - cflag = 1 - else - k = t - kd = td - cflag = 0 - end if -! - ed = c0 - c1 * kd - c2 / kd - if (ed < -14.0 .or. ed > 7.0) return - ed = exp(ed) - ew = c0 - c1 * k - c2 / k - if (ew < -14.0 .or. ew > 7.0) return - ew = exp(ew) - fp = p * f - s = (ew-ed) / (k-kd) - kw = (k*fp+kd*s) / (fp+s) -! - do l = 1, 5 - ew = c0 - c1 * kw - c2 / kw - if (ew < -14.0 .or. ew > 7.0) return - ew = exp(ew) - de = fp * (k-kw) + ed - ew - if (abs(de/ew) < 1e-5) exit - s = ew * (c1-c2/(kw*kw)) - fp - kw = kw - de / s - enddo -! -! print *, 'kw ', kw - if (cflag /= 0) then - xmytw = kw - 273.15 - else - xmytw = kw - end if -! - return - end -! -! -!$$$ subprogram documentation block -! -! subprogram: calwxt_bourg calculate precipitation type (bourgouin) -! prgmmr: baldwin org: np22 date: 1999-07-06 -! -! abstract: this routine computes precipitation type -! using a decision tree approach that uses the so-called -! "energy method" of bourgouin of aes (canada) 1992 -! -! program history log: -! 1999-07-06 m baldwin -! 1999-09-20 m baldwin make more consistent with bourgouin (1992) -! 2005-08-24 g manikin added to wrf post -! 2007-06-19 m iredell mersenne twister, best practices -! 2008-03-03 g manikin added checks to prevent stratospheric warming -! episodes from being seen as "warm" layers -! impacting precip type -! -! usage: call calwxt_bourg(im,jm,jsta_2l,jend_2u,jsta,jend,lm,lp1, & -! & iseed,g, & -! & t,q,pmid,pint,lmh,zint,ptype) -! input argument list: -! im integer i dimension -! jm integer j dimension -! jsta_2l integer j dimension start point (including haloes) -! jend_2u integer j dimension end point (including haloes) -! jsta integer j dimension start point (excluding haloes) -! jend integer j dimension end point (excluding haloes) -! lm integer k dimension -! lp1 integer k dimension plus 1 -! iseed integer random number seed -! g real gravity (m/s**2) -! pthresh real precipitation threshold (m) -! t real(im,jsta_2l:jend_2u,lm) mid layer temp (k) -! q real(im,jsta_2l:jend_2u,lm) specific humidity (kg/kg) -! pmid real(im,jsta_2l:jend_2u,lm) mid layer pressure (pa) -! pint real(im,jsta_2l:jend_2u,lp1) interface pressure (pa) -! lmh real(im,jsta_2l:jend_2u) max number of layers -! zint real(im,jsta_2l:jend_2u,lp1) interface height (m) -! output argument list: -! ptype real(im,jm) instantaneous weather type () -! acts like a 4 bit binary -! 1111 = rain/freezing rain/ice pellets/snow -! where the one's digit is for snow -! the two's digit is for ice pellets -! the four's digit is for freezing rain -! and the eight's digit is for rain -! in other words... -! ptype=1 snow -! ptype=2 ice pellets/mix with ice pellets -! ptype=4 freezing rain/mix with freezing rain -! ptype=8 rain -! -! modules used: -! mersenne_twister pseudo-random number generator -! -! subprograms called: -! random_number pseudo-random number generator -! -! attributes: -! language: fortran 90 -! -! remarks: vertical order of arrays must be layer 1 = top -! and layer lmh = bottom -! -!$$$ - subroutine calwxt_bourg(lm,lp1,rn,g,t,q,pmid,pint,zint,ptype) - implicit none -! -! input: - integer,intent(in) :: lm,lp1 - real,intent(in) :: g,rn(2) - real,intent(in), dimension(lm) :: t, q, pmid - real,intent(in), dimension(lp1) :: pint, zint -! -! output: - integer, intent(out) :: ptype -! - integer ifrzl,iwrml,l,lhiwrm - real pintk1,areane,tlmhk,areape,pintk2,surfw,area1,dzkl,psfck,r1,r2 -! -! initialize weather type array to zero (ie, off). -! we do this since we want ptype to represent the -! instantaneous weather type on return. -! - ptype = 0 - psfck = pint(lm+1) - -! find the depth of the warm layer based at the surface -! this will be the cut off point between computing -! the surface based warm air and the warm air aloft -! -! lowest layer t -! - tlmhk = t(lm) - iwrml = lm + 1 - if (tlmhk >= 273.15) then - do l = lm, 2, -1 - if (t(l) >= 273.15 .and. t(l-1) < 273.15 .and. & - & iwrml == lm+1) iwrml = l - end do - end if -! -! now find the highest above freezing level -! - lhiwrm = lm + 1 - do l = lm, 1, -1 -! gsm added 250 mb check to prevent stratospheric warming situations -! from counting as warm layers aloft - if (t(l) >= 273.15 .and. pmid(l) > 25000.) lhiwrm = l - end do - -! energy variables -! surfw is the positive energy between the ground -! and the first sub-freezing layer above ground -! areane is the negative energy between the ground -! and the highest layer above ground -! that is above freezing -! areape is the positive energy "aloft" -! which is the warm energy not based at the ground -! (the total warm energy = surfw + areape) -! -! pintk1 is the pressure at the bottom of the layer -! pintk2 is the pressure at the top of the layer -! dzkl is the thickness of the layer -! ifrzl is a flag that tells us if we have hit -! a below freezing layer -! - pintk1 = psfck - ifrzl = 0 - areane = 0.0 - areape = 0.0 - surfw = 0.0 - - do l = lm, 1, -1 - if (ifrzl == 0 .and. t(l) <= 273.15) ifrzl = 1 - pintk2 = pint(l) - dzkl = zint(l)-zint(l+1) - if (t(l) >= 273.15 .and. pmid(l) > 25000.) then - area1 = log(t(l)/273.15) * g * dzkl - if (l < iwrml) then - areape = areape + area1 - else - surfw = surfw + area1 - endif - elseif (l > lhiwrm) then - area1 = log(t(l)/273.15) * g * dzkl - areane = areane + abs(area1) - endif - pintk1 = pintk2 - enddo - -! -! decision tree time -! - if (areape < 2.0) then ! very little or no positive energy aloft, check for - ! positive energy just above the surface to determine rain vs. snow - if (surfw < 5.6) then ! not enough positive energy just above the surface snow = 1 - ptype = 1 - else if (surfw > 13.2) then ! enough positive energy just above the surface rain = 8 - ptype = 8 - else ! transition zone, assume equally likely rain/snow - ! picking a random number, if <=0.5 snow - r1 = rn(1) - if (r1 <= 0.5) then ! snow = 1 - ptype = 1 - else ! rain = 8 - ptype = 8 - end if - end if -! - else ! some positive energy aloft, check for enough negative energy - ! to freeze and make ice pellets to determine ip vs. zr - - if (areane > 66.0+0.66*areape) then -! enough negative area to make ip, -! now need to check if there is enough positive energy -! just above the surface to melt ip to make rain - if (surfw < 5.6) then ! not enough energy at the surface to melt ip ice pellets = 2 - ptype = 2 - elseif (surfw > 13.2) then ! enough energy at the surface to melt ip rain = 8 - ptype = 8 - else ! transition zone, assume equally likely ip/rain picking a random number, if <=0.5 ip - r1 = rn(1) - if (r1 <= 0.5) then ! ice pellets = 2 - ptype = 2 - else ! rain = 8 - ptype = 8 - end if - end if - elseif (areane < 46.0+0.66*areape) then -! not enough negative energy to refreeze, check surface temp to determine rain vs. zr - if (tlmhk < 273.15) then ! freezing rain = 4 - ptype = 4 - else ! rain = 8 - ptype = 8 - end if - else -! transition zone, assume equally likely ip/zr picking a random number, if <=0.5 ip - r1 = rn(1) - if (r1 <= 0.5) then -! still need to check positive energy just above the surface to melt ip vs. rain - if (surfw < 5.6) then ! ice pellets = 2 - ptype = 2 - else if (surfw > 13.2) then ! rain = 8 - ptype = 8 - else -! transition zone, assume equally likely ip/rain picking a random number, if <=0.5 ip - r2 = rn(2) - if (r2 <= 0.5) then ! ice pellets = 2 - ptype = 2 - else ! rain = 8 - ptype = 8 - end if - end if - else -! not enough negative energy to refreeze, check surface temp to determine rain vs. zr - if (tlmhk < 273.15) then ! freezing rain = 4 - ptype = 4 - else ! rain = 8 - ptype = 8 - end if - end if - end if - end if -! - return - end -! -! - subroutine calwxt_revised(lm,lp1,t,q,pmid,pint, & - d608,rog,epsq,zint,twet,iwx) -! -! file: calwxt.f -! written: 11 november 1993, michael baldwin -! revisions: -! 30 sept 1994-setup new decision tree (m baldwin) -! 12 june 1998-conversion to 2-d (t black) -! 01-10-25 h chuang - modified to process hybrid model output -! 02-01-15 mike baldwin - wrf version -! 05-07-07 binbin zhou - add prec for rsm -! 05-08-24 geoff manikin - modified the area requirements -! to make an alternate algorithm -! -! -! routine to compute precipitation type using a decision tree -! approach that uses variables such as integrated wet bulb temp -! below freezing and lowest layer temperature -! -! see baldwin and contorno preprint from 13th weather analysis -! and forecasting conference for more details -! (or baldwin et al, 10th nwp conference preprint) -! -! since the original version of the algorithm has a high bias -! for freezing rain and sleet, the goal is to balance that bias -! with a version more likely to predict snow -! -! use params_mod -! use ctlblk_mod -!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - implicit none -! -! list of variables needed -! parameters: -! d608,rog,h1,d00 -!hc parameter(d608=0.608,rog=287.04/9.8,h1=1.0,d00=0.0) -! -! input: -! t,q,pmid,htm,lmh,zint - - integer,intent(in) :: lm,lp1 - real,dimension(lm),intent(in) :: t,q,pmid,twet - real,dimension(lp1),intent(in) :: pint,zint - real,intent(in) :: d608,rog,epsq -! output: -! iwx - instantaneous weather type. -! acts like a 4 bit binary -! 1111 = rain/freezing rain/ice pellets/snow -! where the one's digit is for snow -! the two's digit is for ice pellets -! the four's digit is for freezing rain -! and the eight's digit is for rain - integer, intent(out) :: iwx -! internal: -! - real, parameter :: d00=0.0 - integer karr,licee - real tcold,twarm -! - integer l,lmhk,lice,iwrml,ifrzl - real psfck,tdchk,a,tdkl,tdpre,tlmhk,twrmk,areas8,areap4,area1, & - surfw,surfc,dzkl,pintk1,pintk2,pm150,qkl,tkl,pkl,area0,areap0 - -! subroutines called: -! wetbulb -! -! -! initialize weather type array to zero (ie, off). -! we do this since we want iwx to represent the -! instantaneous weather type on return. -! -! -! allocate local storage -! -! - iwx = 0 - lmhk=lm -! -! find coldest and warmest temps in saturated layer between -! 70 mb above ground and 500 mb -! also find highest saturated layer in that range -! -!meb - psfck = pint(lp1) -!meb - tdchk = 2.0 - 760 tcold = t(lmhk) - twarm = t(lmhk) - licee = lmhk -! - do l=1,lmhk - qkl = q(l) - qkl = max(epsq,qkl) - tkl = t(l) - pkl = pmid(l) -! -! skip past this if the layer is not between 70 mb above ground -! and 500 mb -! - if (pkl < 50000.0 .or. pkl > psfck-7000.0) cycle - a = log(qkl*pkl/(6.1078*(0.378*qkl+0.622))) - tdkl = (237.3*a)/(17.269-a)+273.15 - tdpre = tkl-tdkl - if (tdpre < tdchk .and. tkl < tcold) tcold = tkl - if (tdpre < tdchk .and. tkl > twarm) twarm = tkl - if (tdpre < tdchk .and. l < licee) licee = l - enddo -! -! if no sat layer at dew point dep=tdchk, increase tdchk -! and start again (but don't make tdchk > 6) -! - if (tcold == t(lmhk) .and. tdchk < 6.0) then - tdchk = tdchk + 2.0 - goto 760 - endif -! -! lowest layer t -! - karr = 0 - lmhk = lm - tlmhk = t(lmhk) -! -! decision tree time -! - if (tcold > 269.15) then - if (tlmhk <= 273.15) then -! turn on the flag for freezing rain = 4 if its not on already -! izr=mod(iwx,8)/4 -! if (izr.lt.1) iwx=iwx+4 - iwx = iwx + 4 - goto 850 - else -! turn on the flag for rain = 8 if its not on already -! irain=iwx/8 -! if (irain.lt.1) iwx=iwx+8 - iwx = iwx + 8 - goto 850 - endif - endif - karr = 1 - 850 continue -! - if (karr > 0)then - lmhk = lm - lice = licee -!meb - psfck = pint(lp1) -!meb - tlmhk = t(lmhk) - twrmk = twarm -! -! twet area variables -! calculate only what is needed -! from ground to 150 mb above surface -! from ground to tcold layer -! and from ground to 1st layer where wet bulb t < 0.0 -! -! pintk1 is the pressure at the bottom of the layer -! pintk2 is the pressure at the top of the layer -! -! areap4 is the area of twet above -4 c below highest sat lyr -! areap0 is the area of twet above 0 c below highest sat lyr -! - areas8 = d00 - areap4 = d00 - areap0 = d00 - surfw = d00 - surfc = d00 - -! - do l=lmhk,lice,-1 - dzkl = zint(l)-zint(l+1) - area1 = (twet(l)-269.15)*dzkl - area0 = (twet(l)-273.15)*dzkl - if (twet(l) >= 269.15) areap4 = areap4 + area1 - if (twet(l) >= 273.15) areap0 = areap0 + area0 - enddo -! -! if (areap4.lt.3000.0) then turn on the flag for snow = 1 if its not on already -! isno=mod(iwx,2) -! if (isno.lt.1) iwx=iwx+1 -! iwx=iwx+1 -! go to 1900 -! endif - if (areap0 < 350.0) then ! turn on the flag for snow = 1 - iwx = iwx + 1 - return - endif -! -! areas8 is the net area of twet w.r.t. freezing in lowest 150mb -! - pintk1 = psfck - pm150 = psfck - 15000. -! - do l=lmhk,1,-1 - pintk2 = pint(l) - if(pintk1 >= pm150) then - dzkl = zint(l)-zint(l+1) -! -! sum partial layer if in 150 mb agl layer -! - if(pintk2 < pm150) dzkl = t(l)*(q(l)*d608+1.0)*rog* & - log(pintk1/pm150) - area1 = (twet(l)-273.15)*dzkl - areas8 = areas8 + area1 - endif - pintk1=pintk2 - enddo -! -! surfw is the area of twet above freezing between the ground -! and the first layer above ground below freezing -! surfc is the area of twet below freezing between the ground -! and the warmest sat layer -! - ifrzl = 0 - iwrml = 0 -! - do l=lmhk,1,-1 - if (ifrzl == 0 .and. t(l) < 273.15) ifrzl = 1 - if (iwrml == 0 .and. t(l) >= twrmk) iwrml = 1 -! - if (iwrml == 0 .or. ifrzl == 0) then -! if(pmid(l) .lt. 50000.)print*,'twet needed above 500mb' - dzkl = zint(l)-zint(l+1) - area1 = (twet(l)-273.15)*dzkl - if(ifrzl == 0 .and. twet(l) >= 273.15) surfw = surfw + area1 - if(iwrml == 0 .and. twet(l) <= 273.15) surfc = surfc + area1 - endif - enddo - if (surfc < -3000.0 .or. & - & (areas8 < -3000.0 .and. surfw < 50.0)) then -! turn on the flag for ice pellets = 2 if its not on already -! iip=mod(iwx,4)/2 -! if (iip.lt.1) iwx=iwx+2 - iwx = iwx + 2 - return - endif -! - if (tlmhk < 273.15) then -! turn on the flag for freezing rain = 4 if its not on already -! izr=mod(iwx(k),8)/4 -! if (izr.lt.1) iwx(k)=iwx(k)+4 - iwx = iwx + 4 - else -! turn on the flag for rain = 8 if its not on already -! irain=iwx(k)/8 -! if (irain.lt.1) iwx(k)=iwx(k)+8 - iwx = iwx + 8 - endif -! print *, 'revised check ', iwx(500,800) - endif - - return - end -! -! - subroutine calwxt_explicit(lm,tskin,sr,f_rimef,iwx) -! -! file: calwxt.f -! written: 24 august 2005, g manikin and b ferrier -! -! routine to compute precipitation type using explicit fields -! from the model microphysics - -!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - implicit none -! -! list of variables needed -! parameters: -! -! input: - integer, intent(in) :: lm - real,intent(in) :: tskin, sr - real,intent(in) :: f_rimef(lm) - integer,intent(out) :: iwx - real snow -! real psfc -! -! allocate local storage -! - iwx = 0 - -!gsm the rsm is currently incompatible with this routine -!gsm according to b ferrier, there may be a way to write -!gsm a version of this algorithm to work with the rsm -!gsm microphysics, but it doesn't exist at this time - -! a snow ratio less than 0.5 eliminates snow and sleet -! use the skin temperature to distinguish rain from freezing rain -! note that 2-m temperature may be a better choice if the model -! has a cold bias for skin temperature -! - if (sr < 0.5) then -! surface (skin) potential temperature and temperature. -! psfc=pmid(lm) -! tskin=ths*(psfc/p1000)**capa - - if (tskin < 273.15) then ! freezing rain = 4 - iwx = iwx + 4 - else ! rain = 8 - iwx = iwx + 8 - endif - else -! -! distinguish snow from sleet with the rime factor -! - if(f_rimef(lm) >= 10) then ! sleet = 2 - iwx = iwx + 2 - else - snow = 1 - iwx = iwx + 1 - endif - endif - end -! -! - subroutine calwxt_dominant(nalg,rain,freezr,sleet,snow, & - & domr,domzr,domip,doms) -! -! written: 24 august 2005, g manikin -! -! this routine takes the precip type solutions from different -! algorithms and sums them up to give a dominant type -! -!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - implicit none -! -! input: - integer,intent(in) :: nalg - real,intent(out) :: doms,domr,domzr,domip - integer,dimension(nalg),intent(in) :: rain,snow,sleet,freezr - integer l - real totsn,totip,totr,totzr -!-------------------------------------------------------------------------- -! print* , 'into dominant' - domr = 0. - doms = 0. - domzr = 0. - domip = 0. -! - totsn = 0 - totip = 0 - totr = 0 - totzr = 0 -! loop over the number of different algorithms that are used - do l = 1, nalg - if (rain(l) > 0) then - totr = totr + 1 - elseif (snow(l) > 0) then - totsn = totsn + 1 - elseif (sleet(l) > 0) then - totip = totip + 1 - elseif (freezr(l) > 0) then - totzr = totzr + 1 - endif - enddo - -! ties are broken to favor the most dangerous form of precip -! freezing rain > snow > sleet > rain - if (totsn > totip) then - if (totsn > totzr) then - if (totsn >= totr) then - doms = 1 - else - domr = 1 - endif - elseif (totzr >= totr) then - domzr = 1 - else - domr = 1 - endif - else if (totip > totzr) then - if (totip >= totr) then - domip = 1 - else - domr = 1 - endif - else if (totzr >= totr) then - domzr = 1 - else - domr = 1 - endif -! - return - end From 7fd9ff3aa0925b443d8c81b3e0835c35ea66c0c3 Mon Sep 17 00:00:00 2001 From: llpcarson Date: Fri, 15 Dec 2017 18:03:16 +0000 Subject: [PATCH 24/25] Bug fix for compilation (end subroutine in the wrong place) --- physics/GFS_calpreciptype.f90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/physics/GFS_calpreciptype.f90 b/physics/GFS_calpreciptype.f90 index beab6c561..d613dfd45 100644 --- a/physics/GFS_calpreciptype.f90 +++ b/physics/GFS_calpreciptype.f90 @@ -307,7 +307,7 @@ subroutine GFS_calpreciptype_run(kdt,nrcm,im,ix,lm,lp1,randomno, & endif return - end + end subroutine GFS_calpreciptype_run ! !&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& ! @@ -1511,7 +1511,7 @@ subroutine calwxt_dominant(nalg,rain,freezr,sleet,snow, & endif ! return - end subroutine GFS_calpreciptype_run + end !> \section arg_table_GFS_calpreciptype_finalize Argument table !! From 6910293a68c2c605dbcad35b936348453f7a587b Mon Sep 17 00:00:00 2001 From: "Man.Zhang" Date: Fri, 15 Dec 2017 11:06:30 -0700 Subject: [PATCH 25/25] fix the variable changing names and some format bugs. --- GFS_layer/GFS_physics_driver.F90 | 3 ++ physics/GFS_MP_generic_post.f90 | 60 +++++++++++++++++--------------- physics/GFS_MP_generic_pre.f90 | 45 +++++++++++++----------- physics/GFS_calpreciptype.f90 | 8 ++--- physics/GFS_zhao_carr_pre.f90 | 2 +- 5 files changed, 64 insertions(+), 54 deletions(-) diff --git a/GFS_layer/GFS_physics_driver.F90 b/GFS_layer/GFS_physics_driver.F90 index 085c8bd9c..41aee9755 100644 --- a/GFS_layer/GFS_physics_driver.F90 +++ b/GFS_layer/GFS_physics_driver.F90 @@ -495,6 +495,9 @@ subroutine GFS_physics_driver & real(kind=kind_phys), allocatable, dimension(:,:) :: & qlcn, qicn, w_upi, cf_upi, CNV_MFD, CNV_PRC3, CNV_DQLDT, & CLCN, CNV_FICE, CNV_NDROP, CNV_NICE +!CCPP +! real(kind=kind_phys), dimension(size(Grid%xlon,1),Model%levs) :: & +! initial_t, initial_qv ! ! diff --git a/physics/GFS_MP_generic_post.f90 b/physics/GFS_MP_generic_post.f90 index a9225866b..1fb21fa68 100644 --- a/physics/GFS_MP_generic_post.f90 +++ b/physics/GFS_MP_generic_post.f90 @@ -18,32 +18,32 @@ end subroutine GFS_MP_generic_post_init !!\section arg_table_GFS_MP_generic_post_run Argument Table -!!| local var name | longname |description | units | rank | type | kind | intent | optional | -!!|----------------|--------------------------------------------------------|----------------------------------------------------------|-------------|------|---------|-----------|--------|----------| -!!| im | horizontal_loop_extent | horizontal loop extent, start at 1 | index | 0 | integer | | in | F | -!!| ix | horizontal_dimension | horizontal dimension | index | 0 | integer | | in | F | -!!| levs | vertical_dimension | vertical layer dimension | index | 0 | integer | | in | F | -!!| dtf | time_step_for_dynamics | dynamics time step | s | 0 | real | kind_phys | in | F | -!!| del | air_pressure_difference_between_midlayers | air pressure difference between midlayers | Pa | 2 | real | kind_phys | in | F | -!!| lssav | flag_diagnostics | logical flag for model physics diagnostics | flag | 0 | logical | | in | F | -!!| ldiag3d | flag_diagnostics_3D | logical flag for 3D diagnostics | flag | 0 | logical | | in | F | -!!| rain | total_rainfall_amount | instantaneous total precipitation at surface (APCP) | m | 1 | real | kind_phys | in | F | -!!| frain | factor_for_centered_difference_scheme | dtf/dtp; factor for centered difference scheme correction| none | 0 | real | kind_phys | in | F | -!!| ntcw | index_for_liquid_cloud_condensate | cloud condensate index in tracer array(3) | index | 0 | integer | | in | F | -!!| ncld | number_of_hydrometeors | number_of_hydrometeors(1 for Z-C) | none | 0 | integer | | in | F | -!!| cwm | cloud_condensed_water_specific_humidity | cloud condensed water specific humidity | kg kg-1 | 2 | real | kind_phys | in | F | -!!| t | air_temperature_updated_by_physics | layer mean air temperature | K | 2 | real | kind_phys | in | F | -!!| q | water_vapor_specific_humidity | water vapor specific humidity | kg kg-1 | 2 | real | kind_phys | in | F | -!!| dtdt | air_temperature_before_microphysics_scheme | air temperature saved before micophysics scheme | K | 2 | real | kind_phys | in | F | -!!| dqdt1 | specific_humidity_before_microphysics_scheme | specific humidity saved before microphysics schme | kg kg-1 | 2 | real | kind_phys | in | F | -!!| totprcp | precipitation_rate_at_surface | precipitation rate at surface | kg m-2 s-1 | 1 | real | kind_phys | inout | F | -!!| dt3dt6 | large_scale_condensate_heating_rate_at_model_layers | large scale condensate heating rate at model layers | K s-1 | 2 | real | kind_phys | inout | F | -!!| dq3dt4 | large_scale_condensate_moistening_rate_at_model_layers | large scale condensate moistening rate at model layers | kg kg-1 s-1 | 2 | real | kind_phys | inout | F | -!!| pwat | column_precipitable_water | column integrated precipitable water | kg m-2 | 1 | real | kind_phys | out | F | +!!| local var name | longname |description | units | rank | type | kind | intent | optional | +!!|----------------|--------------------------------------------------------|----------------------------------------------------------------|-------------|------|---------|-----------|--------|----------| +!!| im | horizontal_loop_extent | horizontal loop extent, start at 1 | index | 0 | integer | | in | F | +!!| ix | horizontal_dimension | horizontal dimension | index | 0 | integer | | in | F | +!!| levs | vertical_dimension | vertical layer dimension | index | 0 | integer | | in | F | +!!| dtf | time_step_for_dynamics | dynamics time step | s | 0 | real | kind_phys | in | F | +!!| del | air_pressure_difference_between_midlayers | air pressure difference between midlayers | Pa | 2 | real | kind_phys | in | F | +!!| lssav | flag_diagnostics | logical flag for model physics diagnostics | flag | 0 | logical | | in | F | +!!| ldiag3d | flag_diagnostics_3D | logical flag for 3D diagnostics | flag | 0 | logical | | in | F | +!!| rain | total_rainfall_amount | instantaneous total precipitation at surface (APCP) | m | 1 | real | kind_phys | in | F | +!!| frain | factor_for_centered_difference_scheme | dtf/dtp; factor for centered difference scheme correction | none | 0 | real | kind_phys | in | F | +!!| ntcw | index_for_liquid_cloud_condensate | cloud condensate index in tracer array(3) | index | 0 | integer | | in | F | +!!| ncld | number_of_hydrometeors | number_of_hydrometeors(1 for Z-C) | none | 0 | integer | | in | F | +!!| cwm | cloud_condensed_water_specific_humidity | cloud condensed water specific humidity | kg kg-1 | 2 | real | kind_phys | in | F | +!!| t | air_temperature_updated_by_physics | layer mean air temperature | K | 2 | real | kind_phys | in | F | +!!| q | water_vapor_specific_humidity | water vapor specific humidity | kg kg-1 | 2 | real | kind_phys | in | F | +!!| initial_t | air_temperature_initial | air temperature before entering a physics scheme | K | 2 | real | kind_phys | in | F | +!!| initial_qv | water_vapor_specific_humidity_initial | water vapor specific humidity before entering a physics scheme | kg kg-1 | 2 | real | kind_phys | in | F | +!!| totprcp | precipitation_rate_at_surface | precipitation rate at surface | kg m-2 s-1 | 1 | real | kind_phys | inout | F | +!!| dt3dt6 | large_scale_condensate_heating_rate_at_model_layers | large scale condensate heating rate at model layers | K s-1 | 2 | real | kind_phys | inout | F | +!!| dq3dt4 | large_scale_condensate_moistening_rate_at_model_layers | large scale condensate moistening rate at model layers | kg kg-1 s-1 | 2 | real | kind_phys | inout | F | +!!| pwat | column_precipitable_water | column integrated precipitable water | kg m-2 | 1 | real | kind_phys | out | F | !! - subroutine GFS_MP_generic_post_run(im, ix, levs,dtf,del, & - lssav,ldiag3d,rain,frain,ntcw,ncld,cwm, & !input - t,q,dtdt,dqdt1, & + subroutine GFS_MP_generic_post_run(im, ix, levs,dtf,del, & + lssav,ldiag3d,rain,frain,ntcw,ncld,cwm, & !input + t,q,initial_t, initial_qv, & totprcp, dt3dt6,dq3dt4,pwat ) ! output ! @@ -61,7 +61,8 @@ subroutine GFS_MP_generic_post_run(im, ix, levs,dtf,del, & real(kind=kind_phys),dimension(im) :: work1 real(kind=kind_phys),dimension(im), intent(in) :: rain real(kind=kind_phys),dimension(ix,levs), intent(in) :: t,q, & - cwm, del, dtdt, dqdt1 + cwm, del, initial_t, & + initial_qv real(kind=kind_phys),dimension(im), intent(inout) :: totprcp real(kind=kind_phys),dimension(im), intent(out) :: pwat real(kind=kind_phys),dimension(ix,levs), intent(inout) :: & @@ -77,8 +78,11 @@ subroutine GFS_MP_generic_post_run(im, ix, levs,dtf,del, & if (ldiag3d) then do i = 1, im do k = 1,levs - dt3dt6(i,k) = dt3dt6(i,k) + (t(i,k)-dtdt(i,k)) * frain - dq3dt4(i,k) = dq3dt4(i,k) + (q(i,k)-dqdt1(i,k)) * frain + !CCPP dt3dt6(i,k) = dt3dt6(i,k) + (t(i,k)-dtdt(i,k)) * frain + !CCPP dq3dt4(i,k) = dq3dt4(i,k) + (q(i,k)-dqdt1(i,k)) * frain + dt3dt6(i,k) = dt3dt6(i,k) + (t(i,k)-initial_t(i,k)) * frain + dq3dt4(i,k) = dq3dt4(i,k) + (q(i,k)-initial_qv(i,k)) * frain + enddo enddo endif diff --git a/physics/GFS_MP_generic_pre.f90 b/physics/GFS_MP_generic_pre.f90 index de8a661e9..48842a960 100644 --- a/physics/GFS_MP_generic_pre.f90 +++ b/physics/GFS_MP_generic_pre.f90 @@ -14,26 +14,27 @@ end subroutine GFS_MP_generic_pre_init !!\section arg_table_GFS_MP_generic_pre_run Argument Table -!!| local var name | longname |description | units | rank | type | kind | intent | optional | -!!|----------------|--------------------------------------------------------|----------------------------------------------------------|-------------|------|---------|-----------|--------|----------| -!!| im | horizontal_loop_extent | horizontal loop extent, start at 1 | index | 0 | integer | | in | F | -!!| ix | horizontal_dimension | horizontal dimension | index | 0 | integer | | in | F | -!!| levs | vertical_dimension | vertical layer dimension | index | 0 | integer | | in | F | -!!| clw1 | cloud_ice_specific_humidity | cloud ice specific humidity | kg kg-1 | 2 | real | kind_phys | in | F | -!!| clw2 | cloud_liquid_water_specific_humidity | cloud water specific humidity | kg kg-1 | 2 | real | kind_phys | in | F | -!!| ldiag3d | flag_diagnostics_3D | logical flag for 3D diagnostics | flag | 0 | logical | | in | F | -!!| ntcw | index_for_liquid_cloud_condensate | cloud condensate index in tracer array(3) | none | 0 | integer | | in | F | -!!| ncld | number_of_hydrometeors | number of hydrometeors(1 for Z-C) | none | 0 | integer | | in | F | -!!| num_p3d | array_dimension_of_microphysics | number of 3D arrays needed for microphysics | none | 0 | integer | | in | F | -!!| t | air_temperature_updated_by_physics | layer mean air temperature | K | 2 | real | kind_phys | in | F | -!!| q | water_vapor_specific_humidity_updated_by_physics | water vapor specific humidity | kg kg-1 | 2 | real | kind_phys | in | F | -!!| dtdt | ??? change meaning in _pre and _post | | K | 2 | real | kind_phys | out | F | -!!| dqdt1 | ??? change meaning | | kg kg-1 | 2 | real | kind_phys | out | F | -!!| dqdt3 | cloud_condensed_water_specific_humidity | cloud condensed water specific humidity | kg kg-1 | 2 | real | kind_phys | out | F | +!!| local var name | longname |description | units | rank | type | kind | intent | optional | +!!|----------------|--------------------------------------------------------|-----------------------------------------------------------------|-------------|------|---------|-----------|--------|----------| +!!| im | horizontal_loop_extent | horizontal loop extent, start at 1 | index | 0 | integer | | in | F | +!!| ix | horizontal_dimension | horizontal dimension | index | 0 | integer | | in | F | +!!| levs | vertical_dimension | vertical layer dimension | index | 0 | integer | | in | F | +!!| clw1 | cloud_ice_specific_humidity | cloud ice specific humidity | kg kg-1 | 2 | real | kind_phys | in | F | +!!| clw2 | cloud_liquid_water_specific_humidity | cloud water specific humidity | kg kg-1 | 2 | real | kind_phys | in | F | +!!| ldiag3d | flag_diagnostics_3D | logical flag for 3D diagnostics | flag | 0 | logical | | in | F | +!!| ntcw | index_for_liquid_cloud_condensate | cloud condensate index in tracer array(3) | none | 0 | integer | | in | F | +!!| ncld | number_of_hydrometeors | number of hydrometeors(1 for Z-C) | none | 0 | integer | | in | F | +!!| num_p3d | array_dimension_of_microphysics | number of 3D arrays needed for microphysics | none | 0 | integer | | in | F | +!!| t | air_temperature_updated_by_physics | layer mean air temperature | K | 2 | real | kind_phys | in | F | +!!| q | water_vapor_specific_humidity_updated_by_physics | water vapor specific humidity | kg kg-1 | 2 | real | kind_phys | in | F | +!!| initial_t | air_temperature_initial | air temperature before entering a physics scheme | K | 2 | real | kind_phys | out | F | +!!| initial_qv | water_vapor_specific_humidity_initial | water vapor specific humidity before entering a physics scheme | kg kg-1 | 2 | real | kind_phys | out | F | +!!| dqdt3 | cloud_condensed_water_specific_humidity | cloud condensed water specific humidity | kg kg-1 | 2 | real | kind_phys | out | F | !! subroutine GFS_MP_generic_pre_run(im, ix, levs, clw1, clw2, & ldiag3d, ntcw, ncld, num_p3d, t, q, & !input - dtdt,dqdt1, dqdt3) !output + initial_t, initial_qv, dqdt3 ) +! dtdt,dqdt1, dqdt3) !output ! use machine, only: kind_phys @@ -48,14 +49,16 @@ subroutine GFS_MP_generic_pre_run(im, ix, levs, clw1, clw2, & logical :: ldiag3d real(kind=kind_phys),dimension(ix,levs), intent(in) :: t,q, & clw1,clw2 - real(kind=kind_phys),dimension(ix,levs), intent(out) :: dtdt, & - dqdt1, dqdt3 + real(kind=kind_phys),dimension(ix,levs), intent(out) :: & + initial_t, initial_qv, dqdt3 if (ldiag3d) then do i = 1, im do k = 1, levs - dtdt(i,k) = t(i,k) - dqdt1(i,k) = q(i,k) + !CCPP dtdt(i,k) = t(i,k) + !CCPP dqdt1(i,k) = q(i,k) + initial_t(i,k) = t(i,k) + initial_qv(i,k) = q(i,k) enddo end do !in FV3GFS v0 OP: ntcw=3, ncld=1, num_p3d=4, ntrac=3 diff --git a/physics/GFS_calpreciptype.f90 b/physics/GFS_calpreciptype.f90 index beab6c561..ea2560c78 100644 --- a/physics/GFS_calpreciptype.f90 +++ b/physics/GFS_calpreciptype.f90 @@ -1,6 +1,6 @@ !> \file GFS_calpreciptype.F90 !! This file contains the subroutine that calculates dominant precipitation type (calpreciptype) -!! and its post. It is adopted from post but was made into a column to used by GFS model. +!! and its post. It is adopted from post but was made into a column to used by GFS model. module GFS_calpreciptype contains @@ -41,7 +41,7 @@ end subroutine GFS_calpreciptype_init !!| srflag | flag_for_precipitation_type | snow(1)/rain(0) flag for precipitation | 1 | 1 | real | kind_phys | out | F | !!| tprcp | precipitation_amount_in_one_dynamics_time_step | precipitation amount in one dynamics time step | m | 1 | real | kind_phys | out | F | !! - subroutine GFS_calpreciptype_run(kdt,nrcm,im,ix,lm,lp1,randomno, & + subroutine GFS_calpreciptype_run (kdt,nrcm,im,ix,lm,lp1,randomno, & cal_pre, & gt0,gq0,prsl,prsi, rainc,frain,rain1, & phii,n3dfercld,tskin,sr,phy_f3d, & !input @@ -307,7 +307,7 @@ subroutine GFS_calpreciptype_run(kdt,nrcm,im,ix,lm,lp1,randomno, & endif return - end + end subroutine GFS_CALPRECIPTYPE_RUN ! !&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& ! @@ -1511,7 +1511,7 @@ subroutine calwxt_dominant(nalg,rain,freezr,sleet,snow, & endif ! return - end subroutine GFS_calpreciptype_run + end !> \section arg_table_GFS_calpreciptype_finalize Argument table !! diff --git a/physics/GFS_zhao_carr_pre.f90 b/physics/GFS_zhao_carr_pre.f90 index 938a354da..a09bc6487 100644 --- a/physics/GFS_zhao_carr_pre.f90 +++ b/physics/GFS_zhao_carr_pre.f90 @@ -18,7 +18,7 @@ end subroutine GFS_zhao_carr_pre_init !!|----------------|--------------------------------------------------------|----------------------------------------------------------|-------------|------|---------|-----------|--------|----------| !!| im | horizontal_loop_extent | horizontal loop extent, start at 1 | index | 0 | integer | | in | F | !!| ix | horizontal_dimension | horizontal dimension | index | 0 | integer | | in | F | -!!| levs | vertical_dimension | vertical layer dimension | index | 0 | integer | | in | F | +!!| levs | vertical_dimension | vertical layer dimension | index | 0 | integer | | in | F | !!| cwm | cloud_condensed_water_specific_humidity | cloud condensed water specific humidity | kg kg-1 | 2 | real | kind_phys | in | F | !!| clw1 | cloud_ice_specific_humidity | cloud ice specific humidity | kg kg-1 | 2 | real | kind_phys | out | F | !!