/[MITgcm]/MITgcm/pkg/aim/phy_radiat.F
ViewVC logotype

Contents of /MITgcm/pkg/aim/phy_radiat.F

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

Revision 1.6 - (show annotations) (download)
Fri Sep 27 20:05:11 2002 UTC (21 years, 7 months ago) by jmc
Branch: MAIN
CVS Tags: checkpoint46n_post, checkpoint48f_post, checkpoint51k_post, checkpoint53f_post, checkpoint47j_post, checkpoint54a_pre, checkpoint55c_post, checkpoint53b_pre, checkpoint48d_pre, checkpoint51l_post, checkpoint51j_post, branch-exfmods-tag, checkpoint47e_post, checkpoint57m_post, checkpoint52l_pre, checkpoint48i_post, checkpoint52e_pre, hrcube4, hrcube5, checkpoint57g_pre, checkpoint52j_post, checkpoint47f_post, checkpoint48d_post, checkpoint51o_pre, checkpoint57f_post, checkpoint46j_post, checkpoint47c_post, checkpoint50e_post, checkpoint52e_post, checkpoint50c_post, checkpoint46i_post, checkpoint51n_pre, checkpoint47d_post, checkpoint57j_post, checkpoint47a_post, checkpoint57b_post, checkpoint52d_pre, checkpoint53c_post, checkpoint53d_post, checkpoint57f_pre, checkpoint48a_post, checkpoint55d_pre, checkpoint51f_pre, checkpoint57g_post, checkpoint48e_post, checkpoint57c_pre, checkpoint48h_post, checkpoint55j_post, checkpoint56b_post, checkpoint50c_pre, checkpoint57h_pre, branchpoint-genmake2, checkpoint46k_post, checkpoint52j_pre, checkpoint54a_post, branch-netcdf, checkpoint50d_pre, checkpoint55h_post, checkpoint51r_post, checkpoint47i_post, checkpoint52b_pre, checkpoint52n_post, checkpoint54b_post, checkpoint46l_pre, checkpoint46j_pre, checkpoint51i_post, checkpoint57e_post, checkpoint54d_post, checkpoint47h_post, checkpoint48c_post, checkpoint46l_post, checkpoint56c_post, checkpoint54e_post, checkpoint55b_post, checkpoint51e_post, checkpoint51b_post, checkpoint51l_pre, checkpoint52m_post, checkpoint51c_post, checkpoint55, checkpoint53a_post, checkpoint55a_post, checkpoint57a_post, checkpoint48, checkpoint49, checkpoint47b_post, checkpoint56, checkpoint57o_post, checkpoint55g_post, checkpoint57h_done, checkpoint51o_post, checkpoint48g_post, checkpoint57k_post, checkpoint57d_post, checkpoint55f_post, checkpoint57i_post, checkpoint51q_post, checkpoint52l_post, checkpoint52k_post, checkpoint57h_post, checkpoint57a_pre, checkpoint54, checkpoint57, checkpoint53b_post, checkpoint51, checkpoint50, checkpoint53, checkpoint52, checkpoint50d_post, checkpoint52d_post, checkpoint51b_pre, checkpoint52a_post, checkpoint47g_post, checkpoint52b_post, checkpoint53g_post, checkpoint52f_post, checkpoint57n_post, checkpoint52c_post, checkpoint46m_post, checkpoint57p_post, checkpoint51h_pre, checkpoint50g_post, checkpoint50b_pre, checkpoint51g_post, ecco_c52_e35, checkpoint54f_post, checkpoint51f_post, checkpoint48b_post, checkpoint50b_post, eckpoint57e_pre, checkpoint57c_post, checkpoint50f_post, checkpoint50a_post, checkpoint50f_pre, checkpoint52a_pre, checkpoint47d_pre, checkpoint51d_post, checkpoint48c_pre, checkpoint51m_post, checkpoint51t_post, checkpoint53d_pre, checkpoint47, checkpoint55e_post, checkpoint54c_post, checkpoint50h_post, checkpoint52i_post, checkpoint51a_post, checkpoint50e_pre, checkpoint50i_post, checkpoint51p_post, checkpoint51n_post, checkpoint55i_post, checkpoint51i_pre, checkpoint57l_post, checkpoint52i_pre, checkpoint51u_post, checkpoint52h_pre, checkpoint52f_pre, hrcube_1, hrcube_2, hrcube_3, checkpoint56a_post, checkpoint51s_post, checkpoint55d_post
Branch point for: netcdf-sm0, branch-genmake2, branch-nonh, tg2-branch, checkpoint51n_branch, branch-exfmods-curt
Changes since 1.5: +135 -108 lines 
Clean up AIM package (and keep the results unchanged):
a) include CPP_OPTION and use IMPLICT NONE in all routines ;
  declare all the variables _RL ;
