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

Annotation of /MITgcm_contrib/jscott/igsm/src/radiagso_clm.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: +35 -19 lines
bring igsm atmos code up to date

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

  ViewVC Help
Powered by ViewVC 1.1.22