Context Navigation

← Previous Revision
Next Revision →
Normal
Revision Log

MISR_simulator.F90

Last change on this file was 5185, checked in by abarral, 10 days ago
Replace REPROBUS CPP KEY by logical using handmade wonky wrapper
File size: 13.0 KB

Rev	Line
[3491]	1	! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
	2	! Copyright (c) 2009, Roger Marchand, version 1.2
	3	! All rights reserved.
[5099]	4
[3491]	5	! Redistribution and use in source and binary forms, with or without modification, are
	6	! permitted provided that the following conditions are met:
[5099]	7
[3491]	8	! 1. Redistributions of source code must retain the above copyright notice, this list of
	9	! conditions and the following disclaimer.
[5099]	10
[3491]	11	! 2. Redistributions in binary form must reproduce the above copyright notice, this list
	12	! of conditions and the following disclaimer in the documentation and/or other
	13	! materials provided with the distribution.
[5099]	14
[3491]	15	! 3. Neither the name of the copyright holder nor the names of its contributors may be
	16	! used to endorse or promote products derived from this software without specific prior
	17	! written permission.
[5099]	18
[3491]	19	! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY
	20	! EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF
	21	! MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL
	22	! THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
	23	! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT
	24	! OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
	25	! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
	26	! LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
	27	! OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
[5099]	28
[3491]	29	! History
	30	! May 2015 - D. Swales - Modified for COSPv2.0
	31	! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
	32	MODULE MOD_MISR_SIMULATOR
	33	use cosp_kinds, only: wp
	34	use MOD_COSP_STATS, ONLY: hist2D
	35	use mod_cosp_config, ONLY: R_UNDEF,numMISRHgtBins,numMISRTauBins,misr_histHgt, &
	36	misr_histTau
	37	implicit none
	38
	39	! Parameters
	40	real(wp),parameter :: &
	41	misr_taumin = 0.3_wp, & ! Minimum optical depth for joint-histogram
	42	tauchk = -1.*log(0.9999999) ! Lower limit on optical depth
	43
	44	contains
	45
	46	! ######################################################################################
	47	! SUBROUTINE misr_subcolumn
	48	! ######################################################################################
	49	SUBROUTINE MISR_SUBCOLUMN(npoints,ncol,nlev,dtau,zfull,at,sunlit,tauOUT, &
	50	dist_model_layertops,box_MISR_ztop)
	51	! INPUTS
	52	INTEGER, intent(in) :: &
	53	npoints, & ! Number of horizontal gridpoints
	54	ncol, & ! Number of subcolumns
	55	nlev ! Number of vertical layers
	56	INTEGER, intent(in),dimension(npoints) :: &
	57	sunlit ! 1 for day points, 0 for night time
	58	REAL(WP),intent(in),dimension(npoints,ncol,nlev) :: &
	59	dtau ! Optical thickness
	60	REAL(WP),intent(in),dimension(npoints,nlev) :: &
	61	zfull, & ! Height of full model levels (i.e. midpoints), [nlev] is bottom
	62	at ! Temperature (K)
	63
	64	! OUTPUTS
	65	REAL(WP),intent(out),dimension(npoints,ncol) :: &
	66	box_MISR_ztop, & ! Cloud-top height in each column
	67	tauOUT ! Optical depth in each column
	68	REAL(WP),intent(out),dimension(npoints,numMISRHgtBins) :: &
	69	dist_model_layertops !
	70
	71	! INTERNAL VARIABLES
	72	INTEGER :: ilev,j,loop,ibox,thres_crossed_MISR
	73	INTEGER :: iMISR_ztop
	74	REAL(WP) :: cloud_dtau,MISR_penetration_height,ztest
	75
	76	! ############################################################################
	77	! Initialize
	78	box_MISR_ztop(1:npoints,1:ncol) = 0._wp
	79
[5158]	80	DO j=1,npoints
[3491]	81
	82	! Estimate distribution of Model layer tops
	83	dist_model_layertops(j,:)=0
