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