/[MITgcm]/MITgcm/pkg/thsice/thsice_solve4temp.F
ViewVC logotype

Contents of /MITgcm/pkg/thsice/thsice_solve4temp.F

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


Revision 1.9 - (show annotations) (download)
Tue May 30 22:48:59 2006 UTC (17 years, 11 months ago) by mlosch
Branch: MAIN
CVS Tags: checkpoint58f_post
Changes since 1.8: +32 -12 lines
o couple pkg/thsice and pkg/exf (as a preparation for coupling pkg/thsice
  to pkg/seaice):
  - new routines thsice_map_exf and thsice_get_exf provide the interface
  - add an additional formal parameter to thsice_solve4temp

1 C $Header: /u/gcmpack/MITgcm/pkg/thsice/thsice_solve4temp.F,v 1.8 2006/05/25 18:03:25 jmc Exp $
2 C $Name: $
3
4 #include "THSICE_OPTIONS.h"
5
6 CBOP
7 C !ROUTINE: THSICE_SOLVE4TEMP
8 C !INTERFACE:
9 SUBROUTINE THSICE_SOLVE4TEMP(
10 I bi, bj, siLo, siHi, sjLo, sjHi,
11 I iMin,iMax, jMin,jMax, dBugFlag,
12 I useBulkForce, useEXF,
13 I iceMask, hIce, hSnow, tFrz, flxExSW,
14 U flxSW, tSrf, qIc1, qIc2,
15 O tIc1, tIc2, dTsrf,
16 O sHeat, flxCnB, flxAtm, evpAtm,
17 I myTime, myIter, myThid )
18 C !DESCRIPTION: \bv
19 C *==========================================================*
20 C | S/R THSICE_SOLVE4TEMP
21 C *==========================================================*
22 C | Solve (implicitly) for sea-ice and surface temperature
23 C *==========================================================*
24 C \ev
25
26 C ADAPTED FROM:
27 C LANL CICE.v2.0.2
28 C-----------------------------------------------------------------------
29 C.. thermodynamics (vertical physics) based on M. Winton 3-layer model
30 C.. See Bitz, C. M. and W. H. Lipscomb, 1999: "An energy-conserving
31 C.. thermodynamic sea ice model for climate study." J. Geophys.
32 C.. Res., 104, 15669 - 15677.
33 C.. Winton, M., 1999: "A reformulated three-layer sea ice model."
34 C.. Submitted to J. Atmos. Ocean. Technol.
35 C.. authors Elizabeth C. Hunke and William Lipscomb
36 C.. Fluid Dynamics Group, Los Alamos National Laboratory
37 C-----------------------------------------------------------------------
38 Cc****subroutine thermo_winton(n,fice,fsnow,dqice,dTsfc)
39 C.. Compute temperature change using Winton model with 2 ice layers, of
40 C.. which only the top layer has a variable heat capacity.
41
42 C !USES:
43 IMPLICIT NONE
44
45 C == Global variables ===
46 #include "EEPARAMS.h"
47 #include "THSICE_SIZE.h"
48 #include "THSICE_PARAMS.h"
49
50 C !INPUT/OUTPUT PARAMETERS:
51 C == Routine Arguments ==
52 C siLo,siHi :: size of input/output array: 1rst dim. lower,higher bounds
53 C sjLo,sjHi :: size of input/output array: 2nd dim. lower,higher bounds
54 C bi,bj :: tile indices
55 C iMin,iMax :: computation domain: 1rst index range
56 C jMin,jMax :: computation domain: 2nd index range
57 C dBugFlag :: allow to print debugging stuff (e.g. on 1 grid point).
58 C useBulkForce:: use surf. fluxes from bulk-forcing external S/R
59 C useEXF :: use surf. fluxes from exf external S/R
60 C--- Input:
61 C iceMask :: sea-ice fractional mask [0-1]
62 C hIce (hi) :: ice height [m]
63 C hSnow (hs) :: snow height [m]
64 C tFrz (Tf) :: sea-water freezing temperature [oC] (function of S)
65 C flxExSW (=) :: surf. heat flux (+=down) except SW, function of surf. temp Ts:
66 C 0: Flx(Ts=0) ; 1: Flx(Ts=Ts^n) ; 2: d.Flx/dTs(Ts=Ts^n)
67 C--- Modified (input&output):
68 C flxSW (netSW) :: net Short-Wave flux (+=down) [W/m2]: input= at surface
69 C (=) :: output= below sea-ice, into the ocean
70 C tSrf (Tsf) :: surface (ice or snow) temperature
71 C qIc1 (qicen) :: ice enthalpy (J/kg), 1rst level
72 C qIc2 (qicen) :: ice enthalpy (J/kg), 2nd level
73 C--- Output
74 C tIc1 (Tice) :: temperature of ice layer 1 [oC]
75 C tIc2 (Tice) :: temperature of ice layer 2 [oC]
76 C dTsrf (dTsf) :: surf. temp adjusment: Ts^n+1 - Ts^n
77 C sHeat(sHeating):: surf heating flux left to melt snow or ice (= Atmos-conduction)
78 C flxCnB (=) :: heat flux conducted through the ice to bottom surface
79 C flxAtm (=) :: net flux of energy from the atmosphere [W/m2] (+=down)
80 C without snow precip. (energy=0 for liquid water at 0.oC)
81 C evpAtm (=) :: evaporation to the atmosphere [kg/m2/s] (>0 if evaporate)
82 C--- Input:
83 C myTime :: current Time of simulation [s]
84 C myIter :: current Iteration number in simulation
85 C myThid :: my Thread Id number
86 INTEGER siLo, siHi, sjLo, sjHi
87 INTEGER bi,bj
88 INTEGER iMin, iMax
89 INTEGER jMin, jMax
90 LOGICAL dBugFlag
91 LOGICAL useBulkForce
92 LOGICAL useEXF
93 _RL iceMask(siLo:siHi,sjLo:sjHi)
94 _RL hIce (siLo:siHi,sjLo:sjHi)
95 _RL hSnow (siLo:siHi,sjLo:sjHi)
96 _RL tFrz (siLo:siHi,sjLo:sjHi)
97 _RL flxExSW(iMin:iMax,jMin:jMax,0:2)
98 _RL flxSW (siLo:siHi,sjLo:sjHi)
99 _RL tSrf (siLo:siHi,sjLo:sjHi)
100 _RL qIc1 (siLo:siHi,sjLo:sjHi)
101 _RL qIc2 (siLo:siHi,sjLo:sjHi)
102 _RL tIc1 (siLo:siHi,sjLo:sjHi)
103 _RL tIc2 (siLo:siHi,sjLo:sjHi)
104 c _RL dTsrf (siLo:siHi,sjLo:sjHi)
105 _RL dTsrf (iMin:iMax,jMin:jMax)
106 _RL sHeat (siLo:siHi,sjLo:sjHi)
107 _RL flxCnB (siLo:siHi,sjLo:sjHi)
108 _RL flxAtm (siLo:siHi,sjLo:sjHi)
109 _RL evpAtm (siLo:siHi,sjLo:sjHi)
110 _RL myTime
111 INTEGER myIter
112 INTEGER myThid
113 CEOP
114
115 #ifdef ALLOW_THSICE
116 C !LOCAL VARIABLES:
117 C--- local copy of input/output argument list variables (see description above)
118 c _RL flxExcSw(0:2)
119 _RL Tf
120 _RL hi
121 _RL hs
122 _RL netSW
123 _RL Tsf
124 _RL qicen(nlyr)
125 _RL Tice (nlyr)
126 c _RL sHeating
127 c _RL flxCnB
128 _RL dTsf
129 c _RL flxAtm
130 c _RL evpAtm
131
132 C == Local Variables ==
133 INTEGER i,j
134 INTEGER k, iterMax
135
136 _RL frsnow ! fractional snow cover
137 _RL fswpen ! SW penetrating beneath surface (W m-2)
138 _RL fswdn ! SW absorbed at surface (W m-2)
139 _RL fswint ! SW absorbed in ice (W m-2)
140 _RL fswocn ! SW passed through ice to ocean (W m-2)
141 _RL flxExceptSw ! net surface heat flux, except short-wave (W/m2)
142 C evap :: evaporation over snow/ice [kg/m2/s] (>0 if evaporate)
143 C dEvdT :: derivative of evap. with respect to Tsf [kg/m2/s/K]
144 _RL evap, dEvdT
145 _RL flx0 ! net surf heat flux, from Atmos. to sea-ice (W m-2)
146 _RL fct ! heat conducted to top surface
147 _RL df0dT ! deriv of flx0 wrt Tsf (W m-2 deg-1)
148 _RL k12, k32 ! thermal conductivity terms
149 _RL a10, b10 ! coefficients in quadratic eqn for T1
150 _RL a1, b1, c1 ! coefficients in quadratic eqn for T1
151 c _RL Tsf_start ! old value of Tsf
152 _RL dt ! timestep
153 INTEGER iceornot
154 LOGICAL useBlkFlx
155
156 C- define grid-point location where to print debugging values
157 #include "THSICE_DEBUG.h"
158
159 1010 FORMAT(A,I3,3F11.6)
160 1020 FORMAT(A,1P4E14.6)
161
162 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
163
164 useBlkFlx = useEXF .OR. useBulkForce
165
166 dt = thSIce_deltaT
167 DO j = jMin, jMax
168 DO i = iMin, iMax
169 IF ( iceMask(i,j).GT.0. _d 0) THEN
170 hi = hIce(i,j)
171 hs = hSnow(i,j)
172 Tf = tFrz(i,j)
173 netSW = flxSW(i,j)
174 Tsf = tSrf(i,j)
175 qicen(1)= qIc1(i,j)
176 qicen(2)= qIc2(i,j)
177 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
178 #ifdef ALLOW_DBUG_THSICE
179 IF ( dBug(i,j,bi,bj) ) WRITE(6,'(A,2I4,2I2)')
180 & 'ThSI_SOLVE4T: i,j=',i,j,bi,bj
181 #endif
182 IF ( hi.LT.himin ) THEN
183 C If hi < himin, melt the ice.
184 STOP 'THSICE_SOLVE4TEMP: should not enter if hi<himin'
185 ENDIF
186
187 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
188
189 C fractional snow cover
190 frsnow = 0. _d 0
191 IF (hs .GT. 0. _d 0) frsnow = 1. _d 0
192
193 C Compute SW flux absorbed at surface and penetrating to layer 1.
194 fswpen = netSW * (1. _d 0 - frsnow) * i0
195 fswocn = fswpen * exp(-ksolar*hi)
196 fswint = fswpen - fswocn
197
198 fswdn = netSW - fswpen
199
200 C Compute conductivity terms at layer interfaces.
201
202 k12 = 4. _d 0*kice*ksnow / (ksnow*hi + 4. _d 0*kice*hs)
203 k32 = 2. _d 0*kice / hi
204
205 C compute ice temperatures
206 a1 = cpice
207 b1 = qicen(1) + (cpwater-cpice )*Tmlt1 - Lfresh
208 c1 = Lfresh * Tmlt1
209 Tice(1) = 0.5 _d 0 *(-b1 - SQRT(b1*b1-4. _d 0*a1*c1))/a1
210 Tice(2) = (Lfresh-qicen(2)) / cpice
211
212 IF (Tice(1).GT.0. _d 0 .OR. Tice(2).GT.0. _d 0) THEN
213 WRITE (6,*) 'BBerr Tice(1) > 0 = ',Tice(1)
214 WRITE (6,*) 'BBerr Tice(2) > 0 = ',Tice(2)
215 ENDIF
216 #ifdef ALLOW_DBUG_THSICE
217 IF ( dBug(i,j,bi,bj) ) WRITE(6,1010)
218 & 'ThSI_SOLVE4T: k, Ts, Tice=',0,Tsf,Tice
219 #endif
220
221 C Compute coefficients used in quadratic formula.
222
223 a10 = rhoi*cpice *hi/(2. _d 0*dt) +
224 & k32 * (4. _d 0*dt*k32 + rhoi*cpice *hi)
225 & / (6. _d 0*dt*k32 + rhoi*cpice *hi)
226 b10 = -hi*
227 & (rhoi*cpice*Tice(1)+rhoi*Lfresh*Tmlt1/Tice(1))
228 & /(2. _d 0*dt)
229 & - k32 * (4. _d 0*dt*k32*Tf+rhoi*cpice *hi*Tice(2))
230 & / (6. _d 0*dt*k32 + rhoi*cpice *hi) - fswint
231 c1 = rhoi*Lfresh*hi*Tmlt1 / (2. _d 0*dt)
232
233 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
234 C Compute new surface and internal temperatures; iterate until
235 C Tsfc converges.
236
237 IF ( useBlkFlx ) THEN
238 iterMax = nitMaxTsf
239 ELSE
240 iterMax = 1
241 ENDIF
242 dTsf = Terrmax
243
244 C ----- begin iteration -----
245 DO k = 1,iterMax
246 IF ( ABS(dTsf).GE.Terrmax ) THEN
247
248 C Save temperatures at start of iteration.
249 c Tsf_start = Tsf
250
251 IF ( useBlkFlx ) THEN
252 C Compute top surface flux.
253 IF (hs.GT.3. _d -1) THEN
254 iceornot=2
255 ELSE
256 iceornot=1
257 ENDIF
258 IF ( useBulkForce ) THEN
259 CALL THSICE_GET_BULKF(
260 I iceornot, Tsf,
261 O flxExceptSw, df0dT, evap, dEvdT,
262 I i,j,bi,bj,myThid )
263 ELSEIF ( useEXF ) THEN
264 CALL THSICE_GET_EXF (
265 I iceornot, Tsf,
266 O flxExceptSw, df0dT, evap, dEvdT,
267 I i,j,bi,bj,myThid )
268 ENDIF
269 ELSE
270 flxExceptSw = flxExSW(i,j,1)
271 df0dT = flxExSW(i,j,2)
272 ENDIF
273 flx0 = fswdn + flxExceptSw
274 #ifdef ALLOW_DBUG_THSICE
275 IF ( dBug(i,j,bi,bj) ) WRITE(6,1020)
276 & 'ThSI_SOLVE4T: flx0,df0dT,k12,D=', flx0,df0dT,k12,k12-df0dT
277 #endif
278
279 C Compute new top layer and surface temperatures.
280 C If Tsfc is computed to be > 0 C, fix Tsfc = 0 and recompute T1
281 C with different coefficients.
282
283 a1 = a10 - k12*df0dT / (k12-df0dT)
284 b1 = b10 - k12*(flx0-df0dT*Tsf) / (k12-df0dT)
285 Tice(1) = -(b1 + SQRT(b1*b1-4. _d 0*a1*c1))/(2. _d 0*a1)
286 dTsf = (flx0 + k12*(Tice(1)-Tsf)) / (k12-df0dT)
287 Tsf = Tsf + dTsf
288 IF (Tsf .GT. 0. _d 0) THEN
289 #ifdef ALLOW_DBUG_THSICE
290 IF ( dBug(i,j,bi,bj) ) WRITE(6,1010)
291 & 'ThSI_SOLVE4T: k,ts,t1,dTs=', k,Tsf,Tice(1),dTsf
292 #endif
293 a1 = a10 + k12
294 b1 = b10 ! note b1 = b10 - k12*Tf0
295 Tice(1) = (-b1 - SQRT(b1*b1-4. _d 0*a1*c1))/(2. _d 0*a1)
296 Tsf = 0. _d 0
297 IF ( useBlkFlx ) THEN
298 IF (hs.GT.3. _d -1) THEN
299 iceornot=2
300 ELSE
301 iceornot=1
302 ENDIF
303 IF ( useBulkForce ) THEN
304 CALL THSICE_GET_BULKF(
305 I iceornot, Tsf,
306 O flxExceptSw, df0dT, evap, dEvdT,
307 I i,j,bi,bj,myThid )
308 ELSEIF ( useEXF ) THEN
309 CALL THSICE_GET_EXF (
310 I iceornot, Tsf,
311 O flxExceptSw, df0dT, evap, dEvdT,
312 I i,j,bi,bj,myThid )
313 ENDIF
314 dTsf = 0. _d 0
315 ELSE
316 flxExceptSw = flxExSW(i,j,0)
317 dTsf = 1000.
318 df0dT = 0.
319 ENDIF
320 flx0 = fswdn + flxExceptSw
321 ENDIF
322
323 C Check for convergence. If no convergence, then repeat.
324 C
325 C Convergence test: Make sure Tsfc has converged, within prescribed error.
326 C (Energy conservation is guaranteed within machine roundoff, even
327 C if Tsfc has not converged.)
328 C If no convergence, then repeat.
329
330 #ifdef ALLOW_DBUG_THSICE
331 IF ( dBug(i,j,bi,bj) ) WRITE(6,1010)
332 & 'ThSI_SOLVE4T: k,ts,t1,dTs=', k,Tsf,Tice(1),dTsf
333 #endif
334 IF ( useBlkFlx .AND. k.EQ.nitMaxTsf
335 & .AND. ABS(dTsf).GE.Terrmax ) THEN
336 WRITE (6,*) 'BB: thermw conv err ',i,j,bi,bj,dTsf
337 WRITE (6,*) 'BB: thermw conv err, iceheight ', hi
338 WRITE (6,*) 'BB: thermw conv err: Tsf, flx0', Tsf,flx0
339 IF (Tsf.LT.-70. _d 0) STOP
340 ENDIF
341
342 100 continue ! surface temperature iteration
343 ENDIF
344 ENDDO
345 150 continue
346 C ------ end iteration ------------
347
348 C Compute new bottom layer temperature.
349
350 Tice(2) = (2. _d 0*dt*k32*(Tice(1)+2. _d 0*Tf)
351 & + rhoi*cpice *hi*Tice(2))
352 & /(6. _d 0*dt*k32 + rhoi*cpice *hi)
353 #ifdef ALLOW_DBUG_THSICE
354 IF ( dBug(i,j,bi,bj) ) WRITE(6,1010)
355 & 'ThSI_SOLVE4T: k, Ts, Tice=',k,Tsf,Tice
356 #endif
357
358 C Compute final flux values at surfaces.
359
360 fct = k12*(Tsf-Tice(1))
361 flxCnB(i,j) = 4. _d 0*kice *(Tice(2)-Tf)/hi
362 flx0 = flx0 + df0dT*dTsf
363 IF ( useBlkFlx ) THEN
364 C-- needs to update also Evap (Tsf changes) since Latent heat has been updated
365 evpAtm(i,j) = evap + dEvdT*dTsf
366 ELSE
367 C- WARNING: Evap & +Evap*Lfresh are missing ! (but only affects Diagnostics)
368 evpAtm(i,j) = 0.
369 ENDIF
370 C- energy flux to Atmos: use net short-wave flux at surf. and
371 C use latent heat = Lvap (energy=0 for liq. water at 0.oC)
372 flxAtm(i,j) = netSW + flxExceptSw
373 & + df0dT*dTsf + evpAtm(i,j)*Lfresh
374 C- excess of energy @ surface (used for surface melting):
375 sHeat(i,j) = flx0 - fct
376
377 C- SW flux at sea-ice base left to the ocean
378 flxSW(i,j) = fswocn
379
380 #ifdef ALLOW_DBUG_THSICE
381 IF ( dBug(i,j,bi,bj) ) WRITE(6,1020)
382 & 'ThSI_SOLVE4T: flx0,fct,Dif,flxCnB=',
383 & flx0,fct,flx0-fct,flxCnB(i,j)
384 #endif
385
386 C Compute new enthalpy for each layer.
387
388 qicen(1) = -cpwater*Tmlt1 + cpice *(Tmlt1-Tice(1))
389 & + Lfresh*(1. _d 0-Tmlt1/Tice(1))
390 qicen(2) = -cpice *Tice(2) + Lfresh
391
392 C Make sure internal ice temperatures do not exceed Tmlt.
393 C (This should not happen for reasonable values of i0.)
394
395 IF (Tice(1) .GE. Tmlt1) THEN
396 WRITE (6,'(A,2I4,2I3,1P2E14.6)')
397 & 'BBerr - Bug: IceT(1) > Tmlt',i,j,bi,bj,Tice(1),Tmlt1
398 ENDIF
399 IF (Tice(2) .GE. 0. _d 0) THEN
400 WRITE (6,'(A,2I4,2I3,1P2E14.6)')
401 & 'BBerr - Bug: IceT(2) > 0',i,j,bi,bj,Tice(2)
402 ENDIF
403
404 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
405 C-- Update Sea-Ice state :
406 tSrf(i,j) = Tsf
407 tIc1(i,j) = Tice(1)
408 tic2(i,j) = Tice(2)
409 qIc1(i,j) = qicen(1)
410 qIc2(i,j) = qicen(2)
411 c dTsrf(i,j) = dTsf
412 IF ( .NOT.useBlkFlx ) dTsrf(i,j) = dTsf
413 c sHeat(i,j) = sHeating
414 c flxCnB(i,j)= flxCnB
415 c flxAtm(i,j)= flxAtm
416 c evpAtm(i,j)= evpAtm
417 #ifdef ALLOW_DBUG_THSICE
418 IF ( dBug(i,j,bi,bj) ) THEN
419 WRITE(6,1020) 'ThSI_SOLV_4T: Tsf, Tice(1,2), dTsurf=',
420 & Tsf, Tice, dTsf
421 WRITE(6,1020) 'ThSI_SOLV_4T: sHeat, flxCndBt, Qice =',
422 & sHeat(i,j), flxCnB(i,j), qicen
423 WRITE(6,1020) 'ThSI_SOLV_4T: flxA, evpA, fxSW_bf,af=',
424 & flxAtm(i,j), evpAtm(i,j), netSW, flxSW(i,j)
425 ENDIF
426 #endif
427 ELSE
428 IF ( .NOT.useBlkFlx ) dTsrf(i,j) = 0. _d 0
429 ENDIF
430 ENDDO
431 ENDDO
432 #endif /* ALLOW_THSICE */
433
434 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
435
436 RETURN
437 END

  ViewVC Help
Powered by ViewVC 1.1.22