SUBROUTINE prandtl_fluxes !------------------------------------------------------------------------------! ! Actual revisions: ! ----------------- ! ! ! Former revisions: ! ----------------- ! $Id: prandtl_fluxes.f90 4 2007-02-13 11:33:16Z knoop $ ! RCS Log replace by Id keyword, revision history cleaned up ! ! Revision 1.19 2006/04/26 12:24:35 raasch ! +OpenMP directives and optimization (array assignments replaced by DO loops) ! ! 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