/wrfv2_fire/dyn_em/module_em.F
FORTRAN Legacy | 2017 lines | 1324 code | 389 blank | 304 comment | 30 complexity | 422bdbd307c09316d16f8380bf354f8d MD5 | raw file
Possible License(s): AGPL-1.0
Large files files are truncated, but you can click here to view the full file
- !WRF:MODEL_LAYER:DYNAMICS
- !
- MODULE module_em
- USE module_model_constants
-
- USE module_advect_em, only: advect_u, advect_v, advect_w, advect_scalar, advect_scalar_pd, advect_scalar_mono, &
- advect_weno_u, advect_weno_v, advect_weno_w, advect_scalar_weno, advect_scalar_wenopd
-
- USE module_big_step_utilities_em, only: grid_config_rec_type, calculate_full, couple_momentum, calc_mu_uv, calc_ww_cp, calc_cq, calc_alt, calc_php, set_tend, rhs_ph, &
- horizontal_pressure_gradient, pg_buoy_w, w_damp, perturbation_coriolis, coriolis, curvature, horizontal_diffusion, horizontal_diffusion_3dmp, vertical_diffusion_u, &
- vertical_diffusion_v, vertical_diffusion, vertical_diffusion_3dmp, sixth_order_diffusion, rk_rayleigh_damp, theta_relaxation, vertical_diffusion_mp, zero_tend
-
- USE module_state_description, only: param_first_scalar, p_qr, p_qv, p_qc, p_qg, p_qi, p_qs, tiedtkescheme, heldsuarez, positivedef, &
- gdscheme, g3scheme, kfetascheme, monotonic, wenopd_scalar, weno_scalar, weno_mom
-
- USE module_damping_em, only: held_suarez_damp
- CONTAINS
- !------------------------------------------------------------------------
- SUBROUTINE rk_step_prep ( config_flags, rk_step, &
- u, v, w, t, ph, mu, &
- moist, &
- ru, rv, rw, ww, php, alt, &
- muu, muv, &
- mub, mut, phb, pb, p, al, alb, &
- cqu, cqv, cqw, &
- msfux, msfuy, &
- msfvx, msfvx_inv, msfvy, &
- msftx, msfty, &
- fnm, fnp, dnw, rdx, rdy, &
- n_moist, &
- ids, ide, jds, jde, kds, kde, &
- ims, ime, jms, jme, kms, kme, &
- its, ite, jts, jte, kts, kte )
- IMPLICIT NONE
- ! Input data.
- TYPE(grid_config_rec_type ) , INTENT(IN ) :: config_flags
- INTEGER , INTENT(IN ) :: ids, ide, jds, jde, kds, kde, &
- ims, ime, jms, jme, kms, kme, &
- its, ite, jts, jte, kts, kte
- INTEGER , INTENT(IN ) :: n_moist, rk_step
- REAL , INTENT(IN ) :: rdx, rdy
- REAL , DIMENSION( ims:ime , kms:kme, jms:jme ) , &
- INTENT(IN ) :: u, &
- v, &
- w, &
- t, &
- ph, &
- phb, &
- pb, &
- al, &
- alb
- REAL , DIMENSION( ims:ime , kms:kme , jms:jme ) , &
- INTENT( OUT) :: ru, &
- rv, &
- rw, &
- ww, &
- php, &
- cqu, &
- cqv, &
- cqw, &
- alt
- REAL , DIMENSION( ims:ime , kms:kme, jms:jme ) , &
- INTENT(IN ) :: p
-
- REAL , DIMENSION( ims:ime, kms:kme, jms:jme, n_moist ), INTENT( IN) :: &
- moist
- REAL , DIMENSION( ims:ime , jms:jme ) , INTENT(IN ) :: msftx, &
- msfty, &
- msfux, &
- msfuy, &
- msfvx, &
- msfvx_inv, &
- msfvy, &
- mu, &
- mub
- REAL , DIMENSION( ims:ime , jms:jme ) , INTENT( OUT) :: muu, &
- muv, &
- mut
- REAL , DIMENSION( kms:kme ) , INTENT(IN ) :: fnm, fnp, dnw
- integer :: k
- !<DESCRIPTION>
- !
- ! rk_step_prep prepares a number of diagnostic quantities
- ! in preperation for a Runge-Kutta timestep. subroutines called
- ! by rk_step_prep calculate
- !
- ! (1) total column dry air mass (mut, call to calculate_full)
- !
- ! (2) total column dry air mass at u and v points
- ! (muu, muv, call to calculate_mu_uv)
- !
- ! (3) mass-coupled velocities for advection
- ! (ru, rv, and rw, call to couple_momentum)
- !
- ! (4) omega (call to calc_ww_cp)
- !
- ! (5) moisture coefficients (cqu, cqv, cqw, call to calc_cq)
- !
- ! (6) inverse density (alt, call to calc_alt)
- !
- ! (7) geopotential at pressure points (php, call to calc_php)
- !
- !</DESCRIPTION>
- CALL calculate_full( mut, mub, mu, &
- ids, ide, jds, jde, 1, 2, &
- ims, ime, jms, jme, 1, 1, &
- its, ite, jts, jte, 1, 1 )
- CALL calc_mu_uv ( config_flags, &
- mu, mub, muu, muv, &
- ids, ide, jds, jde, kds, kde, &
- ims, ime, jms, jme, kms, kme, &
- its, ite, jts, jte, kts, kte )
- CALL couple_momentum( muu, ru, u, msfuy, &
- muv, rv, v, msfvx, msfvx_inv, &
- mut, rw, w, msfty, &
- ids, ide, jds, jde, kds, kde, &
- ims, ime, jms, jme, kms, kme, &
- its, ite, jts, jte, kts, kte )
- ! new call, couples V with mu, also has correct map factors. WCS, 3 june 2001
- CALL calc_ww_cp ( u, v, mu, mub, ww, &
- rdx, rdy, msftx, msfty, &
- msfux, msfuy, msfvx, msfvx_inv, &
- msfvy, dnw, &
- ids, ide, jds, jde, kds, kde, &
- ims, ime, jms, jme, kms, kme, &
- its, ite, jts, jte, kts, kte )
- CALL calc_cq ( moist, cqu, cqv, cqw, n_moist, &
- ids, ide, jds, jde, kds, kde, &
- ims, ime, jms, jme, kms, kme, &
- its, ite, jts, jte, kts, kte )
- CALL calc_alt ( alt, al, alb, &
- ids, ide, jds, jde, kds, kde, &
- ims, ime, jms, jme, kms, kme, &
- its, ite, jts, jte, kts, kte )
- CALL calc_php ( php, ph, phb, &
- ids, ide, jds, jde, kds, kde, &
- ims, ime, jms, jme, kms, kme, &
- its, ite, jts, jte, kts, kte )
- END SUBROUTINE rk_step_prep
- !-------------------------------------------------------------------------------
- SUBROUTINE rk_tendency ( config_flags, rk_step, &
- ru_tend, rv_tend, rw_tend, ph_tend, t_tend, &
- ru_tendf, rv_tendf, rw_tendf, ph_tendf, t_tendf, &
- mu_tend, u_save, v_save, w_save, ph_save, &
- t_save, mu_save, RTHFTEN, &
- ru, rv, rw, ww, &
- u, v, w, t, ph, &
- u_old, v_old, w_old, t_old, ph_old, &
- h_diabatic, phb,t_init, &
- mu, mut, muu, muv, mub, &
- al, alt, p, pb, php, cqu, cqv, cqw, &
- u_base, v_base, t_base, qv_base, z_base, &
- msfux, msfuy, msfvx, msfvx_inv, &
- msfvy, msftx, msfty, &
- clat, f, e, sina, cosa, &
- fnm, fnp, rdn, rdnw, &
- dt, rdx, rdy, khdif, kvdif, xkmhd, xkhh, &
- diff_6th_opt, diff_6th_factor, &
- adv_opt, &
- dampcoef,zdamp,damp_opt,rad_nudge, &
- cf1, cf2, cf3, cfn, cfn1, n_moist, &
- non_hydrostatic, top_lid, &
- u_frame, v_frame, &
- ids, ide, jds, jde, kds, kde, &
- ims, ime, jms, jme, kms, kme, &
- its, ite, jts, jte, kts, kte, &
- max_vert_cfl, max_horiz_cfl)
- IMPLICIT NONE
- ! Input data.
- TYPE(grid_config_rec_type) , INTENT(IN ) :: config_flags
- INTEGER , INTENT(IN ) :: ids, ide, jds, jde, kds, kde, &
- ims, ime, jms, jme, kms, kme, &
- its, ite, jts, jte, kts, kte
- LOGICAL , INTENT(IN ) :: non_hydrostatic, top_lid
- INTEGER , INTENT(IN ) :: n_moist, rk_step
- REAL , DIMENSION( ims:ime , kms:kme, jms:jme ) , &
- INTENT(IN ) :: ru, &
- rv, &
- rw, &
- ww, &
- u, &
- v, &
- w, &
- t, &
- ph, &
- u_old, &
- v_old, &
- w_old, &
- t_old, &
- ph_old, &
- phb, &
- al, &
- alt, &
- p, &
- pb, &
- php, &
- cqu, &
- cqv, &
- t_init, &
- xkmhd, &
- xkhh, &
- h_diabatic
- REAL , DIMENSION( ims:ime , kms:kme, jms:jme ) , &
- INTENT(OUT ) :: ru_tend, &
- rv_tend, &
- rw_tend, &
- t_tend, &
- ph_tend, &
- RTHFTEN, &
- u_save, &
- v_save, &
- w_save, &
- ph_save, &
- t_save
- REAL , DIMENSION( ims:ime , kms:kme, jms:jme ) , &
- INTENT(INOUT) :: ru_tendf, &
- rv_tendf, &
- rw_tendf, &
- t_tendf, &
- ph_tendf, &
- cqw
- REAL , DIMENSION( ims:ime , jms:jme ) , INTENT( OUT) :: mu_tend, &
- mu_save
- REAL , DIMENSION( ims:ime , jms:jme ) , INTENT(IN ) :: msfux, &
- msfuy, &
- msfvx, &
- msfvx_inv, &
- msfvy, &
- msftx, &
- msfty, &
- clat, &
- f, &
- e, &
- sina, &
- cosa, &
- mu, &
- mut, &
- mub, &
- muu, &
- muv
- REAL , DIMENSION( kms:kme ) , INTENT(IN ) :: fnm, &
- fnp, &
- rdn, &
- rdnw, &
- u_base, &
- v_base, &
- t_base, &
- qv_base, &
- z_base
- REAL , INTENT(IN ) :: rdx, &
- rdy, &
- dt, &
- u_frame, &
- v_frame, &
- khdif, &
- kvdif
- INTEGER, INTENT( IN ) :: diff_6th_opt
- REAL, INTENT( IN ) :: diff_6th_factor
- INTEGER, INTENT( IN ) :: adv_opt
- INTEGER, INTENT( IN ) :: damp_opt, rad_nudge
- REAL, INTENT( IN ) :: zdamp, dampcoef
- REAL, INTENT( OUT ) :: max_horiz_cfl
- REAL, INTENT( OUT ) :: max_vert_cfl
- REAL :: kdift, khdq, kvdq, cfn, cfn1, cf1, cf2, cf3
- INTEGER :: i,j,k
- INTEGER :: time_step
- !<DESCRIPTION>
- !
- ! rk_tendency computes the large-timestep tendency terms in the
- ! momentum, thermodynamic (theta), and geopotential equations.
- ! These terms include:
- !
- ! (1) advection (for u, v, w, theta - calls to advect_u, advect_v,
- ! advect_w, and advact_scalar).
- !
- ! (2) geopotential equation terms (advection and "gw" - call to rhs_ph).
- !
- ! (3) buoyancy term in vertical momentum equation (call to pg_buoy_w).
- !
- ! (4) Coriolis and curvature terms in u,v,w momentum equations
- ! (calls to subroutines coriolis, curvature)
- !
- ! (5) 3D diffusion on coordinate surfaces.
- !
- !</DESCRIPTION>
- CALL zero_tend ( ru_tend, &
- ids, ide, jds, jde, kds, kde, &
- ims, ime, jms, jme, kms, kme, &
- its, ite, jts, jte, kts, kte )
- CALL zero_tend ( rv_tend, &
- ids, ide, jds, jde, kds, kde, &
- ims, ime, jms, jme, kms, kme, &
- its, ite, jts, jte, kts, kte )
- CALL zero_tend ( rw_tend, &
- ids, ide, jds, jde, kds, kde, &
- ims, ime, jms, jme, kms, kme, &
- its, ite, jts, jte, kts, kte )
- CALL zero_tend ( t_tend, &
- ids, ide, jds, jde, kds, kde, &
- ims, ime, jms, jme, kms, kme, &
- its, ite, jts, jte, kts, kte )
- CALL zero_tend ( ph_tend, &
- ids, ide, jds, jde, kds, kde, &
- ims, ime, jms, jme, kms, kme, &
- its, ite, jts, jte, kts, kte )
- CALL zero_tend ( u_save, &
- ids, ide, jds, jde, kds, kde, &
- ims, ime, jms, jme, kms, kme, &
- its, ite, jts, jte, kts, kte )
- CALL zero_tend ( v_save, &
- ids, ide, jds, jde, kds, kde, &
- ims, ime, jms, jme, kms, kme, &
- its, ite, jts, jte, kts, kte )
- CALL zero_tend ( w_save, &
- ids, ide, jds, jde, kds, kde, &
- ims, ime, jms, jme, kms, kme, &
- its, ite, jts, jte, kts, kte )
- CALL zero_tend ( ph_save, &
- ids, ide, jds, jde, kds, kde, &
- ims, ime, jms, jme, kms, kme, &
- its, ite, jts, jte, kts, kte )
- CALL zero_tend ( t_save, &
- ids, ide, jds, jde, kds, kde, &
- ims, ime, jms, jme, kms, kme, &
- its, ite, jts, jte, kts, kte )
- CALL zero_tend ( mu_tend, &
- ids, ide, jds, jde, 1, 1, &
- ims, ime, jms, jme, 1, 1, &
- its, ite, jts, jte, 1, 1 )
- CALL zero_tend ( mu_save, &
- ids, ide, jds, jde, 1, 1, &
- ims, ime, jms, jme, 1, 1, &
- its, ite, jts, jte, 1, 1 )
- ! advection tendencies
- CALL nl_get_time_step ( 1, time_step )
- IF( (rk_step == 3) .and. ( adv_opt == WENO_MOM ) ) THEN
- CALL advect_weno_u ( u, u , ru_tend, ru, rv, ww, &
- mut, time_step, config_flags, &
- msfux, msfuy, msfvx, msfvy, &
- msftx, msfty, &
- fnm, fnp, rdx, rdy, rdnw, &
- ids, ide, jds, jde, kds, kde, &
- ims, ime, jms, jme, kms, kme, &
- its, ite, jts, jte, kts, kte )
- ELSE
-
- CALL advect_u ( u, u , ru_tend, ru, rv, ww, &
- mut, time_step, config_flags, &
- msfux, msfuy, msfvx, msfvy, &
- msftx, msfty, &
- fnm, fnp, rdx, rdy, rdnw, &
- ids, ide, jds, jde, kds, kde, &
- ims, ime, jms, jme, kms, kme, &
- its, ite, jts, jte, kts, kte )
- ENDIF
- IF( (rk_step == 3) .and. ( adv_opt == WENO_MOM ) ) THEN
- CALL advect_weno_v ( v, v , rv_tend, ru, rv, ww, &
- mut, time_step, config_flags, &
- msfux, msfuy, msfvx, msfvy, &
- msftx, msfty, &
- fnm, fnp, rdx, rdy, rdnw, &
- ids, ide, jds, jde, kds, kde, &
- ims, ime, jms, jme, kms, kme, &
- its, ite, jts, jte, kts, kte )
- ELSE
-
- CALL advect_v ( v, v , rv_tend, ru, rv, ww, &
- mut, time_step, config_flags, &
- msfux, msfuy, msfvx, msfvy, &
- msftx, msfty, &
- fnm, fnp, rdx, rdy, rdnw, &
- ids, ide, jds, jde, kds, kde, &
- ims, ime, jms, jme, kms, kme, &
- its, ite, jts, jte, kts, kte )
- ENDIF
- IF (non_hydrostatic) THEN
- IF( (rk_step == 3) .and. ( adv_opt == WENO_MOM ) ) THEN
- CALL advect_weno_w ( w, w, rw_tend, ru, rv, ww, &
- mut, time_step, config_flags, &
- msfux, msfuy, msfvx, msfvy, &
- msftx, msfty, &
- fnm, fnp, rdx, rdy, rdn, &
- ids, ide, jds, jde, kds, kde, &
- ims, ime, jms, jme, kms, kme, &
- its, ite, jts, jte, kts, kte )
- ELSE
-
- CALL advect_w ( w, w, rw_tend, ru, rv, ww, &
- mut, time_step, config_flags, &
- msfux, msfuy, msfvx, msfvy, &
- msftx, msfty, &
- fnm, fnp, rdx, rdy, rdn, &
- ids, ide, jds, jde, kds, kde, &
- ims, ime, jms, jme, kms, kme, &
- its, ite, jts, jte, kts, kte )
- ENDIF
- ENDIF
- ! theta flux divergence
- CALL advect_scalar ( t, t, t_tend, ru, rv, ww, &
- mut, time_step, config_flags, &
- msfux, msfuy, msfvx, msfvy, &
- msftx, msfty, fnm, fnp, &
- rdx, rdy, rdnw, &
- ids, ide, jds, jde, kds, kde, &
- ims, ime, jms, jme, kms, kme, &
- its, ite, jts, jte, kts, kte )
- IF ( config_flags%cu_physics == GDSCHEME .OR. &
- config_flags%cu_physics == G3SCHEME ) THEN
- ! theta advection only:
- CALL set_tend( RTHFTEN, t_tend, msfty, &
- ids, ide, jds, jde, kds, kde, &
- ims, ime, jms, jme, kms, kme, &
- its, ite, jts, jte, kts, kte )
- END IF
- CALL rhs_ph( ph_tend, u, v, ww, ph, ph, phb, w, &
- mut, muu, muv, &
- fnm, fnp, &
- rdnw, cfn, cfn1, rdx, rdy, &
- msfux, msfuy, msfvx, &
- msfvx_inv, msfvy, &
- msftx, msfty, &
- non_hydrostatic, &
- config_flags, &
- ids, ide, jds, jde, kds, kde, &
- ims, ime, jms, jme, kms, kme, &
- its, ite, jts, jte, kts, kte )
- CALL horizontal_pressure_gradient( ru_tend,rv_tend, &
- ph,alt,p,pb,al,php,cqu,cqv, &
- muu,muv,mu,fnm,fnp,rdnw, &
- cf1,cf2,cf3,rdx,rdy,msfux,msfuy,&
- msfvx,msfvy,msftx,msfty, &
- config_flags, non_hydrostatic, &
- top_lid, &
- ids, ide, jds, jde, kds, kde, &
- ims, ime, jms, jme, kms, kme, &
- its, ite, jts, jte, kts, kte )
- IF (non_hydrostatic) THEN
- CALL pg_buoy_w( rw_tend, p, cqw, mu, mub, &
- rdnw, rdn, g, msftx, msfty, &
- ids, ide, jds, jde, kds, kde, &
- ims, ime, jms, jme, kms, kme, &
- its, ite, jts, jte, kts, kte )
- ENDIF
- CALL w_damp ( rw_tend, max_vert_cfl, &
- max_horiz_cfl, &
- u, v, ww, w, mut, rdnw, &
- rdx, rdy, msfux, msfuy, msfvx, &
- msfvy, dt, config_flags, &
- ids, ide, jds, jde, kds, kde, &
- ims, ime, jms, jme, kms, kme, &
- its, ite, jts, jte, kts, kte )
- IF(config_flags%pert_coriolis) THEN
- CALL perturbation_coriolis ( ru, rv, rw, &
- ru_tend, rv_tend, rw_tend, &
- config_flags, &
- u_base, v_base, z_base, &
- muu, muv, phb, ph, &
- msftx, msfty, msfux, msfuy, &
- msfvx, msfvy, &
- f, e, sina, cosa, fnm, fnp, &
- ids, ide, jds, jde, kds, kde, &
- ims, ime, jms, jme, kms, kme, &
- its, ite, jts, jte, kts, kte )
- ELSE
- CALL coriolis ( ru, rv, rw, &
- ru_tend, rv_tend, rw_tend, &
- config_flags, &
- msftx, msfty, msfux, msfuy, &
- msfvx, msfvy, &
- f, e, sina, cosa, fnm, fnp, &
- ids, ide, jds, jde, kds, kde, &
- ims, ime, jms, jme, kms, kme, &
- its, ite, jts, jte, kts, kte )
- END IF
- CALL curvature ( ru, rv, rw, u, v, w, &
- ru_tend, rv_tend, rw_tend, &
- config_flags, &
- msfux, msfuy, msfvx, msfvy, &
- msftx, msfty, &
- clat, fnm, fnp, rdx, rdy, &
- ids, ide, jds, jde, kds, kde, &
- ims, ime, jms, jme, kms, kme, &
- its, ite, jts, jte, kts, kte )
- ! Damping option added for Held-Suarez test (also uses lw option HELDSUAREZ)
- IF (config_flags%ra_lw_physics == HELDSUAREZ) THEN
- CALL held_suarez_damp ( ru_tend, rv_tend, &
- ru,rv,p,pb, &
- ids, ide, jds, jde, kds, kde, &
- ims, ime, jms, jme, kms, kme, &
- its, ite, jts, jte, kts, kte )
- END IF
- !**************************************************************
- !
- ! Next, the terms that we integrate only with forward-in-time
- ! (evaluate with time t variables).
- !
- !**************************************************************
- forward_step: IF( rk_step == 1 ) THEN
- diff_opt1 : IF (config_flags%diff_opt .eq. 1) THEN
-
- CALL horizontal_diffusion ('u', u, ru_tendf, mut, config_flags, &
- msfux, msfuy, msfvx, msfvx_inv, &
- msfvy,msftx, msfty, &
- khdif, xkmhd, rdx, rdy, &
- ids, ide, jds, jde, kds, kde, &
- ims, ime, jms, jme, kms, kme, &
- its, ite, jts, jte, kts, kte )
- CALL horizontal_diffusion ('v', v, rv_tendf, mut, config_flags, &
- msfux, msfuy, msfvx, msfvx_inv, &
- msfvy,msftx, msfty, &
- khdif, xkmhd, rdx, rdy, &
- ids, ide, jds, jde, kds, kde, &
- ims, ime, jms, jme, kms, kme, &
- its, ite, jts, jte, kts, kte )
- CALL horizontal_diffusion ('w', w, rw_tendf, mut, config_flags, &
- msfux, msfuy, msfvx, msfvx_inv, &
- msfvy,msftx, msfty, &
- khdif, xkmhd, rdx, rdy, &
- ids, ide, jds, jde, kds, kde, &
- ims, ime, jms, jme, kms, kme, &
- its, ite, jts, jte, kts, kte )
- khdq = 3.*khdif
- CALL horizontal_diffusion_3dmp ( 'm', t, t_tendf, mut, &
- config_flags, t_init, &
- msfux, msfuy, msfvx, msfvx_inv, &
- msfvy, msftx, msfty, &
- khdq , xkhh, rdx, rdy, &
- ids, ide, jds, jde, kds, kde, &
- ims, ime, jms, jme, kms, kme, &
- its, ite, jts, jte, kts, kte )
- pbl_test : IF (config_flags%bl_pbl_physics .eq. 0) THEN
- CALL vertical_diffusion_u ( u, ru_tendf, config_flags, &
- u_base, &
- alt, muu, rdn, rdnw, kvdif, &
- ids, ide, jds, jde, kds, kde, &
- ims, ime, jms, jme, kms, kme, &
- its, ite, jts, jte, kts, kte )
- CALL vertical_diffusion_v ( v, rv_tendf, config_flags, &
- v_base, &
- alt, muv, rdn, rdnw, kvdif, &
- ids, ide, jds, jde, kds, kde, &
- ims, ime, jms, jme, kms, kme, &
- its, ite, jts, jte, kts, kte )
- IF (non_hydrostatic) &
- CALL vertical_diffusion ( 'w', w, rw_tendf, config_flags, &
- alt, mut, rdn, rdnw, kvdif, &
- ids, ide, jds, jde, kds, kde, &
- ims, ime, jms, jme, kms, kme, &
- its, ite, jts, jte, kts, kte )
- kvdq = 3.*kvdif
- CALL vertical_diffusion_3dmp ( t, t_tendf, config_flags, t_init, &
- alt, mut, rdn, rdnw, kvdq , &
- ids, ide, jds, jde, kds, kde, &
- ims, ime, jms, jme, kms, kme, &
- its, ite, jts, jte, kts, kte )
- ENDIF pbl_test
- ! Theta tendency computations.
- END IF diff_opt1
- IF ( diff_6th_opt .NE. 0 ) THEN
- CALL sixth_order_diffusion( 'u', u, ru_tendf, mut, dt, &
- config_flags, &
- diff_6th_opt, diff_6th_factor, &
- ids, ide, jds, jde, kds, kde, &
- ims, ime, jms, jme, kms, kme, &
- its, ite, jts, jte, kts, kte )
- CALL sixth_order_diffusion( 'v', v, rv_tendf, mut, dt, &
- config_flags, &
- diff_6th_opt, diff_6th_factor, &
- ids, ide, jds, jde, kds, kde, &
- ims, ime, jms, jme, kms, kme, &
- its, ite, jts, jte, kts, kte )
- IF (non_hydrostatic) &
- CALL sixth_order_diffusion( 'w', w, rw_tendf, mut, dt, &
- config_flags, &
- diff_6th_opt, diff_6th_factor, &
- ids, ide, jds, jde, kds, kde, &
- ims, ime, jms, jme, kms, kme, &
- its, ite, jts, jte, kts, kte )
- CALL sixth_order_diffusion( 'm', t, t_tendf, mut, dt, &
- config_flags, &
- diff_6th_opt, diff_6th_factor, &
- ids, ide, jds, jde, kds, kde, &
- ims, ime, jms, jme, kms, kme, &
- its, ite, jts, jte, kts, kte )
- ENDIF
- IF( damp_opt .eq. 2 ) &
- CALL rk_rayleigh_damp( ru_tendf, rv_tendf, &
- rw_tendf, t_tendf, &
- u, v, w, t, t_init, &
- mut, muu, muv, ph, phb, &
- u_base, v_base, t_base, z_base, &
- dampcoef, zdamp, &
- ids, ide, jds, jde, kds, kde, &
- ims, ime, jms, jme, kms, kme, &
- its, ite, jts, jte, kts, kte )
- IF( rad_nudge .eq. 1 ) &
- CALL theta_relaxation( t_tendf, t, t_init, &
- mut, ph, phb, &
- t_base, z_base, &
- ids, ide, jds, jde, kds, kde, &
- ims, ime, jms, jme, kms, kme, &
- its, ite, jts, jte, kts, kte )
- END IF forward_step
- END SUBROUTINE rk_tendency
- !-------------------------------------------------------------------------------
- SUBROUTINE rk_addtend_dry ( ru_tend, rv_tend, rw_tend, ph_tend, t_tend, &
- ru_tendf, rv_tendf, rw_tendf, ph_tendf, t_tendf, &
- u_save, v_save, w_save, ph_save, t_save, &
- mu_tend, mu_tendf, rk_step, &
- h_diabatic, mut, msftx, msfty, msfux, msfuy, &
- msfvx, msfvx_inv, msfvy, &
- ids,ide, jds,jde, kds,kde, &
- ims,ime, jms,jme, kms,kme, &
- ips,ipe, jps,jpe, kps,kpe, &
- its,ite, jts,jte, kts,kte )
- IMPLICIT NONE
- ! Input data.
- INTEGER , INTENT(IN ) :: ids, ide, jds, jde, kds, kde, &
- ims, ime, jms, jme, kms, kme, &
- ips, ipe, jps, jpe, kps, kpe, &
- its, ite, jts, jte, kts, kte
- INTEGER , INTENT(IN ) :: rk_step
- REAL , DIMENSION( ims:ime , kms:kme, jms:jme ) , INTENT(INOUT) :: ru_tend, &
- rv_tend, &
- rw_tend, &
- ph_tend, &
- t_tend, &
- ru_tendf, &
- rv_tendf, &
- rw_tendf, &
- ph_tendf, &
- t_tendf
- REAL , DIMENSION( ims:ime , jms:jme ) , INTENT(INOUT) :: mu_tend, &
- mu_tendf
- REAL , DIMENSION( ims:ime , kms:kme, jms:jme ) , INTENT(IN ) :: u_save, &
- v_save, &
- w_save, &
- ph_save, &
- t_save, &
- h_diabatic
- REAL , DIMENSION( ims:ime , jms:jme ) , INTENT(IN ) :: mut, &
- msftx, &
- msfty, &
- msfux, &
- msfuy, &
- msfvx, &
- msfvx_inv, &
- msfvy
- ! Local
- INTEGER :: i, j, k
- !<DESCRIPTION>
- !
- ! rk_addtend_dry constructs the full large-timestep tendency terms for
- ! momentum (u,v,w), theta and geopotential equations. This is accomplished
- ! by combining the physics tendencies (in *tendf; these are computed
- ! the first RK substep, held fixed thereafter) with the RK tendencies
- ! (in *tend, these include advection, pressure gradient, etc;
- ! these change each rk substep). Output is in *tend.
- !
- !</DESCRIPTION>
- ! Finally, add the forward-step tendency to the rk_tendency
- ! u/v/w/save contain bc tendency that needs to be multiplied by msf
- ! (u by msfuy, v by msfvx)
- ! before adding it to physics tendency (*tendf)
- ! For momentum we need the final tendency to include an inverse msf
- ! physics/bc tendency needs to be divided, advection tendency already has it
- ! For scalars we need the final tendency to include an inverse msf (msfty)
- ! advection tendency is OK, physics/bc tendency needs to be divided by msf
- DO j = jts,MIN(jte,jde-1)
- DO k = kts,kte-1
- DO i = its,ite
- ! multiply by my to uncouple u
- IF(rk_step == 1)ru_tendf(i,k,j) = ru_tendf(i,k,j) + u_save(i,k,j)*msfuy(i,j)
- ! divide by my to couple u
- ru_tend(i,k,j) = ru_tend(i,k,j) + ru_tendf(i,k,j)/msfuy(i,j)
- ENDDO
- ENDDO
- ENDDO
- DO j = jts,jte
- DO k = kts,kte-1
- DO i = its,MIN(ite,ide-1)
- ! multiply by mx to uncouple v
- IF(rk_step == 1)rv_tendf(i,k,j) = rv_tendf(i,k,j) + v_save(i,k,j)*msfvx(i,j)
- ! divide by mx to couple v
- rv_tend(i,k,j) = rv_tend(i,k,j) + rv_tendf(i,k,j)*msfvx_inv(i,j)
- ENDDO
- ENDDO
- ENDDO
- DO j = jts,MIN(jte,jde-1)
- DO k = kts,kte
- DO i = its,MIN(ite,ide-1)
- ! multiply by my to uncouple w
- IF(rk_step == 1)rw_tendf(i,k,j) = rw_tendf(i,k,j) + w_save(i,k,j)*msfty(i,j)
- ! divide by my to couple w
- rw_tend(i,k,j) = rw_tend(i,k,j) + rw_tendf(i,k,j)/msfty(i,j)
- IF(rk_step == 1)ph_tendf(i,k,j) = ph_tendf(i,k,j) + ph_save(i,k,j)
- ! divide by my to couple scalar
- ph_tend(i,k,j) = ph_tend(i,k,j) + ph_tendf(i,k,j)/msfty(i,j)
- ENDDO
- ENDDO
- ENDDO
- DO j = jts,MIN(jte,jde-1)
- DO k = kts,kte-1
- DO i = its,MIN(ite,ide-1)
- IF(rk_step == 1)t_tendf(i,k,j) = t_tendf(i,k,j) + t_save(i,k,j)
- ! divide by my to couple theta
- t_tend(i,k,j) = t_tend(i,k,j) + t_tendf(i,k,j)/msfty(i,j) &
- + mut(i,j)*h_diabatic(i,k,j)/msfty(i,j)
- ! divide by my to couple heating
- ENDDO
- ENDDO
- ENDDO
- DO j = jts,MIN(jte,jde-1)
- DO i = its,MIN(ite,ide-1)
- ! mu tendencies not coupled with 1/msf
- mu_tend(i,j) = mu_tend(i,j) + mu_tendf(i,j)
- ENDDO
- ENDDO
- END SUBROUTINE rk_addtend_dry
- !-------------------------------------------------------------------------------
- SUBROUTINE rk_scalar_tend ( scs, sce, config_flags, &
- tenddec, &
- rk_step, dt, &
- ru, rv, ww, mut, mub, mu_old, &
- alt, &
- scalar_old, scalar, &
- scalar_tends, advect_tend, &
- h_tendency, z_tendency, &
- RQVFTEN, &
- base, moist_step, fnm, fnp, &
- msfux, msfuy, msfvx, msfvx_inv, &
- msfvy, msftx, msfty, &
- rdx, rdy, rdn, rdnw, &
- khdif, kvdif, xkmhd, &
- diff_6th_opt, diff_6th_factor, &
- adv_opt, &
- ids, ide, jds, jde, kds, kde, &
- ims, ime, jms, jme, kms, kme, &
- its, ite, jts, jte, kts, kte )
- IMPLICIT NONE
- ! Input data.
- TYPE(grid_config_rec_type ) , INTENT(IN ) :: config_flags
- LOGICAL , INTENT(IN ) :: tenddec ! tendency term
- INTEGER , INTENT(IN ) :: rk_step, scs, sce
- INTEGER , INTENT(IN ) :: ids, ide, jds, jde, kds, kde, &
- ims, ime, jms, jme, kms, kme, &
- its, ite, jts, jte, kts, kte
- LOGICAL , INTENT(IN ) :: moist_step
- REAL, DIMENSION(ims:ime, kms:kme, jms:jme , scs:sce ), &
- INTENT(IN ) :: scalar, scalar_old
- REAL, DIMENSION(ims:ime, kms:kme, jms:jme , scs:sce ), &
- INTENT(INOUT) :: scalar_tends
-
- REAL, DIMENSION(ims:ime, kms:kme, jms:jme ), INTENT(INOUT) :: advect_tend
- REAL, DIMENSION(ims:ime, kms:kme, jms:jme ), INTENT( OUT) :: h_tendency, z_tendency
- REAL, DIMENSION(ims:ime, kms:kme, jms:jme ), INTENT(OUT ) :: RQVFTEN
- REAL, DIMENSION(ims:ime, kms:kme, jms:jme ), INTENT(IN ) :: ru, &
- rv, &
- ww, &
- xkmhd, &
- alt
- REAL , DIMENSION( kms:kme ) , INTENT(IN ) :: fnm, &
- fnp, &
- rdn, &
- rdnw, &
- base
- REAL , DIMENSION( ims:ime , jms:jme ) , INTENT(IN ) :: msfux, &
- msfuy, &
- msfvx, &
- msfvx_inv, &
- msfvy, &
- msftx, &
- msfty, &
- mub, &
- mut, &
- mu_old
- REAL , INTENT(IN ) :: rdx, &
- rdy, &
- khdif, &
- kvdif
- INTEGER, INTENT( IN ) :: diff_6th_opt
- REAL, INTENT( IN ) :: diff_6th_factor
- REAL , INTENT(IN ) :: dt
- INTEGER, INTENT(IN ) :: adv_opt
- ! Local data
-
- INTEGER :: im, i,j,k
- INTEGER :: time_step
- REAL :: khdq, kvdq, tendency
- !<DESCRIPTION>
- !
- ! rk_scalar_tend calls routines that computes scalar tendency from advection
- ! and 3D mixing (TKE or fixed eddy viscosities).
- !
- !</DESCRIPTION>
- khdq = khdif/prandtl
- kvdq = kvdif/prandtl
- scalar_loop : DO im = scs, sce
- CALL zero_tend ( advect_tend(ims,kms,jms), &
- ids, ide, jds, jde, kds, kde, &
- ims, ime, jms, jme, kms, kme, &
- its, ite, jts, jte, kts, kte )
- CALL zero_tend ( h_tendency(ims,kms,jms), &
- ids, ide, jds, jde, kds, kde, &
- ims, ime, jms, jme, kms, kme, &
- its, ite, jts, jte, kts, kte )
- CALL zero_tend ( z_tendency(ims,kms,jms), &
- ids, ide, jds, jde, kds, kde, &
- ims, ime, jms, jme, kms, kme, &
- its, ite, jts, jte, kts, kte )
- CALL nl_get_time_step ( 1, time_step )
- IF( (rk_step == 3) .and. (adv_opt == POSITIVEDEF) ) THEN
- CALL advect_scalar_pd ( scalar(ims,kms,jms,im), &
- scalar_old(ims,kms,jms,im), &
- advect_tend(ims,kms,jms), &
- h_tendency(ims,kms,jms), &
- z_tendency(ims,kms,jms), &
- ru, rv, ww, mut, mub, mu_old, &
- time_step, config_flags, tenddec, &
- msfux, msfuy, msfvx, msfvy, &
- msftx, msfty, fnm, fnp, &
- rdx, rdy, rdnw,dt, &
- ids, ide, jds, jde, kds, kde, &
- ims, ime, jms, jme, kms, kme, &
- its, ite, jts, jte, kts, kte )
- ELSE IF( (rk_step == 3) .and. (adv_opt == MONOTONIC) ) THEN
- CALL advect_scalar_mono ( scalar(ims,kms,jms,im), &
- scalar_old(ims,kms,jms,im), &
- advect_tend(ims,kms,jms), &
- h_tendency(ims,kms,jms), &
- z_tendency(ims,kms,jms), &
- ru, rv, ww, mut, mub, mu_old, &
- config_flags, tenddec, &
- msfux, msfuy, msfvx, msfvy, &
- msftx, msfty, fnm, fnp, &
- rdx, rdy, rdnw,dt, &
- ids, ide, jds, jde, kds, kde, &
- ims, ime, jms, jme, kms, kme, &
- its, ite, jts, jte, kts, kte )
- ELSE IF( (rk_step == 3) .and. (adv_opt == WENO_SCALAR) ) THEN
- CALL advect_scalar_weno ( scalar(ims,kms,jms,im), &
- scalar(ims,kms,jms,im), &
- advect_tend(ims,kms,jms), &
- ru, rv, ww, mut, time_step, &
- config_flags, &
- msfux, msfuy, msfvx, msfvy, &
- msftx, msfty, fnm, fnp, &
- rdx, rdy, rdnw, &
- ids, ide, jds, jde, kds, kde, &
- ims, ime, jms, jme, kms, kme, &
- its, …
Large files files are truncated, but you can click here to view the full file