/[MITgcm]/MITgcm_contrib/jscott/igsm/src/radiagso.F
ViewVC logotype

Contents of /MITgcm_contrib/jscott/igsm/src/radiagso.F

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


Revision 1.1 - (show annotations) (download)
Fri Aug 11 19:35:32 2006 UTC (18 years, 11 months ago) by jscott
Branch: MAIN
atm2d package

1
2 #include "ctrparam.h"
3
4 ! ==========================================================
5 !
6 ! RADIAGSO.F: THIS SUBROUTINES ADDS THE RADIATION HEATING
7 ! TO THE TEMPERATURES
8 !
9 ! ----------------------------------------------------------
10 !
11 ! Revision History:
12 !
13 ! When Who What
14 ! ----- ---------- -------
15 ! 080100 Chien Wang repack based on CliChem3 & M24x11,
16 ! and add cpp.
17 !
18 ! ==========================================================
19
20 SUBROUTINE RADIAGSO 5001.
21 C**** 5002.
22 C**** THIS SUBROUTINES ADDS THE RADIATION HEATING TO THE TEMPERATURES 5003.
23 C**** 5004.
24
25 #include "BD2G04.COM"
26 #include "chem_para"
27 #include "chem_com"
28
29 COMMON U,V,T,P,Q 5006.
30 COMMON/WORK1/CONV(IM0,JM0,LM0),PK(IM0,JM0,LM0),PREC(IM0,JM0),
31 & TPREC(IM0,JM0), 5007.
32 * COSZ1(IO0,JM0),COSZ2(IO0,JM0),COSZA(IO0,JM0), 5008.
33 * TRINCG(IO0,JM0),BTMPW(IO0,JM0),SNFS(IO0,JM0,4),TNFS(IO0,JM0,4), 5009.
34 * TRHRS(IO0,JM0,3),SRHRS(IO0,JM0,3),ALB(IO0,JM0,9) 5010.
35 COMMON/WORK2/CLDSS(IM0,JM0,LM0),CLDMC(IM0,JM0,LM0), 5011.
36 * TOTCLD(36) 5012.
37 DIMENSION TRNFP0(JM0),TRNFP1(JM0),ALBJ(JM0,9)
38 real ODATA2(JM0,2),GDATA2(JM0,14),BDATA2(JM0,2),FDATA2(JM0,2),
39 * RQT2(JM0,3)
40 common/SURRAD/TRSURF(JM0,4),SRSURF(JM0,4)
41 C COMMON/WORK4/ IS BEING USED BY THE RADIATION ROUTINES 5013.
42 C 5014.
43 C RADCOM: CONTROL/INPUT PARAMETERS 5015.
44 C 5016.
45 COMMON/RADCOM/VADATA(11,4,3),DGLAT(46),DGLON(72),TMINSR,FULGAS(18)5017.
46 A ,FRACSL,RATQSL,FOGTSL,PTLISO,TLGRAD,TKCICE,FGOLDU(18)5018.
47 B ,FLONO3,FRAYLE,FCLDTR,FCLDSR,FALGAE,FMARCL,FEMTRA(6) 5019.
48 C ,WETTRA,WETSRA,DMOICE,DMLICE,LICETK,NTRCE,FZASRA(6) 5020.
49 D ,ID5(5),ITR(4),IMG(2),ILG(2),LAPGAS,KWVCON,NORMS0,NV 5021.
50 E ,KEEPRH,KEEPAL,ISOSCT,IHGSCT,KFRACC,KGASSR,KAERSR 5022.
51 F ,MARCLD,LAYTOP,LMR,LMRP,JMLAT,IMLON,KFORCE,LASTVC 5023.
52 C 5024.
53 C BASIC RADCOM INPUT DATA 5025.
54 C 5026.
55 G ,PLE(40),HLB(40),TLB(40),TLT(40),TL(40),U0GAS(40,9) 5027.
56 H ,ULGAS(40,9),TRACER(40,4),RTAU(40),QL(40),RHL(40) 5028.
57 I ,POCEAN,PEARTH,POICE,PLICE,AGESN,SNOWE,SNOWOI,SNOWLI 5029.
58 J ,TGO,TGE,TGOI,TGLI,TS,WS,WEARTH,ZOICE,FSPARE(200) 5030.
59 K ,S0,COSZ,PVT(11),BXA(153),SRBXAL(15,2),FRC(5),LUXGAS 5031.
60 L ,JYEARR,JDAYR,JLAT,ILON,MEANAL,KALVIS,ISPARE(25),SGPS5032.
61 C 5033.
62 C BASIC RADCOM OUTPUT DATA 5034.
63 C 5035.
64 M ,TRDFLB(40),TRUFLB(40),TRNFLB(40),TRFCRL(40),TRSLCR 5036.
65 N ,SRDFLB(40),SRUFLB(40),SRNFLB(40),SRFHRL(40),SRSLHR 5037.
66 O ,SRIVIS,SROVIS,PLAVIS,SRINIR,SRONIR,PLANIR,SRXATM(4) 5038.
67 P ,SRDVIS,SRUVIS,ALBVIS,SRDNIR,SRUNIR,ALBNIR,FSRNFG(4) 5039.
68 Q ,SRTVIS,SRRVIS,SRAVIS,SRTNIR,SRRNIR,SRANIR,FTRUFG(4) 5040.
69 R ,TRDFGW,TRUFGW,TRUFTW,BTEMPW,TRDFSL,TRUFSL,DTRUFG(4) 5041.
70 S ,TRSLTS,TRSLTG,TRSLWV,TRSLBS,TTRUFG,LBOTCL,LTOPCL 5042.
71 DIMENSION COE(39) 5043.
72 #if ( defined OCEAN_3D )
73 #include "AGRID.COM"
74 #endif
75
76 #if ( defined CLM )
77 #include "CLM.COM"
78 #endif
79 LOGICAL POLE,DC25,HPRNT,WRCLD,CLDFEED 5044.
80 common/conprn/HPRNT
81 common/COMCLD/READGHG,PCLOUD,WRCLD,NWRCLD,NWRCL,INYEAR,JNDAY
82 &,CFAEROSOL,ALFA,CFBC,cfvolaer
83 COMMON/ADDALB/BVSURFA,XVSURFA,BNSURFA,XNSURFA
84 dimension STAERMN(JM0,12,150),JDY(12)
85 DATA JDY/31,59,90,120,151,181,212,243,278,304,334,365/
86 common/cldfdb/coefcl(3),CLDFEED
87 common/aexpc/AEXP,ISTRT1
88 common/ SNOWALB/FRSNALB
89 common/ S0XR/S0RATE
90 dimension CLDSSF(JM0,LM0),CLDMCF(JM0,LM0)
91 &,BSO4LAND(JM0),BSO4OCEAN(JM0)
92 dimension DSWSRF(jm0),DLWSRF(jm0),DSWVIS(jm0),DSWNIR(jm0)
93 integer PCLOUD
94 common/TSUR/TSURFC(JM0,0:13),TSURFT(JM0),TSURFD(JM0),DTSURF(JM0)
95 *,cfcld(JM0,3)
96 CHARACTER*4 JMNTHF,JMLAST
97 DATA JMLAST /'LAST'/
98 DATA TF/273.16/,TCIR/258.16/,STBO/.567257E-7/,IFIRST/1/,JDLAST/-9/5045.
99 DATA IRFIRST /1/
100 C **** CLEAR SKY
101 dimension SRHRCL(JM0),TRHRCL(JM0),ALBCL(JM0),SNP1CL(JM0),
102 *SNP0CL(JM0),TRINCL(JM0),TRP0CL(JM0),TRP1CL(JM0)
103 common/clrsk/CLEAR(JM0),NCLR(JM0),AJCLR(JM0,12),BJCLR(JM0,12),
104 * CJCLR(JM0,12)
105 integer CLEAR
106 C AJCLR
107 C 1 SW INC AT P0 RD (AJ(1))
108 C 2 SW ABS BELOW P0 RD (AJ(2))
109 C 3 SW ABS BELOW P1 RD (AJ(3))
110 C 4 SW ABS AT Z0 RD (AJ(6))
111 C 5 SW INC AT Z0 RD (AJ(5))
112 C 6 LW INC AT Z0 RD (AJ(67))
113 C 7 NET LW AT Z0 SF (AJ(9))
114 C 8 NET LW AT P0 RD (AJ(7))
115 C 9 NET LW AT P1 RD (AJ(8))
116 C 10 NET RAD AT P0 DG (AJ(10))
117 C 11 NET RAD AT P1 DG (AJ(11))
118 C 12 NET RAD AT Z0 DG (AJ(12))
119 C **** CLEAR SKY
120 C**** 5046.
121 C**** FDATA 2 LAND COVERAGE (1) 5047.
122 C**** 3 RATIO OF LAND ICE COVERAGE TO LAND COVERAGE (1) 5048.
123 C**** 5049.
124 C**** ODATA 1 OCEAN TEMPERATURE (C) 5050.
125 C**** 2 RATIO OF OCEAN ICE COVERAGE TO WATER COVERAGE (1) 5051.
126 C**** 5052.
127 C**** GDATA 1 OCEAN ICE SNOW AMOUNT (KG/M**2) 5053.
128 C**** 2 EARTH SNOW AMOUNT (KG/M**2) 5054.
129 C**** 3 OCEAN ICE TEMPERATURE OF FIRST LAYER (C) 5055.
130 C**** 4 EARTH TEMPERATURE OF FIRST LAYER (C) 5056.
131 C**** 5 EARTH WATER OF FIRST LAYER (KG/M**2) 5057.
132 C**** 6 EARTH ICE OF FIRST LAYER (KG/M**2) 5058.
133 C**** 11 AGE OF SNOW (DAYS) 5059.
134 C**** 12 LAND ICE SNOW AMOUNT (KG/M**2) 5060.
135 C**** 13 LAND ICE TEMPERATURE OF FIRST LAYER (C) 5061.
136 C**** 5062.
137 C**** BLDATA 1 COMPOSITE SURFACE WIND MAGNITUDE (M/S) 5063.
138 C**** 2 COMPOSITE SURFACE AIR TEMPERATURE (K) 5064.
139 C**** 5 FREE 5065.
140 C**** 5066.
141 C**** VDATA 1-8 EARTH RATIOS FOR THE 8 VEGETATION TYPES (1) 5067.
142 C**** 9 WATER FIELD CAPACITY OF FIRST LAYER (KG/M**2) 5068.
143 C**** 5069.
144 IF(MODRD.EQ.0) IDACC(2)=IDACC(2)+1 5070.
145 IF (IFIRST.NE.1) GO TO 50 5071.
146 BETA=0.29
147 JDAYR=JNDAY
148 JYEARR=INYEAR
149 c
150 JDAYR=JDAY
151 JYEARR=JYEAR
152 c
153 nrbyyr=24*365/5
154 nrcldmax=20*nrbyyr
155 c print *,' CLOUDS for ',nrcldmax/nrbyyr,' years'
156 KTREND=-CO2
157 JDAY00=-1
158 print *,' RADIAGSO'
159 if(CLDFEED)then
160 print *,' for low and middle clouds',coefcl(1)
161 print *,' for top clouds',coefcl(2)
162 print *,' for MC clouds',coefcl(3)
163 endif
164 print *,' READGHG=',READGHG
165 print *,' CFAEROSOL=',CFAEROSOL
166 print *,' HC aerosol for. ALFA=',ALFA,' BETA=',BETA
167 print *,'Coefficient for volcanic aerosol=',cfvolaer
168 print *,' separate caclulations for land and ocean'
169 DC25=.TRUE.
170 c DC25=.FALSE.
171 if(DC25)then
172 print *,' with DC'
173 else
174 print *,' without DC'
175 print *,' subroutine COSZR'
176 end if
177 if(abs(PCLOUD-3.).gt.1.5.and..NOT.WRCLD)IFIRST=0 5072.
178 LMP1=LM+1 5072.1
179 DTCNDS=NCNDS*DT 5073.
180 C**** SET THE CONTROL PARAMETERS FOR THE RADIATION 5074.
181 JMLAT=JM 5074.1
182 DO J=1,JMLAT
183 DGLAT(J)=acos(COSP(J))*360./TWOPI
184 if(J.le.JMLAT/2)DGLAT(J)=-DGLAT(J)
185 END DO
186 c print *,' DGLAT'
187 c print '(13f7.3)',DGLAT
188 IMLON=IO 5074.2
189 LMR=LM+3 5075.
190 COEX=.01*GRAV*KAPA/RGAS 5076.
191 PSFMPT=PSF-PTOP 5077.
192 DO 30 L=1,LM 5078.
193 COE(L)=DTCNDS*COEX/DSIG(L) 5079.
194 30 PLE(L)=SIGE(L)*(PSF-PTOP)+PTOP 5080.
195 PLE(LMP1)=PTOP 5081.
196 PLE(LM+2)=.5*PTOP 5082.
197 PLE(LMR)=.2*PTOP 5083.
198 PLE(LMR+1)=1.E-5 5084.
199 DO 40 LR=LMP1,LMR 5085.
200 COE(LR)=DT*NRAD*COEX/(PLE(LR)-PLE(LR+1)) 5086.
201 QL(LR)=.3E-5 5087.
202 40 RTAU(LR)=0. 5088.
203 DPMICE=10. 5089.
204 C S0X=1. 5089.1
205 S0X0=S0X
206 KSTREND=S0RATE*100.
207 print *,'S0RATE=',S0RATE,' KSTREND=',KSTREND
208 IF (KSTREND.LT.0) then
209 print *,'Run with changes in solar constant'
210 print *,' JYEAR=',JYEAR
211 TNOW=JYEAR
212 call obssolar(S0X,TNOW)
213 S0X=S0X/1367.
214 S0AV=0.0
215 S0XAV=0.0
216 RSDISTAV=0.0
217 ELSE
218 S0X=1365./1367.
219 print *,'Run with fixed solar constant=',S0X*1367.
220 ENDIF
221 RVOL=0.012
222 #if ( defined VOL_AER )
223 call read_staer (NYVADAT,STAERMN)
224 #else
225 FVOL=0.0045
226 print *,'STAEROSOL for 1860 FVOL=',FVOL
227 #endif
228 CALL RADIA0 (IO,JM,CO2,READGHG) 5090.
229 INCHM=NRAD/NDYN 5091.
230 C**** CLOUD LAYER INDICES USED FOR DIAGNOSTICS 5092.
231 DO 43 L=1,LM 5093.
232 LLOW=L 5094.
233 IF (.5*(PLE(L+1)+PLE(L+2)).LT.786.) GO TO 44 5095.
234 43 CONTINUE 5096.
235 44 LMID1=LLOW+1 5097.
236 DO 45 L=LMID1,LM 5098.
237 LMID=L 5099.
238 IF (.5*(PLE(L+1)+PLE(L+2)).LT.430.) GO TO 46 5100.
239 45 CONTINUE 5101.
240 46 LHI1=LMID+1 5102.
241 LHI=LM 5103.
242 IF (LHI1.GT.LHI) LHI=LHI1 5104.
243 WRITE (6,47) LLOW,LMID1,LMID,LHI1,LHI 5105.
244 47 FORMAT (' LOW CLOUDS IN LAYERS 1-',I2,' MID LEVEL CLOUDS IN',5106.
245 * ' LAYERS',I3,'-',I2,' HIGH CLOUDS IN LAYERS',I3,'-',I2) 5107.
246 C**** NO RADIATION AVERAGING IJRA=1 JRA=1 IRA=1 5108.
247 C**** RADIATION AVERAGING IN I 2 1 2 5109.
248 C**** RADIATION AVERAGING IN I AND J 4 2 2 5110.
249 JRA=(IJRA+2)/3 5111.
250 IRA=IJRA/JRA 5112.
251 50 JALTER=MOD(NSTEP,NRAD*JRA)/NRAD 5113.
252 JDAYR=JDAY
253 JYEARR=JYEAR
254 IALTER=MOD(NSTEP,NRAD*IJRA)/(NRAD*JRA) 5114.
255 S0=S0X*1367./RSDIST 5115.
256 c print *,'S0X0=',S0X0,' S0X=',S0X,' RSDIST=',RSDIST
257 C**** CALCULATE AVERAGE COSINE OF ZENITH ANGLE FOR CURRENT COMP3 STEP 5116.
258 C**** AND RADIATION PERIOD 5117.
259 ROT1=TWOPI*TOFDAY/24. 5118.
260 if(DC25)then
261 ROT2=ROT1+TWOPI*DTCNDS/SDAY 5119.
262 CALL COSZT (IO,JM,SIND,COSD,ROT1,ROT2,COSZ1) 5120.
263 else
264 ROT2=ROT1+TWOPI
265 CALL COSZR (IO,JM,SIND,COSD,ROT1,ROT2,COSZ1)
266 end if
267 if(HPRNT)then
268 print *,' radia TAU=',TAU
269 print *,' CLDSS'
270 print *,(CLDSS(1,7,L),L=1,LM)
271 print *,' CLDMC'
272 print *,(CLDMC(1,7,L),L=1,LM)
273 endif
274 cprint *,' form radia TAU=',TAU,'MODRD=',MODRD
275 C
276 IF(MODRD.NE.0) GO TO 840 5121.
277 C
278 ROT2=ROT1+TWOPI*NRAD*DT/SDAY 5122.
279 CALL COSZS (IO,JM,SIND,COSD,ROT1,ROT2,COSZ2,COSZA) 5123.
280 C**** 5124.
281 C**** COMPUTE EARTH ALBEDOS AND OTHER PARAMETERS FOR BEGINNING OF DAY 5125.
282
283 TNOW=JYEAR+(JDAY-.5)/365. 5127.1
284 c call sulfr(BSO4LAND,BSO4OCEAN,TNOW)
285 KWRITE=0
286 if(JMONTH.ne.JMLAST) then
287 #if ( defined VOL_AER )
288 do MNAER=1,12
289 if (JDAY.le.JDY(MNAER)) go to 458
290 enddo
291 458 continue
292 c print *,' MNAER=', MNAER,' MONTH=',JMONTH
293 #endif
294 KWRITE=1
295 if(READGHG.eq.2) call tgases(CO2,JMONTH)
296 if(READGHG.eq.1) call rtgases(CO2,JMONTH)
297
298 if(1.eq.0)then
299 IF (KSTREND.GT.0) then
300 print *,'Wrong value of KSTREND'
301 stop
302 S0X=S0X0*(1.+S0RATE/70.*(TNOW-INYEAR))
303 c print *,'S0X=',S0X,' TNOW=',TNOW
304 ELSEIF (KSTREND.LT.0) then
305 c print *,'Before obssolar JYEAR=',JYEAR
306 c print *,' JDAY=',JDAY,' JMONTH=',JMONTH
307 c print *,' JDATE=',JDATE,' TNOW=',TNOW
308 call obssolar(S0X,TNOW)
309 S0X=S0X/1367.
310 c print *,'S0X=',S0X,' TNOW=',TNOW
311 ENDIF
312 S0=S0X*1367./RSDIST
313 S0AV=S0AV+S0/12.
314 S0XAV=S0XAV+1367.*S0X/12.
315 RSDISTAV=RSDISTAV+RSDIST/12.
316 if(JMONTH.eq.'DEC')then
317 print *,' JDAY=',JDAY,' S0=',S0
318 print *,' S0AV=',S0AV,' S0XAV=',s0xav,' RSDISTAV=',RSDISTAV
319 S0AV=0.0
320 S0XAV=0.0
321 RSDISTAV=0.0
322 endif
323 endif
324
325 endif
326 JMLAST=JMONTH
327 IF (JDAY.NE.JDLAST.AND.KTREND.GT.0) then
328 c print *,'TNOW=',TNOW
329 CALL FORGET(TNOW,KTREND,KWRITE)
330 endif
331
332 IF (JDAY.NE.JDLAST)then
333
334 IF (KSTREND.GT.0) then
335 S0X=S0X0*(1.+S0RATE/70.*(TNOW-INYEAR))
336 c print *,'S0X=',S0X,' TNOW=',TNOW
337 ELSEIF (KSTREND.LT.0) then
338 c print *,'Before obssolar JYEAR=',JYEAR
339 c print *,' JDAY=',JDAY,' JMONTH=',JMONTH
340 c print *,' JDATE=',JDATE,' TNOW=',TNOW
341 call obssolar(S0X,TNOW)
342 S0X=S0X/1367.
343 c print *,'S0X=',S0X,' TNOW=',TNOW
344 ENDIF
345 S0=S0X*1367./RSDIST
346 S0AV=S0AV+S0/365.
347 S0XAV=S0XAV+1367.*S0X/365.
348 RSDISTAV=RSDISTAV+RSDIST/365.
349 if(JDAY.eq.365)then
350 print *,'JYEAR=',JYEAR,' JDAY=',JDAY
351 print *,' S0AV=',S0AV,' S0XAV=',s0xav,' RSDISTAV=',RSDISTAV
352 S0AV=0.0
353 S0XAV=0.0
354 RSDISTAV=0.0
355 endif
356
357
358
359 #ifdef PREDICTED_GASES
360 call chemglobal(P)
361 #endif
362
363 call sulfr(BSO4LAND,BSO4OCEAN,TNOW)
364 !
365 c for sulfate.4x5.1986.new.dat
366 c do j=1,jm
367 c FLAND=FDATA(1,J,2)
368 c if(FLAND.gt.0.0)BSO4LAND(j)=BSO4LAND(j)/FLAND
369 c if(FLAND.lt.1.0)BSO4OCEAN(j)=BSO4OCEAN(j)/(1.-FLAND)
370 c enddo
371 c for sulfate.4x5.1986.new.dat
372 !
373 CALL RCOMPT
374 c print *,'After RCOMPT'
375 c CALL WRITER (1,0)
376 if(CLDFEED)then
377 DTSURFAV=0.
378 do j=1,jm
379 DTSURFAV=DTSURFAV+DTSURF(J)*DXYP(j)
380 end do !j
381 DTSURFAV=DTSURFAV/AREAG
382 do j=1,jm
383 do k=1,3
384 cfcld(j,k)=1.+coefcl(k)*DTSURFAV
385 end do ! k
386 end do ! j
387 endif
388 ENDIF
389 JDLAST=JDAY 5129.
390 IHOUR=1.5+TOFDAY 5130.
391 CB READING OF CLOUD
392 if(abs(PCLOUD-3.).lt.1.5)then
393 910 continue
394 if(nreadcld.eq.nrcldmax)go to 900
395 read(585,END=900)TFDAYF,JDATEF,JMNTHF,CLDSSF,CLDMCF,IRAND
396 nreadcld=nreadcld+1
397 if(IFIRST.eq.1)then
398 print *,' radia.f PCLOUD=',PCLOUD
399 if(PCLOUD.eq.2)print *,' FIXED MC and SS CLOUDS'
400 if(PCLOUD.eq.4)print *,' FIXED MC CLOUDS ONLY'
401 if(PCLOUD.eq.3)print *,' FIXED SS CLOUDS ONLY'
402 print *,TOFDAY,JDATE,JMONTH
403 print *,TFDAYF,JDATEF,JMNTHF
404 print *,' DTCNDS=',DTCNDS/3600.
405 print *,' DT*NRAD=',DT*NRAD/3600.
406 if(.not.WRCLD)IFIRST=0
407 endif
408 if(abs(TOFDAY-TFDAYF).gt.1.e-3.or.JDATE.ne.JDATEF.or.
409 * JMONTH.ne.JMNTHF)then
410 print *,' RADIA, disagrement in clouds'
411 print *,TOFDAY,JDATE,JMONTH
412 print *,TFDAYF,JDATEF,JMNTHF
413 stop
414 endif
415 go to 920
416 900 rewind 585
417 nreadcld=0
418 print *,' END OF file85'
419 print *,JYEAR
420 print *,TOFDAY,JDATE,JMONTH
421 print *,' REWIND 85'
422 go to 910
423 920 continue
424 CALL RINIT (IRAND)
425 do 930 k=1,LM
426 do 930 j=1,JM
427 if(PCLOUD.ne.4)CLDSS(1,j,k)=CLDSSF(j,k)
428 if(PCLOUD.ne.3)CLDMC(1,j,k)=CLDMCF(j,k)
429 930 continue
430 endif
431 CE END OF READING OF CLOUD
432 if(WRCLD)then
433 if(NWRCLD.eq.1)then
434 CALL RFINAL(IRAND)
435 if(IFIRST.eq.1)print *,' SHORT CLOUDS RECORD'
436 write(81)TOFDAY,JDATE,JMONTH,CLDSS,CLDMC,IRAND
437 elseif(NWRCLD.eq.2)then
438 if(IFIRST.eq.1)print *,' LONG CLOUDS RECORD'
439 do 1150 k=1,14
440 do 1150 j=1,JM0
441 if(k.le.2)then
442 ODATA2(j,k)=ODATA(1,j,k)
443 BDATA2(j,k)=BLDATA(1,j,k)
444 FDATA2(j,k)=FDATA(1,j,k+1)
445 endif
446 if(k.le.3)RQT2(j,k)=RQT(1,j,k)
447 GDATA2(j,k)=GDATA(1,j,k)
448 1150 continue
449 CALL RFINAL(IRAND)
450 write(81)TOFDAY,JDATE,JMONTH,CLDSS,CLDMC,IRAND,
451 * JDAY,JYEAR,T,Q,P,
452 * ODATA2,BDATA2,FDATA2,GDATA2,RQT2
453 else
454 print *,' NWRCLD=',NWRCLD
455 stop
456 endif
457 IFIRST=0
458 endif
459 if(CLDFEED)then
460 if (KWRITE.eq.1)then
461 print *,'cfcld'
462 print 9456,cfcld
463 print *,' DTSURF'
464 print 9456,DTSURF
465 print *,' DTSURFAV=',DTSURFAV
466 9456 format(12f6.2)
467 endif
468 do k=1,LM
469 if(k.le.5)then
470 k1=1
471 else
472 k1=2
473 endif
474 do j=1,JM
475 CLDSS(1,j,k)=cfcld(j,k1)*CLDSS(1,j,k)
476 CLDMC(1,j,k)=cfcld(j,3)*CLDMC(1,j,k)
477 enddo
478 enddo
479 endif
480 C**** 5131.
481 C**** MAIN J LOOP 5132.
482 C**** 5133.
483 DO 600 J=1,JM 5134.
484 IF ((J-1)*(JM-J).NE.0) GO TO 140 5135.
485 C**** CONDITIONS AT THE POLES 5136.
486 POLE=.TRUE. 5137.
487 MODRJ=0 5138.
488 IMAX=1 5139.
489 GO TO 160 5140.
490 C**** CONDITIONS AT NON-POLAR POINTS 5141.
491 140 POLE=.FALSE. 5142.
492 MODRJ=MOD(J+JALTER,JRA) 5143.
493 IMAX=IM 5144.
494 160 XFRADJ=.2+1.2*COSP(J)*COSP(J) 5145.
495 JLAT=J 5145.1
496 #if ( defined VOL_AER )
497 c RVOL=0.012
498 JYEARAER=min(JYEAR-1849,NYVADAT)
499 FVOL=cfvolaer*STAERMN(J,MNAER,JYEARAER)
500 FGOLDU(1)=(RVOL+FVOL)/RVOL
501 if (j.eq.-1)then
502 print *,'From radia'
503 print *,MNAER,JYEAR,JYEAR-1849
504 print *,'RVOL=',RVOL,' FVOL=',FVOL
505 endif
506 #else
507 FGOLDU(1)=(RVOL+FVOL)/RVOL
508 #endif
509 IF(MODRJ.EQ.0) CALL RCOMPJ 5146.
510 C**** 5147.
511 C**** MAIN I LOOP 5148.
512 C**** 5149.
513 IM1=IM 5150.
514 DO 500 I=1,IMAX 5151.
515 MODRIJ=MODRJ+MOD(I+IALTER,IRA) 5152.
516 IF(POLE) MODRIJ=0 5153.
517 JR=J
518 C**** DETERMINE FRACTIONS FOR SURFACE TYPES AND COLUMN PRESSURE 5155.
519 PLAND=FDATA(I,J,2) 5156.
520 PWATER=1.-PLAND
521 POICE=ODATA(I,J,2)*(1.-PLAND) 5157.
522 POCEAN=(1.-PLAND)-POICE 5158.
523 if(POCEAN.LE.1.E-5)then
524 POCEAN=0.
525 POICE=PWATER
526 endif
527 PLICE=FDATA(I,J,3)*PLAND 5159.
528 PEARTH=PLAND-PLICE 5160.
529 SP=P(I,J) 5161.
530 C**** 5162.
531 C**** DETERMINE CLOUDS (AND THEIR OPTICAL DEPTHS) SEEN BY RADIATION 5163.
532 C**** 5164.
533 X=999999. 5164.1
534 c RANDSS=RANDU(X) 5165.
535 c RANDMC=RANDU(X) 5166.
536 CALL RANDUU(RANDSS,X)
537 CALL RANDUU(RANDMC,X)
538 C
539 CSS=0. 5167.
540 CMC=0. 5168.
541 DEPTH=0. 5169.
542 LTOP=0 5169.1
543 DO 210 L=1,LM 5170.
544 RTAU(L)=0. 5171.
545 210 TOTCLD(L)=0. 5172.
546 DO 240 L=1,LM 5173.
547 IF(CLDSS(I,J,L).LT.RANDSS) GO TO 220 5174.
548 RTAUSS=.013333*(PTOP-100.+SIG(L)*SP) 5175.
549 IF(RTAUSS.LT.0.) RTAUSS=0. 5176.
550 IF (T(I,J,L)*PK(I,J,L).LT.TCIR) RTAUSS=.3333333 5177.
551 RTAU(L)=RTAUSS 5178.
552 CSS=1. 5179.
553 AJL(J,L,28)=AJL(J,L,28)+CSS 5180.
554 TOTCLD(L)=1. 5181.
555 LTOP=L 5181.1
556 220 IF(CLDMC(I,J,L).LE.RANDMC) GO TO 240 5182.
557 RTAUMC=DSIG(L)*SP*.08 5183.
558 IF(RTAUMC.GT.RTAU(L)) RTAU(L)=RTAUMC 5184.
559 CMC=1. 5185.
560 AJL(J,L,29)=AJL(J,L,29)+CMC 5186.
561 TOTCLD(L)=1. 5187.
562 LTOP=L 5187.1
563 DEPTH=DEPTH+SP*DSIG(L) 5188.
564 240 AJL(J,L,19)=AJL(J,L,19)+TOTCLD(L) 5189.
565 AJ(J,57)=AJ(J,57)+CSS*POCEAN 5190.
566 BJ(J,57)=BJ(J,57)+CSS*PLAND 5191.
567 CJ(J,57)=CJ(J,57)+CSS*POICE 5192.
568 DJ(JR,57)=DJ(JR,57)+CSS*DXYP(J) 5193.
569 AJ(J,58)=AJ(J,58)+CMC*POCEAN 5194.
570 BJ(J,58)=BJ(J,58)+CMC*PLAND 5195.
571 CJ(J,58)=CJ(J,58)+CMC*POICE 5196.
572 DJ(JR,58)=DJ(JR,58)+CMC*DXYP(J) 5197.
573 AIJ(I,J,17)=AIJ(I,J,17)+CMC 5198.
574 AJ(J,80)=AJ(J,80)+DEPTH*POCEAN 5199.
575 BJ(J,80)=BJ(J,80)+DEPTH*PLAND 5200.
576 CJ(J,80)=CJ(J,80)+DEPTH*POICE 5201.
577 DJ(JR,80)=DJ(JR,80)+DEPTH*DXYP(J) 5202.
578 CLDCV=CMC+CSS-CMC*CSS 5203.
579 AJ(J,59)=AJ(J,59)+CLDCV*POCEAN 5204.
580 BJ(J,59)=BJ(J,59)+CLDCV*PLAND 5205.
581 CJ(J,59)=CJ(J,59)+CLDCV*POICE 5206.
582 DJ(JR,59)=DJ(JR,59)+CLDCV*DXYP(J) 5207.
583 AIJ(I,J,19)=AIJ(I,J,19)+CLDCV 5208.
584 DO 250 L=1,LLOW 5209.
585 IF (TOTCLD(L).NE.1.) GO TO 250 5210.
586 AIJ(I,J,41)=AIJ(I,J,41)+1. 5211.
587 GO TO 255 5212.
588 250 CONTINUE 5213.
589 255 DO 260 L=LMID1,LMID 5214.
590 IF (TOTCLD(L).NE.1.) GO TO 260 5215.
591 AIJ(I,J,42)=AIJ(I,J,42)+1. 5216.
592 GO TO 265 5217.
593 260 CONTINUE 5218.
594 265 DO 270 L=LHI1,LHI 5219.
595 IF (TOTCLD(L).NE.1.) GO TO 270 5220.
596 AIJ(I,J,43)=AIJ(I,J,43)+1. 5221.
597 GO TO 275 5222.
598 270 CONTINUE 5223.
599 275 DO 280 LX=1,LM 5224.
600 L=1+LM-LX 5225.
601 IF (TOTCLD(L).NE.1.) GO TO 280 5226.
602 AIJ(I,J,18)=AIJ(I,J,18)+SIGE(L+1)*SP+PTOP 5227.
603 GO TO 285 5228.
604 280 CONTINUE 5229.
605 285 DO 290 KR=1,4 5230.
606 IF(I.EQ.IJD6(1,KR).AND.J.EQ.IJD6(2,KR)) GO TO 292 5231.
607 290 CONTINUE 5232.
608 GO TO 300 5233.
609 292 IH=IHOUR 5234.
610 DO 294 INCH=1,INCHM 5235.
611 IF(IH.GT.24) IH=IH-24 5236.
612 ADAILY(IH,21,KR)=ADAILY(IH,21,KR)+TOTCLD(6) 5237.
613 ADAILY(IH,22,KR)=ADAILY(IH,22,KR)+TOTCLD(5) 5238.
614 ADAILY(IH,23,KR)=ADAILY(IH,23,KR)+TOTCLD(4) 5239.
615 ADAILY(IH,24,KR)=ADAILY(IH,24,KR)+TOTCLD(3) 5240.
616 ADAILY(IH,25,KR)=ADAILY(IH,25,KR)+TOTCLD(2) 5241.
617 ADAILY(IH,26,KR)=ADAILY(IH,26,KR)+TOTCLD(1) 5242.
618 ADAILY(IH,27,KR)=ADAILY(IH,27,KR)+CLDCV 5243.
619 294 IH=IH+1 5244.
620 C**** 5245.
621 300 IF(MODRIJ.NE.0) GO TO 500 5246.
622 BVSURFA=0.0
623 XVSURFA=0.0
624 BNSURFA=0.0
625 XNSURFA=0.0
626 C**** clear sky condinion
627 if(CMC.le.0.and.CSS.le.0)then
628 CLEAR(J)=1
629 else
630 CLEAR(J)=0
631 endif
632 C**** 5247.
633 C**** SET UP VERTICAL ARRAYS OMITTING THE I AND J INDICES 5248.
634 C**** 5249.
635 C**** EVEN PRESSURES 5250.
636 DO 340 L=1,LM 5251.
637 PLE(L)=SIGE(L)*SP+PTOP 5252.
638 C**** TEMPERATURES 5253.
639 TL(L)=T(I,J,L)*PK(I,J,L) 5254.
640 C**** MOISTURE VARIABLES 5255.
641 QL(L)=Q(I,J,L) 5256.
642 340 CONTINUE 5257.
643 C**** 5258.
644 C**** RADIATION, SOLAR AND THERMAL 5259.
645 C**** 5260.
646 DO 420 K=1,3 5261.
647 420 TL(LM+K)=RQT(I,J,K) 5262.
648 COSZ=COSZA(I,J) 5263.
649 TGO=ODATA(I,J,1)+TF 5264.
650 TGOI=GDATA(I,J,3)+TF 5265.
651 TGLI=GDATA(I,J,13)+TF 5266.
652 TGE=GDATA(I,J,4)+TF 5267.
653 TS=BLDATA(I,J,2) 5268.
654 SNOWOI=GDATA(I,J,1) 5269.
655 SNOWLI=GDATA(I,J,12) 5270.
656 SNOWE=GDATA(I,J,2) 5271.
657 AGESN=GDATA(I,J,11) 5272.
658 WEARTH=(GDATA(I,J,5)+GDATA(I,J,6))/(VDATA(I,J,9)+1.E-20) 5273.
659 DO 430 K=1,8 5274.
660 430 PVT(K)=VDATA(I,J,K) 5275.
661 WS=BLDATA(I,J,1) 5276.
662 do 439 L=1,LM+1
663 SRHR(I,J,L)=0.
664 TRHR(I,J,L)=0.
665 if(L.le.4)then
666 SNFS(I,J,L)=0.
667 TNFS(I,J,L)=0.
668 if(L.le.3)then
669 SRHRS(I,J,L)=0.
670 TRHRS(I,J,L)=0.
671 endif
672 endif
673 439 continue
674 TRNFP0(J)=0.
675 TRNFP1(J)=0.
676 TRINCG(I,J)=0.
677 BTMPW(I,J)=0.
678 SRDAN=0.
679 SRNAN=0.
680 do 449 K=1,9
681 ALB(I,J,K)=0.
682 ALBJ(J,K)=0.
683 449 continue
684 do 499 ii=1,3
685 COSZ=COSZA(I,J)
686 PLAND=FDATA(I,J,2)
687 PWATER=1.-PLAND
688 POICE=ODATA(I,J,2)*(1.-PLAND)
689 POCEAN=(1.-PLAND)-POICE
690 if(POCEAN.LE.1.E-5)then
691 POCEAN=0.
692 POICE=PWATER
693 endif
694 PLICE=FDATA(I,J,3)*PLAND
695 PEARTH=PLAND-PLICE
696 if(ii.eq.1)then
697 BSO4=BSO4OCEAN(J)
698 PTYPE=POCEAN
699 POICE=0.
700 POCEAN=1.
701 PLAND=0.
702 PEARTH=0.
703 PLICE=0.
704 TGAL=0.
705 else if(ii.eq.3)then
706 BSO4=BSO4OCEAN(J)
707 PTYPE=POICE
708 POICE=1.
709 POCEAN=0.
710 PLAND=0.
711 PEARTH=0.
712 PLICE=0.
713 TGAL=TGOI
714 else
715 BSO4=BSO4LAND(J)
716 PTYPE=PLAND
717 POCEAN=0.
718 POICE=0.
719 PWATER=0.
720 PLICE=FDATA(I,J,3)
721 PEARTH=1.-PLICE
722 TGAL=TGE*PEARTH+TGLI*PLICE
723 PLAND=1.
724 endif
725 if(PTYPE.lt.1.e-10)go to 499
726 if(ii.gt.1)then
727 c if(TGAL.lt.268.)then
728 c FRSNALB=0.35
729 c elseif(TGAL.lt.273.)then
730 c FRSNALB=0.35-0.04*(TGAL-268.)
731 c else
732 c FRSNALB=0.15
733 c endif
734 if(TGAL.lt.263.)then
735 FRSNALB=0.30
736 elseif(TGAL.lt.273.)then
737 FRSNALB=0.30-0.015*(TGAL-263.)
738 else
739 FRSNALB=0.15
740 endif
741 endif !ii
742 c FGOLDU(2)=XFRADJ*(1.-PEARTH) 5277.
743 c FGOLDU(3)=XFRADJ*PEARTH 5278.
744 FGOLDU(2)=XFRADJ*(1.-PLAND)
745 FGOLDU(3)=XFRADJ*PLAND
746 ILON=I 5278.1
747 JLAT=J 5278.2
748 if(CLEAR(J).eq.1)then
749 BVSURFA=BETA*ALFA*BSO4
750 XVSURFA=BETA*ALFA*BSO4
751 BNSURFA=BETA*ALFA*BSO4
752 XNSURFA=BETA*ALFA*BSO4
753 else
754 BVSURFA=0.0
755 XVSURFA=0.0
756 BNSURFA=0.0
757 XNSURFA=0.0
758 endif
759 if(J.le.-2)then
760 print *,' From Radia J=',J,' ii=',ii
761 print *,' BSO4=',BSO4
762 print *,' CLEAR(J)=',CLEAR(J)
763 c print *,' Delta Asrf=',BETA*ALFA*BSO4
764 endif
765 CALL RCOMPX 5279.
766 if (IRFIRST.eq.1.and.READGHG.eq.1)then
767 CALL WRITER(12)
768 if(ii.ge.2)IRFIRST=0
769 endif
770 IF(DMOD(TAU,365.*24.).EQ.0..and.J.eq.JM/2) then
771 print *,' tau=',TAU,' J=',J
772 CALL WRITER (1,0)
773 endif
774 SRHR(I,J,1)=SRHR(I,J,1)+SRNFLB(1)*PTYPE
775 TRHR(I,J,1)=TRHR(I,J,1)+(STBO*(POCEAN*TGO**4+POICE*TGOI**4
776 * +PLICE*TGLI**4+PEARTH*TGE**4)-TRNFLB(1))*PTYPE
777 C *****
778 TRSURF(J,ii)=STBO*(POCEAN*TGO**4+POICE*TGOI**4
779 * +PLICE*TGLI**4+PEARTH*TGE**4)-TRNFLB(1)
780 SRSURF(J,ii)=SRNFLB(1)
781 DO 440 L=1,LM 5284.
782 SRHR(I,J,L+1)=SRHR(I,J,L+1)+SRFHRL(L)*PTYPE
783 440 TRHR(I,J,L+1)=TRHR(I,J,L+1)-TRFCRL(L)*PTYPE
784 DO 450 LR=1,3 5287.
785 SRHRS(I,J,LR)=SRHRS(I,J,LR)+SRFHRL(LM+LR)*PTYPE
786 450 TRHRS(I,J,LR)=TRHRS(I,J,LR)-TRFCRL(LM+LR)*PTYPE
787 DO 460 K=1,4 5290.
788 SNFS(I,J,K)=SNFS(I,J,K)+SRNFLB(K+LM)*PTYPE
789 460 TNFS(I,J,K)=TNFS(I,J,K)+(TRNFLB(K+LM)-TRNFLB(1))*PTYPE
790 TRNFP0(J)=TRNFP0(J)+TRNFLB(4+LM)*PTYPE
791 c 05/02/2003
792 c LS1 is a lowest stratospheric layer (LS1=8 for
793 c both LM=9 and 11)
794 c TRNFP1(J)=TRNFP1(J)+TRNFLB(1+LM)*PTYPE
795 TRNFP1(J)=TRNFP1(J)+TRNFLB(LS1)*PTYPE
796 c 05/02/2003
797 TRINCG(I,J)=TRINCG(I,J)+TRDFLB(1)*PTYPE
798 BTMPW(I,J)=BTMPW(I,J)+(BTEMPW-TF)*PTYPE
799 SRDAN=SRDAN+SRDFLB(1)*PTYPE
800 SRNAN=SRNAN+SRNFLB(1)*PTYPE
801 ALB(I,J,2)=ALB(I,J,2)+PLAVIS*PTYPE
802 ALB(I,J,3)=ALB(I,J,3)+PLANIR*PTYPE
803 ALB(I,J,4)=ALB(I,J,4)+ALBVIS*PTYPE
804 ALB(I,J,5)=ALB(I,J,5)+ALBNIR*PTYPE
805 ALB(I,J,6)=ALB(I,J,6)+SRRVIS*PTYPE
806 ALB(I,J,7)=ALB(I,J,7)+SRRNIR*PTYPE
807 ALB(I,J,8)=ALB(I,J,8)+SRAVIS*PTYPE
808 ALB(I,J,9)=ALB(I,J,9)+SRANIR*PTYPE
809 ALB1=SRNFLB(1)/(SRDFLB(1)+1.E-20)
810 C **********
811 ALBJ(J,2)=PLAVIS
812 ALBJ(J,3)=PLANIR
813 ALBJ(J,4)=ALBVIS
814 ALBJ(J,5)=ALBNIR
815 ALBJ(J,6)=SRRVIS
816 ALBJ(J,7)=SRRNIR
817 ALBJ(J,8)=SRAVIS
818 ALBJ(J,9)=SRANIR
819 ALBJ(J,1)=SRNFLB(1)/(SRDFLB(1)+1.E-20)
820 C *********
821 if(CLEAR(j).eq.0)then
822 SRHRCL(J)=SRNFLB(1)
823 TRHRCL(J)=-TRNFLB(1)
824 ALBCL(J)=SRNFLB(1)/(SRDFLB(1)+1.e-20)
825 c 05/02/2003
826 c SNP1CL(J)=SRNFLB(LM+1)
827 SNP1CL(J)=SRNFLB(LS1)
828 c 05/02/2003
829 SNP0CL(J)=SRNFLB(LM+4)
830 TRINCL(J)=TRDFLB(1)
831 TRP0CL(J)=TRNFLB(LM+4)
832 c 05/02/2003
833 c TRP1CL(J)=TRNFLB(LM+1)
834 TRP1CL(J)=TRNFLB(LS1)
835 c 05/02/2003
836 endif
837 COSZ=COSZ2(I,J)
838 if(ii.eq.2)then
839 #if ( defined CLM )
840 C for TEM CLM
841 DSWSRF(j)=SRDFLB(1)
842 DLWSRF(j)=TRSURF(J,2)
843 DSWVIS(j)=SRDVIS
844 DSWNIR(j)=SRDNIR
845 C for TEM CLM
846 #endif
847 PLAND=PTYPE
848 BJ(J,1)=BJ(J,1)+(S0*COSZ)*PLAND
849 BJ(J,2)=BJ(J,2)+(SRNFLB(4+LM)*COSZ)*PLAND
850 BJ(J,5)=BJ(J,5)+(SRDFLB(1)*COSZ)*PLAND
851 BJ(J,6)=BJ(J,6)+(SRNFLB(1)*COSZ)*PLAND
852 BJ(J,55)=BJ(J,55)+(BTEMPW-TF)*PLAND
853 BJ(J,67)=BJ(J,67)+TRDFLB(1)*PLAND
854 BJ(J,70)=BJ(J,70)-(TRNFLB(4+LM)-TRNFLB(1))*PLAND
855 BJ(J,7)=BJ(J,7)-TRNFLB(4+LM)*PLAND
856 c 05/02/2003
857 c BJ(J,8)=BJ(J,8)-TRNFLB(1+LM)*PLAND
858 c BJ(J,3)=BJ(J,3)+(SRNFLB(1+LM)*COSZ)*PLAND
859 BJ(J,8)=BJ(J,8)-TRNFLB(LS1)*PLAND
860 BJ(J,3)=BJ(J,3)+(SRNFLB(LS1)*COSZ)*PLAND
861 c 05/02/2003
862 BJ(J,71)=BJ(J,71)-(TRNFLB(1+LM)-TRNFLB(1))*PLAND
863 DO 761 K=2,9
864 BJ(J,K+70)=BJ(J,K+70)+(S0*COSZ)*ALBJ(J,K)*PLAND
865 761 CONTINUE
866 if(CLEAR(J).eq.0)then
867 BJCLR(J,1)=BJCLR(J,1)+(S0*COSZ)*PLAND
868 BJCLR(J,2)=BJCLR(J,2)+(SNP0CL(J)*COSZ)*PLAND
869 BJCLR(J,4)=BJCLR(J,4)+(SRHRCL(J)*COSZ)*PLAND
870 BJCLR(J,5)=BJCLR(J,5)+(SRDFLB(1)*COSZ)*PLAND
871 c
872 BJCLR(J,6)=BJCLR(J,6)+TRINCL(J)*PLAND
873 BJCLR(J,8)=BJCLR(J,8)-TRP0CL(J)*PLAND
874 BJCLR(J,9)=BJCLR(J,9)-TRP1CL(J)*PLAND
875 BJCLR(J,3)=BJCLR(J,3)+(SNP1CL(J)*COSZ)*PLAND
876 BJCLR(J,7)=BJCLR(J,7)+TRHRCL(J)*PLAND
877 endif
878 else if(ii.eq.1)then
879 POCEAN=PTYPE
880 AJ(J,1)=AJ(J,1)+(S0*COSZ)*POCEAN
881 AJ(J,2)=AJ(J,2)+(SRNFLB(4+LM)*COSZ)*POCEAN
882 AJ(J,5)=AJ(J,5)+(SRDFLB(1)*COSZ)*POCEAN
883 AJ(J,6)=AJ(J,6)+(SRNFLB(1)*COSZ)*POCEAN
884 AJ(J,55)=AJ(J,55)+(BTEMPW-TF)*POCEAN
885 AJ(J,67)=AJ(J,67)+TRDFLB(1)*POCEAN
886 AJ(J,70)=AJ(J,70)-(TRNFLB(4+LM)-TRNFLB(1))*POCEAN
887 AJ(J,7)=AJ(J,7)-TRNFLB(4+LM)*POCEAN
888 c 05/02/2003
889 c AJ(J,8)=AJ(J,8)-TRNFLB(1+LM)*POCEAN
890 c AJ(J,3)=AJ(J,3)+(SRNFLB(1+LM)*COSZ)*POCEAN
891 AJ(J,8)=AJ(J,8)-TRNFLB(LS1)*POCEAN
892 AJ(J,3)=AJ(J,3)+(SRNFLB(LS1)*COSZ)*POCEAN
893 c 05/02/2003
894 AJ(J,71)=AJ(J,71)-(TRNFLB(1+LM)-TRNFLB(1))*POCEAN
895 #if ( defined OCEAN_3D )
896 solarinc_ocean(J)=solarinc_ocean(J)+SRDFLB(1)*COSZ
897 solarnet_ocean(J)=solarnet_ocean(J)+SRNFLB(1)*COSZ
898 navrado(j)=navrado(j)+1
899 #endif
900 C
901 DO K=2,9
902 AJ(J,K+70)=AJ(J,K+70)+(S0*COSZ)*ALBJ(J,K)*POCEAN
903 END DO
904 if(CLEAR(J).eq.0)then
905 AJCLR(J,1)=AJCLR(J,1)+(S0*COSZ)*POCEAN
906 AJCLR(J,2)=AJCLR(J,2)+(SNP0CL(J)*COSZ)*POCEAN
907 AJCLR(J,4)=AJCLR(J,4)+(SRHRCL(J)*COSZ)*POCEAN
908 AJCLR(J,5)=AJCLR(J,5)+(SRDFLB(1)*COSZ)*POCEAN
909 AJCLR(J,6)=AJCLR(J,6)+TRINCL(J)*POCEAN
910 AJCLR(J,8)=AJCLR(J,8)-TRP0CL(J)*POCEAN
911 AJCLR(J,9)=AJCLR(J,9)-TRP1CL(J)*POCEAN
912 AJCLR(J,3)=AJCLR(J,3)+(SNP1CL(J)*COSZ)*POCEAN
913 AJCLR(J,7)=AJCLR(J,7)+TRHRCL(J)*POCEAN
914 endif
915 C
916 else
917 POICE=PTYPE
918 CJ(J,1)=CJ(J,1)+(S0*COSZ)*POICE
919 CJ(J,2)=CJ(J,2)+(SRNFLB(4+LM)*COSZ)*POICE
920 CJ(J,5)=CJ(J,5)+(SRDFLB(1)*COSZ)*POICE
921 CJ(J,6)=CJ(J,6)+(SRNFLB(1)*COSZ)*POICE
922 CJ(J,55)=CJ(J,55)+(BTEMPW-TF)*POICE
923 CJ(J,67)=CJ(J,67)+TRDFLB(1)*POICE
924 CJ(J,70)=CJ(J,70)-(TRNFLB(4+LM)-TRNFLB(1))*POICE
925 CJ(J,7)=CJ(J,7)-TRNFLB(4+LM)*POICE
926 c 05/02/2003
927 c CJ(J,8)=CJ(J,8)-TRNFLB(1+LM)*POICE
928 c CJ(J,3)=CJ(J,3)+(SRNFLB(1+LM)*COSZ)*POICE
929 CJ(J,8)=CJ(J,8)-TRNFLB(LS1)*POICE
930 CJ(J,3)=CJ(J,3)+(SRNFLB(LS1)*COSZ)*POICE
931 c 05/02/2003
932 CJ(J,71)=CJ(J,71)-(TRNFLB(1+LM)-TRNFLB(1))*POICE
933 #if ( defined OCEAN_3D )
934 solarinc_ice(J)=solarinc_ice(J)+SRDFLB(1)*COSZ
935 solarnet_ice(J)=solarnet_ice(J)+SRNFLB(1)*COSZ
936 navrad(j)=navrad(j)+1
937 #endif
938 if(CLEAR(J).eq.0)then
939 CJCLR(J,1)=CJCLR(J,1)+(S0*COSZ)*POICE
940 CJCLR(J,2)=CJCLR(J,2)+(SNP0CL(J)*COSZ)*POICE
941 CJCLR(J,4)=CJCLR(J,4)+(SRHRCL(J)*COSZ)*POICE
942 CJCLR(J,5)=CJCLR(J,5)+(SRDFLB(1)*COSZ)*POICE
943 c
944 CJCLR(J,6)=CJCLR(J,6)+TRINCL(J)*POICE
945 CJCLR(J,8)=CJCLR(J,8)-TRP0CL(J)*POICE
946 CJCLR(J,9)=CJCLR(J,9)-TRP1CL(J)*POICE
947 CJCLR(J,3)=CJCLR(J,3)+(SNP1CL(J)*COSZ)*POICE
948 CJCLR(J,7)=CJCLR(J,7)+TRHRCL(J)*POICE
949 endif
950 C
951 DO K=2,9
952 CJ(J,K+70)=CJ(J,K+70)+(S0*COSZ)*ALBJ(J,K)*POICE
953 END DO
954 endif
955 499 continue
956 ALB(I,J,1)=SRNAN/(SRDAN+1.E-20)
957 500 IM1=I 5304.
958 I=1
959 PLAND=FDATA(I,J,2)
960 PWATER=1.-PLAND
961 POICE=ODATA(I,J,2)*(1.-PLAND)
962 POCEAN=(1.-PLAND)-POICE
963 if(POCEAN.LE.1.E-5)then
964 POCEAN=0.
965 POICE=PWATER
966 endif
967 PLICE=FDATA(I,J,3)*PLAND
968 PEARTH=PLAND-PLICE
969 if(CLEAR(J).eq.1)then
970 BVSURFA=0.0
971 XVSURFA=0.0
972 BNSURFA=0.0
973 XNSURFA=0.0
974 COSZ=COSZA(I,J)
975 c CSS=0.
976 c CMC=0.
977 c DEPTH=0.
978 c LTOP=0.
979 c do 1210 L=1,LM
980 c RTAU(L)=0.
981 c TOTCLD(L)=0.
982 c1210 continue
983 do 599 ii=1,3
984 BSO4=0.
985 COSZ=COSZA(I,J)
986 PLAND=FDATA(I,J,2)
987 PWATER=1.-PLAND
988 POICE=ODATA(I,J,2)*(1.-PLAND)
989 POCEAN=(1.-PLAND)-POICE
990 if(POCEAN.LE.1.E-5)then
991 POCEAN=0.
992 POICE=PWATER
993 endif
994 PLICE=FDATA(I,J,3)*PLAND
995 PEARTH=PLAND-PLICE
996 if(ii.eq.1)then
997 BSO4=BSO4OCEAN(J)
998 PTYPE=POCEAN
999 POICE=0.
1000 POCEAN=1.
1001 PLAND=0.
1002 PEARTH=0.
1003 PLICE=0.
1004 TGAL=0.
1005 else if(ii.eq.3)then
1006 BSO4=BSO4OCEAN(J)
1007 PTYPE=POICE
1008 POICE=1.
1009 POCEAN=0.
1010 PLAND=0.
1011 PEARTH=0.
1012 PLICE=0.
1013 TGAL=TGOI
1014 else
1015 BSO4=BSO4LAND(J)
1016 PTYPE=PLAND
1017 POCEAN=0.
1018 POICE=0.
1019 PWATER=0.
1020 PLICE=FDATA(I,J,3)
1021 PEARTH=1.-PLICE
1022 TGAL=TGE*PEARTH+TGLI*PLICE
1023 PLAND=1.
1024 endif
1025 if(PTYPE.lt.1.e-10)go to 599
1026 if(ii.gt.1)then
1027 if(TGAL.lt.263.)then
1028 FRSNALB=0.30
1029 elseif(TGAL.lt.273.)then
1030 FRSNALB=0.30-0.015*(TGAL-263.)
1031 else
1032 FRSNALB=0.15
1033 endif
1034 endif !ii
1035 FGOLDU(2)=XFRADJ*(1.-PLAND)
1036 FGOLDU(3)=XFRADJ*PLAND
1037 CALL RCOMPX
1038 SRHRCL(J)=SRNFLB(1)
1039 TRHRCL(J)=-TRNFLB(1)
1040 ALBCL(J)=SRNFLB(1)/(SRDFLB(1)+1.e-20)
1041 c 05/02/2003
1042 c SNP1CL(J)=SRNFLB(LM+1)
1043 SNP1CL(J)=SRNFLB(LS1)
1044 c 05/02/2003
1045 SNP0CL(J)=SRNFLB(LM+4)
1046 TRINCL(J)=TRDFLB(1)
1047 TRP0CL(J)=TRNFLB(LM+4)
1048 c 05/02/2003
1049 c TRP1CL(J)=TRNFLB(LM+1)
1050 TRP1CL(J)=TRNFLB(LS1)
1051 c 05/02/2003
1052 C *********
1053 COSZ=COSZ2(I,J)
1054 if(ii.eq.2)then
1055 PLAND=PTYPE
1056 BJCLR(J,1)=BJCLR(J,1)+(S0*COSZ)*PLAND
1057 BJCLR(J,2)=BJCLR(J,2)+(SNP0CL(J)*COSZ)*PLAND
1058 BJCLR(J,4)=BJCLR(J,4)+(SRHRCL(J)*COSZ)*PLAND
1059 BJCLR(J,5)=BJCLR(J,5)+(SRDFLB(1)*COSZ)*PLAND
1060 BJCLR(J,6)=BJCLR(J,6)+TRINCL(J)*PLAND
1061 BJCLR(J,8)=BJCLR(J,8)-TRP0CL(J)*PLAND
1062 BJCLR(J,9)=BJCLR(J,9)-TRP1CL(J)*PLAND
1063 BJCLR(J,3)=BJCLR(J,3)+(SNP1CL(J)*COSZ)*PLAND
1064 BJCLR(J,7)=BJCLR(J,7)+TRHRCL(J)*PLAND
1065
1066 else if(ii.eq.1)then
1067 POCEAN=PTYPE
1068 AJCLR(J,1)=AJCLR(J,1)+(S0*COSZ)*POCEAN
1069 AJCLR(J,2)=AJCLR(J,2)+(SNP0CL(J)*COSZ)*POCEAN
1070 AJCLR(J,4)=AJCLR(J,4)+(SRHRCL(J)*COSZ)*POCEAN
1071 AJCLR(J,5)=AJCLR(J,5)+(SRDFLB(1)*COSZ)*POCEAN
1072 AJCLR(J,6)=AJCLR(J,6)+TRINCL(J)*POCEAN
1073 AJCLR(J,8)=AJCLR(J,8)-TRP0CL(J)*POCEAN
1074 AJCLR(J,9)=AJCLR(J,9)-TRP1CL(J)*POCEAN
1075 AJCLR(J,3)=AJCLR(J,3)+(SNP1CL(J)*COSZ)*POCEAN
1076 AJCLR(J,7)=AJCLR(J,7)+TRHRCL(J)*POCEAN
1077 else
1078 POICE=PTYPE
1079 CJCLR(J,1)=CJCLR(J,1)+(S0*COSZ)*POICE
1080 CJCLR(J,2)=CJCLR(J,2)+(SNP0CL(J)*COSZ)*POICE
1081 CJCLR(J,4)=CJCLR(J,4)+(SRHRCL(J)*COSZ)*POICE
1082 CJCLR(J,5)=CJCLR(J,5)+(SRDFLB(1)*COSZ)*POICE
1083 CJCLR(J,6)=CJCLR(J,6)+TRINCL(J)*POICE
1084 CJCLR(J,8)=CJCLR(J,8)-TRP0CL(J)*POICE
1085 CJCLR(J,9)=CJCLR(J,9)-TRP1CL(J)*POICE
1086 CJCLR(J,3)=CJCLR(J,3)+(SNP1CL(J)*COSZ)*POICE
1087 CJCLR(J,7)=CJCLR(J,7)+TRHRCL(J)*POICE
1088
1089 endif
1090 599 continue ! ii
1091 endif
1092 if(J.le.-2)then
1093 print *,' Del SW TOA=',SNP0CL(J)-SNFS(I,J,4)
1094 print *,' Del Srf alb=',ALBCL(J)-ALB(I,J,1)
1095 endif
1096 C**** 5305.
1097 C**** END OF MAIN LOOP FOR I INDEX 5306.
1098 C**** 5307.
1099 600 CONTINUE 5345.
1100 C**** 5346.
1101 C**** END OF MAIN LOOP FOR J INDEX 5347.
1102 C**** 5348.
1103 C**** ACCUMULATE THE RADIATION DIAGNOSTICS 5394.
1104 C**** 5395.
1105 700 DO 780 J=1,JM 5396.
1106 DXYPJ=DXYP(J) 5397.
1107 IMAX=IM 5398.
1108 IF(J.EQ.1.OR.J.EQ.JM) IMAX=1 5399.
1109 DO 720 L=1,LM 5400.
1110 ASRHR=0. 5401.
1111 ATRHR=0. 5402.
1112 DO 710 I=1,IMAX 5403.
1113 ASRHR=ASRHR+SRHR(I,J,L+1)*COSZ2(I,J) 5404.
1114 710 ATRHR=ATRHR+TRHR(I,J,L+1) 5405.
1115 AJL(J,L,9)=AJL(J,L,9)+ASRHR 5406.
1116 720 AJL(J,L,10)=AJL(J,L,10)+ATRHR 5407.
1117 ASNFS1=0. 5408.
1118 BSNFS1=0. 5409.
1119 CSNFS1=0. 5410.
1120 ATNFS1=0. 5411.
1121 BTNFS1=0. 5412.
1122 CTNFS1=0. 5413.
1123 DO 770 I=1,IMAX 5414.
1124 SP=P(I,J) 5415.
1125 COSZ=COSZ2(I,J) 5416.
1126 PLAND=FDATA(I,J,2) 5417.
1127 PWATER=1.-PLAND
1128 POICE=ODATA(I,J,2)*(1.-PLAND) 5418.
1129 POCEAN=(1.-PLAND)-POICE 5419.
1130 if(POCEAN.LE.1.E-5)then
1131 POCEAN=0.
1132 POICE=PWATER
1133 endif
1134 JR=J
1135 DO 740 LR=1,3 5421.
1136 ASJL(J,LR,3)=ASJL(J,LR,3)+SRHRS(I,J,LR)*COSZ 5422.
1137 740 ASJL(J,LR,4)=ASJL(J,LR,4)+TRHRS(I,J,LR) 5423.
1138 DO 742 KR=1,4 5424.
1139 IF(I.EQ.IJD6(1,KR).AND.J.EQ.IJD6(2,KR)) GO TO 744 5425.
1140 742 CONTINUE 5426.
1141 GO TO 750 5427.
1142 744 IH=IHOUR 5428.
1143 DO 746 INCH=1,INCHM 5429.
1144 IF(IH.GT.24) IH=IH-24 5430.
1145 ADAILY(IH,2,KR)=ADAILY(IH,2,KR)+(1.-SNFS(I,J,4)/S0) 5431.
1146 ADAILY(IH,3,KR)=ADAILY(IH,3,KR)+(1.-ALB(I,J,1)) 5432.
1147 ADAILY(IH,4,KR)=ADAILY(IH,4,KR) 5433.
1148 * +((SNFS(I,J,4)-SNFS(I,J,1))*COSZ-TNFS(I,J,4)+TNFS(I,J,1)) 5434.
1149 746 IH=IH+1 5435.
1150 750 CONTINUE 5436.
1151 DJ(JR,1)=DJ(JR,1)+(S0*COSZ)*DXYPJ 5440.
1152 DJ(JR,2)=DJ(JR,2)+(SNFS(I,J,4)*COSZ)*DXYPJ 5444.
1153 DJ(JR,3)=DJ(JR,3)+(SNFS(I,J,1)*COSZ)*DXYPJ 5448.
1154 DJ(JR,5)=DJ(JR,5)+(SRHR(I,J,1)*COSZ/(ALB(I,J,1)+1.E-20))*DXYPJ 5452.
1155 DJ(JR,6)=DJ(JR,6)+(SRHR(I,J,1)*COSZ)*DXYPJ 5456.
1156 DJ(JR,55)=DJ(JR,55)+BTMPW(I,J)*DXYPJ 5460.
1157 DJ(JR,67)=DJ(JR,67)+TRINCG(I,J)*DXYPJ 5464.
1158 DJ(JR,70)=DJ(JR,70)-TNFS(I,J,4)*DXYPJ 5468.
1159 C *******
1160 NCLR(J)=NCLR(J)+1
1161 C *********
1162 DJ(JR,71)=DJ(JR,71)-TNFS(I,J,1)*DXYPJ 5472.
1163 AIJ(I,J,21)=AIJ(I,J,21)-TNFS(I,J,4) 5478.
1164 AIJ(I,J,24)=AIJ(I,J,24)+(SNFS(I,J,4)*COSZ) 5479.
1165 AIJ(I,J,25)=AIJ(I,J,25)+(S0*COSZ) 5480.
1166 AIJ(I,J,26)=AIJ(I,J,26)+(SRHR(I,J,1)*COSZ) 5481.
1167 AIJ(I,J,27)=AIJ(I,J,27)+(SRHR(I,J,1)*COSZ/(ALB(I,J,1)+1.E-20)) 5482.
1168 AIJ(I,J,44)=AIJ(I,J,44)+BTMPW(I,J) 5483.
1169 AIJ(I,J,45)=AIJ(I,J,45)+S0*COSZ*ALB(I,J,2) 5484.
1170 770 CONTINUE 5485.
1171 780 CONTINUE 5492.
1172 IF(JM.NE.24) GO TO 800 5493.
1173 DO 790 L=1,LM 5494.
1174 DO 790 I=1,IM 5495.
1175 AIL(I,L,7)=AIL(I,L,7)+((SRHR(I,11,L+1)*COSZ2(I,11)+ 5496.
1176 * TRHR(I,11,L+1))*DXYP(11)+(SRHR(I,12,L+1)*COSZ2(I,12)+ 5497.
1177 * TRHR(I,12,L+1))*DXYP(12)+(SRHR(I,13,L+1)*COSZ2(I,13)+ 5498.
1178 * TRHR(I,13,L+1))*DXYP(13)) 5499.
1179 AIL(I,L,11)=AIL(I,L,11)+(SRHR(I,19,L+1)*COSZ2(I,19)+ 5500.
1180 * TRHR(I,19,L+1))*DXYP(19) 5501.
1181 790 AIL(I,L,15)=AIL(I,L,15)+(SRHR(I,21,L+1)*COSZ2(I,21)+ 5502.
1182 * TRHR(I,21,L+1))*DXYP(21) 5503.
1183 C**** 5504.
1184 C**** UPDATE THE TEMPERATURES BY RADIATION 5505.
1185 C**** 5506.
1186 800 DO 820 J=1,JM 5507.
1187 IMAX=IM 5508.
1188 IF(J.EQ.1.OR.J.EQ.JM) IMAX=1 5509.
1189 DO 820 LR=1,3 5510.
1190 DO 820 I=1,IMAX 5511.
1191 820 RQT(I,J,LR)=RQT(I,J,LR)+(SRHRS(I,J,LR)*COSZ2(I,J) 5512.
1192 * +TRHRS(I,J,LR))*COE(LR+LM) 5513.
1193 840 DO 860 J=1,JM 5514.
1194 #if ( defined CLM )
1195 dsw4clm(j)=DSWSRF(j)*COSZ1(1,j)
1196 dlw4clm(j)=DLWSRF(j)
1197 swinr4clm(j)=DSWNIR(j)*COSZ1(1,j)
1198 swvis4clm(j)=DSWVIS(j)*COSZ1(1,j)
1199 c For TEM
1200 swtd4tem(j)=swtd4tem(j)+S0*COSZ1(1,j)
1201 swsd4tem(j)=swsd4tem(j)+DSWSRF(j)*COSZ1(1,j)
1202 nradd4tem(j)=nradd4tem(j)+1
1203 #endif
1204 IMAX=IM 5515.
1205 IF(J.EQ.1.OR.J.EQ.JM) IMAX=1 5516.
1206 DO 860 L=1,LM 5517.
1207 DO 860 I=1,IMAX 5518.
1208 860 T(I,J,L)=T(I,J,L)+(SRHR(I,J,L+1)*COSZ1(I,J)+TRHR(I,J,L+1)) 5519.
1209 * *COE(L)/(P(I,J)*PK(I,J,L)) 5520.
1210 RETURN 5521.
1211 END 5522.

  ViewVC Help
Powered by ViewVC 1.1.22