SUBROUTINE prandtl_fluxes !--------------------------------------------------------------------------------! ! This file is part of PALM. ! ! PALM is free software: you can redistribute it and/or modify it under the terms ! of the GNU General Public License as published by the Free Software Foundation, ! either version 3 of the License, or (at your option) any later version. ! ! PALM is distributed in the hope that it will be useful, but WITHOUT ANY ! WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR ! A PARTICULAR PURPOSE. See the GNU General Public License for more details. ! ! You should have received a copy of the GNU General Public License along with ! PALM. If not, see . ! ! Copyright 1997-2014 Leibniz Universitaet Hannover !--------------------------------------------------------------------------------! ! ! Current revisions: ! ----------------- ! ! ! Former revisions: ! ----------------- ! $Id: prandtl_fluxes.f90 1552 2015-03-03 14:27:15Z heinze $ ! ! 1551 2015-03-03 14:18:16Z maronga ! Removed land surface model part. The surface fluxes are now always calculated ! within prandtl_fluxes, based on the given surface temperature/humidity (which ! is either provided by the land surface model, by large scale forcing data, or ! directly prescribed by the user. ! ! 1496 2014-12-02 17:25:50Z maronga ! Adapted for land surface model ! ! 1494 2014-11-21 17:14:03Z maronga ! Bugfixes: qs is now calculated before calculation of Rif. Ccalculation of ! buoyancy flux in Rif corrected (added missing humidity term), allow use of ! topography for coupled runs (not tested) ! ! 1361 2014-04-16 15:17:48Z hoffmann ! Bugfix: calculation of turbulent fluxes of rain water content (qrsws) and rain ! drop concentration (nrsws) added ! ! 1340 2014-03-25 19:45:13Z kanani ! REAL constants defined as wp-kind ! ! 1320 2014-03-20 08:40:49Z raasch ! ONLY-attribute added to USE-statements, ! kind-parameters added to all INTEGER and REAL declaration statements, ! kinds are defined in new module kinds, ! old module precision_kind is removed, ! revision history before 2012 removed, ! comment fields (!:) to be used for variable explanations added to ! all variable declaration statements ! ! 1276 2014-01-15 13:40:41Z heinze ! Use LSF_DATA also in case of Dirichlet bottom boundary condition for scalars ! ! 1257 2013-11-08 15:18:40Z raasch ! openACC "kernels do" replaced by "kernels loop", "loop independent" added ! ! 1036 2012-10-22 13:43:42Z raasch ! code put under GPL (PALM 3.9) ! ! 1015 2012-09-27 09:23:24Z raasch ! OpenACC statements added ! ! 978 2012-08-09 08:28:32Z fricke ! roughness length for scalar quantities z0h added ! ! Revision 1.1 1998/01/23 10:06:06 raasch ! Initial revision ! ! ! Description: ! ------------ ! Diagnostic computation of vertical fluxes in the Prandtl layer from the ! values of the variables at grid point k=1 !------------------------------------------------------------------------------! USE arrays_3d, & ONLY: e, nr, nrs, nrsws, pt, q, qr, qrs, qrsws, qs, qsws, rif, shf, & ts, u, us, usws, v, vpt, vsws, zu, zw, z0, z0h USE control_parameters, & ONLY: cloud_physics, constant_heatflux, constant_waterflux, & coupling_mode, g, humidity, ibc_e_b, icloud_scheme, kappa, & large_scale_forcing, lsf_surf, passive_scalar, precipitation, & pt_surface, q_surface, rif_max, rif_min, run_coupled, & surface_pressure USE indices, & ONLY: nxl, nxlg, nxr, nxrg, nys, nysg, nyn, nyng, nzb_s_inner, & nzb_u_inner, nzb_v_inner USE kinds IMPLICIT NONE INTEGER(iwp) :: i !: INTEGER(iwp) :: j !: INTEGER(iwp) :: k !: LOGICAL :: coupled_run !: REAL(wp) :: a !: REAL(wp) :: b !: REAL(wp) :: e_q !: REAL(wp) :: rifm !: REAL(wp) :: uv_total !: REAL(wp) :: z_p !: ! !-- Data information for accelerators !$acc data present( e, nrsws, nzb_u_inner, nzb_v_inner, nzb_s_inner, pt ) & !$acc present( q, qs, qsws, qrsws, rif, shf, ts, u, us, usws, v ) & !$acc present( vpt, vsws, zu, zw, z0, z0h ) ! !-- Compute theta* IF ( constant_heatflux ) THEN ! !-- For a given heat flux in the Prandtl layer: !-- for u* use the value from the previous time step !$OMP PARALLEL DO !$acc kernels loop DO i = nxlg, nxrg DO j = nysg, nyng ts(j,i) = -shf(j,i) / ( us(j,i) + 1E-30_wp ) ! !-- ts must be limited, because otherwise overflow may occur in case of !-- us=0 when computing rif further below IF ( ts(j,i) < -1.05E5_wp ) ts(j,i) = -1.0E5_wp IF ( ts(j,i) > 1.0E5_wp ) ts(j,i) = 1.0E5_wp ENDDO ENDDO ELSE ! !-- For a given surface temperature: !-- (the Richardson number is still the one from the previous time step) IF ( large_scale_forcing .AND. lsf_surf ) THEN !$OMP PARALLEL DO !$acc kernels loop DO i = nxlg, nxrg DO j = nysg, nyng k = nzb_s_inner(j,i) pt(k,j,i) = pt_surface ENDDO ENDDO ENDIF !$OMP PARALLEL DO PRIVATE( a, b, k, z_p ) !$acc kernels loop DO i = nxlg, nxrg DO j = nysg, nyng k = nzb_s_inner(j,i) z_p = zu(k+1) - zw(k) IF ( rif(j,i) >= 0.0_wp ) THEN ! !-- Stable stratification ts(j,i) = kappa * ( pt(k+1,j,i) - pt(k,j,i) ) / ( & LOG( z_p / z0h(j,i) ) + & 5.0_wp * rif(j,i) * ( z_p - z0h(j,i) ) / z_p & ) ELSE ! !-- Unstable stratification a = SQRT( 1.0_wp - 16.0_wp * rif(j,i) ) b = SQRT( 1.0_wp - 16.0_wp * rif(j,i) * z0h(j,i) / z_p ) ts(j,i) = kappa * ( pt(k+1,j,i) - pt(k,j,i) ) / ( & LOG( z_p / z0h(j,i) ) - & 2.0_wp * LOG( ( 1.0_wp + a ) / ( 1.0_wp + b ) ) ) ENDIF ENDDO ENDDO ENDIF ! !-- If required compute q* IF ( humidity .OR. passive_scalar ) THEN IF ( constant_waterflux ) THEN ! !-- For a given water flux in the Prandtl layer: !$OMP PARALLEL DO !$acc kernels loop DO i = nxlg, nxrg DO j = nysg, nyng qs(j,i) = -qsws(j,i) / ( us(j,i) + 1E-30_wp ) ENDDO ENDDO ELSE coupled_run = ( coupling_mode == 'atmosphere_to_ocean' .AND. run_coupled ) IF ( large_scale_forcing .AND. lsf_surf ) THEN !$OMP PARALLEL DO !$acc kernels loop DO i = nxlg, nxrg DO j = nysg, nyng k = nzb_s_inner(j,i) q(k,j,i) = q_surface ENDDO ENDDO ENDIF !$OMP PARALLEL DO PRIVATE( a, b, k, z_p ) !$acc kernels loop independent DO i = nxlg, nxrg !$acc loop independent DO j = nysg, nyng k = nzb_s_inner(j,i) z_p = zu(k+1) - zw(k) ! !-- Assume saturation for atmosphere coupled to ocean (but not !-- in case of precursor runs) IF ( coupled_run ) THEN e_q = 6.1_wp * & EXP( 0.07_wp * ( MIN(pt(k,j,i),pt(k+1,j,i)) - 273.15_wp ) ) q(k,j,i) = 0.622_wp * e_q / ( surface_pressure - e_q ) ENDIF IF ( rif(j,i) >= 0.0_wp ) THEN ! !-- Stable stratification qs(j,i) = kappa * ( q(k+1,j,i) - q(k,j,i) ) / ( & LOG( z_p / z0h(j,i) ) + & 5.0_wp * rif(j,i) * ( z_p - z0h(j,i) ) / z_p & ) ELSE ! !-- Unstable stratification a = SQRT( 1.0_wp - 16.0_wp * rif(j,i) ) b = SQRT( 1.0_wp - 16.0_wp * rif(j,i) * z0h(j,i) / z_p ) qs(j,i) = kappa * ( q(k+1,j,i) - q(k,j,i) ) / ( & LOG( z_p / z0h(j,i) ) - & 2.0_wp * LOG( (1.0_wp + a ) / ( 1.0_wp + b ) ) ) ENDIF ENDDO ENDDO ENDIF ENDIF ! !-- Compute z_p/L (corresponds to the Richardson-flux number) IF ( .NOT. humidity ) THEN !$OMP PARALLEL DO PRIVATE( k, z_p ) !$acc kernels loop DO i = nxlg, nxrg DO j = nysg, nyng k = nzb_s_inner(j,i) z_p = zu(k+1) - zw(k) rif(j,i) = z_p * kappa * g * ts(j,i) / & ( pt(k+1,j,i) * ( us(j,i)**2 + 1E-30_wp ) ) ! !-- Limit the value range of the Richardson numbers. !-- This is necessary for very small velocities (u,v --> 0), because !-- the absolute value of rif can then become very large, which in !-- consequence would result in very large shear stresses and very !-- small momentum fluxes (both are generally unrealistic). IF ( rif(j,i) < rif_min ) rif(j,i) = rif_min IF ( rif(j,i) > rif_max ) rif(j,i) = rif_max ENDDO ENDDO ELSE !$OMP PARALLEL DO PRIVATE( k, z_p ) !$acc kernels loop DO i = nxlg, nxrg DO j = nysg, nyng k = nzb_s_inner(j,i) z_p = zu(k+1) - zw(k) rif(j,i) = z_p * kappa * g * & ( ts(j,i) + 0.61_wp * pt(k+1,j,i) * qs(j,i) + 0.61_wp & * q(k+1,j,i) * ts(j,i)) / & ( vpt(k+1,j,i) * ( us(j,i)**2 + 1E-30_wp ) ) ! !-- Limit the value range of the Richardson numbers. !-- This is necessary for very small velocities (u,v --> 0), because !-- the absolute value of rif can then become very large, which in !-- consequence would result in very large shear stresses and very !-- small momentum fluxes (both are generally unrealistic). IF ( rif(j,i) < rif_min ) rif(j,i) = rif_min IF ( rif(j,i) > rif_max ) rif(j,i) = rif_max ENDDO ENDDO ENDIF ! !-- Compute u* at the scalars' grid points !$OMP PARALLEL DO PRIVATE( a, b, k, uv_total, z_p ) !$acc kernels loop DO i = nxl, nxr DO j = nys, nyn k = nzb_s_inner(j,i) z_p = zu(k+1) - zw(k) ! !-- Compute the absolute value of the horizontal velocity !-- (relative to the surface) uv_total = SQRT( ( 0.5_wp * ( u(k+1,j,i) + u(k+1,j,i+1) & - u(k,j,i) - u(k,j,i+1) ) )**2 + & ( 0.5_wp * ( v(k+1,j,i) + v(k+1,j+1,i) & - v(k,j,i) - v(k,j+1,i) ) )**2 ) IF ( rif(j,i) >= 0.0_wp ) THEN ! !-- Stable stratification us(j,i) = kappa * uv_total / ( & LOG( z_p / z0(j,i) ) + & 5.0_wp * rif(j,i) * ( z_p - z0(j,i) ) / z_p & ) ELSE ! !-- Unstable stratification a = SQRT( SQRT( 1.0_wp - 16.0_wp * rif(j,i) ) ) b = SQRT( SQRT( 1.0_wp - 16.0_wp * rif(j,i) / z_p * z0(j,i) ) ) us(j,i) = kappa * uv_total / ( & LOG( z_p / z0(j,i) ) - & LOG( ( 1.0_wp + a )**2 * ( 1.0_wp + a**2 ) / ( & ( 1.0_wp + b )**2 * ( 1.0_wp + b**2 ) ) ) + & 2.0_wp * ( ATAN( a ) - ATAN( b ) ) & ) ENDIF ENDDO ENDDO ! !-- Values of us at ghost point locations are needed for the evaluation of usws !-- and vsws. !$acc update host( us ) CALL exchange_horiz_2d( us ) !$acc update device( us ) ! !-- Compute u'w' for the total model domain. !-- First compute the corresponding component of u* and square it. !$OMP PARALLEL DO PRIVATE( a, b, k, rifm, z_p ) !$acc kernels loop DO i = nxl, nxr DO j = nys, nyn k = nzb_u_inner(j,i) z_p = zu(k+1) - zw(k) ! !-- Compute Richardson-flux number for this point rifm = 0.5_wp * ( rif(j,i-1) + rif(j,i) ) IF ( rifm >= 0.0_wp ) THEN ! !-- Stable stratification usws(j,i) = kappa * ( u(k+1,j,i) - u(k,j,i) )/ ( & LOG( z_p / z0(j,i) ) + & 5.0_wp * rifm * ( z_p - z0(j,i) ) / z_p & ) ELSE ! !-- Unstable stratification a = SQRT( SQRT( 1.0_wp - 16.0_wp * rifm ) ) b = SQRT( SQRT( 1.0_wp - 16.0_wp * rifm / z_p * z0(j,i) ) ) usws(j,i) = kappa * ( u(k+1,j,i) - u(k,j,i) ) / ( & LOG( z_p / z0(j,i) ) - & LOG( (1.0_wp + a )**2 * ( 1.0_wp + a**2 ) / ( & (1.0_wp + b )**2 * ( 1.0_wp + b**2 ) ) ) + & 2.0_wp * ( ATAN( a ) - ATAN( b ) ) & ) ENDIF usws(j,i) = -usws(j,i) * 0.5_wp * ( us(j,i-1) + us(j,i) ) ENDDO ENDDO ! !-- Compute v'w' for the total model domain. !-- First compute the corresponding component of u* and square it. !$OMP PARALLEL DO PRIVATE( a, b, k, rifm, z_p ) !$acc kernels loop DO i = nxl, nxr DO j = nys, nyn k = nzb_v_inner(j,i) z_p = zu(k+1) - zw(k) ! !-- Compute Richardson-flux number for this point rifm = 0.5_wp * ( rif(j-1,i) + rif(j,i) ) IF ( rifm >= 0.0_wp ) THEN ! !-- Stable stratification vsws(j,i) = kappa * ( v(k+1,j,i) - v(k,j,i) ) / ( & LOG( z_p / z0(j,i) ) + & 5.0_wp * rifm * ( z_p - z0(j,i) ) / z_p & ) ELSE ! !-- Unstable stratification a = SQRT( SQRT( 1.0_wp - 16.0_wp * rifm ) ) b = SQRT( SQRT( 1.0_wp - 16.0_wp * rifm / z_p * z0(j,i) ) ) vsws(j,i) = kappa * ( v(k+1,j,i) - v(k,j,i) ) / ( & LOG( z_p / z0(j,i) ) - & LOG( (1.0_wp + a )**2 * ( 1.0_wp + a**2 ) / ( & (1.0_wp + b )**2 * ( 1.0_wp + b**2 ) ) ) + & 2.0_wp * ( ATAN( a ) - ATAN( b ) ) & ) ENDIF vsws(j,i) = -vsws(j,i) * 0.5_wp * ( us(j-1,i) + us(j,i) ) ENDDO ENDDO ! !-- If required compute qr* and nr* IF ( cloud_physics .AND. icloud_scheme == 0 .AND. precipitation ) THEN !$OMP PARALLEL DO PRIVATE( a, b, k, z_p ) !$acc kernels loop independent DO i = nxlg, nxrg !$acc loop independent DO j = nysg, nyng k = nzb_s_inner(j,i) z_p = zu(k+1) - zw(k) IF ( rif(j,i) >= 0.0 ) THEN ! !-- Stable stratification qrs(j,i) = kappa * ( qr(k+1,j,i) - qr(k,j,i) ) / ( & LOG( z_p / z0h(j,i) ) + & 5.0 * rif(j,i) * ( z_p - z0h(j,i) ) / z_p ) nrs(j,i) = kappa * ( nr(k+1,j,i) - nr(k,j,i) ) / ( & LOG( z_p / z0h(j,i) ) + & 5.0 * rif(j,i) * ( z_p - z0h(j,i) ) / z_p ) ELSE ! !-- Unstable stratification a = SQRT( 1.0 - 16.0 * rif(j,i) ) b = SQRT( 1.0 - 16.0 * rif(j,i) * z0h(j,i) / z_p ) qrs(j,i) = kappa * ( qr(k+1,j,i) - qr(k,j,i) ) / ( & LOG( z_p / z0h(j,i) ) - & 2.0 * LOG( (1.0 + a ) / ( 1.0 + b ) ) ) nrs(j,i) = kappa * ( nr(k+1,j,i) - nr(k,j,i) ) / ( & LOG( z_p / z0h(j,i) ) - & 2.0 * LOG( (1.0 + a ) / ( 1.0 + b ) ) ) ENDIF ENDDO ENDDO ENDIF ! !-- Exchange the boundaries for the momentum fluxes (only for sake of !-- completeness) !$acc update host( usws, vsws ) CALL exchange_horiz_2d( usws ) CALL exchange_horiz_2d( vsws ) !$acc update device( usws, vsws ) IF ( humidity .OR. passive_scalar ) THEN !$acc update host( qsws ) CALL exchange_horiz_2d( qsws ) !$acc update device( qsws ) IF ( cloud_physics .AND. icloud_scheme == 0 .AND. & precipitation ) THEN !$acc update host( qrsws, nrsws ) CALL exchange_horiz_2d( qrsws ) CALL exchange_horiz_2d( nrsws ) !$acc update device( qrsws, nrsws ) ENDIF ENDIF ! !-- Compute the vertical kinematic heat flux IF ( .NOT. constant_heatflux ) THEN !$OMP PARALLEL DO !$acc kernels loop independent DO i = nxlg, nxrg !$acc loop independent DO j = nysg, nyng shf(j,i) = -ts(j,i) * us(j,i) ENDDO ENDDO ENDIF ! !-- Compute the vertical water/scalar flux IF ( .NOT. constant_waterflux .AND. ( humidity .OR. passive_scalar ) ) THEN !$OMP PARALLEL DO !$acc kernels loop independent DO i = nxlg, nxrg !$acc loop independent DO j = nysg, nyng qsws(j,i) = -qs(j,i) * us(j,i) ENDDO ENDDO ENDIF ! !-- Compute (turbulent) fluxes of rain water content and rain drop concentartion IF ( cloud_physics .AND. icloud_scheme == 0 .AND. precipitation ) THEN !$OMP PARALLEL DO !$acc kernels loop independent DO i = nxlg, nxrg !$acc loop independent DO j = nysg, nyng qrsws(j,i) = -qrs(j,i) * us(j,i) nrsws(j,i) = -nrs(j,i) * us(j,i) ENDDO ENDDO ENDIF ! !-- Bottom boundary condition for the TKE IF ( ibc_e_b == 2 ) THEN !$OMP PARALLEL DO !$acc kernels loop independent DO i = nxlg, nxrg !$acc loop independent DO j = nysg, nyng e(nzb_s_inner(j,i)+1,j,i) = ( us(j,i) / 0.1_wp )**2 ! !-- As a test: cm = 0.4 ! e(nzb_s_inner(j,i)+1,j,i) = ( us(j,i) / 0.4_wp )**2 e(nzb_s_inner(j,i),j,i) = e(nzb_s_inner(j,i)+1,j,i) ENDDO ENDDO ENDIF !$acc end data END SUBROUTINE prandtl_fluxes