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 yomcst
      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	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	USE yomcst
45	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