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

Annotation 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 - (hide 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 jscott 1.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 jscott 1.2 #include "AGRID.h"
84 jscott 1.1 #endif
85 jscott 1.3 dimension SWNET(jm0,2),SWIN(jm0,2)
86 jscott 1.1
87     #if ( defined CLM )
88 jscott 1.3 #include "CLM.h"
89 jscott 1.1 #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 jscott 1.3 ! common/TSUR/TSURFC(JM0,0:13),TSURFT(JM0),TSURFD(JM0),DTSURF(JM0)
105     ! *,cfcld(JM0,3)
106     #include "TSRF.COM"
107 jscott 1.1 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 jscott 1.3 DTSURFAV=DTSURFAV+DT2MGL(J)*DXYP(j)
341 jscott 1.1 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 jscott 1.3 print 9456,DT2MGL
426 jscott 1.1 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 jscott 1.3 SWIN(j,1)=0.0
493     SWNET(j,1)=0.0
494     SWIN(j,2)=0.0
495     SWNET(j,2)=0.0
496 jscott 1.1 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 jscott 1.3 SWIN(j,1)=SRDFLB(1)
873     SWNET(j,1)=SRNFLB(1)
874 jscott 1.1 #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 jscott 1.3 SWIN(j,2)=SRDFLB(1)
894     SWNET(j,2)=SRNFLB(1)
895 jscott 1.1 #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 jscott 1.3 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 jscott 1.1 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 jscott 1.3 #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 jscott 1.1 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