[5158]	84	DO ilev=1,nlev
[3491]	85	! Define location of "layer top"
[5095]	86	if(ilev.eq.1 .or. ilev.eq.nlev) then
[3491]	87	ztest=zfull(j,ilev)
	88	else
	89	ztest=0.5_wp*(zfull(j,ilev)+zfull(j,ilev-1))
	90	endif
	91
	92	! Find MISR layer that contains this level
	93	! NOTE the first MISR level is "no height" level
	94	iMISR_ztop=2
[5158]	95	DO loop=2,numMISRHgtBins
[5095]	96	if ( ztest .gt. 1000*misr_histHgt(loop+1) ) then
[3491]	97	iMISR_ztop=loop+1
	98	endif
	99	enddo
	100
	101	dist_model_layertops(j,iMISR_ztop) = dist_model_layertops(j,iMISR_ztop)+1
	102	enddo
	103
	104	! For each GCM cell or horizontal model grid point
[5158]	105	DO ibox=1,ncol
[3491]	106	! Compute optical depth as a cummulative distribution in the vertical (nlev).
	107	tauOUT(j,ibox)=sum(dtau(j,ibox,1:nlev))
	108
	109	thres_crossed_MISR=0
[5158]	110	DO ilev=1,nlev
[3491]	111	! If there a cloud, start the counter and store this height
[5185]	112	if(thres_crossed_MISR .eq. 0 .AND. dtau(j,ibox,ilev) .gt. 0.) then
[3491]	113	! First encountered a "cloud"
	114	thres_crossed_MISR = 1
	115	cloud_dtau = 0
	116	endif
	117
[5185]	118	if( thres_crossed_MISR .lt. 99 .AND. thres_crossed_MISR .gt. 0 ) then
[5095]	119	if( dtau(j,ibox,ilev) .eq. 0.) then
[3491]	120	! We have come to the end of the current cloud layer without yet
	121	! selecting a CTH boundary. Restart cloud tau counter
	122	cloud_dtau=0
	123	else
	124	! Add current optical depth to count for the current cloud layer
	125	cloud_dtau=cloud_dtau+dtau(j,ibox,ilev)
	126	endif
	127
	128	! If the cloud is continuous but optically thin (< 1) from above the
	129	! current layer cloud top to the current level then MISR will like
	130	! see a top below the top of the current layer.
[5185]	131	if( dtau(j,ibox,ilev).gt.0 .AND. (cloud_dtau-dtau(j,ibox,ilev)) .lt. 1) then
[5095]	132	if(dtau(j,ibox,ilev) .lt. 1 .or. ilev.eq.1 .or. ilev.eq.nlev) then
[3491]	133	! MISR will likely penetrate to some point within this layer ... the middle
	134	MISR_penetration_height=zfull(j,ilev)
	135	else
	136	! Take the OD = 1.0 level into this layer
	137	MISR_penetration_height=0.5_wp*(zfull(j,ilev)+zfull(j,ilev-1)) - &
	138	0.5_wp*(zfull(j,ilev-1)-zfull(j,ilev+1))/dtau(j,ibox,ilev)
	139	endif
	140	box_MISR_ztop(j,ibox)=MISR_penetration_height
	141	endif
	142
	143	! Check for a distinctive water layer
[5185]	144	if(dtau(j,ibox,ilev) .gt. 1 .AND. at(j,ilev) .gt. 273 ) then
[3491]	145	! Must be a water cloud, take this as CTH level
	146	thres_crossed_MISR=99
	147	endif
	148
	149	! If the total column optical depth is "large" than MISR can't see
	150	! anything else. Set current point as CTH level
[5095]	151	if(sum(dtau(j,ibox,1:ilev)) .gt. 5) then
[3491]	152	thres_crossed_MISR=99
	153	endif
	154	endif
	155	enddo
	156
	157	! Check to see if there was a cloud for which we didn't
	158	! set a MISR cloud top boundary
