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

 SUBROUTINE prandtl_fluxes

!------------------------------------------------------------------------------!
! Actual revisions:
! -----------------
! 
!
! Former revisions:
! -----------------
! $Log: prandtl_fluxes.f90,v $
! Revision 1.19  2006/04/26 12:24:35  raasch
! +OpenMP directives and optimization (array assignments replaced by DO loops)
!
! Revision 1.18  2006/02/23 12:49:32  raasch
! shf, ts, rif, us, usws, vsws, qs and qsws are now defined at the actual
! surface of the model domain, i.e. either at the bottom or at the height
! of the topography. Thus, zu(1) is replaced
! by zp = ( zu(nzb_[variable]_inner(j,i)+1 - zw(nzb_[variable]_inner(j,i) ),
! [variable](1,j,i) by [variable](nzb_[variable]_inner(j,i)+1,j,i) and
! [variable](0,j,i) by [variable](nzb_[variable]_inner(j,i)  ,j,i).
!
! Revision 1.17  2004/04/30 12:43:50  raasch
! rif_m replaced by rif (they are the same when used here)
!
! Revision 1.16  2003/11/20 15:13:26  raasch
! Variable name (B) changed from capital to small
!
! Revision 1.15  2001/03/30 07:46:47  raasch
! Translation of remaining German identifiers (variables, subroutines, etc.)
!
! Revision 1.14  2001/01/29 12:33:38  raasch
! Passive scalar is considered
!
! Revision 1.13  2001/01/25 07:23:22  raasch
! Range of ts is limited, since otherwise overflow may occur on REAL*4
! machines
!
! Revision 1.11  2001/01/22 07:50:34  raasch
! Module test_variables removed
!
! Revision 1.10  2000/04/13 13:44:41  schroeter
! + implentation of the Prandtl layer for the total water content
!
! Revision 1.9  2000/01/26  14:48:48  14:48:48  letzel (Marcus Letzel)
! correct wrong time level of rif in computation of theta*,
! all comments translated into English
! 
! Revision 1.8  1998/09/22 17:27:15  raasch
! Testweise Randbedingung fuer TKE mit cm = 0.4, aber vorerst auskommentiert
!
! Revision 1.7  1998/08/05 06:54:23  raasch
! Begrenzung von rif ist jetzt variabel (rif_max, rif_min)
!
! Revision 1.6  1998/07/06 12:30:01  raasch
! + USE test_variables
!
! Revision 1.5  1998/04/15 11:22:58  raasch
! Berechnung von theta* ueber Oberflaechentemperatur moeglich
!
! Revision 1.4  1998/03/11 11:53:22  raasch
! Zusaetzliche untere Randbedingung fuer TKE ( (u*/0.1)**2 )
!
! Revision 1.3  1998/02/10 15:08:53  raasch
! Grenzfall bei labiler Schichtung ( a=1, b=1 ) wird stabil gerechnet
! Begrenzung von rif aktiviert
!
! Revision 1.2  1998/02/04 16:09:29  raasch
! Berechnung der Waermefluesse
!
! 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
    USE control_parameters
    USE grid_variables
    USE indices

    IMPLICIT NONE

    INTEGER ::  i, j, k
    REAL    ::  a, b, rifm, uv_total, z_p

!
!-- 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
       DO  i = nxl-1, nxr+1
          DO  j = nys-1, nyn+1
             ts(j,i) = -shf(j,i) / ( us(j,i) + 1E-30 )
!
!--          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 )  ts = -1.0E5
             IF ( ts(j,i) >   1.0E5 )  ts =  1.0E5
          ENDDO
       ENDDO

    ELSE
!
!--    For a given surface temperature:
!--    (the Richardson number is still the one from the previous time step)
       !$OMP PARALLEL DO PRIVATE( a, b, k, z_p )
       DO  i = nxl-1, nxr+1
          DO  j = nys-1, nyn+1

             k   = nzb_s_inner(j,i)
             z_p = zu(k+1) - zw(k)

             IF ( rif(j,i) >= 0.0 )  THEN
!
!--             Stable stratification
                ts(j,i) = kappa * ( pt(k+1,j,i) - pt(k,j,i) ) / (          &
                                  LOG( z_p / z0(j,i) ) +                   &
                                  5.0 * rif(j,i) * ( z_p - z0(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) / z_p * z0(j,i) )
!
!--             If a borderline case occurs, the formula for stable
!--             stratification must be used anyway, or else a zero division
!--             would occur in the argument of the logarithm
                IF ( a == 1.0  .OR.  b == 1.0 )  THEN
                   ts(j,i) = kappa * ( pt(k+1,j,i) - pt(k,j,i) ) / (          &
                                     LOG( z_p / z0(j,i) ) +                   &
                                     5.0 * rif(j,i) * ( z_p - z0(j,i) ) / z_p &
                                                                   )
                ELSE
                   ts(j,i) = kappa * ( pt(k+1,j,i) - pt(k,j,i) ) / (          &
                                 LOG( (1.0+b) / (1.0-b) * (1.0-a) / (1.0+a) ) &
                                                                   )
                ENDIF
             ENDIF

          ENDDO
       ENDDO
    ENDIF

!
!-- Compute z_p/L (corresponds to the Richardson-flux number)
    IF ( .NOT. moisture ) THEN
       !$OMP PARALLEL DO PRIVATE( k, z_p )
       DO  i = nxl-1, nxr+1
          DO  j = nys-1, nyn+1
             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 ) )
