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

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

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


Revision 1.3 - (show annotations) (download)
Mon Apr 23 21:20:18 2007 UTC (18 years, 3 months ago) by jscott
Branch: MAIN
CVS Tags: HEAD
Changes since 1.2: +28 -15 lines
bring igsm atmos code up to date

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

  ViewVC Help
Powered by ViewVC 1.1.22