b) use _d 0 for all numerical constants in Physics package,
  so that the code works with g77 (and give the right answer)
c) use ifdef ALLOW_AIM everywhere so that the package can be
 compiled without increasing the memory size.
d) clean-up the AIM interface (remove commented lines, unused
  variables ...)
1 C $Header: /u/gcmpack/MITgcm/pkg/aim/phy_radiat.F,v 1.5 2001/09/06 13:19:54 adcroft Exp $
2 C $Name: $
3
4 #include "AIM_OPTIONS.h"
5
6 SUBROUTINE SOL_OZ (SOLC,TYEAR,FSOL,OZONE,myThid)
7
8 C--
9 C-- SUBROUTINE SOL_OZ (SOLC,TYEAR,FSOL,OZONE)
10 C--
11 C-- Purpose: Compute the flux of incoming solar radiation
12 C-- and a climatological ozone profile for SW absorption
13 C-- Input: SOLC = solar constant (area averaged)
14 C-- TYEAR = time as fraction of year (0-1, 0 = 1jan.h00)
15 C-- Output: FSOL = flux of incoming solar radiation (2-dim)
16 C-- OZONE = strat. ozone as fraction of global mean (2-dim)
17 C--
18
19 IMPLICIT NONE
20
21 C Resolution parameters
22
23 C-- size for MITgcm & Physics package :
24 #include "AIM_SIZE.h"
25
26 #include "EEPARAMS.h"
27
28 C Constants + functions of sigma and latitude
29 C
30 #include "com_physcon.h"
31
32 C-- Routine arguments:
33 INTEGER myThid
34 _RL FSOL(NLON,NLAT), OZONE(NLON,NLAT)
35
36 C- jmc: declare all routine arguments:
37 _RL SOLC, TYEAR
38
39 #ifdef ALLOW_AIM
40
41 C-- Local variables:
42 INTEGER I, J, I2
43
44 C- jmc: declare all local variables:
45 _RL ALPHA, CSR1, CSR2, COZ1, COZ2
46 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
47
48 C ALPHA = year phase ( 0 - 2pi, 0 = winter solstice = 22dec.h00 )
49 c ALPHA=4.*ASIN(1.)*(TYEAR+10./365.)
50 ALPHA=4. _d 0*ASIN(1. _d 0)*(TYEAR+10. _d 0/365. _d 0)
51
52 CSR1=-0.796 _d 0*COS(ALPHA)
53 CSR2= 0.147 _d 0*COS(2. _d 0*ALPHA)-0.477 _d 0
54 COZ1= 0.0
55 C COZ1= 0.2*SIN(ALPHA)
56 COZ2= 0.3 _d 0
57
58 C
59 DO J=1,NLAT
60 DO I=1,NLON
61 I2=J
62 I2=NLON*(J-1)+I
63 FSOL(I,J) = SOLC*MAX( 0. _d 0,
64 & 1. _d 0+CSR1*FMU(I2,1,myThid)+CSR2*FMU(I2,2,myThid))
65 OZONE(I,J)=1. _d 0+COZ1*FMU(I2,1,myThid)+COZ2*FMU(I2,2,myThid)
66 ENDDO
67 ENDDO
68 C DO J=1,NLAT
69 C FSOL(1,J)=
70 C & SOLC*MAX(0.,1.0+CSR1*FMU(J,1,myThid)+CSR2*FMU(J,2,myThid))
71 C OZONE(1,J)=1.0+COZ1*FMU(J,1,myThid)+COZ2*FMU(J,2,myThid)
72 C DO I=2,NLON
73 C FSOL(I,J)=FSOL(1,J)
74 C OZONE(I,J)=OZONE(1,J)
75 C ENDDO
76 C ENDDO
77
78 #endif /* ALLOW_AIM */
79 RETURN
80 END
81
82
83 SUBROUTINE RADSW (PSA,QA,RH,
84 * FSOL,OZONE,ALB,TAU,
85 * CLOUDC,FTOP,FSFC,DFABS,
86 I myThid)
87 C--
88 C-- SUBROUTINE RADSW (PSA,QA,RH,
89 C-- * FSOL,OZONE,ALB,
90 C-- * CLOUDC,FTOP,FSFC,DFABS)
91 C--
92 C-- Purpose: Compute the absorption of shortwave radiation and
93 C-- initialize arrays for longwave-radiation routines
94 C-- Input: PSA = norm. surface pressure [p/p0] (2-dim)
95 C-- QA = specific humidity [g/kg] (3-dim)
96 C-- RH = relative humidity (3-dim)
97 C-- FSOL = flux of incoming solar radiation (2-dim)
98 C-- OZONE = strat. ozone as fraction of global mean (2-dim)
99 C-- ALB = surface albedo (2-dim)
100 C-- Output: CLOUDC = total cloud cover (2-dim)
101 C-- FTOP = net downw. flux of sw rad. at the atm. top (2-dim)
102 C-- FSFC = net downw. flux of sw rad. at the surface (2-dim)
103 C-- DFABS = flux of sw rad. absorbed by each atm. layer (3-dim)
104 C--
105
106 IMPLICIT NONE
107
108 C Resolution parameters
109
110 C-- size for MITgcm & Physics package :
111 #include "AIM_SIZE.h"
112
113 #include "EEPARAMS.h"
114
115 #include "AIM_GRID.h"
116
117 C Constants + functions of sigma and latitude
118 C
119 #include "com_physcon.h"
120 C
121 C Radiation parameters
122 C
123 #include "com_radcon.h"
124
125 C-- Routine arguments:
126 INTEGER myThid
127 _RL PSA(NGP), QA(NGP,NLEV), RH(NGP,NLEV)
128 _RL FSOL(NGP), OZONE(NGP), ALB(NGP), TAU(NGP,NLEV)
129 _RL CLOUDC(NGP), FTOP(NGP), FSFC(NGP), DFABS(NGP,NLEV)
130
131 #ifdef ALLOW_AIM
132
133 C-- Local variables:
134 _RL FLUX(NGP), FREFL(NGP), TAUOZ(NGP)
135 INTEGER NL1(NGP)
136 INTEGER K, J
137 Cchdbg
138 c INTEGER Npas
139 c SAVE npas
140 c LOGICAL Ifirst
141 c SAVE Ifirst
142 c DATA Ifirst /.TRUE./
143 c REAL clsum(NGP)
144 c SAVE clsum
145 c _RL ABWLW1
146 cchdbg
147
148 C- jmc: declare local variables:
149 _RL DRHCL, RCL
150 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
151 C
152 DO J=1,NGP
153 NL1(J)=NLEVxy(J,myThid)-1
154 ENDDO
155 C
156 C-- 1. Cloud cover:
157 C defined as a linear fun. of the maximum relative humidity
158 C in all tropospheric layers above PBL:
159 C CLOUDC = 0 for RHmax < RHCL1, = 1 for RHmax > RHCL2.
160 C This value is reduced by a factor (Qbase/QACL) if the
161 C cloud-base absolute humidity Qbase < QACL.
162 C
163 DRHCL=RHCL2-RHCL1
164 RCL=1./(DRHCL*QACL)
165 C
166 DO 122 J=1,NGP
167 CLOUDC(J)=0.
168 122 CONTINUE
169 C
170 DO 123 K=1,NLEV
171 DO 123 J=1,NGP
172 DFABS(J,K)=0.
173 123 CONTINUE
174
175 C
176 DO 124 J=1,NGP
177 DO 124 K=2,NL1(J)
178 CLOUDC(J)=MAX(CLOUDC(J),(RH(J,K)-RHCL1))
179 124 CONTINUE
180 C
181 DO 126 J=1,NGP
182 IF ( NL1(J) .GT. 0 ) THEN
183 CLOUDC(J)=MIN(CLOUDC(J),DRHCL)*MIN(QA(J,NL1(J)),QACL)*RCL
184 ENDIF
185 cchdbg *******************************************
186 cchdbg CLOUDC(J)=MIN(CLOUDC(J),DRHCL)/DRHCL
187 cchdbg *******************************************
188 clear sky experiment
189 C cloudc(j) = 0.
190 126 CONTINUE
191 C
192 C
193 C-- 2. Shortwave transmissivity:
194 C function of layer mass, ozone (in the statosphere),
195 C abs. humidity and cloud cover (in the troposphere)
196 C
197 DO 202 J=1,NGP
198 TAU(J,1)=EXP(-ABSSW*PSA(J)*DSIG(1))
199 TAUOZ(J)=EXP(-EPSSW*OZONE(J)*PSA(J))
200 202 CONTINUE
201 C
202 chhh WRITE(0,*) ' Hello from RADSW'
203 DO 204 J=1,NGP
204 DO 204 K=2,NL1(J)
205 TAU(J,K)=EXP(-(ABSSW+ABWSW*QA(J,K)
206 * +ABCSW*CLOUDC(J)*QA(J,NL1(J)))*PSA(J)*DSIG(K))
207 204 CONTINUE
208
209 DO 206 J=1,NGP
210 IF ( NLEVxy(J,myThid) .GT. 0 ) THEN
211 TAU(J,NLEVxy(J,myThid))=
212 & EXP(-(ABSSW+ABWSW*QA(J,NLEVxy(J,myThid)))
213 & *PSA(J)*DSIG(NLEVxy(J,myThid)))
214 ENDIF
215 206 CONTINUE
216 C
217 C--- 3. Shortwave downward flux
218 C
219 C 3.1 Absorption in the stratosphere
220 C
221 DO 312 J=1,NGP
222 FLUX(J)=TAU(J,1)*TAUOZ(J)*FSOL(J)
223 DFABS(J,1)=FSOL(J)-FLUX(J)
224 312 CONTINUE
225
226 C RETURN
227
228 C
229 C 3.2 Reflection at the top of the troposphere
230 C (proportional to cloud cover).
231 C
232 DO 322 J=1,NGP
233 FREFL(J)=ALBCL*CLOUDC(J)*FLUX(J)
234 FTOP(J) =FSOL(J)-FREFL(J)
235 FLUX(J) =FLUX(J)-FREFL(J)
236 322 CONTINUE
237 C
238 C 3.3 Absorption in the troposphere
239 C
240 DO 332 J=1,NGP
241 DO 332 K=2,NLEVxy(J,myThid)
242 DFABS(J,K)=FLUX(J)
243 FLUX(J)=TAU(J,K)*FLUX(J)
244 DFABS(J,K)=DFABS(J,K)-FLUX(J)
245 332 CONTINUE
246
247 Cxx RETURN
248
249 C
250 C--- 4. Shortwave upward flux
251 C
252 C 4.1 Absorption and reflection at the surface
253 C
254 DO 412 J=1,NGP
255 FREFL(J)=ALB(J)*FLUX(J)
256 FSFC(J) =FLUX(J)-FREFL(J)
257 FLUX(J) =FREFL(J)
258 412 CONTINUE
259 C
260 C 4.2 Absorption in the atmosphere
261 C
262 DO 422 J=1,NGP
263 DO 422 K=NLEVxy(J,myThid),1,-1
264 DFABS(J,K)=DFABS(J,K)+FLUX(J)
265 FLUX(J)=TAU(J,K)*FLUX(J)
266 DFABS(J,K)=DFABS(J,K)-FLUX(J)
267 422 CONTINUE
268
269 Cxx RETURN
270
271 C
272 C 4.3 Absorbed solar radiation = incoming - outgoing
273 C
274 DO 432 J=1,NGP
275 FTOP(J)=FTOP(J)-FLUX(J)
276 432 CONTINUE
277
278 C RETURN
279 cdj
280 c write(0,*)'position j=20'
281 c j=20
282 c write(0,*)'ftop fsfc ftop-fsfc'
283 c write(0,*)ftop(j),fsfc(j),ftop(j)-fsfc(j)
284 c write(0,*)
285 c write(0,*)'k dfabs'
286 c do k = 1, nlevxy(j)
287 c write(0,*)k,dfabs(j,k)
288 c enddo
289 c write(0,*)'sum dfabs'
290 c write(0,*)sum(dfabs(j,:))
291 cdj
292 C
293 C--- 5. Initialization of longwave radiation model
294 C
295 C 5.1 Longwave transmissivity:
296 C function of layer mass, abs. humidity and cloud cover.
297 C
298 DO 512 J=1,NGP
299 TAU(J,1)=EXP(-ABSLW*PSA(J)*DSIG(1))
300 512 CONTINUE
301
302 C
303 DO 514 J=1,NGP
304 DO 514 K=2,NL1(J)
305 TAU(J,K)=EXP(-(ABSLW+ABWLW*QA(J,K)
306 * +ABCLW*CLOUDC(J)*QA(J,NL1(J)))*PSA(J)*DSIG(K))
307 514 CONTINUE
308
309 C RETURN
310 C
311 cchdbg ***************************************************
312 c ABCLW1=0.15
313 c DO 514 J=1,NGP
314 c DO 514 K=2,NL1(J)-1
315 c TAU(J,K)=EXP(-(ABSLW+ABWLW*QA(J,K)
316 c * +ABCLW1*CLOUDC(J)*QA(J,NL1(J)))*PSA(J)*DSIG(K))
317 c 514 CONTINUE
318 C
319 c DO 515 J=1,NGP
320 c DO 515 K=NL1(J),NL1(J)
321 c TAU(J,K)=EXP(-(ABSLW+ABWLW*QA(J,K)
322 c * +ABCLW*CLOUDC(J))*PSA(J)*DSIG(K))
323 c 515 CONTINUE
324 cchdbg ************************************************************
325 C
326 C *********************************************************************
327 C *********************************************************************
328 C *****************************************************************
329 cchdbg
330 c if(Ifirst) then
331 c npas=0
332 c do J=1,NGP
333 c clsum(J)=0.
334 c enddo
335 c ifirst=.FALSE.
336 c ENDIF
337 C
338 c npas=npas+1
339 c DO J=1,NGP
340 c clsum(J)=clsum(J)+ABCLW*CLOUDC(J)*QA(J,NL1(J))/5760.
341 c ENDDO
342 C
343 c IF(npas.eq.5760) then
344 c open(73,file='transmoy',form='unformatted')
345 c write(73) clsum
346 c close(73)
347 c ENDIF
348 Cchdbg
349 C
350 C *********************************************************************
351 C *********************************************************************
352
353 C RETURN
354
355 c ABWLW1=0.7
356 DO 516 J=1,NGP
357 IF ( NLEVxy(J,myThid) .GT. 0 ) THEN
358 cchdbg TAU(J,NLEVxy(J,myThid))=EXP(-(ABSLW+ABWLW1*QA(J,NLEVxy(J,myThid)))*PSA(J)
359 TAU(J,NLEVxy(J,myThid))=
360 & EXP(-(ABSLW+ABWLW*QA(J,NLEVxy(J,myThid)))*PSA(J)
361 & *DSIG(NLEVxy(J,myThid)))
362 ENDIF
363 516 CONTINUE
364
365 C---
366 #endif /* ALLOW_AIM */
367
368 RETURN
369 END
370
371
372 SUBROUTINE RADLW (IMODE,TA,TS,ST4S,
373 & TAU,ST4A,
374 * FTOP,FSFC,DFABS,FDOWN,
375 I myThid)
376 C--
377 C-- SUBROUTINE RADLW (IMODE,TA,TS,ST4S,
378 C-- * FTOP,FSFC,DFABS)
379 C--
380 C-- Purpose: Compute the absorption of longwave radiation
381 C-- Input: IMODE = index for operation mode (see below)
382 C-- TA = absolute temperature (3-dim)
383 C-- TS = surface temperature (2-dim) [if IMODE=1]
384 C-- ST4S = surface blackbody emission (2-dim) [if IMODE=2]
385 C-- Output: ST4S = surface blackbody emission (2-dim) [if IMODE=1]
386 C-- FTOP = outgoing flux of lw rad. at the atm. top (2-dim)
387 C-- FSFC = net upw. flux of lw rad. at the surface (2-dim)
388 C-- DFABS = flux of lw rad. absorbed by each atm. layer (3-dim)
389 C-- FDOWN = downward flux of lw rad. at the surface (2-dim)
390 C--
391
392 IMPLICIT NONE
393
394 C Resolution parameters
395
396 C-- size for MITgcm & Physics package :
397 #include "AIM_SIZE.h"
398
399 #include "EEPARAMS.h"
400
401 #include "AIM_GRID.h"
402
403 C Constants + functions of sigma and latitude
404 C
405 #include "com_physcon.h"
406 C
407 C Radiation parameters
408 C
409 #include "com_radcon.h"
410
411 C-- Routine arguments:
412 INTEGER myThid
413 INTEGER IMODE
414 _RL TA(NGP,NLEV), TS(NGP), ST4S(NGP),
415 & TAU(NGP,NLEV), ST4A(NGP,NLEV,2)
416 _RL FTOP(NGP), FSFC(NGP), DFABS(NGP,NLEV)
417 _RL FDOWN(NGP)
418
419 #ifdef ALLOW_AIM
420
421 C-- Local variables:
422 INTEGER K, J
423 INTEGER J0, Jl, I2
424 _RL FLUX(NGP), BRAD(NGP), STCOR(NGP)
425 INTEGER NL1(NGP)
426 C
427 Cchdbg
428 c INteger npas
429 c SAVE npas
430 c LOGICAL Ifirst
431 c SAVE IFIRST
432 c DATA Ifirst/.TRUE./
433 c REAL FluxMoy(NGP)
434 c REAL ST4SMoy(NGP)
435 c SAVE FluxMoy, ST4SMoy
436 Cchdbg
437
438 C- jmc: declare all local variables:
439 _RL COR0, COR1, COR2
440 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
441
442 DO J=1,NGP
443 NL1(J)=NLEVxy(J,myThid)-1
444 ENDDO
445
446 C
447 DO K=1,NLEV
448 DO J=1,NGP
449 DFABS(J,K)=0.
450 ENDDO
451 ENDDO
452
453 C
454 C--- 1. Blackbody emission from atmospheric full and half levels.
455 C Temperature is interpolated as a linear function of ln sigma.
456 C At the lower boundary, the emission is linearly extrapolated;
457 C at the upper boundary, the atmosphere is assumed isothermal.
458 C
459 DO 102 J=1,NGP
460 DO 102 K=1,NLEVxy(J,myThid)
461 ST4A(J,K,1)=TA(J,K)*TA(J,K)
462 ST4A(J,K,1)=SBC*ST4A(J,K,1)*ST4A(J,K,1)
463 102 CONTINUE
464 C
465 DO 104 J=1,NGP
466 DO 104 K=1,NL1(J)
467 ST4A(J,K,2)=TA(J,K)+WVI(K,2)*(TA(J,K+1)-TA(J,K))
468 ST4A(J,K,2)=ST4A(J,K,2)*ST4A(J,K,2)
469 ST4A(J,K,2)=SBC*ST4A(J,K,2)*ST4A(J,K,2)
470 104 CONTINUE
471
472 C
473 DO 106 J=1,NGP
474 IF ( NLEVxy(J,myThid) .GT. 0 ) THEN
475 ST4A(J,NLEVxy(J,myThid),2)=
476 & 2.*ST4A(J,NLEVxy(J,myThid),1)-ST4A(J,NL1(J),2)
477 ENDIF
478 106 CONTINUE
479 C
480 C--- 2. Empirical stratospheric correction
481 C
482 COR0= -13.
483 COR1= 0.
484 COR2= 24.
485 C
486 J0=0
487 DO JL=1,nlat
488 C CORR=COR0+COR1*FMU(JL,1,myThid)+COR2*FMU(JL,2,myThid)
489 DO J=J0+1,J0+NLON
490 I2=JL
491 I2=J
492 STCOR(J)=COR0+COR1*FMU(I2,1,myThid)+COR2*FMU(I2,2,myThid)
493 C STCOR(J)=CORR
494 ENDDO
495 J0=J0+NLON
496 ENDDO
497 C
498 C--- 3. Emission ad absorption of longwave downward flux.
499 C Downward emission is an average of the emission from the full level
500 C and the half-level below, weighted according to the transmissivity
501 C of the layer.
502 C
503 C 3.1 Stratosphere
504 C
505 DO 312 J=1,NGP
506 BRAD(J)=ST4A(J,1,2)+TAU(J,1)*(ST4A(J,1,1)-ST4A(J,1,2))
507 FLUX(J)=(1.-TAU(J,1))*BRAD(J)
508 DFABS(J,1)=STCOR(J)-FLUX(J)
509 312 CONTINUE
510 C
511 C 3.2 Troposphere
512 C
513 DO 322 J=1,NGP
514 DO 322 K=2,NLEVxy(J,myThid)
515 DFABS(J,K)=FLUX(J)
516 BRAD(J)=ST4A(J,K,2)+TAU(J,K)*(ST4A(J,K,1)-ST4A(J,K,2))
517 FLUX(J)=TAU(J,K)*(FLUX(J)-BRAD(J))+BRAD(J)
518 DFABS(J,K)=DFABS(J,K)-FLUX(J)
519 322 CONTINUE
520 C
521 C--- 4. Emission ad absorption of longwave upward flux
522 C Upward emission is an average of the emission from the full level
523 C and the half-level above, weighted according to the transmissivity
524 C of the layer (for the top layer, full-level emission is used).
525 C Surface lw emission in the IR window goes directly into FTOP.
526 C
527 C 4.1 Surface
528 C
529 IF (IMODE.LE.1) THEN
530 DO 412 J=1,NGP
531 ST4S(J)=TS(J)*TS(J)
532 ST4S(J)=SBC*ST4S(J)*ST4S(J)
533 412 CONTINUE
534 ENDIF
535 C
536 C **************************************************************
537 Cchdbg
538 c if(ifirst) then
539 c DO J=1,NGP
540 c ST4SMoy(J)=0.
541 c FluxMoy(J)=0.
542 c ENDDO
543 c npas=0.
544 c ifirst=.FALSE.
545 c endif
546
547 c npas=npas+1
548 c DO 413 J=1,NGP
549 c ST4SMoy(J)=ST4SMoy(J)+ ST4S(J)
550 c FluxMoy(J)=FluxMoy(J)+ Flux(J)
551 c 413 CONTINUE
552
553 c if(npas.eq.5760) then
554 c DO J=1,NGP
555 c ST4SMoy(J)=ST4SMoy(J)/float(npas)
556 c FluxMoy(J)=FluxMoy(J)/float(npas)
557 c ENDDO
558 c open(73,file='ST4Smoy',form='unformatted')
559 c write(73) ST4SMoy
560 c close(73)
561 c open(74,file='FluxMoy',form='unformatted')
562 c write(74) FluxMoy
563 c close(74)
564 c ENDIF
565 Cchdbg
566 C ****************************************************************
567 C
568 C
569 DO 414 J=1,NGP
570 FSFC(J)=ST4S(J)-FLUX(J)
571 FDOWN(J)=FLUX(J)
572 FTOP(J)=EPSLW*ST4S(J)
573 FLUX(J)=ST4S(J)-FTOP(J)
574 414 CONTINUE
575 C
576 C 4.2 Troposphere
577 C
578 DO 422 J=1,NGP
579 DO 422 K=NLEVxy(J,myThid),2,-1
580 DFABS(J,K)=DFABS(J,K)+FLUX(J)
581 BRAD(J)=ST4A(J,K-1,2)+TAU(J,K)*(ST4A(J,K,1)-ST4A(J,K-1,2))
582 FLUX(J)=TAU(J,K)*(FLUX(J)-BRAD(J))+BRAD(J)
583 DFABS(J,K)=DFABS(J,K)-FLUX(J)
584 422 CONTINUE
585 C
586 C 4.3 Stratosphere
587 C
588 DO 432 J=1,NGP
589 DFABS(J,1)=DFABS(J,1)+FLUX(J)
590 FLUX(J)=TAU(J,1)*(FLUX(J)-ST4A(J,1,1))+ST4A(J,1,1)
591 DFABS(J,1)=DFABS(J,1)-FLUX(J)
592 432 CONTINUE
593 C
594 C 4.4 Outgoing longwave radiation
595 C
596 DO 442 J=1,NGP
597 cdj FTOP(J)=FTOP(J)+FLUX(J)
598 FTOP(J)=FTOP(J)+FLUX(J)-STCOR(J)
599 442 CONTINUE
600 cdj
601 c write(0,*)'position j=20'
602 c j=20
603 c write(0,*)'ftop fsfc ftop-fsfc'
604 c write(0,*)ftop(j),fsfc(j),ftop(j)-fsfc(j)
605 c write(0,*)
606 c write(0,*)'k dfabs'
607 c do k = 1, nlevxy(j)
608 c write(0,*)k,dfabs(j,k)
609 c enddo
610 c write(0,*)'sum dfabs'
611 c write(0,*)sum(dfabs(j,:))
612 c open(74,file='ftop0',form='unformatted',status='unknown')
613 c write(74) ftop
614 c open(75,file='stcor',form='unformatted',status='unknown')
615 c write(75) stcor
616 c stop
617 cdj
618 C---
619 #endif /* ALLOW_AIM */
620
621 RETURN
622 END
  ViewVC Help
Powered by ViewVC 1.1.22