/[MITgcm]/MITgcm/pkg/kpp/kpp_calc.F
ViewVC logotype

Contents of /MITgcm/pkg/kpp/kpp_calc.F

Parent Directory Parent Directory | Revision Log Revision Log | View Revision Graph Revision Graph


Revision 1.33 - (show annotations) (download)
Sat Feb 25 16:29:55 2006 UTC (18 years, 2 months ago) by heimbach
Branch: MAIN
CVS Tags: checkpoint58b_post, checkpoint58f_post, checkpoint58d_post, checkpoint58y_post, checkpoint58t_post, checkpoint58m_post, checkpoint58w_post, checkpoint58o_post, checkpoint58p_post, checkpoint58q_post, checkpoint58e_post, checkpoint58r_post, checkpoint58n_post, checkpoint58k_post, checkpoint58v_post, checkpoint58l_post, checkpoint58g_post, checkpoint58x_post, checkpoint58h_post, checkpoint58j_post, checkpoint58i_post, checkpoint58c_post, checkpoint58u_post, checkpoint58s_post
Changes since 1.32: +12 -7 lines
Improve adjoint solver residual from E+204 to E+34
An improvement of 100+ orders of magn.
Aint it amazing (and still useless).

1 C $Header: /u/gcmpack/MITgcm/pkg/kpp/kpp_calc.F,v 1.32 2005/05/15 03:04:56 jmc Exp $
2 C $Name: $
3
4 #include "KPP_OPTIONS.h"
5
6 CBOP
7 C !ROUTINE: KPP_CALC
8
9 C !INTERFACE: ==========================================================
10 subroutine KPP_CALC(
11 I bi, bj, myTime, myThid )
12
13 C !DESCRIPTION: \bv
14 C /==========================================================\
15 C | SUBROUTINE KPP_CALC |
16 C | o Compute all KPP fields defined in KPP.h |
17 C |==========================================================|
18 C | This subroutine serves as an interface between MITGCMUV |
19 C | code and NCOM 1-D routines in kpp_routines.F |
20 C \==========================================================/
21 IMPLICIT NONE
22
23 c=======================================================================
24 c
25 c written by : jan morzel, august 11, 1994
26 c modified by : jan morzel, january 25, 1995 : "dVsq" and 1d code
27 c detlef stammer, august, 1997 : for MIT GCM Classic
28 c d. menemenlis, july, 1998 : for MIT GCM UV
29 c
30 c compute vertical mixing coefficients based on the k-profile
31 c and oceanic planetary boundary layer scheme by large & mcwilliams.
32 c
33 c summary:
34 c - compute interior mixing everywhere:
35 c interior mixing gets computed at all interfaces due to constant
36 c internal wave background activity ("fkpm" and "fkph"), which
37 c is enhanced in places of static instability (local richardson
38 c number < 0).
39 c Additionally, mixing can be enhanced by adding contribution due
40 c to shear instability which is a function of the local richardson
41 c number
42 c - double diffusivity:
43 c interior mixing can be enhanced by double diffusion due to salt
44 c fingering and diffusive convection (ifdef "kmixdd").
45 c - kpp scheme in the boundary layer:
46 c
47 c a.boundary layer depth:
48 c at every gridpoint the depth of the oceanic boundary layer
49 c ("hbl") gets computed by evaluating bulk richardson numbers.
50 c b.boundary layer mixing:
51 c within the boundary layer, above hbl, vertical mixing is
52 c determined by turbulent surface fluxes, and interior mixing at
53 c the lower boundary, i.e. at hbl.
54 c
55 c this subroutine provides the interface between the MIT GCM UV and the
56 c subroutine "kppmix", where boundary layer depth, vertical
57 c viscosity, vertical diffusivity, and counter gradient term (ghat)
58 c are computed slabwise.
59 c note: subroutine "kppmix" uses m-k-s units.
60 c
61 c time level:
62 c input tracer and velocity profiles are evaluated at time level
63 c tau, surface fluxes come from tau or tau-1.
64 c
65 c grid option:
66 c in this "1-grid" implementation, diffusivity and viscosity
67 c profiles are computed on the "t-grid" (by using velocity shear
68 c profiles averaged from the "u,v-grid" onto the "t-grid"; note, that
69 c the averaging includes zero values on coastal and seafloor grid
70 c points). viscosity on the "u,v-grid" is computed by averaging the
71 c "t-grid" viscosity values onto the "u,v-grid".
72 c
73 c vertical grid:
74 c mixing coefficients get evaluated at the bottom of the lowest
75 c layer, i.e., at depth zw(Nr). these values are only useful when
76 c the model ocean domain does not include the entire ocean down to
77 c the seafloor ("upperocean" setup) and allows flux through the
78 c bottom of the domain. for full-depth runs, these mixing
79 c coefficients are being zeroed out before leaving this subroutine.
80 c
81 c-------------------------------------------------------------------------
82
83 c global parameters updated by kpp_calc
84 c KPPviscAz - KPP eddy viscosity coefficient (m^2/s)
85 c KPPdiffKzT - KPP diffusion coefficient for temperature (m^2/s)
86 c KPPdiffKzS - KPP diffusion coefficient for salt and tracers (m^2/s)
87 c KPPghat - Nonlocal transport coefficient (s/m^2)
88 c KPPhbl - Boundary layer depth on "t-grid" (m)
89 c KPPfrac - Fraction of short-wave flux penetrating mixing layer
90
91 c-- KPP_CALC computes vertical viscosity and diffusivity for region
92 c (-2:sNx+3,-2:sNy+3) as required by CALC_DIFFUSIVITY and requires
93 c values of uVel, vVel, surfaceForcingU, surfaceForcingV in the
94 c region (-2:sNx+4,-2:sNy+4).
95 c Hence overlap region needs to be set OLx=4, OLy=4.
96 c When option FRUGAL_KPP is used, computation in overlap regions
97 c is replaced with exchange calls hence reducing overlap requirements
98 c to OLx=1, OLy=1.
99 c \ev
100
101 C !USES: ===============================================================
102 #include "SIZE.h"
103 #include "EEPARAMS.h"
104 #include "PARAMS.h"
105 #include "DYNVARS.h"
106 #include "KPP.h"
107 #include "KPP_PARAMS.h"
108 #include "FFIELDS.h"
109 #include "GRID.h"
110 #ifdef ALLOW_AUTODIFF_TAMC
111 #include "tamc.h"
112 #include "tamc_keys.h"
113 #else /* ALLOW_AUTODIFF_TAMC */
114 integer ikppkey
115 #endif /* ALLOW_AUTODIFF_TAMC */
116
117 EXTERNAL DIFFERENT_MULTIPLE
118 LOGICAL DIFFERENT_MULTIPLE
119
120 C !INPUT PARAMETERS: ===================================================
121 c Routine arguments
122 c bi, bj - array indices on which to apply calculations
123 c myTime - Current time in simulation
124
125 INTEGER bi, bj
126 INTEGER myThid
127 _RL myTime
128
129 #ifdef ALLOW_KPP
130
131 C !LOCAL VARIABLES: ====================================================
132 c Local constants
133 c minusone, p0, p5, p25, p125, p0625
134 c imin, imax, jmin, jmax - array computation indices
135
136 _RL minusone
137 parameter( minusone=-1.0)
138 _KPP_RL p0 , p5 , p25 , p125 , p0625
139 parameter( p0=0.0, p5=0.5, p25=0.25, p125=0.125, p0625=0.0625 )
140 integer imin ,imax ,jmin ,jmax
141 #ifdef FRUGAL_KPP
142 parameter(imin=1 ,imax=sNx ,jmin=1 ,jmax=sNy )
143 #else
144 parameter(imin=2-OLx,imax=sNx+OLx-1,jmin=2-OLy,jmax=sNy+OLy-1)
145 #endif
146
147 c Local arrays and variables
148 c work? (nx,ny) - horizontal working arrays
149 c ustar (nx,ny) - surface friction velocity (m/s)
150 c bo (nx,ny) - surface turbulent buoyancy forcing (m^2/s^3)
151 c bosol (nx,ny) - surface radiative buoyancy forcing (m^2/s^3)
152 c shsq (nx,ny,Nr) - local velocity shear squared
153 c at interfaces for ri_iwmix (m^2/s^2)
154 c dVsq (nx,ny,Nr) - velocity shear re surface squared
155 c at grid levels for bldepth (m^2/s^2)
156 c dbloc (nx,ny,Nr) - local delta buoyancy at interfaces
157 c for ri_iwmix and bldepth (m/s^2)
158 c Ritop (nx,ny,Nr) - numerator of bulk richardson number
159 c at grid levels for bldepth
160 c vddiff (nx,ny,Nrp2,1)- vertical viscosity on "t-grid" (m^2/s)
161 c vddiff (nx,ny,Nrp2,2)- vert. diff. on next row for salt&tracers (m^2/s)
162 c vddiff (nx,ny,Nrp2,3)- vert. diff. on next row for temperature (m^2/s)
163 c ghat (nx,ny,Nr) - nonlocal transport coefficient (s/m^2)
164 c hbl (nx,ny) - mixing layer depth (m)
165 c kmtj (nx,ny) - maximum number of wet levels in each column
166 c z0 (nx,ny) - Roughness length (m)
167 c zRef (nx,ny) - Reference depth: Hmix * epsilon (m)
168 c uRef (nx,ny) - Reference zonal velocity (m/s)
169 c vRef (nx,ny) - Reference meridional velocity (m/s)
170
171 _RL worka ( 1-OLx:sNx+OLx, 1-OLy:sNy+OLy )
172 integer work1 ( ibot:itop , jbot:jtop )
173 _KPP_RL work2 ( ibot:itop , jbot:jtop )
174 _KPP_RL work3 ( ibot:itop , jbot:jtop )
175 _KPP_RL ustar ( ibot:itop , jbot:jtop )
176 _KPP_RL bo ( ibot:itop , jbot:jtop )
177 _KPP_RL bosol ( ibot:itop , jbot:jtop )
178 _KPP_RL shsq ( ibot:itop , jbot:jtop , Nr )
179 _KPP_RL dVsq ( ibot:itop , jbot:jtop , Nr )
180 _KPP_RL dbloc ( ibot:itop , jbot:jtop , Nr )
181 _KPP_RL Ritop ( ibot:itop , jbot:jtop , Nr )
182 _KPP_RL vddiff( ibot:itop , jbot:jtop , 0:Nrp1, mdiff )
183 _KPP_RL ghat ( ibot:itop , jbot:jtop , Nr )
184 _KPP_RL hbl ( ibot:itop , jbot:jtop )
185 cph(
186 _KPP_RL TTALPHA( ibot:itop, jbot:jtop, Nrp1 )
187 _KPP_RL SSBETA ( ibot:itop, jbot:jtop, Nrp1 )
188 cph)
189 #ifdef KPP_ESTIMATE_UREF
190 _KPP_RL z0 ( ibot:itop , jbot:jtop )
191 _KPP_RL zRef ( ibot:itop , jbot:jtop )
192 _KPP_RL uRef ( ibot:itop , jbot:jtop )
193 _KPP_RL vRef ( ibot:itop , jbot:jtop )
194 #endif /* KPP_ESTIMATE_UREF */
195
196 _KPP_RL tempvar2
197 integer i, j, k, kp1, im1, ip1, jm1, jp1
198
199 #ifdef KPP_ESTIMATE_UREF
200 _KPP_RL tempvar1, dBdz1, dBdz2, ustarX, ustarY
201 #endif
202
203 #ifdef ALLOW_AUTODIFF_TAMC
204 act1 = bi - myBxLo(myThid)
205 max1 = myBxHi(myThid) - myBxLo(myThid) + 1
206 act2 = bj - myByLo(myThid)
207 max2 = myByHi(myThid) - myByLo(myThid) + 1
208 act3 = myThid - 1
209 max3 = nTx*nTy
210 act4 = ikey_dynamics - 1
211 ikppkey = (act1 + 1) + act2*max1
212 & + act3*max1*max2
213 & + act4*max1*max2*max3
214 #endif /* ALLOW_AUTODIFF_TAMC */
215 CEOP
216
217 c Check to see if new vertical mixing coefficient should be computed now?
218 IF ( DIFFERENT_MULTIPLE(kpp_freq,myTime,deltaTClock)
219 1 .OR. myTime .EQ. startTime ) THEN
220
221 c-----------------------------------------------------------------------
222 c prepare input arrays for subroutine "kppmix" to compute
223 c viscosity and diffusivity and ghat.
224 c All input arrays need to be in m-k-s units.
225 c
226 c note: for the computation of the bulk richardson number in the
227 c "bldepth" subroutine, gradients of velocity and buoyancy are
228 c required at every depth. in the case of very fine vertical grids
229 c (thickness of top layer < 2m), the surface reference depth must
230 c be set to zref=epsilon/2*zgrid(k), and the reference value
231 c of velocity and buoyancy must be computed as vertical average
232 c between the surface and 2*zref. in the case of coarse vertical
233 c grids zref is zgrid(1)/2., and the surface reference value is
234 c simply the surface value at zgrid(1).
235 c-----------------------------------------------------------------------
236
237 c------------------------------------------------------------------------
238 c density related quantities
239 c --------------------------
240 c
241 c work2 - density of surface layer (kg/m^3)
242 c dbloc - local buoyancy gradient at Nr interfaces
243 c g/rho{k+1,k+1} * [ drho{k,k+1}-drho{k+1,k+1} ] (m/s^2)
244 c dbsfc (stored in Ritop to conserve stack memory)
245 c - buoyancy difference with respect to the surface
246 c g * [ drho{1,k}/rho{1,k} - drho{k,k}/rho{k,k} ] (m/s^2)
247 c ttalpha (stored in vddiff(:,:,:,1) to conserve stack memory)
248 c - thermal expansion coefficient without 1/rho factor
249 c d(rho{k,k})/d(T(k)) (kg/m^3/C)
250 c ssbeta (stored in vddiff(:,:,:,2) to conserve stack memory)
251 c - salt expansion coefficient without 1/rho factor
252 c d(rho{k,k})/d(S(k)) (kg/m^3/PSU)
253 c------------------------------------------------------------------------
254
255 CALL TIMER_START('STATEKPP [KPP_CALC]', myThid)
256 CALL STATEKPP(
257 I ikppkey, bi, bj, myThid
258 O , work2, dbloc, Ritop
259 O , TTALPHA, SSBETA
260 & )
261 CALL TIMER_STOP ('STATEKPP [KPP_CALC]', myThid)
262
263 DO k = 1, Nr
264 DO j = jbot, jtop
265 DO i = ibot, itop
266 ghat(i,j,k) = dbloc(i,j,k)
267 ENDDO
268 ENDDO
269 ENDDO
270
271 #ifdef KPP_SMOOTH_DBLOC
272 c horizontally smooth dbloc with a 121 filter
273 c smooth dbloc stored in ghat to save space
274 c dbloc(k) is buoyancy gradientnote between k and k+1
275 c levels therefore k+1 mask must be used
276
277 DO k = 1, Nr-1
278 CALL KPP_SMOOTH_HORIZ (
279 I k+1, bi, bj,
280 U ghat (ibot,jbot,k) )
281 ENDDO
282
283 #endif /* KPP_SMOOTH_DBLOC */
284
285 #ifdef KPP_SMOOTH_DENS
286 c horizontally smooth density related quantities with 121 filters
287 CALL KPP_SMOOTH_HORIZ (
288 I 1, bi, bj,
289 U work2 )
290 DO k = 1, Nr
291 CALL KPP_SMOOTH_HORIZ (
292 I k+1, bi, bj,
293 U dbloc (ibot,jbot,k) )
294 CALL KPP_SMOOTH_HORIZ (
295 I k, bi, bj,
296 U Ritop (ibot,jbot,k) )
297 CALL KPP_SMOOTH_HORIZ (
298 I k, bi, bj,
299 U TTALPHA(ibot,jbot,k) )
300 CALL KPP_SMOOTH_HORIZ (
301 I k, bi, bj,
302 U SSBETA(ibot,jbot,k) )
303 ENDDO
304 #endif /* KPP_SMOOTH_DENS */
305
306 DO k = 1, Nr
307 DO j = jbot, jtop
308 DO i = ibot, itop
309
310 c zero out dbloc over land points (so that the convective
311 c part of the interior mixing can be diagnosed)
312 dbloc(i,j,k) = dbloc(i,j,k) * maskC(i,j,k,bi,bj)
313 ghat(i,j,k) = ghat(i,j,k) * maskC(i,j,k,bi,bj)
314 Ritop(i,j,k) = Ritop(i,j,k) * maskC(i,j,k,bi,bj)
315 if(k.eq.nzmax(i,j,bi,bj)) then
316 dbloc(i,j,k) = p0
317 ghat(i,j,k) = p0
318 Ritop(i,j,k) = p0
319 endif
320
321 c numerator of bulk richardson number on grid levels
322 c note: land and ocean bottom values need to be set to zero
323 c so that the subroutine "bldepth" works correctly
324 Ritop(i,j,k) = (zgrid(1)-zgrid(k)) * Ritop(i,j,k)
325
326 END DO
327 END DO
328 END DO
329
330 cph(
331 cph this avoids a single or double recomp./call of statekpp
332 CADJ store work2 = comlev1_kpp, key = ikppkey
333 #ifdef KPP_AUTODIFF_EXCESSIVE_STORE
334 CADJ store dbloc, Ritop, ghat = comlev1_kpp, key = ikppkey
335 CADJ store vddiff = comlev1_kpp, key = ikppkey
336 CADJ store TTALPHA, SSBETA = comlev1_kpp, key = ikppkey
337 #endif
338 cph)
339
340 c------------------------------------------------------------------------
341 c friction velocity, turbulent and radiative surface buoyancy forcing
342 c -------------------------------------------------------------------
343 c taux / rho = surfaceForcingU (N/m^2)
344 c tauy / rho = surfaceForcingV (N/m^2)
345 c ustar = sqrt( sqrt( taux^2 + tauy^2 ) / rho ) (m/s)
346 c bo = - g * ( alpha*surfaceForcingT +
347 c beta *surfaceForcingS ) / rho (m^2/s^3)
348 c bosol = - g * alpha * Qsw * drF(1) / rho (m^2/s^3)
349 c------------------------------------------------------------------------
350
351 c initialize arrays to zero
352 DO j = jbot, jtop
353 DO i = ibot, itop
354 ustar(i,j) = p0
355 bo (I,J) = p0
356 bosol(I,J) = p0
357 END DO
358 END DO
359
360 DO j = jmin, jmax
361 jp1 = j + 1
362 DO i = imin, imax
363 ip1 = i+1
364 work3(i,j) =
365 & (surfaceForcingU(i,j,bi,bj) + surfaceForcingU(ip1,j,bi,bj)) *
366 & (surfaceForcingU(i,j,bi,bj) + surfaceForcingU(ip1,j,bi,bj)) +
367 & (surfaceForcingV(i,j,bi,bj) + surfaceForcingV(i,jp1,bi,bj)) *
368 & (surfaceForcingV(i,j,bi,bj) + surfaceForcingV(i,jp1,bi,bj))
369 END DO
370 END DO
371 cph(
372 CADJ store work3 = comlev1_kpp, key = ikppkey
373 cph)
374 DO j = jmin, jmax
375 jp1 = j + 1
376 DO i = imin, imax
377 ip1 = i+1
378
379 if ( work3(i,j) .lt. (phepsi*phepsi*drF(1)*drF(1)) ) then
380 ustar(i,j) = SQRT( phepsi * p5 * drF(1) )
381 else
382 tempVar2 = SQRT( work3(i,j) ) * p5
383 ustar(i,j) = SQRT( tempVar2 )
384 endif
385
386 bo(I,J) = - gravity *
387 & ( TTALPHA(I,J,1) * (surfaceForcingT(i,j,bi,bj)+
388 & surfaceForcingTice(i,j,bi,bj)) +
389 & SSBETA(I,J,1) * surfaceForcingS(i,j,bi,bj) )
390 & / work2(I,J)
391
392 bosol(I,J) = gravity * TTALPHA(I,J,1) * Qsw(i,j,bi,bj) *
393 & recip_Cp*recip_rhoConst
394 & / work2(I,J)
395
396 END DO
397 END DO
398
399 cph(
400 CADJ store ustar = comlev1_kpp, key = ikppkey
401 cph)
402
403 c------------------------------------------------------------------------
404 c velocity shear
405 c --------------
406 c Get velocity shear squared, averaged from "u,v-grid"
407 c onto "t-grid" (in (m/s)**2):
408 c dVsq(k)=(Uref-U(k))**2+(Vref-V(k))**2 at grid levels
409 c shsq(k)=(U(k)-U(k+1))**2+(V(k)-V(k+1))**2 at interfaces
410 c------------------------------------------------------------------------
411
412 c initialize arrays to zero
413 DO k = 1, Nr
414 DO j = jbot, jtop
415 DO i = ibot, itop
416 shsq(i,j,k) = p0
417 dVsq(i,j,k) = p0
418 END DO
419 END DO
420 END DO
421
422 c dVsq computation
423
424 #ifdef KPP_ESTIMATE_UREF
425
426 c Get rid of vertical resolution dependence of dVsq term by
427 c estimating a surface velocity that is independent of first level
428 c thickness in the model. First determine mixed layer depth hMix.
429 c Second zRef = espilon * hMix. Third determine roughness length
430 c scale z0. Third estimate reference velocity.
431
432 DO j = jmin, jmax
433 jp1 = j + 1
434 DO i = imin, imax
435 ip1 = i + 1
436
437 c Determine mixed layer depth hMix as the shallowest depth at which
438 c dB/dz exceeds 5.2e-5 s^-2.
439 work1(i,j) = nzmax(i,j,bi,bj)
440 DO k = 1, Nr
441 IF ( k .LT. nzmax(i,j,bi,bj) .AND.
442 & dbloc(i,j,k) / drC(k+1) .GT. dB_dz )
443 & work1(i,j) = k
444 END DO
445
446 c Linearly interpolate to find hMix.
447 k = work1(i,j)
448 IF ( k .EQ. 0 .OR. nzmax(i,j,bi,bj) .EQ. 1 ) THEN
449 zRef(i,j) = p0
450 ELSEIF ( k .EQ. 1) THEN
451 dBdz2 = dbloc(i,j,1) / drC(2)
452 zRef(i,j) = drF(1) * dB_dz / dBdz2
453 ELSEIF ( k .LT. nzmax(i,j,bi,bj) ) THEN
454 dBdz1 = dbloc(i,j,k-1) / drC(k )
455 dBdz2 = dbloc(i,j,k ) / drC(k+1)
456 zRef(i,j) = rF(k) + drF(k) * (dB_dz - dBdz1) /
457 & MAX ( phepsi, dBdz2 - dBdz1 )
458 ELSE
459 zRef(i,j) = rF(k+1)
460 ENDIF
461
462 c Compute roughness length scale z0 subject to 0 < z0
463 tempVar1 = p5 * (
464 & (uVel(i, j, 1,bi,bj)-uVel(i, j, 2,bi,bj)) *
465 & (uVel(i, j, 1,bi,bj)-uVel(i, j, 2,bi,bj)) +
466 & (uVel(ip1,j, 1,bi,bj)-uVel(ip1,j, 2,bi,bj)) *
467 & (uVel(ip1,j, 1,bi,bj)-uVel(ip1,j, 2,bi,bj)) +
468 & (vVel(i, j, 1,bi,bj)-vVel(i, j, 2,bi,bj)) *
469 & (vVel(i, j, 1,bi,bj)-vVel(i, j, 2,bi,bj)) +
470 & (vVel(i, jp1,1,bi,bj)-vVel(i, jp1,2,bi,bj)) *
471 & (vVel(i, jp1,1,bi,bj)-vVel(i, jp1,2,bi,bj)) )
472 if ( tempVar1 .lt. (epsln*epsln) ) then
473 tempVar2 = epsln
474 else
475 tempVar2 = SQRT ( tempVar1 )
476 endif
477 z0(i,j) = rF(2) *
478 & ( rF(3) * LOG ( rF(3) / rF(2) ) /
479 & ( rF(3) - rF(2) ) -
480 & tempVar2 * vonK /
481 & MAX ( ustar(i,j), phepsi ) )
482 z0(i,j) = MAX ( z0(i,j), phepsi )
483
484 c zRef is set to 0.1 * hMix subject to z0 <= zRef <= drF(1)
485 zRef(i,j) = MAX ( epsilon * zRef(i,j), z0(i,j) )
486 zRef(i,j) = MIN ( zRef(i,j), drF(1) )
487
488 c Estimate reference velocity uRef and vRef.
489 uRef(i,j) = p5 *
490 & ( uVel(i,j,1,bi,bj) + uVel(ip1,j,1,bi,bj) )
491 vRef(i,j) = p5 *
492 & ( vVel(i,j,1,bi,bj) + vVel(i,jp1,1,bi,bj) )
493 IF ( zRef(i,j) .LT. drF(1) ) THEN
494 ustarX = ( surfaceForcingU(i, j,bi,bj) +
495 & surfaceForcingU(ip1,j,bi,bj) ) * p5
496 & *recip_drF(1)
497 ustarY = ( surfaceForcingV(i,j, bi,bj) +
498 & surfaceForcingV(i,jp1,bi,bj) ) * p5
499 & *recip_drF(1)
500 tempVar1 = ustarX * ustarX + ustarY * ustarY
501 if ( tempVar1 .lt. (epsln*epsln) ) then
502 tempVar2 = epsln
503 else
504 tempVar2 = SQRT ( tempVar1 )
505 endif
506 tempVar2 = ustar(i,j) *
507 & ( LOG ( zRef(i,j) / rF(2) ) +
508 & z0(i,j) / zRef(i,j) - z0(i,j) / rF(2) ) /
509 & vonK / tempVar2
510 uRef(i,j) = uRef(i,j) + ustarX * tempVar2
511 vRef(i,j) = vRef(i,j) + ustarY * tempVar2
512 ENDIF
513
514 END DO
515 END DO
516
517 DO k = 1, Nr
518 DO j = jmin, jmax
519 jm1 = j - 1
520 jp1 = j + 1
521 DO i = imin, imax
522 im1 = i - 1
523 ip1 = i + 1
524 dVsq(i,j,k) = p5 * (
525 $ (uRef(i,j) - uVel(i, j, k,bi,bj)) *
526 $ (uRef(i,j) - uVel(i, j, k,bi,bj)) +
527 $ (uRef(i,j) - uVel(ip1,j, k,bi,bj)) *
528 $ (uRef(i,j) - uVel(ip1,j, k,bi,bj)) +
529 $ (vRef(i,j) - vVel(i, j, k,bi,bj)) *
530 $ (vRef(i,j) - vVel(i, j, k,bi,bj)) +
531 $ (vRef(i,j) - vVel(i, jp1,k,bi,bj)) *
532 $ (vRef(i,j) - vVel(i, jp1,k,bi,bj)) )
533 #ifdef KPP_SMOOTH_DVSQ
534 dVsq(i,j,k) = p5 * dVsq(i,j,k) + p125 * (
535 $ (uRef(i,j) - uVel(i, jm1,k,bi,bj)) *
536 $ (uRef(i,j) - uVel(i, jm1,k,bi,bj)) +
537 $ (uRef(i,j) - uVel(ip1,jm1,k,bi,bj)) *
538 $ (uRef(i,j) - uVel(ip1,jm1,k,bi,bj)) +
539 $ (uRef(i,j) - uVel(i, jp1,k,bi,bj)) *
540 $ (uRef(i,j) - uVel(i, jp1,k,bi,bj)) +
541 $ (uRef(i,j) - uVel(ip1,jp1,k,bi,bj)) *
542 $ (uRef(i,j) - uVel(ip1,jp1,k,bi,bj)) +
543 $ (vRef(i,j) - vVel(im1,j, k,bi,bj)) *
544 $ (vRef(i,j) - vVel(im1,j, k,bi,bj)) +
545 $ (vRef(i,j) - vVel(im1,jp1,k,bi,bj)) *
546 $ (vRef(i,j) - vVel(im1,jp1,k,bi,bj)) +
547 $ (vRef(i,j) - vVel(ip1,j, k,bi,bj)) *
548 $ (vRef(i,j) - vVel(ip1,j, k,bi,bj)) +
549 $ (vRef(i,j) - vVel(ip1,jp1,k,bi,bj)) *
550 $ (vRef(i,j) - vVel(ip1,jp1,k,bi,bj)) )
551 #endif /* KPP_SMOOTH_DVSQ */
552 END DO
553 END DO
554 END DO
555
556 #else /* KPP_ESTIMATE_UREF */
557
558 DO k = 1, Nr
559 DO j = jmin, jmax
560 jm1 = j - 1
561 jp1 = j + 1
562 DO i = imin, imax
563 im1 = i - 1
564 ip1 = i + 1
565 dVsq(i,j,k) = p5 * (
566 $ (uVel(i, j, 1,bi,bj)-uVel(i, j, k,bi,bj)) *
567 $ (uVel(i, j, 1,bi,bj)-uVel(i, j, k,bi,bj)) +
568 $ (uVel(ip1,j, 1,bi,bj)-uVel(ip1,j, k,bi,bj)) *
569 $ (uVel(ip1,j, 1,bi,bj)-uVel(ip1,j, k,bi,bj)) +
570 $ (vVel(i, j, 1,bi,bj)-vVel(i, j, k,bi,bj)) *
571 $ (vVel(i, j, 1,bi,bj)-vVel(i, j, k,bi,bj)) +
572 $ (vVel(i, jp1,1,bi,bj)-vVel(i, jp1,k,bi,bj)) *
573 $ (vVel(i, jp1,1,bi,bj)-vVel(i, jp1,k,bi,bj)) )
574 #ifdef KPP_SMOOTH_DVSQ
575 dVsq(i,j,k) = p5 * dVsq(i,j,k) + p125 * (
576 $ (uVel(i, jm1,1,bi,bj)-uVel(i, jm1,k,bi,bj)) *
577 $ (uVel(i, jm1,1,bi,bj)-uVel(i, jm1,k,bi,bj)) +
578 $ (uVel(ip1,jm1,1,bi,bj)-uVel(ip1,jm1,k,bi,bj)) *
579 $ (uVel(ip1,jm1,1,bi,bj)-uVel(ip1,jm1,k,bi,bj)) +
580 $ (uVel(i, jp1,1,bi,bj)-uVel(i, jp1,k,bi,bj)) *
581 $ (uVel(i, jp1,1,bi,bj)-uVel(i, jp1,k,bi,bj)) +
582 $ (uVel(ip1,jp1,1,bi,bj)-uVel(ip1,jp1,k,bi,bj)) *
583 $ (uVel(ip1,jp1,1,bi,bj)-uVel(ip1,jp1,k,bi,bj)) +
584 $ (vVel(im1,j, 1,bi,bj)-vVel(im1,j, k,bi,bj)) *
585 $ (vVel(im1,j, 1,bi,bj)-vVel(im1,j, k,bi,bj)) +
586 $ (vVel(im1,jp1,1,bi,bj)-vVel(im1,jp1,k,bi,bj)) *
587 $ (vVel(im1,jp1,1,bi,bj)-vVel(im1,jp1,k,bi,bj)) +
588 $ (vVel(ip1,j, 1,bi,bj)-vVel(ip1,j, k,bi,bj)) *
589 $ (vVel(ip1,j, 1,bi,bj)-vVel(ip1,j, k,bi,bj)) +
590 $ (vVel(ip1,jp1,1,bi,bj)-vVel(ip1,jp1,k,bi,bj)) *
591 $ (vVel(ip1,jp1,1,bi,bj)-vVel(ip1,jp1,k,bi,bj)) )
592 #endif /* KPP_SMOOTH_DVSQ */
593 END DO
594 END DO
595 END DO
596
597 #endif /* KPP_ESTIMATE_UREF */
598
599 c shsq computation
600 DO k = 1, Nrm1
601 kp1 = k + 1
602 DO j = jmin, jmax
603 jm1 = j - 1
604 jp1 = j + 1
605 DO i = imin, imax
606 im1 = i - 1
607 ip1 = i + 1
608 shsq(i,j,k) = p5 * (
609 $ (uVel(i, j, k,bi,bj)-uVel(i, j, kp1,bi,bj)) *
610 $ (uVel(i, j, k,bi,bj)-uVel(i, j, kp1,bi,bj)) +
611 $ (uVel(ip1,j, k,bi,bj)-uVel(ip1,j, kp1,bi,bj)) *
612 $ (uVel(ip1,j, k,bi,bj)-uVel(ip1,j, kp1,bi,bj)) +
613 $ (vVel(i, j, k,bi,bj)-vVel(i, j, kp1,bi,bj)) *
614 $ (vVel(i, j, k,bi,bj)-vVel(i, j, kp1,bi,bj)) +
615 $ (vVel(i, jp1,k,bi,bj)-vVel(i, jp1,kp1,bi,bj)) *
616 $ (vVel(i, jp1,k,bi,bj)-vVel(i, jp1,kp1,bi,bj)) )
617 #ifdef KPP_SMOOTH_SHSQ
618 shsq(i,j,k) = p5 * shsq(i,j,k) + p125 * (
619 $ (uVel(i, jm1,k,bi,bj)-uVel(i, jm1,kp1,bi,bj)) *
620 $ (uVel(i, jm1,k,bi,bj)-uVel(i, jm1,kp1,bi,bj)) +
621 $ (uVel(ip1,jm1,k,bi,bj)-uVel(ip1,jm1,kp1,bi,bj)) *
622 $ (uVel(ip1,jm1,k,bi,bj)-uVel(ip1,jm1,kp1,bi,bj)) +
623 $ (uVel(i, jp1,k,bi,bj)-uVel(i, jp1,kp1,bi,bj)) *
624 $ (uVel(i, jp1,k,bi,bj)-uVel(i, jp1,kp1,bi,bj)) +
625 $ (uVel(ip1,jp1,k,bi,bj)-uVel(ip1,jp1,kp1,bi,bj)) *
626 $ (uVel(ip1,jp1,k,bi,bj)-uVel(ip1,jp1,kp1,bi,bj)) +
627 $ (vVel(im1,j, k,bi,bj)-vVel(im1,j, kp1,bi,bj)) *
628 $ (vVel(im1,j, k,bi,bj)-vVel(im1,j, kp1,bi,bj)) +
629 $ (vVel(im1,jp1,k,bi,bj)-vVel(im1,jp1,kp1,bi,bj)) *
630 $ (vVel(im1,jp1,k,bi,bj)-vVel(im1,jp1,kp1,bi,bj)) +
631 $ (vVel(ip1,j, k,bi,bj)-vVel(ip1,j, kp1,bi,bj)) *
632 $ (vVel(ip1,j, k,bi,bj)-vVel(ip1,j, kp1,bi,bj)) +
633 $ (vVel(ip1,jp1,k,bi,bj)-vVel(ip1,jp1,kp1,bi,bj)) *
634 $ (vVel(ip1,jp1,k,bi,bj)-vVel(ip1,jp1,kp1,bi,bj)) )
635 #endif
636 END DO
637 END DO
638 END DO
639
640 cph(
641 #ifdef KPP_AUTODIFF_EXCESSIVE_STORE
642 CADJ store dvsq, shsq = comlev1_kpp, key = ikppkey
643 #endif
644 cph)
645
646 c-----------------------------------------------------------------------
647 c solve for viscosity, diffusivity, ghat, and hbl on "t-grid"
648 c-----------------------------------------------------------------------
649
650 DO j = jbot, jtop
651 DO i = ibot, itop
652 work1(i,j) = nzmax(i,j,bi,bj)
653 work2(i,j) = Fcori(i,j,bi,bj)
654 END DO
655 END DO
656 CALL TIMER_START('KPPMIX [KPP_CALC]', myThid)
657 CALL KPPMIX (
658 I mytime, mythid
659 I , work1, shsq, dVsq, ustar
660 I , bo, bosol, dbloc, Ritop, work2
661 I , ikppkey
662 O , vddiff
663 U , ghat
664 O , hbl )
665
666 CALL TIMER_STOP ('KPPMIX [KPP_CALC]', myThid)
667
668 c-----------------------------------------------------------------------
669 c zero out land values and transfer to global variables
670 c-----------------------------------------------------------------------
671
672 DO j = jmin, jmax
673 DO i = imin, imax
674 DO k = 1, Nr
675 KPPviscAz(i,j,k,bi,bj) = vddiff(i,j,k-1,1) * maskC(i,j,k,bi,bj)
676 KPPdiffKzS(i,j,k,bi,bj)= vddiff(i,j,k-1,2) * maskC(i,j,k,bi,bj)
677 KPPdiffKzT(i,j,k,bi,bj)= vddiff(i,j,k-1,3) * maskC(i,j,k,bi,bj)
678 KPPghat(i,j,k,bi,bj) = ghat(i,j,k) * maskC(i,j,k,bi,bj)
679 END DO
680 KPPhbl(i,j,bi,bj) = hbl(i,j) * maskC(i,j,1,bi,bj)
681 END DO
682 END DO
683 #ifdef FRUGAL_KPP
684 _EXCH_XYZ_R8(KPPviscAz , myThid )
685 _EXCH_XYZ_R8(KPPdiffKzS , myThid )
686 _EXCH_XYZ_R8(KPPdiffKzT , myThid )
687 _EXCH_XYZ_R8(KPPghat , myThid )
688 _EXCH_XY_R8 (KPPhbl , myThid )
689 #endif
690
691 #ifdef KPP_SMOOTH_VISC
692 c horizontal smoothing of vertical viscosity
693 DO k = 1, Nr
694 CALL SMOOTH_HORIZ (
695 I k, bi, bj,
696 U KPPviscAz(1-OLx,1-OLy,k,bi,bj) )
697 END DO
698 _EXCH_XYZ_R8(KPPviscAz , myThid )
699 #endif /* KPP_SMOOTH_VISC */
700
701 #ifdef KPP_SMOOTH_DIFF
702 c horizontal smoothing of vertical diffusivity
703 DO k = 1, Nr
704 CALL SMOOTH_HORIZ (
705 I k, bi, bj,
706 U KPPdiffKzS(1-OLx,1-OLy,k,bi,bj) )
707 CALL SMOOTH_HORIZ (
708 I k, bi, bj,
709 U KPPdiffKzT(1-OLx,1-OLy,k,bi,bj) )
710 END DO
711 _EXCH_XYZ_R8(KPPdiffKzS , myThid )
712 _EXCH_XYZ_R8(KPPdiffKzT , myThid )
713 #endif /* KPP_SMOOTH_DIFF */
714
715 cph(
716 cph crucial: this avoids full recomp./call of kppmix
717 CADJ store KPPhbl = comlev1_kpp, key = ikppkey
718 cph)
719
720 C Compute fraction of solar short-wave flux penetrating to
721 C the bottom of the mixing layer.
722 DO j=1-OLy,sNy+OLy
723 DO i=1-OLx,sNx+OLx
724 worka(i,j) = KPPhbl(i,j,bi,bj)
725 ENDDO
726 ENDDO
727 CALL SWFRAC(
728 I (sNx+2*OLx)*(sNy+2*OLy), minusone,
729 I mytime, mythid,
730 U worka )
731 DO j=1-OLy,sNy+OLy
732 DO i=1-OLx,sNx+OLx
733 KPPfrac(i,j,bi,bj) = worka(i,j)
734 ENDDO
735 ENDDO
736
737 ENDIF
738
739 #endif /* ALLOW_KPP */
740
741 RETURN
742 END
743
744 subroutine KPP_CALC_DUMMY(
745 I bi, bj, myTime, myThid )
746 C /==========================================================\
747 C | SUBROUTINE KPP_CALC_DUMMY |
748 C | o Compute all KPP fields defined in KPP.h |
749 C | o Dummy routine for TAMC
750 C |==========================================================|
751 C | This subroutine serves as an interface between MITGCMUV |
752 C | code and NCOM 1-D routines in kpp_routines.F |
753 C \==========================================================/
754 IMPLICIT NONE
755
756 #include "SIZE.h"
757 #include "EEPARAMS.h"
758 #include "PARAMS.h"
759 #include "KPP.h"
760 #include "KPP_PARAMS.h"
761 #include "GRID.h"
762
763 c Routine arguments
764 c bi, bj - array indices on which to apply calculations
765 c myTime - Current time in simulation
766
767 INTEGER bi, bj
768 INTEGER myThid
769 _RL myTime
770
771 #ifdef ALLOW_KPP
772
773 c Local constants
774 integer i, j, k
775
776 DO j=1-OLy,sNy+OLy
777 DO i=1-OLx,sNx+OLx
778 KPPhbl (i,j,bi,bj) = 1.0
779 KPPfrac(i,j,bi,bj) = 0.0
780 DO k = 1,Nr
781 KPPghat (i,j,k,bi,bj) = 0.0
782 KPPviscAz (i,j,k,bi,bj) = viscAr
783 KPPdiffKzT(i,j,k,bi,bj) = diffKrNrT(k)
784 KPPdiffKzS(i,j,k,bi,bj) = diffKrNrS(k)
785 ENDDO
786 ENDDO
787 ENDDO
788
789 #endif
790 RETURN
791 END

  ViewVC Help
Powered by ViewVC 1.1.22