Context Navigation

icarus.F @ 1

Last change on this file since 1 was 1, checked in by emillour, 14 years ago
Import initial LMDZ5
File size: 42.8 KB

Rev	Line
[1]	1	SUBROUTINE ICARUS(
	2	& debug,
	3	& debugcol,
	4	& npoints,
	5	& sunlit,
	6	& nlev,
	7	& ncol,
	8	& pfull,
	9	& phalf,
	10	& qv,
	11	& cc,
	12	& conv,
	13	& dtau_s,
	14	& dtau_c,
	15	& top_height,
	16	& top_height_direction,
	17	& overlap,
	18	& frac_out,
	19	& skt,
	20	& emsfc_lw,
	21	& at,
	22	& dem_s,
	23	& dem_c,
	24	& fq_isccp,
	25	& totalcldarea,
	26	& meanptop,
	27	& meantaucld,
	28	& meanalbedocld,
	29	& meantb,
	30	& meantbclr,
	31	& boxtau,
	32	& boxptop
	33	&)
	34
	35	!$Id: icarus.f,v 4.1 2010/05/27 16:30:18 hadmw Exp $
	36
	37	! ***************************COPYRIGHT**************************
	38	! (c) 2009, Lawrence Livermore National Security Limited Liability
	39	! Corporation.
	40	! All rights reserved.
	41	!
	42	! Redistribution and use in source and binary forms, with or without
	43	! modification, are permitted provided that the
	44	! following conditions are met:
	45	!
	46	! * Redistributions of source code must retain the above
	47	! copyright notice, this list of conditions and the following
	48	! disclaimer.
	49	! * Redistributions in binary form must reproduce the above
	50	! copyright notice, this list of conditions and the following
	51	! disclaimer in the documentation and/or other materials
	52	! provided with the distribution.
	53	! * Neither the name of the Lawrence Livermore National Security
	54	! Limited Liability Corporation nor the names of its
	55	! contributors may be used to endorse or promote products
	56	! derived from this software without specific prior written
	57	! permission.
	58	!
	59	! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
	60	! "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
	61	! LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
	62	! A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
	63	! OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
	64	! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
	65	! LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
	66	! DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
	67	! THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
	68	! (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
	69	! OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
	70	!
	71	! ***************************COPYRIGHT*****************************
	72	! ***************************COPYRIGHT*****************************
	73	! ***************************COPYRIGHT*****************************
	74	! ***************************COPYRIGHT*****************************
	75
	76	implicit none
	77
	78	! NOTE: the maximum number of levels and columns is set by
	79	! the following parameter statement
	80
	81	INTEGER ncolprint
	82
	83	! -----
	84	! Input
	85	! -----
	86
	87	INTEGER npoints ! number of model points in the horizontal
	88	INTEGER nlev ! number of model levels in column
	89	INTEGER ncol ! number of subcolumns
	90
	91	INTEGER sunlit(npoints) ! 1 for day points, 0 for night time
	92
	93	REAL pfull(npoints,nlev)
	94	! pressure of full model levels (Pascals)
	95	! pfull(npoints,1) is top level of model
	96	! pfull(npoints,nlev) is bot of model
	97
	98	REAL phalf(npoints,nlev+1)
	99	! pressure of half model levels (Pascals)
	100	! phalf(npoints,1) is top of model
	101	! phalf(npoints,nlev+1) is the surface pressure
	102
	103	REAL qv(npoints,nlev)
	104	! water vapor specific humidity (kg vapor/ kg air)
	105	! on full model levels
	106
	107	REAL cc(npoints,nlev)
	108	! input cloud cover in each model level (fraction)
	109	! NOTE: This is the HORIZONTAL area of each
	110	! grid box covered by clouds
	111
	112	REAL conv(npoints,nlev)
	113	! input convective cloud cover in each model
	114	! level (fraction)
	115	! NOTE: This is the HORIZONTAL area of each
	116	! grid box covered by convective clouds
	117
	118	REAL dtau_s(npoints,nlev)
	119	! mean 0.67 micron optical depth of stratiform
	120	! clouds in each model level
	121	! NOTE: this the cloud optical depth of only the
	122	! cloudy part of the grid box, it is not weighted
	123	! with the 0 cloud optical depth of the clear
	124	! part of the grid box
	125
	126	REAL dtau_c(npoints,nlev)
	127	! mean 0.67 micron optical depth of convective
	128	! clouds in each
	129	! model level. Same note applies as in dtau_s.
	130
	131	INTEGER overlap ! overlap type
	132	! 1=max
	133	! 2=rand
	134	! 3=max/rand
	135
	136	INTEGER top_height ! 1 = adjust top height using both a computed
	137	! infrared brightness temperature and the visible
	138	! optical depth to adjust cloud top pressure. Note
	139	! that this calculation is most appropriate to compare
	140	! to ISCCP data during sunlit hours.
	141	! 2 = do not adjust top height, that is cloud top
	142	! pressure is the actual cloud top pressure
	143	! in the model
	144	! 3 = adjust top height using only the computed
	145	! infrared brightness temperature. Note that this
	146	! calculation is most appropriate to compare to ISCCP
	147	! IR only algortihm (i.e. you can compare to nighttime
	148	! ISCCP data with this option)
	149
	150	INTEGER top_height_direction ! direction for finding atmosphere pressure level
	151	! with interpolated temperature equal to the radiance
	152	! determined cloud-top temperature
	153	!
	154	! 1 = find the lowest altitude (highest pressure) level
	155	! with interpolated temperature equal to the radiance
	156	! determined cloud-top temperature
	157	!
	158	! 2 = find the highest altitude (lowest pressure) level
	159	! with interpolated temperature equal to the radiance
	160	! determined cloud-top temperature
	161	!
	162	! ONLY APPLICABLE IF top_height EQUALS 1 or 3
	163	! !
	164	! 1 = old setting: matches all versions of
	165	! ISCCP simulator with versions numbers 3.5.1 and lower
	166	!
	167	! 2 = default setting: for version numbers 4.0 and higher
	168	!
	169	! The following input variables are used only if top_height = 1 or top_height = 3
	170	!
	171	REAL skt(npoints) ! skin Temperature (K)
	172	REAL emsfc_lw ! 10.5 micron emissivity of surface (fraction)
	173	REAL at(npoints,nlev) ! temperature in each model level (K)
	174	REAL dem_s(npoints,nlev) ! 10.5 micron longwave emissivity of stratiform
	175	! clouds in each
	176	! model level. Same note applies as in dtau_s.
	177	REAL dem_c(npoints,nlev) ! 10.5 micron longwave emissivity of convective
	178	! clouds in each
	179	! model level. Same note applies as in dtau_s.
	180
	181	REAL frac_out(npoints,ncol,nlev) ! boxes gridbox divided up into
	182	! Equivalent of BOX in original version, but
	183	! indexed by column then row, rather than
	184	! by row then column
	185
	186
	187
	188	! ------
	189	! Output
	190	! ------
	191
	192	REAL fq_isccp(npoints,7,7) ! the fraction of the model grid box covered by
	193	! each of the 49 ISCCP D level cloud types
	194
	195	REAL totalcldarea(npoints) ! the fraction of model grid box columns
	196	! with cloud somewhere in them. NOTE: This diagnostic
	197	! does not count model clouds with tau < isccp_taumin
	198	! Thus this diagnostic does not equal the sum over all entries of fq_isccp.
	199	! However, this diagnostic does equal the sum over entries of fq_isccp with
	200	! itau = 2:7 (omitting itau = 1)
	201
	202
	203	! The following three means are averages only over the cloudy areas with tau > isccp_taumin.
	204	! If no clouds with tau > isccp_taumin are in grid box all three quantities should equal zero.
	205
	206	REAL meanptop(npoints) ! mean cloud top pressure (mb) - linear averaging
	207	! in cloud top pressure.
	208
	209	REAL meantaucld(npoints) ! mean optical thickness
	210	! linear averaging in albedo performed.
	211
	212	real meanalbedocld(npoints) ! mean cloud albedo
	213	! linear averaging in albedo performed
	214
	215	real meantb(npoints) ! mean all-sky 10.5 micron brightness temperature
	216
	217	real meantbclr(npoints) ! mean clear-sky 10.5 micron brightness temperature
	218
	219	REAL boxtau(npoints,ncol) ! optical thickness in each column
	220
	221	REAL boxptop(npoints,ncol) ! cloud top pressure (mb) in each column
	222
	223
	224	!
	225	! ------
	226	! Working variables added when program updated to mimic Mark Webb's PV-Wave code
	227	! ------
	228
	229	REAL dem(npoints,ncol),bb(npoints) ! working variables for 10.5 micron longwave
	230	! emissivity in part of
	231	! gridbox under consideration
	232
	233	REAL ptrop(npoints)
	234	REAL attrop(npoints)
	235	REAL attropmin (npoints)
	236	REAL atmax(npoints)
	237	REAL btcmin(npoints)
	238	REAL transmax(npoints)
	239
	240	INTEGER i,j,ilev,ibox,itrop(npoints)
	241	INTEGER ipres(npoints)
	242	INTEGER itau(npoints),ilev2
	243	INTEGER acc(nlev,ncol)
	244	INTEGER match(npoints,nlev-1)
	245	INTEGER nmatch(npoints)
	246	INTEGER levmatch(npoints,ncol)
	247
	248	!variables needed for water vapor continuum absorption
	249	real fluxtop_clrsky(npoints),trans_layers_above_clrsky(npoints)
	250	real taumin(npoints)
	251	real dem_wv(npoints,nlev), wtmair, wtmh20, Navo, grav, pstd, t0
	252	real press(npoints), dpress(npoints), atmden(npoints)
	253	real rvh20(npoints), wk(npoints), rhoave(npoints)
	254	real rh20s(npoints), rfrgn(npoints)
	255	real tmpexp(npoints),tauwv(npoints)
	256
	257	character*1 cchar(6),cchar_realtops(6)
	258	integer icycle
	259	REAL tau(npoints,ncol)
	260	LOGICAL box_cloudy(npoints,ncol)
	261	REAL tb(npoints,ncol)
	262	REAL ptop(npoints,ncol)
	263	REAL emcld(npoints,ncol)
	264	REAL fluxtop(npoints,ncol)
	265	REAL trans_layers_above(npoints,ncol)
	266	real isccp_taumin,fluxtopinit(npoints),tauir(npoints)
	267	REAL albedocld(npoints,ncol)
	268	real boxarea
	269	integer debug ! set to non-zero value to print out inputs
	270	! with step debug
	271	integer debugcol ! set to non-zero value to print out column
	272	! decomposition with step debugcol
	273	integer rangevec(npoints),rangeerror
	274
	275	integer index1(npoints),num1,jj,k1,k2
	276	real rec2p13,tauchk,logp,logp1,logp2,atd
	277	real output_missing_value
	278
	279	character*10 ftn09
	280
	281	DATA isccp_taumin / 0.3 /
	282	DATA output_missing_value / -1.E+30 /
	283	DATA cchar / ' ','-','1','+','I','+'/
	284	DATA cchar_realtops / ' ',' ','1','1','I','I'/
	285
	286	! ------ End duplicate definitions common to wrapper routine
	287
	288	tauchk = -1.*log(0.9999999)
	289	rec2p13=1./2.13
	290
	291	ncolprint=0
	292
	293	if ( debug.ne.0 ) then
	294	j=1
	295	write(6,'(a10)') 'j='
	296	write(6,'(8I10)') j
	297	write(6,'(a10)') 'debug='
	298	write(6,'(8I10)') debug
	299	write(6,'(a10)') 'debugcol='
	300	write(6,'(8I10)') debugcol
	301	write(6,'(a10)') 'npoints='
	302	write(6,'(8I10)') npoints
	303	write(6,'(a10)') 'nlev='
	304	write(6,'(8I10)') nlev
	305	write(6,'(a10)') 'ncol='
	306	write(6,'(8I10)') ncol
	307	write(6,'(a11)') 'top_height='
	308	write(6,'(8I10)') top_height
	309	write(6,'(a21)') 'top_height_direction='
	310	write(6,'(8I10)') top_height_direction
	311	write(6,'(a10)') 'overlap='
	312	write(6,'(8I10)') overlap
	313	write(6,'(a10)') 'emsfc_lw='
	314	write(6,'(8f10.2)') emsfc_lw
	315	do j=1,npoints,debug
	316	write(6,'(a10)') 'j='
	317	write(6,'(8I10)') j
	318	write(6,'(a10)') 'sunlit='
	319	write(6,'(8I10)') sunlit(j)
	320	write(6,'(a10)') 'pfull='
	321	write(6,'(8f10.2)') (pfull(j,i),i=1,nlev)
	322	write(6,'(a10)') 'phalf='
	323	write(6,'(8f10.2)') (phalf(j,i),i=1,nlev+1)
	324	write(6,'(a10)') 'qv='
	325	write(6,'(8f10.3)') (qv(j,i),i=1,nlev)
	326	write(6,'(a10)') 'cc='
	327	write(6,'(8f10.3)') (cc(j,i),i=1,nlev)
	328	write(6,'(a10)') 'conv='
	329	write(6,'(8f10.2)') (conv(j,i),i=1,nlev)
	330	write(6,'(a10)') 'dtau_s='
	331	write(6,'(8g12.5)') (dtau_s(j,i),i=1,nlev)
	332	write(6,'(a10)') 'dtau_c='
	333	write(6,'(8f10.2)') (dtau_c(j,i),i=1,nlev)
	334	write(6,'(a10)') 'skt='
	335	write(6,'(8f10.2)') skt(j)
	336	write(6,'(a10)') 'at='
	337	write(6,'(8f10.2)') (at(j,i),i=1,nlev)
	338	write(6,'(a10)') 'dem_s='
	339	write(6,'(8f10.3)') (dem_s(j,i),i=1,nlev)
	340	write(6,'(a10)') 'dem_c='
	341	write(6,'(8f10.3)') (dem_c(j,i),i=1,nlev)
	342	enddo
	343	endif
	344
	345	! ---------------------------------------------------!
	346
	347	if (ncolprint.ne.0) then
	348	do j=1,npoints,1000
	349	write(6,'(a10)') 'j='
	350	write(6,'(8I10)') j
	351	enddo
	352	endif
	353
	354	if (top_height .eq. 1 .or. top_height .eq. 3) then
	355
	356	do j=1,npoints
	357	ptrop(j)=5000.
	358	attropmin(j) = 400.
	359	atmax(j) = 0.
	360	attrop(j) = 120.
	361	itrop(j) = 1
	362	enddo
	363
	364	do 12 ilev=1,nlev
	365	do j=1,npoints
	366	if (pfull(j,ilev) .lt. 40000. .and.
	367	& pfull(j,ilev) .gt. 5000. .and.
	368	& at(j,ilev) .lt. attropmin(j)) then
	369	ptrop(j) = pfull(j,ilev)
	370	attropmin(j) = at(j,ilev)
	371	attrop(j) = attropmin(j)
	372	itrop(j)=ilev
	373	end if
	374	enddo
	375	12 continue
	376
	377	do 13 ilev=1,nlev
	378	do j=1,npoints
	379	if (at(j,ilev) .gt. atmax(j) .and.
	380	& ilev .ge. itrop(j)) atmax(j)=at(j,ilev)
	381	enddo
	382	13 continue
	383
	384	end if
	385
	386
	387	if (top_height .eq. 1 .or. top_height .eq. 3) then
	388	do j=1,npoints
	389	meantb(j) = 0.
	390	meantbclr(j) = 0.
	391	end do
	392	else
	393	do j=1,npoints
	394	meantb(j) = output_missing_value
	395	meantbclr(j) = output_missing_value
	396	end do
	397	end if
	398
	399	! -----------------------------------------------------!
	400
	401	! ---------------------------------------------------!
	402
	403	do ilev=1,nlev
	404	do j=1,npoints
	405
	406	rangevec(j)=0
	407
	408	if (cc(j,ilev) .lt. 0. .or. cc(j,ilev) .gt. 1.) then
	409	! error = cloud fraction less than zero
	410	! error = cloud fraction greater than 1
	411	rangevec(j)=rangevec(j)+1
	412	endif
	413
	414	if (conv(j,ilev) .lt. 0. .or. conv(j,ilev) .gt. 1.) then
	415	! ' error = convective cloud fraction less than zero'
	416	! ' error = convective cloud fraction greater than 1'
	417	rangevec(j)=rangevec(j)+2
	418	endif
	419
	420	if (dtau_s(j,ilev) .lt. 0.) then
	421	! ' error = stratiform cloud opt. depth less than zero'
	422	rangevec(j)=rangevec(j)+4
	423	endif
	424
	425	if (dtau_c(j,ilev) .lt. 0.) then
	426	! ' error = convective cloud opt. depth less than zero'
	427	rangevec(j)=rangevec(j)+8
	428	endif
	429
	430	if (dem_s(j,ilev) .lt. 0. .or. dem_s(j,ilev) .gt. 1.) then
	431	! ' error = stratiform cloud emissivity less than zero'
	432	! ' error = stratiform cloud emissivity greater than 1'
	433	rangevec(j)=rangevec(j)+16
	434	endif
	435
	436	if (dem_c(j,ilev) .lt. 0. .or. dem_c(j,ilev) .gt. 1.) then
	437	! ' error = convective cloud emissivity less than zero'
	438	! ' error = convective cloud emissivity greater than 1'
	439	rangevec(j)=rangevec(j)+32
	440	endif
	441	enddo
	442
	443	rangeerror=0
	444	do j=1,npoints
	445	rangeerror=rangeerror+rangevec(j)
	446	enddo
	447
	448	if (rangeerror.ne.0) then
	449	write (6,*) 'Input variable out of range'
	450	write (6,*) 'rangevec:'
	451	write (6,*) rangevec
	452	call flush(6)
	453	STOP
	454	endif
	455	enddo
	456
	457	!
	458	! ---------------------------------------------------!
	459
	460
	461	!
	462	! ---------------------------------------------------!
	463	! COMPUTE CLOUD OPTICAL DEPTH FOR EACH COLUMN and
	464	! put into vector tau
	465
	466	!initialize tau and albedocld to zero
	467	do 15 ibox=1,ncol
	468	do j=1,npoints
	469	tau(j,ibox)=0.
	470	albedocld(j,ibox)=0.
	471	boxtau(j,ibox)=output_missing_value
	472	boxptop(j,ibox)=output_missing_value
	473	box_cloudy(j,ibox)=.false.
	474	enddo
	475	15 continue
	476
	477	!compute total cloud optical depth for each column
	478	do ilev=1,nlev
	479	!increment tau for each of the boxes
	480	do ibox=1,ncol
	481	do j=1,npoints
	482	if (frac_out(j,ibox,ilev).eq.1) then
	483	tau(j,ibox)=tau(j,ibox)
	484	& + dtau_s(j,ilev)
	485	endif
	486	if (frac_out(j,ibox,ilev).eq.2) then
	487	tau(j,ibox)=tau(j,ibox)
	488	& + dtau_c(j,ilev)
	489	end if
	490	enddo
	491	enddo ! ibox
	492	enddo ! ilev
	493	if (ncolprint.ne.0) then
	494
	495	do j=1,npoints ,1000
	496	write(6,'(a10)') 'j='
	497	write(6,'(8I10)') j
	498	write(6,'(i2,1X,8(f7.2,1X))')
	499	& ilev,
	500	& (tau(j,ibox),ibox=1,ncolprint)
	501	enddo
	502	endif
	503	!
	504	! ---------------------------------------------------!
	505
	506
	507
	508	!
	509	! ---------------------------------------------------!
	510	! COMPUTE INFRARED BRIGHTNESS TEMPERUATRES
	511	! AND CLOUD TOP TEMPERATURE SATELLITE SHOULD SEE
	512	!
	513	! again this is only done if top_height = 1 or 3
	514	!
	515	! fluxtop is the 10.5 micron radiance at the top of the
	516	! atmosphere
	517	! trans_layers_above is the total transmissivity in the layers
	518	! above the current layer
	519	! fluxtop_clrsky(j) and trans_layers_above_clrsky(j) are the clear
	520	! sky versions of these quantities.
	521
	522	if (top_height .eq. 1 .or. top_height .eq. 3) then
	523
	524
	525	!----------------------------------------------------------------------
	526	!
	527	! DO CLEAR SKY RADIANCE CALCULATION FIRST
	528	!
	529	!compute water vapor continuum emissivity
	530	!this treatment follows Schwarkzopf and Ramasamy
	531	!JGR 1999,vol 104, pages 9467-9499.
	532	!the emissivity is calculated at a wavenumber of 955 cm-1,
	533	!or 10.47 microns
	534	wtmair = 28.9644
	535	wtmh20 = 18.01534
	536	Navo = 6.023E+23
	537	grav = 9.806650E+02
	538	pstd = 1.013250E+06
	539	t0 = 296.
	540	if (ncolprint .ne. 0)
	541	& write(6,*) 'ilev pw (kg/m2) tauwv(j) dem_wv'
	542	do 125 ilev=1,nlev
	543	do j=1,npoints
	544	!press and dpress are dyne/cm2 = Pascals *10
	545	press(j) = pfull(j,ilev)*10.
	546	dpress(j) = (phalf(j,ilev+1)-phalf(j,ilev))*10
	547	!atmden = g/cm2 = kg/m2 / 10
	548	atmden(j) = dpress(j)/grav
	549	rvh20(j) = qv(j,ilev)*wtmair/wtmh20
	550	wk(j) = rvh20(j)Navoatmden(j)/wtmair
	551	rhoave(j) = (press(j)/pstd)*(t0/at(j,ilev))
	552	rh20s(j) = rvh20(j)*rhoave(j)
	553	rfrgn(j) = rhoave(j)-rh20s(j)
	554	tmpexp(j) = exp(-0.02*(at(j,ilev)-t0))
	555	tauwv(j) = wk(j)1.e-20(
	556	& (0.0224697rh20s(j)tmpexp(j)) +
	557	& (3.41817e-7rfrgn(j)) )0.98
	558	dem_wv(j,ilev) = 1. - exp( -1. * tauwv(j))
	559	enddo
	560	if (ncolprint .ne. 0) then
	561	do j=1,npoints ,1000
	562	write(6,'(a10)') 'j='
	563	write(6,'(8I10)') j
	564	write(6,'(i2,1X,3(f8.3,3X))') ilev,
	565	& qv(j,ilev)*(phalf(j,ilev+1)-phalf(j,ilev))/(grav/100.),
	566	& tauwv(j),dem_wv(j,ilev)
	567	enddo
	568	endif
	569	125 continue
	570
	571	!initialize variables
	572	do j=1,npoints
	573	fluxtop_clrsky(j) = 0.
	574	trans_layers_above_clrsky(j)=1.
	575	enddo
	576
	577	do ilev=1,nlev
	578	do j=1,npoints
	579
	580	! Black body emission at temperature of the layer
	581
	582	bb(j)=1 / ( exp(1307.27/at(j,ilev)) - 1. )
	583	!bb(j)= 5.67e-8at(j,ilev)*4
	584
	585	! increase TOA flux by flux emitted from layer
	586	! times total transmittance in layers above
	587
	588	fluxtop_clrsky(j) = fluxtop_clrsky(j)
	589	& + dem_wv(j,ilev)bb(j)trans_layers_above_clrsky(j)
	590
	591	! update trans_layers_above with transmissivity
	592	! from this layer for next time around loop
	593
	594	trans_layers_above_clrsky(j)=
	595	& trans_layers_above_clrsky(j)*(1.-dem_wv(j,ilev))
	596
	597
	598	enddo
	599	if (ncolprint.ne.0) then
	600	do j=1,npoints ,1000
	601	write(6,'(a10)') 'j='
	602	write(6,'(8I10)') j
	603	write (6,'(a)') 'ilev:'
	604	write (6,'(I2)') ilev
	605
	606	write (6,'(a)')
	607	& 'emiss_layer,100.bb(j),100.f,total_trans:'
	608	write (6,'(4(f7.2,1X))') dem_wv(j,ilev),100.*bb(j),
	609	& 100.*fluxtop_clrsky(j),trans_layers_above_clrsky(j)
	610	enddo
	611	endif
	612
	613	enddo !loop over level
	614
	615	do j=1,npoints
	616	!add in surface emission
	617	bb(j)=1/( exp(1307.27/skt(j)) - 1. )
	618	!bb(j)=5.67e-8skt(j)*4
	619
	620	fluxtop_clrsky(j) = fluxtop_clrsky(j) + emsfc_lw * bb(j)
	621	& * trans_layers_above_clrsky(j)
	622
	623	!clear sky brightness temperature
	624	meantbclr(j) = 1307.27/(log(1.+(1./fluxtop_clrsky(j))))
	625
	626	enddo
	627
	628	if (ncolprint.ne.0) then
	629	do j=1,npoints ,1000
	630	write(6,'(a10)') 'j='
	631	write(6,'(8I10)') j
	632	write (6,'(a)') 'id:'
	633	write (6,'(a)') 'surface'
	634
	635	write (6,'(a)') 'emsfc,100.bb(j),100.f,total_trans:'
	636	write (6,'(5(f7.2,1X))') emsfc_lw,100.*bb(j),
	637	& 100.*fluxtop_clrsky(j),
	638	& trans_layers_above_clrsky(j), meantbclr(j)
	639	enddo
	640	endif
	641
	642
	643	!
	644	! END OF CLEAR SKY CALCULATION
	645	!
	646	!----------------------------------------------------------------
	647
	648
	649
	650	if (ncolprint.ne.0) then
	651
	652	do j=1,npoints ,1000
	653	write(6,'(a10)') 'j='
	654	write(6,'(8I10)') j
	655	write (6,'(a)') 'ts:'
	656	write (6,'(8f7.2)') (skt(j),ibox=1,ncolprint)
	657
	658	write (6,'(a)') 'ta_rev:'
	659	write (6,'(8f7.2)')
	660	& ((at(j,ilev2),ibox=1,ncolprint),ilev2=1,nlev)
	661
	662	enddo
	663	endif
	664	!loop over columns
	665	do ibox=1,ncol
	666	do j=1,npoints
	667	fluxtop(j,ibox)=0.
	668	trans_layers_above(j,ibox)=1.
	669	enddo
	670	enddo
	671
	672	do ilev=1,nlev
	673	do j=1,npoints
	674	! Black body emission at temperature of the layer
	675
	676	bb(j)=1 / ( exp(1307.27/at(j,ilev)) - 1. )
	677	!bb(j)= 5.67e-8at(j,ilev)*4
	678	enddo
	679
	680	do ibox=1,ncol
	681	do j=1,npoints
	682
	683	! emissivity for point in this layer
	684	if (frac_out(j,ibox,ilev).eq.1) then
	685	dem(j,ibox)= 1. -
	686	& ( (1. - dem_wv(j,ilev)) * (1. - dem_s(j,ilev)) )
	687	else if (frac_out(j,ibox,ilev).eq.2) then
	688	dem(j,ibox)= 1. -
	689	& ( (1. - dem_wv(j,ilev)) * (1. - dem_c(j,ilev)) )
	690	else
	691	dem(j,ibox)= dem_wv(j,ilev)
	692	end if
	693
	694
	695	! increase TOA flux by flux emitted from layer
	696	! times total transmittance in layers above
	697
	698	fluxtop(j,ibox) = fluxtop(j,ibox)
	699	& + dem(j,ibox) * bb(j)
	700	& * trans_layers_above(j,ibox)
	701
	702	! update trans_layers_above with transmissivity
	703	! from this layer for next time around loop
	704
	705	trans_layers_above(j,ibox)=
	706	& trans_layers_above(j,ibox)*(1.-dem(j,ibox))
	707
	708	enddo ! j
	709	enddo ! ibox
	710
	711	if (ncolprint.ne.0) then
	712	do j=1,npoints,1000
	713	write (6,'(a)') 'ilev:'
	714	write (6,'(I2)') ilev
	715
	716	write(6,'(a10)') 'j='
	717	write(6,'(8I10)') j
	718	write (6,'(a)') 'emiss_layer:'
	719	write (6,'(8f7.2)') (dem(j,ibox),ibox=1,ncolprint)
	720
	721	write (6,'(a)') '100.*bb(j):'
	722	write (6,'(8f7.2)') (100.*bb(j),ibox=1,ncolprint)
	723
	724	write (6,'(a)') '100.*f:'
	725	write (6,'(8f7.2)')
	726	& (100.*fluxtop(j,ibox),ibox=1,ncolprint)
	727
	728	write (6,'(a)') 'total_trans:'
	729	write (6,'(8f7.2)')
	730	& (trans_layers_above(j,ibox),ibox=1,ncolprint)
	731	enddo
	732	endif
	733
	734	enddo ! ilev
	735
	736
	737	do j=1,npoints
	738	!add in surface emission
	739	bb(j)=1/( exp(1307.27/skt(j)) - 1. )
	740	!bb(j)=5.67e-8skt(j)*4
	741	end do
	742
	743	do ibox=1,ncol
	744	do j=1,npoints
	745
	746	!add in surface emission
	747
	748	fluxtop(j,ibox) = fluxtop(j,ibox)
	749	& + emsfc_lw * bb(j)
	750	& * trans_layers_above(j,ibox)
	751
	752	end do
	753	end do
	754
	755	!calculate mean infrared brightness temperature
	756	do ibox=1,ncol
	757	do j=1,npoints
	758	meantb(j) = meantb(j)+1307.27/(log(1.+(1./fluxtop(j,ibox))))
	759	end do
	760	end do
	761	do j=1, npoints
	762	meantb(j) = meantb(j) / real(ncol)
	763	end do
	764
	765	if (ncolprint.ne.0) then
	766
	767	do j=1,npoints ,1000
	768	write(6,'(a10)') 'j='
	769	write(6,'(8I10)') j
	770	write (6,'(a)') 'id:'
	771	write (6,'(a)') 'surface'
	772
	773	write (6,'(a)') 'emiss_layer:'
	774	write (6,'(8f7.2)') (dem(1,ibox),ibox=1,ncolprint)
	775
	776	write (6,'(a)') '100.*bb(j):'
	777	write (6,'(8f7.2)') (100.*bb(j),ibox=1,ncolprint)
	778
	779	write (6,'(a)') '100.*f:'
	780	write (6,'(8f7.2)') (100.*fluxtop(j,ibox),ibox=1,ncolprint)
	781
	782	write (6,'(a)') 'meantb(j):'
	783	write (6,'(8f7.2)') (meantb(j),ibox=1,ncolprint)
	784
	785	end do
	786	endif
	787
	788	!now that you have the top of atmosphere radiance account
	789	!for ISCCP procedures to determine cloud top temperature
	790
	791	!account for partially transmitting cloud recompute flux
	792	!ISCCP would see assuming a single layer cloud
	793	!note choice here of 2.13, as it is primarily ice
	794	!clouds which have partial emissivity and need the
	795	!adjustment performed in this section
	796	!
	797	!If it turns out that the cloud brightness temperature
	798	!is greater than 260K, then the liquid cloud conversion
	799	!factor of 2.56 is used.
	800	!
	801	!Note that this is discussed on pages 85-87 of
	802	!the ISCCP D level documentation (Rossow et al. 1996)
	803
	804	do j=1,npoints
	805	!compute minimum brightness temperature and optical depth
	806	btcmin(j) = 1. / ( exp(1307.27/(attrop(j)-5.)) - 1. )
	807	enddo
	808	do ibox=1,ncol
	809	do j=1,npoints
	810	transmax(j) = (fluxtop(j,ibox)-btcmin(j))
	811	& /(fluxtop_clrsky(j)-btcmin(j))
	812	!note that the initial setting of tauir(j) is needed so that
	813	!tauir(j) has a realistic value should the next if block be
	814	!bypassed
	815	tauir(j) = tau(j,ibox) * rec2p13
	816	taumin(j) = -1. * log(max(min(transmax(j),0.9999999),0.001))
	817
	818	enddo
	819
	820	if (top_height .eq. 1) then
	821	do j=1,npoints
	822	if (transmax(j) .gt. 0.001 .and.
	823	& transmax(j) .le. 0.9999999) then
	824	fluxtopinit(j) = fluxtop(j,ibox)
	825	tauir(j) = tau(j,ibox) *rec2p13
	826	endif
	827	enddo
	828	do icycle=1,2
	829	do j=1,npoints
	830	if (tau(j,ibox) .gt. (tauchk )) then
	831	if (transmax(j) .gt. 0.001 .and.
	832	& transmax(j) .le. 0.9999999) then
	833	emcld(j,ibox) = 1. - exp(-1. * tauir(j) )
	834	fluxtop(j,ibox) = fluxtopinit(j) -
	835	& ((1.-emcld(j,ibox))*fluxtop_clrsky(j))
	836	fluxtop(j,ibox)=max(1.E-06,
	837	& (fluxtop(j,ibox)/emcld(j,ibox)))
	838	tb(j,ibox)= 1307.27
	839	& / (log(1. + (1./fluxtop(j,ibox))))
	840	if (tb(j,ibox) .gt. 260.) then
	841	tauir(j) = tau(j,ibox) / 2.56
	842	end if
	843	end if
	844	end if
	845	enddo
	846	enddo
	847
	848	endif
	849
	850	do j=1,npoints
	851	if (tau(j,ibox) .gt. (tauchk )) then
	852	!cloudy box
	853	!NOTE: tb is the cloud-top temperature not infrared brightness temperature
	854	!at this point in the code
	855	tb(j,ibox)= 1307.27/ (log(1. + (1./fluxtop(j,ibox))))
	856	if (top_height.eq.1.and.tauir(j).lt.taumin(j)) then
	857	tb(j,ibox) = attrop(j) - 5.
	858	tau(j,ibox) = 2.13*taumin(j)
	859	end if
	860	else
	861	!clear sky brightness temperature
	862	tb(j,ibox) = meantbclr(j)
	863	end if
	864	enddo ! j
	865	enddo ! ibox
	866
	867	if (ncolprint.ne.0) then
	868
	869	do j=1,npoints,1000
	870	write(6,'(a10)') 'j='
	871	write(6,'(8I10)') j
	872
	873	write (6,'(a)') 'attrop:'
	874	write (6,'(8f7.2)') (attrop(j))
	875
	876	write (6,'(a)') 'btcmin:'
	877	write (6,'(8f7.2)') (btcmin(j))
	878
	879	write (6,'(a)') 'fluxtop_clrsky*100:'
	880	write (6,'(8f7.2)')
	881	& (100.*fluxtop_clrsky(j))
	882
	883	write (6,'(a)') '100.*f_adj:'
	884	write (6,'(8f7.2)') (100.*fluxtop(j,ibox),ibox=1,ncolprint)
	885
	886	write (6,'(a)') 'transmax:'
	887	write (6,'(8f7.2)') (transmax(ibox),ibox=1,ncolprint)
	888
	889	write (6,'(a)') 'tau:'
	890	write (6,'(8f7.2)') (tau(j,ibox),ibox=1,ncolprint)
	891
	892	write (6,'(a)') 'emcld:'
	893	write (6,'(8f7.2)') (emcld(j,ibox),ibox=1,ncolprint)
	894
	895	write (6,'(a)') 'total_trans:'
	896	write (6,'(8f7.2)')
	897	& (trans_layers_above(j,ibox),ibox=1,ncolprint)
	898
	899	write (6,'(a)') 'total_emiss:'
	900	write (6,'(8f7.2)')
	901	& (1.0-trans_layers_above(j,ibox),ibox=1,ncolprint)
	902
	903	write (6,'(a)') 'total_trans:'
	904	write (6,'(8f7.2)')
	905	& (trans_layers_above(j,ibox),ibox=1,ncolprint)
	906
	907	write (6,'(a)') 'ppout:'
	908	write (6,'(8f7.2)') (tb(j,ibox),ibox=1,ncolprint)
	909	enddo ! j
	910	endif
	911
	912	end if
	913
	914	! ---------------------------------------------------!
	915
	916	!
	917	! ---------------------------------------------------!
	918	! DETERMINE CLOUD TOP PRESSURE
	919	!
	920	! again the 2 methods differ according to whether
	921	! or not you use the physical cloud top pressure (top_height = 2)
	922	! or the radiatively determined cloud top pressure (top_height = 1 or 3)
	923	!
	924
	925	!compute cloud top pressure
	926	do 30 ibox=1,ncol
	927	!segregate according to optical thickness
	928	if (top_height .eq. 1 .or. top_height .eq. 3) then
	929	!find level whose temperature
	930	!most closely matches brightness temperature
	931	do j=1,npoints
	932	nmatch(j)=0
	933	enddo
	934	do 29 k1=1,nlev-1
	935	if (top_height_direction .eq. 2) then
	936	ilev = nlev - k1
	937	else
	938	ilev = k1
	939	end if
	940	!cdir nodep
	941	do j=1,npoints
	942	if (ilev .ge. itrop(j)) then
	943	if ((at(j,ilev) .ge. tb(j,ibox) .and.
	944	& at(j,ilev+1) .le. tb(j,ibox)) .or.
	945	& (at(j,ilev) .le. tb(j,ibox) .and.
	946	& at(j,ilev+1) .ge. tb(j,ibox))) then
	947	nmatch(j)=nmatch(j)+1
	948	match(j,nmatch(j))=ilev
	949	end if
	950	end if
	951	enddo
	952	29 continue
	953
	954	do j=1,npoints
	955	if (nmatch(j) .ge. 1) then
	956	k1 = match(j,nmatch(j))
	957	k2 = k1 + 1
	958	logp1 = log(pfull(j,k1))
	959	logp2 = log(pfull(j,k2))
	960	atd = max(tauchk,abs(at(j,k2) - at(j,k1)))
	961	logp=logp1+(logp2-logp1)*abs(tb(j,ibox)-at(j,k1))/atd
	962	ptop(j,ibox) = exp(logp)
	963	if(abs(pfull(j,k1)-ptop(j,ibox)) .lt.
	964	& abs(pfull(j,k2)-ptop(j,ibox))) then
	965	levmatch(j,ibox)=k1
	966	else
	967	levmatch(j,ibox)=k2
	968	end if
	969	else
	970	if (tb(j,ibox) .le. attrop(j)) then
	971	ptop(j,ibox)=ptrop(j)
	972	levmatch(j,ibox)=itrop(j)
	973	end if
	974	if (tb(j,ibox) .ge. atmax(j)) then
	975	ptop(j,ibox)=pfull(j,nlev)
	976	levmatch(j,ibox)=nlev
	977	end if
	978	end if
	979	enddo ! j
	980
	981	else ! if (top_height .eq. 1 .or. top_height .eq. 3)
	982
	983	do j=1,npoints
	984	ptop(j,ibox)=0.
	985	enddo
	986	do ilev=1,nlev
	987	do j=1,npoints
	988	if ((ptop(j,ibox) .eq. 0. )
	989	& .and.(frac_out(j,ibox,ilev) .ne. 0)) then
	990	ptop(j,ibox)=phalf(j,ilev)
	991	levmatch(j,ibox)=ilev
	992	end if
	993	end do
	994	end do
	995	end if
	996
	997	do j=1,npoints
	998	if (tau(j,ibox) .le. (tauchk )) then
	999	ptop(j,ibox)=0.
	1000	levmatch(j,ibox)=0
	1001	endif
	1002	enddo
	1003
	1004	30 continue
	1005
	1006	!
	1007	!
	1008	! ---------------------------------------------------!
	1009
	1010
	1011	!
	1012	! ---------------------------------------------------!
	1013	! DETERMINE ISCCP CLOUD TYPE FREQUENCIES
	1014	!
	1015	! Now that ptop and tau have been determined,
	1016	! determine amount of each of the 49 ISCCP cloud
	1017	! types
	1018	!
	1019	! Also compute grid box mean cloud top pressure and
	1020	! optical thickness. The mean cloud top pressure and
	1021	! optical thickness are averages over the cloudy
	1022	! area only. The mean cloud top pressure is a linear
	1023	! average of the cloud top pressures. The mean cloud
	1024	! optical thickness is computed by converting optical
	1025	! thickness to an albedo, averaging in albedo units,
	1026	! then converting the average albedo back to a mean
	1027	! optical thickness.
	1028	!
	1029
	1030	!compute isccp frequencies
	1031
	1032	!reset frequencies
	1033	do 38 ilev=1,7
	1034	do 38 ilev2=1,7
	1035	do j=1,npoints !
	1036	if (sunlit(j).eq.1 .or. top_height .eq. 3) then
	1037	fq_isccp(j,ilev,ilev2)= 0.
	1038	else
	1039	fq_isccp(j,ilev,ilev2)= output_missing_value
	1040	end if
	1041	enddo
	1042	38 continue
	1043
	1044	!reset variables need for averaging cloud properties
	1045	do j=1,npoints
	1046	if (sunlit(j).eq.1 .or. top_height .eq. 3) then
	1047	totalcldarea(j) = 0.
	1048	meanalbedocld(j) = 0.
	1049	meanptop(j) = 0.
	1050	meantaucld(j) = 0.
	1051	else
	1052	totalcldarea(j) = output_missing_value
	1053	meanalbedocld(j) = output_missing_value
	1054	meanptop(j) = output_missing_value
	1055	meantaucld(j) = output_missing_value
	1056	end if
	1057	enddo ! j
	1058
	1059	boxarea = 1./real(ncol)
	1060
	1061	do 39 ibox=1,ncol
	1062	do j=1,npoints
	1063
	1064	if (tau(j,ibox) .gt. (tauchk )
	1065	& .and. ptop(j,ibox) .gt. 0.) then
	1066	box_cloudy(j,ibox)=.true.
	1067	endif
	1068
	1069	if (box_cloudy(j,ibox)) then
	1070
	1071	if (sunlit(j).eq.1 .or. top_height .eq. 3) then
	1072
	1073	boxtau(j,ibox) = tau(j,ibox)
	1074
	1075	if (tau(j,ibox) .ge. isccp_taumin) then
	1076	totalcldarea(j) = totalcldarea(j) + boxarea
	1077
	1078	!convert optical thickness to albedo
	1079	albedocld(j,ibox)
	1080	& = (tau(j,ibox)0.895)/((tau(j,ibox)0.895)+6.82)
	1081
	1082	!contribute to averaging
	1083	meanalbedocld(j) = meanalbedocld(j)
	1084	& +albedocld(j,ibox)*boxarea
	1085
	1086	end if
	1087
	1088	endif
	1089
	1090	endif
	1091
	1092	if (sunlit(j).eq.1 .or. top_height .eq. 3) then
	1093
	1094	if (box_cloudy(j,ibox)) then
	1095
	1096	!convert ptop to millibars
	1097	ptop(j,ibox)=ptop(j,ibox) / 100.
	1098
	1099	!save for output cloud top pressure and optical thickness
	1100	boxptop(j,ibox) = ptop(j,ibox)
	1101
	1102	if (tau(j,ibox) .ge. isccp_taumin) then
	1103	meanptop(j) = meanptop(j) + ptop(j,ibox)*boxarea
	1104	end if
	1105
	1106	!reset itau(j), ipres(j)
	1107	itau(j) = 0
	1108	ipres(j) = 0
	1109
	1110	!determine optical depth category
	1111	if (tau(j,ibox) .lt. isccp_taumin) then
	1112	itau(j)=1
	1113	else if (tau(j,ibox) .ge. isccp_taumin
	1114	&
	1115	& .and. tau(j,ibox) .lt. 1.3) then
	1116	itau(j)=2
	1117	else if (tau(j,ibox) .ge. 1.3
	1118	& .and. tau(j,ibox) .lt. 3.6) then
	1119	itau(j)=3
	1120	else if (tau(j,ibox) .ge. 3.6
	1121	& .and. tau(j,ibox) .lt. 9.4) then
	1122	itau(j)=4
	1123	else if (tau(j,ibox) .ge. 9.4
	1124	& .and. tau(j,ibox) .lt. 23.) then
	1125	itau(j)=5
	1126	else if (tau(j,ibox) .ge. 23.
	1127	& .and. tau(j,ibox) .lt. 60.) then
	1128	itau(j)=6
	1129	else if (tau(j,ibox) .ge. 60.) then
	1130	itau(j)=7
	1131	end if
	1132
	1133	!determine cloud top pressure category
	1134	if ( ptop(j,ibox) .gt. 0.
	1135	& .and.ptop(j,ibox) .lt. 180.) then
	1136	ipres(j)=1
	1137	else if(ptop(j,ibox) .ge. 180.
	1138	& .and.ptop(j,ibox) .lt. 310.) then
	1139	ipres(j)=2
	1140	else if(ptop(j,ibox) .ge. 310.
	1141	& .and.ptop(j,ibox) .lt. 440.) then
	1142	ipres(j)=3
	1143	else if(ptop(j,ibox) .ge. 440.
	1144	& .and.ptop(j,ibox) .lt. 560.) then
	1145	ipres(j)=4
	1146	else if(ptop(j,ibox) .ge. 560.
	1147	& .and.ptop(j,ibox) .lt. 680.) then
	1148	ipres(j)=5
	1149	else if(ptop(j,ibox) .ge. 680.
	1150	& .and.ptop(j,ibox) .lt. 800.) then
	1151	ipres(j)=6
	1152	else if(ptop(j,ibox) .ge. 800.) then
	1153	ipres(j)=7
	1154	end if
	1155
	1156	!update frequencies
	1157	if(ipres(j) .gt. 0.and.itau(j) .gt. 0) then
	1158	fq_isccp(j,itau(j),ipres(j))=
	1159	& fq_isccp(j,itau(j),ipres(j))+ boxarea
	1160	end if
	1161
	1162	end if
	1163
	1164	end if
	1165
	1166	enddo ! j
	1167	39 continue
	1168
	1169	!compute mean cloud properties
	1170	do j=1,npoints
	1171	if (totalcldarea(j) .gt. 0.) then
	1172	! code above guarantees that totalcldarea > 0
	1173	! only if sunlit .eq. 1 .or. top_height = 3
	1174	! and applies only to clouds with tau > isccp_taumin
	1175	meanptop(j) = meanptop(j) / totalcldarea(j)
	1176	meanalbedocld(j) = meanalbedocld(j) / totalcldarea(j)
	1177	meantaucld(j) = (6.82/((1./meanalbedocld(j))-1.))**(1./0.895)
	1178	else
	1179	! this code is necessary so that in the case that totalcldarea = 0.,
	1180	! that these variables, which are in-cloud averages, are set to missing
	1181	! note that totalcldarea will be 0. if all the clouds in the grid box have
	1182	! tau < isccp_taumin
	1183	meanptop(j) = output_missing_value
	1184	meanalbedocld(j) = output_missing_value
	1185	meantaucld(j) = output_missing_value
	1186	end if
	1187	enddo ! j
	1188	!
	1189	! ---------------------------------------------------!
	1190
	1191	! ---------------------------------------------------!
	1192	! OPTIONAL PRINTOUT OF DATA TO CHECK PROGRAM
	1193	!
	1194	if (debugcol.ne.0) then
	1195	!
	1196	do j=1,npoints,debugcol
	1197
	1198	!produce character output
	1199	do ilev=1,nlev
	1200	do ibox=1,ncol
	1201	acc(ilev,ibox)=0
	1202	enddo
	1203	enddo
	1204
	1205	do ilev=1,nlev
	1206	do ibox=1,ncol
	1207	acc(ilev,ibox)=frac_out(j,ibox,ilev)*2
	1208	if (levmatch(j,ibox) .eq. ilev)
	1209	& acc(ilev,ibox)=acc(ilev,ibox)+1
	1210	enddo
	1211	enddo
	1212
	1213	!print test
	1214
	1215	write(ftn09,11) j
	1216	11 format('ftn09.',i4.4)
	1217	open(9, FILE=ftn09, FORM='FORMATTED')
	1218
	1219	write(9,'(a1)') ' '
	1220	write(9,'(10i5)')
	1221	& (ilev,ilev=5,nlev,5)
	1222	write(9,'(a1)') ' '
	1223
	1224	do ibox=1,ncol
	1225	write(9,'(40(a1),1x,40(a1))')
	1226	& (cchar_realtops(acc(ilev,ibox)+1),ilev=1,nlev)
	1227	& ,(cchar(acc(ilev,ibox)+1),ilev=1,nlev)
	1228	end do
	1229	close(9)
	1230
	1231	if (ncolprint.ne.0) then
	1232	write(6,'(a1)') ' '
	1233	write(6,'(a2,1X,5(a7,1X),a50)')
	1234	& 'ilev',
	1235	& 'pfull','at',
	1236	& 'cc*100','dem_s','dtau_s',
	1237	& 'cchar'
	1238
	1239	! do 4012 ilev=1,nlev
	1240	! write(6,'(60i2)') (box(i,ilev),i=1,ncolprint)
	1241	! write(6,'(i2,1X,5(f7.2,1X),50(a1))')
	1242	! & ilev,
	1243	! & pfull(j,ilev)/100.,at(j,ilev),
	1244	! & cc(j,ilev)*100.0,dem_s(j,ilev),dtau_s(j,ilev)
	1245	! & ,(cchar(acc(ilev,ibox)+1),ibox=1,ncolprint)
	1246	!4012 continue
	1247	write (6,'(a)') 'skt(j):'
	1248	write (6,'(8f7.2)') skt(j)
	1249
	1250	write (6,'(8I7)') (ibox,ibox=1,ncolprint)
	1251
	1252	write (6,'(a)') 'tau:'
	1253	write (6,'(8f7.2)') (tau(j,ibox),ibox=1,ncolprint)
	1254
	1255	write (6,'(a)') 'tb:'
	1256	write (6,'(8f7.2)') (tb(j,ibox),ibox=1,ncolprint)
	1257
	1258	write (6,'(a)') 'ptop:'
	1259	write (6,'(8f7.2)') (ptop(j,ibox),ibox=1,ncolprint)
	1260	endif
	1261
	1262	enddo
	1263
	1264	end if
	1265
	1266	return
	1267	end
	1268
	1269

Note: See TracBrowser for help on using the repository browser.

Download in other formats:

Original Format