!
!--          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 )
       DO  i = nxl-1, nxr+1
          DO  j = nys-1, nyn+1
             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 * pt(k+1,j,i) * qs(j,i) ) / &
                        ( vpt(k+1,j,i) * ( us(j,i)**2 + 1E-30 ) )
!
!--          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 )
    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
          uv_total = SQRT( ( 0.5 * ( u(k+1,j,i) + u(k+1,j,i+1) ) )**2 + &
                           ( 0.5 * ( v(k+1,j,i) + v(k+1,j+1,i) ) )**2   &
                         )

          IF ( rif(j,i) >= 0.0 )  THEN
!
!--          Stable stratification
             us(j,i) = kappa * uv_total / (                                &
                                  LOG( z_p / z0(j,i) ) +                   &
                                  5.0 * rif(j,i) * ( z_p - z0(j,i) ) / z_p &
                                          )
          ELSE
!
!--          Unstable stratification
             a = 1.0 / SQRT( SQRT( 1.0 - 16.0 * rif(j,i) ) )
             b = 1.0 / SQRT( SQRT( 1.0 - 16.0 * rif(j,i) / z_p * z0(j,i) ) )
!
!--          If a borderline case occurs, the formula for stable stratification
!--          must be used anyway, or else a zero division would occur in the 
!--          argument of the logarithm.
             IF ( a == 1.0  .OR.  b == 1.0 )  THEN
                us(j,i) = kappa * uv_total / (                                &
                                     LOG( z_p / z0(j,i) ) +                   &
                                     5.0 * rif(j,i) * ( z_p - z0(j,i) ) / z_p &
                                             )
             ELSE
                us(j,i) = kappa * uv_total / (                               &
                              LOG( (1.0+b) / (1.0-b) * (1.0-a) / (1.0+a) ) + &
                              2.0 * ( ATAN( b ) - ATAN( a ) )                &
                                             )
             ENDIF
          ENDIF
       ENDDO
    ENDDO

!
!-- 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 )
    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 * ( rif(j,i-1) + rif(j,i) )
          IF ( rifm >= 0.0 )  THEN
!
!--          Stable stratification
             usws(j,i) = kappa * u(k+1,j,i) / (                           &
                                     LOG( z_p / z0(j,i) ) +               &
                                     5.0 * rifm * ( z_p - z0(j,i) ) / z_p &
                                              )
          ELSE
!
!--          Unstable stratification
             a = 1.0 / SQRT( SQRT( 1.0 - 16.0 * rifm ) )
             b = 1.0 / SQRT( SQRT( 1.0 - 16.0 * rifm / z_p * z0(j,i) ) )
