/[MITgcm]/MITgcm/pkg/ebm/ebm_atmosphere.F
ViewVC logotype

Contents of /MITgcm/pkg/ebm/ebm_atmosphere.F

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


Revision 1.8 - (show annotations) (download)
Tue Aug 24 14:14:30 2010 UTC (13 years, 9 months ago) by jmc
Branch: MAIN
CVS Tags: checkpoint63a, checkpoint63, checkpoint62k, checkpoint62j, checkpoint62o, checkpoint62n, checkpoint62m, checkpoint62l, checkpoint62s, checkpoint62r, checkpoint62q, checkpoint62p, checkpoint62w, checkpoint62v, checkpoint62u, checkpoint62t, checkpoint62z, checkpoint62y, checkpoint62x
Changes since 1.7: +2 -2 lines
remove tabs

1 C $Header: /u/gcmpack/MITgcm/pkg/ebm/ebm_atmosphere.F,v 1.7 2009/08/06 13:52:52 jmc Exp $
2 C $Name: $
3
4 #include "EBM_OPTIONS.h"
5
6 SUBROUTINE EBM_ATMOSPHERE ( myTime, myiter, myThid )
7
8 C |==========================================================|
9 C | S/R CALCULATE FORCING FROM ENERGY AND MOISTURE |
10 C | BALANCE ATMOSPHERE |
11 C |==========================================================|
12 C References:
13 C * X. Wang, P. Stone and J. Marotzke, 1999:
14 C Global thermohaline circulation. Part I:
15 C Sensitivity to atmospheric moisture transport.
16 C J. Climate 12(1), 71-82
17 C * X. Wang, P. Stone and J. Marotzke, 1999:
18 C Global thermohaline circulation. Part II:
19 C Sensitivity with interactive transport.
20 C J. Climate 12(1), 83-91
21 C * M. Nakamura, P. Stone and J. Marotzke, 1994:
22 C Destabilization of the thermohaline circulation
23 C by atmospheric eddy transports.
24 C J. Climate 7(12), 1870-1882
25
26 IMPLICIT NONE
27
28 C === Global variables ===
29 #include "SIZE.h"
30 #include "EEPARAMS.h"
31 #include "PARAMS.h"
32 #include "FFIELDS.h"
33 #include "GRID.h"
34 #include "EBM.h"
35 #ifdef ALLOW_AUTODIFF_TAMC
36 # include "tamc.h"
37 # include "tamc_keys.h"
38 #endif
39
40 C === Routine arguments ===
41 C myThid - Instance number for this innvocation of CALC_FORCING
42 INTEGER myThid
43 INTEGER myIter
44 _RL myTime
45 CEndOfInterface
46
47 #ifdef ALLOW_EBM
48
49 C == Local variables ==
50 _RL ReCountX(1-OLy:sNy+OLy,nSy)
51 INTEGER bi, bj
52 INTEGER i, j
53 INTEGER no_so
54 INTEGER iebmkey
55 LOGICAL TOP_LAYER
56
57 C-- Top layer only
58 cph TOP_LAYER = k .EQ. 1
59
60 cph IF ( TOP_LAYER ) THEN
61
62 DO bj=myByLo(myThid),myByHi(myThid)
63 DO bi=myBxLo(myThid),myBxHi(myThid)
64
65 #ifdef ALLOW_AUTODIFF_TAMC
66 act1 = bi - myBxLo(myThid)
67 max1 = myBxHi(myThid) - myBxLo(myThid) + 1
68 act2 = bj - myByLo(myThid)
69 max2 = myByHi(myThid) - myByLo(myThid) + 1
70 act3 = myThid - 1
71 max3 = nTx*nTy
72 act4 = ikey_dynamics - 1
73 iebmkey = (act1 + 1) + act2*max1
74 & + act3*max1*max2
75 & + act4*max1*max2*max3
76 #endif /* ALLOW_AUTODIFF_TAMC */
77
78 DO j=1-oLy,sNy+oLy
79 DO i=1-oLx,sNx+oLx
80 S(i,j,bj) = 0.0
81 P2(i,j,bj) = 0.0
82 P4(i,j,bj) = 0.0
83 ENDDO
84 SW(j,bj) = 0.0
85 LW(j,bj) = 0.0
86 Hd(j,bj) = 0.0
87 Fw(j,bj) = 0.0
88 T(j,bj) = 0.0
89 ReCountX(j,bj) = 0.0
90 ENDDO
91
92 print *, 'SH', TmlS-t_mlt, TtS-t_mlt
93 print *, 'NH', TmlN-t_mlt, TtN-t_mlt
94
95 C-- account for ice (can absorb heat on an annual averaged basis)
96 C-- Greenland in Northern Hemisphere, Antarctica in Southern
97 DO j = 1,sNy
98 ReCountX(j,bj) = CountX(j,bj)
99 IF (yC(1,j,bi,bj) .LE. -62.0) THEN
100 ReCountX(j,bj) = 90.
101 ELSE IF (yC(1,j,bi,bj) .EQ. 74.0) THEN
102 ReCountX(j,bj) = CountX(j,bj) + 9.0
103 ELSE IF (yC(1,j,bi,bj) .EQ. 70.0) THEN
104 ReCountX(j,bj) = CountX(j,bj) + 8.0
105 ELSE IF (yC(1,j,bi,bj) .EQ. 66.0) THEN
106 ReCountX(j,bj) = CountX(j,bj) + 5.0
107 ELSE IF (yC(1,j,bi,bj) .EQ. 62.0) THEN
108 ReCountX(j,bj) = CountX(j,bj) + 1.0
109 ENDIF
110 ENDDO
111 #ifdef ALLOW_AUTODIFF_TAMC
112 CADJ STORE ReCountX(:,bj) = comlev1_bibj, key=iebmkey, byte=isbyte
113 #endif
114
115 c=====================================================
116 c Fit area-weighed averaged SST north/south of 34
117 c degree to second Legendre polynomial:
118 c=======================================================
119 T_var(1) = SIN(lat(2)*deg2rad) - SIN(lat(1)*deg2rad)
120 T_var(2) = SIN(lat(3)*deg2rad) - SIN(lat(2)*deg2rad)
121 T_var(3) = SIN(lat(2)*deg2rad)**3 - SIN(lat(1)*deg2rad)**3
122 T_var(4) = SIN(lat(3)*deg2rad)**3 - SIN(lat(2)*deg2rad)**3
123 #ifdef ALLOW_AUTODIFF_TAMC
124 CADJ STORE T_var(:) = comlev1_bibj, key=iebmkey, byte=isbyte
125 #endif
126
127 c----------------------------------------
128 c Southern hemisphere:
129 c----------------------------------------
130 T2(1) = 2.*(TtS - TmlS)*T_var(1)*T_var(2)/
131 & (T_var(3)*T_var(2) - T_var(4)*T_var(1))
132 T0(1) = TtS - 0.5*T2(1)*((T_var(3)/T_var(1)) - 1.)
133 c----------------------------------------
134 c Northern hemisphere
135 c----------------------------------------
136 T2(2) = 2.*(TtN - TmlN)*T_var(1)*T_var(2)/
137 & (T_var(3)*T_var(2) - T_var(4)*T_var(1))
138 T0(2) = TtN - 0.5*T2(2)*((T_var(3)/T_var(1)) - 1.)
139 c-----------------------------------------
140 c Temperature at 35 N/S
141 c-----------------------------------------
142 DO no_so = 1,2
143 T35(no_so)= T0(no_so) +
144 & T2(no_so)*0.5*
145 & ( 3.*SIN(lat(2)*deg2rad)**2 - 1. )
146 ENDDO
147 c-----------------------------------------
148 c Temperature gradient at 35 N/S
149 c-----------------------------------------
150 DO no_so = 1, 2
151 DTDy35(no_so) = 3.*T2(no_so)*
152 & SIN(lat(2)*deg2rad)/rSphere
153 ENDDO
154 c-----------------------------------------------------------
155 c Magnitude of the heat and moisture transport at 35 N/S
156 c-----------------------------------------------------------
157
158 #ifdef ALLOW_AUTODIFF_TAMC
159 CADJ STORE T35(:) = comlev1_bibj, key=iebmkey, byte=isbyte
160 CADJ STORE DTDy35(:) = comlev1_bibj, key=iebmkey, byte=isbyte
161 #endif
162
163 DO no_so = 1, 2
164 IF ( DTDy35(no_so).NE.0. .AND. T35(no_so).NE.0. ) THEN
165 gamma = -T35(no_so)*beta*Hw*Nw*Nw/
166 & (gravity*f0*DTDy35(no_so))
167 kappa = Hw/(1. _d 0 + gamma)
168 De = Hw/(0.48 _d 0 + 1.48 _d 0 *gamma)
169 C = 0.6 _d 0 *gravity*kappa*kappa*Nw/
170 & (Tw*f0*f0)
171 Cs = rho_air*cp*C*
172 & ( 1. _d 0 /(1. _d 0 /Hw + 1. _d 0 /De)
173 & -1. _d 0 /(1. _d 0 /Hw+1. _d 0 /De+1. _d 0 /dz) )
174 Cf = htil*2.97 _d 12*C/(T35(no_so)**3)*(
175 & 1. _d 0/(1. _d 0/De + (5420. _d 0*tau /(T35(no_so)**2)))
176 & -1. _d 0/(1. _d 0/De+5420. _d 0*tau/(T35(no_so)**2)
177 & +1. _d 0/dz))
178 Cl = Cf*lv
179 Hd35(no_so) = 2.*PI*rSphere*COS(lat(2)*deg2rad)
180 & *(Cs + Cl*exp(-5420./T35(no_so)))
181 & *(abs(DTDy35(no_so))**trans_eff)
182 Fw35(no_so) = 2.*PI*rSphere*COS(lat(2)*deg2rad)
183 & *(abs(DTDy35(no_so))**trans_eff)
184 & *Cf*exp(-5420./T35(no_so))
185 ELSE
186 Hd35(no_so) = 0.
187 Fw35(no_so) = 0.
188 ENDIF
189 ENDDO
190 c
191 Fw35(1) = 929944128.
192 Fw35(2) = 678148032.
193 c
194 #ifdef EBM_VERSION_1BASIN
195 c Fw35(2) = 0.7*Fw35(2)
196 #else
197 Hd35(2) = 1.6 _d 0*Hd35(2)
198 #endif
199 c======================================================
200 c Calculation of latitudinal profiles
201 c======================================================
202 c
203 DO j=1,sNy
204 DO i=1,sNx
205 C sin(lat)
206 S(i,j,bj) = sin(yC(i,j,bi,bj)*deg2rad)
207 C setup Legendre polynomials and derivatives
208 P2(i,j,bj) = 0.5*(3.*S(i,j,bj)**2 - 1.)
209 P4(i,j,bj) = 0.12 _d 0 *
210 & (35.*S(i,j,bj)**4 - 30.*S(i,j,bj)**2 + 3.)
211 ENDDO
212 ENDDO
213 #ifdef ALLOW_AUTODIFF_TAMC
214 CADJ STORE S(:,:,bj) = comlev1_bibj, key=iebmkey, byte=isbyte
215 CADJ STORE P2(:,:,bj) = comlev1_bibj, key=iebmkey, byte=isbyte
216 CADJ STORE P4(:,:,bj) = comlev1_bibj, key=iebmkey, byte=isbyte
217 #endif
218 c
219 DO j=1,sNy
220 DO i=1,sNx
221
222 IF (yC(i,j,bi,bj) .LT. 0.) THEN
223 no_so = 1
224 ELSE
225 no_so = 2
226 ENDIF
227 c net shortwave
228 SW(j,bj) = 0.25 _d 0 *Q0*(1. _d 0 + Q2*P2(i,j,bj))*
229 & (1. _d 0 - A0 - A2*P2(i,j,bj) - A4*P4(i,j,bj) )
230 c temperature
231 T(j,bj) = T0(no_so) + T2(no_so)*P2(i,j,bj)
232 c net longwave
233 LW(j,bj) = LW0 + LW1*(T(j,bj)-t_mlt)
234 c climate change run, the parameter to change is DLW
235 #ifdef EBM_CLIMATE_CHANGE
236 LW(j,bj) = LW(j,bj) -
237 & (myTime-startTime)*3.215 _d -8*DLW
238 c < - 6.0
239 c < *75.0*0.0474*
240 c < (-2.62*S(i,j,bj)**8 + 0.73*S(i,j,bj)**7 +
241 c < 4.82*S(i,j,bj)**6 -
242 c < 1.12*S(i,j,bj)**5 - 2.69*S(i,j,bj)**4 + 0.47*S(i,j,bj)**3 +
243 c < 0.51*S(i,j,bj)**2 - 0.05*S(i,j,bj)**1 + 0.17)
244 #endif
245 c fluxes at ocean/atmosphere interface
246 c Heat Flux = -Div(atmospheric heat transport) + SW - LW
247 #ifdef EBM_VERSION_1BASIN
248 Qnet(i,j,bi,bj) = -1.0 _d 0 *( SW(j,bj) - LW(j,bj) -
249 & Hd35(no_so)*(
250 & 0.000728 _d 4 - 0.00678 _d 4*S(i,j,bj) +
251 & 0.0955 _d 4*S(i,j,bj)**2 + 0.0769 _d 4*S(i,j,bj)**3 -
252 & 0.8508 _d 4*S(i,j,bj)**4 - 0.3581 _d 4*S(i,j,bj)**5 +
253 & 2.9240 _d 4*S(i,j,bj)**6 + 0.8311 _d 4*S(i,j,bj)**7 -
254 & 4.9548 _d 4*S(i,j,bj)**8 - 0.8808 _d 4*S(i,j,bj)**9 +
255 & 4.0644 _d 4*S(i,j,bj)**10 +0.3409 _d 4*S(i,j,bj)**11 -
256 & 1.2893 _d 4*S(i,j,bj)**12 )
257 & /(2.*PI*rSphere*rSphere*25.) )
258 c Qnet(i,j,bi,bj) = -1.0*( SW(j,bj) - LW(j,bj) -
259 c < 0.5*Hd35(no_so)*(3.054e1 - 3.763e1*S(i,j,bj) +
260 c < 1.892e2*S(i,j,bj)**2 + 3.041e2*S(i,j,bj)**3 -
261 c < 1.540e3*S(i,j,bj)**4 - 9.586e2*S(i,j,bj)**5 +
262 c < 2.939e3*S(i,j,bj)**6 + 1.219e3*S(i,j,bj)**7 -
263 c < 2.550e3*S(i,j,bj)**8 - 5.396e2*S(i,j,bj)**9 +
264 c < 8.119e2*S(i,j,bj)**10)
265 c < /(2*PI*rSphere*rSphere*22.3) )
266 #else
267 IF (ReCountX(j,bj) .GT. 0.) THEN
268 Qnet(i,j,bi,bj) = (-90. _d 0 /ReCountX(j,bj))*
269 & ( SW(j,bj) - LW(j,bj) -
270 & Hd35(no_so)*(3.054 _d 1 - 3.763 _d 1*S(i,j,bj) +
271 & 1.892 _d 2*S(i,j,bj)**2 + 3.041 _d 2*S(i,j,bj)**3 -
272 & 1.540 _d 3*S(i,j,bj)**4 - 9.586 _d 2*S(i,j,bj)**5 +
273 & 2.939 _d 3*S(i,j,bj)**6 + 1.219 _d 3*S(i,j,bj)**7 -
274 & 2.550 _d 3*S(i,j,bj)**8 - 5.396 _d 2*S(i,j,bj)**9 +
275 & 8.119 _d 2*S(i,j,bj)**10)
276 & /(2.*PI*rSphere*rSphere*22.3 _d 0) )
277 ELSE
278 Qnet(i,j,bi,bj) = 0.
279 ENDIF
280 #endif
281 c Freshwater Flux = Div(atmospheric moisture transport)
282 c--- conversion of E-P from kg/(s m^2) -> m/s -> psu/s: 1e-3*35/delZ(1)
283 #ifdef EBM_VERSION_1BASIN
284 EmPmR(i,j,bi,bj) = -1. _d -3*Fw35(no_so)
285 & *(-0.8454 _d 5*S(i,j,bj)**14 + 0.5367 _d 5*S(i,j,bj)**13
286 & +3.3173 _d 5*S(i,j,bj)**12 - 1.8965 _d 5*S(i,j,bj)**11
287 & -5.1701 _d 5*S(i,j,bj)**10
288 & +2.6240 _d 5*S(i,j,bj)**9 + 4.077 _d 5*S(i,j,bj)**8
289 & -1.791 _d 5*S(i,j,bj)**7
290 & -1.7231 _d 5*S(i,j,bj)**6 + 0.6229 _d 5*S(i,j,bj)**5
291 & +0.3824 _d 5*S(i,j,bj)**4
292 & -0.1017 _d 5*S(i,j,bj)**3 - 0.0387 _d 5*S(i,j,bj)**2
293 & +0.00562 _d 5*S(i,j,bj) + 0.0007743 _d 5)
294 & /(2.0*12.0*PI*rSphere*rSphere)
295 c EmPmR(i,j,bi,bj) = 1.e-3*Fw35(no_so)
296 c < *(50.0 + 228.0*S(i,j,bj) -1.593e3*S(i,j,bj)**2
297 c < - 2.127e3*S(i,j,bj)**3 + 7.3e3*S(i,j,bj)**4
298 c < + 5.799e3*S(i,j,bj)**5 - 1.232e4*S(i,j,bj)**6
299 c < - 6.389e3*S(i,j,bj)**7 + 9.123e3*S(i,j,bj)**8
300 c < + 2.495e3*S(i,j,bj)**9 - 2.567e3*S(i,j,bj)**10)
301 c < /(2*PI*rSphere*rSphere*15.0)
302 #else
303 IF (yC(i,j,bi,bj) .LT. -40.) THEN
304 c-- Southern Hemisphere
305 EmPmR(i,j,bi,bj) = -1. _d -3*(Fw35(no_so)*
306 & (-6.5 _d 0 + 35.3 _d 0 + 71.7 _d 0*S(i,j,bj)
307 & - 1336.3 _d 0*S(i,j,bj)**2 - 425.8 _d 0*S(i,j,bj)**3
308 & + 5434.8 _d 0*S(i,j,bj)**4 + 707.9 _d 0*S(i,j,bj)**5
309 & - 6987.7 _d 0*S(i,j,bj)**6 - 360.4 _d 0*S(i,j,bj)**7
310 & + 2855.0 _d 0*S(i,j,bj)**8)
311 & /(2.*PI*rSphere*rSphere*18.0))
312 ELSE
313 c-- Atlantic
314 IF (xC(i,j,bi,bj) .GT. 284.
315 & .OR. xC(i,j,bi,bj) .LT. 28.) THEN
316 EmPmR(i,j,bi,bj) = -1. _d -3*(Fw35(no_so)*
317 & (-6.5 _d 0 -2.878 _d 0 + 3.157 _d 2*S(i,j,bj) -
318 & 2.388 _d 3*S(i,j,bj)**2 - 4.101 _d 3*S(i,j,bj)**3 +
319 & 1.963 _d 4*S(i,j,bj)**4 + 1.534 _d 4*S(i,j,bj)**5 -
320 & 6.556 _d 4*S(i,j,bj)**6 - 2.478 _d 4*S(i,j,bj)**7 +
321 & 1.083 _d 5*S(i,j,bj)**8 + 1.85 _d 4*S(i,j,bj)**9 -
322 & 8.703 _d 4*S(i,j,bj)**10 - 5.276 _d 3*S(i,j,bj)**11 +
323 & 2.703 _d 4*S(i,j,bj)**12)
324 & /(2.*PI*rSphere*rSphere*12.0))
325 ELSE
326 c-- Pacific
327 EmPmR(i,j,bi,bj) = -1. _d -3*(Fw35(no_so)
328 & *(-6.5 _d 0 +51.89 _d 0 + 4.916 _d 2*S(i,j,bj) -
329 & 1.041 _d 3*S(i,j,bj)**2 - 7.546 _d 3*S(i,j,bj)**3 +
330 & 2.335 _d 3*S(i,j,bj)**4 + 3.449 _d 4*S(i,j,bj)**5 +
331 & 6.702 _d 3*S(i,j,bj)**6 - 6.601 _d 4*S(i,j,bj)**7 -
332 & 2.594 _d 4*S(i,j,bj)**8 + 5.652 _d 4*S(i,j,bj)**9 +
333 & 2.738 _d 4*S(i,j,bj)**10 - 1.795 _d 4*S(i,j,bj)**11 -
334 & 9.486 _d 3*S(i,j,bj)**12)
335 & /(2.*PI*rSphere*rSphere*12.0))
336 ENDIF
337 ENDIF
338 #endif
339 EmPmR(i,j,bi,bj) = EmPmR(i,j,bi,bj)*rhoConstFresh
340 ENDDO
341 ENDDO
342 ENDDO
343 ENDDO
344
345 _EXCH_XY_RS(Qnet , myThid )
346 _EXCH_XY_RS(EmPmR , myThid )
347
348
349 C CALL PLOT_FIELD_XYRS( Qnet, 'Qnet' , 1, myThid )
350 C CALL PLOT_FIELD_XYRS( EmPmR, 'EmPmR' , 1, myThid )
351
352 cph end of IF TOP_LAYER
353 cph ENDIF
354
355 #endif /* ALLOW_EBM */
356
357 RETURN
358 END

  ViewVC Help
Powered by ViewVC 1.1.22