| [3] | 1 | subroutine gwprofil |
|---|
| 2 | * ( nlon, nlev |
|---|
| 3 | * , kgwd ,kdx , ktest |
|---|
| 4 | * , kkcrit, kkcrith, kcrit , kkenvh, kknu,kknu2 |
|---|
| [2047] | 5 | * , kkbreak |
|---|
| [3] | 6 | * , paphm1, prho , pstab , ptfr , pvph , pri , ptau |
|---|
| 7 | * , pdmod , pnu , psig ,pgamma, pstd, ppic,pval) |
|---|
| 8 | |
|---|
| 9 | C**** *gwprofil* |
|---|
| 10 | C |
|---|
| 11 | C purpose. |
|---|
| 12 | C -------- |
|---|
| 13 | C |
|---|
| 14 | C** interface. |
|---|
| 15 | C ---------- |
|---|
| 16 | C from *gwdrag* |
|---|
| 17 | C |
|---|
| 18 | C explicit arguments : |
|---|
| 19 | C -------------------- |
|---|
| 20 | C ==== inputs === |
|---|
| 21 | C |
|---|
| 22 | C ==== outputs === |
|---|
| 23 | C |
|---|
| 24 | C implicit arguments : none |
|---|
| 25 | C -------------------- |
|---|
| 26 | C |
|---|
| 27 | C method: |
|---|
| 28 | C ------- |
|---|
| 29 | C the stress profile for gravity waves is computed as follows: |
|---|
| 30 | C it decreases linearly with heights from the ground |
|---|
| 31 | C to the low-level indicated by kkcrith, |
|---|
| 32 | C to simulates lee waves or |
|---|
| 33 | C low-level gravity wave breaking. |
|---|
| 34 | C above it is constant, except when the waves encounter a critical |
|---|
| 35 | C level (kcrit) or when they break. |
|---|
| 36 | C The stress is also uniformly distributed above the level |
|---|
| 37 | C ntop. |
|---|
| 38 | C |
|---|
| [101] | 39 | use dimphy |
|---|
| [3] | 40 | IMPLICIT NONE |
|---|
| 41 | |
|---|
| 42 | #include "YOMCST.h" |
|---|
| 43 | #include "YOEGWD.h" |
|---|
| 44 | |
|---|
| 45 | C----------------------------------------------------------------------- |
|---|
| 46 | C |
|---|
| 47 | C* 0.1 ARGUMENTS |
|---|
| 48 | C --------- |
|---|
| 49 | C |
|---|
| 50 | integer nlon,nlev,kgwd |
|---|
| 51 | integer kkcrit(nlon),kkcrith(nlon),kcrit(nlon) |
|---|
| 52 | * ,kdx(nlon),ktest(nlon) |
|---|
| [2047] | 53 | * ,kkenvh(nlon),kknu(nlon),kknu2(nlon),kkbreak(nlon) |
|---|
| [3] | 54 | C |
|---|
| 55 | real paphm1(nlon,nlev+1), pstab(nlon,nlev+1), |
|---|
| 56 | * prho (nlon,nlev+1), pvph (nlon,nlev+1), |
|---|
| 57 | * pri (nlon,nlev+1), ptfr (nlon), ptau(nlon,nlev+1) |
|---|
| 58 | |
|---|
| 59 | real pdmod (nlon) , pnu (nlon) , psig(nlon), |
|---|
| 60 | * pgamma(nlon) , pstd(nlon) , ppic(nlon), pval(nlon) |
|---|
| 61 | |
|---|
| 62 | C----------------------------------------------------------------------- |
|---|
| 63 | C |
|---|
| 64 | C* 0.2 local arrays |
|---|
| 65 | C ------------ |
|---|
| 66 | C |
|---|
| 67 | integer jl,jk |
|---|
| 68 | real zsqr,zalfa,zriw,zdel,zb,zalpha,zdz2n,zdelp,zdelpt |
|---|
| 69 | |
|---|
| 70 | real zdz2 (klon,klev) , znorm(klon) , zoro(klon) |
|---|
| 71 | real ztau (klon,klev+1) |
|---|
| 72 | C |
|---|
| 73 | C----------------------------------------------------------------------- |
|---|
| 74 | C |
|---|
| 75 | C* 1. INITIALIZATION |
|---|
| 76 | C -------------- |
|---|
| 77 | C |
|---|
| 78 | C print *,' entree gwprofil' |
|---|
| 79 | 100 CONTINUE |
|---|
| 80 | C |
|---|
| 81 | C |
|---|
| 82 | C* COMPUTATIONAL CONSTANTS. |
|---|
| 83 | C ------------- ---------- |
|---|
| 84 | C |
|---|
| 85 | do 400 jl=kidia,kfdia |
|---|
| 86 | if(ktest(jl).eq.1)then |
|---|
| 87 | zoro(jl)=psig(jl)*pdmod(jl)/4./pstd(jl) |
|---|
| 88 | ztau(jl,klev+1)=ptau(jl,klev+1) |
|---|
| 89 | c print *,jl,ptau(jl,klev+1) |
|---|
| 90 | ztau(jl,kkcrith(jl))=grahilo*ptau(jl,klev+1) |
|---|
| 91 | endif |
|---|
| 92 | 400 continue |
|---|
| 93 | |
|---|
| 94 | C |
|---|
| 95 | do 430 jk=klev+1,1,-1 |
|---|
| 96 | C |
|---|
| 97 | C |
|---|
| 98 | C* 4.1 constant shear stress until top of the |
|---|
| 99 | C low-level breaking/trapped layer |
|---|
| 100 | 410 CONTINUE |
|---|
| 101 | C |
|---|
| 102 | do 411 jl=kidia,kfdia |
|---|
| 103 | if(ktest(jl).eq.1)then |
|---|
| 104 | if(jk.gt.kkcrith(jl)) then |
|---|
| 105 | zdelp=paphm1(jl,jk)-paphm1(jl,klev+1) |
|---|
| 106 | zdelpt=paphm1(jl,kkcrith(jl))-paphm1(jl,klev+1) |
|---|
| 107 | ptau(jl,jk)=ztau(jl,klev+1)+zdelp/zdelpt* |
|---|
| 108 | c (ztau(jl,kkcrith(jl))-ztau(jl,klev+1)) |
|---|
| 109 | else |
|---|
| 110 | ptau(jl,jk)=ztau(jl,kkcrith(jl)) |
|---|
| 111 | endif |
|---|
| 112 | endif |
|---|
| 113 | 411 continue |
|---|
| 114 | C |
|---|
| 115 | C* 4.15 constant shear stress until the top of the |
|---|
| 116 | C low level flow layer. |
|---|
| 117 | 415 continue |
|---|
| 118 | C |
|---|
| 119 | C |
|---|
| 120 | C* 4.2 wave displacement at next level. |
|---|
| 121 | C |
|---|
| 122 | 420 continue |
|---|
| 123 | C |
|---|
| 124 | 430 continue |
|---|
| 125 | |
|---|
| 126 | C |
|---|
| 127 | C* 4.4 wave richardson number, new wave displacement |
|---|
| 128 | C* and stress: breaking evaluation and critical |
|---|
| 129 | C level |
|---|
| 130 | C |
|---|
| [2047] | 131 | |
|---|
| 132 | |
|---|
| [3] | 133 | do 440 jk=klev,1,-1 |
|---|
| 134 | |
|---|
| 135 | do 441 jl=kidia,kfdia |
|---|
| 136 | if(ktest(jl).eq.1)then |
|---|
| 137 | znorm(jl)=prho(jl,jk)*sqrt(pstab(jl,jk))*pvph(jl,jk) |
|---|
| 138 | zdz2(jl,jk)=ptau(jl,jk)/amax1(znorm(jl),gssec)/zoro(jl) |
|---|
| 139 | endif |
|---|
| 140 | 441 continue |
|---|
| 141 | |
|---|
| 142 | do 442 jl=kidia,kfdia |
|---|
| 143 | if(ktest(jl).eq.1)then |
|---|
| 144 | if(jk.lt.kkcrith(jl)) then |
|---|
| 145 | if((ptau(jl,jk+1).lt.gtsec).or.(jk.le.kcrit(jl))) then |
|---|
| 146 | ptau(jl,jk)=0.0 |
|---|
| 147 | else |
|---|
| 148 | zsqr=sqrt(pri(jl,jk)) |
|---|
| 149 | zalfa=sqrt(pstab(jl,jk)*zdz2(jl,jk))/pvph(jl,jk) |
|---|
| 150 | zriw=pri(jl,jk)*(1.-zalfa)/(1+zalfa*zsqr)**2 |
|---|
| 151 | if(zriw.lt.grcrit) then |
|---|
| [808] | 152 | c print *,' breaking!!!',ptau(jl,jk),zsqr |
|---|
| [3] | 153 | zdel=4./zsqr/grcrit+1./grcrit**2+4./grcrit |
|---|
| 154 | zb=1./grcrit+2./zsqr |
|---|
| 155 | zalpha=0.5*(-zb+sqrt(zdel)) |
|---|
| 156 | zdz2n=(pvph(jl,jk)*zalpha)**2/pstab(jl,jk) |
|---|
| 157 | ptau(jl,jk)=znorm(jl)*zdz2n*zoro(jl) |
|---|
| 158 | endif |
|---|
| 159 | |
|---|
| 160 | ptau(jl,jk)=amin1(ptau(jl,jk),ptau(jl,jk+1)) |
|---|
| 161 | |
|---|
| 162 | endif |
|---|
| 163 | endif |
|---|
| 164 | endif |
|---|
| 165 | 442 continue |
|---|
| 166 | 440 continue |
|---|
| 167 | |
|---|
| 168 | C REORGANISATION OF THE STRESS PROFILE AT LOW LEVEL |
|---|
| 169 | |
|---|
| 170 | do 530 jl=kidia,kfdia |
|---|
| 171 | if(ktest(jl).eq.1)then |
|---|
| 172 | ztau(jl,kkcrith(jl)-1)=ptau(jl,kkcrith(jl)-1) |
|---|
| 173 | ztau(jl,ntop)=ptau(jl,ntop) |
|---|
| 174 | endif |
|---|
| 175 | 530 continue |
|---|
| 176 | |
|---|
| 177 | do 531 jk=1,klev |
|---|
| 178 | |
|---|
| 179 | do 532 jl=kidia,kfdia |
|---|
| 180 | if(ktest(jl).eq.1)then |
|---|
| 181 | |
|---|
| 182 | if(jk.gt.kkcrith(jl)-1)then |
|---|
| 183 | |
|---|
| 184 | zdelp=paphm1(jl,jk)-paphm1(jl,klev+1 ) |
|---|
| 185 | zdelpt=paphm1(jl,kkcrith(jl)-1)-paphm1(jl,klev+1 ) |
|---|
| 186 | ptau(jl,jk)=ztau(jl,klev+1 ) + |
|---|
| 187 | . (ztau(jl,kkcrith(jl)-1)-ztau(jl,klev+1 ) )* |
|---|
| 188 | . zdelp/zdelpt |
|---|
| 189 | |
|---|
| 190 | endif |
|---|
| 191 | endif |
|---|
| 192 | |
|---|
| 193 | 532 continue |
|---|
| 194 | |
|---|
| 195 | C REORGANISATION AT THE MODEL TOP.... |
|---|
| 196 | |
|---|
| 197 | do 533 jl=kidia,kfdia |
|---|
| 198 | if(ktest(jl).eq.1)then |
|---|
| 199 | |
|---|
| 200 | if(jk.lt.ntop)then |
|---|
| 201 | |
|---|
| 202 | zdelp =paphm1(jl,ntop) |
|---|
| 203 | zdelpt=paphm1(jl,jk) |
|---|
| 204 | ptau(jl,jk)=ztau(jl,ntop)*zdelpt/zdelp |
|---|
| 205 | c ptau(jl,jk)=ztau(jl,ntop) |
|---|
| 206 | |
|---|
| 207 | endif |
|---|
| 208 | |
|---|
| 209 | endif |
|---|
| 210 | |
|---|
| 211 | 533 continue |
|---|
| 212 | |
|---|
| 213 | |
|---|
| 214 | 531 continue |
|---|
| 215 | |
|---|
| [2047] | 216 | c Yo, this is Venus. |
|---|
| 217 | do jl=kidia,kfdia |
|---|
| 218 | do jk=klev,1,-1 |
|---|
| 219 | if(ktest(jl).eq.1)then |
|---|
| 220 | if(jk.lt.kkbreak(jl)) ptau(jl,jk)=0.0 |
|---|
| 221 | endif |
|---|
| 222 | enddo |
|---|
| 223 | enddo |
|---|
| [3] | 224 | |
|---|
| [2047] | 225 | |
|---|
| 226 | ! Venus: resolve waves |
|---|
| 227 | do jk=klev,1,-1 |
|---|
| 228 | do jl=kidia,kfdia |
|---|
| 229 | if(ktest(jl).eq.1)then |
|---|
| 230 | ! if surface stress greater than threshold |
|---|
| 231 | if (ztau(jl,klev+1) .ge. taubs) then |
|---|
| 232 | ! then enforce same stress in the atmosphere up to the predefined level |
|---|
| 233 | if ((jk.gt.levbs)) then |
|---|
| 234 | ptau(jl,jk) = ztau(jl,klev+1) |
|---|
| 235 | ! and zero above |
|---|
| 236 | elseif (jk.le.levbs) then |
|---|
| 237 | ptau(jl,jk) = 0. |
|---|
| 238 | endif |
|---|
| 239 | ! else |
|---|
| 240 | !if (jk.le.klev-1) ptau(jl,jk) = 0. |
|---|
| 241 | ! ptau(jl,jk) = 0. |
|---|
| 242 | endif |
|---|
| 243 | endif |
|---|
| 244 | enddo |
|---|
| 245 | enddo |
|---|
| 246 | |
|---|
| 247 | |
|---|
| 248 | |
|---|
| [3] | 249 | 123 format(i4,1x,20(f6.3,1x)) |
|---|
| 250 | |
|---|
| 251 | |
|---|
| 252 | return |
|---|
| 253 | end |
|---|
| 254 | |
|---|
