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