phylmd/Orography/gwstress.f

module gwstress_m

  IMPLICIT NONE

contains

  SUBROUTINE gwstress(nlon,nlev,ktest,kkenvh,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

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

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

    INTEGER nlon, nlev
    INTEGER ktest(nlon), kkenvh(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

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

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

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

    !*         3.1     gravity wave stress.

    DO 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.
       ELSE

          ptau(jl,klev+1) = 0.0

       END IF

    end DO

  END SUBROUTINE gwstress

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