phylmd/Orography/gwstress.f

    SUBROUTINE gwstress(nlon,nlev,ktest,kcrit,kkenvh,kknu,prho,pstab,pvph, &
        pstd,psig,pmea,ppic,ptau,pgeom1,pdmod)

!**** *gwstress*

!     purpose.
!     --------

!**   interface.
!     ----------
!     call *gwstress*  from *gwdrag*

!        explicit arguments :
!        --------------------
!     ==== inputs ===
!     ==== outputs ===

!        implicit arguments :   none
!        --------------------

!     method.
!     -------


!     externals.
!     ----------


!     reference.
!     ----------

!        see ecmwf research department documentation of the "i.f.s."

!     author.
!     -------

!     modifications.
!     --------------
!     f. lott put the new gwd on ifs      22/11/93

!-----------------------------------------------------------------------
      USE dimens_m
      USE dimphy
      USE suphec_m
      USE yoegwd
      IMPLICIT NONE

!-----------------------------------------------------------------------

!*       0.1   arguments
!              ---------

      INTEGER nlon, nlev
      INTEGER kcrit(nlon), ktest(nlon), kkenvh(nlon), kknu(nlon)

      REAL prho(nlon,nlev+1), pstab(nlon,nlev+1), ptau(nlon,nlev+1), &
        pvph(nlon,nlev+1), pgeom1(nlon,nlev)
      REAL, INTENT (IN) :: pstd(nlon)

      REAL, INTENT (IN) :: psig(nlon)
      REAL pmea(nlon), ppic(nlon)
      REAL pdmod(nlon)

!-----------------------------------------------------------------------

!*       0.2   local arrays
!              ------------
      INTEGER jl
      REAL zblock, zvar, zeff
      LOGICAL lo

!-----------------------------------------------------------------------

!*       0.3   functions
!              ---------
!     ------------------------------------------------------------------

!*         1.    initialization
!                --------------

100   CONTINUE

!*         3.1     gravity wave stress.

300   CONTINUE


      DO 301 jl = 1, klon
        IF (ktest(jl)==1) THEN

!  effective mountain height above the blocked flow

          IF (kkenvh(jl)==klev) THEN
            zblock = 0.0
          ELSE
            zblock = (pgeom1(jl,kkenvh(jl))+pgeom1(jl,kkenvh(jl)+1))/2./rg
          END IF

          zvar = ppic(jl) - pmea(jl)
          zeff = amax1(0.,zvar-zblock)

          ptau(jl,klev+1) = prho(jl,klev+1)*gkdrag*psig(jl)*zeff**2/4./ &
            pstd(jl)*pvph(jl,klev+1)*pdmod(jl)*sqrt(pstab(jl,klev+1))

!  too small value of stress or  low level flow include critical level
!  or low level flow:  gravity wave stress nul.

          lo = (ptau(jl,klev+1)<gtsec) .OR. (kcrit(jl)>=kknu(jl)) .OR. &
            (pvph(jl,klev+1)<gvcrit)
!       if(lo) ptau(jl,klev+1)=0.0

        ELSE

          ptau(jl,klev+1) = 0.0

        END IF

301   CONTINUE

      RETURN
    END
1	guez	23	SUBROUTINE gwstress(nlon,nlev,ktest,kcrit,kkenvh,kknu,prho,pstab,pvph, &
2			pstd,psig,pmea,ppic,ptau,pgeom1,pdmod)
3
4			!**** gwstress
5
6			! purpose.
7			! --------
8
9			!** interface.
10			! ----------
11			! call gwstress from gwdrag
12
13			! explicit arguments :
14			! --------------------
15			! ==== inputs ===
16			! ==== outputs ===
17
18			! implicit arguments : none
19			! --------------------
20
21			! method.
22			! -------
23
24
25			! externals.
26			! ----------
27
28
29			! reference.
30			! ----------
31
32			! see ecmwf research department documentation of the "i.f.s."
33
34			! author.
35			! -------
36
37			! modifications.
38			! --------------
39			! f. lott put the new gwd on ifs 22/11/93
40
41			!-----------------------------------------------------------------------
42			USE dimens_m
43			USE dimphy
44	guez	38	USE suphec_m
45	guez	23	USE yoegwd
46			IMPLICIT NONE
47
48			!-----------------------------------------------------------------------
49
50			!* 0.1 arguments
51			! ---------
52
53			INTEGER nlon, nlev
54			INTEGER kcrit(nlon), ktest(nlon), kkenvh(nlon), kknu(nlon)
55
56			REAL prho(nlon,nlev+1), pstab(nlon,nlev+1), ptau(nlon,nlev+1), &
57			pvph(nlon,nlev+1), pgeom1(nlon,nlev)
58			REAL, INTENT (IN) :: pstd(nlon)
59
60			REAL, INTENT (IN) :: psig(nlon)
61			REAL pmea(nlon), ppic(nlon)
62			REAL pdmod(nlon)
63
64			!-----------------------------------------------------------------------
65
66			!* 0.2 local arrays
67			! ------------
68			INTEGER jl
69			REAL zblock, zvar, zeff
70			LOGICAL lo
71
72			!-----------------------------------------------------------------------
73
74			!* 0.3 functions
75			! ---------
76			! ------------------------------------------------------------------
77
78			!* 1. initialization
79			! --------------
80
81			100 CONTINUE
82
83			!* 3.1 gravity wave stress.
84
85			300 CONTINUE
86
87
88			DO 301 jl = 1, klon
89			IF (ktest(jl)==1) THEN
90
91			! effective mountain height above the blocked flow
92
93			IF (kkenvh(jl)==klev) THEN
94			zblock = 0.0
95			ELSE
96			zblock = (pgeom1(jl,kkenvh(jl))+pgeom1(jl,kkenvh(jl)+1))/2./rg
97			END IF
98
99			zvar = ppic(jl) - pmea(jl)
100			zeff = amax1(0.,zvar-zblock)
101
102			ptau(jl,klev+1) = prho(jl,klev+1)gkdragpsig(jl)zeff*2/4./ &
103			pstd(jl)pvph(jl,klev+1)pdmod(jl)*sqrt(pstab(jl,klev+1))
104
105			! too small value of stress or low level flow include critical level
106			! or low level flow: gravity wave stress nul.
107
108			lo = (ptau(jl,klev+1)<gtsec) .OR. (kcrit(jl)>=kknu(jl)) .OR. &
109			(pvph(jl,klev+1)<gvcrit)
110			! if(lo) ptau(jl,klev+1)=0.0
111
112			ELSE
113
114			ptau(jl,klev+1) = 0.0
115
116			END IF
117
118			301 CONTINUE
119
120			RETURN
121			END