!
!--          If a borderline case occurs, the formula for stable stratification
!--          must be used anyway, or else a zero division would occur in the 
!--          argument of the logarithm. 
             IF ( a == 1.0  .OR.  B == 1.0 )  THEN
                usws(j,i) = kappa * u(k+1,j,i) / (                           &
                                        LOG( z_p / z0(j,i) ) +               &
                                        5.0 * rifm * ( z_p - z0(j,i) ) / z_p &
                                                 )
             ELSE
                usws(j,i) = kappa * u(k+1,j,i) / (                           &
                              LOG( (1.0+b) / (1.0-b) * (1.0-a) / (1.0+a) ) + &
                              2.0 * ( ATAN( b ) - ATAN( a ) )                &
                                                 )
             ENDIF
          ENDIF
          usws(j,i) = -usws(j,i) * ABS( usws(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 )
    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 * ( rif(j-1,i) + rif(j,i) )
          IF ( rifm >= 0.0 )  THEN
!
!--          Stable stratification
             vsws(j,i) = kappa * v(k+1,j,i) / (                           &
                                     LOG( z_p / z0(j,i) ) +               &
                                     5.0 * rifm * ( z_p - z0(j,i) ) / z_p &
                                              )
          ELSE
!
!--          Unstable stratification
             a = 1.0 / SQRT( SQRT( 1.0 - 16.0 * rifm ) )
             b = 1.0 / SQRT( SQRT( 1.0 - 16.0 * rifm / z_p * z0(j,i) ) )
!
!--          If a borderline case occurs, the formula for stable stratification
!--          must be used anyway, or else a zero division would occur in the 
!--          argument of the logarithm.
             IF ( a == 1.0  .OR.  b == 1.0 )  THEN
                vsws(j,i) = kappa * v(k+1,j,i) / (                           &
                                        LOG( z_p / z0(j,i) ) +               &
                                        5.0 * rifm * ( z_p - z0(j,i) ) / z_p &
                                                 )
             ELSE
                vsws(j,i) = kappa * v(k+1,j,i) / (                           &
                              LOG( (1.0+b) / (1.0-b) * (1.0-a) / (1.0+a) ) + &
                              2.0 * ( ATAN( b ) - ATAN( a ) )                &
                                                 )
             ENDIF
          ENDIF
          vsws(j,i) = -vsws(j,i) * ABS( vsws(j,i) )
       ENDDO
    ENDDO

!
!-- If required compute q*
    IF ( moisture  .OR.  passive_scalar )  THEN
       IF ( constant_waterflux )  THEN
!
!--       For a given water flux in the Prandtl layer:
          !$OMP PARALLEL DO
          DO  i = nxl-1, nxr+1
             DO  j = nys-1, nyn+1
                qs(j,i) = -qsws(j,i) / ( us(j,i) + 1E-30 )
             ENDDO
          ENDDO
          
       ELSE          
          !$OMP PARALLEL DO PRIVATE( a, b, k, z_p )
          DO  i = nxl-1, nxr+1
             DO  j = nys-1, nyn+1

                k   = nzb_s_inner(j,i)
                z_p = zu(k+1) - zw(k)

                IF ( rif(j,i) >= 0.0 )  THEN
!
!--                Stable stratification
                   qs(j,i) = kappa * ( q(k+1,j,i) - q(k,j,i) ) / (         &
                                  LOG( z_p / z0(j,i) ) +                   &
                                  5.0 * rif(j,i) * ( z_p - z0(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) / z_p * z0(j,i) )
!
!--                If a borderline case occurs, the formula for stable
!--                stratification must be used anyway, or else a zero division
!--                would occur in the argument of the logarithm. 
                   IF ( a == 1.0  .OR.  b == 1.0 )  THEN
                      qs(j,i) = kappa * ( q(k+1,j,i) - q(k,j,i) ) / (         &
                                     LOG( z_p / z0(j,i) ) +                   &
                                     5.0 * rif(j,i) * ( z_p - z0(j,i) ) / z_p &
                                                                    )
                   ELSE
                      qs(j,i) = kappa * ( q(k+1,j,i) - q(k,j,i) ) / (          &
                                  LOG( (1.0+b) / (1.0-b) * (1.0-a) / (1.0+a) ) &
                                                                    )
                   ENDIF
                ENDIF

             ENDDO
          ENDDO
       ENDIF
    ENDIF

!
!-- Exchange the boundaries for u* and the momentum fluxes (fluxes only for
!-- completeness's sake).
    CALL exchange_horiz_2d( us )
    CALL exchange_horiz_2d( usws )
    CALL exchange_horiz_2d( vsws )
    IF ( moisture  .OR.  passive_scalar )  CALL exchange_horiz_2d( qsws )

!
!-- Compute the vertical kinematic heat flux
    IF ( .NOT. constant_heatflux )  THEN
       !$OMP PARALLEL DO
       DO  i = nxl-1, nxr+1
          DO  j = nys-1, nyn+1
             shf(j,i) = -ts(j,i) * us(j,i)
          ENDDO
       ENDDO
    ENDIF

!
!-- Compute the vertical water/scalar flux
    IF ( .NOT. constant_heatflux .AND. ( moisture .OR. passive_scalar ) ) THEN
       !$OMP PARALLEL DO
       DO  i = nxl-1, nxr+1
          DO  j = nys-1, nyn+1
             qsws(j,i) = -qs(j,i) * us(j,i)
          ENDDO
       ENDDO
    ENDIF

!
!-- Bottom boundary condition for the TKE
    IF ( ibc_e_b == 2 )  THEN
       !$OMP PARALLEL DO
       DO  i = nxl-1, nxr+1
          DO  j = nys-1, nyn+1
             e(nzb_s_inner(j,i)+1,j,i) = ( us(j,i) / 0.1 )**2
!
!--          As a test: cm = 0.4
!            e(nzb_s_inner(j,i)+1,j,i) = ( us(j,i) / 0.4 )**2
             e(nzb_s_inner(j,i),j,i)   = e(nzb_s_inner(j,i)+1,j,i)
          ENDDO
       ENDDO
    ENDIF


 END SUBROUTINE prandtl_fluxes