[5095]	159	if( thres_crossed_MISR .eq. 1) then
[3491]	160	! If the cloud has a total optical depth of greater
	161	! than ~ 0.5 MISR will still likely pick up this cloud
	162	! with a height near the true cloud top
	163	! otherwise there should be no CTH
[5095]	164	if(sum(dtau(j,ibox,1:nlev)) .gt. 0.5) then
[3491]	165	! keep MISR detected CTH
[5095]	166	elseif(sum(dtau(j,ibox,1:nlev)) .gt. 0.2) then
[3491]	167	! MISR may detect but wont likley have a good height
	168	box_MISR_ztop(j,ibox)=-1
	169	else
	170	! MISR not likely to even detect.
	171	! so set as not cloudy
	172	box_MISR_ztop(j,ibox)=0
	173	endif
	174	endif
	175	enddo ! loop of subcolumns
	176
	177	enddo ! loop of gridpoints
	178
	179	! Modify MISR CTH for satellite spatial / pattern matcher effects
	180	! Code in this region added by roj 5/2006 to account
	181	! for spatial effect of the MISR pattern matcher.
	182	! Basically, if a column is found between two neighbors
	183	! at the same CTH, and that column has no hieght or
	184	! a lower CTH, THEN misr will tend to but place the
	185	! odd column at the same height as it neighbors.
	186
	187	! This setup assumes the columns represent a about a 1 to 4 km scale
	188	! it will need to be modified significantly, otherwise
[5158]	189	! ! DS2015: Add loop over gridpoints and index accordingly.
[3491]	190	! if(ncol.eq.1) then
	191	! ! Adjust based on neightboring points.
	192	! do j=2,npoints-1
[5185]	193	! if(box_MISR_ztop(j-1,1) .gt. 0 .AND. &
	194	! box_MISR_ztop(j+1,1) .gt. 0 .AND. &
	195	! abs(box_MISR_ztop(j-1,1)-box_MISR_ztop(j+1,1)) .lt. 500 .AND. &
[3491]	196	! box_MISR_ztop(j,1) .lt. box_MISR_ztop(j+1,1)) then
	197	! box_MISR_ztop(j,1) = box_MISR_ztop(j+1,1)
	198	! endif
	199	! enddo
	200	! else
	201	! ! Adjust based on neighboring subcolumns.
	202	! do j=1,npoints
	203	! do ibox=2,ncol-1
[5185]	204	! if(box_MISR_ztop(j,ibox-1) .gt. 0 .AND. &
	205	! box_MISR_ztop(j,ibox+1) .gt. 0 .AND. &
	206	! abs(box_MISR_ztop(j,ibox-1)-box_MISR_ztop(j,ibox+1)) .lt. 500 .AND. &
[3491]	207	! box_MISR_ztop(j,ibox) .lt. box_MISR_ztop(j,ibox+1)) then
	208	! box_MISR_ztop(j,ibox) = box_MISR_ztop(j,ibox+1)
	209	! endif
	210	! enddo
	211	! enddo
	212	! endif
	213	! ! DS2015 END
	214
	215	! Fill dark scenes
[5158]	216	DO j=1,numMISRHgtBins
[5095]	217	where(sunlit .ne. 1) dist_model_layertops(1:npoints,j) = R_UNDEF
[3491]	218	enddo
	219
