source: palm/trunk/SOURCE/prandtl_fluxes.f90 @ 1502

 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 <http://www.gnu.org/licenses/>.
!
! Copyright 1997-2014 Leibniz Universitaet Hannover
!--------------------------------------------------------------------------------!
!
! Current revisions:
! -----------------
! 
! 
! Former revisions:
! -----------------
! $Id: prandtl_fluxes.f90 1497 2014-12-02 17:28:07Z kanani $
!
! 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

    USE land_surface_model_mod,                                                &
        ONLY: land_surface

    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 .AND. .NOT. land_surface )  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 )       &
         .AND. .NOT. land_surface )  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