/[lmdze]/trunk/Sources/phylmd/Orography/gwstress.f
ViewVC logotype

Diff of /trunk/Sources/phylmd/Orography/gwstress.f

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

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