[5159]	220	END SUBROUTINE MISR_SUBCOLUMN
[3491]	221
	222	! ######################################################################################
	223	! SUBROUTINE misr_column
	224	! ######################################################################################
	225	SUBROUTINE MISR_COLUMN(npoints,ncol,box_MISR_ztop,sunlit,tau,MISR_cldarea,MISR_mean_ztop,fq_MISR_TAU_v_CTH)
	226
	227	! INPUTS
	228	INTEGER, intent(in) :: &
	229	npoints, & ! Number of horizontal gridpoints
	230	ncol ! Number of subcolumns
	231	INTEGER, intent(in),dimension(npoints) :: &
	232	sunlit ! 1 for day points, 0 for night time
	233	REAL(WP),intent(in),dimension(npoints,ncol) :: &
	234	box_MISR_ztop, & ! Cloud-top height in each column
	235	tau ! Column optical thickness
	236
	237	! OUTPUTS
	238	REAL(WP),intent(inout),dimension(npoints) :: &
	239	MISR_cldarea, & ! Fraction area covered by clouds
	240	MISR_mean_ztop ! Mean cloud top height MISR would observe
	241	REAL(WP),intent(inout),dimension(npoints,7,numMISRHgtBins) :: &
	242	fq_MISR_TAU_v_CTH ! Joint histogram of cloud-cover and tau
	243
	244	! INTERNAL VARIABLES
	245	INTEGER :: j
	246	LOGICAL,dimension(ncol) :: box_cloudy
	247	real(wp),dimension(npoints,ncol) :: tauWRK,box_MISR_ztopWRK
	248	! ############################################################################
	249
	250	! Compute column quantities and joint-histogram
	251	MISR_cldarea(1:npoints) = 0._wp
	252	MISR_mean_ztop(1:npoints) = 0._wp
	253	fq_MISR_TAU_v_CTH(1:npoints,1:7,1:numMISRHgtBins) = 0._wp
	254	tauWRK(1:npoints,1:ncol) = tau(1:npoints,1:ncol)
	255	box_MISR_ztopWRK(1:npoints,1:ncol) = box_MISR_ztop(1:npoints,1:ncol)
[5158]	256	DO j=1,npoints
[3491]	257
	258	! Subcolumns that are cloudy(true) and not(false)
[5095]	259	box_cloudy(1:ncol) = merge(.true.,.false.,tau(j,1:ncol) .gt. tauchk)
[3491]	260
	261	! Fill optically thin clouds with fill value
	262	where(.not. box_cloudy(1:ncol)) tauWRK(j,1:ncol) = -999._wp
[5095]	263	where(box_MISR_ztopWRK(j,1:ncol) .eq. 0) box_MISR_ztopWRK(j,1:ncol)=-999._wp
[3491]	264
	265	! Compute joint histogram and column quantities for points that are sunlit and cloudy
[5095]	266	if (sunlit(j) .eq. 1) then
[3491]	267	! Joint histogram
	268	call hist2D(tauWRK(j,1:ncol),box_MISR_ztopWRK(j,1:ncol),ncol,misr_histTau,numMISRTauBins,&
	269	1000*misr_histHgt,numMISRHgtBins,fq_MISR_TAU_v_CTH(j,1:numMISRTauBins,1:numMISRHgtBins))
	270	fq_MISR_TAU_v_CTH(j,1:numMISRTauBins,1:numMISRHgtBins) = &
	271	100._wp*fq_MISR_TAU_v_CTH(j,1:numMISRTauBins,1:numMISRHgtBins)/ncol
	272
	273	! Column cloud area
[5095]	274	MISR_cldarea(j)=real(count(box_MISR_ztopWRK(j,1:ncol) .ne. -999.))/ncol
[3491]	275
	276	! Column cloud-top height
[5095]	277	if ( count(box_MISR_ztopWRK(j,1:ncol) .ne. -999.) .ne. 0 ) then
	278	MISR_mean_ztop(j) = sum(box_MISR_ztopWRK(j,1:ncol),box_MISR_ztopWRK(j,1:ncol) .ne. -999.)/ &
	279	count(box_MISR_ztopWRK(j,1:ncol) .ne. -999.)
[3491]	280	else
	281	MISR_mean_ztop(j) = R_UNDEF
	282	endif
	283
	284	else
	285	MISR_cldarea(j) = R_UNDEF
	286	MISR_mean_ztop(npoints) = R_UNDEF
	287	endif
	288	enddo
	289
[5159]	290	END SUBROUTINE MISR_COLUMN
[3491]	291
[5159]	292	END MODULE MOD_MISR_SIMULATOR

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

Download in other formats:

Original Format